guile18/lang/elisp/internals/lambda.scm

   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))