/[guile]/guile/guile-core/lang/elisp/primitives/syntax.scm
ViewVC logotype

Diff of /guile/guile-core/lang/elisp/primitives/syntax.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by ossau, Fri Feb 1 16:47:00 2002 UTC revision 1.3 by ossau, Mon Feb 4 21:13:46 2002 UTC
# Line 1  Line 1 
1  (define-module (lang elisp primitives syntax)  (define-module (lang elisp primitives syntax)
2    #:use-module (lang elisp internals evaluation)    #:use-module (lang elisp internals evaluation)
3    #:use-module (lang elisp internals fset)    #:use-module (lang elisp internals fset)
4      #:use-module (lang elisp internals lambda)
5    #:use-module (lang elisp internals trace)    #:use-module (lang elisp internals trace)
6    #:use-module (lang elisp transform))    #:use-module (lang elisp transform))
7    
8  ;;; Define Emacs Lisp special forms as macros.  This is much more  ;;; Define Emacs Lisp special forms as macros.  This is more flexible
9  ;;; flexible than handling them specially in the translator: allows  ;;; than handling them specially in the translator: allows them to be
10  ;;; them to be redefined, and hopefully allows better source location  ;;; redefined, and hopefully allows better source location tracking.
 ;;; tracking.  
11    
12  ;;; {Variables}  ;;; {Variables}
13    
# Line 44  Line 44 
44    
45  ;;; {lambda, function and macro definitions}  ;;; {lambda, function and macro definitions}
46    
 ;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and  
 ;;; returns three values: (i) list of symbols for required arguments,  
 ;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or  
 ;;; #f if there is no rest argument.  
 (define (parse-formals formals)  
   (letrec ((do-required  
             (lambda (required formals)  
               (if (null? formals)  
                   (values (reverse required) '() #f)  
                   (let ((next-sym (car formals)))  
                     (cond ((not (symbol? next-sym))  
                            (error "Bad formals (non-symbol in required list)"))  
                           ((eq? next-sym '&optional)  
                            (do-optional required '() (cdr formals)))  
                           ((eq? next-sym '&rest)  
                            (do-rest required '() (cdr formals)))  
                           (else  
                            (do-required (cons next-sym required)  
                                         (cdr formals))))))))  
            (do-optional  
             (lambda (required optional formals)  
               (if (null? formals)  
                   (values (reverse required) (reverse optional) #f)  
                   (let ((next-sym (car formals)))  
                     (cond ((not (symbol? next-sym))  
                            (error "Bad formals (non-symbol in optional list)"))  
                           ((eq? next-sym '&rest)  
                            (do-rest required optional (cdr formals)))  
                           (else  
                            (do-optional required  
                                         (cons next-sym optional)  
                                         (cdr formals))))))))  
            (do-rest  
             (lambda (required optional formals)  
               (if (= (length formals) 1)  
                   (let ((next-sym (car formals)))  
                     (if (symbol? next-sym)  
                         (values (reverse required) (reverse optional) next-sym)  
                         (error "Bad formals (non-symbol rest formal)")))  
                   (error "Bad formals (more than one rest formal)")))))  
   
     (do-required '() (cond ((list? formals)  
                             formals)  
                            ((symbol? formals)  
                             (list '&rest formals))  
                            (else  
                             (error "Bad formals (not a list or a single symbol)"))))))  
   
 (define (transform-lambda exp)  
   (call-with-values (lambda () (parse-formals (cadr exp)))  
     (lambda (required optional rest)  
       (let ((num-required (length required))  
             (num-optional (length optional)))  
         `(,lambda %--args  
            (,let ((%--num-args (,length %--args)))  
              (,cond ((,< %--num-args ,num-required)  
                      (,error "Wrong number of args (not enough required args)"))  
                     ,@(if rest  
                           '()  
                           `(((,> %--num-args ,(+ num-required num-optional))  
                              (,error "Wrong number of args (too many args)"))))  
                     (else  
                      (@bind ,(append (map (lambda (i)  
                                             (list (list-ref required i)  
                                                   `(,list-ref %--args ,i)))  
                                           (iota num-required))  
                                      (map (lambda (i)  
                                             (let ((i+nr (+ i num-required)))  
                                               (list (list-ref optional i)  
                                                     `(,if (,> %--num-args ,i+nr)  
                                                           (,list-ref %--args ,i+nr)  
                                                           #f))))  
                                           (iota num-optional))  
                                      (if rest  
                                          (list (list rest  
                                                      `(,if (,> %--num-args  
                                                                ,(+ num-required  
                                                                    num-optional))  
                                                            (,list-tail %--args  
                                                                        ,(+ num-required  
                                                                            num-optional))  
                                                            '())))  
                                          '()))  
                             ,@(map transformer (cddr exp)))))))))))  
   
 (define interactive-spec (make-fluid))  
   
 (define (set-not-subr! proc boolean)  
   (set! (not-subr? proc) boolean))  
   
 (define (transform-lambda/interactive exp name)  
   (fluid-set! interactive-spec #f)  
   (let* ((x (transform-lambda exp))  
          (is (fluid-ref interactive-spec)))  
     `(,let ((%--lambda ,x))  
        (,set-procedure-property! %--lambda (,quote name) (,quote ,name))  
        (,set-not-subr! %--lambda #t)  
        ,@(if is  
              `((,set! (,interactive-spec %--lambda) (,quote ,is)))  
              '())  
        %--lambda)))  
   
47  (fset 'lambda  (fset 'lambda
48        (procedure->memoizing-macro        (procedure->memoizing-macro
49         (lambda (exp env)         (lambda (exp env)

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26