home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / DEFMAC.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  4.8 KB  |  126 lines
  1. ;;; (C) Copyright 1984 by Gold Hill Computers
  2.  
  3. (MACRO DEFMACRO (X) (DEFMACRO1 (CDR X)))
  4.  
  5. (DEFVAR *OPTIONAL-SPECIFIED-FLAGS*)
  6.  
  7. ;; whether &BODY was specified
  8. (DEFVAR *DEFMACRO-&BODY-FLAG*)
  9.  
  10. ;; X is the cdr of the macro definition form.
  11. (DEFUN DEFMACRO1 (X)
  12.   (UNLESS (TYPEP (CAR X) 'SYMBOL)
  13.     (ERROR "~S: wrong type argument: ~S. A SYMBOL was expected." 
  14.        'DEFMACRO (CAR X)))
  15.   (LET* ((WHOLE-P (AND (LISTP (CADR X)) (EQ '&WHOLE (CAADR X))))
  16.          (*VARLIST* (IF WHOLE-P (LIST (CAR (CDADR X)))))
  17.          (*VALLIST* (IF WHOLE-P (LIST '*MACROARG*)))
  18.          *OPTIONAL-SPECIFIED-FLAGS* *DEFMACRO-&BODY-FLAG*)
  19.      (LET ((PAIR (DEFMACRO-PARSE-&
  20.                    (IF WHOLE-P (CDR (CDADR X))(CADR X))
  21.            '(CDR *MACROARG*) 0 (CADR X)))
  22.            (BODY (CDDR X)))
  23.         `(MACRO ,(CAR X) (*MACROARG*)
  24.          ,@(IF (NOT (AND (ZEROP (CAR PAIR))
  25.                          (NULL (CDR PAIR))))
  26.                `((AND ,(COND ((ZEROP (CAR PAIR))
  27.                               `(> (LENGTH *MACROARG*)
  28.                                  ,(1+ (CDR PAIR))))
  29.                               ((NULL (CDR PAIR))
  30.                                `(< (LENGTH *MACROARG*)
  31.                                    ,(1+ (CAR PAIR))))
  32.                               (T `(OR (< (LENGTH *MACROARG*)
  33.                                          ,(1+ (CAR PAIR)))
  34.                                       (> (LENGTH *MACROARG*)
  35.                                          ,(1+ (CDR PAIR))))))
  36.                          (ERROR "Wrong number of args to macro: ~S"
  37.                                 *MACROARG*))))
  38.          ,(DEFMACRO2 (NREVERSE *VARLIST*) (NREVERSE *VALLIST*)
  39.                      *OPTIONAL-SPECIFIED-FLAGS* BODY)))))
  40.  
  41. ;; Put together the various bindings and the body.
  42. ;; The VARS are bound sequentially since their initializations may depend
  43. ;; on each other (in left-to-right fashion).
  44. (DEFUN DEFMACRO2 (VARS VALS FLAGS BODY)
  45.   `(LET* (,@FLAGS 
  46.       ,@(MAPCAR #'(LAMBDA (X Y)(LIST X Y)) VARS VALS)
  47.       (*MACROARG1* ,(IF (CDR BODY) 
  48.                 `(PROGN . ,BODY)
  49.                  (CAR BODY))))
  50.      (IF (CONSP *MACROARG1*) 
  51.      (RPLACB *MACROARG* *MACROARG1*)
  52.      *MACROARG1*)))
  53.  
  54. (DEFUN DEFMACRO-PARSE-& (PATTERN PATH STATE EPAT)
  55.        (COND ((NULL PATTERN) (CONS 0 0))
  56.          ((ATOM PATTERN)
  57.           (COND ((> STATE 1) (ERROR "Bad pattern to DEFMACRO: ~S" EPAT))
  58.             (T (DEFMACRO-COLLECT PATTERN PATH)
  59.                (NCONS 0))))
  60.          ((EQ (CAR PATTERN) '&OPTIONAL)
  61.           (COND ((> STATE 0) (ERROR "Bad pattern to DEFMACRO: ~S" EPAT))
  62.             (T (DEFMACRO-PARSE-& (CDR PATTERN) PATH 1 EPAT))))
  63.          ((MEMBER (CAR PATTERN) '(&REST &BODY))
  64.           (AND (EQ (CAR PATTERN) '&BODY)
  65.            (SETQ *DEFMACRO-&BODY-FLAG* T))
  66.           (AND (NULL (CDR PATTERN))
  67.            (ERROR "Bad pattern to DEFMACRO: ~S" EPAT))
  68.           (COND ((> STATE 1) (ERROR "Bad pattern to DEFMACRO: ~S" EPAT))
  69.             (T (DEFMACRO-PARSE-& (CDR PATTERN) PATH 2 EPAT))))
  70.          ((EQ (CAR PATTERN) '&AUX)
  71.           (COND ((> STATE 2) (ERROR "Bad pattern to DEFMACRO: ~S" EPAT))
  72.             (T (DEFMACRO-PARSE-& (CDR PATTERN) PATH 3 EPAT))))
  73.          ((= STATE 0)
  74.           (DEFMACRO-COLLECT (CAR PATTERN) (LIST 'CAR PATH))
  75.           (LET ((PAIR (DEFMACRO-PARSE-&
  76.                 (CDR PATTERN) (LIST 'CDR PATH) 0 EPAT)))
  77.         (WHEN (CDR PAIR) (INCF (CDR PAIR)))
  78.         (INCF (CAR PAIR))
  79.         PAIR))
  80.          ((= STATE 1)
  81.           (COND ((ATOM (CAR PATTERN))
  82.              (DEFMACRO-COLLECT (CAR PATTERN)
  83.                             `(CAR ,PATH)))
  84.             (T
  85.              (AND (CAR (CDDAR PATTERN))
  86.               (PUSH (CAR (CDDAR PATTERN))
  87.                 *OPTIONAL-SPECIFIED-FLAGS*))
  88.              (DEFMACRO-COLLECT (CAAR PATTERN)
  89.                        `(COND (,PATH
  90.                            ,(AND (CAR (CDDAR PATTERN))
  91.                              `(SETQ ,(CAR (CDDAR PATTERN)) T))
  92.                            (CAR ,PATH))
  93.                           (T ,(CADAR PATTERN))))))
  94.           (LET ((PAIR (DEFMACRO-PARSE-& 
  95.                 (CDR PATTERN) (LIST 'CDR PATH) 1 EPAT)))
  96.         (IF (NULL (CDR PAIR))
  97.             PAIR
  98.             (INCF (CDR PAIR)))
  99.         PAIR))
  100.          ((= STATE 2)
  101.           (DEFMACRO-COLLECT (CAR PATTERN) PATH)
  102.           (WHEN (CDR PATTERN)
  103.         (WHEN (OR (ATOM (CDR PATTERN))
  104.               (NOT (EQ (CADR PATTERN) '&AUX)))
  105.           (ERROR "Bad pattern to DEFMACRO: ~S" EPAT))
  106.         (DEFMACRO-PARSE-& (CDDR PATTERN) PATH 3 EPAT))
  107.           (NCONS 0))
  108.          ((= STATE 3)
  109.           (IF (ATOM (CAR PATTERN))
  110.           (DEFMACRO-COLLECT (CAR PATTERN) NIL)
  111.           (DEFMACRO-COLLECT (CAAR PATTERN) (CADAR PATTERN)))
  112.           (DEFMACRO-PARSE-& (CDR PATTERN) (LIST 'CDR PATH) 3 EPAT))
  113.          ))
  114.  
  115. (DEFUN DEFMACRO-COLLECT (PATTERN PATH)
  116.        (COND ((NULL PATTERN))
  117.          ((ATOM PATTERN)
  118.           (WHEN (MEMBER PATTERN '(&REST &AUX &OPTIONAL &WHOLE &BODY))
  119.             (ERROR "~S can only be used in top-level lambda lists."
  120.                PATTERN))
  121.           (SETQ *VARLIST* (CONS PATTERN *VARLIST*))
  122.           (SETQ *VALLIST* (CONS PATH *VALLIST*)))
  123.          (T 
  124.           (DEFMACRO-COLLECT (CAR PATTERN) (LIST 'CAR PATH))
  125.           (DEFMACRO-COLLECT (CDR PATTERN) (LIST 'CDR PATH)))))
  126.