guile18/lang/elisp/primitives/syntax.scm

   1 (define-module (lang elisp primitives syntax)
   2   #:use-module (lang elisp internals evaluation)
   3   #:use-module (lang elisp internals fset)
   4   #:use-module (lang elisp internals lambda)
   5   #:use-module (lang elisp internals set)
   6   #:use-module (lang elisp internals trace)
   7   #:use-module (lang elisp transform))
   8
   9 ;;; Define Emacs Lisp special forms as macros.  This is more flexible
  10 ;;; than handling them specially in the translator: allows them to be
  11 ;;; redefined, and hopefully allows better source location tracking.
  12
  13 ;;; {Variables}
  14
  15 (define (setq exp env)
  16   (cons begin
  17         (let loop ((sets (cdr exp)))
  18           (if (null? sets)
  19               '()
  20               (cons `(,set (,quote ,(car sets)) ,(transformer (cadr sets)))
  21                     (loop (cddr sets)))))))
  22
  23 (fset 'setq
  24       (procedure->memoizing-macro setq))
  25
  26 (fset 'defvar
  27       (procedure->memoizing-macro
  28         (lambda (exp env)
  29           (trc 'defvar (cadr exp))
  30           (if (null? (cddr exp))
  31               `(,quote ,(cadr exp))
  32               `(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
  33                             ,(setq (list (car exp) (cadr exp) (caddr exp)) env))
  34                        (,quote ,(cadr exp)))))))
  35
  36 (fset 'defconst
  37       (procedure->memoizing-macro
  38         (lambda (exp env)
  39           (trc 'defconst (cadr exp))
  40           `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
  41                    (,quote ,(cadr exp))))))
  42
  43 ;;; {lambda, function and macro definitions}
  44
  45 (fset 'lambda
  46       (procedure->memoizing-macro
  47        (lambda (exp env)
  48          (transform-lambda/interactive exp '<elisp-lambda>))))
  49
  50 (fset 'defun
  51       (procedure->memoizing-macro
  52        (lambda (exp env)
  53          (trc 'defun (cadr exp))
  54          `(,begin (,fset (,quote ,(cadr exp))
  55                          ,(transform-lambda/interactive (cdr exp)
  56                                                         (symbol-append '<elisp-defun:
  57                                                                        (cadr exp)
  58                                                                        '>)))
  59                   (,quote ,(cadr exp))))))
  60
  61 (fset 'interactive
  62       (procedure->memoizing-macro
  63         (lambda (exp env)
  64           (fluid-set! interactive-spec exp)
  65           #f)))
  66
  67 (fset 'defmacro
  68       (procedure->memoizing-macro
  69        (lambda (exp env)
  70          (trc 'defmacro (cadr exp))
  71          (call-with-values (lambda () (parse-formals (caddr exp)))
  72            (lambda (required optional rest)
  73              (let ((num-required (length required))
  74                    (num-optional (length optional)))
  75                `(,begin (,fset (,quote ,(cadr exp))
  76                                (,procedure->memoizing-macro
  77                                 (,lambda (exp1 env1)
  78                                   (,trc (,quote using) (,quote ,(cadr exp)))
  79                                   (,let* ((%--args (,cdr exp1))
  80                                           (%--num-args (,length %--args)))
  81                                     (,cond ((,< %--num-args ,num-required)
  82                                             (,error "Wrong number of args (not enough required args)"))
  83                                            ,@(if rest
  84                                                  '()
  85                                                  `(((,> %--num-args ,(+ num-required num-optional))
  86                                                     (,error "Wrong number of args (too many args)"))))
  87                                            (else (,transformer
  88                                                   (, @bind ,(append (map (lambda (i)
  89                                                                            (list (list-ref required i)
  90                                                                                  `(,list-ref %--args ,i)))
  91                                                                          (iota num-required))
  92                                                                     (map (lambda (i)
  93                                                                            (let ((i+nr (+ i num-required)))
  94                                                                              (list (list-ref optional i)
  95                                                                                    `(,if (,> %--num-args ,i+nr)
  96                                                                                          (,list-ref %--args ,i+nr)
  97                                                                                          ,%nil))))
  98                                                                          (iota num-optional))
  99                                                                     (if rest
 100                                                                         (list (list rest
 101                                                                                     `(,if (,> %--num-args
 102                                                                                               ,(+ num-required
 103                                                                                                   num-optional))
 104                                                                                           (,list-tail %--args
 105                                                                                                       ,(+ num-required
 106                                                                                                           num-optional))
 107                                                                                           ,%nil)))
 108                                                                         '()))
 109                                                            ,@(map transformer (cdddr exp)))))))))))))))))
 110
 111 ;;; {Sequencing}
 112
 113 (fset 'progn
 114       (procedure->memoizing-macro
 115         (lambda (exp env)
 116           `(,begin ,@(map transformer (cdr exp))))))
 117
 118 (fset 'prog1
 119       (procedure->memoizing-macro
 120         (lambda (exp env)
 121           `(,let ((%--res1 ,(transformer (cadr exp))))
 122              ,@(map transformer (cddr exp))
 123              %--res1))))
 124
 125 (fset 'prog2
 126       (procedure->memoizing-macro
 127         (lambda (exp env)
 128           `(,begin ,(transformer (cadr exp))
 129                    (,let ((%--res2 ,(transformer (caddr exp))))
 130                      ,@(map transformer (cdddr exp))
 131                      %--res2)))))
 132
 133 ;;; {Conditionals}
 134
 135 (fset 'if
 136       (procedure->memoizing-macro
 137         (lambda (exp env)
 138           (let ((else-case (cdddr exp)))
 139             (cond ((null? else-case)
 140                    `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
 141                   ((null? (cdr else-case))
 142                    `(,nil-cond ,(transformer (cadr exp))
 143                                ,(transformer (caddr exp))
 144                                ,(transformer (car else-case))))
 145                   (else
 146                    `(,nil-cond ,(transformer (cadr exp))
 147                                ,(transformer (caddr exp))
 148                                (,begin ,@(map transformer else-case)))))))))
 149
 150 (fset 'and
 151       (procedure->memoizing-macro
 152         (lambda (exp env)
 153           (cond ((null? (cdr exp)) #t)
 154                 ((null? (cddr exp)) (transformer (cadr exp)))
 155                 (else
 156                  (cons nil-cond
 157                        (let loop ((args (cdr exp)))
 158                          (if (null? (cdr args))
 159                              (list (transformer (car args)))
 160                              (cons (list not (transformer (car args)))
 161                                    (cons %nil
 162                                          (loop (cdr args))))))))))))
 163
 164 ;;; NIL-COND expressions have the form:
 165 ;;;
 166 ;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
 167 ;;;
 168 ;;; The CONDs are evaluated in order until one of them returns true
 169 ;;; (in the Elisp sense, so not including empty lists).  If a COND
 170 ;;; returns true, its corresponding VAL is evaluated and returned,
 171 ;;; except if that VAL is the unspecified value, in which case the
 172 ;;; result of evaluating the COND is returned.  If none of the COND's
 173 ;;; returns true, ELSEVAL is evaluated and its value returned.
 174
 175 (define <-- *unspecified*)
 176
 177 (fset 'or
 178       (procedure->memoizing-macro
 179         (lambda (exp env)
 180           (cond ((null? (cdr exp)) %nil)
 181                 ((null? (cddr exp)) (transformer (cadr exp)))
 182                 (else
 183                  (cons nil-cond
 184                        (let loop ((args (cdr exp)))
 185                          (if (null? (cdr args))
 186                              (list (transformer (car args)))
 187                              (cons (transformer (car args))
 188                                    (cons <--
 189                                          (loop (cdr args))))))))))))
 190
 191 (fset 'cond
 192       (procedure->memoizing-macro
 193        (lambda (exp env)
 194          (if (null? (cdr exp))
 195              %nil
 196              (cons
 197               nil-cond
 198               (let loop ((clauses (cdr exp)))
 199                 (if (null? clauses)
 200                     (list %nil)
 201                     (let ((clause (car clauses)))
 202                       (if (eq? (car clause) #t)
 203                           (cond ((null? (cdr clause)) (list #t))
 204                                 ((null? (cddr clause))
 205                                  (list (transformer (cadr clause))))
 206                                 (else `((,begin ,@(map transformer (cdr clause))))))
 207                           (cons (transformer (car clause))
 208                                 (cons (cond ((null? (cdr clause)) <--)
 209                                             ((null? (cddr clause))
 210                                              (transformer (cadr clause)))
 211                                             (else
 212                                              `(,begin ,@(map transformer (cdr clause)))))
 213                                       (loop (cdr clauses)))))))))))))
 214
 215 (fset 'while
 216       (procedure->memoizing-macro
 217         (lambda (exp env)
 218           `((,letrec ((%--while (,lambda ()
 219                                   (,nil-cond ,(transformer (cadr exp))
 220                                              (,begin ,@(map transformer (cddr exp))
 221                                                      (%--while))
 222                                              ,%nil))))
 223               %--while)))))
 224
 225 ;;; {Local binding}
 226
 227 (fset 'let
 228       (procedure->memoizing-macro
 229         (lambda (exp env)
 230           `(, @bind ,(map (lambda (binding)
 231                             (trc 'let binding)
 232                             (if (pair? binding)
 233                                 `(,(car binding) ,(transformer (cadr binding)))
 234                                 `(,binding ,%nil)))
 235                           (cadr exp))
 236                     ,@(map transformer (cddr exp))))))
 237
 238 (fset 'let*
 239       (procedure->memoizing-macro
 240         (lambda (exp env)
 241           (if (null? (cadr exp))
 242               `(,begin ,@(map transformer (cddr exp)))
 243               (car (let loop ((bindings (cadr exp)))
 244                      (if (null? bindings)
 245                          (map transformer (cddr exp))
 246                          `((, @bind (,(let ((binding (car bindings)))
 247                                         (if (pair? binding)
 248                                             `(,(car binding) ,(transformer (cadr binding)))
 249                                             `(,binding ,%nil))))
 250                                     ,@(loop (cdr bindings)))))))))))
 251
 252 ;;; {Exception handling}
 253
 254 (fset 'unwind-protect
 255       (procedure->memoizing-macro
 256         (lambda (exp env)
 257           (trc 'unwind-protect (cadr exp))
 258           `(,let ((%--throw-args #f))
 259              (,catch #t
 260                (,lambda ()
 261                  ,(transformer (cadr exp)))
 262                (,lambda args
 263                  (,set! %--throw-args args)))
 264              ,@(map transformer (cddr exp))
 265              (,if %--throw-args
 266                   (,apply ,throw %--throw-args))))))