Changeset 278


Ignore:
Timestamp:
08/18/11 18:03:57 (3 years ago)
Author:
rjs
Message:

Update from System 78.

Location:
trunk/lisp/lispm2
Files:
9 added
15 deleted
28 edited

Legend:

Unmodified
Added
Removed
  • trunk/lisp/lispm2/band.lisp

    r248 r278  
    11;-*- Mode:LISP; Package:System-Internals; Base:8 -*-
    22
    3 (DEFUN GET-PARTITION-SIZE (PART &AUX PART-BASE PART-SIZE RQB BUF)
    4   (MULTIPLE-VALUE (PART-BASE PART-SIZE) (SYS:FIND-DISK-PARTITION PART))
    5   (AND (STRING-EQUAL PART "LOD" 0 0 3 3)
    6        (UNWIND-PROTECT
    7          (PROGN (SETQ RQB (SYS:GET-DISK-RQB 1))
    8                 (SETQ BUF (SYS:RQB-BUFFER RQB))
    9                 (SYS:DISK-READ RQB 0 (1+ PART-BASE))
    10                 (LET ((SIZE (DPB (AREF BUF (1+ (* 2 SYS:%SYS-COM-VALID-SIZE)))
    11                                  1010           ;Knows page-size is 2^8
    12                                  (LDB 1010 (AREF BUF (* 2 SYS:%SYS-COM-VALID-SIZE))))))
    13                   (COND ((AND (> SIZE 10) (
    14  SIZE PART-SIZE))
    15                          (SETQ PART-SIZE SIZE)))))
    16          (SYS:RETURN-DISK-RQB RQB)))
    17   PART-SIZE)
     3;; Values can be T, :NOTIFY, or NIL, as with CHAOS:EVAL-SERVER-ON.
     4(DEFVAR BAND-TRANSFER-SERVER-ON ':NOTIFY)
     5
     6;Note: because of the way this transfers bytes between the network and
     7;the disk buffers, if you change the value of QUANTUM it will break; i.e.
     8;two machines with different values of quantum cannot send to each other.
    189
    1910(DEFUNP BAND-TRANSFER-SERVER (&AUX CONN PKT STR TEM RQB BUF WRITE-P (QUANTUM 17.) PART-NAME
    2011                                   PART-BASE PART-SIZE PART-COMMENT SUB-START SUB-N NB TOP)
    2112 (UNWIND-PROTECT (PROGN
    22   (SETQ CONN (CHAOS:LISTEN "BAND-TRANSFER" 25.))
    23   (PROCESS-WAIT "Listen" #'(LAMBDA (CONN) (EQ (CHAOS:STATE CONN) 'CHAOS:RFC-RECEIVED-STATE))
    24                          CONN)
     13  (SETQ CONN (CHAOS:LISTEN "BAND-TRANSFER" QUANTUM))
     14  (AND (NULL BAND-TRANSFER-SERVER-ON)
     15       (NOT (MEMBER USER-ID '(NIL "")))
     16       (RETURN (CHAOS:REJECT CONN (FORMAT NIL "This machine is in use by ~A" USER-ID))))
    2517  (SETQ STR (CHAOS:PKT-STRING (CHAOS:READ-PKTS CONN)))  ;Look at the RFC
    2618  (LET ((IBASE 10.))    ;RFC is BAND-TRANSFER READ/WRITE band subset size comment
    2719                        ;subset is NIL or list of rel start and n-blocks
    2820    (SETQ TEM (READ-FROM-STRING (STRING-APPEND "(" STR ")"))))
    29   (MULTIPLE-VALUE (PART-BASE PART-SIZE)
    30     (SYS:FIND-DISK-PARTITION (SETQ PART-NAME (THIRD TEM))))
     21  (MULTIPLE-VALUE (PART-BASE PART-SIZE NIL PART-NAME)
     22    (SYS:FIND-DISK-PARTITION (THIRD TEM)))
    3123  (OR PART-BASE
    3224      (RETURN (CHAOS:REJECT CONN (FORMAT NIL "No /"~A/" partition here." PART-NAME))))
     
    3931         (OR (
    4032 (FIFTH TEM) PART-SIZE)
    41              (RETURN (CHAOS:REJECT CONN "Partition too small")))
     33             (RETURN (CHAOS:REJECT CONN (FORMAT NIL "Partition too small, ~D>~D"
     34                                                (FIFTH TEM) PART-SIZE))))
    4235         (SETQ PART-SIZE (FIFTH TEM))
    4336         (SETQ PART-COMMENT (STRING (SIXTH TEM))))      ;Comment to store later
     
    4639       (CHAOS:REJECT CONN "Subset outside of partition"))
    4740  (CHAOS:ACCEPT CONN)
    48   (BEEP)
    49   (FORMAT (TV:GET-NOTIFICATION-STREAM)
    50           "~&[BAND-TRANSFER-SERVER: ~:[READ~;WRITE~] of ~A partition by ~A]~%"
    51           WRITE-P PART-NAME (CHAOS:HOST-DATA (CHAOS:FOREIGN-ADDRESS CONN)))
     41  (OR (EQ BAND-TRANSFER-SERVER-ON ':NOTIFY)
     42      (TV:NOTIFY NIL "BAND-TRANSFER-SERVER: ~:[READ~;WRITE~] of ~A partition by ~A"
     43                 WRITE-P PART-NAME (CHAOS:HOST-DATA (CHAOS:FOREIGN-ADDRESS CONN))))
     44  (FUNCALL TV:WHO-LINE-FILE-STATE-SHEET ':ADD-SERVER CONN "BAND-TRANSFER")
    5245  (COND ((NOT WRITE-P)                          ;Send packet containing size, comment
    53          (SETQ PART-SIZE (GET-PARTITION-SIZE PART-NAME))
     46         (SETQ PART-SIZE (MEASURED-SIZE-OF-PARTITION PART-NAME))
    5447         (SETQ PKT (CHAOS:GET-PKT))
    5548         (CHAOS:SET-PKT-STRING PKT (FORMAT NIL "~D ~S" PART-SIZE PART-COMMENT))
     
    6659    (AND (< (SETQ NB (- TOP BLOCK)) QUANTUM)
    6760         (SI:WIRE-DISK-RQB RQB (SETQ QUANTUM NB)))
    68     (COND ((NOT WRITE-P)
    69            (SI:DISK-READ-WIRED RQB 0 BLOCK)
     61    (COND ((NOT WRITE-P)                        ;This can modify pages without setting
     62           (SI:DISK-READ-WIRED RQB 0 BLOCK)     ; the modified bits, but as long as
     63                                                ; we dont depend on data after its unwired,
     64                                                ; it wont hurt.
    7065           (ARRAY-TO-NET BUF CONN (* QUANTUM PAGE-SIZE 2)))
    7166          (T (ARRAY-FROM-NET BUF CONN (* QUANTUM PAGE-SIZE 2))
     
    7772 (AND CONN (CHAOS:REMOVE-CONN CONN))))
    7873
    79 (DEFUN ARRAY-TO-NET (BUF CONN &OPTIONAL (NHWDS (ARRAY-LENGTH BUF))
     74(DEFUN ARRAY-TO-NET (BUF CONN &OPTIONAL (NHWDS (ARRAY-LENGTH BUF)) (OPCODE 300)
    8075                     &AUX PKT (N (// CHAOS:MAX-DATA-BYTES-PER-PKT 2)))
    8176  (DO I 0 (+ I N) (
     
    8681                        PKT CHAOS:FIRST-DATA-WORD-IN-PKT (+ CHAOS:FIRST-DATA-WORD-IN-PKT N))
    8782    (SETF (CHAOS:PKT-NBYTES PKT) (* N 2))
    88     (CHAOS:SEND-PKT CONN PKT 300)))
    89 
    90 (DEFUN ARRAY-FROM-NET (BUF CONN &OPTIONAL (NHWDS (ARRAY-LENGTH BUF))
    91                        &AUX PKT N)
    92   (DO I 0 (+ I N) (
     83    (CHAOS:SEND-PKT CONN PKT OPCODE)))
     84
     85(DEFUN ARRAY-FROM-NET (BUF CONN &OPTIONAL (NHWDS (ARRAY-LENGTH BUF)) PKT PKT-OFFSET
     86                       &AUX N LIM BUFLIM)
     87  (DO ((I 0 LIM))
     88      ((
    9389 I NHWDS)
    94     (SETQ PKT (CHAOS:GET-NEXT-PKT CONN))
    95     (SETQ N (// (CHAOS:PKT-NBYTES PKT) 2))
    96     (COPY-ARRAY-PORTION PKT CHAOS:FIRST-DATA-WORD-IN-PKT (+ CHAOS:FIRST-DATA-WORD-IN-PKT N)
    97                         BUF I (+ I N))
    98     (CHAOS:RETURN-PKT PKT)))
     90       (AND ( I NHWDS)
     91            (VALUES PKT PKT-OFFSET)))
     92    (OR PKT
     93        (SETQ PKT (CHAOS:GET-NEXT-PKT CONN)
     94              PKT-OFFSET CHAOS:FIRST-DATA-WORD-IN-PKT))
     95    (SETQ N (- (+ CHAOS:FIRST-DATA-WORD-IN-PKT (// (CHAOS:PKT-NBYTES PKT) 2)) PKT-OFFSET)
     96          LIM (+ I N)
     97          BUFLIM (MIN NHWDS LIM))
     98    (COPY-ARRAY-PORTION PKT PKT-OFFSET (SETQ PKT-OFFSET (+ PKT-OFFSET (- BUFLIM I)))
     99                        BUF I BUFLIM)
     100    (COND ((= LIM BUFLIM)
     101           (CHAOS:RETURN-PKT PKT)
     102           (SETQ PKT NIL)))))
    99103
    100104(DEFUNP RECEIVE-BAND (FROM-MACHINE FROM-PART TO-PART
     
    103107                           PART-BASE ORIG-PART-BASE PART-SIZE PART-COMMENT (N-HUNDRED 0))
    104108 (UNWIND-PROTECT (PROGN
    105   (MULTIPLE-VALUE (PART-BASE PART-SIZE) (SYS:FIND-DISK-PARTITION TO-PART))
    106   (OR PART-BASE
    107       (RETURN (FORMAT NIL "No /"~A/" partition here." TO-PART)))
     109  (MULTIPLE-VALUE (PART-BASE PART-SIZE NIL TO-PART) (FIND-DISK-PARTITION-FOR-WRITE TO-PART))
    108110  (SETQ CONN (CHAOS:CONNECT FROM-MACHINE
    109111                            (FORMAT NIL "BAND-TRANSFER READ ~A ~D"
    110112                                        FROM-PART (AND SUBSET-N-BLOCKS
    111113                                                       (LIST SUBSET-START SUBSET-N-BLOCKS)))
    112                             25.))
     114                            QUANTUM))
    113115  (AND (STRINGP CONN) (RETURN CONN))    ;Error message
    114116  ;; Receive packet containing size and comment
     
    117119  (SETQ TEM (LET ((IBASE 10.)) (READ-FROM-STRING STR)))
    118120  (OR (
    119  TEM PART-SIZE) (RETURN "Does not fit in local partition"))
     121 TEM PART-SIZE)
     122      (RETURN (FORMAT NIL "Does not fit in local partition, ~D>~D" TEM PART-SIZE)))
    120123  (SETQ PART-SIZE TEM)
    121124  (SETQ TEM (STRING-SEARCH-CHAR #\SP STR))
     
    143146  (OR SUBSET-N-BLOCKS (SI:UPDATE-PARTITION-COMMENT TO-PART PART-COMMENT 0)))
    144147 (AND RQB (SYS:RETURN-DISK-RQB RQB))
    145  (AND CONN (NOT (STRINGP CONN)) (CHAOS:REMOVE-CONN CONN))))
     148 (AND CONN (NOT (STRINGP CONN)) (CHAOS:REMOVE-CONN CONN)))
     149 T)
    146150
    147151(DEFUNP COMPARE-BAND (FROM-MACHINE FROM-PART TO-PART   
     
    150154                           PART-BASE PART-SIZE PART-COMMENT (N-HUNDRED 0))
    151155 (UNWIND-PROTECT (PROGN
    152   (MULTIPLE-VALUE (PART-BASE PART-SIZE) (SYS:FIND-DISK-PARTITION TO-PART))
    153   (OR PART-BASE
    154       (RETURN (FORMAT NIL "No /"~A/" partition here." TO-PART)))
     156  (MULTIPLE-VALUE (PART-BASE PART-SIZE) (FIND-DISK-PARTITION-FOR-READ TO-PART))
    155157  (SETQ CONN (CHAOS:CONNECT FROM-MACHINE
    156158                            (FORMAT NIL "BAND-TRANSFER READ ~A ~D"
    157159                                        FROM-PART (AND SUBSET-N-BLOCKS
    158160                                                       (LIST SUBSET-START SUBSET-N-BLOCKS)))
    159                             25.))
     161                            QUANTUM))
    160162  (AND (STRINGP CONN) (RETURN CONN))    ;Error message
    161163  ;; Receive packet containing size and comment
     
    164166  (SETQ TEM (LET ((IBASE 10.)) (READ-FROM-STRING STR)))
    165167  (OR (
    166  TEM PART-SIZE) (RETURN "Does not fit in local partition"))
     168 TEM PART-SIZE)
     169      (RETURN (FORMAT NIL "Does not fit in local partition, ~D>~D" TEM PART-SIZE)))
    167170  (SETQ PART-SIZE TEM)
    168171  (SETQ TEM (STRING-SEARCH-CHAR #\SP STR))
     
    176179  (SETQ RQB (SYS:GET-DISK-RQB QUANTUM)
    177180        BUF (SYS:RQB-BUFFER RQB)
    178         BUF1 (MAKE-ARRAY NIL 'ART-16B (ARRAY-LENGTH BUF)))
     181        BUF1 (MAKE-ARRAY (ARRAY-LENGTH BUF) ':TYPE 'ART-16B))
    179182  (SETQ SI:DISK-ERROR-RETRY-COUNT 20.)  ;Try to bypass hardware overrun problem
    180183  (SI:WIRE-DISK-RQB RQB)
     
    204207  (CHAOS:CLOSE CONN "Done"))
    205208 (AND RQB (SYS:RETURN-DISK-RQB RQB))
    206  (AND CONN (NOT (STRINGP CONN)) (CHAOS:REMOVE-CONN CONN))))
     209 (AND CONN (NOT (STRINGP CONN)) (CHAOS:REMOVE-CONN CONN)))
     210 T)
    207211
    208212(DEFUNP TRANSMIT-BAND (FROM-PART TO-MACHINE TO-PART
     
    211215                            PART-BASE ORIG-PART-BASE PART-SIZE PART-COMMENT (N-HUNDRED 0))
    212216 (UNWIND-PROTECT (PROGN
    213   (MULTIPLE-VALUE (PART-BASE PART-SIZE) (SYS:FIND-DISK-PARTITION FROM-PART))
    214   (OR PART-BASE
    215       (RETURN (FORMAT NIL "No /"~A/" partition here." FROM-PART)))
    216   (SETQ PART-SIZE (GET-PARTITION-SIZE FROM-PART)
     217  (MULTIPLE-VALUE (PART-BASE PART-SIZE) (FIND-DISK-PARTITION-FOR-READ FROM-PART))
     218  (SETQ PART-SIZE (MEASURED-SIZE-OF-PARTITION FROM-PART)
    217219        PART-COMMENT (SI:PARTITION-COMMENT FROM-PART 0))
    218220  (SETQ CONN (CHAOS:CONNECT TO-MACHINE
     
    239241    (AND ( (SETQ TEM (// (- BLOCK ORIG-PART-BASE) 100.)) N-HUNDRED)
    240242         (FORMAT T "~D " (SETQ N-HUNDRED TEM)))
    241     (SI:DISK-READ-WIRED RQB 0 BLOCK)
     243    (SI:DISK-READ-WIRED RQB 0 BLOCK)    ;Modifies pages without setting modified bits.
     244                                        ;This is ok since it remains wired while we care.
    242245    (ARRAY-TO-NET BUF CONN (* QUANTUM PAGE-SIZE 2)))
    243246  (CHAOS:FINISH CONN)
    244247  (CHAOS:CLOSE CONN "Done"))
    245248 (AND RQB (SYS:RETURN-DISK-RQB RQB))
    246  (AND CONN (NOT (STRINGP CONN)) (CHAOS:REMOVE-CONN CONN))))
     249 (AND CONN (NOT (STRINGP CONN)) (CHAOS:REMOVE-CONN CONN)))
     250 T)
    247251
    248252(ADD-INITIALIZATION "BAND-TRANSFER"
    249                     '(PROCESS-RUN-FUNCTION "Band-Transfer" 'BAND-TRANSFER-SERVER)
     253                    '(PROCESS-RUN-TEMPORARY-FUNCTION
     254                       "BAND-TRANSFER Server" 'BAND-TRANSFER-SERVER)
    250255                    NIL 'CHAOS:SERVER-ALIST)
  • trunk/lisp/lispm2/class.lisp

    r245 r278  
    7777;   (LEXPR-FUNCALL (SYMEVAL-IN-CLOSURE CLASS-SYMBOL 'CLASS-METHOD-SYMBOL) MESSAGE))
    7878
    79 (DEFUN UNCLAIMED-MESSAGE (KEY &REST REST)  ;GET TO HERE VIA TAIL POINTER ON OBJECT-CLASS
    80   (FERROR NIL "The object ~S received a ~S message, which went unclaimed.
     79;; GET TO HERE VIA TAIL POINTER ON OBJECT-CLASS
     80;; Flavors now use FLAVOR-UNCLAIMED-MESSAGE by default instead.
     81(DEFUN UNCLAIMED-MESSAGE (KEY &REST REST)
     82  (FERROR ':UNCLAIMED-MESSAGE "The object ~S received a ~S message, which went unclaimed.
    8183The rest of the message was ~S~%" SELF KEY REST))
    8284
     
    193195                       ANS)))
    194196       ((NULL L) ANS)))
     197
     198;Returns the function a closure is closing around.
     199(DEFUN CLOSURE-FUNCTION (CLOSURE)
     200   (CHECK-ARG CLOSURE (OR (ENTITYP CLOSURE) (CLOSUREP CLOSURE)) "an entity or a closure")
     201   (CAR (%MAKE-POINTER DTP-LIST CLOSURE)))
    195202
    196203(DEFUN CLOSURE-COPY (CLOSURE &AUX CLOSURE1)
     
    443450  (<- (CLASS SELF) ':CLASS-SYMBOL-HIERARCHY))
    444451
    445 (DEFMETHOD (OBJECT-CLASS :PRINT) (&OPTIONAL (STREAM T) &REST IGNORE)
    446   (<-AS OBJECT-CLASS ':PRINT-SELF STREAM))
    447 
    448452(DEFMETHOD (OBJECT-CLASS :PRINT-SELF) (&OPTIONAL (STREAM T) &REST IGNORE &AUX TEM)
    449453  (COND ((NOT (ENTITYP SELF))
     
    501505;; This definition is sufficient except for objects with ideosyncratic handlers,
    502506;; which don't exist yet.
    503 (DEFMETHOD (OBJECT-CLASS :OPERATIONS) (&OPTIONAL (SUPERIORS-FLAG T))
     507(DEFMETHOD (OBJECT-CLASS :WHICH-OPERATIONS) (&OPTIONAL (SUPERIORS-FLAG T))
    504508    (<- (CLASS SELF) ':CLASS-OPERATIONS SUPERIORS-FLAG))
    505509
  • trunk/lisp/lispm2/defmac.lisp

    r244 r278  
    5353(DECLARE (SPECIAL OPTIONAL-SPECIFIED-FLAGS))
    5454
     55;; This is set to T if the pattern used &body instead of &rest.
     56;; This allows us to tell ZWEI about how to indent the form.
     57(DECLARE (SPECIAL DEFMACRO-&BODY-FLAG))
     58
    5559;; X is the cdr of the DEFMACRO form.  TYPE is MACRO or MACRO-DISPLACE.
    5660(DEFUN DEFMACRO1 (X TYPE)
    57   (LET (*VARLIST* *VALLIST* OPTIONAL-SPECIFIED-FLAGS)
     61  (LET (*VARLIST* *VALLIST* OPTIONAL-SPECIFIED-FLAGS DEFMACRO-&BODY-FLAG)
    5862    (LET ((PAIR (DEFMACRO-&MUMBLE-CHEVEUX (CADR X) '(CDR *MACROARG*) 0 (CADR X))))
    5963     `(LOCAL-DECLARE ((ARGLIST . ,(CADR X)))
    60        (,TYPE ,(CAR X) (*MACROARG*)
     64       ,@(AND DEFMACRO-&BODY-FLAG
     65              `((EVAL-WHEN (EVAL COMPILE LOAD)
     66                  (DEFMACRO-SET-INDENTATION-FOR-ZWEI ',(CAR X) ',(CAR PAIR)))))
     67       (,TYPE ,(STANDARDIZE-FUNCTION-SPEC (CAR X)) (*MACROARG*)
    6168        ,@(COND ((AND DEFMACRO-CHECK-ARGS
    6269                      (NOT (AND (ZEROP (CAR PAIR))
     
    7582                               `(,',(CADR X) ,*MACROARG*)))))
    7683                (T NIL))
    77         ;; Don't use LET here if no optional-specified-flags, since that would
    78         ;; cause infinite recursion since LET is defined with DEFMACRO
    79         ,(COND (OPTIONAL-SPECIFIED-FLAGS
    80                 `(LET ,OPTIONAL-SPECIFIED-FLAGS
    81                    ((LAMBDA ,*VARLIST* . ,(CDDR X))
    82                     . ,*VALLIST*)))
    83                (`((LAMBDA ,*VARLIST* . ,(CDDR X))
    84                     . ,*VALLIST*))))))))
    85 
    86 (DEFMACRO DESTRUCTURING-BIND (VARIABLES DATA . BODY)
    87   (LET (*VARLIST* *VALLIST* OPTIONAL-SPECIFIED-FLAGS)
     84        ,(DEFMACRO2 (NREVERSE *VARLIST*) (NREVERSE *VALLIST*)
     85                    OPTIONAL-SPECIFIED-FLAGS (CDDR X)))))))
     86
     87;; Put together the various bindings and the body.
     88;; The VARS are bound sequentially since their initializations may depend
     89;; on each other (in left-to-right fashion).
     90(DEFUN DEFMACRO2 (VARS VALS FLAGS BODY)
     91  (COND (FLAGS `((LAMBDA ,FLAGS ,(DEFMACRO2 VARS VALS NIL BODY))
     92                 . ,(MAKE-LIST (LENGTH FLAGS))))
     93        (VARS `((LAMBDA (,(CAR VARS)) ,(DEFMACRO2 (CDR VARS) (CDR VALS) NIL BODY))
     94                ,(CAR VALS)))
     95        ((CDR BODY) `(PROGN . ,BODY))
     96        (T (CAR BODY))))
     97
     98(DEFMACRO DESTRUCTURING-BIND (VARIABLES DATA &BODY BODY)
     99  (LET (*VARLIST* *VALLIST* OPTIONAL-SPECIFIED-FLAGS DEFMACRO-&BODY-FLAG)
    88100    (DEFMACRO-&MUMBLE-CHEVEUX VARIABLES DATA 0 VARIABLES)
    89     `(LET ,OPTIONAL-SPECIFIED-FLAGS
    90        ((LAMBDA ,*VARLIST* . ,BODY)
    91         . ,*VALLIST*))))
     101    (DEFMACRO2 (NREVERSE *VARLIST*) (NREVERSE *VALLIST*) OPTIONAL-SPECIFIED-FLAGS BODY)))
    92102
    93103;; STATE is 0 for mandatory args, 1 for optional args, 2 for rest args, 3 for aux vars.
     
    111121              (COND ((> STATE 0) (ERROR '|-- bad pattern to DEFMACRO.| EPAT))
    112122                    (T (DEFMACRO-&MUMBLE-CHEVEUX (CDR PATTERN) PATH 1 EPAT))))
    113              ((EQ (CAR PATTERN) '&REST)
     123             ((MEMQ (CAR PATTERN) '(&REST &BODY))
     124              (AND (EQ (CAR PATTERN) '&BODY)
     125                   (SETQ DEFMACRO-&BODY-FLAG T))
    114126              (COND ((> STATE 1) (ERROR '|-- bad pattern to DEFMACRO.| EPAT))
    115127                    (T (DEFMACRO-&MUMBLE-CHEVEUX (CDR PATTERN) PATH 2 EPAT))))
     
    208220       (COND ((NULL (CDR PAIR)) (RPLACA PAIR (1+ (CAR PAIR))))
    209221             (T (RPLACA (RPLACD PAIR (1+ (CDR PAIR))) (1+ (CAR PAIR))))))
    210 
  • trunk/lisp/lispm2/defsel.lisp

    r245 r278  
    1 ;;; -*- Mode: LISP; Package: SYSTEM-INTERNALS -*-
     1;; -*- Mode: LISP; Package: SYSTEM-INTERNALS; Lowercase: T -*-
    22;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
    33
     
    55;;; objects that use the DTP-SELECT-METHOD microcode feature to allow
    66;;; destructuring of args on a per-operation basis
     7
     8;--- Someone should fix this to use a new kind of function spec instead
     9;--- of using symbols, to hold its methods.
    710
    811;(DEFSELECT <function-name or (<function-name> <function-to-be-called-if-no-match>)>
     
    1619;           (SPZZA)))
    1720
    18 (declare (special **defselect-alist** **defselect-function**))
     21(declare (special **defselect-alist** **defselect-fspec** **defselect-fname**))
    1922
    20 (defmacro DEFSELECT (**defselect-function** &rest methods &aux no-which-operations)
     23(defmacro DEFSELECT (**defselect-fspec** &body methods &aux no-which-operations)
    2124  (let ((**defselect-alist** nil)
    2225        (tail-pointer)
    23         (wo-list-name))
    24      (cond ((listp **defselect-function**)
    25             (setq tail-pointer (cadr **defselect-function**)
    26                   no-which-operations (caddr **defselect-function**))
    27             (setq **defselect-function** (car **defselect-function**))))
     26        (wo-list-name)
     27        **defselect-fname**)
     28     (cond ((listp **defselect-fspec**)
     29            (setq tail-pointer (cadr **defselect-fspec**)
     30                  no-which-operations (caddr **defselect-fspec**))
     31            (setq **defselect-fspec** (car **defselect-fspec**))))
     32     (setq **defselect-fspec** (standardize-function-spec **defselect-fspec**))
     33     (setq **defselect-fname**
     34           (if (listp **defselect-fspec**)
     35               (intern (format nil "~A" **defselect-fspec**))
     36               **defselect-fspec**))
    2837     (setq wo-list-name
    29            (intern (string-append "{" **defselect-function** "-" "WHICH-OPERATIONS" "}")))
     38           (intern
     39             (string-append **defselect-fname** "-DEFSELECT-" ':WHICH-OPERATIONS "-METHOD")
     40             (symbol-package **defselect-fname**)))
    3041    `(progn 'COMPILE
    3142       ,@(mapcar (function defselect-internal) methods)
    3243       (declare (special ,wo-list-name))
     44       ,@(cond ((not no-which-operations)
     45                (list
     46                 (defselect-internal
     47                   `(:which-operations (&rest ignore)
     48                        ;; Do this at runtime because of possible tail pointers.
     49                        (cond (,wo-list-name)
     50                              (t (setq ,wo-list-name
     51                                       (defselect-make-which-operations
     52                                         ',**defselect-fspec**))))))
     53                 (defselect-internal
     54                   `(:operation-handled-p (operation)
     55                        (if (null ,wo-list-name)
     56                            (setq ,wo-list-name
     57                                  (defselect-make-which-operations
     58                                    ',**defselect-fspec**)))
     59                        (memq operation ,wo-list-name)))
     60                 (defselect-internal
     61                   `(:send-if-handles (operation &rest arguments)
     62                        (if (null ,wo-list-name)
     63                            (setq ,wo-list-name
     64                                  (defselect-make-which-operations
     65                                    ',**defselect-fspec**)))
     66                        (if (memq operation ,wo-list-name)
     67                            (lexpr-funcall (fdefinition ',**defselect-fspec**)
     68                                           operation arguments)))))))
     69       ,(and (atom **defselect-fspec**) `(declare (*EXPR ,**defselect-fspec**)))
     70       (defselect-add-methods ',**defselect-fspec** ',**defselect-alist** ',tail-pointer)
     71       ,(and tail-pointer
     72             `(eval-when (compile) (compiler:function-referenced ',tail-pointer
     73                                                                 ',**defselect-fspec**)))
    3374       ,(or no-which-operations
    34             (defselect-internal
    35               `(:WHICH-OPERATIONS (&rest ignore)
    36                  (cond (,wo-list-name)  ;Do this at runtime because of possible tail pointers.
    37                        (t (setq ,wo-list-name
    38                                 (defselect-make-which-operations
    39                                   ',**defselect-function**)))))))
    40        (declare (*EXPR ,**defselect-function**))
    41        (defselect-add-methods ',**defselect-function** ',**defselect-alist** ',tail-pointer)
    42        ,(or no-which-operations
    43             `(setq ,wo-list-name nil)))))
     75            `(setq ,wo-list-name nil))
     76       ',**defselect-fspec**)))
    4477
    4578
    4679(defun defselect-make-which-operations (fctn)
     80  ;; Ignore tracing, decode full hair, (:property foo bar), etc
     81  (setq fctn (fdefinition (unencapsulate-function-spec fctn)))
    4782  (prog (ops subr)
    4883    l   (cond ((or (null fctn)
    4984                   (and (symbolp fctn)
    5085                        (not (fboundp fctn))))
    51                (return ops))
     86               ;; This cdr-codes the list, and conses it safely away from temporary areas.
     87               (return (copylist ops permanent-storage-area)))
    5288              ((symbolp fctn)
    5389               (setq fctn (fsymeval fctn)))
     
    5894                            (t (setq subr (cdr fctn)    ;explore subroutine
    5995                                     fctn (car fctn)))))
    60                      ((eq (caar fctn) ':which-operations)   ;Dont add that.
     96                     ((memq (caar fctn)                 ;Dont add these
     97                            '(:which-operations :operation-handled-p :send-if-handles))
    6198                      (setq fctn (cdr fctn)))
    6299                     (t (setq ops (cons (caar fctn) ops))
     
    77114          (do ((l (cdar method) (cdr l))
    78115               (name (cond ((atom (cdr method)) (cdr method))
    79                            (t (intern (string-append "{" **defselect-function** "-"
    80                                                      (caar method) "}"))))))
     116                           (t (intern (string-append **defselect-fname** "-DEFSELECT-"
     117                                                     (caar method) "-METHOD")
     118                                      (symbol-package **defselect-fname**))))))
    81119              ((null l))
    82120              (setq **defselect-alist** (cons (cons (car l) name) **defselect-alist**)))))
     
    85123                                                  **defselect-alist**))
    86124                  nil)
    87                  (t (let ((name (intern (string-append "{" **defselect-function** "-"
    88                                                        (car method) "}"))))
     125                 (t (let ((name (intern (string-append **defselect-fname** "-DEFSELECT-"
     126                                                       (car method) "-METHOD")
     127                                        (symbol-package **defselect-fname**))))
    89128                      (setq **defselect-alist** (cons (cons (car method) name)
    90129                                                      **defselect-alist**))
    91130                      `(defun ,name
    92                         ,(cons '**defselect-op**       ;First argument is operation
     131                        ,(cons '**defselect-op**       ;First argument is operation
    93132                                (cadr method))          ;Remaining args are those specified
     133                         (declare (function-parent ,**defselect-fname**))
    94134                         **defselect-op**               ;Suppress bound but not used warning
    95135                         . ,(cddr method))))))))
    96136
    97137(defun defselect-add-methods (function alist &optional tail-pointer)
    98   (let ((current-definition (and (fboundp function)
    99                                  (= (%data-type (fsymeval function)) dtp-select-method)
    100                                  (%make-pointer dtp-list (fsymeval function)))))
     138  (let ((current-definition (if (listp function)
     139                                (get (car function) (cadr function))
     140                                (and (fboundp function)
     141                                     (fsymeval function)))))
     142    (setq current-definition (if (= (%data-type current-definition) dtp-select-method)
     143                                 (%make-pointer dtp-list current-definition)))
    101144    (do ((next-alist alist (cdr next-alist)))
    102145        ((null next-alist))
  • trunk/lisp/lispm2/disass.lisp

    r245 r278  
    99  (COND ((= (%DATA-TYPE FUNCTION) DTP-FEF-POINTER)
    1010         (SETQ FEF FUNCTION))
    11         ((SETQ FEF (FDEFINITION FUNCTION))))
     11        ((SETQ FEF (FDEFINITION (SI:UNENCAPSULATE-FUNCTION-SPEC FUNCTION)))))
    1212  (COND ((AND (LISTP FEF)
    1313              (EQ (CAR FEF) 'MACRO))
     
    1717      (FERROR NIL "Can't find FEF for ~S" FUNCTION))
    1818  (SETQ LIM-PC (DISASSEMBLE-LIM-PC FEF))
    19   (DO PC (SI:FEF-INITIAL-PC FEF) (+ PC ILEN) (>= PC LIM-PC)
     19  (DO PC (FEF-INITIAL-PC FEF) (+ PC ILEN) (>= PC LIM-PC)
    2020    (TERPRI)
    2121    (SETQ ILEN (DISASSEMBLE-INSTRUCTION FEF PC)))
    22   (TERPRI))
     22  (TERPRI)
     23  FUNCTION)
    2324
    2425(DEFUN DISASSEMBLE-LIM-PC (FEF &AUX LIM-PC)
     
    100101;; Print out the disassembly of an instruction source address.
    101102;; REG is the register number of the address, and DISP is the displacement.
    102 (DEFUN DISASSEMBLE-ADDRESS (FEF REG DISP &AUX PTR OFFSET TEM LOC)
     103(DEFUN DISASSEMBLE-ADDRESS (FEF REG DISP &AUX PTR OFFSET TEM LOC CELL)
    103104  (TYO 40)
    104105  (COND ((< REG 4)
     
    109110                           (SETQ TEM (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF DISP)))
    110111                      OFFSET (%POINTER-DIFFERENCE TEM PTR))
    111                 (LET ((CELL (NTH OFFSET '("@+0?? " "" "#'"
    112                                           "@PLIST-HEAD-CELL " "@PACKAGE-CELL "))))
    113                   (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
    114                       (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN PTR CELL LOC)
    115                       (PRINC CELL)
    116                       (PRIN1 PTR) )))
     112                (COND ((SYMBOLP PTR)
     113                       (SETQ CELL (NTH OFFSET '("@+0?? " "" "#'"
     114                                                "@PLIST-HEAD-CELL " "@PACKAGE-CELL "))))
     115                      ((LISTP PTR)
     116                       (SETQ PTR (SI:METH-FUNCTION-SPEC PTR) CELL "#'"))
     117                      (T (SETQ CELL "")))
     118                (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
     119                    (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN PTR CELL LOC)
     120                    (PRINC CELL)
     121                    (PRIN1 PTR) ))
    117122               (T
    118123                (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
     
    177182         (%P-LDB-OFFSET %%Q-LOW-HALF FEF IDX))
    178183        ((%P-LDB-OFFSET %%Q-HIGH-HALF FEF IDX))))
     184
  • trunk/lisp/lispm2/flavor.lisp

    r248 r278  
    1 ; Tasteful Flavors                      -*- Mode: Lisp; Package: SI -*-
     1; Tasteful Flavors                      -*- Mode: Lisp; Package: SI; Base:8 -*-
    22
    33; A flavor-name is a symbol which names a type of objects defined
     
    2121; DEFWRAPPER - macro for defining a flavor-wrapper
    2222; INSTANTIATE-FLAVOR - create an object of a specified flavor
     23; MAKE-INSTANCE - easier to call version of INSTANTIATE-FLAVOR
    2324; COMPILE-FLAVOR-METHODS - macro which does the right thing in the compiler
    2425; RECOMPILE-FLAVOR - function to recompile a flavor and maybe any flavors
     
    3334; LEXPR-FUNCALL-SELF - LEXPR-FUNCALL version of above
    3435; *ALL-FLAVOR-NAMES* - list of all symbols which have been used as the name of a flavor
     36; *ALL-FLAVOR-NAMES-AARRAY* - completion aarray of flavor names to flavors.
     37;               Each flavor is included twice, once with and once without its package prefix.
    3538; *FLAVOR-COMPILATIONS* - list of all methods which had to be compiled
    3639;               this is useful for finding flavors which weren't compiled in qfasl files
    3740;               or which need to be recompiled to bring them up to date.
     41; *FLAVOR-COMPILE-TRACE* - if non-NIL, a FORMAT destination for messages about
     42;               recompilation of combined methods
    3843; FLAVOR-ALLOWS-INIT-KEYWORD-P - determine whether a certain flavor allows
    3944;               a certain keyword in its init-plist.
     
    7479  ; (:REQUIRED-METHODS m1 m2...) - any flavor incorporating this
    7580  ;   flavor and actually instantiated must have methods for the specified
    76   ;   messages.  This is used for defining general types of flavors.
     81  ;   operations.  This is used for defining general types of flavors.
     82  ; (:REQUIRED-FLAVORS f1 f2...) - similar,  for component flavors
     83  ;   rather than methods.
    7784  ; (:INITABLE-INSTANCE-VARIABLES v1 v2...) - these instance variables
    7885  ;   may be initialized via the options to INSTANTIATE-FLAVOR.
    7986  ;   The atomic form works too.
    8087  ;   Settable instance variables are also initable.
    81   ; (:INIT-KEYWORDS k1 k2...) - specifies keywords for the :INIT message
     88  ; (:INIT-KEYWORDS k1 k2...) - specifies keywords for the :INIT operation
    8289  ;   which are legal to give to this flavor.  Just used for error checking.
    8390  ; (:DEFAULT-INIT-PLIST k1 v1 k2 v2...) - specifies defaults to be put
     
    106113  ;   at run-time.
    107114  ;   The atomic form works too.
     115  ; (:ACCESSOR-PREFIX sym) - uses "sym" as the prefix on the names of the above
     116  ;   defsubsts instead of "flavor-".
    108117  ; (:SELECT-METHOD-ORDER m1 m2...) - specifies that the keywords m1, m2, ... are
    109118  ;   are important and should have their methods first in the select-method
    110119  ;   table for increased efficiency.
    111   ; (:METHOD-COMBINATION (type order message1 message2...)...)
     120  ; (:METHOD-COMBINATION (type order operation1 operation2...)...)
    112121  ;   Specify ways of combining methods from different flavors.  :DAEMON NIL is the
    113122  ;   the default.  order is usually :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST,
     
    132141                                          INSTANCE-VARIABLES))))
    133142                   (CDR VS))
     143               (PREFIX (OR (CADR (ASSQ-CAREFUL ':ACCESSOR-PREFIX OPTIONS))
     144                           (STRING-APPEND NAME "-")))
    134145               (ORDS (DO ((OPTS OPTIONS (CDR OPTS)))
    135146                         ((NULL OPTS) NIL)
     
    140151                            (RETURN (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X)))
    141152                                            INSTANCE-VARIABLES)))))
    142                (RES NIL (CONS `(DEFSUBST ,(INTERN1 (FORMAT NIL "~A-~A" NAME (CAR VS))) (,NAME)
     153               (RES NIL (CONS `(DEFSUBST ,(INTERN1 (STRING-APPEND PREFIX (CAR VS))) (,NAME)
    143154                                 ,(IF (MEMQ (CAR VS) ORDS)
    144155                                      `(%INSTANCE-REF ,NAME
     
    156167     (EVAL-WHEN (LOAD EVAL)
    157168       ;; Verify the existence of the instance-variable get/set methods at load time
    158        (COMPOSE-AUTOMATIC-METHODS (GET ',NAME 'FLAVOR)))))
     169       (COMPOSE-AUTOMATIC-METHODS (GET ',NAME 'FLAVOR)))
     170     ',NAME))
    159171
    160172; This wraps a local-declare special of the instance variables around its body.
    161173; It's good for things like defining functions that deal with a flavor but
    162174; are not methods (generally they are called by methods.)
    163 (DEFMACRO DECLARE-FLAVOR-INSTANCE-VARIABLES ((FLAVOR-NAME) . BODY)
    164   `(LOCAL-DECLARE (,(FLAVOR-SPECIAL-DECLARATION FLAVOR-NAME))
    165      . ,BODY))
    166 
    167 ; This lets you specify code to be wrapped around the invocation of the
    168 ; various methods for a message.  For example,
    169 ; (DEFWRAPPER (FOO-FLAVOR :MESSAGE) ((ARG1 ARG2) . BODY)
    170 ;   `(WITH-FOO-LOCKED (SELF)
    171 ;      (PRE-FROBULATE SELF ,ARG1 ,ARG2)
    172 ;      ,@BODY
    173 ;      (POST-FROBULATE SELF ,ARG2 ,ARG1)))
    174 ;Note that the wrapper needs to be defined at both compile and run times
    175 ;so that compiling combined methods as part of the qfasl file works.
    176 (DEFMACRO DEFWRAPPER ((FLAVOR-NAME MESSAGE) (DEFMACRO-LAMBDA . GUTS)
    177                       . BODY)
    178   `(PROGN 'COMPILE
    179        ;; At compile-time, add enough information so that combined-methods
    180        ;; can be compiled.  The compile-time definition of macros does not
    181        ;; go through FDEFINE, so this is necessary to record the existence
    182        ;; of the wrapper.
    183        ,(AND (GET FLAVOR-NAME 'FLAVOR)
    184              COMPILER:QC-FILE-IN-PROGRESS
    185              `(EVAL-WHEN (COMPILE)
    186                  (FLAVOR-NOTICE-METHOD '(,FLAVOR-NAME :WRAPPER ,MESSAGE))))
    187        (EVAL-WHEN (COMPILE LOAD EVAL) ;Wrapper defs needed to stay around between files
    188          ;; The following optimization could go away if defmacro was made very smart
    189          ,(IF (AND (SYMBOLP DEFMACRO-LAMBDA) (STRING-EQUAL DEFMACRO-LAMBDA 'IGNORE))
    190              `(DEFMACRO (:METHOD ,FLAVOR-NAME :WRAPPER ,MESSAGE) (IGNORE . ,GUTS)
    191                 . ,BODY)
    192              `(DEFMACRO (:METHOD ,FLAVOR-NAME :WRAPPER ,MESSAGE) (ARGLISTNAME . ,GUTS)
    193                 `(DESTRUCTURING-BIND ,',DEFMACRO-LAMBDA (CDR ,ARGLISTNAME)
    194                                            ,,@BODY))))))
     175(DEFMACRO DECLARE-FLAVOR-INSTANCE-VARIABLES ((FLAVOR-NAME) &BODY BODY)
     176  (LET ((SPECIAL-DECLARATION (FLAVOR-SPECIAL-DECLARATION FLAVOR-NAME)))
     177    (IF SPECIAL-DECLARATION
     178        `(LOCAL-DECLARE (,SPECIAL-DECLARATION) . ,BODY)
     179        ;Don't do a (LOCAL-DECLARE (NIL) ...)
     180        `(PROGN 'COMPILE . ,BODY))))
     181
    195182
    196183(DEFVAR *ALL-FLAVOR-NAMES* NIL) ;List of names of all flavors (mostly for editor)
     184(DEFVAR *ALL-FLAVOR-NAMES-AARRAY*       ;For editor's completing reader
     185        (MAKE-ARRAY 2400                ;736 flavors in system 75
     186                    ':TYPE 'ART-Q-LIST
     187                    ':LEADER-LIST '(0 NIL)))
     188
     189(ADD-INITIALIZATION "Condense Flavor Name Tables"
     190                    '(PROGN (ZWEI:SORT-COMPLETION-AARRAY *ALL-FLAVOR-NAMES-AARRAY*)
     191                            (IF (= (%P-CDR-CODE *ALL-FLAVOR-NAMES*) CDR-NORMAL)
     192                                (SETQ *ALL-FLAVOR-NAMES* (COPYLIST *ALL-FLAVOR-NAMES*))))
     193                    '(:BEFORE-COLD))
     194
    197195(DEFVAR *JUST-COMPILING* NIL)   ;T means putting combined methods into qfasl file,
    198196                                ; not updating the current flavor data-structure
     
    201199(DEFVAR *FLAVOR-PENDING-DEPENDS* NIL)   ;Used by DEFFLAVOR1
    202200(DEFVAR *FLAVOR-COMPILATIONS* NIL)      ;List of methods compiled
     201(DEFVAR *FLAVOR-COMPILE-TRACE* NIL)
     202
     203;This is an area in which to cons data internal to the flavor system.  It is used
     204;rather than default-cons-area as a hedge against temporary area lossage which can
     205;happen if you do things from an error in a compilation, or if you make instances
     206;in a temporary area and that requires composing flavors or methods.
     207(DEFVAR *FLAVOR-AREA* WORKING-STORAGE-AREA)
    203208
    204209; These two functions are used when sending a message to yourself, for extra efficiency.
     
    214219; The data-structure on the FLAVOR property of a flavor-name
    215220; This must agree with INSTANCE-DESCRIPTOR-OFFSETS in LISPM;QCOM
    216 (EVAL-WHEN (COMPILE LOAD EVAL)
    217221(DEFSTRUCT (FLAVOR :NAMED :ARRAY (:CONSTRUCTOR MAKE-FLAVOR)
    218                                  (:MAKE-ARRAY (PERMANENT-STORAGE-AREA)))
     222                                 (:MAKE-ARRAY (:AREA PERMANENT-STORAGE-AREA)))
    219223  FLAVOR-INSTANCE-SIZE          ;1+ the number of instance variables
    220224  FLAVOR-BINDINGS               ;List of locatives to instance variable
     
    239243                                ; this flavor itself.  NIL means flavor-combination not
    240244                                ; composed yet.  This is used by TYPEP of 2 arguments.
    241   (FLAVOR-WHICH-OPERATIONS NIL) ;List of messages handled, created when needed.
     245  (FLAVOR-WHICH-OPERATIONS NIL) ;List of operations handled, created when needed.
    242246                                ; This is NIL if it has not been computed yet.
    243247  (FLAVOR-GETTABLE-INSTANCE-VARIABLES NIL)      ;List of them
    244248  (FLAVOR-SETTABLE-INSTANCE-VARIABLES NIL)      ;List of them
    245   (FLAVOR-INITABLE-INSTANCE-VARIABLES NIL)      ;option
     249  (FLAVOR-INITABLE-INSTANCE-VARIABLES NIL)
     250                                ;Alist from init keyword to name of variable
    246251  (FLAVOR-INIT-KEYWORDS NIL)                    ;option
    247252  (FLAVOR-PLIST NIL)            ;Esoteric things stored here as properties
    248253                                ;Known: :DEFAULT-HANDLER, :ORDERED-INSTANCE-VARIABLES,
    249                                 ; :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES,
     254                                ; :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES, :ACCESSOR-PREFIX,
    250255                                ; :REQUIRED-INSTANCE-VARIABLES, :REQUIRED-METHODS,
    251                                 ; :SELECT-METHOD-ORDER, :DEFAULT-INIT-PLIST
    252                                 ; :DOCUMENTATION
     256                                ; :REQUIRED-FLAVORS, :SELECT-METHOD-ORDER,
     257                                ; :DEFAULT-INIT-PLIST, :DOCUMENTATION, :NO-VANILLA-FLAVOR
    253258                                ; ADDITIONAL-SPECIAL-VARIABLES
    254259                                ; COMPILE-FLAVOR-METHODS
     
    256261                                ;ones in the keyword packages are allowed to be
    257262                                ;used by users.
    258   ))
     263                                ;Some of these are not used by the flavor system, they are
     264                                ;just remembered on the plist in case anyone cares.  The
     265                                ;flavor system does all its handling of them during the
     266                                ;expansion of the DEFFLAVOR macro.
     267  )
    259268
    260269;Named-structure handler for above structure, to make it print nicer
    261 (DEFUN FLAVOR (MESSAGE SELF &REST ARGS)
    262   (SELECTQ MESSAGE
    263     (:WHICH-OPERATIONS '(:PRINT :PRINT-SELF :DESCRIBE))
    264     ((:PRINT :PRINT-SELF)
    265             (FORMAT (CAR ARGS) "#<FLAVOR ~S internal-info ~O>"
    266                                (FLAVOR-NAME SELF) (%POINTER SELF)))
     270(DEFUN (FLAVOR NAMED-STRUCTURE-INVOKE) (OPERATION &OPTIONAL SELF &REST ARGS)
     271  (SELECTQ OPERATION
     272    (:WHICH-OPERATIONS '(:PRINT-SELF :DESCRIBE))
     273    ((:PRINT-SELF)
     274     (SI:PRINTING-RANDOM-OBJECT (SELF (CAR ARGS))
     275       (FORMAT (CAR ARGS) "FLAVOR ~S" (FLAVOR-NAME SELF))))
    267276    (:DESCRIBE (DESCRIBE-FLAVOR SELF))
    268     (OTHERWISE (FERROR NIL "~S unknown" MESSAGE))))
     277    (OTHERWISE (FERROR NIL "~S unknown" OPERATION))))
    269278
    270279;Format of flavor-method-table:
    271 ; ((message-name combination-type combination-type-arg
    272 ;       (method-type symbol)...)
    273 ;  ...)
    274 ; In the magic-list, there can be more than one symbol listed under a method-type,
     280; New format of a flavor-method-table entry is:
     281;   (message combination-type combination-order meth...)
     282; A meth is:
     283;   (function-spec definition plist)
     284; Thus the second element of a meth is actually a function-cell.
     285; The meth's are stored in permanent-storage-area so that they will be compact.
     286;    [That might not be the best area, the select-methods, and component
     287;     lists, and instanc-variable lists, and which-operations's, are also there.]
     288; A magic-list entry is:
     289;   (message combination-type combination-order (method-type function-spec...)...)
     290; In the magic-list, there can be more than one method listed under a method-type,
    275291; the base flavor always comes first.  The :COMBINED methods are elided from
    276292; the magic-list.
     
    302318; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST.
    303319
     320;Definitions of a meth (the datum which stands for a method)
     321
     322(DEFSTRUCT (METH :LIST :CONC-NAME (:CONSTRUCTOR NIL))
     323                ;No constructor because defstruct doesn't let me specify the area
     324  FUNCTION-SPEC
     325  DEFINITION
     326  (PLIST NIL))
     327
     328; If there is no definition, it contains DTP-NULL and a pointer to the meth
     329
     330; Extract the method-type of a meth
     331(DEFSUBST METH-METHOD-TYPE (METH)
     332  (AND (CDDDR (METH-FUNCTION-SPEC METH))
     333       (THIRD (METH-FUNCTION-SPEC METH))))
     334
     335; Return a meth of specified type from a list of meth's.
     336(DEFUN METH-LOOKUP (METHOD-TYPE METH-LIST)
     337  (LOOP FOR METH IN METH-LIST
     338        WHEN (EQ (METH-METHOD-TYPE METH) METHOD-TYPE)
     339          RETURN METH))
     340
     341(DEFUN NULLIFY-METHOD-DEFINITION (METH)
     342  (LET ((P (LOCF (METH-DEFINITION METH))))
     343    (%P-STORE-TAG-AND-POINTER P (+ (LSH (%P-CDR-CODE P) 6) DTP-NULL) METH)))
     344
     345(DEFUN METH-DEFINEDP (METH)
     346  ( (%P-DATA-TYPE (LOCF (METH-DEFINITION METH))) DTP-NULL))
     347
     348(DEFUN METHOD-PLIST (FUNCTION-SPEC)             ;For debugging ease only
     349  (METH-PLIST (FLAVOR-METHOD-ENTRY FUNCTION-SPEC T)))
     350
     351
     352(DEFPROP DEFFLAVOR "Flavor" DEFINITION-TYPE-NAME)
    304353
    305354;Function to define or redefine a flavor (used by DEFFLAVOR macro).
     
    311360;something incompatibly, in which case you will get a warning.
    312361(DEFUN DEFFLAVOR1 (FLAVOR-NAME INSTANCE-VARIABLES COMPONENT-FLAVORS OPTIONS
    313                    &AUX FFL PL ALREADY-EXISTS NO-VANILLA-P INSTV)
    314   ;; This can happen if you get an error in a compilation and do things.
    315   ;; Avoid arbitrary propagation of lossage and destruction.
    316   (FLAVOR-CHECK-FOR-TEMPORARY-AREA-LOSSAGE)
    317   (RECORD-SOURCE-FILE-NAME FLAVOR-NAME)
     362                   &AUX FFL ALREADY-EXISTS INSTV IDENTICAL-COMPONENTS
     363                        GETTABLE SETTABLE INITABLE INIT-KEYWORDS INCLUDES METH-COMB
     364                        NEW-PLIST (PL (LOCF NEW-PLIST))
     365                        (DEFAULT-CONS-AREA *FLAVOR-AREA*))
     366  (RECORD-SOURCE-FILE-NAME FLAVOR-NAME 'DEFFLAVOR)
    318367  (WITHOUT-INTERRUPTS
    319     (OR (MEMQ FLAVOR-NAME *ALL-FLAVOR-NAMES*)
    320         (PUSH FLAVOR-NAME *ALL-FLAVOR-NAMES*)))
    321   ;; If the flavor is being redefined, and the number or order of instance variables
    322   ;; or component-flavors is being changed, and this flavor or any that depends on it
    323   ;; has a select-method table (i.e. has probably been instantiated), give a warning
    324   ;; and disconnect from the old FLAVOR defstruct so that old instances will
    325   ;; retain the old information.
     368    (COND ((NOT (MEMQ FLAVOR-NAME *ALL-FLAVOR-NAMES*))
     369           (PUSH FLAVOR-NAME *ALL-FLAVOR-NAMES*)
     370           ;; Push on the name without the package prefix.
     371           (ARRAY-PUSH-EXTEND *ALL-FLAVOR-NAMES-AARRAY*
     372                              (CONS (GET-PNAME FLAVOR-NAME) FLAVOR-NAME))
     373           ;; Push on the name with the package prefix.
     374           (ARRAY-PUSH-EXTEND *ALL-FLAVOR-NAMES-AARRAY*
     375                              (LET ((PACKAGE NIL))
     376                                (CONS (FORMAT NIL "~S" FLAVOR-NAME) FLAVOR-NAME)))
     377           ;; Array is no longer sorted.
     378           (STORE-ARRAY-LEADER NIL *ALL-FLAVOR-NAMES-AARRAY* 1))))
     379  ;; Analyze and error check the instance-variable and component-flavor lists
    326380  (SETQ INSTV (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X))) INSTANCE-VARIABLES))
    327   (AND (SETQ ALREADY-EXISTS (GET FLAVOR-NAME 'FLAVOR))
    328        (OR (NOT (EQUAL INSTV (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X)))
    329                                      (FLAVOR-LOCAL-INSTANCE-VARIABLES ALREADY-EXISTS))))
    330            (NOT (EQUAL COMPONENT-FLAVORS (FLAVOR-DEPENDS-ON ALREADY-EXISTS)))
    331            ;; Look for change of INCLUDED-FLAVORS
    332            (LET ((IF (DO L OPTIONS (CDR L) (NULL L)
    333                          (AND (LISTP (CAR L)) (EQ (CAAR L) ':INCLUDED-FLAVORS)
    334                               (RETURN (CDAR L))))))
    335              (OR (MEMQ ':NO-VANILLA-FLAVOR OPTIONS) (MEMQ 'VANILLA-FLAVOR IF)
    336                  (SETQ IF (APPEND IF '(VANILLA-FLAVOR))))
    337              (NOT (EQUAL IF (FLAVOR-INCLUDES ALREADY-EXISTS)))))
    338        (SETQ ALREADY-EXISTS (PERFORM-FLAVOR-REDEFINITION FLAVOR-NAME)))
    339   ;; Make the information structure unless the flavor already exists.
    340   (LET ((FL (OR ALREADY-EXISTS (MAKE-FLAVOR FLAVOR-NAME FLAVOR-NAME))))
    341     (SETF (FLAVOR-PACKAGE FL) PACKAGE)
    342     (SETF (FLAVOR-LOCAL-INSTANCE-VARIABLES FL) INSTANCE-VARIABLES)
    343     (SETF (FLAVOR-DEPENDS-ON FL) COMPONENT-FLAVORS)
    344     (SETQ PL (LOCF (FLAVOR-PLIST FL)))
    345     ;; Process the options.
    346     (DO ((L OPTIONS (CDR L))
    347          (OPTION) (ARGS))
    348         ((NULL L))
    349       (IF (ATOM (CAR L))
    350           (SETQ OPTION (CAR L) ARGS NIL)
    351           (SETQ OPTION (CAAR L) ARGS (CDAR L)))
    352       (SELECTQ OPTION
     381  (DOLIST (IV INSTV)
     382    (IF (OR (NULL IV) (NOT (SYMBOLP IV)))
     383        (FERROR NIL "~S, which is not a symbol, was specified as an instance variable" IV)))
     384  (DOLIST (CF COMPONENT-FLAVORS)
     385    (IF (OR (NULL CF) (NOT (SYMBOLP CF)))
     386        (FERROR NIL "~S, which is not a symbol, was specified as a component flavor" CF)))
     387  ;; Certain properties are inherited from the old property list, while
     388  ;; others are generated afresh each time from the defflavor-options.
     389  (COND ((SETQ ALREADY-EXISTS (GET FLAVOR-NAME 'FLAVOR))
     390         (LOOP FOR (IND VAL) ON (FLAVOR-PLIST ALREADY-EXISTS) BY 'CDDR
     391               UNLESS (MEMQ IND '(:DEFAULT-HANDLER :ORDERED-INSTANCE-VARIABLES
     392                                  :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES :ACCESSOR-PREFIX
     393                                  :REQUIRED-INSTANCE-VARIABLES :REQUIRED-METHODS
     394                                  :REQUIRED-FLAVORS :SELECT-METHOD-ORDER
     395                                  :DEFAULT-INIT-PLIST :DOCUMENTATION :NO-VANILLA-FLAVOR))
     396                 DO (PUTPROP PL VAL IND))))
     397  ;; First, parse all the defflavor options into local variables so we can see
     398  ;; whether the flavor is being redefined incompatibly.
     399  (DO ((L OPTIONS (CDR L))
     400       (OPTION) (ARGS))
     401      ((NULL L))
     402    (IF (ATOM (CAR L))
     403        (SETQ OPTION (CAR L) ARGS NIL)
     404        (SETQ OPTION (CAAR L) ARGS (CDAR L)))
     405    (SELECTQ OPTION
    353406        (:GETTABLE-INSTANCE-VARIABLES
    354407          (VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION)
    355           (SETF (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL) (OR ARGS INSTV)))
     408          (SETQ GETTABLE (OR ARGS INSTV)))
    356409        (:SETTABLE-INSTANCE-VARIABLES
    357410          (VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION)
    358           (SETF (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL) (OR ARGS INSTV)))
     411          (SETQ SETTABLE (OR ARGS INSTV)))
    359412        (:INITABLE-INSTANCE-VARIABLES
    360413          (VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION)
    361           (SETF (FLAVOR-INITABLE-INSTANCE-VARIABLES FL) (OR ARGS INSTV)))
     414          (SETQ INITABLE (OR ARGS INSTV)))
    362415        (:INIT-KEYWORDS
    363           (SETF (FLAVOR-INIT-KEYWORDS FL) ARGS))
     416          (SETQ INIT-KEYWORDS ARGS))
    364417        (:INCLUDED-FLAVORS
    365           (SETF (FLAVOR-INCLUDES FL) ARGS))
     418          (SETQ INCLUDES ARGS))
    366419        (:NO-VANILLA-FLAVOR
    367           (SETQ NO-VANILLA-P T))
     420          (PUTPROP PL T OPTION))
    368421        (:ORDERED-INSTANCE-VARIABLES
    369422          (VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION)
     
    373426          (PUTPROP PL (OR ARGS INSTV) ':OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES))
    374427        (:METHOD-COMBINATION
    375           (DOLIST (DECL ARGS)
    376             (LET ((TYPE (CAR DECL)) (ORDER (CADR DECL)) ELEM)
    377               ;; Don't error-check TYPE now, its definition might not be loaded yet
    378               (DOLIST (MSG (CDDR DECL))
    379                 (OR (SETQ ELEM (ASSQ MSG (FLAVOR-METHOD-TABLE FL)))
    380                     (PUSH (SETQ ELEM (LIST* MSG NIL NIL NIL)) (FLAVOR-METHOD-TABLE FL)))
    381                 (SETF (SECOND ELEM) TYPE)
    382                 (SETF (THIRD ELEM) ORDER)))))
     428          (SETQ METH-COMB ARGS))
    383429        (:DEFAULT-HANDLER
    384430          (PUTPROP PL (CAR ARGS) OPTION))
    385         ((:REQUIRED-INSTANCE-VARIABLES :REQUIRED-METHODS :DOCUMENTATION
    386           :DEFAULT-INIT-PLIST :SELECT-METHOD-ORDER)
     431        ((:REQUIRED-INSTANCE-VARIABLES :REQUIRED-METHODS :REQUIRED-FLAVORS :DOCUMENTATION
     432          :DEFAULT-INIT-PLIST :SELECT-METHOD-ORDER :ACCESSOR-PREFIX)
    387433          (PUTPROP PL ARGS OPTION))
    388434        (OTHERWISE (FERROR NIL "~S unknown option to DEFFLAVOR" OPTION))))
    389     ;; Unless user has specially suppressed it, VANILLA-FLAVOR must be included
    390     ;; so as to get default methods for :PRINT, :DESCRIBE, :WHICH-OPERATIONS
    391     (OR NO-VANILLA-P
    392         (MEMQ 'VANILLA-FLAVOR (FLAVOR-INCLUDES FL))
    393         (SETF (FLAVOR-INCLUDES FL) (APPEND (FLAVOR-INCLUDES FL) '(VANILLA-FLAVOR))))
    394     ;; All settable instance variables should also be gettable.
    395     (DOLIST (V (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL))
    396       (OR (MEMQ V (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL))
    397           (PUSH V (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL))))
     435  ;; All settable instance variables should also be gettable and initable.
     436  (DOLIST (V SETTABLE)
     437    (OR (MEMQ V GETTABLE)
     438        (PUSH V GETTABLE))
     439    (OR (MEMQ V INITABLE)
     440        (PUSH V INITABLE)))
     441  ;; See whether there are any changes in component flavor structure from last time
     442  (SETQ IDENTICAL-COMPONENTS
     443        (AND ALREADY-EXISTS
     444             (EQUAL COMPONENT-FLAVORS (FLAVOR-DEPENDS-ON ALREADY-EXISTS))
     445             (EQUAL INCLUDES (FLAVOR-INCLUDES ALREADY-EXISTS))))
     446  ;; If the flavor is being redefined, and the number or order of instance variables
     447  ;; is being changed, and this flavor or any that depends on it
     448  ;; has a select-method table (i.e. has probably been instantiated), give a warning
     449  ;; and disconnect from the old FLAVOR defstruct so that old instances will
     450  ;; retain the old information.  The instance variables can get changed either
     451  ;; locally or by rearrangement of the component flavors.
     452  (AND ALREADY-EXISTS
     453       (NOT (AND (EQUAL (GET PL ':ORDERED-INSTANCE-VARIABLES)
     454                        (GET (LOCF (FLAVOR-PLIST ALREADY-EXISTS))
     455                             ':ORDERED-INSTANCE-VARIABLES))
     456                 (OR (EQUAL (FLAVOR-LOCAL-INSTANCE-VARIABLES ALREADY-EXISTS)
     457                            INSTANCE-VARIABLES)
     458                     (EQUAL (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X)))
     459                                    (FLAVOR-LOCAL-INSTANCE-VARIABLES ALREADY-EXISTS))
     460                            INSTV))
     461                 (OR IDENTICAL-COMPONENTS
     462                     (EQUAL (FLAVOR-RELEVANT-COMPONENTS ALREADY-EXISTS
     463                                                        COMPONENT-FLAVORS INCLUDES)
     464                            (FLAVOR-RELEVANT-COMPONENTS ALREADY-EXISTS
     465                                                        (FLAVOR-DEPENDS-ON ALREADY-EXISTS)
     466                                                        (FLAVOR-INCLUDES ALREADY-EXISTS))))))
     467       (SETQ ALREADY-EXISTS (PERFORM-FLAVOR-REDEFINITION FLAVOR-NAME)))
     468  ;; Make the information structure unless the flavor already exists.
     469  (LET ((FL (OR ALREADY-EXISTS (MAKE-FLAVOR FLAVOR-NAME FLAVOR-NAME))))
     470    (SETF (FLAVOR-PACKAGE FL) PACKAGE)
     471    (SETF (FLAVOR-LOCAL-INSTANCE-VARIABLES FL) INSTANCE-VARIABLES)
     472    (SETF (FLAVOR-DEPENDS-ON FL) COMPONENT-FLAVORS)
     473    (SETF (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL) GETTABLE)
     474    (SETF (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL) SETTABLE)
     475    (SETF (FLAVOR-INITABLE-INSTANCE-VARIABLES FL)
     476          (LOOP FOR V IN INITABLE COLLECT (CONS (CORRESPONDING-KEYWORD V) V)))
     477    (SETF (FLAVOR-INIT-KEYWORDS FL) INIT-KEYWORDS)
     478    (SETF (FLAVOR-INCLUDES FL) INCLUDES)
     479    (SETF (FLAVOR-PLIST FL) NEW-PLIST)
     480    (DOLIST (DECL METH-COMB)
     481      (LET ((TYPE (CAR DECL)) (ORDER (CADR DECL)) ELEM)
     482        ;; Don't error-check TYPE now, its definition might not be loaded yet
     483        (DOLIST (MSG (CDDR DECL))
     484          (OR (SETQ ELEM (ASSQ MSG (FLAVOR-METHOD-TABLE FL)))
     485              (PUSH (SETQ ELEM (LIST* MSG NIL NIL NIL)) (FLAVOR-METHOD-TABLE FL)))
     486          (SETF (SECOND ELEM) TYPE)
     487          (SETF (THIRD ELEM) ORDER))))
    398488    ;; Make this a depended-on-by of its depends-on, or remember to do it later in
    399489    ;; the case of depends-on's not yet defined.
     
    419509               (SETQ *FLAVOR-PENDING-DEPENDS* (DELQ X *FLAVOR-PENDING-DEPENDS*))))))
    420510    (PUTPROP FLAVOR-NAME FL 'FLAVOR)
     511    ;; Now, if the flavor was redefined in a way that changes the methods but doesn't
     512    ;; invalidate old instances, we have to propagate some changes.
     513    (AND ALREADY-EXISTS
     514         (NOT IDENTICAL-COMPONENTS)
     515         (PERFORM-FLAVOR-METHOD-ONLY-REDEFINITION FLAVOR-NAME))
    421516    FLAVOR-NAME))
    422 
    423 (DEFUN FLAVOR-CHECK-FOR-TEMPORARY-AREA-LOSSAGE ()
    424   (AND (BOUNDP 'COMPILER:FASD-TEMPORARY-AREA)     ;This gets executed during bootstraping
    425        (EQ DEFAULT-CONS-AREA COMPILER:FASD-TEMPORARY-AREA)
    426        (FERROR NIL "You are about to lose with flavor data structure in a temporary area")))
    427517
    428518;Check for typos in user-specified lists of instance variables.
     
    435525             (FORMAT:PRINT-LIST ERROR-OUTPUT "~S" (NREVERSE BAD)))))
    436526
     527;List of those components which affect the names, number, and ordering of the
     528;instance variables.  Don't worry about undefined components, by definition
     529;they must be different from the already-existing flavor, so the right
     530;thing will happen.  (I wonder what that comment means?  Undefined components
     531;will not even appear in the list.)
     532(DEFUN FLAVOR-RELEVANT-COMPONENTS (FL COMPONENT-FLAVORS INCLUDED-FLAVORS)
     533  (BIND (LOCF (FLAVOR-DEPENDS-ON FL)) COMPONENT-FLAVORS)
     534  (BIND (LOCF (FLAVOR-INCLUDES FL)) INCLUDED-FLAVORS)
     535  (DEL-IF-NOT #'(LAMBDA (FLAVOR)                ;Splice out the uninteresting ones
     536                  (FLAVOR-LOCAL-INSTANCE-VARIABLES (GET FLAVOR 'FLAVOR)))
     537              (COMPOSE-FLAVOR-INCLUSION (FLAVOR-NAME FL) NIL)))
     538
    437539;Return new copy of the FLAVOR defstruct, and propagate to those that depend on it.
     540;*** This should hack the old flavor's select-method and combined-methods ***
     541;*** so that the old methods will be called directly, not via symbols ***
    438542(DEFUN PERFORM-FLAVOR-REDEFINITION (FLAVOR-NAME &AUX FL NFL)
    439543  (SETQ FL (GET FLAVOR-NAME 'FLAVOR))
     
    453557    (PERFORM-FLAVOR-REDEFINITION FN))
    454558  FL)
     559
     560;This one is when the old instances don't have to be discarded, but recomposition
     561;does have to occur because something was changed in the order of flavor combination
     562(DEFUN PERFORM-FLAVOR-METHOD-ONLY-REDEFINITION (FLAVOR-NAME &AUX FL)
     563  (SETQ FL (GET FLAVOR-NAME 'FLAVOR))
     564  (IF (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL))
     565  (IF (FLAVOR-SELECT-METHOD FL) (COMPOSE-METHOD-COMBINATION FL))
     566  (LET ((FDEFINE-FILE-PATHNAME NIL))    ;Don't give warnings for combined methods
     567    (DOLIST (FN (FLAVOR-DEPENDED-ON-BY FL))
     568      (PERFORM-FLAVOR-METHOD-ONLY-REDEFINITION FN))))
    455569
    456570
     
    478592           (DO ((TPL (CDDDR M) (CDR TPL))) ((NULL TPL))
    479593             (FORMAT T "~@[:~A ~]:~A~:[~;, ~]"
    480                        (CAAR TPL) (CAR M) (CDR TPL)))
     594                       (METH-METHOD-TYPE (CAR TPL)) (CAR M) (CDR TPL)))
    481595           (AND (CADR M)
    482596                (FORMAT T "    :~A~@[ :~A~]" (CADR M) (CADDR M)))
     
    492606  (AND (FLAVOR-INITABLE-INSTANCE-VARIABLES FL)
    493607       (FORMAT T "Instance variables that may be set by initialization: ~{~S~^, ~}~%"
    494                  (FLAVOR-INITABLE-INSTANCE-VARIABLES FL)))
     608                 (MAPCAR #'CDR (FLAVOR-INITABLE-INSTANCE-VARIABLES FL))))
    495609  (AND (FLAVOR-INIT-KEYWORDS FL)
    496610       (FORMAT T "Keywords in the :INIT message handled by this flavor: ~{~S~^, ~}~%"
     
    512626;; If in place of the lambda-list you have a symbol, and the body
    513627;; is null, that symbol is a function which stands in for the method.
    514 (DEFMACRO DEFMETHOD (FSPEC LAMBDA-LIST . BODY)
    515   (LET ((CLASS-NAME (CAR FSPEC)))
     628(DEFMACRO DEFMETHOD (SPEC LAMBDA-LIST . BODY)
     629  (LET ((CLASS-NAME (CAR SPEC))
     630        (FUNCTION-SPEC (CONS ':METHOD SPEC)))
    516631    `(PROGN 'COMPILE
    517632       ;; At compile-time, add enough information so that combined-methods
     
    524639             (NEQ CLASS-NAME 'VANILLA-FLAVOR)   ;This kludge avoids bootstrapping problems!
    525640             `(EVAL-WHEN (COMPILE)
    526                  (FLAVOR-NOTICE-METHOD ',FSPEC)))
     641                 (FLAVOR-NOTICE-METHOD ',FUNCTION-SPEC)))
    527642       ;; At load-time, define the method function
    528643       ,(COND ((AND (SYMBOLP LAMBDA-LIST) (NOT (NULL LAMBDA-LIST)) (NULL BODY))
    529                `(FDEFINE '(:METHOD ,@FSPEC) ',LAMBDA-LIST))
     644               `(FDEFINE ',FUNCTION-SPEC ',LAMBDA-LIST))
    530645              ((GET CLASS-NAME 'FLAVOR)
    531646               `(LOCAL-DECLARE (,(AND (NEQ CLASS-NAME 'VANILLA-FLAVOR) ;Bootstrap kludge
    532647                                      (FLAVOR-SPECIAL-DECLARATION CLASS-NAME)))
    533                   (DEFUN (:METHOD ,@FSPEC) (OPERATION . ,LAMBDA-LIST)
     648                  (DEFUN ,FUNCTION-SPEC (OPERATION . ,LAMBDA-LIST)
    534649                    . ,BODY)))
    535650              (T ;; The non-flavor class system
    536                 (AND (CDDR FSPEC) (FERROR NIL "~S bad in non-flavor DEFMETHOD"
    537                                           FSPEC))
    538                 (LET ((OPERATION (CADR FSPEC)))
     651                (IF (NOT (NULL (CDDR SPEC)))
     652                    (FERROR NIL "~S is not a flavor" (CAR SPEC)))
     653                (LET ((OPERATION (CADR SPEC)))
    539654                  (COND ((ATOM OPERATION)
    540655                         `(PROGN 'COMPILE
     
    550665                                             OPERATION))))))))))
    551666
     667; This lets you specify code to be wrapped around the invocation of the
     668; various methods for an operation.  For example,
     669; (DEFWRAPPER (FOO-FLAVOR :OPERATION) ((ARG1 ARG2) . BODY)
     670;   `(WITH-FOO-LOCKED (SELF)
     671;      (PRE-FROBULATE SELF ARG1 ARG2)
     672;      ,@BODY
     673;      (POST-FROBULATE SELF ARG2 ARG1)))
     674;Note that the wrapper needs to be defined at both compile and run times
     675;so that compiling combined methods as part of the qfasl file works.
     676(DEFMACRO DEFWRAPPER ((FLAVOR-NAME OPERATION) (DEFMACRO-LAMBDA . GUTS)
     677                      &BODY BODY)
     678  (LET ((FUNCTION-SPEC `(:METHOD ,FLAVOR-NAME :WRAPPER ,OPERATION)))
     679    `(PROGN 'COMPILE
     680         ;; At compile-time, add enough information so that combined-methods
     681         ;; can be compiled.  The compile-time definition of macros does not
     682         ;; go through FDEFINE, so this is necessary to record the existence
     683         ;; of the wrapper.
     684         ,(AND (GET FLAVOR-NAME 'FLAVOR)
     685               COMPILER:QC-FILE-IN-PROGRESS
     686               `(EVAL-WHEN (COMPILE)
     687                   (FLAVOR-NOTICE-METHOD ',FUNCTION-SPEC)))
     688         (EVAL-WHEN (COMPILE LOAD EVAL) ;Wrapper defs needed to stay around between files
     689           ;; The following optimization could go away if defmacro was made very smart
     690           ,(IF (AND (SYMBOLP DEFMACRO-LAMBDA) (STRING-EQUAL DEFMACRO-LAMBDA 'IGNORE))
     691               `(DEFMACRO ,FUNCTION-SPEC (IGNORE . ,GUTS)
     692                  . ,BODY)
     693               `(DEFMACRO ,FUNCTION-SPEC (ARGLISTNAME . ,GUTS)
     694                  `(DESTRUCTURING-BIND ,',DEFMACRO-LAMBDA (CDR ,ARGLISTNAME)
     695                                             ,,@BODY)))))))
     696
    552697;This just exists to be called at compile-time from the DEFMETHOD macro,
    553698;so that any combined methods generated by COMPILE-FLAVOR-METHODS will
    554699;know that this method will be around at run time and should be called.
    555700(DEFUN FLAVOR-NOTICE-METHOD (FUNCTION-SPEC)
    556   (MULTIPLE-VALUE-BIND (METHOD-SYMBOL FL TYPE MESSAGE)
    557       (FLAVOR-METHOD-SYMBOL FUNCTION-SPEC)
    558     (PUSH METHOD-SYMBOL COMPILER:FUNCTIONS-DEFINED)
    559     (FLAVOR-ADD-METHOD FL TYPE MESSAGE METHOD-SYMBOL)))
    560 
    561 ;;; This is called by FDEFINE when a Flavor method is being defined.
    562 (DEFUN FDEFINE-FLAVOR (FUNCTION-SPEC DEFINITION CAREFULLY-FLAG FORCE-FLAG &AUX REDEFINING)
    563   ;; First, decode the function-spec and check that the flavor is defined.
    564   (MULTIPLE-VALUE-BIND (METHOD-SYMBOL FL TYPE MESSAGE)
    565       (FLAVOR-METHOD-SYMBOL (CDR FUNCTION-SPEC))
    566     (SETQ REDEFINING (FBOUNDP METHOD-SYMBOL))
    567     ;; Store the function definition on the method symbol
    568     ;; except that they may be EQ in some bizarre cases, apparently(?)
    569     (OR (EQ METHOD-SYMBOL DEFINITION)
    570         (FDEFINE METHOD-SYMBOL DEFINITION CAREFULLY-FLAG FORCE-FLAG))
    571     ;; Put the method symbol into the flavor's method table.
    572     ;; Incrementally recompile the flavor if this is a new method, unless
    573     ;; it is a :COMBINED method, which is the result of compilation, not a client of it.
    574     ;; The reason there are two things to check to see if it is a new method
    575     ;; is because of FLAVOR-NOTICE-METHOD.
    576     (COND ((AND (OR (FLAVOR-ADD-METHOD FL TYPE MESSAGE METHOD-SYMBOL) (NOT REDEFINING))
    577                 (NEQ TYPE ':COMBINED))
    578            (RECOMPILE-FLAVOR (FLAVOR-NAME FL) MESSAGE)
    579            (SETF (FLAVOR-WHICH-OPERATIONS FL) NIL)))    ;Needs to be recomputed
    580     ;; Always return the method symbol, for want of anything better
    581     METHOD-SYMBOL))
    582 
    583 ;;; Put a method-symbol into a flavor's method table.
    584 ;;; Returns non-NIL if this is a new method, NIL if it existed already.
    585 (DEFUN FLAVOR-ADD-METHOD (FL TYPE MESSAGE METHOD-SYMBOL &AUX MTE)
    586   ;; This can happen if you get an error in a compilation and do things.
    587   ;; Avoid arbitrary propagation of lossage and destruction.
    588   (FLAVOR-CHECK-FOR-TEMPORARY-AREA-LOSSAGE)
    589   (IF (NULL (SETQ MTE (ASSQ MESSAGE (FLAVOR-METHOD-TABLE FL))))
    590       ;; Message not previously known about, put into table
    591       (PUSH (LIST* MESSAGE NIL NIL (LIST TYPE METHOD-SYMBOL) NIL)
    592             (FLAVOR-METHOD-TABLE FL))
    593       ;; Message known, search for the type entry, and update it, or create it
    594       (DO ((L (CDDDR MTE) (CDR L)))
    595           ((NULL L)
    596            (PUSH (LIST TYPE METHOD-SYMBOL) (CDDDR MTE)))
    597         (COND ((EQ (CAAR L) TYPE)
    598                (SETF (CADAR L) METHOD-SYMBOL)
    599                (RETURN NIL))))))                ;Not a new method, return NIL
    600 
    601 ;;; Returns a symbol which names a flavor method, given a list (flavor type message)
    602 ;;; where type is optional and may be omitted.
    603 ;;; The symbol is put into the same package as the flavor name.
    604 ;;; Also returns various other handy things decoded from the function spec.
    605 ;;; Note that this symbol is NOT the same as the name of the function which
    606 ;;; handles that message.  Use GET-HANDLER-FOR for that.
    607 ;;; This function works for Class methods as well as Flavor methods.
    608 (LOCAL-DECLARE ((RETURN-LIST METHOD-SYMBOL FL TYPE MESSAGE))
    609 (DEFUN FLAVOR-METHOD-SYMBOL (FSPEC)
    610   ;*** This is a temporary kludge since I gratuitously changed this guy's calling sequence
    611   (AND (EQ (CAR FSPEC) ':METHOD) (SETQ FSPEC (CDR FSPEC)))
    612   (PROG* ((FLAVOR-NAME (CAR FSPEC))
    613           (TYPE (CADR FSPEC))
    614           (MESSAGE (CADDR FSPEC))
    615           (FL (GET FLAVOR-NAME 'FLAVOR))
    616           (PKG PACKAGE))
    617     (AND (NULL MESSAGE) (SETQ MESSAGE TYPE TYPE NIL))   ;If no type
    618     (AND (OR (NULL MESSAGE) (> (LENGTH FSPEC) 3))
    619          (FERROR NIL "~S is not a valid function-spec" (CONS ':METHOD FSPEC)))
    620     ;; If flavor is undefined, assume current package.  Don't want to give an error since
    621     ;; then you could not edit a source file containing methods of an undefined flavor.
    622     (AND (TYPEP FL 'FLAVOR) (SETQ PKG (FLAVOR-PACKAGE FL)))
    623     (RETURN (INTERN1 (FORMAT NIL "~A~@[-~A~]-~A-METHOD" FLAVOR-NAME TYPE MESSAGE) PKG)
    624             FL TYPE MESSAGE))))
     701  (AND (BOUNDP 'COMPILER:FUNCTIONS-DEFINED)
     702       (PUSH FUNCTION-SPEC COMPILER:FUNCTIONS-DEFINED))
     703  (FLAVOR-METHOD-ENTRY FUNCTION-SPEC))
     704
     705;Find or create a method-table entry for the specified method.
     706(DEFUN FLAVOR-METHOD-ENTRY (FUNCTION-SPEC &OPTIONAL DONT-CREATE)
     707  (LET ((FLAVOR-NAME (SECOND FUNCTION-SPEC))
     708        (TYPE (THIRD FUNCTION-SPEC))
     709        (MESSAGE (FOURTH FUNCTION-SPEC)))
     710    (IF (NULL MESSAGE) (SETQ MESSAGE TYPE TYPE NIL))    ;If no type
     711    (IF (OR (NULL MESSAGE) (NEQ (FIRST FUNCTION-SPEC) ':METHOD) (> (LENGTH FUNCTION-SPEC) 4)
     712            (NOT (SYMBOLP FLAVOR-NAME)) (NOT (SYMBOLP TYPE)) (NOT (SYMBOLP MESSAGE)))
     713        (FERROR NIL "~S is not a valid function-spec" FUNCTION-SPEC))
     714    (LET* ((FL (GET FLAVOR-NAME 'FLAVOR))
     715           (MTE (ASSQ MESSAGE (FLAVOR-METHOD-TABLE FL))))
     716      (OR MTE DONT-CREATE
     717          ;; Message not previously known about, put into table
     718          (PUSH (SETQ MTE (LIST* MESSAGE NIL NIL NIL)) (FLAVOR-METHOD-TABLE FL)))
     719      ;; Message known, search for the type entry
     720      (OR (METH-LOOKUP TYPE (CDDDR MTE))
     721          (AND (NOT DONT-CREATE)
     722               ;; Type not known, create a new meth with an unbound definition cell
     723               (LET ((METH (LIST-IN-AREA PERMANENT-STORAGE-AREA FUNCTION-SPEC NIL NIL)))
     724                 (NULLIFY-METHOD-DEFINITION METH)
     725                 (PUSH METH (CDDDR MTE))
     726                 (VALUES METH T)))))))
    625727
    626728;;; See if a certain method exists in a flavor
    627 (DEFUN FLAVOR-METHOD-EXISTS (FL TYPE MESSAGE &AUX MTE)
    628   (AND (SETQ MTE (ASSQ MESSAGE (FLAVOR-METHOD-TABLE FL)))
    629        (ASSQ TYPE (CDDDR MTE))))
    630 
     729(DEFUN FLAVOR-METHOD-EXISTS (FL TYPE OPERATION &AUX MTE)
     730  (AND (SETQ MTE (ASSQ OPERATION (FLAVOR-METHOD-TABLE FL)))
     731       (METH-LOOKUP TYPE (CDDDR MTE))))
     732
     733;;; Forcibly remove a method definition from a flavor's method table
     734;;; Syntax is identical to the beginning of a defmethod for the same method.
     735(DEFMACRO UNDEFMETHOD (SPEC)
     736  `(FUNDEFINE '(:METHOD . ,SPEC)))
     737
     738;;; Interface to function-spec system
     739;; (:METHOD class-name operation) refers to the method in that class for
     740;;   that operation; this works for both Class methods and Flavor methods.
     741;;   In the case of Flavor methods, the specification may also be of the form
     742;;   (:METHOD flavor-name method-type operation).
     743(DEFPROP :METHOD METHOD-FUNCTION-SPEC-HANDLER FUNCTION-SPEC-HANDLER)
     744(DEFUN METHOD-FUNCTION-SPEC-HANDLER (FUNCTION FUNCTION-SPEC &OPTIONAL ARG1 ARG2)
     745  (LET ((FLAVOR (SECOND FUNCTION-SPEC))
     746        (METHOD-TYPE (THIRD FUNCTION-SPEC))
     747        (MESSAGE (FOURTH FUNCTION-SPEC)))
     748    (IF (NULL (CDDDR FUNCTION-SPEC))
     749        (SETQ MESSAGE (THIRD FUNCTION-SPEC) METHOD-TYPE NIL))
     750    (COND ((AND (SYMBOLP FLAVOR) (GET FLAVOR 'FLAVOR))
     751           (IF (EQ FUNCTION 'VALIDATE-FUNCTION-SPEC)
     752               (AND (SYMBOLP METHOD-TYPE) (SYMBOLP MESSAGE) (
     753 3 (LENGTH FUNCTION-SPEC) 4))
     754               (LET ((FL (GET FLAVOR 'FLAVOR))
     755                     (METH (FLAVOR-METHOD-ENTRY FUNCTION-SPEC
     756                                                (NOT (MEMQ FUNCTION '(FDEFINE PUTPROP))))))
     757                 (OR (NOT (NULL METH))
     758                     (MEMQ FUNCTION '(FDEFINEDP COMPILER-FDEFINEDP GET FUNCTION-PARENT))
     759                     (FERROR NIL "~S is not a defined method; it is not possible to ~S it"
     760                                 FUNCTION-SPEC FUNCTION))
     761                 (SELECTQ FUNCTION
     762                   (FDEFINE
     763                     (LET ((NEW-DEFINITION (NOT (METH-DEFINEDP METH))))
     764                       (SETF (METH-DEFINITION METH) ARG1)
     765                       ;; Incrementally recompile the flavor if this is a new method, unless
     766                       ;; it is a :COMBINED method, which is the result of compilation,
     767                       ;; not a client of it.
     768                       (AND NEW-DEFINITION
     769                            (NEQ METHOD-TYPE ':COMBINED)
     770                            (RECOMPILE-FLAVOR FLAVOR MESSAGE))))
     771                   (FDEFINITION (METH-DEFINITION METH))
     772                   (FDEFINEDP (AND METH (METH-DEFINEDP METH)))
     773                   (FDEFINITION-LOCATION (LOCF (METH-DEFINITION METH)))
     774                   (FUNDEFINE
     775                     (LET ((MTE (ASSQ MESSAGE (FLAVOR-METHOD-TABLE FL))) TEM)
     776                       (SETF (CDDDR MTE) (DELQ METH (CDDDR MTE)))       ;Remove this method
     777                       (IF (OR (NULL (CDDDR MTE))       ;No methods left for this operation?
     778                                                        ;or just a worthless combined method?
     779                               (AND (= (LENGTH (CDDDR MTE)) 1)
     780                                    (EQ (METH-METHOD-TYPE (CADDDR MTE)) ':COMBINED)
     781                                    (= (LENGTH (SETQ TEM
     782                                                 (CDDDR (FUNCTION-SPEC-GET
     783                                                          (METH-FUNCTION-SPEC (CADDDR MTE))
     784                                                          'COMBINED-METHOD-DERIVATION))))
     785                                       1)
     786                                    (IF METHOD-TYPE (EQ (CADDAR TEM) METHOD-TYPE)
     787                                        (NULL (CDDDAR TEM)))))
     788                           (SETF (FLAVOR-METHOD-TABLE FL)
     789                                 (DELQ MTE (FLAVOR-METHOD-TABLE FL))))
     790                       (RECOMPILE-FLAVOR (FLAVOR-NAME FL) MESSAGE)      ;Propagate the change
     791                       ;; In case anyone has their paws on the function cell
     792                       (NULLIFY-METHOD-DEFINITION METH)))
     793                   (FUNCTION-PARENT (VALUES FLAVOR 'DEFFLAVOR)) ;Useful for automatic methods
     794                   (COMPILER-FDEFINEDP METH)
     795                   (GET (AND METH (GET (LOCF (METH-PLIST METH)) ARG1)))
     796                   (PUTPROP (PUTPROP (LOCF (METH-PLIST METH)) ARG1 ARG2))
     797                   (OTHERWISE
     798                     (FUNCTION-SPEC-DEFAULT-HANDLER FUNCTION FUNCTION-SPEC ARG1 ARG2))))))
     799          ((AND (SYMBOLP FLAVOR) (CLASS-SYMBOLP FLAVOR))
     800           (CLASS-METHOD-FUNCTION-SPEC-HANDLER FUNCTION FUNCTION-SPEC ARG1 ARG2))
     801          (T (FERROR NIL "In the function spec ~S,
     802    ~S is neither the name of a flavor nor the name of a class"
     803                         FUNCTION-SPEC FLAVOR)))))
     804
     805
     806;Make an object of a particular flavor, taking the init-plist options
     807;as a rest argument and sending the :INIT message if the flavor
     808;handles it.
     809(DEFUN MAKE-INSTANCE (FLAVOR-NAME &REST INIT-OPTIONS)
     810  (INSTANTIATE-FLAVOR FLAVOR-NAME (LOCF INIT-OPTIONS) 'MAYBE))
    631811
    632812;Make an object of a particular flavor.
     
    640820                                     RETURN-UNHANDLED-KEYWORDS-P ;as second value
    641821                                     AREA-TO-CONS-INSTANCE-IN
    642                            &AUX FL FFL UNHANDLED-KEYWORDS INSTANCE VARS N)
     822                           &AUX FL FFL UNHANDLED-KEYWORDS INSTANCE VARS N TEM)
    643823  (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) "the name of a flavor")
    644824  ;; Do any composition (compilation) of combined stuff, if not done already
     
    656836                              DTP-NULL (CAR V)))
    657837  ;; Put defaults into the INIT-PLIST
    658   (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL))
    659     (SETQ FFL (GET FFL 'FLAVOR))
    660     (DO L (GET (LOCF (FLAVOR-PLIST FFL)) ':DEFAULT-INIT-PLIST) (CDDR L) (NULL L)
    661       (DO ((M (CDR INIT-PLIST) (CDDR M)))
    662           ((NULL M) (PUTPROP INIT-PLIST (EVAL (CADR L)) (CAR L)))
    663         (AND (EQ (CAR M) (CAR L)) (RETURN)))))
     838  (FLAVOR-DEFAULT-INIT-PLIST FLAVOR-NAME INIT-PLIST)
    664839  ;; For each init keyword, either initialize the corresponding variable, remember
    665840  ;; that it will be handled later by an :INIT method, or give an error for not being handled.
    666841  (DO L (CDR INIT-PLIST) (CDDR L) (NULL L)
    667     (LET ((KEYWORD (CAR L)) (ARG (CADR L)) V)
     842    (LET ((KEYWORD (CAR L)) (ARG (CADR L)))
    668843      (DO ((FFLS (FLAVOR-DEPENDS-ON-ALL FL) (CDR FFLS)))
    669844          ((NULL FFLS) (PUSH KEYWORD UNHANDLED-KEYWORDS))
    670845        (SETQ FFL (GET (CAR FFLS) 'FLAVOR))
    671         (COND ((SETQ V (MEM #'STRING-EQUAL KEYWORD (FLAVOR-INITABLE-INSTANCE-VARIABLES FFL)))
    672                (RETURN (%P-STORE-CONTENTS-OFFSET ARG INSTANCE
    673                                                  (1+ (FIND-POSITION-IN-LIST (CAR V) VARS)))))
    674               ((SETQ V (MEM #'STRING-EQUAL KEYWORD (FLAVOR-SETTABLE-INSTANCE-VARIABLES FFL)))
    675                (RETURN (%P-STORE-CONTENTS-OFFSET ARG INSTANCE
    676                                                  (1+ (FIND-POSITION-IN-LIST (CAR V) VARS)))))
    677               ((MEMQ KEYWORD (FLAVOR-INIT-KEYWORDS FFL))
    678                (RETURN))))))
     846        (COND ((SETQ TEM (ASSQ KEYWORD (FLAVOR-INITABLE-INSTANCE-VARIABLES FFL)))
     847               (%P-STORE-CONTENTS-OFFSET ARG INSTANCE
     848                                         (1+ (FIND-POSITION-IN-LIST (CDR TEM) VARS)))
     849               (RETURN))
     850              ((MEMQ KEYWORD (FLAVOR-INIT-KEYWORDS FFL)) (RETURN))))))
    679851  ;; Do default initializations
    680852  (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL))
     
    693865               (LENGTH UNHANDLED-KEYWORDS)
    694866               UNHANDLED-KEYWORDS))
     867  (AND (EQ SEND-INIT-MESSAGE-P 'MAYBE)
     868       (NOT (GET-HANDLER-FOR INSTANCE ':INIT))
     869       (SETQ SEND-INIT-MESSAGE-P NIL))
    695870  (AND SEND-INIT-MESSAGE-P
    696871       (FUNCALL INSTANCE ':INIT INIT-PLIST))
    697872  (PROG () (RETURN INSTANCE UNHANDLED-KEYWORDS)))
     873
     874(DEFUN FLAVOR-DEFAULT-INIT-PLIST (FLAVOR-NAME &OPTIONAL (INIT-PLIST (NCONS NIL)) &AUX FL)
     875  (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) "the name of a flavor")
     876  ;; Do any composition (compilation) of combined stuff, if not done already
     877  (OR (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL))
     878  (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL))
     879    (SETQ FFL (GET FFL 'FLAVOR))
     880    (DO L (GET (LOCF (FLAVOR-PLIST FFL)) ':DEFAULT-INIT-PLIST) (CDDR L) (NULL L)
     881      (DO ((M (CDR INIT-PLIST) (CDDR M)))
     882          ((NULL M) (PUTPROP INIT-PLIST (EVAL (CADR L)) (CAR L)))
     883        (AND (EQ (CAR M) (CAR L)) (RETURN)))))
     884  INIT-PLIST)
    698885
    699886;Returns non-NIL if the flavor allows the specified keyword in its init-plist,
     
    703890  (MAP-OVER-COMPONENT-FLAVORS 0 T T
    704891      #'(LAMBDA (FL IGNORE KEYWORD)
    705           (AND (OR (MEM #'STRING-EQUAL KEYWORD (FLAVOR-INITABLE-INSTANCE-VARIABLES FL))
    706                    (MEM #'STRING-EQUAL KEYWORD (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL))
     892          (AND (OR (ASSQ KEYWORD (FLAVOR-INITABLE-INSTANCE-VARIABLES FL))
    707893                   (MEMQ KEYWORD (FLAVOR-INIT-KEYWORDS FL)))
    708894               (FLAVOR-NAME FL)))
     
    714900;  what they depend on.
    715901; Note that it does the specified flavor itself as well as all its components.
     902; Note well: if there are included flavors, this does not do them in the
     903;  right order.  Also note well: if there are multiple paths to a component,
     904;  it will be done more than once.
    716905; RECURSION-STATE is 0 except when recursively calling itself.
    717906; ERROR-P is T if not-yet-defflavored flavors are to be complained about,
     
    770959;If a compilation is in progress the compilations performed
    771960; will get output as part of that compilation.
    772 ;SINGLE-MESSAGE is NIL to do all messages, or the name of a message
     961;SINGLE-OPERATION is NIL to do all operations, or the name of an operation
    773962; which needs incremental compilation.
    774963;USE-OLD-COMBINED-METHODS can be NIL to force regeneration of all combined methods.
     
    776965;DO-DEPENDENTS controls whether flavors that depend on this one are also compiled.
    777966(DEFUN RECOMPILE-FLAVOR (FLAVOR-NAME
    778                          &OPTIONAL (SINGLE-MESSAGE NIL) (*USE-OLD-COMBINED-METHODS* T)
     967                         &OPTIONAL (SINGLE-OPERATION NIL) (*USE-OLD-COMBINED-METHODS* T)
    779968                                   (DO-DEPENDENTS T)
    780969                         &AUX FL)
     
    784973         (OR (FLAVOR-DEPENDS-ON-ALL FL)
    785974             (COMPOSE-FLAVOR-COMBINATION FL))
    786          (COMPOSE-METHOD-COMBINATION FL SINGLE-MESSAGE)))
    787   (AND DO-DEPENDENTS
    788        (DOLIST (FN (FLAVOR-DEPENDED-ON-BY FL))
    789          (RECOMPILE-FLAVOR FN SINGLE-MESSAGE))))
     975         (COMPOSE-METHOD-COMBINATION FL SINGLE-OPERATION)))
     976  (IF DO-DEPENDENTS
     977      (LET ((FDEFINE-FILE-PATHNAME NIL))        ;Don't give warnings for combined methods
     978        (DOLIST (FN (FLAVOR-DEPENDED-ON-BY-ALL FL))
     979          (RECOMPILE-FLAVOR FN SINGLE-OPERATION *USE-OLD-COMBINED-METHODS* NIL)))))
     980
     981;Make a list of all flavors that depend on this one, not including this flavor itself.
     982;This is a list of the names, not the defstructs.
     983(DEFUN FLAVOR-DEPENDED-ON-BY-ALL (FL &OPTIONAL (LIST-SO-FAR NIL) &AUX FFL)
     984  (DOLIST (FN (FLAVOR-DEPENDED-ON-BY FL))
     985    (OR (MEMQ FN LIST-SO-FAR)
     986        (NOT (SETQ FFL (GET FN 'FLAVOR)))
     987        (SETQ LIST-SO-FAR (FLAVOR-DEPENDED-ON-BY-ALL FFL (CONS FN LIST-SO-FAR)))))
     988  LIST-SO-FAR)
    790989
    791990
     
    794993;instance variables.  It generally needs to be called only once for a
    795994;flavor, and must be called before method-combination can be dealt with.
    796 (DEFUN COMPOSE-FLAVOR-COMBINATION (FL &AUX FLS VARS ORDS REQS SIZE)
    797   ;; This can happen if you get an error in a compilation and do things.
    798   ;; Avoid arbitrary propagation of lossage and destruction.
    799   (FLAVOR-CHECK-FOR-TEMPORARY-AREA-LOSSAGE)
     995(DEFUN COMPOSE-FLAVOR-COMBINATION (FL &AUX FLS VARS ORDS REQS SIZE
     996                                           (DEFAULT-CONS-AREA *FLAVOR-AREA*))
    800997  ;; Make list of all component flavors' names.
    801998  ;; This list is in outermost-first order.
    802999  ;; Would be nice for this not to have to search to all levels, but for
    8031000  ;; the moment that is hard, so I won't do it.
     1001  ;; Included-flavors are hairy: if not otherwise in the list of components, they
     1002  ;; are stuck in after the rightmost component that includes them, along with
     1003  ;; any components of their own not otherwise in the list.
    8041004  (SETF (FLAVOR-DEPENDS-ON-ALL FL)
    805         (SETQ FLS (COPYLIST (NREVERSE (MAP-OVER-COMPONENT-FLAVORS 0 T NIL
    806                                          #'(LAMBDA (FL LIST)
    807                                              (SETQ FL (FLAVOR-NAME FL))
    808                                              (OR (MEMQ FL LIST) (PUSH FL LIST))
    809                                              LIST)
    810                                          (FLAVOR-NAME FL) NIL))
     1005        (SETQ FLS (COPYLIST (COMPOSE-FLAVOR-INCLUSION (FLAVOR-NAME FL) T)
    8111006                            PERMANENT-STORAGE-AREA)))
     1007  ;; Vanilla-flavor may have been put in by magic, so maintain the dependencies
     1008  ;; in case new methods get added to it later.
     1009  (LET ((VAN (GET 'VANILLA-FLAVOR 'FLAVOR))
     1010        (FLAV (FLAVOR-NAME FL)))
     1011    (AND (NOT (NULL VAN))
     1012         (NEQ FLAV 'VANILLA-FLAVOR)
     1013         (MEMQ 'VANILLA-FLAVOR FLS)
     1014         (NOT (MEMQ FLAV (FLAVOR-DEPENDED-ON-BY VAN)))
     1015         (PUSH FLAV (FLAVOR-DEPENDED-ON-BY VAN))))
    8121016  ;; Compute what the instance variables will be, and in what order.
    8131017  ;; Also collect the required but not present instance variables, which go onto the
    814   ;; ADDITIONAL-SPECIAL-VARIABLES property.
     1018  ;; ADDITIONAL-SPECIAL-VARIABLES property.  The instance variables of the
     1019  ;; :REQUIRED-FLAVORS work the same way.
    8151020  (DOLIST (F FLS)
    8161021    (SETQ F (GET F 'FLAVOR))
     
    8201025    (DOLIST (V (GET (LOCF (FLAVOR-PLIST F)) ':REQUIRED-INSTANCE-VARIABLES))
    8211026      (OR (MEMQ V VARS) (MEMQ V REQS) (PUSH V REQS)))
     1027    (DOLIST (FF (GET (LOCF (FLAVOR-PLIST F)) ':REQUIRED-FLAVORS))
     1028      (COND ((AND (NOT (MEMQ FF FLS)) (SETQ FF (GET FF 'FLAVOR)))
     1029             (OR (FLAVOR-DEPENDS-ON-ALL FF) (COMPOSE-FLAVOR-COMBINATION FF))
     1030             (DOLIST (V (FLAVOR-ALL-INSTANCE-VARIABLES FF))
     1031               (OR (MEMQ V VARS) (MEMQ V REQS) (PUSH V REQS)))
     1032             (DOLIST (V (GET (LOCF (FLAVOR-PLIST FF)) 'ADDITIONAL-SPECIAL-VARIABLES))
     1033               (OR (MEMQ V VARS) (MEMQ V REQS) (PUSH V REQS))))))
    8221034    (LET ((ORD (GET (LOCF (FLAVOR-PLIST F)) ':ORDERED-INSTANCE-VARIABLES)))
    8231035      ;; Merge into existing order requirement.  Shorter of the two must be
     
    8431055  ;; Tell microcode about the instance variables
    8441056  (SETF (FLAVOR-BINDINGS FL)
    845         (LET ((B (MAKE-LIST PERMANENT-STORAGE-AREA (LENGTH VARS))))
     1057        (LET ((B (MAKE-LIST (LENGTH VARS) ':AREA PERMANENT-STORAGE-AREA)))
    8461058          (DO ((V VARS (CDR V))         ;This way rather than MAPCAR for CDR-coding
    8471059               (L B (CDR L)))
     
    8651077  NIL)
    8661078
     1079(DEFUN COMPOSE-FLAVOR-INCLUSION (FLAVOR ERROR-P)
     1080  (MULTIPLE-VALUE-BIND (FLS ADDITIONS) (COMPOSE-FLAVOR-INCLUSION-1 FLAVOR NIL ERROR-P)
     1081    ;; The new additions may themselves imply more components
     1082    (DO L ADDITIONS (CDR L) (NULL L)
     1083      (LET ((MORE-FLS (COMPOSE-FLAVOR-INCLUSION-1 (CAR L) FLS ERROR-P)))
     1084        (DOLIST (F MORE-FLS)
     1085          ;; This hair inserts F before (after) the thing that indirectly included it
     1086          ;; and then puts that next on ADDITIONS so it gets composed also
     1087          (LET ((LL (MEMQ (CAR L) FLS)))
     1088            (RPLACA (RPLACD LL (CONS (CAR LL) (CDR LL))) F)
     1089            (RPLACD L (CONS F (CDR L)))))))
     1090    ;; Now attach vanilla-flavor if desired
     1091    (OR (LOOP FOR FLAVOR IN FLS
     1092              THEREIS (GET (LOCF (FLAVOR-PLIST (GET FLAVOR 'FLAVOR))) ':NO-VANILLA-FLAVOR))
     1093        (PUSH 'VANILLA-FLAVOR FLS))
     1094    (NREVERSE FLS)))
     1095
     1096(LOCAL-DECLARE ((SPECIAL OTHER-COMPONENTS))
     1097(DEFUN COMPOSE-FLAVOR-INCLUSION-1 (FLAVOR OTHER-COMPONENTS ERROR-P)
     1098  ;; First, make a backwards list of all the normal (non-included) components
     1099  (LET ((FLS (MAP-OVER-COMPONENT-FLAVORS 1 ERROR-P NIL
     1100                                         #'(LAMBDA (FL LIST)
     1101                                             (SETQ FL (FLAVOR-NAME FL))
     1102                                             (OR (MEMQ FL LIST)
     1103                                                 (MEMQ FL OTHER-COMPONENTS)
     1104                                                 (PUSH FL LIST))
     1105                                             LIST)
     1106                                         FLAVOR NIL))
     1107        (ADDITIONS NIL))
     1108    ;; If there are any inclusions that aren't in the list, plug
     1109    ;; them in right after (before in backwards list) their last (first) includer
     1110    (DO L FLS (CDR L) (NULL L)
     1111      (DOLIST (FL (FLAVOR-INCLUDES (GET (CAR L) 'FLAVOR)))
     1112        (OR (MEMQ FL FLS)
     1113            (MEMQ FL OTHER-COMPONENTS)
     1114            (PUSH (CAR (RPLACA (RPLACD L (CONS (CAR L) (CDR L))) FL)) ADDITIONS))))
     1115    (OR (MEMQ FLAVOR FLS)
     1116        (SETQ FLS (NCONC FLS
     1117                         (NREVERSE
     1118                           (LOOP FOR FL IN (FLAVOR-INCLUDES (GET FLAVOR 'FLAVOR))
     1119                                 UNLESS (OR (MEMQ FL FLS) (MEMQ FL OTHER-COMPONENTS))
     1120                                   COLLECT FL
     1121                                   AND DO (PUSH FL ADDITIONS))))))
     1122    (VALUES FLS ADDITIONS))))
     1123
    8671124
    8681125;Once the flavor-combination stuff has been done, do the method-combination stuff.
    8691126;The above function usually only gets called once, but this function gets called
    8701127;when a new method is added.
    871 ;Specify SINGLE-MESSAGE to do this for just one message, for incremental update.
    872 (DEFUN COMPOSE-METHOD-COMBINATION (FL &OPTIONAL (SINGLE-MESSAGE NIL)
     1128;Specify SINGLE-OPERATION to do this for just one operation, for incremental update.
     1129;NOTE WELL: If a meth is in the method-table at all, it is considered to be defined
     1130; for purposes of compose-method-combination.  Thus merely putprop'ing a method,
     1131; or calling flavor-notice-method, will make the flavor think that method exists
     1132; when it is next composed.  This is necessary to make compile-flavor-methods work.
     1133; (Putprop must create the meth because loading does putprop before fdefine.)
     1134(DEFUN COMPOSE-METHOD-COMBINATION (FL &OPTIONAL (SINGLE-OPERATION NIL)
    8731135                                   &AUX TEM MAGIC-LIST DEFAULT-HANDLER ORDER
    874                                         MSG ELEM SYMS SM FFL PL)
    875   ;; This can happen if you get an error in a compilation and do things.
    876   ;; Avoid arbitrary propagation of lossage and destruction.
    877   (FLAVOR-CHECK-FOR-TEMPORARY-AREA-LOSSAGE)
     1136                                        MSG ELEM HANDLERS SM FFL PL
     1137                                        (DEFAULT-CONS-AREA *FLAVOR-AREA*))
    8781138  ;; Look through all the flavors depended upon and collect the following:
    879   ;; A list of all the messages handled and all the methods for each, called MAGIC-LIST.
    880   ;; The default handler for unknown messages.
     1139  ;; A list of all the operations handled and all the methods for each, called MAGIC-LIST.
     1140  ;; The default handler for unknown operations.
    8811141  ;; The declared order of entries in the select-method alist.
    8821142  ;; Also generate any automatically-created methods not already present.
    8831143  ;; MAGIC-LIST is roughly the same format as the flavor-method-table, see its comments.
    884   (DO ((FFLS (FLAVOR-DEPENDS-ON-ALL FL) (CDR FFLS))
    885        (NO-MORE NIL))
     1144  ;; Each magic-list entry is (message comb-type comb-order (type function-spec...)...)
     1145  (DO ((FFLS (FLAVOR-DEPENDS-ON-ALL FL) (CDR FFLS)))
    8861146      ((NULL FFLS))
    8871147    (SETQ FFL (GET (CAR FFLS) 'FLAVOR) PL (LOCF (FLAVOR-PLIST FFL)))
    888     ;; If we are doing COMPILE-FLAVOR-METHODS, don't look past the
    889     ;; first component flavor which itself has been compiled-flavor-methods.
    890     ;; That is, do look past it, but don't add any more messages.
    891     ;; This will not do the right thing in all cases, but it will do the
    892     ;; right thing in most cases, with respect to sharing of combined methods.
    893     ;; (It won't work if you combine flavors in a funny order, in which
    894     ;; case some run-time compilation will still be required.)
    895     (AND *JUST-COMPILING* (NEQ FFL FL) (GET PL 'COMPILE-FLAVOR-METHODS) (SETQ NO-MORE T))
    896     (COND ((NOT SINGLE-MESSAGE)
     1148    (COND ((NOT SINGLE-OPERATION)
    8971149           (OR DEFAULT-HANDLER (SETQ DEFAULT-HANDLER (GET PL ':DEFAULT-HANDLER)))
    8981150           (AND (SETQ TEM (GET PL ':SELECT-METHOD-ORDER))
     
    9021154    (DOLIST (MTE (FLAVOR-METHOD-TABLE FFL))
    9031155      (SETQ MSG (CAR MTE))
    904       (COND ((OR (NOT SINGLE-MESSAGE) (EQ MSG SINGLE-MESSAGE))
    905              ;; Well, we're supposed to concern ourselves with this message
    906              (COND ((AND (OR (SETQ ELEM (ASSQ MSG MAGIC-LIST)) (NOT NO-MORE))
    907                          (DOLIST (X (CDDDR MTE))
    908                            (OR (EQ (CAR X) ':COMBINED) (RETURN T))))
    909                     ;; OK, this flavor really contributes to handling this message
     1156      (COND ((OR (NOT SINGLE-OPERATION) (EQ MSG SINGLE-OPERATION))
     1157             ;; Well, we're supposed to concern ourselves with this operation
     1158             (SETQ ELEM (ASSQ MSG MAGIC-LIST))  ;What we already know about it
     1159             (COND ((DOLIST (METH (CDDDR MTE))
     1160                      (OR (EQ (METH-METHOD-TYPE METH) ':COMBINED) (RETURN T)))
     1161                    ;; OK, this flavor really contributes to handling this operation
    9101162                    (OR ELEM (PUSH (SETQ ELEM (LIST* MSG NIL NIL NIL)) MAGIC-LIST))
    911                     ;; For each non-combined method for this message, add it to the front
     1163                    ;; For each non-combined method for this operation, add it to the front
    9121164                    ;; of the magic-list element, thus they are in base-flavor-first order.
    913                     (DOLIST (X (CDDDR MTE))
    914                       (COND ((EQ (CAR X) ':COMBINED) )
    915                             ((NOT (SETQ TEM (ASSQ (CAR X) (CDDDR ELEM))))
    916                              (PUSH (LIST (CAR X) (CADR X)) (CDDDR ELEM)))
    917                             ((NOT (MEMQ (CADR X) (CDR TEM)))    ;but don't let a method
    918                              (PUSH (CADR X) (CDR TEM)))))))     ; get in twice
     1165                    (DOLIST (METH (CDDDR MTE))
     1166                      (LET ((TYPE (METH-METHOD-TYPE METH)))
     1167                        (COND ((EQ TYPE ':COMBINED))
     1168                              ((NOT (SETQ TEM (ASSQ TYPE (CDDDR ELEM))))
     1169                               (PUSH (LIST TYPE (METH-FUNCTION-SPEC METH)) (CDDDR ELEM)))
     1170                              ;; Don't let the same method get in twice (how could it?)
     1171                              ((NOT (MEMQ (METH-FUNCTION-SPEC METH) (CDR TEM)))
     1172                               (PUSH (METH-FUNCTION-SPEC METH) (CDR TEM))))))))
    9191173             ;; Pick up method-combination declarations
    9201174             (AND (CADR MTE) (CADR ELEM)        ;If both specify combination-type, check
     
    9451199                    (RPLACA TEM NIL)))
    9461200           (OR (SETQ TEM (GET (OR (CADR MTE) ':DAEMON) 'METHOD-COMBINATION))
    947                (FERROR NIL "~S unknown method combination type for ~S message"
     1201               (FERROR NIL "~S unknown method combination type for ~S operation"
    9481202                           (CADR MTE) (CAR MTE)))
    949            (PUSH (FUNCALL TEM FL MTE) SYMS))
     1203           (PUSH (FUNCALL TEM FL MTE) HANDLERS))
    9501204          (T (SETQ MAGIC-LIST (DELQ MTE MAGIC-LIST 1)))))
    951   ;; Get back into declared order
    952   (SETQ SYMS (NREVERSE SYMS))
     1205  ;; Get back into declared order.  We now have a list of function specs for handlers.
     1206  (SETQ HANDLERS (NREVERSE HANDLERS))
    9531207  (COND (*JUST-COMPILING* )     ;If just compiling, don't affect select-method
    954         (SINGLE-MESSAGE
    955           ;; If doing SINGLE-MESSAGE, put it into the select-method list
     1208        (SINGLE-OPERATION
     1209          ;; If doing SINGLE-OPERATION, put it into the select-method list
    9561210          (SETQ SM (%MAKE-POINTER DTP-LIST (FLAVOR-SELECT-METHOD FL)))
    957           (IF (SETQ ELEM (ASSQ-CAREFUL SINGLE-MESSAGE SM))
    958               (RPLACD ELEM (CAR SYMS))
    959               (RPLACD (LAST SM) (CONS-IN-AREA (CONS-IN-AREA SINGLE-MESSAGE (CAR SYMS)
    960                                                             PERMANENT-STORAGE-AREA)
    961                                               (CDR (LAST SM)) PERMANENT-STORAGE-AREA))))
     1211          (SETQ ELEM (ASSQ-CAREFUL SINGLE-OPERATION SM))
     1212          (COND ((NULL HANDLERS)                ;Deleting method
     1213                 (COND (ELEM
     1214                         (SETF (FLAVOR-SELECT-METHOD FL)
     1215                               (%MAKE-POINTER DTP-SELECT-METHOD (DELQ ELEM SM 1)))
     1216                         ;; This will have to be recomputed
     1217                         (SETF (FLAVOR-WHICH-OPERATIONS FL) NIL))))
     1218                (ELEM                           ;Replacing method
     1219                 (STORE-HANDLER-EVCP ELEM (CAR HANDLERS)))
     1220                (T (RPLACD (LAST SM)            ;Adding method
     1221                           (CONS-IN-AREA (CONS-HANDLER-EVCP SINGLE-OPERATION (CAR HANDLERS))
     1222                                         (CDR (LAST SM)) PERMANENT-STORAGE-AREA))
     1223                   ;; This will have to be recomputed
     1224                   (SETF (FLAVOR-WHICH-OPERATIONS FL) NIL))))
    9621225        (T
    9631226          ;; Now cons up the select-method list.  CDR-code its top-level to save on memory.
    964           (SETQ SM (MAKE-LIST PERMANENT-STORAGE-AREA (1+ (LENGTH MAGIC-LIST))))
     1227          (SETQ SM (MAKE-LIST (1+ (LENGTH MAGIC-LIST)) ':AREA PERMANENT-STORAGE-AREA))
    9651228          (DO ((SM SM (CDR SM))
    966                (SYMS SYMS (CDR SYMS))
     1229               (HANDLERS HANDLERS (CDR HANDLERS))
    9671230               (ML MAGIC-LIST (CDR ML)))
    9681231              ((NULL ML)
    9691232               ;; Final CDR is default handler
    970                (RPLACA SM (OR DEFAULT-HANDLER 'UNCLAIMED-MESSAGE))
     1233               (RPLACA SM (OR DEFAULT-HANDLER 'FLAVOR-UNCLAIMED-MESSAGE))
    9711234               (%P-DPB-OFFSET CDR-NORMAL %%Q-CDR-CODE SM -1)
    9721235               (%P-DPB-OFFSET CDR-ERROR %%Q-CDR-CODE SM 0))
    973             (RPLACA SM (CONS-IN-AREA (CAAR ML) (CAR SYMS) PERMANENT-STORAGE-AREA)))
     1236            (RPLACA SM (CONS-HANDLER-EVCP (CAAR ML) (CAR HANDLERS))))
    9741237          (SETF (FLAVOR-SELECT-METHOD FL) (%MAKE-POINTER DTP-SELECT-METHOD SM))
    975           (SETF (FLAVOR-WHICH-OPERATIONS FL) NIL)       ;This will have to be recomputed
    976           ;; Make sure that the required variables and methods are present.
    977           (DO ((FFLS (FLAVOR-DEPENDS-ON-ALL FL) (CDR FFLS))
    978                (MISSING-METHODS NIL)
    979                (MISSING-INSTANCE-VARIABLES NIL))
    980               ((NULL FFLS)
    981                (AND (OR MISSING-INSTANCE-VARIABLES MISSING-METHODS)
    982                     (FERROR NIL "Flavor ~S is missing ~:[~*~*~;instance variable~P ~{~S~^, ~} ~]~:[~;and ~]~:[~*~*~;method~P ~{~S~^, ~}~]"
    983                                 (FLAVOR-NAME FL)
    984                                 MISSING-INSTANCE-VARIABLES
    985                                 (LENGTH MISSING-INSTANCE-VARIABLES)
    986                                 MISSING-INSTANCE-VARIABLES
    987                                 (AND MISSING-INSTANCE-VARIABLES MISSING-METHODS)
    988                                 MISSING-METHODS
    989                                 (LENGTH MISSING-METHODS)
    990                                 MISSING-METHODS)))
    991             (SETQ FFL (GET (CAR FFLS) 'FLAVOR) PL (LOCF (FLAVOR-PLIST FFL)))
    992             (DOLIST (REQM (GET PL ':REQUIRED-METHODS))
    993               (OR (ASSQ REQM MAGIC-LIST)
    994                   (MEMQ REQM MISSING-METHODS)
    995                   (PUSH REQM MISSING-METHODS)))
    996             (DOLIST (REQV (GET PL ':REQUIRED-INSTANCE-VARIABLES))
    997               (OR (MEMQ REQV (FLAVOR-ALL-INSTANCE-VARIABLES FL))
    998                   (MEMQ REQV MISSING-INSTANCE-VARIABLES)
    999                   (PUSH REQV MISSING-INSTANCE-VARIABLES))))))
     1238          (SETF (FLAVOR-WHICH-OPERATIONS FL) NIL)))     ;This will have to be recomputed
     1239  (OR SINGLE-OPERATION
     1240      ;; Make sure that the required variables and methods are present.
     1241      (DO ((FFLS (FLAVOR-DEPENDS-ON-ALL FL) (CDR FFLS))
     1242           (MISSING-METHODS NIL)
     1243           (MISSING-INSTANCE-VARIABLES NIL)
     1244           (MISSING-FLAVORS NIL))
     1245          ((NULL FFLS)
     1246           (AND (OR MISSING-INSTANCE-VARIABLES MISSING-METHODS MISSING-FLAVORS)
     1247                (FERROR NIL "Flavor ~S is missing ~
     1248                                ~:[~2*~;instance variable~P ~{~S~^, ~} ~]~
     1249                                ~:[~3*~;~:[~;and ~]method~P ~{~S~^, ~}~]~
     1250                                ~:[~3*~;~:[~;and ~]component flavor~P ~{~S~^, ~}~]"
     1251                        (FLAVOR-NAME FL)
     1252                        MISSING-INSTANCE-VARIABLES
     1253                        (LENGTH MISSING-INSTANCE-VARIABLES)
     1254                        MISSING-INSTANCE-VARIABLES
     1255                        MISSING-METHODS
     1256                        MISSING-INSTANCE-VARIABLES
     1257                        (LENGTH MISSING-METHODS)
     1258                        MISSING-METHODS
     1259                        MISSING-FLAVORS
     1260                        (OR MISSING-INSTANCE-VARIABLES MISSING-METHODS)
     1261                        (LENGTH MISSING-FLAVORS)
     1262                        MISSING-FLAVORS)))
     1263        (SETQ FFL (GET (CAR FFLS) 'FLAVOR) PL (LOCF (FLAVOR-PLIST FFL)))
     1264        (DOLIST (REQM (GET PL ':REQUIRED-METHODS))
     1265          (OR (ASSQ REQM MAGIC-LIST)
     1266              (MEMQ REQM MISSING-METHODS)
     1267              (PUSH REQM MISSING-METHODS)))
     1268        (DOLIST (REQV (GET PL ':REQUIRED-INSTANCE-VARIABLES))
     1269          (OR (MEMQ REQV (FLAVOR-ALL-INSTANCE-VARIABLES FL))
     1270              (MEMQ REQV MISSING-INSTANCE-VARIABLES)
     1271              (PUSH REQV MISSING-INSTANCE-VARIABLES)))
     1272        (DOLIST (REQF (GET PL ':REQUIRED-FLAVORS))
     1273          (OR (MEMQ REQF (FLAVOR-DEPENDS-ON-ALL FL))
     1274              (MEMQ REQF MISSING-FLAVORS)
     1275              (PUSH REQF MISSING-FLAVORS)))))
    10001276  NIL)
     1277
     1278;This is the default handler for flavors.
     1279(DEFUN FLAVOR-UNCLAIMED-MESSAGE (&REST MESSAGE)
     1280  (IF (FUNCALL-SELF ':OPERATION-HANDLED-P ':UNCLAIMED-MESSAGE)
     1281      (LEXPR-FUNCALL-SELF ':UNCLAIMED-MESSAGE MESSAGE)
     1282      (FERROR ':UNCLAIMED-MESSAGE "The object ~S received a ~S message, which went unclaimed.
     1283The rest of the message was ~S~%" SELF (CAR MESSAGE) (CDR MESSAGE))))
     1284
     1285;Cons up an a-list entry mapping the message keyword into an evcp to the handler function cell
     1286(DEFUN CONS-HANDLER-EVCP (MESSAGE HANDLER)
     1287  (STORE-HANDLER-EVCP (CONS-IN-AREA MESSAGE NIL PERMANENT-STORAGE-AREA) HANDLER))
     1288
     1289;Store an external-value-cell-pointer to the function cell of the handler
     1290;into the cdr of the cons (a-list element)
     1291(DEFUN STORE-HANDLER-EVCP (LOC HANDLER)
     1292  (SETQ HANDLER (FDEFINITION-LOCATION HANDLER))
     1293  (LET ((P (%MAKE-POINTER-OFFSET DTP-LOCATIVE LOC 1)))
     1294    (%P-STORE-TAG-AND-POINTER P (+ (LSH (%P-CDR-CODE P) 6) DTP-EXTERNAL-VALUE-CELL-POINTER)
     1295                                HANDLER))
     1296  LOC)
    10011297
    10021298;; Make the instance-variable getting and setting methods
    10031299(DEFUN COMPOSE-AUTOMATIC-METHODS (FL)
    10041300  (DOLIST (V (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL))
    1005     (LET ((VV (INTERN (GET-PNAME V) "")))
     1301    (LET ((VV (CORRESPONDING-KEYWORD V)))
    10061302      (AND (OR *JUST-COMPILING* (NOT (FLAVOR-METHOD-EXISTS FL NIL VV)))
    1007            (LET ((LOCAL-DECLARATIONS (CONS `(SPECIAL ,V) LOCAL-DECLARATIONS)))
    1008              (COMPILE-AT-APPROPRIATE-TIME FL
    1009                                           `(:METHOD ,(FLAVOR-NAME FL) ,VV)
    1010                                           `(LAMBDA (IGNORE) ,V))))))
     1303           (LET ((LOCAL-DECLARATIONS (CONS `(SPECIAL ,V) LOCAL-DECLARATIONS))
     1304                 (METH `(:METHOD ,(FLAVOR-NAME FL) ,VV)))
     1305             (FLAVOR-NOTICE-METHOD METH)
     1306             (COMPILE-AT-APPROPRIATE-TIME FL METH `(LAMBDA (IGNORE) ,V))))))
    10111307  (DOLIST (V (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL))
    1012     (LET ((SV (INTERN1 (FORMAT NIL "SET-~A" V) "")))
     1308    (LET ((SV (INTERN1 (FORMAT NIL "SET-~A" V) PKG-USER-PACKAGE)))
    10131309      (AND (OR *JUST-COMPILING* (NOT (FLAVOR-METHOD-EXISTS FL NIL SV)))
    1014            (LET ((LOCAL-DECLARATIONS (CONS `(SPECIAL ,V) LOCAL-DECLARATIONS)))
    1015              (COMPILE-AT-APPROPRIATE-TIME FL
    1016                           `(:METHOD ,(FLAVOR-NAME FL) ,SV)
     1310           (LET ((LOCAL-DECLARATIONS (CONS `(SPECIAL ,V) LOCAL-DECLARATIONS))
     1311                 (METH `(:METHOD ,(FLAVOR-NAME FL) ,SV)))
     1312             (FLAVOR-NOTICE-METHOD METH)
     1313             (COMPILE-AT-APPROPRIATE-TIME FL METH
    10171314                          `(LAMBDA (IGNORE .NEWVALUE.) (SETQ ,V .NEWVALUE.))))))))
    10181315
     
    10221319         (RETURN-ARRAY PNAME)))
    10231320
     1321;Given a symbol return the corresponding one in the keyword package
     1322(DEFUN CORRESPONDING-KEYWORD (SYMBOL)
     1323  (INTERN (GET-PNAME SYMBOL) PKG-USER-PACKAGE))
     1324
    10241325
    10251326; Method-combination functions.  Found on the SI:METHOD-COMBINATION property
    10261327; of the combination-type.  These are passed the flavor structure, and the
    1027 ; magic-list entry, and must return the symbol to go into the select-method,
    1028 ; defining any necessary functions.  This function interprets combination-type-arg,
     1328; magic-list entry, and must return the function-spec for the handler
     1329; to go into the select-method, defining any necessary functions.
     1330; This function interprets combination-type-arg,
    10291331; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST.
    10301332
     
    10441346                                            ':BASE-FLAVOR-FIRST))
    10451347        (WRAPPERS-P (ASSQ ':WRAPPER (CDDDR MAGIC-LIST-ENTRY))))
     1348    ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like
     1349    ;; we depend on them (which could cause extraneous combined-method recompilation).
     1350    (LET ((MLE (ASSQ NIL (CDDDR MAGIC-LIST-ENTRY))))
     1351      (AND (CDDR MLE)
     1352           (SETF (CDR MLE) (LIST PRIMARY-METHOD))))
    10461353    (OR (AND (NOT WRAPPERS-P) (NULL BEFORE-METHODS) (NULL AFTER-METHODS) PRIMARY-METHOD)
    10471354        (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY)
     
    10641371                        `(LEXPR-FUNCALL #',PRIMARY-METHOD .DAEMON-CALLER-ARGS.))))))))
    10651372
     1373; :DAEMON-WITH-OVERRIDE combination
     1374; This is the same as :DAEMON (the default), except that :OVERRIDE type methods
     1375; are combined with the :BEFORE-primary-:AFTER methods in an OR.  This allows
     1376; overriding of the main methods function.  For example, a combined method as follows
     1377; might be generated: (OR (FOO-OVERRIDE-BAR-METHOD) (PROGN (FOO-BEFORE-BAR-METHOD)))
     1378(DEFUN (:DAEMON-WITH-OVERRIDE METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY)
     1379  (LET ((PRIMARY-METHOD (CAR (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL
     1380                                                  '(:BEFORE :AFTER :OVERRIDE) T
     1381                                                  ':BASE-FLAVOR-LAST)))
     1382        (BEFORE-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':BEFORE T T
     1383                                             ':BASE-FLAVOR-LAST))
     1384        (AFTER-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':AFTER T T
     1385                                            ':BASE-FLAVOR-FIRST))
     1386        (WRAPPERS-P (ASSQ ':WRAPPER (CDDDR MAGIC-LIST-ENTRY)))
     1387        (OVERRIDE-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY
     1388                                               ':OVERRIDE T T ':BASE-FLAVOR-LAST)))
     1389    ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like
     1390    ;; we depend on them (which could cause extraneous combined-method recompilation).
     1391    (LET ((MLE (ASSQ NIL (CDDDR MAGIC-LIST-ENTRY))))
     1392      (AND (CDDR MLE)
     1393           (SETF (CDR MLE) (LIST PRIMARY-METHOD))))
     1394    (OR (AND (NOT WRAPPERS-P) (NULL BEFORE-METHODS) (NULL AFTER-METHODS)
     1395             (NULL OVERRIDE-METHODS)
     1396             PRIMARY-METHOD)
     1397        (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY)
     1398        (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY
     1399          `(OR ,@(MAPCAR #'(LAMBDA (X) `(LEXPR-FUNCALL #',X .DAEMON-CALLER-ARGS.))
     1400                         OVERRIDE-METHODS)
     1401             (PROGN
     1402              ,@(MAPCAR #'(LAMBDA (X) `(LEXPR-FUNCALL #',X .DAEMON-CALLER-ARGS.))
     1403                        BEFORE-METHODS)
     1404              ,(IF AFTER-METHODS
     1405                   ;; Kludge to return a few multiple values
     1406                   `(PROG (.VAL1. .VAL2. .VAL3.)
     1407                       ,(AND PRIMARY-METHOD
     1408                             `(MULTIPLE-VALUE (.VAL1. .VAL2. .VAL3.)
     1409                                (LEXPR-FUNCALL #',PRIMARY-METHOD .DAEMON-CALLER-ARGS.)))
     1410                       ,@(MAPCAR #'(LAMBDA (X) `(LEXPR-FUNCALL #',X .DAEMON-CALLER-ARGS.))
     1411                                 AFTER-METHODS)
     1412                       (RETURN .VAL1. .VAL2. .VAL3.))
     1413                   ;; No :AFTER methods, hair not required
     1414                   ;; You are allowed to not have a primary method
     1415                   (AND PRIMARY-METHOD
     1416                        `(LEXPR-FUNCALL #',PRIMARY-METHOD .DAEMON-CALLER-ARGS.)))))))))
     1417
    10661418; :LIST combination
    10671419; No typed-methods allowed.  Returns a list of the results of all the methods.
     
    10851437                    (R NIL))
    10861438                   ((NULL ML) (NREVERSE R))
    1087                  (PUSH `(,(CAR ML) (CAR .DAEMON-CALLER-ARGS.) (CAR .FOO.)) R)
     1439                 (PUSH `(FUNCALL #',(CAR ML) (CAR .DAEMON-CALLER-ARGS.) (CAR .FOO.)) R)
    10881440                 (AND (CDR ML) (PUSH '(SETQ .FOO. (CDR .FOO.)) R)))))))
    10891441
     
    11101462                 (MAPCAR #'(LAMBDA (M) `(LEXPR-FUNCALL #',M .DAEMON-CALLER-ARGS.))
    11111463                         METHODS))))))
     1464
     1465; :PASS-ON combination
     1466; The values from the individual methods are the arguments to the next one;
     1467; the values from the last method are the values returned by the combined
     1468; method.  Format is (:METHOD-COMBINATION (:PASS-ON (ORDERING . ARGLIST)) . OPERATION-NAMES)
     1469; ORDERING is :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST.  ARGLIST can have &AUX and &OPTIONAL.
     1470
     1471(DEFUN (:PASS-ON METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY)
     1472  (LET ((METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL NIL NIL (CAADDR MAGIC-LIST-ENTRY)))
     1473        (ARGLIST (CDADDR MAGIC-LIST-ENTRY))
     1474        ARGS REST-ARG-P)
     1475    (DO ((L ARGLIST (CDR L))
     1476         (ARG)
     1477         (NL NIL))
     1478        ((NULL L)
     1479         (SETQ ARGS (NREVERSE NL)))
     1480      (SETQ ARG (CAR L))
     1481      (AND (LISTP ARG)
     1482           (SETQ ARG (CAR ARG)))
     1483      (COND ((EQ ARG '&REST)
     1484             (SETQ REST-ARG-P T))
     1485            ((EQ ARG '&AUX))
     1486            (T
     1487             (PUSH ARG NL))))     
     1488    (OR (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY)
     1489        (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY
     1490          `(DESTRUCTURING-BIND ,(CONS '.OPERATION. ARGLIST) SI:.DAEMON-CALLER-ARGS.
     1491             . ,(DO ((METHS METHODS (CDR METHS))
     1492                     (LIST NIL)
     1493                     (METH))
     1494                    ((NULL METHS)
     1495                     (NREVERSE LIST))
     1496                  (SETQ METH `(,(IF REST-ARG-P 'LEXPR-FUNCALL 'FUNCALL)
     1497                               #',(CAR METHS) .OPERATION. . ,ARGS))
     1498                  (AND (CDR METHS)
     1499                       (SETQ METH (IF (NULL (CDR ARGS))
     1500                                      `(SETQ ,(CAR ARGS) ,METH)
     1501                                      `(MULTIPLE-VALUE ,ARGS ,METH))))
     1502                  (PUSH METH LIST)))))))
    11121503
    11131504
     
    11491540;; Always canonicalizes the magic-list-entry, since it will be needed
    11501541;; canonicalized later.
    1151 (DEFUN HAVE-COMBINED-METHOD (FL MAGIC-LIST-ENTRY &AUX MESSAGE-NAME CMS TEM)
     1542(DEFUN HAVE-COMBINED-METHOD (FL MAGIC-LIST-ENTRY
     1543                             &AUX OPERATION-NAME CMS MTE OLD-MLE OLD-CMS TEM)
    11521544  ;; Canonicalize the magic-list-entry so can compare with EQUAL
    11531545  (SETF (CDDDR MAGIC-LIST-ENTRY)                ;Canonicalize before comparing
    1154         (SORTCAR (CDDDR MAGIC-LIST-ENTRY) #'STRING-LESSP))
    1155   ;; Get the :COMBINED method symbol for this flavor.  Note that if a suitable
    1156   ;; one can be inherited, we will do so, unless directed not to by
    1157   ;; *USE-OLD-COMBINED-METHODS*.
    1158   (SETQ MESSAGE-NAME (CAR MAGIC-LIST-ENTRY)
    1159         CMS (AND *USE-OLD-COMBINED-METHODS*
    1160                  (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL))
    1161                    (AND (SETQ TEM (ASSQ ':COMBINED
    1162                                     (CDDDR (ASSQ MESSAGE-NAME
    1163                                                  (FLAVOR-METHOD-TABLE (GET FFL 'FLAVOR))))))
    1164                         (RETURN (CADR TEM))))))
    1165   ;; If all OK, return the symbol, else return NIL if new combined method must be made
    1166   (AND CMS (EQUAL MAGIC-LIST-ENTRY (GET CMS 'COMBINED-METHOD-DERIVATION))
    1167        CMS))
    1168 
    1169 ;; This function creates a combined-method, and returns the appropriate symbol.
     1546        (SORTCAR (CDDDR MAGIC-LIST-ENTRY) #'STRING-LESSP))      ;Sort by method-type
     1547  (SETQ OPERATION-NAME (CAR MAGIC-LIST-ENTRY))
     1548  ;; Get the :COMBINED method function spec for this flavor.  Note that if a suitable
     1549  ;; one can be inherited, we will do so.
     1550  ;; *USE-OLD-COMBINED-METHODS* controls whether we reuse an existing one for this
     1551  ;; flavor; if we inherit one it will always be up-to-date already.
     1552  ;; If all OK, return the function spec, else return NIL if new combined method must be made.
     1553  (OR (AND *USE-OLD-COMBINED-METHODS*           ;See if we already have one ourselves
     1554           (SETQ MTE (ASSQ OPERATION-NAME (FLAVOR-METHOD-TABLE FL)))
     1555           (SETQ OLD-CMS (SETQ CMS (METH-FUNCTION-SPEC (METH-LOOKUP ':COMBINED (CDDDR MTE)))))
     1556           (FDEFINEDP CMS)
     1557           (EQUAL MAGIC-LIST-ENTRY
     1558                  (SETQ OLD-MLE (FUNCTION-SPEC-GET CMS 'COMBINED-METHOD-DERIVATION)))
     1559           CMS)
     1560      ;; See if we can inherit one in either the current or future (being-compiled) world
     1561      (DOLIST (FFL (CDR (FLAVOR-DEPENDS-ON-ALL FL)))  ;CDR = not self!
     1562        (AND (SETQ MTE (ASSQ OPERATION-NAME (FLAVOR-METHOD-TABLE (GET FFL 'FLAVOR))))
     1563             (SETQ CMS (METH-FUNCTION-SPEC (METH-LOOKUP ':COMBINED (CDDDR MTE))))
     1564             (OR (FDEFINEDP CMS) *JUST-COMPILING*)
     1565             (EQUAL MAGIC-LIST-ENTRY
     1566                    (SETQ TEM
     1567                          (OR (AND *JUST-COMPILING*
     1568                                  (FUNCTION-SPEC-GET CMS 'FUTURE-COMBINED-METHOD-DERIVATION))
     1569                              (FUNCTION-SPEC-GET CMS 'COMBINED-METHOD-DERIVATION))))
     1570             (RETURN CMS))
     1571        ;Save first combined-method seen for tracing, it's the one we would
     1572        ;have been most likely to inherit
     1573        (OR OLD-CMS (NULL CMS) (NULL TEM)
     1574            (SETQ OLD-CMS CMS OLD-MLE TEM)))
     1575      ;; Have to make a new combined method.  Trace if desired, but return NIL in any case.
     1576      (PROGN
     1577        (COND (*FLAVOR-COMPILE-TRACE*
     1578               (FORMAT *FLAVOR-COMPILE-TRACE*
     1579                       "~&~S's ~S combined method needs to be recompiled~%to come from "
     1580                       (FLAVOR-NAME FL) OPERATION-NAME)
     1581               (PRINT-COMBINED-METHOD-DERIVATION MAGIC-LIST-ENTRY *FLAVOR-COMPILE-TRACE*)
     1582               (COND (OLD-CMS
     1583                      (FORMAT *FLAVOR-COMPILE-TRACE*
     1584                              "~%rather than using ~S which comes from " OLD-CMS)
     1585                      (PRINT-COMBINED-METHOD-DERIVATION OLD-MLE *FLAVOR-COMPILE-TRACE*))
     1586                     ((NOT *USE-OLD-COMBINED-METHODS*)
     1587                      (FORMAT *FLAVOR-COMPILE-TRACE* "~%because of forced recompilation.")))))
     1588        NIL)))
     1589
     1590
     1591(DEFUN PRINT-COMBINED-METHOD-DERIVATION (MLE STREAM)
     1592  (LOOP FOR (TYPE . FUNCTION-SPECS) IN (CDDDR MLE)
     1593        DO (LOOP FOR FUNCTION-SPEC IN FUNCTION-SPECS DO (FORMAT STREAM "~S " FUNCTION-SPEC)))
     1594  (IF (OR (CADR MLE) (CADDR MLE))
     1595      (FORMAT STREAM "with method-combination ~S ~S" (CADR MLE) (CADDR MLE))))
     1596
     1597;; This function creates a combined-method, and returns the appropriate function spec.
    11701598;; Its main job in life is to take care of wrappers.  Note the combined method
    11711599;; always takes a single &REST argument named .DAEMON-CALLER-ARGS.
    11721600;; FORM is a single form to be used as the body.
    1173 (DEFUN MAKE-COMBINED-METHOD (FL MAGIC-LIST-ENTRY FORM
    1174                              &AUX FSPEC COMBINED-METHOD-SYMBOL)
    1175   ;; Get the symbol which will name the combined-method
    1176   (SETQ FSPEC `(,(FLAVOR-NAME FL) :COMBINED ,(CAR MAGIC-LIST-ENTRY))
    1177         COMBINED-METHOD-SYMBOL (FLAVOR-METHOD-SYMBOL FSPEC))
     1601(DEFUN MAKE-COMBINED-METHOD (FL MAGIC-LIST-ENTRY FORM &AUX FSPEC)
     1602  ;; Get the function spec which will name the combined-method
     1603  (SETQ FSPEC `(:METHOD ,(FLAVOR-NAME FL) :COMBINED ,(CAR MAGIC-LIST-ENTRY)))
    11781604  ;; Put the wrappers around the form.  The base-flavor wrapper goes on the inside.
    11791605  ;; Here we just put the macro-names.  The macros will be expanded by the compiler.
    11801606  (DO ((WRAPPERS (CDR (ASSQ ':WRAPPER (CDDDR MAGIC-LIST-ENTRY))) (CDR WRAPPERS)))
    11811607      ((NULL WRAPPERS))
    1182     (OR (AND (FBOUNDP (CAR WRAPPERS)) (EQ (CAR (FSYMEVAL (CAR WRAPPERS))) 'MACRO))
     1608    (OR (AND (FDEFINEDP (CAR WRAPPERS))
     1609             (LET ((DEF (FDEFINITION (CAR WRAPPERS))))
     1610               (OR (AND (LISTP DEF) (EQ (CAR DEF) 'MACRO))
     1611                   ;--- temporary code so I can test things in the kludge environment
     1612                   (AND (SYMBOLP DEF)
     1613                        (EQ (CAR (FSYMEVAL DEF)) 'MACRO)))))
    11831614        (FERROR NIL "~S supposed to be a wrapper macro, but missing!" (CAR WRAPPERS)))
    1184     (SETQ FORM (LIST (CAR WRAPPERS) '.DAEMON-CALLER-ARGS. FORM)))
     1615    (SETQ FORM `(MACROCALL #',(CAR WRAPPERS) .DAEMON-CALLER-ARGS. ,FORM)))
     1616  ;; Remember that it's going to be there, for HAVE-COMBINED-METHOD
     1617  (FLAVOR-NOTICE-METHOD FSPEC)
     1618  (IF *JUST-COMPILING*
     1619      (FUNCTION-SPEC-PUTPROP FSPEC MAGIC-LIST-ENTRY 'FUTURE-COMBINED-METHOD-DERIVATION))
    11851620  ;; Compile the function.  It will be inserted into the flavor's tables either
    11861621  ;; now or when the QFASL file is loaded.
     
    11901625    (COMPILE-AT-APPROPRIATE-TIME
    11911626        FL
    1192         (CONS ':METHOD FSPEC)
     1627        FSPEC
    11931628        `(LAMBDA (&REST .DAEMON-CALLER-ARGS.)
    11941629           ,FORM)
    1195         `(DEFPROP ,COMBINED-METHOD-SYMBOL
    1196                   ,MAGIC-LIST-ENTRY
    1197                   COMBINED-METHOD-DERIVATION)))
    1198   COMBINED-METHOD-SYMBOL)
     1630        `(FUNCTION-SPEC-PUTPROP ',FSPEC
     1631                                ',MAGIC-LIST-ENTRY
     1632                                'COMBINED-METHOD-DERIVATION)))
     1633  FSPEC)
     1634
     1635;Sort of a macro version of funcall, for wrappers
     1636(DEFMACRO MACROCALL (&REST X)
     1637  (LET ((MACRO (EVAL (CAR X))))
     1638    (IF (AND (LISTP MACRO) (EQ (CAR MACRO) 'MACRO))
     1639        (FUNCALL (CDR MACRO) X)
     1640        ;--- Temporary code so I can test things in the kludge environment
     1641        (IF (AND (SYMBOLP MACRO) (LISTP (FSYMEVAL MACRO)) (EQ (CAR (FSYMEVAL MACRO)) 'MACRO))
     1642            (FUNCALL (CDR (FSYMEVAL MACRO)) X)
     1643            (FERROR NIL "~S evaluated to ~S, which is not a macro" (CAR X) MACRO)))))
     1644
    11991645
    12001646;Return the SPECIAL declaration for a flavor, suitable for use in methods.
     
    12311677  (:DOCUMENTATION :MIXIN "The default base flavor.
    12321678This flavor provides the normal handlers for the :PRINT, :DESCRIBE, and :WHICH-OPERATIONS
    1233 messages.  Only esoteric hacks should give the :NO-VANILLA-FLAVOR option to DEFFLAVOR to
     1679operations.  Only esoteric hacks should give the :NO-VANILLA-FLAVOR option to DEFFLAVOR to
    12341680prevent this inclusion."))
    12351681)
    12361682
    1237 (DEFMETHOD (VANILLA-FLAVOR :PRINT) (STREAM &REST ARGS)
    1238   (LEXPR-FUNCALL-SELF ':PRINT-SELF STREAM ARGS))
    1239 
    12401683(DEFMETHOD (VANILLA-FLAVOR :PRINT-SELF) (STREAM &REST IGNORE)
    1241   (FORMAT STREAM "#<~A ~O>" (TYPEP SELF) (%POINTER SELF)))
     1684  (SI:PRINTING-RANDOM-OBJECT (SELF STREAM)
     1685    (PRINC (TYPEP SELF) STREAM)))
    12421686
    12431687(DEFMETHOD (VANILLA-FLAVOR :DESCRIBE) ()
     
    12561700          (T (FORMAT T "~S~%" (%P-CONTENTS-OFFSET SELF I))))))
    12571701
    1258 ;The default response to :WHICH-OPERATIONS is a list of all messages
     1702;The default response to :WHICH-OPERATIONS is a list of all operations
    12591703;handled.  The list is consed up just once.  It is computed by examination
    12601704;of the dtp-select-method table, since that has no duplications.
     
    12651709        (SETF (FLAVOR-WHICH-OPERATIONS FL)
    12661710              (LET ((S-M (%MAKE-POINTER DTP-LIST (FLAVOR-SELECT-METHOD FL))))
    1267                 (LET ((W-O (MAKE-LIST DEFAULT-CONS-AREA (LENGTH S-M))))
     1711                (LET ((W-O (MAKE-LIST (LENGTH S-M) ':AREA PERMANENT-STORAGE-AREA)))
    12681712                  (DO ((S-M S-M (CDR S-M))
    12691713                       (R W-O (CDR R)))
    12701714                      ((ATOM S-M) W-O)
    12711715                    (RPLACA R (CAAR S-M)))))))))
     1716
     1717(DEFMETHOD (VANILLA-FLAVOR :OPERATION-HANDLED-P) (OP)
     1718  (LET* ((FL (%MAKE-POINTER DTP-ARRAY-POINTER (%P-CONTENTS-AS-LOCATIVE-OFFSET SELF 0)))
     1719         (WO (OR (FLAVOR-WHICH-OPERATIONS FL) (FUNCALL-SELF ':WHICH-OPERATIONS))))
     1720    (NOT (NOT (MEMQ OP WO)))))
     1721
     1722(DEFMETHOD (VANILLA-FLAVOR :SEND-IF-HANDLES) (OP &REST TO-SEND)
     1723  (LET* ((FL (%MAKE-POINTER DTP-ARRAY-POINTER (%P-CONTENTS-AS-LOCATIVE-OFFSET SELF 0)))
     1724         (WO (OR (FLAVOR-WHICH-OPERATIONS FL) (FUNCALL-SELF ':WHICH-OPERATIONS))))
     1725    (AND (MEMQ OP WO)
     1726         (LEXPR-FUNCALL-SELF OP TO-SEND))))
    12721727
    12731728;This is useful for debugging.  E.g. you can get a break with all the
     
    12791734(DEFMETHOD (VANILLA-FLAVOR :FUNCALL-INSIDE-YOURSELF) (FUNCTION &REST ARGS)
    12801735  (APPLY FUNCTION ARGS))
     1736
     1737(DEFMETHOD (VANILLA-FLAVOR :GET-HANDLER-FOR) (OP)
     1738  (GET-HANDLER-FOR SELF OP))
     1739
     1740
     1741;;; This flavor is a useful mixin that provides messages for a property list protocol.
     1742
     1743(DEFFLAVOR PROPERTY-LIST-MIXIN ((PROPERTY-LIST NIL)) ()
     1744  :SETTABLE-INSTANCE-VARIABLES
     1745  (:DOCUMENTATION :MIXIN "A mixin that provides property list messages."))
     1746
     1747(DEFMETHOD (PROPERTY-LIST-MIXIN :GET) (INDICATOR)
     1748  (GET (LOCF PROPERTY-LIST) INDICATOR))
     1749
     1750(DEFMETHOD (PROPERTY-LIST-MIXIN :GETL) (INDICATOR-LIST)
     1751  (GETL (LOCF PROPERTY-LIST) INDICATOR-LIST))
     1752
     1753(DEFMETHOD (PROPERTY-LIST-MIXIN :PUTPROP) (PROPERTY INDICATOR)
     1754  (PUTPROP (LOCF PROPERTY-LIST) PROPERTY INDICATOR))
     1755
     1756(DEFMETHOD (PROPERTY-LIST-MIXIN :REMPROP) (INDICATOR)
     1757  (REMPROP (LOCF PROPERTY-LIST) INDICATOR))
     1758
     1759(DEFMETHOD (PROPERTY-LIST-MIXIN :PUSH-PROPERTY) (PROPERTY INDICATOR)
     1760  (PUSH PROPERTY (GET (LOCF PROPERTY-LIST) INDICATOR)))
     1761
     1762(DEFMETHOD (PROPERTY-LIST-MIXIN :PLIST) () PROPERTY-LIST)
    12811763
    12821764
     
    12871769    (SELECT (%DATA-TYPE FUNCTION)
    12881770      (DTP-ARRAY-POINTER
    1289        (AND (NAMED-STRUCTURE-P FUNCTION)        ;This is a crock
    1290             (SETQ FUNCTION (NAMED-STRUCTURE-SYMBOL FUNCTION))))
     1771       (AND (NAMED-STRUCTURE-P FUNCTION)        ;This is a crock (why?)
     1772            (SETQ FUNCTION (GET (NAMED-STRUCTURE-SYMBOL FUNCTION) 'NAMED-STRUCTURE-INVOKE))))
    12911773      (DTP-SYMBOL
    12921774       (OR (FBOUNDP FUNCTION) (RETURN NIL))
     
    13121794       (RETURN-FROM GET-HANDLER-FOR NIL)))))
    13131795
     1796;;; Get the function that would handle an operation for a flavor
     1797(DEFUN GET-FLAVOR-HANDLER-FOR (FLAVOR-NAME OPERATION &OPTIONAL (SUPERIORS-P T) &AUX FL)
     1798  (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) "the name of a flavor")
     1799  ;; Do any composition (compilation) of combined stuff, if not done already
     1800  (OR (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL))
     1801  (OR (FLAVOR-SELECT-METHOD FL) (COMPOSE-METHOD-COMBINATION FL))
     1802  (GET-HANDLER-FOR (FLAVOR-SELECT-METHOD FL) OPERATION SUPERIORS-P))
     1803
     1804;; (:HANDLER flavor operation) refers to the function that is called when
     1805;;   an object of flavor FLAVOR is sent the message OPERATION.
     1806;; Storing into this changes the select-method for that specific flavor
     1807;;  which should make it possible to trace and so forth.
     1808(DEFPROP :HANDLER HANDLER-FUNCTION-SPEC-HANDLER FUNCTION-SPEC-HANDLER)
     1809(DEFUN HANDLER-FUNCTION-SPEC-HANDLER (FUNCTION FUNCTION-SPEC &OPTIONAL ARG1 ARG2)
     1810  (LET ((FLAVOR (SECOND FUNCTION-SPEC))
     1811        (MESSAGE (THIRD FUNCTION-SPEC)))
     1812    ;; Checking structure like :INTERNAL
     1813    (AND (SYMBOLP FLAVOR)
     1814         (LET ((FL (GET FLAVOR 'FLAVOR)))
     1815           (OR FL (FERROR NIL "In the function spec ~S, ~S is not the name of a flavor"
     1816                              FUNCTION-SPEC FLAVOR))
     1817           ;; Do any composition (compilation) of combined stuff, if not done already
     1818           (OR (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL))
     1819           (OR (FLAVOR-SELECT-METHOD FL) (COMPOSE-METHOD-COMBINATION FL))
     1820           (LET ((LOC (DO ((L (%MAKE-POINTER DTP-LIST (FLAVOR-SELECT-METHOD FL)) (CDR L)))
     1821                          ((ATOM L) NIL)
     1822                        (IF (EQ (CAAR L) MESSAGE)
     1823                            (RETURN (CAR L))))))        ;CDR of this is the method
     1824             (OR (NOT (NULL LOC))
     1825                 (MEMQ FUNCTION '(VALIDATE-FUNCTION-SPEC FDEFINEDP))
     1826                 (FERROR NIL "The flavor ~S does not handle the ~S message" FLAVOR MESSAGE))
     1827             (SELECTQ FUNCTION
     1828               (VALIDATE-FUNCTION-SPEC (AND (= (LENGTH FUNCTION-SPEC) 3)
     1829                                            (SYMBOLP MESSAGE)))
     1830               (FDEFINE (RPLACD LOC ARG1))
     1831               (FDEFINITION (CDR LOC))
     1832               (FDEFINEDP LOC)
     1833               (FDEFINITION-LOCATION LOC)
     1834               (FUNDEFINE (FERROR NIL "FUNDEFINE is not implemented for :HANDLER"))
     1835               (OTHERWISE (FUNCTION-SPEC-DEFAULT-HANDLER FUNCTION FUNCTION-SPEC ARG1 ARG2))
     1836               ))))))
     1837
     1838
    13141839(DEFPROP %INSTANCE-REF ((%INSTANCE-REF INSTANCE INDEX)
    13151840                        %INSTANCE-SET VAL INSTANCE INDEX) SETF)
     
    13791904               'COMPILER:QFASL 'COMPILER:COMPILE-TO-CORE))
    13801905        ;; This case if not doing anything special
    1381         (LET ((FDEFINE-FILE-SYMBOL NIL)
     1906        (LET ((FDEFINE-FILE-PATHNAME NIL)
    13821907              (INHIBIT-FDEFINE-WARNINGS T))
    13831908          (PUSH NAME *FLAVOR-COMPILATIONS*)
     
    14221947(DEFUN COMPILE-FLAVOR-METHODS-2 (FLAVOR-NAME &AUX FL)
    14231948  (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) "the name of a flavor")
    1424   (PUTPROP (LOCF (FLAVOR-PLIST FL)) T 'COMPILE-FLAVOR-METHODS)
     1949  (PUTPROP (LOCF (FLAVOR-PLIST FL)) (OR FDEFINE-FILE-PATHNAME T) 'COMPILE-FLAVOR-METHODS)
    14251950  (COND ((FLAVOR-COMPONENTS-DEFINED-P FLAVOR-NAME)
    14261951         (OR (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL))
  • trunk/lisp/lispm2/gc.lisp

    r247 r278  
    55;;; Some GC-related functions that need to be in the cold-load can be found in QRAND.
    66
    7 ;*** Needs a facility which continuously maintains a second who-line with gc stats
    8 ;*** Needs a way to sound a warning when you are close to running out of virtual memory
     7;*** Needs a facility which continuously maintains a second who-line with gc stats?
    98
    109
     
    4241                                        ;like a copying garbage collector.
    4342
    44 ;;; Fix some things which the cold-load generator sets up wrong.
    45 (DEFUN GC-ONCE-INIT (&AUX BITS)
    46   ;; The cold-load does not set up the %%REGION-SCAVENGE-ENABLE bits, and gets
    47   ;; the REGION-GC-POINTER's wrong, at least in LINEAR-PDL-AREA and LINEAR-BIND-PDL-AREA.
    48   ;; This then gets propagated through all newly-created regions.
    49   (DO REGION SIZE-OF-AREA-ARRAYS (1- REGION) (MINUSP REGION)
    50     (STORE (REGION-GC-POINTER REGION) 0) ;assuming no compact-consing regions yet
    51     (SETQ BITS (REGION-BITS REGION))
    52     (STORE (REGION-BITS REGION)
    53            (%LOGDPB (SELECT (LDB %%REGION-SPACE-TYPE BITS)
    54                   ;; These should not be scavenged
    55                   ((%REGION-SPACE-FREE %REGION-SPACE-EXITED
    56                     %REGION-SPACE-EXTRA-PDL ;Very important!! This does not follow the
    57                                             ;prescribed protocol for use of header-forward
    58                                             ;and body-forward.  Also this area gets randomly
    59                                             ;reset without interfacing with the scavenger.
    60                     %REGION-SPACE-WIRED %REGION-SPACE-USER-PAGED) 0)
    61                   ;; These usually should be scavenged, except for efficiency certain ones
    62                   ;; that only contain fixnums will be bypassed
    63                   (%REGION-SPACE-FIXED
    64                     (COND ((OR (= REGION MICRO-CODE-SYMBOL-AREA)
    65                                (= REGION PAGE-TABLE-AREA)
    66                                (= REGION PHYSICAL-PAGE-DATA)
    67                                (= REGION REGION-ORIGIN)
    68                                (= REGION REGION-LENGTH)
    69                                (= REGION REGION-BITS)
    70                                (= REGION REGION-SORTED-BY-ORIGIN)
    71                                (= REGION REGION-FREE-POINTER)
    72                                (= REGION REGION-GC-POINTER)
    73                                (= REGION REGION-LIST-THREAD)
    74                                (= REGION AREA-REGION-LIST)
    75                                (= REGION AREA-REGION-SIZE)
    76                                (= REGION AREA-MAXIMUM-SIZE)
    77                                (= REGION MICRO-CODE-ENTRY-AREA)
    78                                (= REGION MICRO-CODE-ENTRY-MAX-PDL-USAGE))
    79                            0)
    80                           (T 1)))
    81                   ;; Newspace doesn't need scavenging
    82                   (%REGION-SPACE-NEW 0)
    83                   ;; Other regions should be scavenged
    84                   (OTHERWISE 1))
    85                 %%REGION-SCAVENGE-ENABLE BITS)))
    86   ;; Crank up the default region-size for certain areas
    87   (DO L '(WORKING-STORAGE-AREA 200000 MACRO-COMPILED-PROGRAM 200000
    88           P-N-STRING 200000 NR-SYM 100000)
    89       (CDDR L) (NULL L)
    90     (STORE (AREA-REGION-SIZE (SYMEVAL (CAR L))) (CADR L))))
    91 
    92 (ADD-INITIALIZATION "GC-ONCE" '(GC-ONCE-INIT) '(ONCE))
    93 
    94 ;;; Check the size of the free regions in case this is a band
    95 ;;; that was shipped over from a machine with a different size paging partition.
    96 (DEFUN GC-CHECK-FREE-REGIONS (PAGE-PART-SIZE)
    97   ;; Find the size of the paging partition and adjust the free area if necessary.
    98   ;; The microcode already knows this, but it isn't left around, so read the label again.
    99   (LET ((HIGHEST-PAGE-USED 0) (PAGE-NUMBER-FIELD 1020))
    100     (WITHOUT-INTERRUPTS  ;Don't let any allocation happen
    101       (DO REGION SIZE-OF-AREA-ARRAYS (1- REGION) (MINUSP REGION)
    102         (LET ((REGION-TOP (+ (LDB PAGE-NUMBER-FIELD (REGION-ORIGIN REGION))
    103                              (LDB PAGE-NUMBER-FIELD (REGION-LENGTH REGION)))))
    104           (SETQ HIGHEST-PAGE-USED (MAX REGION-TOP HIGHEST-PAGE-USED))))
    105       (DO REGION (AREA-REGION-LIST FREE-AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
    106         (LET ((REGION-TOP (+ (LDB PAGE-NUMBER-FIELD (REGION-ORIGIN REGION))
    107                              (LDB PAGE-NUMBER-FIELD (REGION-LENGTH REGION)))))
    108           (COND ((OR (> REGION-TOP PAGE-PART-SIZE) (= REGION-TOP HIGHEST-PAGE-USED))
    109                  (STORE (REGION-LENGTH REGION)
    110                         (%LOGDPB (MAX 0 (- PAGE-PART-SIZE
    111                                            (LDB PAGE-NUMBER-FIELD (REGION-ORIGIN REGION))))
    112                                  PAGE-NUMBER-FIELD 0)))))))))
    113 
    114 (DEFUN GC-REPORT-STREAM ()
    115   (IF (EQ GC-REPORT-STREAM T) (TV:GET-NOTIFICATION-STREAM) GC-REPORT-STREAM))
     43(DEFVAR GC-SCAVENGER-WS-SIZE)           ;Physical pages the scavenger may use.
     44                                        ; Don't set this variable directly,
     45                                        ; instead call SET-SCAVENGER-WS.
     46
     47;Args like FORMAT, but stream comes from GC-REPORT-STREAM
     48(DEFUN GC-REPORT (FORMAT-CONTROL &REST FORMAT-ARGS)
     49  (COND ((NULL GC-REPORT-STREAM))
     50        ((EQ GC-REPORT-STREAM T)
     51         (LEXPR-FUNCALL #'TV:NOTIFY NIL FORMAT-CONTROL FORMAT-ARGS))
     52        (T (LEXPR-FUNCALL #'FORMAT GC-REPORT-STREAM FORMAT-CONTROL FORMAT-ARGS))))
    11653
    11754
     
    14885  (MULTIPLE-VALUE-BIND (DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE)
    14986                (GC-GET-SPACE-SIZES)
    150     (AND GC-REPORT-STREAM
    151          (FORMAT (GC-REPORT-STREAM) ;separate static from exited when exited exists?
    152              "~&[GC: About to flip.  Dynamic space=~D., Static space=~D., Free space=~D.]~%"
    153              DYNAMIC-SIZE (+ STATIC-SIZE EXITED-SIZE) FREE-SIZE))
     87    (GC-REPORT ;separate static from exited when exited exists?
     88                "GC: About to flip.  Dynamic space=~D., Static space=~D., Free space=~D."
     89                DYNAMIC-SIZE (+ STATIC-SIZE EXITED-SIZE) FREE-SIZE)
    15490    ;; Perform whatever actions other programs need to do on flips
    15591    (MAPC #'EVAL GC-EVERY-FLIP-LIST)
     
    175111       (STATIC-SIZE 0)
    176112       (EXITED-SIZE 0)
    177        (FREE-SIZE 0)
     113       (FREE-SIZE (GET-FREE-SPACE-SIZE))
    178114       (OLD-SIZE 0))
    179115      ((MINUSP REGION)
    180        (DO REGION (AREA-REGION-LIST FREE-AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
    181          (SETQ FREE-SIZE (+ (24-BIT-UNSIGNED (REGION-LENGTH REGION)) FREE-SIZE)))
    182116       (RETURN DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE OLD-SIZE))
    183117    (SETQ SZ (24-BIT-UNSIGNED (REGION-FREE-POINTER REGION)))
    184118    (SELECT (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION))
    185       ((%REGION-SPACE-NEW %REGION-SPACE-COPY)
    186         (SETQ DYNAMIC-SIZE (+ SZ DYNAMIC-SIZE)))
     119      ((%REGION-SPACE-NEW %REGION-SPACE-COPY %REGION-SPACE-NEW1 %REGION-SPACE-NEW2
     120        %REGION-SPACE-NEW3 %REGION-SPACE-NEW4 %REGION-SPACE-NEW5 %REGION-SPACE-NEW6)
     121       (SETQ DYNAMIC-SIZE (+ SZ DYNAMIC-SIZE)))
    187122      (%REGION-SPACE-OLD
    188123        (SETQ OLD-SIZE (+ SZ OLD-SIZE)))
    189       ((%REGION-SPACE-STATIC %REGION-SPACE-FIXED %REGION-SPACE-EXIT)
    190         (SETQ STATIC-SIZE (+ SZ STATIC-SIZE)))
    191       (%REGION-SPACE-EXITED
    192         (SETQ EXITED-SIZE (+ SZ EXITED-SIZE))))))
     124      ((%REGION-SPACE-STATIC %REGION-SPACE-FIXED)
     125        (SETQ STATIC-SIZE (+ SZ STATIC-SIZE))))))
     126
     127;Returns the number of words of free space
     128(DEFUN GET-FREE-SPACE-SIZE ()
     129  (* (LOOP FOR I FROM (// (+ (REGION-ORIGIN INIT-LIST-AREA) (REGION-LENGTH INIT-LIST-AREA))
     130                          %ADDRESS-SPACE-QUANTUM-SIZE)
     131                 BELOW (// VIRTUAL-MEMORY-SIZE %ADDRESS-SPACE-QUANTUM-SIZE)
     132           COUNT (ZEROP (AREF #'ADDRESS-SPACE-MAP I)))
     133     %ADDRESS-SPACE-QUANTUM-SIZE))
    193134
    194135;;; If called when %GC-FLIP-READY is true, returns a conservative (over) estimate of
     
    281222(DEFUN GC-RECLAIM-OLDSPACE ()
    282223  ;; Make sure all regions are clean (no pointers to oldspace)
    283   (DO ((%SCAVENGER-WS-ENABLE NIL))  ;Use all of memory as long as using all of processor
     224  (DO ((%SCAVENGER-WS-ENABLE 0))  ;Use all of memory as long as using all of processor
    284225      (%GC-FLIP-READY)  ;Stop when scavenger says all is clean
    285226    (%GC-SCAVENGE 10000))
     
    290231              (OLD-USED-SIZE 0))
    291232             ((MINUSP REGION)
    292               (FORMAT (GC-REPORT-STREAM)
    293                       "~&[GC: Flushing oldspace.  allocated=~D., used=~D.]~%"
    294                       OLD-TOTAL-SIZE OLD-USED-SIZE))
     233              (GC-REPORT "GC: Flushing oldspace.  allocated=~D., used=~D."
     234                         OLD-TOTAL-SIZE OLD-USED-SIZE))
    295235           (COND ((= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) %REGION-SPACE-OLD)
    296236                  (SETQ OLD-TOTAL-SIZE (+ (24-BIT-UNSIGNED (REGION-LENGTH REGION))
     
    303243      (AND (OR (MINUSP AREA-NUMBER) (> AREA-NUMBER SIZE-OF-AREA-ARRAYS))
    304244           (FERROR NIL "Area-symbol ~S clobbered" AREA)) ;don't get grossly faked out
    305       (GC-RECLAIM-OLDSPACE-AREA AREA-NUMBER))))
     245      (GC-RECLAIM-OLDSPACE-AREA AREA-NUMBER)))
     246  (SETQ GC-DAEMON-PAGE-CONS-ALARM -1))  ;Wake up daemon process
    306247
    307248;;; GC-RECLAIM-OLDSPACE-AREA - deletes all old-space regions of a specified area,
     
    371312              (T                ;Wait a while before flipping, then compute frob again
    372313               (SETQ %PAGE-CONS-ALARM 0)
    373                (AND GC-REPORT-STREAM
    374                     (FORMAT (GC-REPORT-STREAM)
    375                             "~&[GC: Allowing ~D. words more consing before flip.]~%"
    376                             (- FREE-SPACE COMMITTED-FREE-SPACE)))
     314               (GC-REPORT "GC: Allowing ~D. words more consing before flip."
     315                          (- FREE-SPACE COMMITTED-FREE-SPACE))
    377316               (SETQ GC-PAGE-CONS-ALARM-MARK
    378317                     (// (- FREE-SPACE COMMITTED-FREE-SPACE) PAGE-SIZE))
     
    385324(DEFUN GC-ON ()
    386325  (OR (BOUNDP 'GC-PROCESS)
    387       (SETQ GC-PROCESS (PROCESS-CREATE "Garbage Collector")))
     326      (SETQ GC-PROCESS (MAKE-PROCESS "Garbage Collector")))
    388327  (PROCESS-PRESET GC-PROCESS #'GC-PROCESS)
    389328  (PROCESS-ENABLE GC-PROCESS)                   ;Start flipper process
     
    420359                   (GC-FLIP-NOW))
    421360                (T              ;Wait a while before flipping, then compute frob again
    422                  (AND GC-REPORT-STREAM
    423                       (FORMAT (GC-REPORT-STREAM)
    424                               "~&[GC: Allowing ~D. words more consing before flip.]~%"
    425                               (- FREE-SPACE COMMITTED-FREE-SPACE)))
     361                 (GC-REPORT "GC: Allowing ~D. words more consing before flip."
     362                            (- FREE-SPACE COMMITTED-FREE-SPACE))
    426363                 (SETQ %PAGE-CONS-ALARM 0
    427364                       GC-PAGE-CONS-ALARM-MARK (// (- FREE-SPACE COMMITTED-FREE-SPACE)
     
    444381      (LET ((BITS (REGION-BITS REGION)))
    445382        (SELECT (LDB %%REGION-SPACE-TYPE BITS)
    446           ((%REGION-SPACE-NEW %REGION-SPACE-COPY)
    447              (STORE (REGION-BITS REGION)
    448                     (%LOGDPB 1 %%REGION-SCAVENGE-ENABLE
    449                              (%LOGDPB %REGION-SPACE-STATIC %%REGION-SPACE-TYPE BITS)))))))))
     383          ((%REGION-SPACE-NEW %REGION-SPACE-COPY %REGION-SPACE-NEW1 %REGION-SPACE-NEW2
     384            %REGION-SPACE-NEW3 %REGION-SPACE-NEW4 %REGION-SPACE-NEW5 %REGION-SPACE-NEW6)
     385           (STORE (REGION-BITS REGION)
     386                  (%LOGDPB 1 %%REGION-SCAVENGE-ENABLE
     387                           (%LOGDPB %REGION-SPACE-STATIC %%REGION-SPACE-TYPE BITS)))))))))
    450388
    451389;;; Make a static area dynamic.  This can happen right away, although it really
     
    481419  (MAKE-AREA-DYNAMIC AREA))
    482420
     421;Find boundary in physical core for scavenger working set.  Scan up until right number
     422; of non-wired pages passed.
     423(DEFUN SET-SCAVENGER-WS (WS-SIZE)
     424  (DO ((PHYS-ADR 0 (+ PHYS-ADR PAGE-SIZE))
     425       (PAGES-FOUND 0))
     426      ((>= PAGES-FOUND WS-SIZE)
     427       (SETQ GC-SCAVENGER-WS-SIZE WS-SIZE
     428             %SCAVENGER-WS-ENABLE PHYS-ADR))
     429    (LET ((PPD-ADR (+ (REGION-ORIGIN PHYSICAL-PAGE-DATA)
     430                      (// PHYS-ADR PAGE-SIZE))))
     431      (IF (NOT (AND (= (%P-LDB 0020 PPD-ADR) 177777)            ;flush if fixed wired
     432                    ( (%P-LDB 2020 PPD-ADR) 177777)))
     433          (LET ((PHT-ADR (+ (%P-LDB 0020 PPD-ADR) (REGION-ORIGIN PAGE-TABLE-AREA))))
     434            (IF (NOT
     435                  (AND (NOT (ZEROP (%P-LDB %%PHT1-VALID-BIT PHT-ADR)))
     436                       (= (%P-LDB %%PHT1-SWAP-STATUS-CODE PHT-ADR) %PHT-SWAP-STATUS-WIRED)))
     437                (SETQ PAGES-FOUND (1+ PAGES-FOUND))))))))
     438
     439(DEFUN SET-SWAP-RECOMMENDATIONS-OF-AREA (AREA SWAP-RECOMMENDATIONS)
     440  (CHECK-ARG AREA (AND (NUMBERP AREA) (
     441 AREA 0) (
     442 AREA SIZE-OF-AREA-ARRAYS))
     443             "an area number")
     444  (WITHOUT-INTERRUPTS
     445    (STORE (AREA-SWAP-RECOMMENDATIONS AREA) SWAP-RECOMMENDATIONS)
     446    (DO REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
     447      (STORE (REGION-BITS REGION)
     448             (%LOGDPB SWAP-RECOMMENDATIONS %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION))))))
     449
     450(DEFUN CHECK-SWAP-RECOMMENDATIONS-OF-AREA (AREA)
     451  (LET ((SWAP-RECOMMENDATIONS (AREA-SWAP-RECOMMENDATIONS AREA)))
     452    (DO REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
     453        (IF (NOT (= (%LOGLDB %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION))
     454                    SWAP-RECOMMENDATIONS))
     455            (FORMAT T "~%Swap recomendations of region ~S are ~s but should be ~s."
     456                    REGION
     457                    (%LOGLDB %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION))
     458                    SWAP-RECOMMENDATIONS)))))
     459
     460(DEFUN SET-ALL-SWAP-RECOMMENDATIONS (N)
     461  (DOLIST (NAME-OF-AREA AREA-LIST)
     462    (SET-SWAP-RECOMMENDATIONS-OF-AREA (SYMEVAL NAME-OF-AREA) N)))
     463
     464
     465
     466;;; GC-Daemon facility.
     467
     468;;; A GC-daemon is a set of address-space conditions to wait for, and a
     469;;; function to run (in a separate process) when conditions are met.
     470
     471;;; This simple process implements the queue
     472(DEFVAR GC-DAEMON-PROCESS)
     473
     474;;; Each element on this queue is a list at least four long:
     475;;;     (name function region-cons-alarm page-cons-alarm)
     476;;; If either alarm is
     477 the value in the queue, the function is called
     478;;; in a background process with the queue element as its argument.
     479;;; If any oldspace is reclaimed, all entries on the queue go off, since the
     480;;; allocation of address space has just changed.  This may need improvement
     481;;; in the future, when oldspace reclamation is more frequent.
     482(DEFVAR GC-DAEMON-QUEUE NIL)
     483
     484(DEFVAR GC-DAEMON-PAGE-CONS-ALARM 0)
     485(DEFVAR GC-DAEMON-REGION-CONS-ALARM 0)
     486
     487;;; Add to the queue.  Arguments are how many more regions and pages
     488;;; must be consed before the function goes off.  If you want your
     489;;; queue element to be more than four long, pre-create it and pass it in
     490(DEFUN GC-DAEMON-QUEUE (NAME FUNCTION N-REGIONS N-PAGES &OPTIONAL ELEM)
     491  (OR ELEM (SETQ ELEM (ASSQ NAME GC-DAEMON-QUEUE)) (SETQ ELEM (LIST NAME FUNCTION NIL NIL)))
     492  (WITHOUT-INTERRUPTS
     493    (SETF (THIRD ELEM) (+ %REGION-CONS-ALARM N-REGIONS))
     494    (SETF (FOURTH ELEM) (+ %PAGE-CONS-ALARM N-PAGES))
     495    (OR (MEMQ ELEM GC-DAEMON-QUEUE)
     496        (PUSH ELEM GC-DAEMON-QUEUE))
     497    (SETQ GC-DAEMON-PAGE-CONS-ALARM -1)))       ;Wake up daemon process
     498
     499;;; This is the function that runs in the scheduler
     500(DEFUN GC-DAEMON-FUNCTION ()
     501  ;; Fire off any interesting queue entries
     502  (LOOP FOR ELEM IN GC-DAEMON-QUEUE
     503        WHEN (OR (
     504 %REGION-CONS-ALARM (THIRD ELEM))
     505                 (
     506 %PAGE-CONS-ALARM (FOURTH ELEM)))
     507          DO (SETQ GC-DAEMON-QUEUE (DELQ ELEM GC-DAEMON-QUEUE))
     508             (PROCESS-RUN-FUNCTION (STRING (FIRST ELEM)) (SECOND ELEM) ELEM)) 
     509  ;; Cause process to sleep until next interesting time
     510  (IF GC-DAEMON-QUEUE
     511      (SETQ GC-DAEMON-REGION-CONS-ALARM (LOOP FOR ELEM IN GC-DAEMON-QUEUE
     512                                              MINIMIZE (THIRD ELEM))
     513            GC-DAEMON-PAGE-CONS-ALARM (LOOP FOR ELEM IN GC-DAEMON-QUEUE
     514                                            MINIMIZE (FOURTH ELEM)))
     515      (SETQ GC-DAEMON-REGION-CONS-ALARM 37777777
     516            GC-DAEMON-PAGE-CONS-ALARM 37777777))     
     517  (SET-PROCESS-WAIT CURRENT-PROCESS
     518                    #'(LAMBDA ()
     519                        (OR (
     520 %REGION-CONS-ALARM GC-DAEMON-REGION-CONS-ALARM)
     521                            (
     522 %PAGE-CONS-ALARM GC-DAEMON-PAGE-CONS-ALARM)))
     523                    NIL)
     524  (SETF (PROCESS-WHOSTATE CURRENT-PROCESS) "GC Daemon"))
     525
     526(DEFUN START-GC-DAEMON ()
     527  (OR (BOUNDP 'GC-DAEMON-PROCESS)
     528      (SETQ GC-DAEMON-PROCESS (MAKE-PROCESS "GC Daemon"
     529                                ':SIMPLE-P T
     530                                ':WARM-BOOT-ACTION 'GC-DAEMON-RESTART)))
     531  (FUNCALL GC-DAEMON-PROCESS ':PRESET 'GC-DAEMON-FUNCTION)
     532  (FUNCALL GC-DAEMON-PROCESS ':RUN-REASON 'START-GC-DAEMON))
     533
     534(DEFUN GC-DAEMON-RESTART (P)
     535  ;; %REGION-CONS-ALARM and %PAGE-CONS-ALARM have changed unpredictably
     536  ;; so schedule all gc-daemons to go off almost immediately
     537  (DOLIST (ELEM GC-DAEMON-QUEUE)
     538    (GC-DAEMON-QUEUE (FIRST ELEM) (SECOND ELEM) 1 1 ELEM))
     539  (PROCESS-WARM-BOOT-DELAYED-RESTART P))
     540
     541(START-GC-DAEMON)
     542
     543
     544;;; GC-daemon which watches for exhaustion of address space
     545
     546;;; Controlling parameters:
     547;;; Amount of free space at which to start complaining, fraction by which to go down
     548(DEFCONST ADDRESS-SPACE-WARNING-LOW-WORDS 1000000.)
     549(DEFCONST ADDRESS-SPACE-WARNING-LOW-REGIONS 50.)
     550(DEFCONST ADDRESS-SPACE-WARNING-WORDS-RATIO 0.75)
     551(DEFCONST ADDRESS-SPACE-WARNING-REGIONS-RATIO 0.75)
     552;; These two are where it last notified the user
     553(DEFVAR ADDRESS-SPACE-WARNING-WORDS NIL)
     554(DEFVAR ADDRESS-SPACE-WARNING-REGIONS NIL)
     555
     556(DEFUN ADDRESS-SPACE-WARNING (ELEM &AUX (COMPLAIN NIL))
     557  ;; Is it time to complain?
     558  (LET ((FREE-WORDS (GET-FREE-SPACE-SIZE))
     559        (FREE-REGIONS
     560          (LOOP FOR REGION = (SYSTEM-COMMUNICATION-AREA %SYS-COM-FREE-REGION#-LIST)
     561                           THEN (REGION-LIST-THREAD REGION)
     562                UNTIL (MINUSP REGION)
     563                COUNT T)))
     564    (COND ((AND (
     565 FREE-WORDS ADDRESS-SPACE-WARNING-LOW-WORDS)
     566                (
     567 FREE-REGIONS ADDRESS-SPACE-WARNING-LOW-REGIONS))
     568           ;; No need to complain at all, reset everything
     569           (SETQ ADDRESS-SPACE-WARNING-WORDS ADDRESS-SPACE-WARNING-LOW-WORDS)
     570           (SETQ ADDRESS-SPACE-WARNING-REGIONS ADDRESS-SPACE-WARNING-LOW-REGIONS))
     571          ((OR (< FREE-WORDS
     572                  (* ADDRESS-SPACE-WARNING-LOW-WORDS ADDRESS-SPACE-WARNING-WORDS-RATIO))
     573               (< FREE-REGIONS
     574                  (* ADDRESS-SPACE-WARNING-LOW-REGIONS ADDRESS-SPACE-WARNING-REGIONS-RATIO)))
     575           ;; Time to complain again, space significantly lower than last time
     576           (SETQ COMPLAIN '<
     577                 ADDRESS-SPACE-WARNING-WORDS FREE-WORDS
     578                 ADDRESS-SPACE-WARNING-REGIONS FREE-REGIONS))
     579          ((AND (> FREE-REGIONS
     580                   (// ADDRESS-SPACE-WARNING-LOW-REGIONS ADDRESS-SPACE-WARNING-REGIONS-RATIO))
     581                (> FREE-WORDS
     582                   (// ADDRESS-SPACE-WARNING-LOW-WORDS ADDRESS-SPACE-WARNING-WORDS-RATIO)))
     583           ;; Significantly more space than there was before, let user know
     584           (SETQ COMPLAIN '>
     585                 ADDRESS-SPACE-WARNING-WORDS FREE-WORDS
     586                 ADDRESS-SPACE-WARNING-REGIONS FREE-REGIONS)))
     587    ;; Re-queue self
     588    (GC-DAEMON-QUEUE 'ADDRESS-SPACE-WARNING 'ADDRESS-SPACE-WARNING
     589                     (FIX (* FREE-REGIONS (- 1 ADDRESS-SPACE-WARNING-REGIONS-RATIO)))
     590                     (FIX (* (// FREE-WORDS PAGE-SIZE)
     591                             (- 1 ADDRESS-SPACE-WARNING-WORDS-RATIO)))
     592                     ELEM)
     593    ;; If suppose to complain, do so
     594    (AND COMPLAIN
     595         (TV:NOTIFY NIL "~:[Address space low!  ~]You have ~D regions and ~
     596                                      ~DK words of address space left"
     597                    (EQ COMPLAIN '>) FREE-REGIONS (// FREE-WORDS 1024.)))))
     598
     599;; Start
     600(GC-DAEMON-QUEUE 'ADDRESS-SPACE-WARNING 'ADDRESS-SPACE-WARNING 0 0)
     601
    483602
    484603;;; Peek display
  • trunk/lisp/lispm2/global.lisp

    r251 r278  
    5757 %FIND-STRUCTURE-LEADER
    5858 %FLOAT-DOUBLE
    59  %HALT
    6059 %LOGDPB
    6160 %LOGLDB
     
    109108;;; Lambda-list keywords:
    110109
     110 &ALLOW-OTHER-KEYS
    111111 &AUX
     112 &BODY
    112113 &DT-ATOM
    113114 &DT-DONTCARE
     
    120121 &FUNCTION-CELL
    121122 &FUNCTIONAL
    122  &LIST
     123 &KEY
    123124 &LIST-OF
    124125 &LOCAL
     
    143144 ***
    144145 *ALL-FLAVOR-NAMES*
     146 *ALL-FLAVOR-NAMES-AARRAY*
    145147 *ARRAY
    146148 *CATCH
     
    183185 ADD-INITIALIZATION
    184186 ADJUST-ARRAY-SIZE
     187 ADVISE
     188 ADVISE-WITHIN
    185189 ALL-SPECIAL-SWITCH
    186190 ALLOCATE-RESOURCE
     
    195199 AP-LEADER
    196200 APPEND
     201 APPEND-TO-ARRAY
    197202 APPLY
    198203 APROPOS
     
    242247 ART-8B
    243248 ART-ERROR
     249 ART-FAT-STRING
    244250 ART-FLOAT
     251 ART-FPS-FLOAT
     252 ART-HALF-FIX
    245253 ART-Q
    246254 ART-Q-LIST
     
    276284 BOUNDP
    277285 BREAK
     286 BREAKON
    278287 BUG
    279288 BUTLAST
     
    295304 CAR
    296305 CAR-LOCATION
     306 CASEQ
    297307 CATCH
    298308 CATCH-ALL
     309 CATCH-ERROR
    299310 CDAAAR
    300311 CDAADR
     
    323334 CHAR-UPCASE
    324335 CHECK-ARG
     336 CHECK-ARG-TYPE
    325337 CHOOSE-USER-OPTIONS
    326338 CIRCULAR-LIST
     
    331343 CLASS-SYMBOLP
    332344 CLEAR-MAR
     345 CLEAR-RESOURCE
    333346 CLOSE
    334347 CLOSURE
     348 CLOSURE-ALIST
     349 CLOSURE-FUNCTION
    335350 CLOSUREP
    336351 CLRHASH
     352 CLRHASH-EQUAL
    337353 COMMENT
    338354 COMPILE
    339355 COMPILE-FILE-ALIST
    340  COMPILE-FILE-ALIST-MAP
    341356 COMPILE-FLAVOR-METHODS
    342357 COMPILER-LET
     
    352367 COPY-ARRAY-CONTENTS-AND-LEADER
    353368 COPY-ARRAY-PORTION
     369 COPY-READTABLE
    354370 COPYALIST
    355371 COPYLIST
    356372 COPYLIST*
    357373 COPYSYMBOL
     374 COPYTREE
    358375 COS
    359376 COSD
     
    362379 DATA-TYPE
    363380 DEALLOCATE-RESOURCE
     381 DEBUGGING-INFO
     382 DECF
    364383 DECLARE
    365384 DECLARE-FLAVOR-INSTANCE-VARIABLES
     
    371390 DEFF
    372391 DEFFLAVOR
     392 DEFFUNCTION
    373393 DEFINE-LOOP-MACRO
     394 DEFINE-LOOP-PATH
     395 DEFINE-LOOP-SEQUENCE-PATH
     396 DEFINE-SITE-ALIST-USER-OPTION
     397 DEFINE-SITE-HOST-LIST
     398 DEFINE-SITE-USER-OPTION
     399 DEFINE-SITE-VARIABLE
    374400 DEFINE-USER-OPTION
    375401 DEFINE-USER-OPTION-ALIST
     402 DEFLAMBDA-MACRO
     403 DEFLAMBDA-MACRO-DISPLACE
    376404 DEFMACRO
    377405 DEFMACRO-DISPLACE
     
    381409 DEFRESOURCE
    382410 DEFSELECT
     411 DEFSTRUCT-DEFINE-TYPE
    383412 DEFSTRUCT
    384413 DEFSTRUCTCLASS
    385414 DEFSUBST
     415 DEFSYSTEM
    386416 DEFUN
    387  DEFUN-COMPATIBILITY
    388417 DEFUNP
    389418 DEFVAR
     419 DEFWINDOW-RESOURCE
    390420 DEFWRAPPER
    391421 DEL-IF
     
    396426 DELETEF
    397427 DELQ
     428 DEPOSIT-BYTE
    398429 DEPOSIT-FIELD
    399430 DESCRIBE
    400431 DESCRIBE-AREA
    401  DESCRIBE-FILE
     432 DESCRIBE-DEFSTRUCT
     433 DESCRIBE-FLAVOR
    402434 DESCRIBE-PACKAGE
    403435 DESTRUCTURING-BIND
     
    411443 DO
    412444 DO-NAMED
     445 DOCUMENTATION
    413446 DOLIST
    414447 DOTIMES
     
    455488 ERROR-OUTPUT
    456489 ERROR-RESTART
     490 ERRORP
    457491 ERRSET
    458492 EVAL
     
    477511 FED
    478512 FERROR
    479  FETCH
    480  FETCHF
    481  FETCHR
    482513 FEXPR
    483514 FIFTH
    484  FILE-ERROR-STATUS
    485  FILE-EXISTS-P
    486  FILE-EXPAND-PATHNAME
    487  FILE-QFASL-P
     515 FILL-POINTER
    488516 FILLARRAY
    489517 FIND-POSITION-IN-LIST
     
    495523 FIXNUM
    496524 FIXNUM-CLASS
     525 FIXNUMP
    497526 FIXP
    498527 FLATC
     
    502531 FLOATP
    503532 FLONUM
     533 FLONUMP
    504534 FLONUM-CLASS
    505535 FMAKUNBOUND
     536 FOLLOW-CELL-FORWARDING
    506537 FOLLOW-STRUCTURE-FORWARDING
    507538 FONT
     
    531562 FUNCALL-SELF
    532563 FUNCTION
     564 FUNCTION-CELL-LOCATION
    533565 FUNCTION-DOCUMENTATION
    534566 FUNCTIONAL-ALIST
    535  FUNCTION-CELL-LOCATION
     567 FUNCTIONP
     568 FQUERY
    536569 G-L-P
    537570 GC-ON
     
    550583 GETCHARN
    551584 GETHASH
     585 GETHASH-EQUAL
    552586 GETL
    553587 GLOBALIZE
     
    566600 IF-IN-LISPM
    567601 IF-IN-MACLISP
     602 IGNORE
    568603 IMPLODE
     604 INCF
    569605 INCLUDE
    570606 INHIBIT-FDEFINE-WARNINGS
     
    581617 INTERN-LOCAL-SOFT
    582618 INTERN-SOFT
     619 INTERSECTION
    583620 ISQRT
    584  ITER
    585  ITER-FETCHR
    586  ITER-LIST
    587621 KBD-CHAR-AVAILABLE
    588622 KBD-TYI
     
    591625 LAMBDA
    592626 LAMBDA-LIST-KEYWORDS
     627 LAMBDA-MACRO
    593628 LAST
    594629 LDB
     
    600635 LET-CLOSED
    601636 LET-GLOBALLY
     637 LET-IF
    602638 LET*
     639 LEXICAL-CLOSURE
    603640 LEXPR-FUNCALL
    604641 LEXPR-FUNCALL-SELF
     
    611648 LIST-SUM
    612649 LIST*
     650 LIST*-IN-AREA
    613651 LISTARRAY
    614652 LISTIFY
    615653 LISTP
    616654 LOAD
     655 LOAD-BYTE
    617656 LOAD-FILE-ALIST
    618  LOAD-FILE-ALIST-MAP
    619657 LOAD-FILE-LIST
     658 LOAD-PATCHES
    620659 LOCAL-DECLARE
    621660 LOCAL-DECLARATIONS
     
    632671 LOGIN-SETQ
    633672 LOGIOR
     673 LOGNOT
    634674 LOGOUT
    635675 LOGOUT-LIST
     
    647687 MAKE-ARRAY-INTO-NAMED-STRUCTURE
    648688 MAKE-BROADCAST-STREAM
     689 MAKE-EQUAL-HASH-TABLE
    649690 MAKE-HASH-TABLE
     691 MAKE-INSTANCE
    650692 MAKE-LIST
    651693 MAKE-PLANE
     694 MAKE-PROCESS
    652695 MAKE-STACK-GROUP
    653696 MAKE-SYMBOL
    654697 MAKE-SYN-STREAM
     698 MAKE-SYSTEM
    655699 MAKNAM
    656700 MAKUNBOUND
     
    664708 MAPCON
    665709 MAPHASH
     710 MAPHASH-EQUAL
    666711 MAPLIST
    667712 MAR-BREAK
     
    687732 NAMED-STRUCTURE-P
    688733 NAMED-STRUCTURE-SYMBOL
     734 NAMED-SUBST
    689735 NBUTLAST
    690736 NCONC
     
    707753 NULL-MACRO
    708754 NUMBER-GC-ON
     755 NUMBER-INTO-ARRAY
    709756 NUMBERP
    710757 NUMBER-CLASS
     
    712759 OBSOLETE-FUNCTION-WARNING-SWITCH
    713760 ODDP
     761 ONCE-ONLY
    714762 OPEN
    715763 OPEN-CODE
     
    722770 PAIR
    723771 PAIRLIS
    724  PARALLELISM-CLASS
     772 PARSE-NUMBER
    725773 PEEK
    726774 PERMANENT-STORAGE-AREA
     
    741789 PKG-SYSTEM-PACKAGE
    742790 PLANE-AR-N
     791 PLANE-AREF
    743792 PLANE-AS-N
     793 PLANE-ASET
    744794 PLANE-DEFAULT
    745795 PLANE-EXTENSION
     
    760810 PRINT-ERROR-MODE
    761811 PRINT-LOADED-BAND
    762  PRINT-MODIFICATION-RECORD
     812 PRINT-NOTIFICATIONS
    763813 PRINT-SENDS
     814 PRINT-SYSTEM-MODIFICATIONS
    764815 PROBEF
    765816 PROCESS-ALLOW-SCHEDULE
     
    777828 PROCESS-RESET
    778829 PROCESS-RUN-FUNCTION
     830 PROCESS-RESET-AND-ENABLE
     831 PROCESS-RUN-RESTARTABLE-FUNCTION
     832 PROCESS-RUN-TEMPORARY-FUNCTION
    779833 PROCESS-SLEEP
    780834 PROCESS-STACK-GROUP
     
    783837 PROCESS-WAIT-ARGUMENT-LIST
    784838 PROCESS-WAIT-FUNCTION
     839 PROCESS-WAIT-WITH-TIMEOUT
    785840 PROCESS-WHOSTATE
    786841 PROG
     
    790845 PROGN
    791846 PROGV
     847 PROGW
    792848 PROPERTY-CELL-LOCATION
    793849 PSETQ
     
    795851 PUT-ON-ALTERNATING-LIST
    796852 PUTHASH
     853 PUTHASH-EQUAL
    797854 PUTPROP
    798855 Q-DATA-TYPES
    799856 QC-FILE
    800857 QC-FILE-LOAD
    801  QLD
    802858 QUERY-IO
    803859 QUOTE
     
    805861 QSEND
    806862 RANDOM
     863 RASS
    807864 RASSOC
     865 RASSQ
    808866 READ
     867 READ-FOR-TOP-LEVEL
    809868 READ-FROM-STRING
    810869 READ-METER
     
    816875 READTABLE
    817876 RECOMPILE-FLAVOR
    818  RECOMPILE-WORLD
    819877 REM-IF
    820878 REM-IF-NOT
    821879 REM
    822880 REMAINDER
     881 REMHASH
     882 REMHASH-EQUAL
    823883 REMMETHOD
    824884 REMOB
     
    856916 SELECTQ-EVERY
    857917 SELF
    858  SEND
    859918 SET
    860919 SET-CHARACTER-TRANSLATION
     
    876935 SETSYNTAX
    877936 SETSYNTAX-SHARP-MACRO
    878  SETUP-KEYBOARD-DISPATCH-TABLE
    879937 SEVENTH
    880938 SG-AREA
     
    892950 SORT-GROUPED-ARRAY
    893951 SORT-GROUPED-ARRAY-GROUP-KEY
    894  SORT-SHORT-LIST
    895952 SORTCAR
    896  SORTCAR-SHORT-LIST
    897953 SOURCE-FILE-NAME     ;Trying to put this in keywords causes infinite problems
    898954                      ; in FROID.
     
    900956 SQRT
    901957 SSTATUS
     958 STABLE-SORT
     959 STABLE-SORTCAR
    902960 STACK-GROUP-PRESET
     961 STACK-GROUP-RESUME
    903962 STACK-GROUP-RETURN
    904963 STANDARD-INPUT
     
    906965 STATUS
    907966 STEP
     967 STEP-FORM
     968 STEP-VALUE
     969 STEP-VALUES
    908970 STORE
    909971 STORE-ARRAY-LEADER
     
    912974 STRING
    913975 STRING-APPEND
     976 STRING-COMPARE
    914977 STRING-DOWNCASE
    915978 STRING-EQUAL
     
    919982 STRING-NCONC
    920983 STRING-NREVERSE
     984 STRING-PLURALIZE
    921985 STRING-REVERSE
    922986 STRING-REVERSE-SEARCH
     
    9491013 SWAP-SV-OF-SG-THAT-CALLS-ME
    9501014 SWAP-SV-ON-CALL-OUT
     1015 SWAPF
     1016 SWAPHASH
     1017 SWAPHASH-EQUAL
    9511018 SXHASH
    9521019 SYMBOL
    9531020 SYMBOLP
    9541021 SYMBOL-CLASS
     1022 SYMBOL-PACKAGE
    9551023 SYMEVAL
    9561024 SYMEVAL-IN-CLOSURE
     
    9791047 TYO
    9801048 TYPEP
     1049 UNADVISE
     1050 UNADVISE-WITHIN
    9811051 UNBIND
     1052 UNBOUND-FUNCTION  ;for WHO-CALLS
     1053 UNBREAKON
    9821054 UNCOMPILE
     1055 UNDEFMETHOD
    9831056 UNDEFUN
     1057 UNDELETF
    9841058 UNION
     1059 UNMONITOR-VARIABLE
    9851060 UNSPECIAL
    9861061 UNTRACE
     
    9891064 UNWIND-PROTECT-VALUE
    9901065 USER-ID
     1066 USING-RESOURCE
    9911067 VALUE-CELL-LOCATION
     1068 VALUES
     1069 VALUES-LIST
    9921070 WHERE-IS
     1071 WHAT-FILES-CALL
    9931072 WHO-CALLS
    9941073 WHO-USES
     
    9961075 WITH-INPUT-FROM-STRING
    9971076 WITH-OPEN-FILE
     1077 WITH-OPEN-STREAM
    9981078 WITH-OUTPUT-TO-STRING
    999  WITH-RESOURCE
     1079 WITH-RESOURCE          ;Delete this in June 1981
    10001080 WORKING-STORAGE-AREA
    10011081 WRITE-METER
     
    10091089 ZEROP
    10101090 ZDT
     1091 ZMAIL
    10111092 ZUNDERFLOW
    10121093
  • trunk/lisp/lispm2/hash.lisp

    r246 r278  
    5050        (OTHERWISE (FERROR NIL "~S not a recognized option" (CAR L)))))
    5151  (SETQ SIZE (HASH-TABLE-GOOD-SIZE (* SIZE 2)))
    52   (SETQ HT (MAKE-HASH-TABLE-INTERNAL :MAKE-ARRAY (AREA 'ART-Q SIZE)
     52  (SETQ HT (MAKE-HASH-TABLE-INTERNAL :MAKE-ARRAY (:LENGTH SIZE :AREA AREA)
    5353                                     HASH-TABLE-MODULUS (// SIZE 16.)
    5454                                     HASH-TABLE-REHASH-FUNCTION RHF
     
    142142           (RETURN VALUE))
    143143          ((= (%P-DATA-TYPE P) DTP-NULL)        ;Remember empty slot
    144            (SETQ EMPTYP P)))))
     144           (OR EMPTYP (SETQ EMPTYP P))))))
     145
     146;Like PUTHASH, but returns old contents
     147(DEFUN SWAPHASH (KEY VALUE HASH-TABLE)
     148  (SETQ HASH-TABLE (GET-REAL-HASH-TABLE HASH-TABLE))
     149  (DO ((P (HASH-BLOCK-POINTER HASH-TABLE KEY) (%MAKE-POINTER-OFFSET DTP-LOCATIVE P 1))
     150       (N 8 (1- N))
     151       (EMPTYP NIL))
     152      ((ZEROP N)                                ;Not found
     153       (COND (( (HASH-TABLE-GC-GENERATION-NUMBER HASH-TABLE) %GC-GENERATION-NUMBER)
     154              ;; Some %POINTER's may have changed, try rehashing
     155              (FUNCALL (HASH-TABLE-REHASH-FUNCTION HASH-TABLE) HASH-TABLE NIL)
     156              (PUTHASH KEY VALUE HASH-TABLE))
     157             (EMPTYP                            ;Add to table using empty slot found
     158              (%P-STORE-CONTENTS EMPTYP KEY)
     159              (%P-STORE-CONTENTS-OFFSET VALUE EMPTYP 8)
     160              (SETF (HASH-TABLE-FULLNESS HASH-TABLE) (1+ (HASH-TABLE-FULLNESS HASH-TABLE))))
     161             (T                                 ;Need to make more room, then try again
     162              (FUNCALL (HASH-TABLE-REHASH-FUNCTION HASH-TABLE)
     163                       HASH-TABLE (HASH-TABLE-REHASH-SIZE HASH-TABLE))
     164              (PUTHASH KEY VALUE HASH-TABLE)))
     165       (VALUES NIL NIL))
     166    (COND ((%P-CONTENTS-EQ P KEY)               ;Found existing entry
     167           (RETURN (PROG1 (%P-CONTENTS-OFFSET P 8)
     168                          (%P-STORE-CONTENTS-OFFSET VALUE P 8))
     169                   T))
     170          ((= (%P-DATA-TYPE P) DTP-NULL)        ;Remember empty slot
     171           (OR EMPTYP (SETQ EMPTYP P))))))
    145172
    146173;Returns T if was really in table, NIL if not found
     
    187214                                  (+ (ARRAY-LENGTH HASH-TABLE) GROW GROW)))
    188215                       (ARRAY-LENGTH HASH-TABLE)))
    189          (TEMP-ARRAY (MAKE-ARRAY NIL 'ART-Q NEW-SIZE))
     216         (TEMP-ARRAY (MAKE-ARRAY NEW-SIZE))
    190217         (NEW-HASH-TABLE)
    191218         (J 0))
     
    207234           (SETQ NEW-HASH-TABLE
    208235                 (MAKE-HASH-TABLE-INTERNAL
    209                             :MAKE-ARRAY ((%AREA-NUMBER HASH-TABLE) 'ART-Q NEW-SIZE)
     236                            :MAKE-ARRAY (:LENGTH NEW-SIZE :AREA (%AREA-NUMBER HASH-TABLE))
    210237                            HASH-TABLE-MODULUS (// NEW-SIZE 16.)
    211238                            HASH-TABLE-REHASH-FUNCTION (HASH-TABLE-REHASH-FUNCTION HASH-TABLE)
     
    220247
    221248;Named-structure handler
    222 (DEFUN HASH-TABLE (MESSAGE SELF &REST IGNORE)
     249(DEFUN (HASH-TABLE NAMED-STRUCTURE-INVOKE) (MESSAGE SELF &REST IGNORE)
    223250  (SELECTQ MESSAGE
    224251    (:WHICH-OPERATIONS '(:DESCRIBE))
     
    232259                         (HASH-TABLE-REHASH-FUNCTION SELF) (HASH-TABLE-REHASH-SIZE SELF))
    233260               (COND ((Y-OR-N-P "Do you want to see the block fullness distribution?")
    234                       (DO ((RES (MAKE-ARRAY NIL 'ART-32B 9))
     261                      (DO ((RES (MAKE-ARRAY 9 ':TYPE 'ART-32B))
    235262                           (I (HASH-TABLE-MODULUS SELF))
    236263                           (TOT (HASH-TABLE-MODULUS SELF))
     
    260287                            (SETQ *L* (SORTCAR *L* #'ALPHALESSP))
    261288                            (FORMAT T "~&~:{ ~S -> ~S~%~}" *L*))))))))
     289
     290
     291;;; EQUAL hash tables
     292;;; The functions here have similar names to the EQ hashing ones.
     293
     294(DEFSTRUCT (EQUAL-HASH-TABLE :NAMED :ARRAY-LEADER
     295                             (:CONSTRUCTOR MAKE-EQUAL-HASH-TABLE-INTERNAL))
     296  EQUAL-HASH-TABLE-SIZE
     297  (EQUAL-HASH-TABLE-FULLNESS 0)
     298  EQUAL-HASH-TABLE-THRESHOLD
     299  EQUAL-HASH-TABLE-GROWTH-FACTOR)
     300
     301;;; 3-D manual defstruct
     302(DEFMACRO EQUAL-HASH-TABLE-HASH (HASH-TABLE IDX)
     303  `(AREF ,HASH-TABLE ,IDX 0))
     304
     305(DEFMACRO EQUAL-HASH-TABLE-KEY (HASH-TABLE IDX)
     306  `(AREF ,HASH-TABLE ,IDX 1))
     307
     308(DEFMACRO EQUAL-HASH-TABLE-VALUE (HASH-TABLE IDX)
     309  `(AREF ,HASH-TABLE ,IDX 2))
     310
     311(DEFUN MAKE-EQUAL-HASH-TABLE (&REST OPTIONS &AUX (SIZE 100) AREA (THRESH 0.8s0) (GROW 1.3s0))
     312  (TV:DOPLIST (OPTIONS VAL KEY)
     313    (SELECTQ KEY
     314      (:SIZE (SETQ SIZE VAL))
     315      (:AREA (SETQ AREA VAL))
     316      (:REHASH-THRESHOLD (SETQ THRESH VAL))
     317      (:GROWTH-FACTOR (SETQ GROW VAL))
     318      (OTHERWISE (FERROR NIL "~S not a recognized option" KEY))))
     319  (DOLIST (GOOD-SIZE PKG-GOOD-SIZES)
     320    (COND ((
     321 GOOD-SIZE SIZE)
     322           (SETQ SIZE GOOD-SIZE)
     323           (RETURN))))
     324  (MAKE-EQUAL-HASH-TABLE-INTERNAL :MAKE-ARRAY (:LENGTH (LIST SIZE 3) :AREA AREA)
     325                                  EQUAL-HASH-TABLE-SIZE SIZE
     326                                  EQUAL-HASH-TABLE-THRESHOLD THRESH
     327                                  EQUAL-HASH-TABLE-GROWTH-FACTOR GROW))
     328
     329(DEFUN CLRHASH-EQUAL (HASH-TABLE)
     330  (MATH:FILL-2D-ARRAY HASH-TABLE '((NIL)))
     331  (SETF (EQUAL-HASH-TABLE-FULLNESS HASH-TABLE) 0)
     332  HASH-TABLE)
     333
     334(DEFUN GETHASH-EQUAL (KEY HASH-TABLE &AUX HASH SIZE)
     335  (SETQ HASH (ABS (SXHASH KEY))
     336        SIZE (EQUAL-HASH-TABLE-SIZE HASH-TABLE))
     337  (DO ((IDX (\ HASH SIZE) (\ (1+ IDX) SIZE))
     338       (TEM))
     339      (NIL)
     340    (OR (SETQ TEM (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX))
     341        (RETURN NIL NIL))                       ;Not found
     342    (AND (= TEM HASH) (EQUAL KEY (EQUAL-HASH-TABLE-KEY HASH-TABLE IDX))
     343         (RETURN (EQUAL-HASH-TABLE-VALUE HASH-TABLE IDX) T))))
     344
     345(DEFUN PUTHASH-EQUAL (KEY VALUE HASH-TABLE &AUX SIZE HASH)
     346  (SETQ SIZE (EQUAL-HASH-TABLE-SIZE HASH-TABLE))
     347  (SETQ HASH (ABS (SXHASH KEY)))
     348  (DO ((IDX (\ HASH SIZE) (\ (1+ IDX) SIZE))
     349       (TEM))
     350      (NIL)
     351    (COND ((OR (NULL (SETQ TEM (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX)))
     352               (MINUSP TEM))
     353           (SETF (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX) HASH)
     354           (SETF (EQUAL-HASH-TABLE-KEY HASH-TABLE IDX) KEY)
     355           (SETF (EQUAL-HASH-TABLE-VALUE HASH-TABLE IDX) VALUE)
     356           (LET ((FULLNESS (1+ (EQUAL-HASH-TABLE-FULLNESS HASH-TABLE))))
     357             (SETF (EQUAL-HASH-TABLE-FULLNESS HASH-TABLE) FULLNESS)
     358             (AND (> FULLNESS (* SIZE (EQUAL-HASH-TABLE-THRESHOLD HASH-TABLE)))
     359                  (EQUAL-HASH-TABLE-REHASH
     360                    HASH-TABLE
     361                    (FIX (* SIZE (EQUAL-HASH-TABLE-GROWTH-FACTOR HASH-TABLE))))))
     362           (RETURN))
     363          ((AND (= TEM HASH) (EQUAL KEY (EQUAL-HASH-TABLE-KEY HASH-TABLE IDX)))
     364           (SETF (EQUAL-HASH-TABLE-VALUE HASH-TABLE IDX) VALUE)
     365           (RETURN))))
     366  VALUE)
     367
     368(DEFUN SWAPHASH-EQUAL (KEY VALUE HASH-TABLE &AUX SIZE HASH)
     369  (SETQ SIZE (EQUAL-HASH-TABLE-SIZE HASH-TABLE))
     370  (SETQ HASH (ABS (SXHASH KEY)))
     371  (DO ((IDX (\ HASH SIZE) (\ (1+ IDX) SIZE))
     372       (TEM))
     373      (NIL)
     374    (COND ((OR (NULL (SETQ TEM (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX)))
     375               (MINUSP TEM))
     376           (SETF (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX) HASH)
     377           (SETF (EQUAL-HASH-TABLE-KEY HASH-TABLE IDX) KEY)
     378           (SETF (EQUAL-HASH-TABLE-VALUE HASH-TABLE IDX) VALUE)
     379           (LET ((FULLNESS (1+ (EQUAL-HASH-TABLE-FULLNESS HASH-TABLE))))
     380             (SETF (EQUAL-HASH-TABLE-FULLNESS HASH-TABLE) FULLNESS)
     381             (AND (> FULLNESS (* SIZE (EQUAL-HASH-TABLE-THRESHOLD HASH-TABLE)))
     382                  (EQUAL-HASH-TABLE-REHASH
     383                    HASH-TABLE
     384                    (FIX (* SIZE (EQUAL-HASH-TABLE-GROWTH-FACTOR HASH-TABLE))))))
     385           (RETURN NIL NIL))
     386          ((AND (= TEM HASH) (EQUAL KEY (EQUAL-HASH-TABLE-KEY HASH-TABLE IDX)))
     387           (RETURN (PROG1 (EQUAL-HASH-TABLE-VALUE HASH-TABLE IDX)
     388                          (SETF (EQUAL-HASH-TABLE-VALUE HASH-TABLE IDX) VALUE))
     389                   T)))))
     390
     391;Note that this rehashes using the hash codes saved in the table.  It does not page
     392;in any of the keys and values.
     393(DEFUN EQUAL-HASH-TABLE-REHASH (HASH-TABLE NEW-SIZE &AUX HASH)
     394  (LET ((NEW-HASH-TABLE (MAKE-EQUAL-HASH-TABLE
     395                            ':AREA (%AREA-NUMBER HASH-TABLE)
     396                            ':SIZE NEW-SIZE
     397                            ':REHASH-THRESHOLD (EQUAL-HASH-TABLE-THRESHOLD HASH-TABLE)
     398                            ':GROWTH-FACTOR (EQUAL-HASH-TABLE-GROWTH-FACTOR HASH-TABLE))))
     399    (SETQ NEW-SIZE (EQUAL-HASH-TABLE-SIZE NEW-HASH-TABLE))
     400    (DOTIMES (I (EQUAL-HASH-TABLE-SIZE HASH-TABLE))
     401      (COND ((AND (SETQ HASH (EQUAL-HASH-TABLE-HASH HASH-TABLE I))
     402                  (
     403 HASH 0))
     404             (DO ((J (\ HASH NEW-SIZE) (\ (1+ J) NEW-SIZE))) (NIL)
     405               (COND ((NULL (EQUAL-HASH-TABLE-HASH NEW-HASH-TABLE J))
     406                      (SETF (EQUAL-HASH-TABLE-HASH NEW-HASH-TABLE J) HASH)
     407                      (SETF (EQUAL-HASH-TABLE-KEY NEW-HASH-TABLE J)
     408                            (EQUAL-HASH-TABLE-KEY HASH-TABLE I))
     409                      (SETF (EQUAL-HASH-TABLE-VALUE NEW-HASH-TABLE J)
     410                            (EQUAL-HASH-TABLE-VALUE HASH-TABLE I))
     411                      (RETURN)))))))
     412    (SETF (EQUAL-HASH-TABLE-FULLNESS NEW-HASH-TABLE)
     413          (EQUAL-HASH-TABLE-FULLNESS HASH-TABLE))
     414    (STRUCTURE-FORWARD HASH-TABLE NEW-HASH-TABLE)))
     415
     416(DEFUN REMHASH-EQUAL (KEY HASH-TABLE &AUX HASH SIZE)
     417  (SETQ HASH (ABS (SXHASH KEY))
     418        SIZE (EQUAL-HASH-TABLE-SIZE HASH-TABLE))
     419  (DO ((IDX (\ HASH SIZE) (\ (1+ IDX) SIZE))
     420       (TEM))
     421      (NIL)
     422    (OR (SETQ TEM (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX))
     423        (RETURN NIL))                           ;Not found
     424    (COND ((AND (= TEM HASH) (EQUAL KEY (EQUAL-HASH-TABLE-KEY HASH-TABLE IDX)))
     425           (SETF (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX) -1)
     426           (SETF (EQUAL-HASH-TABLE-KEY HASH-TABLE IDX) NIL)
     427           (SETF (EQUAL-HASH-TABLE-VALUE HASH-TABLE IDX) NIL)
     428           (SETF (EQUAL-HASH-TABLE-FULLNESS HASH-TABLE)
     429                 (1- (EQUAL-HASH-TABLE-FULLNESS HASH-TABLE)))
     430           (RETURN T)))))
     431
     432(DEFUN MAPHASH-EQUAL (FUNCTION HASH-TABLE)
     433  (DO ((IDX 0 (1+ IDX))
     434       (SIZE (EQUAL-HASH-TABLE-SIZE HASH-TABLE))
     435       (HASH))
     436      ((
     437 IDX SIZE))
     438    (AND (SETQ HASH (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX))
     439         (
     440 HASH 0)
     441         (FUNCALL FUNCTION (EQUAL-HASH-TABLE-KEY HASH-TABLE IDX)
     442                           (EQUAL-HASH-TABLE-VALUE HASH-TABLE IDX)))))
     443
     444(DEFSELECT ((EQUAL-HASH-TABLE NAMED-STRUCTURE-INVOKE))
     445  (:DESCRIBE (HASH-TABLE &AUX SIZE FULLNESS)
     446    (SETQ SIZE (EQUAL-HASH-TABLE-SIZE HASH-TABLE)
     447          FULLNESS (EQUAL-HASH-TABLE-FULLNESS SELF))
     448    (FORMAT T "~&~S is a hash-table with ~D entries out of a possible ~D (~D%).~%"
     449            HASH-TABLE FULLNESS SIZE (// (* FULLNESS 100.) SIZE))
     450    (FORMAT T "~&Rehash threshold = ~2F, Growth factor = ~2F"
     451            (EQUAL-HASH-TABLE-THRESHOLD HASH-TABLE)
     452            (EQUAL-HASH-TABLE-GROWTH-FACTOR HASH-TABLE))
     453    (AND (NOT (ZEROP FULLNESS))
     454         (Y-OR-N-P "Do you want to see distribution information?")
     455         (DO ((DIFFS (MAKE-ARRAY FULLNESS ':TYPE 'ART-16B))
     456              (IDX 0 (1+ IDX))
     457              (HASH) (DIFF))
     458             ((
     459 IDX SIZE)
     460              (DO ((J 0 (1+ J))
     461                   (N))
     462                  ((
     463 J FULLNESS))
     464                (AND (NOT (ZEROP (SETQ N (AREF DIFFS J))))
     465                     (FORMAT T "~&~D entr~:@P off by ~D~%" N J))))
     466           (COND ((AND (SETQ HASH (EQUAL-HASH-TABLE-HASH HASH-TABLE IDX))
     467                       (
     468 HASH 0))
     469                  (SETQ DIFF (- IDX (\ HASH SIZE)))
     470                  (AND (MINUSP DIFF) (SETQ DIFF (+ DIFF SIZE)))
     471                  (ASET (1+ (AREF DIFFS DIFF)) DIFFS DIFF)))))
     472    (AND (NOT (ZEROP FULLNESS))
     473         (Y-OR-N-P "Do you want to see the contents of the hash table?")
     474         (IF (NOT (Y-OR-N-P "Do you want it sorted?"))
     475             (MAPHASH-EQUAL #'(LAMBDA (KEY VALUE) (FORMAT T "~& ~S -> ~S~%" KEY VALUE))
     476                            HASH-TABLE)
     477             (LOCAL-DECLARE ((SPECIAL *L*))
     478               (LET ((*L* NIL))
     479                 (MAPHASH-EQUAL #'(LAMBDA (KEY VALUE) (PUSH (LIST KEY VALUE) *L*))
     480                                HASH-TABLE)
     481                 (SETQ *L* (SORTCAR *L* #'ALPHALESSP))
     482                 (FORMAT T "~&~:{ ~S -> ~S~%~}" *L*)))))))
  • trunk/lisp/lispm2/let.lisp

    r245 r278  
    1919           ((null pairs)
    2020            (cond ((not (null vars))
    21                    `((lambda ,vars . ,body) . ,let-macro-vals))
     21                   `((lambda ,(reverse vars) . ,body) . ,(reverse let-macro-vals)))
    2222                  ((null (cdr body))
    2323                   (car body))
  • trunk/lisp/lispm2/lmmac.lisp

    r247 r278  
    1 ;; These are the macros in the Lisp Machine system.   -*-LISP-*-
     1;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8 -*-
     2;; These are the macros in the Lisp Machine system.
    23;; They used to be in LISPM;MACROS > but have been moved
    34;; for purposes of the cold load.
     
    7172                 (T `(SETF ,DEST (CAR ,LIST))))
    7273           (SETF ,LIST (CDR ,LIST))))
    73 
    74 ; (LET ((VAR1 VAL1) (VAR2 VAL2) VAR3 ..) <BODY>)
    75 ; binds VAR1 to VAL1 and VAR2 to VAL2 and VAR3 to NIL.
    76 
    77 (DEFMACRO-DISPLACE LET (VARLIST . BODY)
    78    `((LAMBDA ,(MAPCAR '(LAMBDA (V) (COND ((ATOM V) V)
    79                                          ((CDDR V)
    80                                           (FERROR NIL "~S extraneous in LET" V))
    81                                          (T (CAR V))))
    82                       VARLIST)
    83              . ,BODY)
    84      . ,(MAPCAR '(LAMBDA (V) (COND ((ATOM V) NIL) (T (CADR V)))) VARLIST)))
    85 
    86 ; LET* is like LET except it binds sequentially instead of in parallel.
    87 
    88 (DEFMACRO-DISPLACE LET* (VARLIST . BODY)
    89           (DO ((L (REVERSE VARLIST) (CDR L))
    90                (B BODY `(((LAMBDA (,(COND ((ATOM (CAR L)) (CAR L))
    91                                           (T (CAAR L))))
    92                                   . ,B)
    93                           ,(COND ((ATOM (CAR L)) NIL)
    94                                  (T (CADAR L)))))))
    95               ((NULL L)
    96                (COND ((NULL (CDR B)) (CAR B))
    97                      (T `(PROGN . ,B))))))
    98 
    9974)
    10075
     76;;; (DEFSUBST FOO (X) (AR-1 X 5)) is like a similar DEFUN
     77;;; except that the definition of FOO will be substituted in at compile time
     78;;; and FOO's argument variables eliminated by substitution.
     79;;; It is your responsibility to make sure that FOO's args
     80;;; are evaluated exactly once, in the right ordr, in FOO's body,
     81;;; and that the symbols used for the args do not appear except
     82;;; to represent the args.
     83#Q
     84(DEFMACRO DEFSUBST (FUNCTION LAMBDA-LIST . BODY)
     85  (LET ((DEF1 `(NAMED-SUBST ,FUNCTION ,LAMBDA-LIST . ,BODY)))
     86    `(PROGN 'COMPILE
     87            (EVAL-WHEN (COMPILE) (PUSH '(DEF ,FUNCTION . ,DEF1) LOCAL-DECLARATIONS))
     88            (FSET-CAREFULLY ',FUNCTION ',DEF1))))
     89
     90;Semi-adequate Maclisp version
     91#M
     92(DEFMACRO DEFSUBST (FUNCTION LAMBDA-LIST . BODY)
     93  `(DEFUN ,FUNCTION MACRO (X)
     94     (SUBLIS (DO ((V ',LAMBDA-LIST (CDR V))
     95                  (X (CDR X) (CDR X))
     96                  (R NIL (CONS (CONS (CAR V) (CAR X)) R)))
     97                  ((NULL V) (NREVERSE R)))
     98              '(PROGN . ,BODY))))
     99
     100;This is for defstruct (or anything else which writes substs automatically
     101;as part of the expansion of some other form)
     102;PARENT is a list of the parent definition name and its definition type.
     103;Also accepted is a symbol, which is what it used to be (for old compiled defstructs).
     104;Note that this -does- -not- put the function on compiler:functions-defined, thus
     105;you get a warning if you fail to get open-coding due to a forward reference.
     106(DEFMACRO DEFSUBST-WITH-PARENT (FUNCTION PARENT LAMBDA-LIST . BODY)
     107  (OR (LISTP PARENT) (SETQ PARENT (LIST PARENT)))
     108  (LET ((DEF1 `(NAMED-SUBST (,FUNCTION (FUNCTION-PARENT . ,PARENT)) ,LAMBDA-LIST . ,BODY)))
     109    `(PROGN 'COMPILE
     110            (EVAL-WHEN (COMPILE) (PUSH '(DEF ,FUNCTION . ,DEF1) LOCAL-DECLARATIONS))
     111            (FSET-CAREFULLY ',FUNCTION ',DEF1))))
     112
    101113(DEFMACRO-DISPLACE @DEFINE (&REST IGNORE) NIL)
    102114
     
    122134
    123135(DEFSUBST REST4 (LIST) (CDDDDR LIST))
    124 
    125 ;; (<= A B) --> (NOT (> A B))
    126 ;; (<= A B C) --> (NOT (OR (> A B) (> B C)))
    127 ;; Funny arglist to check for correct number of arguments.
    128 
    129 (DEFMACRO-DISPLACE <= (ARG1 ARG2 &REST REST &AUX RESULT)
    130   (SETQ REST (LIST* ARG1 ARG2 REST))
    131   (DO L REST (CDR L) (NULL (CDR L))
    132       (PUSH `(> ,(CAR L) ,(CADR L)) RESULT))
    133   (COND ((NULL (CDR RESULT)) `(NOT ,(CAR RESULT)))
    134         (T `(NOT (OR . ,(NREVERSE RESULT))))))
    135 
    136 ;; (>= A B) --> (NOT (< A B))
    137 ;; (>= A B C) --> (NOT (OR (< A B) (< B C)))
    138 ;; Funny arglist to check for correct number of arguments.
    139 
    140 (DEFMACRO-DISPLACE >= (ARG1 ARG2 &REST REST &AUX RESULT)
    141   (SETQ REST (LIST* ARG1 ARG2 REST))
    142   (DO L REST (CDR L) (NULL (CDR L))
    143       (PUSH `(< ,(CAR L) ,(CADR L)) RESULT))
    144   (COND ((NULL (CDR RESULT)) `(NOT ,(CAR RESULT)))
    145         (T `(NOT (OR . ,(NREVERSE RESULT))))))
    146 
    147 (DEFMACRO-DISPLACE /
    148  (ARG1 ARG2 &REST REST) `(<= ,ARG1 ,ARG2 . ,REST))
    149 
    150 (DEFMACRO-DISPLACE /
    151  (ARG1 ARG2 &REST REST) `(>= ,ARG1 ,ARG2 . ,REST))
    152136
    153137(DEFSUBST NEQ (X Y) (NOT (EQ X Y)))
     
    185169)
    186170
     171(DEFMACRO-DISPLACE CATCH-ERROR (BODY &OPTIONAL (PRINTFLAG T))
     172    `(LET ((EH:ERRSET-STATUS T)
     173           (EH:ERRSET-PRINT-MSG ,PRINTFLAG))
     174       (*CATCH 'EH:ERRSET-CATCH ,BODY)))
     175
    187176(IF-IN-LISPM
    188177(DEFMACRO-DISPLACE ARRAYCALL (IGNORE ARRAY &REST DIMS)
     
    191180
    192181
    193 (DEFMACRO-DISPLACE SELECTQ (TEST-OBJECT . CLAUSES)
     182(DEFMACRO-DISPLACE SELECTQ (TEST-OBJECT &BODY CLAUSES)
    194183    (LET (TEST-EXP COND-EXP)
    195184         (SETQ TEST-EXP
     
    215204                      ,COND-EXP)))))
    216205
    217 (DEFMACRO-DISPLACE SELECT (TEST-OBJECT . CLAUSES)
     206;;;This should be sufficient for the moment:
     207(DEFMACRO-DISPLACE CASEQ (TEST-OBJECT &BODY CLAUSES)
     208  `(SELECTQ ,TEST-OBJECT ,@CLAUSES))
     209
     210(DEFMACRO-DISPLACE SELECT (TEST-OBJECT &BODY CLAUSES)
    218211    (LET (TEST-EXP COND-EXP)
    219212         (SETQ TEST-EXP
     
    242235                      ,COND-EXP)))))
    243236
    244 (DEFMACRO-DISPLACE SELECTOR (TEST-OBJECT TEST-FUNCTION . CLAUSES)
     237(DEFMACRO-DISPLACE SELECTOR (TEST-OBJECT TEST-FUNCTION &BODY CLAUSES)
    245238    (LET (TEST-EXP COND-EXP)
    246239         (SETQ TEST-EXP
     
    270263
    271264;EVENTUALLY THE MICRO COMPILER SHOULD BE AWARE OF THIS
    272 (DEFMACRO-DISPLACE DISPATCH (PPSS WORD . BODY)
    273   (LIST
    274     (LIST
    275       'LAMBDA
    276       '(*BYTE*)
    277       (CONS 'COND
    278             (MAPCAR (FUNCTION (LAMBDA (CLAUSE)
    279                        (COND ((EQ (CAR CLAUSE) 'OTHERWISE)
    280                               (CONS T (CDR CLAUSE)))
    281                              ((ATOM (CAR CLAUSE))
    282                               (CONS (LIST '= '*BYTE* (CAR CLAUSE))
    283                                     (CDR CLAUSE)))
    284                              (T
    285                               (CONS (CONS 'OR
    286                                           (MAPCAR (FUNCTION (LAMBDA (ITEM)
    287                                                      (LIST '= '*BYTE* ITEM)))
    288                                                   (CAR CLAUSE)))
    289                                     (CDR CLAUSE))))))
    290                     BODY)))
    291     (LIST 'LDB PPSS WORD)))
     265(DEFMACRO-DISPLACE DISPATCH (PPSS WORD &BODY BODY)
     266  `(LET ((.DISPATCH-INTERNAL. (LDB ,PPSS ,WORD)))
     267     (COND ,@(MAPCAR #'(LAMBDA (CLAUSE)
     268                         `(,(COND ((EQ (CAR CLAUSE) 'OTHERWISE)
     269                                   'T)
     270                                  ((ATOM (CAR CLAUSE))
     271                                   `(= .DISPATCH-INTERNAL. ,(CAR CLAUSE)))
     272                                  (T
     273                                   `(OR ,@(MAPCAR #'(LAMBDA (ITEM)
     274                                                      `(= .DISPATCH-INTERNAL. ,ITEM))
     275                                                  (CAR CLAUSE)))))
     276                           . ,(CDR CLAUSE)))
     277                     BODY))))
    292278
    293279(DEFMACRO-DISPLACE EVERY (LIST PRED &OPTIONAL (STEP ''CDR))
     
    301287      (AND (FUNCALL ,PRED (CAR *L*)) (RETURN *L*))))
    302288
    303 ;(BEGF FOO)  and  (ENDF FOO) delimit the definition of FOO, for EDFN.
    304 (DEFMACRO-DISPLACE BEGF IGNORE '(DECLARE))
    305 
    306 (DEFMACRO-DISPLACE ENDF IGNORE '(DECLARE))
    307 
    308 ; LET-GLOBALLY IS SIMILAR TO LET, EXCEPT THAT THE BINDING APPLIES
    309 ; TO THE WHOLE WORLD, NOT JUST THE CURRENTLY-EXECUTING STACK GROUP.
    310 ; FOR THE MOMENT, ANYWAY, IT IS IMPLEMENTED USING UNWIND-PROTECT.
    311 (DEFMACRO-DISPLACE LET-GLOBALLY (VARLIST . BODY)
     289;;;  LET-GLOBALLY IS SIMILAR TO LET, EXCEPT THAT THE BINDING APPLIES
     290;;;  TO THE WHOLE WORLD, NOT JUST THE CURRENTLY-EXECUTING STACK GROUP.
     291;;;  FOR THE MOMENT, ANYWAY, IT IS IMPLEMENTED USING UNWIND-PROTECT.
     292(DEFMACRO-DISPLACE LET-GLOBALLY (VARLIST &BODY BODY)
    312293  (LET ((VARS (MAPCAR '(LAMBDA (V) (COND ((ATOM V) V) (T (CAR V)))) VARLIST))
    313294        (VALS (MAPCAR '(LAMBDA (V) (COND ((ATOM V) NIL) (T (CADR V)))) VARLIST))
     
    318299                        (SETQ . ,(MAPCAN 'LIST VARS GENVARS))))))
    319300
    320 ;DEFUNP is like DEFUN but provides an implicit PROG.
    321 ;However, the value on falling off the end is the last thing in the body.
    322 
    323 (DEFMACRO DEFUNP (FUNCTION ARGS &REST BODY
    324                                 &AUX (DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
    325                                      (LAST NIL))
    326   (SETQ BODY (APPEND BODY NIL))
    327   (SETQ LAST (LAST BODY))
    328   (COND ((OR (ATOM (CAR LAST)) (NOT (EQ 'RETURN (CAAR LAST))))
    329          (RPLACA LAST (LIST 'RETURN (CAR LAST)))))
    330   `(DEFUN ,FUNCTION ,ARGS
    331      (PROG () . ,BODY)))
    332 
    333 ;This is a dummy DISPLACE for use in lisp-machine macros
    334 ;called in code being compiled on the PDP-10.
    335 ;If anyone starts wanting a real DISPLACE in QCMP
    336 ;(eg, for running interpretively part of QCMP
    337 ;which uses displacing macros)
    338 ;just flush this one and let the real one be used for this as well.
    339 (IF-IN-MACLISP
    340 (DEFUN DISPLACE (OLD NEW) NEW))
    341 
    342 ;(UNWIND-PROTECT risky-stuff forms-to-do-when-unwinding-this-frame)
    343 ;If risky-stuff returns, we return what it returns, doing forms-to-do
    344 ;(just as PROG1 would do).  If risky-stuff does a throw, we let the throw
    345 ;function as specified, but make sure that forms-to-do get done as well.
    346 ;forms-to-do can refer to UNWIND-PROTECT-TAG, which is the tag if
    347 ;a throw is happening, or NIL if risky-stuff is just returning.
    348 ;UNWIND-PROTECT is an fsubr in Maclisp.
    349 (PROGN 'COMPILE
    350 #Q
    351 (DEFMACRO-DISPLACE UNWIND-PROTECT (BODY . UNDO-FN)
    352     `(MULTIPLE-VALUE-BIND (UNWIND-PROTECT-VALUE UNWIND-PROTECT-TAG
    353                            UNWIND-PROTECT-COUNT UNWIND-PROTECT-ACTION)
    354          (*CATCH T ,BODY)
    355          ,@UNDO-FN
    356          (AND UNWIND-PROTECT-TAG  ;Continue whatever type of throw or unwind was happening
    357               (*UNWIND-STACK UNWIND-PROTECT-TAG UNWIND-PROTECT-VALUE
    358                              UNWIND-PROTECT-COUNT UNWIND-PROTECT-ACTION))
    359          UNWIND-PROTECT-VALUE))
    360 )
     301;;; DEFUNP is like DEFUN but provides an implicit PROG.
     302;;; However, the value on falling off the end is the last thing in the body.
     303
     304(DEFMACRO DEFUNP (FUNCTION ARGS &REST BODY)
     305  (LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
     306        (LAST NIL)
     307        (DECLARES NIL))
     308    (SETQ BODY (APPEND BODY NIL))
     309    (SETQ LAST (LAST BODY))
     310    (DO () (())
     311      (IF (OR (NULL BODY) (EQ BODY LAST))
     312          (RETURN))
     313      (LET ((FORM (CAR BODY)))
     314        (COND ((AND (NOT (ATOM FORM))
     315                    (EQ (CAR FORM) 'DECLARE))
     316               (PUSH FORM DECLARES)
     317               (POP BODY))
     318              (T (RETURN)))))
     319    (COND ((OR (ATOM (CAR LAST)) (NOT (EQ 'RETURN (CAAR LAST))))
     320           (RPLACA LAST (LIST 'RETURN (CAR LAST)))))
     321    `(DEFUN ,FUNCTION ,ARGS
     322       ,@(NREVERSE DECLARES)
     323       (PROG () . ,BODY))))
    361324
    362325(DEFMACRO-DISPLACE CATCH-ALL BODY
    363326   `(*CATCH NIL (PROGN . ,BODY)))
    364327
    365 ;(IF test then-action else-action)
     328;;; (IF test then-action else-action)
    366329(DEFMACRO-DISPLACE IF (TEST THEN &REST ELSES)
    367330   (COND ((NULL TEST) (AND ELSES `(PROGN . ,ELSES)))    ;macros can generate this case...
     
    400363                       ',ERROR-TYPE-NAME ,ARG-NAME ',ARG-NAME ',TYPE-STRING))))
    401364
    402 ;(KEYWORD-EXTRACT <keylist> KEY '(FOO (UGH BLETCH) BAR) '(FLAG FALG) <otherwise> ...)
    403 ;parses a TV-DEFINE-PC-PPR style list of alternating keywords and values, <keylist>.
    404 ;The symbol KEY is bound internally to the name of the next keyword to be tested.
    405 ;The keywords recognized are :FOO, :BAR and UGH;  whatever follows
    406 ;the keyword UGH is put in the variable BLETCH, whatever follows the
    407 ;keyword :FOO is put in the variable FOO, and similar for BAR.
    408 ;The flags are :FLAG and :FALG;  if :FLAG is seen, FLAG is set to T.
    409 ;<otherwise> is one or more SELECTQ clauses which can be used
    410 ;to recognize whatever else you like, in nonstandard format.
    411 ;To gobble the next thing from the <keylist>, say (CAR (SETQ KEY (CDR KEY))).
    412 ;Note that by default the actual keywords are in the user package and
    413 ;the variables are in the current package.  Because of this, you
    414 ;cannot compile except on the real machine unless you restrict yourself
    415 ;to specifying the keywords and variables, both, as in (UGH BLETCH).
    416 ;That is ok, since code written any other way which put the keywords in
    417 ;the user package as it should would require colons and have the same problem.
    418 (DEFMACRO-DISPLACE KEYWORD-EXTRACT (KEYLIST KEYVAR KEYWORDS &OPTIONAL FLAGS &REST OTHERWISE)
     365;;; (CHECK-ARG-TYPE X FIXNUM) signals an error if (TYPEP X 'FIXNUM) is not true.
     366(DEFMACRO CHECK-ARG-TYPE (ARG-NAME TYPE &OPTIONAL TYPE-STRING)
     367  (IF (NULL TYPE-STRING)
     368      (SETQ TYPE-STRING
     369            (COND ((AND (SYMBOLP TYPE)
     370                        (GET TYPE 'SI:TYPE-NAME)))
     371                  (T
     372                   (STRING-APPEND "a " (STRING-DOWNCASE (FORMAT NIL "~A" TYPE)))))))
     373  `(DO () ((TYPEP ,ARG-NAME ',TYPE))
     374     (SETQ ,ARG-NAME
     375           (CERROR T NIL ':WRONG-TYPE-ARGUMENT
     376                   "The argument ~2G~A was ~1G~S, which is not ~3G~A"
     377                   ',TYPE ,ARG-NAME ',ARG-NAME ',TYPE-STRING))))
     378
     379;;; (KEYWORD-EXTRACT <keylist> KEY (FOO (UGH BLETCH) BAR) (FLAG FALG) <otherwise> ...)
     380;;; parses a TV-DEFINE-PC-PPR style list of alternating keywords and values, <keylist>.
     381;;; The symbol KEY is bound internally to remaineder of the keyword list.
     382;;; The keywords recognized are :FOO, :BAR and UGH;  whatever follows
     383;;; the keyword UGH is put in the variable BLETCH, whatever follows the
     384;;; keyword :FOO is put in the variable FOO, and similar for BAR.
     385;;; The flags are :FLAG and :FALG;  if :FLAG is seen, FLAG is set to T.
     386;;; <otherwise> is one or more SELECTQ clauses which can be used
     387;;; to recognize whatever else you like, in nonstandard format.
     388;;; To gobble the next thing from the <keylist>, say (CAR (SETQ KEY (CDR KEY))).
     389(DEFMACRO-DISPLACE KEYWORD-EXTRACT (KEYLIST KEYVAR KEYWORDS &OPTIONAL FLAGS &BODY OTHERWISE)
    419390    `(DO ((,KEYVAR ,KEYLIST (CDR ,KEYVAR)))
    420391         ((NULL ,KEYVAR))
     
    429400                     KEYWORDS)
    430401           ,@(MAPCAR (FUNCTION (LAMBDA (KEYWORD)
    431                                  `(,(INTERN (STRING KEYWORD) "USER")
    432                                    (SETQ ,KEYWORD T))))
     402                                 (COND ((ATOM KEYWORD)
     403                                        `(,(INTERN (STRING KEYWORD) "USER")
     404                                          (SETQ ,KEYWORD T)))
     405                                       (T `(,(CAR KEYWORD)
     406                                            (SETQ ,(CADR KEYWORD) T))))))
    433407                     FLAGS)
    434            . ,OTHERWISE)))
    435 
    436 ;PSETQ looks like SETQ but does its work in parallel.
     408           ,@OTHERWISE
     409           (OTHERWISE
     410            (FERROR NIL "~S is not a recognized keyword" (CAR ,KEYVAR))))))
     411
     412;;; PSETQ looks like SETQ but does its work in parallel.
     413;;; Note that the return value of PSETQ is -not- guaranteed.
    437414(DEFMACRO-DISPLACE PSETQ (&REST REST)
    438      (COND ((CDDR REST)
    439             ;; Not the last pair.
    440             ;; Improve the efficiency of DO-stepping by detecting
    441             ;; that a variable is being set to its CDR or its 1+,
    442             ;; and doing all such variables last.
    443             ;; That makes it possible to do all of them with SETE-CDR.
    444             (COND ((AND (LISTP (CADR REST))
    445                         (MEMQ (CAADR REST) '(1+ CDR))
    446                         (EQ (CADADR REST) (CAR REST)))
    447                    `(PROGN (PSETQ . ,(CDDR REST))
    448                      (SETQ ,(CAR REST) ,(CADR REST))))
    449                   ;; Not set to its own 1+ or CDR;  do it the general way.
    450                   (T
    451                    `(SETQ ,(CAR REST) (PROG1 ,(CADR REST) (PSETQ . ,(CDDR REST)))))))
    452            ;; The last pair.  Keep it simple;  no superfluous (PROG1 (SETQ...) (PSETQ)).
    453            ((CDR REST)
    454             `(SETQ . ,REST))))
    455 
    456 ;For things which want to do a tail-recursive call, passing back multiple
    457 ;values.  This does not work in the interpreter.  This is a temporary measure
    458 ;and will go away when the calling protocol is changed to always pass back
    459 ;multiple values on "tail recursive" calls.
     415  ;; To improve the efficiency of do-stepping, by using the SETE-CDR, SETE-CDDR,
     416  ;; SETE-1+, and SETE-1- instructions, we try to do such operations with SETQ
     417  ;; rather than PSETQ.  To avoid having to do full code analysis, never rearrange
     418  ;; the order of any code when doing this, and only do it when there are no
     419  ;; variable name duplications.
     420  (LOOP FOR (VAL VAR) ON (REVERSE REST) BY 'CDDR
     421        WITH SETQS = NIL WITH PSETQS = NIL
     422        DO (IF (AND (NULL PSETQS)
     423                    (LISTP VAL)
     424                    (MEMQ (CAR VAL) '(1+ 1- CDR CDDR))
     425                    (EQ (CADR VAL) VAR)
     426                    (NOT (MEMQ VAR SETQS)))
     427               (SETQ SETQS (CONS VAR (CONS VAL SETQS)))
     428               (SETQ PSETQS (CONS VAR (CONS VAL PSETQS))))
     429        FINALLY
     430          (SETQ PSETQS (PSETQ-PROG1IFY PSETQS))
     431          (RETURN (COND ((NULL SETQS) PSETQS)
     432                        ((NULL PSETQS) (CONS 'SETQ SETQS))
     433                        (T `(PROGN ,PSETQS (SETQ . ,SETQS)))))))
     434
     435(DEFUN PSETQ-PROG1IFY (X)
     436  (COND ((NULL X) NIL)
     437        ((NULL (CDDR X)) (CONS 'SETQ X))
     438        (T `(SETQ ,(CAR X) (PROG1 ,(CADR X) ,(PSETQ-PROG1IFY (CDDR X)))))))
     439
     440(DEFPROP MULTIPLE-VALUE-CALL COMPILER:OBSOLETE COMPILER:STYLE-CHECKER)
     441;;; THIS FUNCTION IS OBSOLETE.
     442;;; For things which want to do a tail-recursive call, passing back multiple
     443;;; values.  This does not work in the interpreter.  This was a temporary measure
     444;;; and should go away when the calling protocol is changed to always pass back
     445;;; multiple values on "tail recursive" calls.
    460446(DEFMACRO-DISPLACE MULTIPLE-VALUE-CALL ((FUNCTION . ARGS))
    461447  `(PROGN (%OPEN-CALL-BLOCK (FUNCTION ,FUNCTION) 0 4) ;No ADI, destination-return
     
    464450          (%ACTIVATE-OPEN-CALL-BLOCK)))
    465451
    466 ;(LOCAL-DECLARE ((SPECIAL FOO) (UNSPECIAL BAR)) code)
    467 ;declares FOO and BAR locally within <code>.
    468 ;LOCAL-DECLARE can also be used by macros to pass information down
    469 ;to other macros that expand inside the code they produce.
    470 ;The list of declarations (in this case, ((MUMBLE FOO BAR))) is appended
    471 ;onto the front of LOCAL-DECLARATIONS, which can be searched by
    472 ;macros expending inside of <code>.
    473 (DEFMACRO-DISPLACE LOCAL-DECLARE (DECLARATIONS &REST BODY)
     452;;; (LOCAL-DECLARE ((SPECIAL FOO) (UNSPECIAL BAR)) code)
     453;;; declares FOO and BAR locally within <code>.
     454;;; LOCAL-DECLARE can also be used by macros to pass information down
     455;;; to other macros that expand inside the code they produce.
     456;;; The list of declarations (in this case, ((MUMBLE FOO BAR))) is appended
     457;;; onto the front of LOCAL-DECLARATIONS, which can be searched by
     458;;; macros expending inside of <code>.
     459(DEFMACRO-DISPLACE LOCAL-DECLARE (DECLARATIONS &BODY BODY)
    474460    `(COMPILER-LET ((LOCAL-DECLARATIONS (APPEND ',DECLARATIONS LOCAL-DECLARATIONS)))
    475461                   . ,BODY))
    476462
    477 ;INHIBIT-STYLE-WARNINGS inhibits compiler style checking of what is inside it.
    478 ;In the interpreter, it is a no-op.
     463;;; INHIBIT-STYLE-WARNINGS inhibits compiler style checking of what is inside it.
     464;;; In the interpreter, it is a no-op.
    479465(DEFMACRO-DISPLACE INHIBIT-STYLE-WARNINGS (BODY)
    480466    BODY)
    481467
    482 ;(ERROR-RESTART .... (CERROR ...) ...) causes a request by the user
    483 ;or error handler to "restart" after the error to re-execute all the
    484 ;code inside the ERROR-RESTART.
     468;;; (ERROR-RESTART .... (CERROR ...) ...) causes a request by the user
     469;;; or error handler to "restart" after the error to re-execute all the
     470;;; code inside the ERROR-RESTART.
    485471(DEFMACRO-DISPLACE ERROR-RESTART (&REST BODY)
    486472   `(PROG ()
     
    489475          (GO LOOP)))
    490476
    491 ;(LET-CLOSED (variables as in LET) initializations ... (FUNCTION ..))
    492 ;binds the variables and executes the initialization,
    493 ;then returns the last thing in the body, closed over those variables.
    494 (DEFMACRO-DISPLACE LET-CLOSED (VARS &REST BODY)
     477;;; (LET-CLOSED (variables as in LET) initializations ... (FUNCTION ..))
     478;;; binds the variables and executes the initialization,
     479;;; then returns the last thing in the body, closed over those variables.
     480(DEFMACRO-DISPLACE LET-CLOSED (VARS &BODY BODY)
    495481    (LET ((VARNAMES (MAPCAR (FUNCTION (LAMBDA (V) (COND ((ATOM V) V) (T (CAR V))))) VARS)))
    496482         `(LOCAL-DECLARE ((SPECIAL . ,VARNAMES))
     
    498484                      (CLOSURE ',VARNAMES (PROGN . ,BODY))))))
    499485
    500 ;(DEF-OPEN-CODED FOO-COMPONENT (CURRY-AFTER AR-1 5))
    501 ;defines FOO-COMPONENT as an open-coded function with that definition.
     486;;; (DEF-OPEN-CODED FOO-COMPONENT (CURRY-AFTER AR-1 5))
     487;;; defines FOO-COMPONENT as an open-coded function with that definition.
    502488(DEFMACRO DEF-OPEN-CODED (FUNCTION DEFINITION)
    503489    `(PROGN 'COMPILE
     
    505491                       (PUSH '(OPEN-CODE ,FUNCTION ,DEFINITION) LOCAL-DECLARATIONS))
    506492            (FSET-CAREFULLY ',FUNCTION ',DEFINITION)
    507             (DEFPROP ,FUNCTION T 'OPEN-CODE)))
    508 
    509 ;Say that FUNCTION should be open-coded by the compiler as DEFINITION
    510 ;without changing FUNCTION's real definition.
    511 ;A call to this OPEN-CODE can be used as a local declaration, too.
    512 ;Giving NIL as the definition turns off open-coding.
     493            (DEFPROP ,FUNCTION T OPEN-CODE)))
     494
     495;;; Say that FUNCTION should be open-coded by the compiler as DEFINITION
     496;;; without changing FUNCTION's real definition.
     497;;; A call to this OPEN-CODE can be used as a local declaration, too.
     498;;; Giving NIL as the definition turns off open-coding.
    513499(DEFMACRO OPEN-CODE (FUNCTION DEFINITION)
    514500    `(PROGN 'COMPILE
    515501            (EVAL-WHEN (COMPILE)
    516502                       (PUSH '(OPEN-CODE ,FUNCTION ,DEFINITION) LOCAL-DECLARATIONS))
    517             (DEFPROP ,FUNCTION ,DEFINITION 'OPEN-CODE)))
    518 
    519 ;(DEFSUBST FOO (X) (AR-1 X 5)) is like a similar DEFUN
    520 ;except that the definition of FOO will be substituted in at compile time
    521 ;and FOO's argument variables eliminated by substitution.
    522 ;It is your responsibility to make sure that FOO's args
    523 ;are evaluated exactly once, in the right ordr, in FOO's body,
    524 ;and that the symbols used for the args do not appear except
    525 ;to represent the args.
    526 (DEFMACRO DEFSUBST (FUNCTION LAMBDA-LIST . BODY)
    527   (LET ((DEF1 `(SUBST ,LAMBDA-LIST . ,BODY)))
    528     `(PROGN 'COMPILE
    529             (EVAL-WHEN (COMPILE) (PUSH '(DEF ,FUNCTION . ,DEF1) LOCAL-DECLARATIONS))
    530             (FSET-CAREFULLY ',FUNCTION ',DEF1))))
    531 
    532 ;Make a variable special and, optionally, initialize it.
    533 ;This is recorded as a definition by TAGS and ZWEI.
    534 (DEFMACRO DEFVAR (VARIABLE &OPTIONAL (INITIAL-VALUE NIL INITIALIZE-P))
     503            (DEFPROP ,FUNCTION ,DEFINITION OPEN-CODE)))
     504
     505;;; Make a variable special and, optionally, initialize it.
     506;;; This is recorded as a definition by TAGS and ZWEI.
     507(DEFMACRO DEFVAR (VARIABLE &OPTIONAL (INITIAL-VALUE NIL INITIALIZE-P)
     508                                     (DOCUMENTATION "" DOCUMENTATION-P))
    535509  `(PROGN 'COMPILE
    536510        (SPECIAL ,VARIABLE)
    537         (RECORD-SOURCE-FILE-NAME ',VARIABLE)
     511        (RECORD-SOURCE-FILE-NAME ',VARIABLE 'DEFVAR)
     512        ,(IF INITIALIZE-P
     513             ;; Initialize in a way that works in the cold-load
     514             ;; Don't evaluate INITIAL-VALUE unless used
     515             `(,(IF FS:THIS-IS-A-PATCH-FILE 'SETQ 'SETQ-IF-UNBOUND)
     516               ,VARIABLE ,INITIAL-VALUE))
     517        ,(IF DOCUMENTATION-P
     518             `(PUTPROP ',VARIABLE ',DOCUMENTATION ':VALUE-DOCUMENTATION))))
     519
     520;;; Similar to DEFVAR, but if initialization given, always use it (not just if
     521;;; variable was previously unbound).
     522(DEFMACRO DEFCONST (VARIABLE &OPTIONAL (INITIAL-VALUE NIL INITIALIZE-P)
     523                                       (DOCUMENTATION "" DOCUMENTATION-P))
     524  `(PROGN 'COMPILE
     525        (SPECIAL ,VARIABLE)
     526        (RECORD-SOURCE-FILE-NAME ',VARIABLE 'DEFVAR)
    538527        ,(AND INITIALIZE-P   
    539528              ;Initialize in a way that works in the cold-load
    540529              ;Don't evaluate INITIAL-VALUE unless used
    541               `(SETQ-IF-UNBOUND ,VARIABLE ,INITIAL-VALUE))))
    542 
    543 ;Similar to DEFVAR, but if initialization given, always use it (not just if
    544 ;variable was previously unbound).
    545 (DEFMACRO DEFCONST (VARIABLE &OPTIONAL (INITIAL-VALUE NIL INITIALIZE-P))
    546   `(PROGN 'COMPILE
    547         (SPECIAL ,VARIABLE)
    548         (RECORD-SOURCE-FILE-NAME ',VARIABLE)
    549         ,(AND INITIALIZE-P   
    550               ;Initialize in a way that works in the cold-load
    551               ;Don't evaluate INITIAL-VALUE unless used
    552               `(SETQ ,VARIABLE ,INITIAL-VALUE))))
    553 
    554 ;Performs a sequence of operations while inhibiting scheduling
     530              `(SETQ ,VARIABLE ,INITIAL-VALUE))
     531        ,(IF DOCUMENTATION-P
     532             `(PUTPROP ',VARIABLE ',DOCUMENTATION ':VALUE-DOCUMENTATION))))
     533
     534;;; Performs a sequence of operations while inhibiting scheduling
    555535(DEFMACRO-DISPLACE WITHOUT-INTERRUPTS (&REST FORMS)
    556536  `(LET ((INHIBIT-SCHEDULING-FLAG T))
    557537     . ,FORMS))
    558538
    559 ;MAPC with a prog body instead of a function.  <form> evaluates to a list,
    560 ;and <body> is executed with <var> bound to successive elements of the list.
    561 (DEFMACRO-DISPLACE DOLIST ((VAR FORM) &REST BODY)
    562    (LET ((DUMMY (GENSYM)))
    563      `(DO ((,DUMMY ,FORM (CDR ,DUMMY))
    564            (,VAR))
    565           ((NULL ,DUMMY))
    566          (SETQ ,VAR (CAR ,DUMMY))
    567          . ,BODY)))
    568 
    569 ;Repeat a number of times.  <form> evaluates to the number of times,
    570 ;and <body> is executed with <var> bound to 0, 1, ...
    571 ;Don't generate dummy variable if <form> is an integer.  We could also do this
    572 ;if <form> were a symbol, but the symbol may get clobbered inside the body,
    573 ;so the behavior of the macro would change.
    574 (DEFMACRO-DISPLACE DOTIMES ((VAR FORM) &REST BODY &AUX DUMMY)
     539;;; MAPC with a prog body instead of a function.  <form> evaluates to a list,
     540;;; and <body> is executed with <var> bound to successive elements of the list.
     541(DEFMACRO-DISPLACE DOLIST ((VAR FORM) &BODY BODY)
     542  `(DO ((.DOLIST-INTERNAL. ,FORM (CDR .DOLIST-INTERNAL.))
     543        (,VAR))
     544       ((NULL .DOLIST-INTERNAL.))
     545     (SETQ ,VAR (CAR .DOLIST-INTERNAL.))
     546     . ,BODY))
     547
     548;;; Repeat a number of times.  <form> evaluates to the number of times,
     549;;; and <body> is executed with <var> bound to 0, 1, ...
     550;;; Don't generate dummy variable if <form> is an integer.  We could also do this
     551;;; if <form> were a symbol, but the symbol may get clobbered inside the body,
     552;;; so the behavior of the macro would change.
     553(DEFMACRO-DISPLACE DOTIMES ((VAR FORM) &BODY BODY)
    575554  (COND ((FIXP FORM)
    576555         `(DO ((,VAR 0 (1+ ,VAR)))
     
    578557 ,VAR ,FORM))
    579558            . ,BODY))
    580         (T (SETQ DUMMY (GENSYM))
    581            `(DO ((,VAR 0 (1+ ,VAR))
    582                  (,DUMMY ,FORM))
     559        (T `(DO ((,VAR 0 (1+ ,VAR))
     560                 (.DOTIMES-INTERNAL. ,FORM))
    583561                ((
    584  ,VAR ,DUMMY))
     562 ,VAR .DOTIMES-INTERNAL.))
    585563              . ,BODY))))
    586564
    587 ;Execute body with a file open.  Abnormal exit aborts the file (if it's an output file).
    588 (DEFMACRO-DISPLACE WITH-OPEN-FILE ((STREAM FILENAME OPTIONS) . BODY)
    589   `(LET ((,STREAM NIL))
    590      (UNWIND-PROTECT (PROGN (SETQ ,STREAM (OPEN ,FILENAME ,OPTIONS))
    591                             ,@BODY
    592                             (FUNCALL ,STREAM ':CLOSE))
    593        (AND ,STREAM (FUNCALL ,STREAM ':CLOSE ':ABORT)))))
     565;;; Execute body with a stream open.  Abnormal exit aborts the file (if it's an output file).
     566(DEFMACRO-DISPLACE WITH-OPEN-STREAM ((STREAM CONSTRUCTION-FORM) &BODY BODY)
     567  `(LET ((,STREAM NIL)
     568         (.FILE-ABORTED-FLAG. ':ABORT))
     569     (UNWIND-PROTECT
     570       (PROG2 (SETQ ,STREAM ,CONSTRUCTION-FORM)
     571              (PROGN . ,BODY)
     572              (SETQ .FILE-ABORTED-FLAG. NIL))
     573       (AND ,STREAM (NOT (STRINGP ,STREAM))
     574            (FUNCALL ,STREAM ':CLOSE .FILE-ABORTED-FLAG.)))))
     575
     576;;; Execute body with a file open.
     577(DEFMACRO-DISPLACE WITH-OPEN-FILE ((STREAM FILENAME . OPTIONS) &BODY BODY)
     578  `(WITH-OPEN-STREAM (,STREAM (OPEN ,FILENAME . ,OPTIONS))
     579     . ,BODY))
     580
     581;;; Create code that is body, possibly with a lambda wrapped around it to make
     582;;; sure that the forms assigned to the listed variables only get evaluated once.
     583(DEFMACRO ONCE-ONLY (VARIABLE-LIST &BODY BODY)
     584  (DOLIST (VARIABLE VARIABLE-LIST)
     585    (IF (NOT (SYMBOLP VARIABLE))
     586        (FERROR NIL "~S is not a variable" VARIABLE)))
     587  (LET ((BIND-VARS (GENSYM))
     588        (BIND-VALS (GENSYM))
     589        (TEM (GENSYM)))
     590    `(LET ((,BIND-VARS NIL)
     591           (,BIND-VALS NIL))
     592       (LET ((RESULT ((LAMBDA ,VARIABLE-LIST . ,BODY)
     593                      . ,(LOOP FOR VARIABLE IN VARIABLE-LIST
     594                               COLLECT `(IF (OR (ATOM ,VARIABLE)
     595                                                (EQ (CAR ,VARIABLE) 'QUOTE))
     596                                            ,VARIABLE
     597                                            (LET ((,TEM (GENSYM)))
     598                                              (PUSH ,TEM ,BIND-VARS)
     599                                              (PUSH ,VARIABLE ,BIND-VALS)
     600                                              ,TEM))))))
     601         (IF (NULL ,BIND-VARS)
     602             RESULT
     603             `((LAMBDA ,,BIND-VARS ,RESULT) . ,,BIND-VALS))))))
     604
     605;Bind NAME-TO-BIND to a cleanup-list,
     606;and on exit do any cleanup-actions stored in the list.
     607;The body can pass NAME-TO-BIND to various allocation functions,
     608;which will attach cleanups to the car of the cleanup-list
     609;so that the objects they allocate will be returned.
     610;A cleanup is just a list of a function and (evaluated) args.
     611(DEFMACRO WITH-CLEANUP-LIST (NAME-TO-BIND &BODY BODY)
     612  `(LET ((,NAME-TO-BIND (LIST NIL)))
     613     (UNWIND-PROTECT (PROGN . ,BODY)
     614                     (MAPC 'FUNCALL (CAR ,NAME-TO-BIND)))))
     615
     616;Move a specific cleanup action from one cleanup-list to another, atomically.
     617(DEFUN MOVE-CLEANUP (CLEANUP FROM-CLEANUP-LIST TO-CLEANUP-LIST)
     618  (WITHOUT-INTERRUPTS
     619    (SETF (CAR FROM-CLEANUP-LIST) (DELQ CLEANUP (CAR FROM-CLEANUP-LIST)))
     620    (PUSH CLEANUP (CAR TO-CLEANUP-LIST))))
     621
     622;Replace one cleanup with another, atomically.
     623(DEFUN REPLACE-CLEANUP (OLD-CLEANUP NEW-CLEANUP CLEANUP-LIST)
     624  (WITHOUT-INTERRUPTS
     625    (SETF (CAR CLEANUP-LIST) (CONS NEW-CLEANUP (DELQ OLD-CLEANUP (CAR CLEANUP-LIST))))))
  • trunk/lisp/lispm2/login.lisp

    r249 r278  
    1 ; LISP Machine Package for Logging In and Out.          DLW 11/13/77 -*-LISP-*-
     1; -*-Package:SYSTEM-INTERNALS; Mode:LISP-*-
     2; LISP Machine Package for Logging In and Out.          DLW 11/13/77
    23;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
    34
     
    78(DEFVAR LOGOUT-LIST NIL)
    89
    9 ;; MACHINE-OR-T is the machine to get the init and fix files from (default = AI)
    10 ;; or T meaning dont do any of that hair.
    11 (DEFUN LOGIN (USER-NAME &OPTIONAL (MACHINE-OR-T "AI"))
    12   (LOGOUT)
    13   (OR (EQ MACHINE-OR-T T)
    14       (SETQ MACHINE-OR-T (STRING MACHINE-OR-T)))
    15   (SETQ USER-ID (STRING-TRIM '(#\SP) (STRING USER-NAME)))
    16   (FS:FILE-HOST-USER-ID USER-ID (IF (EQ MACHINE-OR-T T) FS:FILE-DEFAULT-HOST MACHINE-OR-T))
    17   (FS:FILE-LOGIN T)
    18   (COND ((NOT (EQ MACHINE-OR-T T))
    19          (SETQ MACHINE-OR-T (STRING MACHINE-OR-T)) ;canonicalize for ASSOC's in FS:FILE...
    20          (LET ((FILE-NAME (FS:FILE-PARSE-NAME (FS:FILE-USER-ID-HSNAME MACHINE-OR-T T)
    21                                               MACHINE-OR-T)))
    22            (FUNCALL FILE-NAME ':INIT-FILE "LISPM")
    23            (LOAD FILE-NAME "USER" T))))
     10;History so we can tell who has had their little paws into a saved band.
     11;List of elements (user host cadr time)
     12(DEFVAR LOGIN-HISTORY NIL)
     13
     14(DEFUN LOGIN (USER-NAME &OPTIONAL (HOST ASSOCIATED-MACHINE) (LOAD-INIT-FILE-P T))
     15  ;; Do this so LOGIN init list has the correct enviroment.
     16  (DECLARE (SPECIAL USER-ID HOST LOAD-INIT-FILE-P))
     17  (LET ((WIN-P NIL))
     18    (UNWIND-PROTECT
     19      (PROGN
     20        (LOGOUT)
     21        (AND (EQ HOST T)                        ;For compatibility
     22             (SETQ HOST ASSOCIATED-MACHINE LOAD-INIT-FILE-P NIL))
     23        (SETQ USER-ID (STRING-TRIM '(#\SP) (STRING USER-NAME)))
     24        (SETQ HOST (FS:GET-PATHNAME-HOST HOST))
     25        (SETQ FS:USER-LOGIN-MACHINE HOST)
     26        (INITIALIZATIONS 'LOGIN-INITIALIZATION-LIST)
     27        (RESET-INITIALIZATIONS 'LOGOUT-INITIALIZATION-LIST)
     28        (PUSH (LIST USER-ID HOST
     29                    (AND (BOUNDP 'LOCAL-PRETTY-HOST-NAME) LOCAL-PRETTY-HOST-NAME)
     30                    (AND (FBOUNDP 'TIME:PRINT-CURRENT-TIME) (TIME:PRINT-CURRENT-TIME NIL)))
     31              LOGIN-HISTORY)
     32        ;; This is an attempt to prevent losers from losing and writing on the LISPM directory
     33        (FS:SET-DEFAULT-PATHNAME (FS:USER-HOMEDIR) FS:*DEFAULT-PATHNAME-DEFAULTS*)
     34        (FS:SET-DEFAULT-PATHNAME (FS:USER-HOMEDIR) FS:LOAD-PATHNAME-DEFAULTS)
     35        (AND LOAD-INIT-FILE-P
     36             (LOAD (FS:INIT-FILE-PATHNAME "LISPM" HOST T) "USER" T T))
     37        (SETQ WIN-P T))
     38      (IF (NOT WIN-P)
     39          ;; If user aborts during login, particularly if he types Abort when
     40          ;; being asked for his password, log him out so he can try again.
     41          (LOGOUT))))
    2442  T)
    2543
    2644(DEFUN LOGOUT ()
    2745  (MAPC 'EVAL LOGOUT-LIST)
     46  (INITIALIZATIONS 'LOGOUT-INITIALIZATION-LIST)
     47  (RESET-INITIALIZATIONS 'LOGIN-INITIALIZATION-LIST)
     48  ;; Do this last so that the initializations won't ask you to login.
    2849  (SETQ USER-ID ""
    29         FS:USER-HSNAMES NIL FS:USER-PERSONAL-NAME "" FS:USER-GROUP-AFFILIATION #/-
    30         FS:USER-LOGIN-MACHINE "AI")
     50        FS:USER-HOMEDIRS NIL
     51        FS:USER-PERSONAL-NAME ""
     52        FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST ""
     53        FS:USER-GROUP-AFFILIATION #/-
     54        FS:USER-LOGIN-MACHINE ASSOCIATED-MACHINE)
    3155  (SETQ LOGOUT-LIST NIL)
    32   (FS:FILE-LOGIN NIL)
    3356  T)
    3457
    35 (DEFUN LOGIN-EVAL (X)  ;Value returned by such a form is how to undo it
    36     (PUSH X LOGOUT-LIST))
     58(DEFUN LOGIN-EVAL (X)   ;Value returned by such a form is how to undo it
     59  (PUSH X LOGOUT-LIST))
    3760
    3861(DEFUN LOGIN-SETQ (&QUOTE &REST L)  ;Undoing SETQ
    39     (DO L L (CDDR L) (NULL L)
     62  (DO L L (CDDR L) (NULL L)
    4063      (COND ((BOUNDP (CAR L))
    4164             (PUSH `(SETQ ,(CAR L) ',(SYMEVAL (CAR L))) LOGOUT-LIST))
     
    4669;It would be nice if there were FUNDEFINE.
    4770(DEFUN LOGIN-FDEFINE (FUNCTION-NAME DEFINITION)  ;Undoing FDEFINE
    48     (AND (FDEFINEDP FUNCTION-NAME)
    49         (PUSH `(FDEFINE ',FUNCTION-NAME ',(FDEFINITION FUNCTION-NAME)) LOGOUT-LIST))
    50     (FDEFINE FUNCTION-NAME DEFINITION))
     71  (AND (FDEFINEDP FUNCTION-NAME)
     72      (PUSH `(FDEFINE ',FUNCTION-NAME ',(FDEFINITION FUNCTION-NAME)) LOGOUT-LIST))
     73  (FDEFINE FUNCTION-NAME DEFINITION))
  • trunk/lisp/lispm2/loop.lisp

    r245 r278  
    1 ;-*- Mode:LISP; Package:System-Internals; Base:8; Lowercase:T -*-
     1;;;   LOOP  -*- Mode:LISP; Package:System-Internals; Base:8; Lowercase:T -*-
     2;;;   **********************************************************************
     3;;;   ****** Universal ******** LOOP Iteration Macro ***********************
     4;;;   **********************************************************************
     5;;;   **** (C) COPYRIGHT 1980, 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
     6;;;   ******** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *************
     7;;;   **********************************************************************
    28
    39;The master copy of this file is on ML:LSB1;LOOP >
    410;The current Lisp machine copy is on AI:LISPM2;LOOP >
    511;The FASL and QFASL should also be accessible from LIBLSP; on all machines.
     12;Duplicate source is usually also maintained on MC:LSB1;LOOP >
     13
     14; **********************************************************************
     15; **********************************************************************
     16; ********************* NOTE BLOODY GODDAMNED WELL *********************
     17; **********************************************************************
     18; ******* INCREMENTAL COMPILING OF THIS WILL GENERATE WRONG CODE *******
     19; ******* UNLESS YOU FIRST DO THE 'FEATURE' STUFF BELOW STARTING *******
     20; ******* WITH EVAL-WHEN.  IF YOU FORGET THIS YOU WILL REGRET IT. *****
     21; **********************************************************************
     22; **********************************************************************
    623
    724; Bugs/complaints/suggestions/solicitations-for-documentation to BUG-LOOP
     
    1027;;;; LOOP Iteration Macro
    1128
     29; Bootstrap up our basic primitive environment.
     30; This includes backquote, sharpsign, defmacro, maybe let.
     31
     32(eval-when (eval compile)
     33  (cond ((status feature Multics)
     34           (setq macros t) ; enable defmacro hackery
     35           (defun include-for-multics macro (x)
     36             (cons '%include (cdr x))))
     37        ('t (defun include-for-multics macro (x) ()))))
     38
     39(include-for-multics lisp_prelude)
     40(include-for-multics lisp_dcls)
     41
     42; Now set up the readtime conditionalization environment.
     43; This won't work in any compiler that reads the whole file before compiling anything.
     44(eval-when (eval compile)
     45    ; Set up losing compatibility crock to get around (status feature)
     46    ; lossage in NIL.
     47    #+NIL (progn
     48             (defmacro loop-featurep (f)
     49               `(featurep ',f target-features))
     50             (defmacro loop-nofeaturep (f)
     51               `(nofeaturep ',f target-features))
     52             (defmacro loop-set-feature (f)
     53               `(set-feature ',f target-features))
     54             (defmacro loop-set-nofeature (f)
     55               `(set-nofeature ',f target-features))
     56             )
     57    #-NIL (progn
     58             (defmacro loop-featurep (f)
     59               `(status feature ,f))
     60             (defmacro loop-nofeaturep (f)
     61               ; Multics doesn't have (status nofeature)...
     62               `(not (status feature ,f)))
     63             (defmacro loop-set-feature (f)
     64               `(sstatus feature ,f))
     65             (defmacro loop-set-nofeature (f)
     66               ; Does this work on Multics???  I think not but we don't use.
     67               `(sstatus nofeature ,f))
     68             )
     69    (cond ((loop-featurep NALOOP)
     70             ; NALOOP means we are compiling a LOOP which will produce
     71             ; code for real NIL but it won't be running in a real NIL.
     72             ; I guess i sort of assume that this implies we are being
     73             ; compiled in, and will run in, PDP10 Maclisp.
     74             ; Almost all of LOOP conditionalization is oriented towards
     75             ; the code generation.  Thus, if NALOOP, we will pretend
     76             ; we are aiming at a NIL.  This is OK since most of the
     77             ; Maclisp/NIL stuff is compatible anyway.
     78             (loop-set-feature For-NIL)
     79             (loop-set-nofeature For-Maclisp)
     80             (loop-set-nofeature For-PDP10)
     81             (loop-set-nofeature For-PDP-10)
     82             (loop-set-feature Run-in-Maclisp)
     83             (loop-set-feature Run-on-PDP10)
     84             (loop-set-nofeature Run-on-PDP-10))
     85          ((and (loop-featurep Maclisp) (loop-nofeaturep For-NIL))
     86             (loop-set-feature For-Maclisp)
     87             (loop-set-feature Run-In-Maclisp)
     88             (cond ((loop-nofeaturep Multics)
     89                      (loop-set-feature For-PDP10)
     90                      (loop-set-feature PDP10)
     91                      (loop-set-feature Run-on-PDP10))))
     92          ((loop-featurep NIL)
     93             (loop-set-nofeature PDP10)
     94             (loop-set-nofeature PDP-10)
     95             (loop-set-nofeature Run-on-PDP10)
     96             (loop-set-nofeature For-PDP10)
     97             (loop-set-nofeature Run-on-PDP-10)
     98             (loop-set-nofeature For-PDP-10)))
     99    (cond ((or (loop-featurep Lispm) (loop-featurep For-PDP10))
     100             (loop-set-feature Hairy-Collection))
     101          ('t (loop-set-nofeature Hairy-Collection)))
     102    (cond ((or (loop-featurep For-NIL) (loop-featurep For-PDP10))
     103             (loop-set-feature System-Destructuring))
     104          ('t (loop-set-nofeature System-Destructuring)))
     105    (cond ((loop-nofeaturep For-Maclisp)
     106             (loop-set-feature Named-PROGs))
     107          ('t (loop-set-nofeature Named-PROGs)))
     108    ())
     109
     110; Following isn't needed on Lispm, as loop is installed there (ie, these
     111; symbols are already in GLOBAL).
     112#-(or Lispm Run-in-Maclisp)
     113(globalize "LOOP"                               ; Major macro
     114           "LOOP-FINISH"                        ; Handy macro
     115           "DEFINE-LOOP-MACRO"
     116           "DEFINE-LOOP-PATH"                   ; for users to define paths
     117           "DEFINE-LOOP-SEQUENCE-PATH"          ; this too
     118           )
     119
     120#-(or Lispm Multics)
     121(herald LOOP /716)
     122
     123
     124
    12125; Set up some LISPM compatibility macros etc.
    13126;     We use sharpsign to conditionalize code;  this means that the
    14 ; conditionalized code must at least be able to READ in both Maclisp
    15 ; and on the Lisp Machine.
    16 ;    For Maclisp, we also define a double-quote readmacro character;
    17 ; this will turn into a QUOTED symbol, so don't use it inside constant
    18 ; list structure!
    19 ;    This code assumes the presence of FERROR and hence FORMAT.
    20 
    21 
    22 ; Piece of Shit
    23 (declare
    24     (cond ((status feature Multics)
    25              (load ">udd>Mathlab>Lisp>environment.lisp"))
    26           ((status feature Maclisp)
    27            (cond ((status macro /#)
    28                     (princ '|/
    29 ; No more need to load /"#/" into the compiler.|
    30                            msgfiles))
    31                  (t (load '((lisp) sharpm)))))))
     127; conditionalized code must at least be able to READ in all implementations.
     128; That means that you cannot use such things as 1.0s0 (small-flonum).
     129;    We also assume the presence of a DEFMACRO.  Assumptions as to how
     130; it decides whether the definition should appear in the fasl file are
     131; carefully circumvented by judicious use of EVAL-WHEN, and with the
     132; use of the following:
     133
     134#-Run-In-Maclisp
     135(defmacro loop-macro-progn (&rest forms)
     136    `(progn 'compile ,@forms))
     137#+Run-In-Maclisp
     138(eval-when (eval compile)
     139    (defmacro loop-macro-progn (&rest forms)
     140        `(eval-when (eval compile) ,@forms)))
     141
    32142
    33143; Hack up the stuff for data-types.  DATA-TYPE? will always be a macro
    34144; so that it will not require the data-type package at run time if
    35145; all uses of the other routines are conditionalized upon that value.
     146(eval-when (eval compile)
     147    ; Crock for DATA-TYPE? derives from DTDCL.  We just copy it rather
     148    ; than load it in, which requires knowing where it comes from (sigh).
     149    #+Run-In-Maclisp
     150      (or (get 'data-type? 'macro)
     151          (defmacro data-type? (x) `(get ,x ':data-type)))
     152    #-Run-In-Maclisp
     153      (or (fboundp 'data-type?)
     154          (defmacro data-type? (frob)
     155             (let ((foo (gensym)) (bar (gensym)))
     156                `((lambda (,foo)
     157                    (or (get ,foo ':data-type)
     158                        (multiple-value-bind (,foo ,bar)
     159                                             (intern-soft (get-pname ,foo) "")
     160                          (and ,bar (get ,foo ':data-type)))))
     161                  ,frob))))
     162    (*lexpr variable-declarations)
     163    ; Multics defaults to free-functional-variable since it is declared
     164    ; special & used as function before it is defined:
     165    (*expr loop-when-it-variable)
     166    (*expr initial-value primitive-type)
     167  #-Lispm
     168    (muzzled t) ; I know what i'm doing
     169    )
     170
     171#+Run-on-PDP10
     172(declare (mapex ())
     173         (genprefix loop/|-)
     174         (special squid)
     175       #+(and Run-in-Maclisp For-NIL) ; patch it up
     176         (*expr stringp vectorp vref vector-length)
     177         )
     178
     179#-Run-on-PDP10
    36180(declare
    37     (or #M (get 'data-type? 'macro) #Q (fboundp 'data-type?)
    38         (defmacro data-type? (x) `(get ,x ':data-type)))
    39     (*lexpr variable-declarations)
    40     (*expr initial-value form-wrapper))
    41 
    42 
    43 ;Loop macro
    44 #Q (globalize 'loop 'loop-finish 'loop-add-path 'loop-tequal)
    45 
    46 ;Another Piece of Shit
    47 #M (progn 'compile
    48       (declare (*lexpr ferror))
    49       (or (getl 'ferror '(macro lsubr autoload))
    50           (not (get 'format 'autoload))
    51           (putprop 'ferror (get 'format 'autoload) 'autoload))
    52       ; LEXPR-FUNCALL is now in pdp-10 Maclisp.  However we must
    53       ; keep this around for a while until most if not all old lisps
    54       ; dissappear.  Eventually, make it #+Multics.
    55       (eval-when (eval compile)
    56           (defun lexpr-funcall macro (x)
    57                `(apply ,(cadr x) (list* . ,(cddr x)))))
    58       (mapc '(lambda (x)
    59                 (or (getl x '(macro subr lsubr autoload))
    60                     (putprop x #+Multics
    61                                   ">udd>Mathlab>LSB>data-type_declarations"
    62                                #-Multics '((dsk lsb) dtdcl)
    63                              'autoload)))
    64             '(data-type? variable-declarations initial-value)))
    65 
    66 
    67 
     181  #+Lispm (setq open-code-map-switch t)
     182  #-Lispm (mapex t)
     183  #-Lispm (genprefix loop-iteration/|-))
     184
     185#+Run-on-PDP10
     186(mapc '(lambda (x)
     187           (or (getl x '(subr lsubr fsubr macro fexpr expr autoload))
     188               ; This dtdcl will sort of work for NIL code generation,
     189               ; if declarations will ignored.
     190               (putprop x '((lisp) dtdcl fasl) 'autoload)))
     191      '(data-type? variable-declarations initial-value primitive-type))
     192
     193
     194; String hacks.
     195#+Run-on-PDP10
     196(eval-when (compile)
     197    ; Note this hack used when compiled only.
     198    (setsyntax #/" 'macro
     199               '(lambda ()
     200                   (do ((ch (tyi) (tyi)) (l () (cons ch l)))
     201                       ((= ch #/")
     202                        (list squid (list 'quote (implode (nreverse l)))))
     203                     (and (= ch #//) (setq ch (tyi)))))))
     204
     205
     206; LEXPR-FUNCALL
    68207#+Multics
    69   (progn 'compile
    70      (defun loop-displace (x y)
    71         ((lambda (val) (rplaca x (car val)) (rplacd x (cdr val)) x)
    72          (cond ((atom y) (list 'progn y)) (t y))))
    73      (or (getl 'displace '(expr fexpr macro autoload subr lsubr fsubr))
    74          ((lambda (pl) (putprop 'displace (cadr pl) (car pl)))
    75           (getl 'loop-displace '(subr expr)))))
    76 
    77 
    78 (defmacro loop-finish ()
    79     '(go end-loop))
    80 
    81 #M
    82 (defun neq macro (x) `(not (eq . ,(cdr x))))
    83 
     208(loop-macro-progn
     209    (defun lexpr-funcall macro (x)
     210           (list 'apply (cadr x) (cons 'list* (cddr x)))))
     211
     212(loop-macro-progn
     213 (defmacro loop-copylist* (l)
     214    #+Lispm `(copylist* ,l)
     215    #-Lispm `(append ,l ())))
     216
     217
     218
     219;;;; Random Macros
     220
     221; Error macro.  Note that in the PDP10 version we call LOOP-DIE rather
     222; than ERROR -- there are so many occurences of it in this source that
     223; it is worth breaking off that function, since calling the lsubr ERROR
     224; takes more inline code.
     225(loop-macro-progn
     226 (defmacro loop-simple-error (unquoted-message &optional (datum () datump))
     227    #+(and Run-In-Maclisp (not Multics))
     228      (progn (cond ((symbolp unquoted-message))
     229                   ((and (not (atom unquoted-message))
     230                         compiler-state
     231                         (eq (car unquoted-message) squid)
     232                         (not (atom (setq unquoted-message
     233                                          (cadr unquoted-message))))
     234                         (eq (car unquoted-message) 'quote)
     235                         (symbolp (cadr unquoted-message)))
     236                      (setq unquoted-message (cadr unquoted-message)))
     237                   ('t (error '|Uloze -- LOOP-SIMPLE-ERROR|
     238                              (list 'loop-simple-error
     239                                    unquoted-message datum))))
     240             (cond (datump `(loop-die ',unquoted-message ,datum))
     241                   ('t `(error ',unquoted-message))))
     242    #+Multics
     243      (progn (or (memq (typep unquoted-message) '(string symbol))
     244                 (error '|Uloze -- | (list 'loop-simple-error
     245                                           unquoted-message datum)))
     246             `(error ,(catenate "lisp:  " unquoted-message
     247                                (if datump " -- " ""))
     248                     . ,(and datump (list datum))))
     249    #-Run-In-Maclisp
     250      `(ferror () ,(if datump (string-append "~S " unquoted-message)
     251                       unquoted-message)
     252               . ,(and datump (list datum)))))
     253
     254
     255#+(and Run-in-Maclisp (not Multics))
     256(defun loop-die (arg1 arg2)
     257    (error arg1 arg2))
     258
     259
     260; This is a KLUDGE.  But it apparently saves an average of two inline
     261; instructions per call in the PDP10 version...  The ACS prop is
     262; fairly gratuitous.
     263
     264#+Run-on-PDP10
     265(progn 'compile
     266   (lap-a-list
     267     '((lap loop-pop-source subr)
     268       (args loop-pop-source (() . 0))
     269           (hlrz a @ (special loop-source-code))
     270           (hrrz b @ (special loop-source-code))
     271           (movem b (special loop-source-code))
     272           (popj p)
     273       nil))
     274   (eval-when (compile)
     275       (defprop loop-pop-source 2 acs)
     276       ))
     277
     278#-Run-on-PDP10
     279(loop-macro-progn
     280 (defmacro loop-pop-source () '(pop loop-source-code)))
     281
     282
     283
     284;;;; Variable defining macros
     285
     286; Note:  multics lcp has some misfeature whereby DECLARE and
     287; (EVAL-WHEN (COMPILE) ...) don't get hacked properly inside of
     288; more than one level of (PROGN 'COMPILE ...).  Thus we hack around
     289; DEFVAR and DEFIVAR to bypass this lossage.
     290
     291#+Multics
     292(loop-macro-progn
     293 (defmacro defvar (name &optional (init nil initp) documentation
     294                   &aux (dclform `(and (status feature compiler)
     295                                       (special ,name))))
     296    ; For some obscure reason, (DECLARE ...) doesn't take effect
     297    ; within 2 (PROGN 'COMPILE ...)s.  But (EVAL-WHEN (COMPILE) ...) does.
     298    (apply 'special (list name))
     299    (cond ((not initp) dclform)
     300          (t `(progn 'compile
     301                     ,dclform
     302                     (or (boundp ',name) (setq ,name ,init)))))))
     303
     304(loop-macro-progn
     305 ; A DEFVAR alternative - "DEFine Internal VARiable".
     306 (defmacro defivar (name &optional (init () initp))
     307    #-Run-in-Maclisp `(defvar ,name ,@(and initp `(,init)))
     308    #+Run-in-Maclisp (progn
     309                        (apply 'special (list name))
     310                        (cond (initp `(or (boundp ',name)
     311                                          (setq ,name ,init)))
     312                              ('t '(progn 'compile))))))
     313
     314#-Lispm
     315(loop-macro-progn
     316  (defmacro defconst (name init &optional documentation)
     317     (and (status feature #+Multics Compiler #-Multics complr)
     318          (apply 'special (list name)))
     319     `(setq ,name ,init)))
     320
     321
     322
     323
     324;;;; Setq Hackery
     325
     326; Note:  LOOP-MAKE-PSETQ is NOT flushable depending on the existence
     327; of PSETQ, unless PSETQ handles destructuring.  Even then it is
     328; preferable for the code LOOP produces to not contain intermediate
     329; macros, especially in the PDP10 version.
    84330
    85331(defun loop-make-psetq (frobs)
    86     (loop-make-setq
    87        (car frobs)
    88        (cond ((null (cddr frobs)) (cadr frobs))
    89              (t `(prog1 ,(cadr frobs) ,(loop-make-psetq (cddr frobs)))))))
    90 
    91 (defmacro loop-psetq (&rest frobs)
    92     (loop-make-psetq frobs))
    93 
    94 #M
    95 (or (get 'psetq 'macro)
    96     (putprop 'psetq (get 'loop-psetq 'macro) 'macro))
    97 
    98 #+(and Maclisp (not Multics))
    99   (eval-when (eval compile)
    100        ; Define a default doublequote macro.  Note it uppercasifies
    101        ; and quotes the symbol.  DON'T USE IT INSIDE CONSTANT STRUCTURE!
    102        (setsyntax '/" 'macro
    103           '(lambda ()
    104               (do ((ch (tyi) (tyi)) (l nil (cons ch l)))
    105                   ((= ch #/") (list 'quote (implode (nreverse l))))
    106                 (cond ((and (> ch 96.) (< ch 123.)) (setq ch (- ch 32.)))
    107                       ((= ch #//) (setq ch (tyi))))))))
    108 
    109 
    110 
    111 (defvar loop-keyword-alist                      ;clause introducers
    112      '( (initially loop-do-initially)
     332    (and frobs
     333         (loop-make-setq
     334            (list (car frobs)
     335                  (if (null (cddr frobs)) (cadr frobs)
     336                      `(prog1 ,(cadr frobs)
     337                              ,(loop-make-psetq (cddr frobs))))))))
     338
     339#-System-Destructuring
     340(progn 'compile
     341
     342(defvar si:loop-use-system-destructuring?
     343    ())
     344
     345(defivar loop-desetq-temporary)
     346
     347; Do we want this???  It is, admittedly, useful...
     348;(defmacro loop-desetq (&rest x)
     349;  (let ((loop-desetq-temporary ()))
     350;     (let ((setq-form (loop-make-desetq x)))
     351;       (if loop-desetq-temporary
     352;           `((lambda (,loop-desetq-temporary) ,setq-form) ())
     353;           setq-form))))
     354
     355
     356(defun loop-make-desetq (x)
     357   (if si:loop-use-system-destructuring?
     358       (cons (do ((l x (cddr l))) ((null l) 'setq)
     359               (or (atom (car l)) (return 'desetq)))
     360             x)
     361       (do ((x x (cddr x)) (r ()) (var) (val))
     362           ((null x) (and r (cons 'setq r)))
     363         (setq var (car x) val (cadr x))
     364         (cond ((and (not (atom var))
     365                     (not (atom val))
     366                     (not (and (memq (car val)
     367                                     '(car cdr cadr cddr caar cdar))
     368                               (atom (cadr val)))))
     369                  (setq x (list* (or loop-desetq-temporary
     370                                     (setq loop-desetq-temporary (gensym)))
     371                                 val var loop-desetq-temporary (cddr x)))))
     372         (setq r (nconc r (loop-desetq-internal (car x) (cadr x)))))))
     373
     374(defun loop-desetq-internal (var val)
     375  (cond ((null var) ())
     376        ((atom var) (list var val))
     377        ('t (nconc (loop-desetq-internal (car var) `(car ,val))
     378                   (loop-desetq-internal (cdr var) `(cdr ,val))))))
     379); End desetq hackery for #-System-Destructuring
     380
     381
     382(defun loop-make-setq (pairs)
     383    (and pairs
     384         #-System-Destructuring
     385           (loop-make-desetq pairs)
     386         #+System-Destructuring
     387           (cons (do ((l pairs (cddr l))) ((null l) 'setq)
     388                   (or (and (car l) (atom (car l))) (return 'desetq)))
     389                 pairs)))
     390
     391
     392
     393(defconst loop-keyword-alist                    ;clause introducers
     394     '(
     395      #+Named-PROGs
     396        (named loop-do-named)
     397        (initially loop-do-initially)
    113398        (finally loop-do-finally)
     399        (nodeclare loop-nodeclare)
    114400        (do loop-do-do)
    115401        (doing loop-do-do)
     
    127413        (maximize loop-do-collect max)
    128414        (minimize loop-do-collect min)
    129         (always loop-do-always t)
    130         (never loop-do-always nil)
     415        (always loop-do-always or)
     416        (never loop-do-always and)
    131417        (thereis loop-do-thereis)
    132         (while loop-do-while or)
    133         (until loop-do-while and)
    134         (when loop-do-when nil)
     418        (while loop-do-while or while)
     419        (until loop-do-while and until)
     420        (when loop-do-when ())
     421        (if loop-do-when ())
    135422        (unless loop-do-when t)
    136         (with loop-do-with)
    137         (for loop-do-for)
    138         (as loop-do-for)))
    139 
    140 (defvar loop-for-keyword-alist                  ;Types of FOR
     423        (with loop-do-with)))
     424
     425
     426(defconst loop-iteration-keyword-alist
     427    `((for loop-do-for)
     428      (as loop-do-for)
     429      (repeat loop-do-repeat)))
     430
     431
     432(defconst loop-for-keyword-alist                        ;Types of FOR
    141433     '( (= loop-for-equals)
    142         (in loop-for-in)
    143         (on loop-for-on)
    144         (from loop-for-arithmetic nil)
    145         (downfrom loop-for-arithmetic down)
    146         (upfrom loop-for-arithmetic up)
     434        (first loop-for-first)
     435        (in loop-list-stepper car)
     436        (on loop-list-stepper ())
     437        (from loop-for-arithmetic from)
     438        (downfrom loop-for-arithmetic downfrom)
     439        (upfrom loop-for-arithmetic upfrom)
     440        (below loop-for-arithmetic below)
     441        (to loop-for-arithmetic to)
    147442        (being loop-for-being)))
    148443
    149 (defvar loop-path-keyword-alist nil)            ; PATH functions
    150 (defvar loop-variables)                         ;Variables local to the loop
    151 (defvar loop-declarations)                      ; Local dcls for above
    152 (defvar loop-variable-stack)
    153 (defvar loop-declaration-stack)
    154 (defvar loop-prologue)                          ;List of forms in reverse order
    155 (defvar loop-body)                              ;..
    156 (defvar loop-after-body)                        ;.. for FOR steppers
    157 (defvar loop-epilogue)                          ;..
    158 (defvar loop-after-epilogue)                    ;So COLLECT's RETURN comes after FINALLY
    159 (defvar loop-conditionals)                      ;If non-NIL, condition for next form in body
     444#+Named-PROGs
     445(defivar loop-prog-names)
     446
     447(defvar loop-path-keyword-alist ())             ; PATH functions
     448(defivar loop-named-variables)                  ; see SI:LOOP-NAMED-VARIABLE
     449(defivar loop-collection-crocks)                ; see LOOP-DO-COLLECT etc
     450(defivar loop-variables)                        ;Variables local to the loop
     451(defivar loop-declarations)                     ; Local dcls for above
     452(defivar loop-nodeclare)                        ; but don't declare these
     453(defivar loop-variable-stack)
     454(defivar loop-declaration-stack)
     455#-System-Destructuring
     456(defivar loop-desetq-crocks)                    ; see loop-make-variable
     457#-System-Destructuring
     458(defivar loop-desetq-stack)                     ; and loop-translate-1
     459(defivar loop-prologue)                         ;List of forms in reverse order
     460(defivar loop-before-loop)
     461(defivar loop-body)                             ;..
     462(defivar loop-after-body)                       ;.. for FOR steppers
     463(defivar loop-epilogue)                         ;..
     464(defivar loop-after-epilogue)                   ;So COLLECT's RETURN comes after FINALLY
     465(defivar loop-conditionals)                     ;If non-NIL, condition for next form in body
    160466  ;The above is actually a list of entries of the form
    161   ;(condition forms...)
     467  ;(cond (condition forms...))
    162468  ;When it is output, each successive condition will get
    163469  ;nested inside the previous one, but it is not built up
    164470  ;that way because you wouldn't be able to tell a WHEN-generated
    165471  ;COND from a user-generated COND.
    166 
    167 (defvar loop-when-it-variable)                  ;See LOOP-DO-WHEN
    168 (defvar loop-collect-cruft)                     ; for multiple COLLECTs (etc)
    169 (defvar loop-source-code)
    170 (defvar loop-attachment-transformer             ; see attachment definition
    171         (cond ((status feature lms) 'progn) (t nil)))
    172 
    173 
    174 #-Multics
    175 (defun loop-lookup-keyword macro (x)
    176 
    177     #Q `(ass #'string-equal . ,(cdr x))
    178     #M `(assq . ,(cdr x)))
     472  ;When ELSE is used, each cond can get a second clause
     473
     474(defivar loop-when-it-variable)                 ;See LOOP-DO-WHEN
     475(defivar loop-never-stepped-variable)           ; see LOOP-FOR-FIRST
     476(defivar loop-emitted-body?)                    ; see LOOP-EMIT-BODY,
     477                                                ; and LOOP-DO-FOR
     478(defivar loop-iteration-variables)              ; LOOP-MAKE-ITERATION-VARIABLE
     479(defivar loop-iteration-variablep)              ; ditto
     480(defivar loop-collect-cruft)                    ; for multiple COLLECTs (etc)
     481(defivar loop-source-code)
     482(defvar loop-duplicate-code ())  ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC
     483
     484
     485
     486;;;; Token Hackery
     487
     488;Compare two "tokens".  The first is the frob out of LOOP-SOURCE-CODE,
     489;the second a symbol to check against.
     490
     491; Consider having case-independent comparison on Multics.
    179492#+Multics
    180 (defun loop-lookup-keyword (kwd alist)
    181     (and (symbolp kwd)
    182          (do ((l alist (cdr l))) ((null l) nil)
    183              (and (samepnamep kwd (caar l)) (return (car l))))))
    184 
    185 
    186 (defun loop-add-keyword (cruft alist-name)
    187     (let ((val (symeval alist-name)) (known?))
    188       (and (setq known? (loop-lookup-keyword (car cruft) val))
    189            (set alist-name (delq known? val)))
    190       (set alist-name (cons cruft val))))
    191 
     493(progn 'compile
     494    (defmacro si:loop-tequal (x1 x2)
     495        `(eq ,x1 ,x2))
     496    (defmacro si:loop-tmember (x l)
     497        `(memq ,x ,l))
     498    (defmacro si:loop-tassoc (x l)
     499        `(assq ,x ,l)))
     500
     501
     502#+Lispm
     503(progn 'compile
     504   (defun si:loop-tequal (x1 x2)
     505        (and (symbolp x1) (string-equal x1 x2)))
     506   (defun si:loop-tassoc (kwd alist)
     507        (and (symbolp kwd) (ass #'string-equal kwd alist)))
     508   (defun si:loop-tmember (kwd list)
     509        (and (symbolp kwd) (mem #'string-equal kwd list))))
     510
     511
     512#+Run-on-PDP10
     513(progn 'compile
     514   #+For-NIL
     515     (defun si:loop-tequal (x1 x2)
     516         (eq x1 x2))
     517   #-For-NIL
     518     (progn 'compile
     519        (eval-when (load compile)
     520           (cond ((status feature complr)
     521                    ; Gross me out!
     522                    (setq macrolist
     523                          (cons '(si:loop-tequal
     524                                    . (lambda (x) (cons 'eq (cdr x))))
     525                                (delq (assq 'si:loop-tequal macrolist)
     526                                      macrolist)))
     527                    (*expr si:loop-tmember si:loop-tassoc))))
     528        (defun si:loop-tequal (x1 x2)
     529           (eq x1 x2)))
     530     (defun si:loop-tmember (kwd list)
     531         (memq kwd list))
     532     (defun si:loop-tassoc (kwd alist)
     533         (assq kwd alist))
     534     )
     535
     536#+(and For-NIL (not Run-in-Maclisp))
     537(progn 'compile
     538  ; STRING-EQUAL only accepts strings.  GET-PNAME can be open-coded
     539  ; however.
     540  (defun si:loop-tequal (kwd1 kwd2)
     541      (and (symbolp kwd1) (string-equal (get-pname kwd1) (get-pname kwd2))))
     542  (defun si:loop-tassoc (kwd alist)
     543    (cond ((symbolp kwd)
     544             (setq kwd (get-pname kwd))
     545             (do ((l alist (cdr l))) ((null l) ())
     546               (and (string-equal kwd (get-pname (caar l)))
     547                    (return (car l)))))))
     548  (defun si:loop-tmember (token list)
     549     (cond ((symbolp token)
     550              (setq token (get-pname token))
     551              (do ((l list (cdr l))) ((null l))
     552                (and (string-equal token (get-pname (car l)))
     553                     (return l)))))))
     554
     555
     556
     557#+(or For-PDP10 For-NIL)
     558(eval-when (eval compile) (setq defmacro-displace-call ()))
    192559
    193560(defmacro define-loop-macro (keyword)
    194561    (or (eq keyword 'loop)
    195         (loop-lookup-keyword keyword loop-keyword-alist)
    196         #-Multics (ferror nil "~s not a loop keyword" keyword)
    197         #+Multics (error "lisp: Not a loop keyword -- " keyword))
    198     `(eval-when (compile load eval)
    199          #Q (fset-carefully ',keyword '(macro . loop-translate))
    200          #+(and Maclisp (not Multics)) (|forget-macromemos/|| ',keyword)
    201          #M (putprop ',keyword 'loop-translate 'macro)))
     562        (si:loop-tassoc keyword loop-keyword-alist)
     563        (loop-simple-error "not a loop keyword - define-loop-macro" keyword))
     564    (subst keyword 'keyword
     565           '(eval-when (compile load eval)
     566              #+(or For-NIL Run-on-PDP10)
     567                (progn (|forget-macromemos/|| 'keyword)
     568                       (|forget-macromemos/|| 'loop))
     569              #-Run-in-Maclisp
     570                (fset-carefully 'keyword '(macro . loop-translate))
     571              #+Run-in-Maclisp
     572                (progn (defprop keyword loop-translate macro))
     573              )))
     574
     575#+(or For-PDP10 For-NIL)
     576(eval-when (eval compile) (setq defmacro-displace-call 't))
    202577
    203578(define-loop-macro loop)
     579
     580#+Run-in-Maclisp
     581(defun (loop-finish macro) (form)
     582    (and (cdr form) (loop-simple-error "Wrong number of args" form))
     583    '(go end-loop))
     584
     585#-Run-in-Maclisp
     586(defmacro loop-finish ()
     587    '(go end-loop))
     588
    204589
    205590(defun loop-translate (x)
    206591    #+(or Lispm Multics) (displace x (loop-translate-1 x))
    207     #+(and Maclisp (not Multics))
    208       (or (macrofetch x) (macromemo x (loop-translate-1 x) (car x))))
     592    #-(or Lispm Multics)
     593      (or (macrofetch x) (macromemo x (loop-translate-1 x) 'loop)))
     594
     595
     596(defun loop-end-testify (list-of-forms)
     597    (if (null list-of-forms) ()
     598        `(and ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
     599                   (car list-of-forms)
     600                   (cons 'or list-of-forms))
     601              (go end-loop))))
     602
     603
     604(defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b
     605                                               lastdiff)
     606    (do ((l1 (nreverse loop-before-loop) (cdr l1))
     607         (l2 (nreverse loop-after-body) (cdr l2)))
     608        ((equal l1 l2)
     609           (setq loop-body (nconc (delq '() l1) (nreverse loop-body))))
     610      (push (car l1) before) (push (car l2) after))
     611    (cond ((not (null loop-duplicate-code))
     612             (setq loop-before-loop (nreverse (delq () before))
     613                   loop-after-body (nreverse (delq () after))))
     614          ('t (setq loop-before-loop () loop-after-body ()
     615                    before (nreverse before) after (nreverse after))
     616              (do ((bb before (cdr bb)) (aa after (cdr aa)))
     617                  ((null aa))
     618                (cond ((not (equal (car aa) (car bb))) (setq lastdiff aa))
     619                      ((not (si:loop-simplep (car aa))) ;Mustn't duplicate
     620                       (return ()))))
     621              (cond (lastdiff  ;Down through lastdiff should be duplicated
     622                     (do () (())
     623                       (and (car before) (push (car before) loop-before-loop))
     624                       (and (car after) (push (car after) loop-after-body))
     625                       (setq before (cdr before) after (cdr after))
     626                       (and (eq after (cdr lastdiff)) (return ())))
     627                     (setq loop-before-loop (nreverse loop-before-loop)
     628                           loop-after-body (nreverse loop-after-body))))
     629              (do ((bb (nreverse before) (cdr bb))
     630                   (aa (nreverse after) (cdr aa)))
     631                  ((null aa))
     632                (setq a (car aa) b (car bb))
     633                (cond ((and (null a) (null b)))
     634                      ((equal a b)
     635                         (loop-output-group groupb groupa)
     636                         (push a loop-body)
     637                         (setq groupb () groupa ()))
     638                      ('t (and a (push a groupa)) (and b (push b groupb)))))
     639              (loop-output-group groupb groupa)))
     640    (and loop-never-stepped-variable
     641         (push `(setq ,loop-never-stepped-variable ()) loop-after-body))
     642    ())
     643
     644
     645(defun loop-output-group (before after)
     646    (and (or after before)
     647         (let ((v (or loop-never-stepped-variable
     648                      (setq loop-never-stepped-variable
     649                            (loop-make-variable (gensym) ''t ())))))
     650            (push (cond ((not before) `(or ,v (progn . ,after)))
     651                        ((not after) `(and ,v (progn . ,before)))
     652                        ('t `(cond (,v . ,before) ('t . ,after))))
     653                  loop-body))))
    209654
    210655
     
    213658  (and (eq (car loop-source-code) 'loop)
    214659       (setq loop-source-code (cdr loop-source-code)))
    215   (do ((loop-variables nil)
    216        (loop-declarations nil)
    217        (loop-variable-stack nil)
    218        (loop-declaration-stack nil)
    219        (loop-prologue nil)
    220        (loop-body nil)
    221        (loop-after-body nil)
    222        (loop-epilogue nil)
    223        (loop-after-epilogue nil)
    224        (loop-conditionals nil)
    225        (loop-when-it-variable nil)
    226        (loop-collect-cruft nil)
     660  (do ((loop-iteration-variables ())
     661       (loop-iteration-variablep ())
     662       (loop-variables ())
     663       (loop-nodeclare ())
     664       (loop-named-variables ())
     665       (loop-declarations ())
     666     #-System-Destructuring
     667       (loop-desetq-crocks ())
     668       (loop-variable-stack ())
     669       (loop-declaration-stack ())
     670     #-System-destructuring
     671       (loop-desetq-stack ())
     672       (loop-prologue ())
     673       (loop-before-loop ())
     674       (loop-body ())
     675       (loop-emitted-body? ())
     676       (loop-after-body ())
     677       (loop-epilogue ())
     678       (loop-after-epilogue ())
     679       (loop-conditionals ())
     680       (loop-when-it-variable ())
     681       (loop-never-stepped-variable ())
     682     #-System-Destructuring
     683       (loop-desetq-temporary ())
     684     #+Named-PROGs
     685       (loop-prog-names ())
     686       (loop-collect-cruft ())
     687       (loop-collection-crocks ())
    227688       (keyword)
    228        (tem))
     689       (tem)
     690       (progvars))
    229691      ((null loop-source-code)
    230692       (and loop-conditionals
    231             #-Multics (ferror nil "~S Hanging conditional in LOOP macro"
    232                               (caar loop-conditionals))
    233             #+Multics (error "lisp:  hanging conditional in loop macro -- "
    234                              (caar loop-conditionals)))
    235        (cond (loop-variables
    236                 (push loop-variables loop-variable-stack)
    237                 (push loop-declarations loop-declaration-stack)))
    238        (setq tem `(prog ()
    239                       ,@(nreverse loop-prologue)
     693            (loop-simple-error "Hanging conditional in loop macro"
     694                               (caadar loop-conditionals)))
     695       (loop-optimize-duplicated-code-etc)
     696       (loop-bind-block)
     697       (setq progvars loop-collection-crocks)
     698     #-System-Destructuring
     699       (and loop-desetq-temporary (push loop-desetq-temporary progvars))
     700       (setq tem `(prog #+Named-PROGs ,.loop-prog-names
     701                        ,progvars
     702                      #+Hairy-Collection
     703                        ,.(do ((l loop-collection-crocks (cddr l))
     704                               (v () (cons `(loop-collect-init
     705                                                ,(cadr l) ,(car l))
     706                                            v)))
     707                              ((null l) v))
     708                      ,.(nreverse loop-prologue)
     709                      ,.loop-before-loop
    240710                   next-loop
    241                       ,@(nreverse loop-body)
    242                       ,@(nreverse loop-after-body)
     711                      ,.loop-body
     712                      ,.loop-after-body
    243713                      (go next-loop)
     714                      ; Multics complr notices when end-loop is not gone
     715                      ; to.  So we put in a dummy go.  This does not generate
     716                      ; extra code, at least in the simple example i tried,
     717                      ; but it does keep it from complaining about unused
     718                      ; go tag.
     719            #+Multics (go end-loop)
    244720                   end-loop
    245                       ,@(nreverse loop-epilogue)
    246                       ,@(nreverse loop-after-epilogue)))
    247        (do ((vars) (dcls)) ((null loop-variable-stack))
    248          (setq vars (pop loop-variable-stack)
    249                dcls (pop loop-declaration-stack))
    250          (and dcls (setq dcls `((declare . ,(nreverse dcls)))))
    251          #+Maclisp
    252            (setq tem `(,@dcls ,tem))
    253          #+Maclisp
    254            (cond ((do ((l vars (cdr l))) ((null l) nil)
    255                     (and (not (atom (car l)))
    256                          (not (atom (caar l)))
    257                          (return t)))
    258                     (setq tem `(let ,(nreverse vars) ,.tem)))
    259                  (t (let ((lambda-vars nil) (lambda-vals nil))
    260                        (do ((l vars (cdr l)) (v)) ((null l))
    261                          (cond ((atom (setq v (car l)))
    262                                   (push v lambda-vars)
    263                                   (push nil lambda-vals))
    264                                (t (push (car v) lambda-vars)
    265                                   (push (cadr v) lambda-vals))))
    266                        (setq tem `((lambda ,(nreverse lambda-vars) ,.tem)
    267                                    ,.(nreverse lambda-vals))))))
    268          #-Maclisp (setq tem `(let ,(nreverse vars) ,@dcls ,tem)))
     721                      ,.(nreverse loop-epilogue)
     722                      ,.(nreverse loop-after-epilogue)))
     723       (do ((vars) (dcls) #-System-Destructuring (crocks))
     724           ((null loop-variable-stack))
     725         (setq vars (car loop-variable-stack)
     726               loop-variable-stack (cdr loop-variable-stack)
     727               dcls (car loop-declaration-stack)
     728               loop-declaration-stack (cdr loop-declaration-stack)
     729               tem (ncons tem))
     730         #-System-Destructuring
     731           (and (setq crocks (pop loop-desetq-stack))
     732                (push (loop-make-desetq crocks) tem))
     733         (and dcls (push (cons 'declare dcls) tem))
     734         (cond ((do ((l vars (cdr l))) ((null l) ())
     735                  (and (not (atom (car l)))
     736                       (not (atom (caar l)))
     737                       (return 't)))
     738                  (setq tem `(let ,(nreverse vars) ,.tem)))
     739               ('t (let ((lambda-vars ()) (lambda-vals ()))
     740                     (do ((l vars (cdr l)) (v)) ((null l))
     741                       (cond ((atom (setq v (car l)))
     742                                (push v lambda-vars)
     743                                (push () lambda-vals))
     744                             ('t (push (car v) lambda-vars)
     745                                 (push (cadr v) lambda-vals))))
     746                     (setq tem `((lambda ,lambda-vars ,.tem)
     747                                 ,.lambda-vals))))))
    269748       tem)
    270     (if (symbolp (setq keyword (pop loop-source-code)))
    271         (if (setq tem (loop-lookup-keyword keyword loop-keyword-alist))
     749    (if (symbolp (setq keyword (loop-pop-source)))
     750        (if (setq tem (si:loop-tassoc keyword loop-keyword-alist))
    272751            (apply (cadr tem) (cddr tem))
    273             #-Multics (ferror nil "~S unknown keyword" keyword)
    274             #+Multics (error "lisp:  unknown keyword in loop macro -- "
    275                              keyword))
    276         #-Multics (ferror nil "~S where keyword expected" keyword)
    277         #+Multics (error "lisp:  loop found object where keyword expected -- "
    278                          keyword))))
     752            (if (setq tem (si:loop-tassoc
     753                             keyword loop-iteration-keyword-alist))
     754                (loop-hack-iteration tem)
     755                (if (si:loop-tmember keyword '(and else))
     756                    ; Alternative is to ignore it, ie let it go around to the
     757                    ; next keyword...
     758                    (loop-simple-error
     759                       "secondary clause misplaced at top level in LOOP macro"
     760                       (list keyword (car loop-source-code)
     761                             (cadr loop-source-code)))
     762                    (loop-simple-error
     763                       "unknown keyword in LOOP macro" keyword))))
     764        (loop-simple-error
     765           "found where keyword expected in LOOP macro" keyword))))
    279766
    280767
     
    283770            (push loop-variables loop-variable-stack)
    284771            (push loop-declarations loop-declaration-stack)
    285             (setq loop-variables nil loop-declarations nil))
    286          (loop-declarations (break barf))))
     772            (setq loop-variables () loop-declarations ())
     773            #-System-Destructuring
     774              (progn (push loop-desetq-crocks loop-desetq-stack)
     775                     (setq loop-desetq-crocks ())))))
    287776
    288777
     
    290779;Get FORM argument to a keyword.  Read up to atom.  PROGNify if necessary.
    291780(defun loop-get-form ()
    292   (do ((forms (list (pop loop-source-code)) (cons (pop loop-source-code) forms))
     781  (do ((forms (ncons (loop-pop-source)) (cons (loop-pop-source) forms))
    293782       (nextform (car loop-source-code) (car loop-source-code)))
    294783      ((atom nextform)
     
    297786
    298787
    299 (defun loop-make-setq (var-or-pattern value)
    300 
    301     (list (if (atom var-or-pattern) 'setq 'desetq) var-or-pattern value))
    302 
    303 
    304 (defun loop-imply-type (expression type
    305                         &aux (frob (and (data-type? type)
    306                                         (form-wrapper type expression))))
    307     (cond ((not (null frob)) frob)
    308       #+(and Maclisp (not Multics))
    309           ((setq frob (assq type '((fixnum . fixnum-identity)
    310                                    (flonum . flonum-identity))))
    311              (list (cdr frob) expression))
    312           (t expression)))
     788(defun loop-typed-arith (substitutable-expression data-type)
     789  #-Lispm
     790    (if (setq data-type (car (si:loop-tmember (if (data-type? data-type)
     791                                                  (primitive-type data-type)
     792                                                  data-type)
     793