home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / lang / elisp / internals / lambda.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  3.6 KB  |  109 lines
  1. (define-module (lang elisp internals lambda)
  2.   #:use-module (lang elisp internals fset)
  3.   #:use-module (lang elisp transform)
  4.   #:export (parse-formals
  5.         transform-lambda/interactive
  6.         interactive-spec))
  7.  
  8. ;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
  9. ;;; returns three values: (i) list of symbols for required arguments,
  10. ;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
  11. ;;; #f if there is no rest argument.
  12. (define (parse-formals formals)
  13.   (letrec ((do-required
  14.         (lambda (required formals)
  15.           (if (null? formals)
  16.           (values (reverse required) '() #f)
  17.           (let ((next-sym (car formals)))
  18.             (cond ((not (symbol? next-sym))
  19.                (error "Bad formals (non-symbol in required list)"))
  20.               ((eq? next-sym '&optional)
  21.                (do-optional required '() (cdr formals)))
  22.               ((eq? next-sym '&rest)
  23.                (do-rest required '() (cdr formals)))
  24.               (else
  25.                (do-required (cons next-sym required)
  26.                     (cdr formals))))))))
  27.        (do-optional
  28.         (lambda (required optional formals)
  29.           (if (null? formals)
  30.           (values (reverse required) (reverse optional) #f)
  31.           (let ((next-sym (car formals)))
  32.             (cond ((not (symbol? next-sym))
  33.                (error "Bad formals (non-symbol in optional list)"))
  34.               ((eq? next-sym '&rest)
  35.                (do-rest required optional (cdr formals)))
  36.               (else
  37.                (do-optional required
  38.                     (cons next-sym optional)
  39.                     (cdr formals))))))))
  40.        (do-rest
  41.         (lambda (required optional formals)
  42.           (if (= (length formals) 1)
  43.           (let ((next-sym (car formals)))
  44.             (if (symbol? next-sym)
  45.             (values (reverse required) (reverse optional) next-sym)
  46.             (error "Bad formals (non-symbol rest formal)")))
  47.           (error "Bad formals (more than one rest formal)")))))
  48.  
  49.     (do-required '() (cond ((list? formals)
  50.                 formals)
  51.                ((symbol? formals)
  52.                 (list '&rest formals))
  53.                (else
  54.                 (error "Bad formals (not a list or a single symbol)"))))))
  55.  
  56. (define (transform-lambda exp)
  57.   (call-with-values (lambda () (parse-formals (cadr exp)))
  58.     (lambda (required optional rest)
  59.       (let ((num-required (length required))
  60.         (num-optional (length optional)))
  61.     `(,lambda %--args
  62.        (,let ((%--num-args (,length %--args)))
  63.          (,cond ((,< %--num-args ,num-required)
  64.              (,error "Wrong number of args (not enough required args)"))
  65.             ,@(if rest
  66.               '()
  67.               `(((,> %--num-args ,(+ num-required num-optional))
  68.                  (,error "Wrong number of args (too many args)"))))
  69.             (else
  70.              (, @bind ,(append (map (lambda (i)
  71.                           (list (list-ref required i)
  72.                             `(,list-ref %--args ,i)))
  73.                         (iota num-required))
  74.                        (map (lambda (i)
  75.                           (let ((i+nr (+ i num-required)))
  76.                         (list (list-ref optional i)
  77.                               `(,if (,> %--num-args ,i+nr)
  78.                                 (,list-ref %--args ,i+nr)
  79.                                 ,%nil))))
  80.                         (iota num-optional))
  81.                        (if rest
  82.                        (list (list rest
  83.                                `(,if (,> %--num-args
  84.                                  ,(+ num-required
  85.                                      num-optional))
  86.                                  (,list-tail %--args
  87.                                      ,(+ num-required
  88.                                          num-optional))
  89.                                  ,%nil)))
  90.                        '()))
  91.                   ,@(map transformer (cddr exp)))))))))))
  92.  
  93. (define (set-not-subr! proc boolean)
  94.   (set! (not-subr? proc) boolean))
  95.  
  96. (define (transform-lambda/interactive exp name)
  97.   (fluid-set! interactive-spec #f)
  98.   (let* ((x (transform-lambda exp))
  99.      (is (fluid-ref interactive-spec)))
  100.     `(,let ((%--lambda ,x))
  101.        (,set-procedure-property! %--lambda (,quote name) (,quote ,name))
  102.        (,set-not-subr! %--lambda #t)
  103.        ,@(if is
  104.          `((,set! (,interactive-specification %--lambda) (,quote ,is)))
  105.          '())
  106.        %--lambda)))
  107.  
  108. (define interactive-spec (make-fluid))
  109.