home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / evalmacros.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  8.8 KB  |  285 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;    evalmacros.lsp
  21.  
  22.  
  23. (in-package 'lisp)
  24.  
  25. (export '(defvar defparameter defconstant))
  26.  
  27. (in-package 'system)
  28.  
  29.  
  30. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  31. (eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
  32. (eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
  33.  
  34.  
  35. (defmacro defvar (var &optional (form nil form-sp) doc-string)
  36.   `(progn (si:*make-special ',var)
  37.       ,(if doc-string
  38.            `(si:putprop ',var ,doc-string 'variable-documentation))
  39.       ,(if form-sp
  40.            `(or (boundp ',var)
  41.             (setq ,var ,form)))
  42.       ',var)
  43.       )
  44.  
  45. (defmacro defparameter (var form &optional doc-string)
  46.   (if doc-string
  47.       `(progn (si:*make-special ',var)
  48.               (si:putprop ',var ,doc-string 'variable-documentation)
  49.               (setq ,var ,form)
  50.               ',var)
  51.       `(progn (si:*make-special ',var)
  52.               (setq ,var ,form)
  53.               ',var)))
  54.  
  55. (defmacro defconstant (var form &optional doc-string)
  56.   (if doc-string
  57.       `(progn (si:*make-constant ',var ,form)
  58.               (si:putprop ',var ,doc-string 'variable-documentation)
  59.               ',var)
  60.       `(progn (si:*make-constant ',var ,form)
  61.               ',var)))
  62.  
  63.  
  64. ;;; Each of the following macros is also defined as a special form.
  65. ;;; Thus their names need not be exported.
  66.  
  67. (defmacro and (&rest forms)
  68.   (if (endp forms)
  69.       t
  70.       (let ((x (reverse forms)))
  71.            (do ((forms (cdr x) (cdr forms))
  72.                 (form (car x) `(if ,(car forms) ,form)))
  73.                ((endp forms) form))))
  74.   )
  75.  
  76. (defmacro or (&rest forms)
  77.   (if (endp forms)
  78.       nil
  79.       (let ((x (reverse forms)))
  80.            (do ((forms (cdr x) (cdr forms))
  81.                 (form (car x)
  82.                       (let ((temp (gensym)))
  83.                            `(let ((,temp ,(car forms)))
  84.                                  (if ,temp ,temp ,form)))))
  85.                ((endp forms) form))))
  86.   )
  87.                
  88. (defmacro locally (&rest body) `(let () ,@body))
  89.  
  90. (defmacro loop (&rest body &aux (tag (gensym)))
  91.   `(block nil (tagbody ,tag (progn ,@body) (go ,tag))))
  92.  
  93. (defmacro defmacro (name vl &rest body)
  94.   `(si:define-macro ',name (si:defmacro* ',name ',vl ',body)))
  95.  
  96. (defmacro defun (name lambda-list &rest body)
  97.   (multiple-value-bind (doc decl body)
  98.        (find-doc body nil)
  99.     (if doc
  100.         `(progn (setf (get ',name 'si:function-documentation) ,doc)
  101.                 (setf (symbol-function ',name)
  102.                       #'(lambda ,lambda-list
  103.                           ,@decl (block ,name ,@body)))
  104.                 ',name)
  105.         `(progn (setf (symbol-function ',name)
  106.                       #'(lambda ,lambda-list
  107.                           ,@decl (block ,name ,@body)))
  108.                 ',name))))
  109.  
  110. ; assignment
  111.  
  112. (defmacro psetq (&rest args)
  113.    (do ((l args (cddr l))
  114.         (forms nil)
  115.         (bindings nil))
  116.        ((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms))))
  117.        (declare (object l))
  118.        (let ((sym (gensym)))
  119.             (push (list sym (cadr l)) bindings)
  120.             (push (list 'setq (car l) sym) forms)))
  121.    )
  122.  
  123. ; conditionals
  124.  
  125. (defmacro cond (&rest clauses &aux (form nil))
  126.   (dolist (l (reverse clauses) form)
  127.           (declare (object l))
  128.     (cond ((endp (cdr l))
  129.            (if (eq (car l) 't)
  130.                (setq form 't)
  131.                (let ((sym (gensym)))
  132.                     (setq form `(let ((,sym ,(car l)))
  133.                                      (if ,sym ,sym ,form))))))
  134.           ((eq (car l) 't)
  135.            (setq form (if (endp (cddr l))
  136.                           (cadr l)
  137.                           `(progn ,@(cdr l)))))
  138.           (t (setq form (if (endp (cddr l))
  139.                             `(if ,(car l) ,(cadr l) ,form)
  140.                             `(if ,(car l) (progn ,@(cdr l)) ,form))))))
  141.   )
  142.  
  143. (defmacro when (pred &rest body)
  144.   `(if ,pred (progn ,@body)))
  145.  
  146. (defmacro unless (pred &rest body)
  147.   `(if (not ,pred) (progn ,@body)))
  148.  
  149. ; program feature
  150.  
  151. (defmacro prog (vl &rest body &aux (decl nil))
  152.   (do ()
  153.       ((or (endp body)
  154.            (not (consp (car body)))
  155.            (not (eq (caar body) 'declare)))
  156.        `(block nil (let ,vl ,@decl (tagbody ,@body)))
  157.        )
  158.       (push (car body) decl)
  159.       (pop body))
  160.   )
  161.  
  162. (defmacro prog* (vl &rest body &aux (decl nil))
  163.   (do ()
  164.       ((or (endp body)
  165.            (not (consp (car body)))
  166.            (not (eq (caar body) 'declare)))
  167.        `(block nil (let* ,vl ,@decl (tagbody ,@body)))
  168.        )
  169.       (push (car body) decl)
  170.       (pop body))
  171.   )
  172.  
  173. ; sequencing
  174.  
  175. (defmacro prog1 (first &rest body &aux (sym (gensym)))
  176.   `(let ((,sym ,first)) ,@body ,sym))
  177.  
  178. (defmacro prog2 (first second &rest body &aux (sym (gensym)))
  179.   `(progn ,first (let ((,sym ,second)) ,@body ,sym)))
  180.  
  181. ; multiple values
  182.  
  183. (defmacro multiple-value-list (form)
  184.   `(multiple-value-call 'list ,form))
  185.  
  186. (defmacro multiple-value-setq (vars form)
  187.   (do ((vl vars (cdr vl))
  188.        (sym (gensym))
  189.        (forms nil)
  190.        (n 0 (1+ n)))
  191.       ((endp vl) `(let ((,sym (multiple-value-list ,form))) ,@forms))
  192.       (declare (fixnum n) (object vl))
  193.       (push `(setq ,(car vl) (nth ,n ,sym)) forms))
  194.   )
  195.  
  196. (defmacro multiple-value-bind (vars form &rest body)
  197.   (do ((vl vars (cdr vl))
  198.        (sym (gensym))
  199.        (bind nil)
  200.        (n 0 (1+ n)))
  201.       ((endp vl) `(let* ((,sym (multiple-value-list ,form)) ,@(reverse bind))
  202.                         ,@body))
  203.       (declare (fixnum n) (object vl))
  204.       (push `(,(car vl) (nth ,n ,sym)) bind))
  205.   )
  206.  
  207. (defmacro do (control (test . result) &rest body
  208.               &aux (decl nil) (label (gensym)) (vl nil) (step nil))
  209.   (do ()
  210.       ((or (endp body)
  211.            (not (consp (car body)))
  212.            (not (eq (caar body) 'declare))))
  213.       (push (car body) decl)
  214.       (pop body))
  215.   (dolist (c control)
  216.           (declare (object c))
  217.     (if(symbolp  c) (setq c (list c)))
  218.         (push (list (car c) (cadr c)) vl)
  219.     (unless (endp (cddr c))
  220.             (push (car c) step)
  221.             (push (caddr c) step)))
  222.   `(block nil
  223.           (let ,(reverse vl)
  224.                ,@decl
  225.                (tagbody
  226.                 ,label (if ,test (return (progn ,@result)))
  227.                        (tagbody ,@body)
  228.                        (psetq ,@(reverse step))
  229.                        (go ,label)))))
  230.  
  231. (defmacro do* (control (test . result) &rest body
  232.                &aux (decl nil) (label (gensym)) (vl nil) (step nil))
  233.   (do ()
  234.       ((or (endp body)
  235.            (not (consp (car body)))
  236.            (not (eq (caar body) 'declare))))
  237.       (push (car body) decl)
  238.       (pop body))
  239.   (dolist (c control)
  240.           (declare (object c))
  241.     (if(symbolp  c) (setq c (list c)))
  242.         (push (list (car c) (cadr c)) vl)
  243.     (unless (endp (cddr c))
  244.             (push (car c) step)
  245.             (push (caddr c) step)))
  246.   `(block nil
  247.           (let* ,(reverse vl)
  248.                 ,@decl
  249.                 (tagbody
  250.                  ,label (if ,test (return (progn ,@result)))
  251.                         (tagbody ,@body)
  252.                         (setq ,@(reverse step))
  253.                         (go ,label))))
  254.   )
  255.  
  256. (defmacro case (keyform &rest clauses &aux (form nil) (key (gensym)))
  257.   (dolist (clause (reverse clauses) `(let ((,key ,keyform)) ,form))
  258.           (declare (object clause))
  259.     (cond ((or (eq (car clause) 't) (eq (car clause) 'otherwise))
  260.            (setq form `(progn ,@(cdr clause))))
  261.           ((consp (car clause))
  262.            (setq form `(if (member ,key ',(car clause))
  263.                            (progn ,@(cdr clause))
  264.                            ,form)))
  265.           ((car clause)
  266.            (setq form `(if (eql ,key ',(car clause))
  267.                            (progn ,@(cdr clause))
  268.                            ,form)))))
  269.   )
  270.  
  271.  
  272. (defmacro return (&optional (val nil)) `(return-from nil ,val))
  273.  
  274. (defmacro dolist ((var form &optional (val nil)) &rest body
  275.                                                  &aux (temp (gensym)))
  276.   `(do* ((,temp ,form (cdr ,temp)) (,var (car ,temp) (car ,temp)))
  277.     ((endp ,temp) ,val)
  278.     ,@body))
  279.  
  280. (defmacro dotimes ((var form &optional (val nil)) &rest body
  281.                                                   &aux (temp (gensym)))
  282.   `(do* ((,temp ,form) (,var 0 (1+ ,var)))
  283.         ((>= ,var ,temp) ,val)
  284.         ,@body))
  285.