home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / DEFSTRUC.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  8.0 KB  |  229 lines
  1. ;;; (C) Copyright 1984 by Gold Hill Computers
  2.  
  3. ;; The DEFSTRUCT package
  4.  
  5. ;; Notes:  The DEFSTRUCT package is not completely COMMON Lisp compatible yet.
  6. ;; The contructor is a macro and not a function as per COMMON Lisp.
  7.  
  8. ;; The currently supported options are shown below:
  9.  
  10. ;; (DEFSTRUC NAME-OR-OPTIONS &REST SLOTS)
  11. ;; Options:
  12. ;;    :CONC-NAME
  13. ;;    :CONSTRUCTOR
  14. ;;    :NAMED
  15. ;;    :PREDICATE
  16. ;;    :PRINT-FUNCTION
  17. ;;    :TYPE {VECTOR | LIST}
  18.  
  19. ;; Accessor macros
  20. ;; These macros take the object that is on the STRUCTURE-DESCRIPTOR
  21. ;; property of the structure name.
  22. (DEFMACRO DEFST-SLOTS X `(CAR ,(CAR X)))    ; returns structures slots
  23.                         ; hard wired in DESCRIBE
  24. (DEFMACRO DEFST-TYPE X `(CADR ,(CAR X)))    ; returns type
  25. (DEFMACRO DEFST-OPTIONS X `(CADDR ,(CAR X)))    ; returns all defstruct options
  26.                         ; hard wired in DESCRIBE
  27. (DEFMACRO DEFST-SLOT-CNT X `(NTH 3 ,(CAR X)))    ; number of slots (local?)
  28. (DEFMACRO DEFST-NAMEDP X `(NTH 4 ,(CAR X)))    ; whether named structure
  29.  
  30. ;; These macros take a slot descriptor, member of the DEFST-SLOTS list.
  31. (DEFMACRO SLOT-NAME X `(CAR ,(CAR X)))        ; name of slot
  32.                         ; hard wired in DESCRIBE
  33. (DEFMACRO SLOT-POS X `(CADR ,(CAR X)))        ; structure position (local?)
  34. (DEFMACRO SLOT-DEFAULT X `(CDDR ,(CAR X)))    ; default form, returns a LIST
  35.  
  36. ;;; This function returns the accessor definition function and the
  37. ;;; form used to tell setf how to perform the update operation.
  38. (DEFUN DEF-ACCESSOR (SLOT-D CONC-NAME TYPE)
  39.   (LET ((NAME (IF CONC-NAME
  40.                   (INTERN (STRING-APPEND CONC-NAME (CAR SLOT-D)))
  41.                   (CAR SLOT-D))))
  42.     `((DEFUN ,NAME
  43.              (OBJ)
  44.          ,(CASE TYPE
  45.             (VECTOR `(AREF OBJ ,(CADR SLOT-D)))
  46.             (LIST `(NTH ,(CADR SLOT-D) OBJ))))
  47.       (SETF (GET ',NAME 'SETF-EXPANDER) 
  48.         '((,NAME OBJ) . ,(CASE TYPE
  49.                                (VECTOR `(AREF OBJ ,(CADR SLOT-D)))
  50.                                (LIST `(NTH ,(CADR SLOT-D) OBJ))))))))
  51.     
  52. ;;; Second value indicates whether value is present or not.
  53. ;;; Either on LST or default.
  54. (DEFUN DEFST-GETV (LST SLOT)
  55.   (DO ((I LST (CDDR I)))
  56.       ((NULL I) (WHEN (SLOT-DEFAULT SLOT)
  57.               (VALUES (CAR (SLOT-DEFAULT SLOT))
  58.                   (SLOT-NAME SLOT))))
  59.     (WHEN (SAMEPNAMEP (CAR I) (SLOT-NAME SLOT))
  60.       (RETURN (VALUES (SECOND I) (FIRST I))))))
  61.     
  62. (DEFUN DEFST-KLIST (LST)
  63.   (DO ((I LST (CDDR I))
  64.        (RES NIL (CONS (CAR I) RES)))
  65.       ((NULL I) RES)))
  66.  
  67.  
  68. ;; Returns the macro that will make the structure.
  69. (DEFUN MAKE-STRUCTURE (STRUCT NAME NAMEDP)
  70.   `(DEFMACRO ,NAME X (MAKE-STRUCTURE1 ',STRUCT X ',NAMEDP)))
  71.  
  72. (DEFUN MAKE-STRUCTURE1 (STRUCT ARGS NAMEDP)
  73.   (LET* ((STRUCTURE-DESCRIPTOR (GET STRUCT 'STRUCTURE-DESCRIPTOR))
  74.      (TYPE (DEFST-TYPE STRUCTURE-DESCRIPTOR))
  75.      (SLOT-ALIST (DEFST-SLOTS STRUCTURE-DESCRIPTOR))
  76.      (OPTIONS (DEFST-OPTIONS STRUCTURE-DESCRIPTOR))
  77.      (ST)
  78.      (KLIST (DEFST-KLIST ARGS)))
  79.     (CASE TYPE
  80.        (LIST
  81.          `(LIST
  82.             ,@(DO ((S (DEFST-SLOTS (GET STRUCT 'STRUCTURE-DESCRIPTOR))
  83.                       (CDR S))
  84.                    VAL KEYP
  85.                    (RES (WHEN (DEFST-NAMEDP STRUCTURE-DESCRIPTOR)
  86.                           `(NCONS ',STRUCT))))
  87.                   ((NULL S)
  88.                    (WHEN KLIST
  89.                      (ERROR "While making structure ~S, bad keywords: ~S"
  90.                             STRUCT KLIST))
  91.                    (NREVERSE RES))
  92.                 (SETF (VALUES VAL KEYP)
  93.                       (DEFST-GETV ARGS (CAR S)))
  94.                 (SETQ KLIST (DELETE KEYP KLIST))
  95.                 (PUSH VAL RES))))
  96.        (VECTOR
  97.      `(LET ((,(SETQ ST (MAKE-SYMBOL "VAR")) 
  98.                  (MAKE-ARRAY ,(DEFST-SLOT-CNT STRUCTURE-DESCRIPTOR)
  99.                              ,@(WHEN NAMEDP
  100.                  `(:NAMED-STRUCTURE-SYMBOL ',STRUCT)))))
  101.         ,@(DO ((S (DEFST-SLOTS (GET STRUCT 'STRUCTURE-DESCRIPTOR))
  102.                       (CDR S))
  103.                    VAL KEYP
  104.            (RES NIL))
  105.           ((NULL S)
  106.                    (WHEN KLIST
  107.                      (ERROR "While making structure ~S, bad keywords: ~S"
  108.                             STRUCT KLIST))
  109.            (NREVERSE (CONS ST RES)))
  110.         (SETF (VALUES VAL KEYP)
  111.               (DEFST-GETV ARGS (CAR S)))
  112.         (WHEN KEYP
  113.           (PUSH `(ASET ,VAL ,ST ,(SLOT-POS (CAR S)))
  114.             RES))
  115.         (SETQ KLIST (DELETE KEYP KLIST))))))))
  116.  
  117.  
  118. (DEFUN UPDATE-OFFSET (TYPE NAMEDP)
  119.   (IF NAMEDP 1 0))
  120.  
  121. (DEFUN DEFSTRUCT-PROCESS-OPTIONS (STRUCT-NAME OPTIONS)
  122.   (LET ((CONC-NAME (STRING-APPEND STRUCT-NAME #\-))    ; set up defaults
  123.     (TYPE 'VECTOR)
  124.     (OFFSET 1)
  125.     (EXP-NAMEDP)            ; whether NAMED/UNNAMED specified
  126.     (NAMEDP T)
  127.     (PRINT-FUNCTION)
  128.     (CONSER (INTERN (STRING-APPEND "MAKE-" STRUCT-NAME)))
  129.     (PREDICATE T)
  130.     )
  131.     (DOLIST (OPT OPTIONS)
  132.       (CASE (IF (CONSP OPT) (CAR OPT) 'ATOMIC)
  133.         (:CONC-NAME
  134.       (SETQ CONC-NAME (CADR OPT)))
  135.     (:TYPE
  136.       (UNLESS (MEMBER (SETQ TYPE (CADR OPT))
  137.               '(VECTOR LIST))
  138.         (ERROR "Illegal DEFSTRUCT type: ~S" OPT))
  139.       (UNLESS EXP-NAMEDP (SETQ NAMEDP NIL))
  140.       (SETQ OFFSET (UPDATE-OFFSET TYPE NAMEDP))
  141.       )
  142.     (:NAMED
  143.       (SETQ NAMEDP T EXP-NAMEDP T OFFSET (UPDATE-OFFSET TYPE NAMEDP)))
  144.     (:CONSTRUCTOR 
  145.       (SETQ CONSER (CADR OPT)))
  146.     (:PREDICATE
  147.       (SETQ PREDICATE (CADR OPT)))
  148.     (:PRINT-FUNCTION
  149.       (SETQ PRINT-FUNCTION `(PUTPROP ',STRUCT-NAME 
  150.                      ,(CADR OPT)
  151.                      ':PRINT-FUNCTION)))
  152.     (ATOMIC
  153.       (CASE OPT
  154.         ((:CONSTRUCTOR :CONC-NAME))            ; just ignore
  155.         (:NAMED
  156.           (SETQ NAMEDP T EXP-NAMEDP T
  157.                   OFFSET (UPDATE-OFFSET TYPE NAMEDP)))
  158.         (OTHERWISE
  159.           (ERROR "Illegal DEFSTRUCT option: ~S" OPT))))
  160.     (OTHERWISE
  161.       (ERROR "Illegal DEFSTRUCT option: ~S" OPT))))
  162.     (WHEN PREDICATE
  163.       (IF  (EQ PREDICATE T)
  164.            (SETQ PREDICATE (IF NAMEDP
  165.                    (INTERN (STRING-APPEND STRUCT-NAME "-P"))
  166.                    NIL))
  167.        (UNLESS NAMEDP
  168.          (ERROR "Can't have PREDICATE with UNNAMED structure"))))
  169.     (WHEN PREDICATE
  170.       (SETQ PREDICATE
  171.         `(DEFUN ,PREDICATE (X)
  172.        ,(IF (EQ TYPE 'LIST)
  173.         `(EQ (CAR X) ',STRUCT-NAME)
  174.         `(TYPEP X ',STRUCT-NAME)))))
  175.     (VALUES CONC-NAME            ; prefix for accessor macros or NIL
  176.         TYPE            ; structure type
  177.         OFFSET            ; offset to structure elements
  178.         NAMEDP            ; wheter its named
  179.         PRINT-FUNCTION        ; the print function or NIL
  180.         CONSER            ; name of the conser or NIL
  181.         PREDICATE            ; name of predicate or NIL
  182.         )))
  183.  
  184.  
  185.  
  186. ; The structure definition info is kept on the STRUCTURE-DESCRIPTOR property
  187. ; of the structure name.  It consists of a list:
  188. ;    ( slot-alist type options)
  189.  
  190. (DEFMACRO DEFSTRUCT FRM
  191.   (LET* ((SLOTS (MAPCAR '(LAMBDA (X) (IF (CONSP X) X (NCONS X))) (CDR FRM)))
  192.       (S-NAME (IFN (CONSP (CAR FRM)) (CAR FRM) (CAAR FRM)))
  193.      (OPTIONS (IF (CONSP (CAR FRM)) (CDAR FRM) NIL))
  194.      (RESULT `(',S-NAME))
  195.      (SLOT-ALIST))
  196.     (IF (STRINGP (CAAR SLOTS)) (POP SLOTS))        ; dump DOC string
  197.     (MULTIPLE-VALUE-BIND (CONC-NAME STRUCT-TYPE OFFSET NAMEDP
  198.               PRINT-FUNCTION CONSER PREDICATE)
  199.             (DEFSTRUCT-PROCESS-OPTIONS S-NAME OPTIONS)
  200.       
  201.       (SETQ SLOT-ALIST            ; entries: (SLOT-NAME INDEX DEFAULT)
  202.             (DO ((I OFFSET (1+ I))
  203.              (SLOT SLOTS (CDR SLOT))
  204.              (ALIST NIL (CONS (IF (CONSP (CDAR SLOT))
  205.                       (LIST (CAAR SLOT) I (CADAR SLOT))
  206.                       (LIST (CAAR SLOT) I)) ALIST)))
  207.           ((NULL SLOT) (NREVERSE ALIST))))
  208.  
  209.       (PUTPROP S-NAME
  210.            (LIST SLOT-ALIST                ; alist of slots
  211.              STRUCT-TYPE            ; type of structure
  212.              OPTIONS                ; options
  213.              (+ OFFSET (LENGTH SLOT-ALIST))    ; size of structure
  214.              NAMEDP)
  215.            'STRUCTURE-DESCRIPTOR)
  216.       ;; hook into to the type mechanism
  217.       (WHEN NAMEDP (SETF (GET S-NAME 'SUPER-TYPES)
  218.              (LIST S-NAME (GET 'STRUCTURE 'SUPER-TYPES))))
  219.  
  220.       (DOLIST (SLT SLOT-ALIST)                ; define accessors
  221.     (SETQ RESULT
  222.           (APPEND (DEF-ACCESSOR SLT CONC-NAME STRUCT-TYPE) RESULT)))
  223.       (WHEN CONSER                    ; define make macro
  224.         (PUSH (MAKE-STRUCTURE S-NAME CONSER NAMEDP) RESULT))
  225.       (WHEN PREDICATE (PUSH PREDICATE RESULT))
  226.       (WHEN PRINT-FUNCTION (PUSH PRINT-FUNCTION RESULT))
  227.       (CONS 'PROGN RESULT)
  228.       )))
  229.