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
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)
14 (lambda (required 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)))
25 (do-required (cons next-sym required)
28 (lambda (required optional 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)))
38 (cons next-sym optional)
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)")))))
49 (do-required '() (cond ((list? formals)
52 (list '&rest formals))
54 (error "Bad formals (not a list or a single symbol)"))))))
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)))
62 (,let ((%--num-args (,length %--args)))
63 (,cond ((,< %--num-args ,num-required)
64 (,error "Wrong number of args (not enough required args)"))
67 `(((,> %--num-args ,(+ num-required num-optional))
68 (,error "Wrong number of args (too many args)"))))
70 (, @bind ,(append (map (lambda (i)
71 (list (list-ref required i)
72 `(,list-ref %--args ,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)
91 ,@(map transformer (cddr exp)))))))))))
93 (define (set-not-subr! proc boolean)
94 (set! (not-subr? proc) boolean))
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)
104 `((,set! (,interactive-specification %--lambda) (,quote ,is)))
108 (define interactive-spec (make-fluid))