src/lsp/common3.lsp

   1 ;;;;
   2 ;;;; Additional Common Lisp Functions for XLISP-STAT 2.0
   3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990-95, by Luke Tierney
   4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   5 ;;;; You may give out copies of this software; for conditions see the file
   6 ;;;; COPYING included with this distribution.
   7 ;;;;
   8
   9 (in-package "XLISP")
  10
  11 ;;;;;;
  12 ;;;;;;         Environment Access and Modification Routines
  13 ;;;;;;
  14
  15 (defvar *cmp-global-macros* nil)
  16 (defvar *cmp-macros*)
  17 (defvar *cmp-specials*)
  18
  19 (export '(ftype ignorable ignore inline notinline))
  20
  21
  22 ;;;;
  23 ;;;; PARSE-MACRO and ENCLOSE
  24 ;;;;
  25
  26 (export '(enclose parse-macro))
  27
  28 (defun split-declarations (x)
  29   (flet ((head-is-declaration (x)
  30            (and (consp (first x)) (eq (first (first x)) 'declare)))
  31          (head-is-docstring (x) (and (stringp (first x)) (consp (rest x))))
  32          (check-declarations (decls)
  33            (dolist (d decls)
  34              (dolist (i (rest d))
  35                (if (and (consp i) (eq (first i) 'special))
  36                    (dolist (v (rest i))
  37                      (warn "special declaration for ~s ignored." v)))))))
  38     (do ((decls nil)
  39          (body x (rest body))
  40          (doc nil))
  41         (nil)
  42         (cond
  43          ((head-is-declaration body) (push (first body) decls))
  44          ((head-is-docstring body) (setf doc (first body)))
  45          (t (check-declarations decls)
  46             (return (list (nreverse decls) body doc)))))))
  47
  48 ;; This returns a lambda expression consistent with the CLtL2
  49 ;; specification of macro expansion functions as functions of two
  50 ;; arguments, the form to be expanded and the environment to use. The
  51 ;; internal calling conventions and construction of macro closures has
  52 ;; been modified accordingly.  This definition does not do the right
  53 ;; thing with declarations at this point.
  54 (defun make-macro-lambda-expression (name lambda-list body)
  55   (flet ((fixup-macro-args (args)
  56            (let ((esym nil)
  57                  (wsym nil))
  58              (setf args (copy-list args))
  59              (let ((last (last args)))
  60                (unless (null (cdr last))
  61                        (rplacd last (list '&rest (cdr last)))))
  62              (setf args (nsubst '&rest '&body args))
  63              (when (find '&environment args)
  64                    (setf esym (second (member '&environment args)))
  65                    (setf args (remove esym (remove '&environment args))))
  66              (cond
  67               ((eq (first args) '&whole)
  68                (setf wsym (second args))
  69                (setf args (rest (rest args))))
  70               (t (setf wsym (gensym "WHOLE"))))
  71              (cons esym (cons wsym args))))
  72          (destructuring-arglist-p (x)
  73            (consp
  74             (find-if #'(lambda (x)
  75                          (or (member x lambda-list-keywords) (consp x)))
  76                      x))))
  77     (let* ((args (fixup-macro-args lambda-list))
  78            (bd (split-declarations body))
  79            (body `(,@(first bd) (block ,name ,@(second bd))))
  80            (doc (third bd))
  81            (wsym (second args))
  82            (esym (first args))
  83            (edecl nil)
  84            (llist (rest (rest args))))
  85       (unless esym
  86               (setf esym (gensym "ENV"))
  87               (setf edecl `((declare (ignore ,esym)))))
  88       (values
  89        `(lambda (,wsym ,esym)
  90           ,@edecl
  91           ,(if (destructuring-arglist-p args)
  92                `(destructuring-bind ,llist (rest ,wsym) ,@body)
  93                `(apply #'(lambda ,llist ,@body) (rest ,wsym))))
  94        doc))))
  95
  96
  97 ;; This implementation produces an interpreted function
  98 (defun enclose (expr &optional env) (evalhook expr nil nil env))
  99
 100 (defun parse-macro (name lambda-list body  &optional env)
 101   (enclose (make-macro-lambda-expression name lambda-list body) env))
 102
 103
 104 ;;;;
 105 ;;;; DEFINE-COMPILER-MACRO
 106 ;;;;
 107 ;;;; Fake version to be overridded if the compiler is loaded
 108
 109 (export 'define-compiler-macro)
 110
 111 (defmacro set-cmp-macro (symarg funarg)
 112   `(let* ((sym ,symarg)
 113           (fun ,funarg)
 114           (entry (assoc sym *cmp-global-macros*)))
 115      (if entry
 116          (rplacd entry fun)
 117          (push (cons sym fun) *cmp-global-macros*))
 118      sym))
 119
 120 (defmacro define-compiler-macro (sym args &rest body)
 121   (let ((fexpr (make-macro-lambda-expression sym args body)))
 122     `(progn
 123        (set-cmp-macro ',sym (coerce-to-macro #',fexpr))
 124        ',sym)))
 125
 126 (defmacro define-special-form-macro (sym args &rest body)
 127   (let ((fexpr (make-macro-lambda-expression sym args body)))
 128     `(progn
 129        (%set-get ',sym 'macro (coerce-to-macro #',fexpr))
 130        ',sym)))
 131
 132
 133 ;;;;
 134 ;;;; AUGMENT-ENVIRONMENT, VARIABLE-INFORMATION, and FUNCTION-INFORMATION
 135 ;;;;
 136
 137 (export '(augment-environment variable-information function-information))
 138
 139 ;; Environments are of the form (venv . fenv). Each of venv and fenv
 140 ;; is a list of frames, and frames are lists of bindings. Bindings are
 141 ;; pairs (name . value).  If the value in a variable binding is
 142 ;; :symbol-macro and the next pair has name :symbol-macro, then the
 143 ;; value of the second of these bindings represente the symbol macro
 144 ;; expansion of the symbol in the first binding.
 145
 146 (defun special-variable-p (sym)
 147   (or (specialp sym)
 148       (and (boundp '*cmp-specials*) (member sym *cmp-specials*))))
 149
 150 (defun augment-environment (env &key
 151                                 variable symbol-macro function macro declare)
 152   (declare (ignore declare))
 153   (when (intersection variable (mapcar #'first symbol-macro))
 154         (error "adding some symbols as variables and as symbol macros"))
 155   (when (intersection function (mapcar #'first macro))
 156         (error "adding some symbols as functions and macros"))
 157   (dolist (v variable)
 158     (when (special-variable-p v)
 159           (error "cant't make lexical binding for the special variable ~s" v)))
 160   (dolist (sm symbol-macro)
 161     (let ((v (first sm)))
 162       (when (special-variable-p v)
 163             (error "cant't make lexical binding for the special variable ~s"
 164                    v))))
 165   (flet ((add-variable-frame (frame env)
 166            (if frame (cons (cons frame (car env)) (cdr env)) env))
 167          (add-function-frame (frame env)
 168            (if frame (cons (car env) (cons frame (cdr env))) env))
 169          (make-variable-frame (vars) (mapcar #'list vars))
 170          (make-function-frame (funs) (mapcar #'list funs))
 171          (make-macro-frame (macs)
 172            (mapcar #'(lambda (x) (cons (first x) (coerce-to-macro (second x))))
 173                    macs))
 174          (make-symbol-macro-frame (smacs)
 175            (let ((frame nil))
 176              (dolist (s smacs)
 177                (push (cons :symbol-macro (second s)) frame)
 178                (push (cons (first s) :symbol-macro) frame))
 179              frame)))
 180     (setf env (add-variable-frame (make-variable-frame variable) env))
 181     (setf env (add-variable-frame (make-symbol-macro-frame symbol-macro) env))
 182     (setf env (add-function-frame (make-function-frame function) env))
 183     (setf env (add-function-frame (make-macro-frame macro) env))
 184     env))
 185
 186 (defun get-environment-entry (name env)
 187   (dolist (frame env)
 188     (let ((m (member name frame :key #'car)))
 189       (when m
 190             (if (and (eq (cdr (first m)) :symbol-macro)
 191                      (eq (car (second m)) :symbol-macro))
 192                 (return (values t :symbol-macro (second m) frame))
 193               (return (values t (cdr (first m)) nil frame)))))))
 194
 195 (defun global-symbol-macro (sym)
 196   (if (or (boundp sym) (special-variable-p sym))
 197       (values nil nil)
 198     (let ((m (member :symbol-macro (symbol-plist sym))))
 199       (if m
 200           (values (second m) t)
 201         (values nil nil)))))
 202
 203 ;;**** this needs fixing once special declarations are supported
 204 (defun variable-information (sym &optional env)
 205   (multiple-value-bind (found value extra)
 206                        (get-environment-entry sym (first env))
 207     (cond
 208      (found
 209       (if (and found (eq value :symbol-macro) (eq (car extra) :symbol-macro))
 210           (values :symbol-macro t nil)
 211         (values :lexical t nil)))
 212      ((constantp sym) (values :constant nil nil))
 213      ((special-variable-p sym) (values :special nil nil))
 214      ((nth-value 1 (global-symbol-macro sym))
 215       (values :symbol-macro nil nil))
 216      (t (values nil nil nil)))))
 217
 218 ;;**** needs to be fixed for special forms
 219 ;;**** needs to be fixed for C-compiler macroe is they ever materialize
 220 (defun function-information (sym &optional env)
 221   (flet ((macrop (f)
 222            (and (or (typep f 'byte-code-closure) (typep f 'closure))
 223                 (not (functionp f))))
 224          (global-frame-p (f)
 225            (or (eq f *cmp-global-macros*)
 226                (and (boundp '*cmp-macros*)
 227                     (eq f *cmp-macros*)))))
 228     (multiple-value-bind (found value extra frame)
 229                          (get-environment-entry sym (rest env))
 230      (declare (ignore extra))
 231      (cond
 232       ((and found (macrop value))
 233        (values :macro (not (global-frame-p frame)) nil))
 234       (found (values :function t nil))
 235       ((and (fboundp sym) (macrop (symbol-function sym)))
 236        (values :macro nil nil))
 237       ((and (fboundp sym) (typep (symbol-function sym) 'fsubr))
 238        (values :special-form nil nil))
 239       ((and (fboundp sym) (functionp (symbol-function sym)))
 240        (values :function nil nil))
 241       (t (values nil nil nil))))))
 242
 243
 244 ;;;;
 245 ;;;; New versions of MACROEXPAND and MACROEXPAND-1 that handle symbol macros
 246 ;;;;
 247
 248 (export '(macroexpand macroexpand-1))
 249
 250 ;; This function copies symbol macro forms to protect them from
 251 ;; splicing that occurs if *displace-macros* in non-nil.
 252 (defun macroexpand-symbol-1 (symbol &optional env)
 253   (unless (symbolp symbol) (error "not a symbol - ~s" symbol))
 254   (multiple-value-bind (found value extra)
 255                        (get-environment-entry symbol (first env))
 256     (if (and found (eq value :symbol-macro) (eq (car extra) :symbol-macro))
 257       (let ((form (cdr extra)))
 258         (values (if (consp form) (copy-tree form) form) t))
 259      (multiple-value-bind (form found)
 260                           (global-symbol-macro symbol)
 261        (if found
 262            (values (if (consp form) (copy-tree form) form) t)
 263          (values symbol nil))))))
 264
 265 (eval-when (:compile-toplevel :load-toplevel :execute)
 266            (unless (fboundp 'base-macroexpand-1)
 267                    (setf (symbol-function 'base-macroexpand-1)
 268                          #'macroexpand-1)))
 269
 270 ;; new version that expands symbol macros
 271 (defun macroexpand-1 (form &optional env)
 272   (if (symbolp form)
 273       (macroexpand-symbol-1 form env)
 274       (base-macroexpand-1 form env)))
 275
 276 ;; new version that expands symbol macros
 277 (defun macroexpand (form &optional env)
 278   (multiple-value-bind
 279    (form expanded)
 280    (macroexpand-1 form env)
 281    (if expanded
 282        (loop
 283         (multiple-value-bind
 284          (newform expanded)
 285          (macroexpand-1 form env)
 286          (unless expanded (return (values newform t)))
 287          (setf form newform)))
 288        (values form nil))))
 289
 290
 291 ;;;;
 292 ;;;; DEFINE-SYMBOL-MACRO
 293 ;;;;
 294
 295 (export 'define-symbol-macro)
 296
 297 (defmacro define-symbol-macro (name form)
 298   `(eval-when (:compile-toplevel :load-toplevel :execute)
 299               (when (or (special-variable-p ',name) (boundp ',name))
 300                     (error "can't assign symbol macro to ~s" ',name))
 301               (setf (get ',name :symbol-macro) ',form)
 302               ',name))
 303
 304
 305 ;;;;;
 306 ;;;;;                   New Setf Macro Expansion System
 307 ;;;;;
 308
 309 (export '(get-setf-method setf))
 310
 311 (defun get-cmp-setf-info (sym &optional env)
 312   (declare (ignore env))
 313   (if (boundp '*cmp-setf*) (assoc sym *cmp-setf*)))
 314
 315 (defun get-cmp-setf-method (sym &optional env)
 316   (let ((cmpsetf (get-cmp-setf-info sym env)))
 317     (if (and cmpsetf (eq (second cmpsetf) '*setf*)) (third cmpsetf))))
 318
 319 (defun get-cmp-setf-lambda (sym &optional env)
 320   (let ((cmpsetf (get-cmp-setf-info sym env)))
 321     (if (and cmpsetf (eq (second cmpsetf) '*setf-lambda*)) (third cmpsetf))))
 322
 323 (defun get-xlisp-setf-method (sym &optional env)
 324   (declare (ignore env))
 325   (get sym '*setf*))
 326
 327 (defun get-xlisp-setf-lambda (sym &optional env)
 328   (declare (ignore env))
 329   (get sym '*setf-lambda*))
 330
 331 ;; This function checks for defsetf expanders before doing macro expansion,
 332 ;; so one can defsetf a macro. This seems to be what many implementations
 333 ;; do, but I'm not sure it is consistent with CLtL2.
 334 (defun get-setf-method (form &optional env)
 335   (loop
 336    (cond
 337     ((consp form)
 338      (let* ((sym (first form))
 339             (is-global (not (nth-value 1 (function-information sym env))))
 340             (cmpsfun (get-cmp-setf-method sym env))
 341             (cmpslam (get-cmp-setf-lambda sym env))
 342             (sxfun (get-xlisp-setf-method sym env))
 343             (sxlam (get-xlisp-setf-lambda sym env)))
 344        (when (and (or cmpsfun cmpslam sxfun sxlam) is-global)
 345              (let* ((args (rest form))
 346                     (tvars (mapcar #'(lambda (x) (gensym "T")) args))
 347                     (vvars (list (gensym "V")))
 348                     (aform `(,sym ,@tvars)))
 349                (return
 350                 (values tvars
 351                         args
 352                         vvars
 353                         (cond
 354                          (cmpsfun `(,cmpsfun ,@tvars ,@vvars))
 355                          (cmpslam (apply cmpslam (append tvars vvars)))
 356                          ((and sxfun (symbolp sxfun))
 357                           `(,sxfun ,@tvars ,@vvars))
 358                          (sxfun
 359                           `(funcall (get ',sym '*setf*) ,@tvars ,@vvars))
 360                          (sxlam (apply sxlam (append tvars vvars))))
 361                         aform))))
 362        (when (and (eq sym 'apply) is-global)
 363              (return (get-apply-setf-method form env)))
 364        (multiple-value-bind (newform changed) (macroexpand-1 form env)
 365          (unless changed (error "bad place form - ~s" form))
 366          (setf form newform))))
 367     ((symbolp form)
 368      (multiple-value-bind (newform changed) (macroexpand-1 form env)
 369        (cond
 370         (changed (setf form newform))
 371         (t
 372          (let ((sym (gensym (string form))))
 373            (return (values nil nil `(,sym) `(setq ,newform ,sym) newform)))))))
 374     (t (error "bad place form - ~s" form)))))
 375
 376 ;; The implementation here seems consistent with AKCL and common
 377 ;; sense, but not with CLtL. The specification in CLtL would not work
 378 ;; for things with setf methods defined by the simple form of defsetf
 379 (defun get-apply-setf-method (form &optional env)
 380   (declare (ignore env))
 381   (let ((fun (second form)))
 382     (unless (and (consp fun)
 383                  (eq (first fun) 'function)
 384                  (symbolp (second fun))
 385                  (null (rest (rest fun))))
 386             (error "bad place form - ~s" form)))
 387   (multiple-value-bind
 388    (tvars tvals vvars sform aform)
 389    (get-setf-method `(,(second (second form)) ,@(rest (rest form))))
 390    (cond
 391     ((equal (last tvars) (last sform)) ;; simple case as described in CLtL
 392      (values tvars
 393              tvals
 394              vvars
 395              `(apply #',(first sform) ,@(rest sform))
 396              `(apply #',(first aform) ,@(rest aform))))
 397     ((equal (last tvars) (last (butlast sform))) ;; covers simple defsetf's
 398      (values tvars
 399              tvals
 400              vvars
 401              (let* ((lv (first (last sform)))
 402                     (bl (butlast sform))
 403                     (rv (first (last bl))))
 404                `(apply #',(first sform)
 405                        ,@(butlast (rest bl))
 406                        (append ,rv (list ,lv))))
 407              `(apply #',(first aform) ,@(rest aform))))
 408     (t (error "bad place form - ~s" form)))))
 409
 410
 411 ;; The special variable *simplify-setf* controls the tradeoff of speed
 412 ;; and correctness used by make-setf-form in expanding setf forms. If
 413 ;; this variable is nil, then make-setf-form is careful about avoiding
 414 ;; multiple evaluation and doing evaluations in the proper order.  If
 415 ;; *simplify-setf* is not nil, then subforms of place forms and the
 416 ;; value form are not protect against multiple evaluation occurring in
 417 ;; setf expansions. This is consistent with the internal
 418 ;; implementation. It should not be a problem for any f the standard
 419 ;; setf methods. The compiler should be able to optimize out all
 420 ;; unnecessary variables the careful version setsup, so the compiler
 421 ;; should probably bind this variable to nil.
 422
 423 (export '*simplify-setf*)
 424
 425 (defvar *simplify-setf* nil)
 426
 427 (defun make-setf-form (form value &optional env)
 428   (multiple-value-bind (tvars args vvars sform)
 429                        (get-setf-method form env)
 430     (let ((vars (append tvars vvars))
 431           (vals (append args (list value))))
 432       (if *simplify-setf*
 433           (sublis (mapcar #'cons vars vals) sform)
 434         `(let* ,(mapcar #'list vars vals) ,sform)))))
 435
 436 (defmacro setf (&rest pairs &environment env)
 437   (let ((forms nil))
 438     (loop
 439      (when (null pairs)
 440            (return (if (consp (rest forms))
 441                        `(progn ,@(nreverse forms))
 442                        (first forms))))
 443      (unless (consp (rest pairs))
 444              (error "setf requires an even number of arguments"))
 445      ;; need to use setq here to avoid infinite recursion
 446      (setq forms
 447            (cons (make-setf-form (first pairs) (second pairs) env) forms))
 448      (setq pairs (rest (rest pairs))))))
 449
 450 ;;;;;;
 451 ;;;;;; New versions of Some Modifier Macros
 452 ;;;;;;
 453 ;;;;;; These versions (except rotatef) attempt to optimize simple
 454 ;;;;;; symbol place forms with so symbol macro bindings.
 455
 456 (export '(incf decf push pop pushnew remf rotatef))
 457
 458 ;; this checks if place is a symbol with no macro definition in env
 459 (defun non-macro-variable-symbol-p (place env)
 460   (and (symbolp place)
 461        (not (eq :symbol-macro (variable-information place env)))))
 462
 463 (defmacro incf (place &optional (delta 1) &environment env)
 464   (if (non-macro-variable-symbol-p place env)
 465       `(setf ,place (+ ,place ,delta))
 466       (multiple-value-bind
 467        (tvars args vvars sform aform)
 468        (get-setf-method place env)
 469        (let ((vars (append tvars vvars))
 470              (vals (append args (list `(+ ,aform ,delta)))))
 471          `(let* ,(mapcar #'list vars vals) ,sform)))))
 472
 473 (defmacro decf (place &optional (delta 1) &environment env)
 474   (if (non-macro-variable-symbol-p place env)
 475       `(setf ,place (- ,place ,delta))
 476       (multiple-value-bind
 477        (tvars args vvars sform aform)
 478        (get-setf-method place env)
 479        (let ((vars (append tvars vvars))
 480              (vals (append args (list `(- ,aform ,delta)))))
 481          `(let* ,(mapcar #'list vars vals) ,sform)))))
 482
 483 (defmacro push (val place &environment env)
 484   (if (non-macro-variable-symbol-p place env)
 485       `(setq ,place (cons ,val ,place))
 486       (multiple-value-bind
 487        (tvars args vvars sform aform)
 488        (get-setf-method place env)
 489        (let ((vars (append tvars vvars))
 490              (vals (append args (list `(cons ,val ,aform)))))
 491          `(let* ,(mapcar #'list vars vals) ,sform)))))
 492
 493 (defmacro pop (place &environment env)
 494   (if (non-macro-variable-symbol-p place env)
 495       `(prog1 (first ,place) (setq ,place (rest ,place)))
 496       (multiple-value-bind
 497        (tvars args vvars sform aform)
 498        (get-setf-method place env)
 499        (let ((vars (append tvars vvars))
 500              (vals (append args (list `(rest ,aform)))))
 501          `(let* ,(mapcar #'list vars vals)
 502             (prog1 (first ,aform) ,sform))))))
 503
 504 (defmacro pushnew (val place &rest rest &environment env)
 505   (if (non-macro-variable-symbol-p place env)
 506       `(setq ,place (adjoin ,val ,place ,@rest))
 507       (multiple-value-bind
 508        (tvars args vvars sform aform)
 509        (get-setf-method place env)
 510        (let ((vars (append tvars vvars))
 511              (vals (append args (list `(adjoin ,val ,aform ,@rest)))))
 512          `(let* ,(mapcar #'list vars vals) ,sform)))))
 513
 514 (defun rem-f (list y)
 515   (do* ((last nil x)
 516         (x list (cdr x)))
 517        ((null x) (values list nil))
 518        (when (eq y (first x))
 519              (cond
 520               (last
 521                (rplacd last (cddr x))
 522                (return (values list t)))
 523               (t (return (values (cddr list) t)))))))
 524
 525 (defmacro remf (place indicator &environment env)
 526   (if (non-macro-variable-symbol-p place env)
 527       `(setq ,place (rem-f ,place ,indicator))
 528       (multiple-value-bind
 529        (tvars args vvars sform aform)
 530        (get-setf-method place env)
 531        (let ((vars (append tvars vvars))
 532              (vals (append args (list `(rem-f ,aform ,indicator)))))
 533          `(let* ,(mapcar #'list vars vals) ,sform)))))
 534
 535 ;; This version does not optimize out the case where some places are
 536 ;; symbols, but it is not the most used macro in the world, and the
 537 ;; compiler should take care of these optimizations anyway.
 538 (defmacro rotatef (&rest places &environment env)
 539   (let* ((smethods (mapcar #'(lambda (x)
 540                                (multiple-value-list (get-setf-method x env)))
 541                            places))
 542          (tvars (apply #'append (mapcar #'first smethods)))
 543          (args (apply #'append (mapcar #'second smethods)))
 544          (vvars (apply #'append (mapcar #'third smethods)))
 545          (sforms (mapcar #'fourth smethods))
 546          (aforms (mapcar #'fifth smethods))
 547          (rotaforms (append (rest aforms) (list (first aforms))))
 548          (vars (append tvars vvars))
 549          (vals (append args rotaforms)))
 550     `(let* ,(mapcar #'list vars vals) ,@sforms nil)))
 551
 552
 553 ;;;;;;
 554 ;;;;;; Replacements for Some Internal Special Forms
 555 ;;;;;;
 556
 557 (export '(psetq psetf))
 558
 559 ;;;;
 560 ;;;; Replacements for internal PSETQ and PSETF
 561 ;;;;
 562
 563 (defun expand-pset-form (name pairs)
 564   (let ((gsyms nil)
 565         (syms nil)
 566         (vals nil))
 567     (loop
 568      (if (null pairs) (return))
 569      (push (gensym) gsyms)
 570      (push (first pairs) syms)
 571      (push (second pairs) vals)
 572      (setf pairs (rest (rest pairs))))
 573     (setf gsyms (reverse gsyms))
 574     (setf syms (reverse syms))
 575     (setf vals (reverse vals))
 576     (let ((bds (mapcar #'list gsyms vals))
 577           (vsets (mapcar #'(lambda (x y) `(,name ,x ,y)) syms gsyms)))
 578       `(let* ,bds ,@vsets nil))))
 579
 580 (defmacro psetq (&rest pairs) (expand-pset-form 'setq pairs))
 581 (defmacro psetf (&rest pairs) (expand-pset-form 'setf pairs))
 582
 583
 584 ;;;;;;
 585 ;;;;;;               Macro Definitions for Special Forms
 586 ;;;;;;
 587 ;;;;;;
 588 ;;;;;; There is one non-standard special forms, ERRSET. In addition,
 589 ;;;;;; the compiler treats CASE and NTH-VALUE as special forms. Code
 590 ;;;;;; walkers will need to handle these three cases separately.
 591 ;;;;;; ERRSET cannot be macroexpanded, and providing macro definitions
 592 ;;;;;; for NTH-VALUE and CASE would result in poor compiled
 593 ;;;;;; code. Perhaps they should CASE and NTH-VALUE should be handled
 594 ;;;;;; with compiler macros.
 595
 596 ;;;;
 597 ;;;; DEFUN and DEFMACRO
 598 ;;;;
 599
 600 (define-special-form-macro defun (f args &rest body)
 601   (let* ((db (split-declarations body))
 602          (decls (first db))
 603          (b (second db))
 604          (doc (third db))
 605          (fexpr `#'(lambda ,args ,@decls (block ,f ,@b))))
 606     `(progn
 607        ,@(if doc `((%set-get ',f 'function-documentation ,doc)))
 608        (install-function ',f ,fexpr))))
 609
 610 (define-special-form-macro defmacro (f args &rest body)
 611   (multiple-value-bind (fexpr doc)
 612                        (make-macro-lambda-expression f args body)
 613     `(progn
 614        (eval-when (:compile-toplevel)
 615                   (push (cons ',f (coerce-to-macro ,fexpr)) *cmp-macros*))
 616        ,@(if doc `((%set-get ',f 'function-documentation ,doc)))
 617        (install-function ',f (coerce-to-macro ,fexpr)))))
 618
 619
 620 ;;;;
 621 ;;;; DEFMETH and DEFPROTO
 622 ;;;;
 623
 624 #+xlisp-stat
 625 (define-special-form-macro defmeth (ob sym args &rest body)
 626   (let* ((db (split-declarations body))
 627          (decls (first db))
 628          (b (second db))
 629          (doc (third db))
 630          (fexpr `#'(lambda ,(cons 'self args) ,@decls (block ,sym ,@b))))
 631     `(progn
 632        (xlisp::add-method ,ob ',sym ,fexpr ,doc)
 633        ',sym)))
 634
 635 #+xlisp-stat
 636 (define-special-form-macro defproto (name &optional ivars cvars parents doc)
 637   (let ((pp (gensym))
 638         (p (gensym))
 639         (d (gensym)))
 640     `(let* ((,pp ,parents)
 641             (,p (apply #'make-object (if (listp ,pp) ,pp (list ,pp))))
 642             (,d ,doc))
 643        (dolist (s ,cvars) (send ,p :add-slot s))
 644        (send ,p :make-prototype ',name ,ivars)
 645        (if ,d (send ,p :documentation 'proto ,d))
 646        (set ',name ,p)
 647        ',name)))
 648
 649
 650 ;;;;
 651 ;;;; DEFVAR, DEFPARAMETER and DEFCONSTANT
 652 ;;;;
 653
 654 (define-special-form-macro defvar (var &optional (value nil have-val) doc)
 655   `(progn
 656      (eval-when (:compile-toplevel)
 657                 (pushnew ',var *cmp-specials*))
 658      (mark-as-special ',var)
 659      ,@(if have-val `((unless (boundp ',var) (set ',var ,value))))
 660      ,@(if doc `((%set-get ',var 'variable-documentation ,doc)))
 661      ',var))
 662
 663 (define-special-form-macro defparameter (var value &optional doc)
 664   `(progn
 665      (eval-when (:compile-toplevel)
 666                 (pushnew ',var *cmp-specials*))
 667      (mark-as-special ',var)
 668      (set ',var ,value)
 669      ,@(if doc `((%set-get ',var 'variable-documentation ,doc)))
 670      ',var))
 671
 672 ;;**** is this the best way?
 673 (define-special-form-macro defconstant (var value &optional doc)
 674   `(eval-when (:compile-toplevel :load-toplevel :execute)
 675               (mark-as-special ',var t ,value)
 676               ,@(if doc `((%set-get ',var 'variable-documentation ,doc)))
 677               ',var))
 678
 679
 680 ;;;;
 681 ;;;; AND, OR, UNLESS, WHEN, and COND Macros
 682 ;;;;
 683
 684 (defun make-progn-form (body)
 685   (if (consp body) (if (consp (rest body)) `(progn ,@body) (first body))))
 686
 687 (defun make-tagbody-body (body)
 688   (if (find-if-not #'consp body) `((tagbody ,@body)) `(,@body nil)))
 689
 690 (define-special-form-macro and (&rest args)
 691   (labels ((expand (args)
 692              (if args
 693                  (let ((a (first args))
 694                        (rest (rest args)))
 695                    (if rest `(if ,a ,(expand rest)) a))
 696                  t)))
 697     (expand args)))
 698
 699 (define-special-form-macro or (&rest args)
 700   (labels ((expand (args)
 701              (if args
 702                  (let ((a (first args))
 703                        (rest (rest args)))
 704                    (if rest
 705                        (let ((s (gensym)))
 706                          `(let ((,s ,a))
 707                             (if ,s ,s ,(expand rest))))
 708                        a))
 709                  nil)))
 710     (expand args)))
 711
 712 (define-special-form-macro unless (test &rest body)
 713   `(if ,test nil ,(make-progn-form body)))
 714
 715 (define-special-form-macro when (test &rest body)
 716   `(if ,test ,(make-progn-form body)))
 717
 718
 719 (define-special-form-macro cond (&rest clauses)
 720   (labels ((expand (clauses)
 721              (if clauses
 722                  (let* ((fc (first clauses))
 723                         (rc (rest clauses))
 724                         (test (first fc))
 725                         (consequents (rest fc)))
 726                    (if (eq test t)
 727                        (if consequents (make-progn-form consequents) t)
 728                        (if consequents
 729                            `(if ,test
 730                                 ,(make-progn-form consequents)
 731                                 ,(expand rc))
 732                            (let ((tsym (gensym "T")))
 733                              `(let ((,tsym ,test))
 734                                 (if ,tsym ,tsym ,(expand rc))))))))))
 735     (expand clauses)))
 736
 737
 738 ;;;;
 739 ;;;; RETURN Macro
 740 ;;;;
 741
 742 (define-special-form-macro return (&optional val) `(return-from nil ,val))
 743
 744
 745 ;;;;
 746 ;;;; PROG, PROG*, PROG1, and PROG2 Macros
 747 ;;;;
 748
 749 (define-special-form-macro prog (vlist &rest body)
 750   (let ((db (split-declarations body)))
 751     `(block nil (let ,vlist ,@(first db) ,@(make-tagbody-body (second db))))))
 752
 753 (define-special-form-macro prog* (vlist &rest body)
 754   (let ((db (split-declarations body)))
 755     `(block nil (let* ,vlist ,@(first db) ,@(make-tagbody-body (second db))))))
 756
 757 (define-special-form-macro prog1 (first &rest rest)
 758   (let ((s (gensym)))
 759     `(let ((,s ,first)) ,@rest ,s)))
 760
 761 (define-special-form-macro prog2 (first second &rest rest)
 762   (let ((s (gensym)))
 763     `(progn ,first (let ((,s ,second)) ,@rest ,s))))
 764
 765
 766 ;;;;
 767 ;;;; LOOP, DOTIMES, DOLIST, DO, and DO* Macros
 768 ;;;;
 769
 770 (define-special-form-macro loop (&rest body)
 771     (let ((start (gensym "LOOP")))
 772       `(block nil (tagbody ,start (progn ,@body) (go ,start)))))
 773
 774 (defun do-loop-binding-variables (bds)
 775   (mapcar #'(lambda (x) (if (consp x) (first x) x)) bds))
 776
 777 (defun do-loop-binding-values (bds)
 778   (mapcar #'(lambda (x) (if (consp x) (second x) nil)) bds))
 779
 780 (defun do-loop-binding-steps (bds)
 781   (mapcar #'(lambda (x) (if (consp x) (rest (rest x)) nil)) bds))
 782
 783 (defun make-do-step-pairs (vars steps)
 784   (apply #'append
 785          (delete nil (mapcar #'(lambda (x y) (if y (cons x y))) vars steps))))
 786
 787 ;; This definition duplicates the test form (it is used at the start
 788 ;; of the loop and in the body, so the code may be a little longer
 789 ;; than it could be. But it is now possible to define dotimes and
 790 ;; dolist in terms of do without loss of efficiency. Also this version
 791 ;; removes the need for a jump label bewteen the update and test
 792 ;; forms. It may therefore be possible to reduce the updte-branch
 793 ;; instructions to a single instruction in the peephole optimization
 794 ;; phase.
 795 (defun make-do-loop (letsym setsym bds tr body)
 796   (let* ((vars (do-loop-binding-variables bds))
 797          (ivals (do-loop-binding-values bds))
 798          (slist (make-do-step-pairs vars (do-loop-binding-steps bds)))
 799          (test (first tr))
 800          (result (rest tr))
 801          (db (split-declarations body))
 802          (loop-sym (gensym "LOOP"))
 803          (return-sym (gensym "RETURN")))
 804     `(block nil
 805             (,letsym ,(mapcar #'list vars ivals)
 806               ,@(first db)
 807               (tagbody
 808                (when ,test (go ,return-sym))
 809                ,loop-sym
 810                ,@(second db)
 811                (,setsym ,@slist)
 812                (unless ,test (go ,loop-sym))
 813                ,return-sym
 814                (return-from nil ,(make-progn-form result)))))))
 815
 816 (define-special-form-macro do (bds tr &rest body)
 817   (make-do-loop 'let 'psetq bds tr body))
 818
 819 (define-special-form-macro do* (bds tr &rest body)
 820   (make-do-loop 'let* 'setq bds tr body))
 821
 822 (define-special-form-macro dotimes ((isym nval &optional res) &rest body)
 823   (let ((nsym (gensym "N")))
 824     `(do ((,isym 0 (1+ ,isym))
 825           (,nsym ,nval))
 826          ((not (< ,isym ,nsym)) ,res)
 827          ,@body)))
 828
 829 (define-special-form-macro dolist ((esym lval &optional res) &rest body)
 830   (let ((lsym (gensym "LIST")))
 831     `(do* ((,lsym ,lval (cdr ,lsym))
 832            (,esym (car ,lsym) (car ,lsym)))
 833           ((not (consp ,lsym)) ,res)
 834           ,@body)))
 835
 836
 837 ;;;;
 838 ;;;; IN-PACKAGE Macro
 839 ;;;;
 840
 841 (define-special-form-macro in-package (name)
 842   `(eval-when (:compile-toplevel :load-toplevel :execute)
 843               (let ((newpack (find-package ',name)))
 844                 (unless newpack (error "can't find package ~s" ',name))
 845                 (setf *package* newpack))))
 846
 847
 848 ;;;;
 849 ;;;; TIME Macro
 850 ;;;;
 851
 852 (define-special-form-macro time (expr)
 853   (let ((rtsym (gensym "RUN"))
 854         (gtsym (gensym "GC")))
 855     `(let ((,rtsym (get-internal-run-time))
 856            (,gtsym(get-internal-gc-time)))
 857        (multiple-value-prog1
 858         ,expr
 859         (format t "The evaluation took ~,2f seconds; ~,2f seconds in GC.~%"
 860                 (float (/ (- (get-internal-run-time) ,rtsym)
 861                           internal-time-units-per-second))
 862                 (float (/ (- (get-internal-gc-time) ,gtsym)
 863                           internal-time-units-per-second)))))))
 864
 865
 866 ;;;;
 867 ;;;; TRACE and UNTRACE Macros
 868 ;;;;
 869
 870 (define-special-form-macro trace (&rest args)
 871   `(dolist (s ',args *tracelist*)
 872      (unless (symbolp s) (error "not a symbol - ~s" s))
 873      (pushnew s *tracelist*)))
 874
 875 (define-special-form-macro untrace (&rest args)
 876   (if args
 877       `(dolist (s ',args *tracelist*)
 878          (unless (symbolp s) (error "not a symbol - ~s" s))
 879          (setf *tracelist* (delete s *tracelist*)))
 880       `(setf *tracelist* nil)))
 881
 882
 883 ;;;;
 884 ;;;; WITHOUT-INTERRUPTS Macro
 885 ;;;;
 886
 887 (export 'system::without-interrupts "SYSTEM")
 888 (defmacro system::without-interrupts (&rest body)
 889   `(progn
 890      (system::enable-interrupts nil)
 891      (unwind-protect
 892          (progn ,@body)
 893        (system::enable-interrupts t))))
 894
 895
 896 ;;;;
 897 ;;;; This is the final file in the common module
 898 ;;;;
 899
 900 (provide "common")