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

Update from System 78.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/lisp/lispm/qmisc.lisp

    r229 r283  
    1 ; -*-LISP-*- MACHINE MISCELLANEOUS FUNCTIONS NOT WORTHY OF BEING IN QFCTNS
     1; -*- Package:SYSTEM-INTERNALS; Mode:LISP; Base:8 -*-
     2; MACHINE MISCELLANEOUS FUNCTIONS NOT WORTHY OF BEING IN QFCTNS
    23;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
    34
     
    4445  T)
    4546
    46 (DEFUN ROOM (&OPTIONAL ARG)
    47   (TERPRI)
    48   (COND ((NUMBERP ARG)
    49          (ROOM-PRINT-AREA ARG))
    50         (T
    51           (LET ((FREE-SIZE (ROOM-GET-AREA-LENGTH-USED FREE-AREA))
    52                 (PHYS-SIZE (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE)))
    53             (FORMAT T "Physical memory: ~O (~DK), Free space: ~O (~DK)"
    54                       PHYS-SIZE (// PHYS-SIZE 2000) FREE-SIZE (// FREE-SIZE 2000)))
    55           (MULTIPLE-VALUE-BIND (N-WIRED-PAGES N-FIXED-WIRED-PAGES)
    56               (COUNT-WIRED-PAGES)
    57             (FORMAT T ", Wired pages ~D+~D (~D~[~;.25~;.5~;.75~]K)~%"
    58                       N-FIXED-WIRED-PAGES (- N-WIRED-PAGES N-FIXED-WIRED-PAGES)
    59                       (// N-WIRED-PAGES (// 2000 PAGE-SIZE))
    60                       (\ N-WIRED-PAGES (// 2000 PAGE-SIZE))))
    61           (COND ((NULL ARG)
    62                  (DOLIST (AREA ROOM)
    63                    (ROOM-PRINT-AREA (IF (SYMBOLP AREA) (SYMEVAL AREA) AREA))))
    64                 ((EQ ARG 'T)
    65                  (PRINC "Unless otherwise noted, area names are in the SYSTEM package")
    66                  (TERPRI)
    67                  (DO AREA 0 (1+ AREA) (> AREA SIZE-OF-AREA-ARRAYS)
    68                    (ROOM-PRINT-AREA AREA)))
    69                 (T (FERROR NIL "~S is the wrong type arg" ARG))))))
     47;(ROOM) tells about the default areas
     48;(ROOM area1 area2...) tells about those areas
     49;(ROOM T) tells about all areas
     50;(ROOM NIL) prints only the header, does not do any areas
     51(DEFUN ROOM (&REST ARGS)
     52  (LET ((FREE-SIZE (GET-FREE-SPACE-SIZE))
     53        (PHYS-SIZE (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE)))
     54    (FORMAT T "~&Physical memory: ~O (~DK), Free space: ~O (~DK)"
     55              PHYS-SIZE (// PHYS-SIZE 2000) FREE-SIZE (// FREE-SIZE 2000)))
     56  (MULTIPLE-VALUE-BIND (N-WIRED-PAGES N-FIXED-WIRED-PAGES)
     57      (COUNT-WIRED-PAGES)
     58    (FORMAT T ", Wired pages ~D+~D (~D~[~;.25~;.5~;.75~]K)~%"
     59              N-FIXED-WIRED-PAGES (- N-WIRED-PAGES N-FIXED-WIRED-PAGES)
     60              (// N-WIRED-PAGES (// 2000 PAGE-SIZE))
     61              (\ N-WIRED-PAGES (// 2000 PAGE-SIZE))))
     62  (COND ((NULL ARGS)
     63         (SETQ ARGS ROOM))
     64        ((EQUAL ARGS '(T))
     65         (FORMAT T "Unless otherwise noted, area names are in the SYSTEM package~%")
     66         (SETQ ARGS AREA-LIST)))
     67  (COND ((NOT (EQUAL ARGS '(NIL)))
     68         (DOLIST (AREA ARGS)
     69           (ROOM-PRINT-AREA (IF (SYMBOLP AREA) (SYMEVAL AREA) AREA))))))
    7070
    7171;First value is total number of wired pages.  Second is number of fixed-wired pages.
    7272(DEFUN COUNT-WIRED-PAGES ()
    7373  (DO ((ADR (REGION-ORIGIN PAGE-TABLE-AREA) (+ ADR 2))
    74        (N (// (REGION-LENGTH PAGE-TABLE-AREA) 2) (1- N))
     74       (N (// (SYSTEM-COMMUNICATION-AREA %SYS-COM-PAGE-TABLE-SIZE) 2) (1- N))
    7575       (N-WIRED 0))
    7676      ((ZEROP N)
    77        (RETURN N-WIRED (// (REGION-ORIGIN REGION-FREE-POINTER) PAGE-SIZE)))
     77       (DO ((ADR (REGION-ORIGIN PHYSICAL-PAGE-DATA) (1+ ADR))
     78            (N (// (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE) PAGE-SIZE) (1- N))
     79            (N-FIXED-WIRED 0))
     80           ((ZEROP N)
     81            (RETURN (+ N-WIRED N-FIXED-WIRED) N-FIXED-WIRED))
     82         (AND (= (%P-LDB 0020 ADR) 177777)
     83              ( (%P-LDB 2020 ADR) 177777)
     84              (SETQ N-FIXED-WIRED (1+ N-FIXED-WIRED)))))
    7885    (AND (NOT (ZEROP (%P-LDB %%PHT1-VALID-BIT ADR)))
    7986         (= (%P-LDB %%PHT1-SWAP-STATUS-CODE ADR) %PHT-SWAP-STATUS-WIRED)
    8087         (SETQ N-WIRED (1+ N-WIRED)))))
    8188
    82 (DEFUN STREAM-COPY-UNTIL-EOF (FROM-STREAM TO-STREAM &OPTIONAL (LEADER-SIZE T))
    83     (COND ((AND (MEMQ ':LINE-IN (FUNCALL FROM-STREAM ':WHICH-OPERATIONS))
    84                 (MEMQ ':LINE-OUT (FUNCALL TO-STREAM ':WHICH-OPERATIONS)))
    85            (DO ((LINE)(EOF))
     89(DEFUN STREAM-COPY-UNTIL-EOF (FROM-STREAM TO-STREAM &OPTIONAL (LEADER-SIZE NIL))
     90  "Copy from one stream to another, until EOF on the from-stream.
     91  The default is to use the most efficient mode, but the third argument
     92  may be used to force use of :LINE-IN//:LINE-OUT mode, especially useful
     93  when the to-stream is an editor interval stream.  If you use this to
     94  copy binary files, note that you had better open the streams with
     95  appropriate host-dependent byte sizes, and that if the from-stream
     96  supports :LINE-IN but not :READ-INPUT-BUFFER you will probably lose."
     97  (LET ((FWO (FUNCALL FROM-STREAM ':WHICH-OPERATIONS))
     98        (TWO (FUNCALL TO-STREAM ':WHICH-OPERATIONS)))
     99    (COND ((AND (NOT LEADER-SIZE)
     100                (MEMQ ':READ-INPUT-BUFFER FWO)
     101                (MEMQ ':STRING-OUT TWO))
     102           ;; If it can go, this mode is the most efficient by far.
     103           (DO ((BUF) (OFFSET) (LIMIT))
     104               (())
     105             (MULTIPLE-VALUE (BUF OFFSET LIMIT)
     106               (FUNCALL FROM-STREAM ':READ-INPUT-BUFFER))
     107             (COND ((NULL BUF) (RETURN NIL)))
     108             (FUNCALL TO-STREAM ':STRING-OUT BUF OFFSET LIMIT)
     109             (FUNCALL FROM-STREAM ':ADVANCE-INPUT-BUFFER)))
     110
     111          ((AND (MEMQ ':LINE-IN FWO)
     112                (MEMQ ':LINE-OUT TWO))
     113           ;; Not as good, but better than :TYI/:TYO
     114           (DO ((LINE) (EOF))
    86115               (())
    87116             (MULTIPLE-VALUE (LINE EOF)
    88                              (FUNCALL FROM-STREAM ':LINE-IN LEADER-SIZE))
     117               (FUNCALL FROM-STREAM ':LINE-IN LEADER-SIZE))
    89118             (COND ((NOT EOF)
    90119                    (FUNCALL TO-STREAM ':LINE-OUT LINE))
    91120                   (T (FUNCALL TO-STREAM ':STRING-OUT LINE)
    92121                      (RETURN NIL)))))
     122          ;; This always wins, but is incredibly slow.
    93123          (T (DO ((CHAR))
    94124                 ((NULL (SETQ CHAR (FUNCALL FROM-STREAM ':TYI))))
    95                (FUNCALL TO-STREAM ':TYO CHAR)))))
     125               (FUNCALL TO-STREAM ':TYO CHAR))))))
    96126
    97127(DEFUN DESCRIBE-ADL (ADL)
     
    276306(DEFUN DESCRIBE (ANYTHING &OPTIONAL NO-COMPLAINTS &AUX TYPE)
    277307  (COND ((AND (NAMED-STRUCTURE-P ANYTHING)
    278               (COND ((AND (FBOUNDP (NAMED-STRUCTURE-SYMBOL ANYTHING))
     308              (COND ((AND (GET (NAMED-STRUCTURE-SYMBOL ANYTHING) 'NAMED-STRUCTURE-INVOKE)
    279309                          (MEMQ ':DESCRIBE
    280310                                (NAMED-STRUCTURE-INVOKE ANYTHING ':WHICH-OPERATIONS)))
    281311                     (NAMED-STRUCTURE-INVOKE ANYTHING ':DESCRIBE))
    282312                    ((GET (SETQ TYPE (NAMED-STRUCTURE-SYMBOL ANYTHING)) 'DEFSTRUCT-ITEMS)
    283                      (DESCRIBE-DEFSTRUCT TYPE ANYTHING)))))
     313                     (DESCRIBE-OLD-DEFSTRUCT TYPE ANYTHING))
     314                    ((GET (NAMED-STRUCTURE-SYMBOL ANYTHING) 'DEFSTRUCT-DESCRIPTION)
     315                     (DESCRIBE-DEFSTRUCT ANYTHING)))))
    284316        ((OR (ENTITYP ANYTHING) (= (%DATA-TYPE ANYTHING) DTP-INSTANCE))
    285317         (FUNCALL ANYTHING ':DESCRIBE))
     
    302334        ((= (%DATA-TYPE ANYTHING) DTP-SELECT-METHOD)
    303335         (DESCRIBE-SELECT-METHOD ANYTHING))
     336        ((bigp anything)
     337         (describe-bignum anything))
    304338        ((FIXP ANYTHING)
    305339         (FORMAT T "~%~R is ~[even~;odd~]" ANYTHING (LDB 0001 ANYTHING)))
    306340        ((NOT NO-COMPLAINTS)
    307341         (FORMAT STANDARD-OUTPUT "~%I don't know how to describe ~S" ANYTHING)))
    308   (FUNCALL STANDARD-OUTPUT ':FRESH-LINE))
     342  (FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
     343  ANYTHING)
    309344
    310345(DEFUN DESCRIBE-1 (THING)       ;AN INTERNAL SUBROUTINE
     
    350385  (FORMAT STANDARD-OUTPUT "~%~S is a list" L))
    351386
    352 (DEFUN DESCRIBE-DEFSTRUCT (SYMBOL X)
    353     (FORMAT T "~%~S is a ~S~%" X SYMBOL)
    354     (DO L (GET SYMBOL 'DEFSTRUCT-ITEMS) (CDR L) (NULL L)
     387(DEFUN DESCRIBE-OLD-DEFSTRUCT (SYMBOL X)
     388  (FORMAT T "~%~S is a ~S~%" X SYMBOL)
     389  (DO L (GET SYMBOL 'DEFSTRUCT-ITEMS) (CDR L) (NULL L)
    355390      (FORMAT T "   ~30A~S~%"
    356391              (STRING-APPEND (CAR L) ":")
    357392              (EVAL `(,(CAR L) ',X)))))
    358393
     394(DEFUN DESCRIBE-DEFSTRUCT (X &OPTIONAL DEFSTRUCT-TYPE &AUX DESCRIPTION)
     395  (SETQ DESCRIPTION (GET (OR DEFSTRUCT-TYPE (NAMED-STRUCTURE-SYMBOL X))
     396                         'DEFSTRUCT-DESCRIPTION))
     397  (FORMAT T "~%~S is a ~S~%" X (DEFSTRUCT-DESCRIPTION-NAME))
     398  (DO L (DEFSTRUCT-DESCRIPTION-SLOT-ALIST) (CDR L) (NULL L)
     399      (FORMAT T "   ~30A~S~%"
     400              (STRING-APPEND (CAAR L) ":")
     401              (EVAL `(,(DEFSTRUCT-SLOT-DESCRIPTION-REF-MACRO-NAME (CDAR L)) ',X)))))
     402
    359403(DEFUN DESCRIBE-CLOSURE (CL)
    360     (LET ((C (%MAKE-POINTER DTP-LIST CL))
    361           (SYM NIL) (OFFSET NIL))
    362       (FORMAT T "~%~S is a closure of ~S:~%" CL (CAR C))
    363       (DO L (CDR C) (CDDR L) (NULL L)
    364        (SETQ SYM (%FIND-STRUCTURE-HEADER (CAR L))
    365              OFFSET (%POINTER-DIFFERENCE (CAR L) SYM))
    366        (FORMAT T
    367                "   ~A cell of ~S:        ~32,7A~%"
    368                (SELECTQ OFFSET
    369                         (0 "Print name") (1 "Value") (2 "Function")
    370                         (3 "Property list") (4 "Package"))
    371                SYM
    372                (COND ((= (%P-DATA-TYPE (CADR L)) DTP-NULL)
    373                       "unbound.")
    374                      (T (CAADR L)))))
    375       (DESCRIBE-1 (CAR C))
    376       ))
     404  (LET ((C (%MAKE-POINTER DTP-LIST CL))
     405        (SYM NIL) (OFFSET NIL))
     406    (FORMAT T "~%~S is a closure of ~S:~%" CL (CAR C))
     407    (DO L (CDR C) (CDDR L) (NULL L)
     408        (SETQ SYM (%FIND-STRUCTURE-HEADER (CAR L))
     409              OFFSET (%POINTER-DIFFERENCE (CAR L) SYM))
     410        (FORMAT T
     411                "   ~A cell of ~S:        ~32,7S~%"
     412                (SELECTQ OFFSET
     413                  (0 "Print name") (1 "Value") (2 "Function")
     414                  (3 "Property list") (4 "Package"))
     415                SYM
     416                (COND ((= (%P-DATA-TYPE (CADR L)) DTP-NULL)
     417                       "unbound.")
     418                      (T (CAADR L)))))
     419    (DESCRIBE-1 (CAR C))
     420    ))
    377421
    378422(DEFUN DESCRIBE-SELECT-METHOD (M)
     
    386430                     )))))
    387431    (COND ((ATOM (CAR ML)) (FORMAT T "~%   subroutine ~S" (CAR ML)))
    388           (T (FORMAT T "~%   ~S: ~S" (CAAR ML) (CDAR ML))))))
     432          (T (FORMAT T "~%   ~S: ~34T~S" (CAAR ML)
     433                     (IF (= (%DATA-TYPE (CDAR ML)) DTP-FEF-POINTER)
     434                         (%P-CONTENTS-OFFSET (CDAR ML) %FEFHI-FCTN-NAME)
     435                         (CDAR ML)))))))
    389436
    390437(DEFUN DESCRIBE-SMALL-FLONUM (X)
     
    400447               (%P-LDB-OFFSET 1414 X 1)
    401448               (%P-LDB-OFFSET 0014 X 1)))
     449
     450(defun describe-bignum (x)
     451  (let ((len (%p-ldb-offset #o0022 x 0))
     452        (barf nil))
     453    (format t "~&~S is a bignum.~&It is ~R word~:P long.  It is ~[positive~;negative~].  ~
     454                 It is stored starting at location: ~O~&Its contents:~2%"
     455            x len (%p-ldb-offset #o2201 x 0) (%pointer x))
     456    (do ((i 1 (1+ i)))
     457        ((> i len))
     458      (or (zerop (%p-ldb-offset #o3701 x i))
     459          (setq barf t))
     460      (format t "~&~3O: ~[ ~;*~]"
     461              i (%p-ldb-offset #o3701 x i))
     462      (do ((ppss #o3601 (- ppss #o0100)))
     463          ((< ppss #o0001))
     464        (tyo (+ #/0 (%p-ldb-offset ppss x i))))
     465      (format t "  ~O," (%p-ldb-offset #o3601 x i))
     466      (do ((ppss #o3303 (- ppss #o0300)))
     467          ((< ppss #o0003))
     468        (tyo (+ #/0 (%p-ldb-offset ppss x i))))
     469      (princ "  ")
     470      (do ((ppss #o3403 (- ppss #o0300)))
     471          ((< ppss #o0103))
     472        (tyo (+ #/0 (%p-ldb-offset ppss x i))))
     473      (format t ",~O  ~O," (%p-ldb-offset #o0001 x i) (%p-ldb-offset #o3502 x i))
     474      (do ((ppss #o3203 (- ppss #o0300)))
     475          ((< ppss #o0203))
     476        (tyo (+ #/0 (%p-ldb-offset ppss x i))))
     477      (format t ",~O" (%p-ldb-offset #o0002 x i)))
     478    (if barf
     479        (format t "~2&* = high order bit illegally 1, bug in bignum microcode?"))
     480    (terpri))
     481  x)
    402482
    403483(DEFUN DESCRIBE-AREA (AREA &AUX LENGTH USED N-REGIONS)
     
    414494             (SETQ BITS (REGION-BITS REGION))
    415495             (FORMAT T "  Region #~O: Origin ~O, Length ~O, Free ~O, GC ~O, Type ~A ~A, Map ~O,~[NoScav~;Scav~]~%"
    416                      REGION (REGION-ORIGIN REGION) (REGION-LENGTH REGION)
     496                     REGION (REGION-ORIGIN-TRUE-VALUE REGION) (REGION-LENGTH REGION)
    417497                     (REGION-FREE-POINTER REGION) (REGION-GC-POINTER REGION)
    418498                     (NTH (LDB %%REGION-REPRESENTATION-TYPE BITS)
    419499                          '(LIST STRUC "REP=2" "REP=3"))
    420500                     (NTH (LDB %%REGION-SPACE-TYPE BITS)
    421                           '(FREE OLD NEW STATIC FIXED EXITED EXIT EXTRA-PDL
    422                             WIRED MAPPED COPY "TYPE=13" "TYPE=14" "TYPE=15"
    423                             "TYPE=16" "TYPE=17"))
     501                          '(FREE OLD NEW NEW1 NEW2 NEW3 NEW4 NEW5 NEW6
     502                            STATIC FIXED EXTRA-PDL COPY "TYPE=15" "TYPE=16" "TYPE=17"))
    424503                     (LDB %%REGION-MAP-BITS BITS)
    425504                     (LDB %%REGION-SCAVENGE-ENABLE BITS)))
     
    427506
    428507
    429 
    430 (SPECIAL RANDOM-ARRAY)
     508(DEFVAR RANDOM-ARRAY)
    431509
    432510(DEFSTRUCT (RANDOM-NUMBER-TABLE ARRAY-LEADER)
     
    434512    RANDOM-SEED
    435513    RANDOM-POINTER-1
    436     RANDOM-POINTER-2
    437     )
    438 
    439 (DEFUN RANDOM-CREATE-ARRAY (SIZE OFFSET SEED &OPTIONAL (AREA NIL) &AUX ARRAY)
    440     (SETQ ARRAY (MAKE-RANDOM-NUMBER-TABLE
    441                         MAKE-ARRAY (AREA ART-Q-LIST SIZE)))
    442     (SETF (RANDOM-FILL-POINTER ARRAY) SIZE)
    443     (SETF (RANDOM-SEED ARRAY) SEED)
    444     (SETF (RANDOM-POINTER-1 ARRAY) 0)
    445     (SETF (RANDOM-POINTER-2 ARRAY) OFFSET)
    446     (RANDOM-INITIALIZE ARRAY)
    447     ARRAY)
    448 
    449 (DEFUN RANDOM-INITIALIZE (ARRAY &AUX SIZE X BYTE-SPEC POINTER)
     514    RANDOM-POINTER-2)
     515
     516(DEFUN RANDOM-CREATE-ARRAY (SIZE OFFSET SEED &OPTIONAL (AREA NIL))
     517    (LET ((ARRAY (MAKE-RANDOM-NUMBER-TABLE
     518                   MAKE-ARRAY (:AREA AREA
     519                               :TYPE 'ART-Q-LIST
     520                               :LENGTH SIZE)
     521                   RANDOM-FILL-POINTER SIZE
     522                   RANDOM-SEED SEED
     523                   RANDOM-POINTER-1 0
     524                   RANDOM-POINTER-2 OFFSET)))
     525      (RANDOM-INITIALIZE ARRAY)
     526      ARRAY))
     527
     528(DEFUN RANDOM-INITIALIZE (ARRAY &OPTIONAL NEW-SEED &AUX SIZE X BYTE-SPEC POINTER)
     529   (IF (NOT (NULL NEW-SEED))
     530       (SETF (RANDOM-SEED ARRAY) NEW-SEED))
    450531   (SETQ SIZE (RANDOM-FILL-POINTER ARRAY)
    451532         POINTER (AP-1 ARRAY 0))
     533   (SETF (RANDOM-POINTER-2 ARRAY) (\ (+ SIZE (- (RANDOM-POINTER-2 ARRAY)
     534                                                (RANDOM-POINTER-1 ARRAY)))
     535                                     SIZE))
     536   (SETF (RANDOM-POINTER-1 ARRAY) 0)
    452537   (DO I 0 (1+ I) (= I SIZE)
    453      (AS-1 0 ARRAY I))
     538     (ASET 0 ARRAY I))
    454539   (SETQ X (RANDOM-SEED ARRAY))
    455540   (DO L '(1414 0014) (CDR L) (NULL L)
     
    457542     (DO I 0 (1+ I) (= I SIZE)
    458543       (SETQ X (%24-BIT-TIMES X 4093.))                 ;4093. is a prime number.
    459        (%P-DPB-OFFSET (LDB 1314 X) BYTE-SPEC POINTER I)))
    460    (SETF (RANDOM-SEED ARRAY) X))
     544       (%P-DPB-OFFSET (LDB 1314 X) BYTE-SPEC POINTER I))))
    461545
    462546(DEFUN RANDOM (&OPTIONAL ARG ARRAY &AUX PTR1 PTR2 SIZE ANS)
     
    476560      (SETF (RANDOM-POINTER-2 ARRAY) PTR2)
    477561      (SETQ ANS (%24-BIT-PLUS (AR-1 ARRAY PTR1) (AR-1 ARRAY PTR2)))
    478       (AS-1 ANS ARRAY PTR2))
     562      (ASET ANS ARRAY PTR2))
    479563    (COND (ARG (\ (LOGAND ANS 37777777) ARG))   ;ASSURE POSITIVE ANSWER
    480564          (T ANS)))
     
    546630(DECLARE (SPECIAL APROPOS-SUBSTRING))
    547631
    548 (DEFUN APROPOS (APROPOS-SUBSTRING &OPTIONAL (PKG PKG-GLOBAL-PACKAGE))
    549     (MAPATOMS-ALL
    550      (FUNCTION (LAMBDA (SYMBOL)
    551          (COND ((STRING-SEARCH APROPOS-SUBSTRING (GET-PNAME SYMBOL))
    552                 (LET ((PACKAGE (CAR (PACKAGE-CELL-LOCATION SYMBOL))))
    553                      ;;Binding PACKAGE is to prevent printing of a package prefix.
    554                   (FORMAT T "~%~A:~S" PACKAGE SYMBOL)) ;ALWAYS get a prefix
    555                 (AND (FBOUNDP SYMBOL)
    556                      (FORMAT T " - Function ~:S" (ARGLIST SYMBOL)))
    557                 (AND (BOUNDP SYMBOL)
    558                      (COND ((FBOUNDP SYMBOL) (PRINC ", Bound"))
    559                            (T (PRINC " - Bound"))))))))
    560      PKG))
     632(LOCAL-DECLARE ((SPECIAL RETURN-LIST))
     633(DEFUN APROPOS (APROPOS-SUBSTRING &OPTIONAL PKG (DO-INFERIORS T) DO-SUPERIORS
     634                &AUX RETURN-LIST)
     635  (SETQ PKG (IF (NULL PKG) PKG-GLOBAL-PACKAGE (PKG-FIND-PACKAGE PKG)))
     636  (MAPATOMS #'APROPOS-1 PKG DO-SUPERIORS)
     637  (AND DO-INFERIORS
     638       (DOLIST (P (PKG-SUBPACKAGES PKG))
     639         (MAPATOMS-ALL #'APROPOS-1 P)))
     640  RETURN-LIST)
     641
     642(DEFUN APROPOS-1 (SYMBOL)
     643  (COND ((STRING-SEARCH APROPOS-SUBSTRING (GET-PNAME SYMBOL))
     644         (PUSH SYMBOL RETURN-LIST)
     645         ;; Binding the package to NIL forces the package to be printed.
     646         ;; This is better than explicitly printing the package, because
     647         ;; this way you get the "short" version.
     648         (LET ((PACKAGE NIL))
     649           (FORMAT T "~%~S" SYMBOL))
     650         (AND (FBOUNDP SYMBOL)
     651              (FORMAT T " - Function ~:S" (ARGLIST SYMBOL)))
     652         (AND (BOUNDP SYMBOL)
     653              (COND ((FBOUNDP SYMBOL) (PRINC ", Bound"))
     654                    (T (PRINC " - Bound")))))))
     655);End of LOCAL-DECLARE
    561656
    562657(DEFUN SYMEVAL-IN-CLOSURE (CLOSURE PTR)
     
    599694(DEFUN ENTITYP (X)
    600695    (= (%DATA-TYPE X) DTP-ENTITY))
    601 
    602 (DEFUN LOCATIVEP (X)
    603     (= (%DATA-TYPE X) DTP-LOCATIVE))
    604696
    605697;ARRAY-POP, eventually to be micro-coded
     
    620712        (RETURN VAL)))
    621713
    622 ;FILLARRAY as in Maclisp, eventually to be micro-coded.
    623 ;SOURCE may be an array or a list.
    624 ;Order of subscripts is currently incompatible with Maclisp for multi-dimensional
    625 ;arrays.  In any case, will not bother supporting multi-dimensional until it's micro-coded.
     714;;; The following definitions of FILLARRAY and LISTARRAY should be completely
     715;;; compatible with Maclisp.  Slow, maybe, but compatible.
     716
     717;;; When filling from an array, extra elements in the destination get the default initial
     718;;; value for the array type.  When filling from a list it sticks at the last element.
     719;;; Extra elements in the source are ignored.  copy-array-contents
     720;;; does the right thing for one-d arrays, but for multi-dimensional arrays
     721;;; uses column-major rather than row-major order.
     722
     723(DEFRESOURCE FILLARRAY-INDEX-ARRAYS ()
     724        :CONSTRUCTOR (MAKE-ARRAY 10)
     725        :INITIAL-COPIES 2)
     726
    626727(DEFUN FILLARRAY (ARRAY SOURCE)
    627   (AND (SYMBOLP ARRAY) (SETQ ARRAY (FSYMEVAL ARRAY)))
    628   (COND ((ARRAYP SOURCE)
    629          (COPY-ARRAY-CONTENTS SOURCE ARRAY))
    630         (T (DO ((I 0 (1+ I))
    631                 (N (ARRAY-LENGTH ARRAY))
    632                 (L SOURCE (OR (CDR L) L)))
    633                ((>= I N))
    634              (AS-1 (CAR L) ARRAY I))))
     728  (LET ((DEST (IF (SYMBOLP ARRAY) (FSYMEVAL ARRAY) ARRAY)))
     729    (CHECK-ARG ARRAY (ARRAYP DEST) "an array or a symbol FBOUND to an array")
     730    ;; Note, I really mean LISTP here -- Maclisp does not allow NIL, and that is right.
     731    ;; Well, there is code in the system that depends on the empty list working as a source,
     732    ;; at least for zero-length arrays.  This code says filling from () means fill
     733    ;; with the default initial value for the destination array type.
     734    (CHECK-ARG SOURCE (OR (ARRAYP SOURCE) (LISTP SOURCE) (NULL SOURCE)) "an array or a list")
     735    (LET ((DEST-NDIMS (ARRAY-#-DIMS DEST))
     736          (SOURCE-IS-AN-ARRAY-P (ARRAYP SOURCE)))
     737      (COND (SOURCE-IS-AN-ARRAY-P
     738             (LET ((SOURCE-NDIMS (ARRAY-#-DIMS SOURCE)))
     739               (COND ((AND (= DEST-NDIMS 1)
     740                           (= SOURCE-NDIMS 1))
     741                      ;; One-D array into a one-D array is in microcode!
     742                      (LET ((N-ELEMENTS (MIN (ARRAY-LENGTH SOURCE)
     743                                             (ARRAY-LENGTH DEST))))
     744                        (COPY-ARRAY-PORTION SOURCE 0 N-ELEMENTS DEST 0 N-ELEMENTS)))
     745                     (T
     746                      ;; Hairy case, some array is multi-dimensional.
     747                      (USING-RESOURCE (SOURCE-INDEX-ARRAY FILLARRAY-INDEX-ARRAYS)
     748                        (USING-RESOURCE (DEST-INDEX-ARRAY FILLARRAY-INDEX-ARRAYS)
     749                          (DOTIMES (I 10)
     750                            (ASET 0 SOURCE-INDEX-ARRAY I)
     751                            (ASET 0 DEST-INDEX-ARRAY I))
     752                          (LET ((SOURCE-ELEMENTS (ARRAY-LENGTH SOURCE))
     753                                (DEST-ELEMENTS (ARRAY-LENGTH DEST)))
     754                            (DOTIMES (I (MIN SOURCE-ELEMENTS DEST-ELEMENTS))
     755                              (FILLARRAY-PUT (FILLARRAY-GET SOURCE
     756                                                            SOURCE-INDEX-ARRAY
     757                                                            SOURCE-NDIMS)
     758                                             DEST DEST-INDEX-ARRAY DEST-NDIMS)))))))))
     759            ((NULL SOURCE) (COPY-ARRAY-PORTION DEST 0 0 DEST 0 (ARRAY-LENGTH DEST)))
     760            (T
     761             ;; Source is a list.
     762             (COND ((= DEST-NDIMS 1)
     763                    (DOTIMES (X (ARRAY-DIMENSION-N 1 DEST))
     764                      (ASET (CAR SOURCE) DEST X)
     765                      (IF (NOT (NULL (CDR SOURCE))) (SETQ SOURCE (CDR SOURCE)))))
     766                   ((= DEST-NDIMS 2)
     767                    (DOTIMES (X (ARRAY-DIMENSION-N 1 DEST))
     768                      (DOTIMES (Y (ARRAY-DIMENSION-N 2 DEST))
     769                        (ASET (CAR SOURCE) DEST X Y)
     770                        (IF (NOT (NULL (CDR SOURCE))) (SETQ SOURCE (CDR SOURCE))))))
     771                   ((= DEST-NDIMS 3)
     772                    (DOTIMES (X (ARRAY-DIMENSION-N 1 DEST))
     773                      (DOTIMES (Y (ARRAY-DIMENSION-N 2 DEST))
     774                        (DOTIMES (Z (ARRAY-DIMENSION-N 3 DEST))
     775                          (ASET (CAR SOURCE) DEST X Y Z)
     776                          (IF (NOT (NULL (CDR SOURCE))) (SETQ SOURCE (CDR SOURCE)))))))
     777                   (T
     778                    (USING-RESOURCE (DEST-INDEX-ARRAY FILLARRAY-INDEX-ARRAYS)
     779                      (DOTIMES (I 10)
     780                        (ASET 0 DEST-INDEX-ARRAY I))
     781                      (DOTIMES (I (ARRAY-LENGTH DEST))
     782                        (FILLARRAY-PUT (CAR SOURCE) DEST DEST-INDEX-ARRAY DEST-NDIMS)
     783                        (IF (NOT (NULL (CDR SOURCE))) (SETQ SOURCE (CDR SOURCE)))))))))))
    635784  ARRAY)
    636785
    637 (DEFUN LISTARRAY (ARRAY &OPTIONAL LIMIT &AUX LST)
    638   (AND (SYMBOLP ARRAY) (SETQ ARRAY (FSYMEVAL ARRAY)))
    639   (OR LIMIT
    640       (SETQ LIMIT (ARRAY-ACTIVE-LENGTH ARRAY)))
    641   (SETQ LST (MAKE-LIST DEFAULT-CONS-AREA LIMIT))
    642   (DO ((I 0 (1+ I))
    643        (L LST (CDR L)))
    644       ((>= I LIMIT)
    645        LST)
    646     (RPLACA L (AR-1 ARRAY I))))
     786(DEFUN FILLARRAY-GET (ARRAY INDEX-ARRAY NDIMS)
     787  (%OPEN-CALL-BLOCK ARRAY 0 1)                  ;d-stack
     788  (%ASSURE-PDL-ROOM NDIMS)
     789  (DOTIMES (I NDIMS)
     790    (%PUSH (AREF INDEX-ARRAY I)))
     791  (%ACTIVATE-OPEN-CALL-BLOCK)
     792  (FILLARRAY-INCREMENT-INDEX ARRAY INDEX-ARRAY NDIMS)
     793  (%POP))
     794
     795(DEFUN FILLARRAY-PUT (VALUE ARRAY INDEX-ARRAY NDIMS)
     796  (%OPEN-CALL-BLOCK ARRAY 0 0)                  ;d-ignore
     797  (%ASSURE-PDL-ROOM NDIMS)
     798  (DOTIMES (I NDIMS)
     799    (%PUSH (AREF INDEX-ARRAY I)))
     800  (%ACTIVATE-OPEN-CALL-BLOCK)
     801  (STORE NIL VALUE)
     802  (FILLARRAY-INCREMENT-INDEX ARRAY INDEX-ARRAY NDIMS))
     803
     804(DEFUN FILLARRAY-INCREMENT-INDEX (ARRAY INDEX-ARRAY NDIMS)
     805  (DO ((DIM NDIMS (1- DIM)))
     806      ((
     807 DIM 0))
     808    (LET ((VAL (1+ (AREF INDEX-ARRAY (1- DIM)))))
     809      (COND ((< VAL (ARRAY-DIMENSION-N DIM ARRAY))
     810             (ASET VAL INDEX-ARRAY (1- DIM))
     811             (RETURN))
     812            (T
     813             (ASET 0 INDEX-ARRAY (1- DIM)))))))
     814
     815;;; LISTARRAY of a one-dimensional array respects the fill pointer, but
     816;;; for multi-dimensional arrays it ignores the fill pointer.
     817(DEFUN LISTARRAY (ARRAY &OPTIONAL LIMIT)
     818  (IF (SYMBOLP ARRAY)
     819      (SETQ ARRAY (FSYMEVAL ARRAY)))
     820  (CHECK-ARG ARRAY ARRAYP "an array or a symbol FBOUND to an array")
     821  (CHECK-ARG LIMIT (OR (NULL LIMIT) (FIXP LIMIT)) "NIL or a fixnum")
     822  (LET* ((NDIMS (ARRAY-#-DIMS ARRAY))
     823         (ELEMENTS (IF (= NDIMS 1)
     824                       (ARRAY-ACTIVE-LENGTH ARRAY)
     825                       (ARRAY-LENGTH ARRAY)))
     826         (TIMES (IF (NULL LIMIT)
     827                    ELEMENTS
     828                    (MIN LIMIT ELEMENTS)))
     829         (LIST (MAKE-LIST TIMES))
     830         (L LIST)
     831         (COUNT 0))
     832    (COND ((= NDIMS 1)
     833           (DOTIMES (X (ARRAY-ACTIVE-LENGTH ARRAY))
     834             (SETQ COUNT (1+ COUNT))
     835             (IF (> COUNT TIMES)
     836                 (RETURN))
     837             (RPLACA L (AREF ARRAY X))
     838             (SETQ L (CDR L))))
     839          ((= NDIMS 2)
     840           (DOTIMES (X (ARRAY-DIMENSION-N 1 ARRAY))
     841             (DOTIMES (Y (ARRAY-DIMENSION-N 2 ARRAY))
     842               (SETQ COUNT (1+ COUNT))
     843               (IF (> COUNT TIMES)
     844                   (RETURN))
     845               (RPLACA L (AREF ARRAY X Y))
     846               (SETQ L (CDR L)))))
     847          ((= NDIMS 3)
     848           (DOTIMES (X (ARRAY-DIMENSION-N 1 ARRAY))
     849             (DOTIMES (Y (ARRAY-DIMENSION-N 2 ARRAY))
     850               (DOTIMES (Z (ARRAY-DIMENSION-N 3 ARRAY))
     851                 (SETQ COUNT (1+ COUNT))
     852                 (IF (> COUNT TIMES)
     853                     (RETURN))
     854                 (RPLACA L (AREF ARRAY X Y Z))
     855                 (SETQ L (CDR L))))))
     856          (T
     857           (USING-RESOURCE (INDEX-ARRAY FILLARRAY-INDEX-ARRAYS)
     858             (DOTIMES (I 10) (ASET 0 INDEX-ARRAY I))
     859             (DOTIMES (I TIMES)
     860               (RPLACA L (FILLARRAY-GET ARRAY INDEX-ARRAY NDIMS))
     861               (SETQ L (CDR L))))))
     862    LIST))
    647863
    648864(DEFUN LIST-ARRAY-LEADER (ARRAY &OPTIONAL LIMIT &AUX LST)
     
    667883    (AR-1 (FSYMEVAL 'Q-DATA-TYPES) (%DATA-TYPE X)))
    668884
    669 (LOCAL-DECLARE ((SPECIAL FUNCTION))
    670 (DEFUN WHO-CALLS (FUNCTION &OPTIONAL (PKG PKG-GLOBAL-PACKAGE))
    671     (SETQ PKG (PKG-FIND-PACKAGE PKG))
    672     (AND (STRINGP FUNCTION) (SETQ FUNCTION (INTERN FUNCTION)))
    673     (CHECK-ARG FUNCTION SYMBOLP "a symbol")
    674     (MAPATOMS-ALL (FUNCTION WHO-CALLS-AUX) PKG)
    675     NIL))
    676 
    677 
    678 ;; This attempts to reduce page faults
    679 ;; but it only saves as much time as the sort uses up.
    680 ;; Maybe with explicit swap-out it will be faster.
    681 (COMMENT
    682 (LOCAL-DECLARE ((SPECIAL FUNCTION ARRAY))
    683 (DEFUN WHO-CALLS (FUNCTION &OPTIONAL (PKG PKG-GLOBAL-PACKAGE))
    684     (SETQ PKG (PKG-FIND-PACKAGE PKG))
    685     (AND (STRINGP FUNCTION) (SETQ FUNCTION (INTERN FUNCTION)))
    686     (CHECK-ARG FUNCTION SYMBOLP "a symbol")
    687     (LET ((ARRAY (MAKE-ARRAY NIL ART-Q 10000. NIL 1)))
    688         (SETF (ARRAY-LEADER ARRAY 0) 0)
    689         (MAPATOMS-ALL (FUNCTION (LAMBDA (SYMBOL)
    690                           (AND (FBOUNDP SYMBOL)
    691                                (ARRAY-PUSH-EXTEND ARRAY SYMBOL (ARRAY-ACTIVE-LENGTH ARRAY)))))
    692                       PKG)
    693         (SORT ARRAY (FUNCTION (LAMBDA (X Y)
    694                         (< (%POINTER (FSYMEVAL X)) (%POINTER (FSYMEVAL Y))))))
    695         (DO I (1- (ARRAY-ACTIVE-LENGTH ARRAY)) (1- I) (< I 0)
    696            (WHO-CALLS-AUX (AR-1 ARRAY I)))
    697         (RETURN-ARRAY ARRAY))
    698     NIL)))
    699 (DEFUN WHO-USES (FUNCTION &OPTIONAL (PKG PKG-GLOBAL-PACKAGE)) (WHO-CALLS FUNCTION PKG))
    700 
    701 ;Print out CALLER if it refers to the symbol in the special variable FUNCTION,
    702 ;either as a function call, as a variable reference, or as a constant reference.
    703 ;The symbol UNBOUND-FUNCTION is treated specially.
    704 (LOCAL-DECLARE ((SPECIAL FUNCTION))
    705 (DEFUN WHO-CALLS-AUX (CALLER &AUX DEFN)
    706    ;; Ignore all symbols which are forwarded to others, to avoid duplication.
    707    (COND ((NOT (= (%P-LDB-OFFSET %%Q-DATA-TYPE CALLER 1) DTP-ONE-Q-FORWARD))
    708           (COND ((FBOUNDP CALLER)
    709                  (SETQ DEFN (FSYMEVAL CALLER))
    710                  ;; Don't be fooled by macros, interpreted or compiled.
    711                  (AND (LISTP DEFN) (EQ (CAR DEFN) 'MACRO) (SETQ DEFN (CDR DEFN)))
    712                  (COND ((LISTP DEFN)
    713                         (WHO-CALLS-AUX-LIST CALLER FUNCTION DEFN))
    714                        ((= (%DATA-TYPE DEFN) DTP-FEF-POINTER)
    715                         (WHO-CALLS-AUX-FEF CALLER FUNCTION DEFN)))))
    716           (DO ((L (PLIST CALLER) (CDDR L)))
    717               ((NULL L))
    718             (COND ((= (%DATA-TYPE (CADR L)) DTP-FEF-POINTER)
    719                    (WHO-CALLS-AUX-FEF (LIST CALLER (CAR L)) FUNCTION (CADR L)))))))))
     885
     886;;; Facilities for looking through all functions in the world
     887;;; and finding out what they do.
     888
     889(LOCAL-DECLARE ((SPECIAL RETURN-LIST))
     890(DEFUN WHO-CALLS (SYMBOL &OPTIONAL PKG (DO-INFERIORS T) (DO-SUPERIORS T) &AUX RETURN-LIST)
     891  (OR PKG (SETQ PKG PKG-GLOBAL-PACKAGE))
     892  (FIND-CALLERS-OF-SYMBOLS SYMBOL PKG
     893        #'(LAMBDA (CALLER CALLEE HOW)
     894            (FORMAT T "~&~S" CALLER)
     895            (FORMAT T (SELECTQ HOW
     896                        (:VARIABLE " uses ~S as a variable.")
     897                        (:FUNCTION " calls ~S as a function.")
     898                        (:MISC-FUNCTION " calls ~S via a 'misc' instruction.")
     899                        (:CONSTANT " uses ~S as a constant.")
     900                        (:UNBOUND-FUNCTION " calls ~S, an undefined function.")
     901                        (NIL ", an interpreted function, uses ~S somehow."))
     902                    CALLEE)
     903            (PUSH CALLER RETURN-LIST)) DO-INFERIORS DO-SUPERIORS)
     904  RETURN-LIST)
     905)
     906
     907(DEFF WHO-USES 'WHO-CALLS)
     908
     909(DEFUN WHAT-FILES-CALL (SYMBOL-OR-SYMBOLS &OPTIONAL PKG (DO-INFERIORS T) (DO-SUPERIORS T))
     910  (OR PKG (SETQ PKG PKG-GLOBAL-PACKAGE))
     911  (LOCAL-DECLARE ((SPECIAL L))
     912    (LET ((L NIL))
     913      (FIND-CALLERS-OF-SYMBOLS SYMBOL-OR-SYMBOLS PKG
     914        #'(LAMBDA (CALLER IGNORE IGNORE)
     915            (AND (SETQ CALLER (GET-SOURCE-FILE-NAME CALLER 'DEFUN))
     916                 (NOT (MEMQ CALLER L))
     917                 (PUSH CALLER L)))
     918        DO-INFERIORS DO-SUPERIORS)
     919      L)))
     920
     921(LOCAL-DECLARE ((SPECIAL SYMBOL FUNCTION))
     922(DEFUN FIND-CALLERS-OF-SYMBOLS (SYMBOL PKG FUNCTION
     923                                &OPTIONAL (DO-INFERIORS T) (DO-SUPERIORS T))
     924  "This is the main driving function for WHO-CALLS and friends.
     925   Looks at all symbols in PKG and its inferiors and its superiors (does not
     926   do its sisters, cousins, and aunts).
     927   Looks at each symbol's function definition and if it
     928   refers to SYMBOL calls FUNCTION with the function name, the symbol used,
     929   and the type of use (:VARIABLE, :FUNCTION, :MISC-FUNCTION, :CONSTANT, :UNBOUND-FUNCTION,
     930   or NIL if used in an unknown way in an interpreted function.)
     931   SYMBOL can be a single symbol or a list of symbols.
     932   The symbol :UNBOUND-FUNCTION is treated specially."
     933  ;; Sorting first, in order of function definitions, didn't help much when
     934  ;; tried in the previous generation of this function.
     935  (SETQ PKG (PKG-FIND-PACKAGE PKG))
     936  (CHECK-ARG SYMBOL
     937             (OR (SYMBOLP SYMBOL)
     938                 (LOOP FOR SYM IN SYMBOL ALWAYS (SYMBOLP SYM)))
     939             "a symbol or a list of symbols")
     940  (IF (SYMBOLP SYMBOL)
     941      (SETQ SYMBOL (ADD-SYMBOLS-OPTIMIZED-INTO SYMBOL SYMBOL))
     942      (DOLIST (SYM SYMBOL)
     943        (SETQ SYMBOL (ADD-SYMBOLS-OPTIMIZED-INTO SYM SYMBOL))))
     944  (MAPATOMS #'FIND-CALLERS-OF-SYMBOLS-AUX PKG DO-SUPERIORS)
     945  (AND DO-INFERIORS
     946       (DOLIST (P (PKG-SUBPACKAGES PKG))
     947         (MAPATOMS-ALL #'FIND-CALLERS-OF-SYMBOLS-AUX P)))
     948  NIL)
     949
     950(DEFUN ADD-SYMBOLS-OPTIMIZED-INTO (SYM LIST)
     951  (DOLIST (SYM1 (GET SYM 'COMPILER:OPTIMIZED-INTO))
     952    (IF (SYMBOLP LIST) (SETQ LIST (LIST LIST)))
     953    (OR (MEMQ SYM1 LIST)
     954        (SETQ LIST (ADD-SYMBOLS-OPTIMIZED-INTO SYM1 (CONS SYM1 LIST)))))
     955  LIST)
     956
     957(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX (CALLER &AUX FL)
     958  ;; Ignore all symbols which are forwarded to others, to avoid duplication.
     959  (AND ( (%P-LDB-OFFSET %%Q-DATA-TYPE CALLER 2) DTP-ONE-Q-FORWARD)
     960       (FBOUNDP CALLER)
     961       (FIND-CALLERS-OF-SYMBOLS-AUX1 CALLER (FSYMEVAL CALLER)))
     962  (COND (( (%P-LDB-OFFSET %%Q-DATA-TYPE CALLER 3) DTP-ONE-Q-FORWARD)
     963         ;; Also look for properties
     964         (DO ((L (PLIST CALLER) (CDDR L)))
     965             ((NULL L))
     966           (COND ((= (%DATA-TYPE (CADR L)) DTP-FEF-POINTER)
     967                  (FIND-CALLERS-OF-SYMBOLS-AUX-FEF
     968                    (LIST ':PROPERTY CALLER (CAR L)) (CADR L)))))
     969         ;; Also look for flavor methods
     970         (AND (SETQ FL (GET CALLER 'FLAVOR))
     971              (ARRAYP FL)               ;Could be T
     972              (DOLIST (MTE (FLAVOR-METHOD-TABLE FL))
     973                (DOLIST (METH (CDDDR MTE))
     974                  (IF (METH-DEFINEDP METH)
     975                      (FIND-CALLERS-OF-SYMBOLS-AUX1 (METH-FUNCTION-SPEC METH)
     976                                                    (METH-DEFINITION METH))))))
     977         ;; Also look for initializations
     978         (IF (GET CALLER 'INITIALIZATION-LIST)
     979             ;; It is an initialization list.
     980             (DOLIST (INIT-LIST-ENTRY (SYMEVAL CALLER))
     981               (FIND-CALLERS-OF-SYMBOLS-AUX-LIST CALLER (INIT-FORM INIT-LIST-ENTRY)))))))
     982
     983(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX1 (CALLER DEFN)
     984  ;; Don't be fooled by macros, interpreted or compiled.
     985  (AND (LISTP DEFN) (EQ (CAR DEFN) 'MACRO) (SETQ DEFN (CDR DEFN)))
     986  (COND ((LISTP DEFN)
     987         (FIND-CALLERS-OF-SYMBOLS-AUX-LIST CALLER DEFN))
     988        ((= (%DATA-TYPE DEFN) DTP-FEF-POINTER)
     989         (FIND-CALLERS-OF-SYMBOLS-AUX-FEF CALLER DEFN)))
     990  ;; If this function is traced, advised, etc.
     991  ;; then look through the actual definition.
     992  (LET* ((DEBUG-INFO (FUNCTION-DEBUGGING-INFO DEFN))
     993         (INNER (ASSQ 'SI:ENCAPSULATED-DEFINITION DEBUG-INFO)))
     994    (AND INNER (FIND-CALLERS-OF-SYMBOLS-AUX (CADR INNER)))))
    720995                 
    721 (DEFUN WHO-CALLS-AUX-FEF (CALLER FUNCTION DEFN &AUX TEM OFFSET SYM)
    722     (DO ((I %FEF-HEADER-LENGTH (1+ I))
    723          (LIM (// (FEF-INITIAL-PC DEFN) 2)))
    724         ((>= I LIM) NIL)
    725       (COND ((= (%P-LDB-OFFSET %%Q-DATA-TYPE DEFN I)
    726                 DTP-EXTERNAL-VALUE-CELL-POINTER)
    727              (SETQ TEM (%P-CONTENTS-AS-LOCATIVE-OFFSET DEFN I)
    728                    SYM (%FIND-STRUCTURE-HEADER TEM)
    729                    OFFSET (%POINTER-DIFFERENCE TEM SYM))
    730              (COND ((EQ FUNCTION 'UNBOUND-FUNCTION)
    731                     (COND ((AND (= OFFSET 2)
    732                                 (NOT (FBOUNDP SYM)))
    733                            (FORMAT STANDARD-OUTPUT "
    734 ~S calls ~S, which is currently an unbound function." CALLER SYM))))
    735                    ((EQ SYM FUNCTION)
    736                     (FORMAT T "~%~S ~A ~S."
    737                             CALLER
    738                             (NTH OFFSET '("gets the print name of"
    739                                           "uses"
    740                                           "calls"
    741                                           "gets the property list of"))
    742                             FUNCTION))))
    743             ((EQ (%P-CONTENTS-OFFSET DEFN I) FUNCTION)
    744              (FORMAT T "~%~S uses ~S as a constant." CALLER FUNCTION))))
    745     ;; See if we have a function reference compiled into a misc instruction
    746     ;; This won't work for LIST and LIST-IN-AREA
    747     (AND (FEF-CALLS-MISC-FUNCTION DEFN FUNCTION)
    748          (FORMAT STANDARD-OUTPUT "
    749 ~S calls ~S via a misc-instruction." CALLER FUNCTION)))
     996(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX-FEF (CALLER DEFN &AUX TEM OFFSET SYM)
     997  (DO ((I %FEF-HEADER-LENGTH (1+ I))
     998       (LIM (// (FEF-INITIAL-PC DEFN) 2)))
     999      ((>= I LIM) NIL)
     1000    (COND ((= (%P-LDB-OFFSET %%Q-DATA-TYPE DEFN I) DTP-EXTERNAL-VALUE-CELL-POINTER)
     1001           (SETQ TEM (%P-CONTENTS-AS-LOCATIVE-OFFSET DEFN I)
     1002                 SYM (%FIND-STRUCTURE-HEADER TEM)
     1003                 OFFSET (%POINTER-DIFFERENCE TEM SYM))
     1004           (COND ((NOT (SYMBOLP SYM)))
     1005                 ((= OFFSET 2)                  ;Function cell reference
     1006                  (IF (IF (ATOM SYMBOL) (EQ SYM SYMBOL) (MEMQ SYM SYMBOL))
     1007                      (FUNCALL FUNCTION CALLER SYM ':FUNCTION)
     1008                      (AND (IF (ATOM SYMBOL) (EQ ':UNBOUND-FUNCTION SYMBOL)
     1009                               (MEMQ ':UNBOUND-FUNCTION SYMBOL))
     1010                           (NOT (FBOUNDP SYM))
     1011                           (FUNCALL FUNCTION CALLER SYM ':UNBOUND-FUNCTION))))
     1012                 (T                             ;Value reference presumably
     1013                  (IF (IF (ATOM SYMBOL) (EQ SYM SYMBOL) (MEMQ SYM SYMBOL))
     1014                      (FUNCALL FUNCTION CALLER SYM ':VARIABLE)))))
     1015          ((SYMBOLP (SETQ SYM (%P-CONTENTS-OFFSET DEFN I)))
     1016           (IF (IF (ATOM SYMBOL) (EQ SYM SYMBOL) (MEMQ SYM SYMBOL))
     1017               (FUNCALL FUNCTION CALLER SYM ':CONSTANT)))))
     1018  ;; See if we have a function reference compiled into a misc instruction
     1019  ;; This won't work for LIST and LIST-IN-AREA
     1020  (IF (SYMBOLP SYMBOL)
     1021      (IF (FEF-CALLS-MISC-FUNCTION DEFN SYMBOL)
     1022          (FUNCALL FUNCTION CALLER SYMBOL ':MISC-FUNCTION))
     1023      (DOLIST (SYM SYMBOL)
     1024        (IF (FEF-CALLS-MISC-FUNCTION DEFN SYM)
     1025            (FUNCALL FUNCTION CALLER SYM ':MISC-FUNCTION))))
     1026  (AND (LDB-TEST %%FEFHI-MS-DEBUG-INFO-PRESENT
     1027                 (%P-CONTENTS-OFFSET DEFN %FEFHI-MISC))
     1028       (SETQ TEM (CDR (ASSQ ':INTERNAL-FEF-OFFSETS
     1029                            (%P-CONTENTS-OFFSET DEFN (1- (%P-LDB %%FEFH-PC-IN-WORDS DEFN))))))
     1030       (LOOP FOR OFFSET IN TEM
     1031             FOR I FROM 0
     1032             DO (FIND-CALLERS-OF-SYMBOLS-AUX-FEF `(:INTERNAL ,CALLER ,I)
     1033                                                 (%P-CONTENTS-OFFSET DEFN OFFSET)))))
    7501034
    7511035;;; See if this FEF uses a certain MISC instruction
     
    7651049               ((= INST LONGJUMP) (SETQ PC (1+ PC)))))))
    7661050
    767 ;;; Tree-walk CALLER looking for FUNCTION.  If it appears, print a message
    768 ;;; to that effect and stop looking.  CALLER should be the function name,
    769 ;;; and LIST should be its definition.
    770 
    771 (DEFUN WHO-CALLS-AUX-LIST (CALLER FUNCTION DEFN)
    772     (*CATCH 'WHO-CALLS (WHO-CALLS-AUX-LIST1 DEFN FUNCTION CALLER)))
    773 
    774 (DEFUN WHO-CALLS-AUX-LIST1 (SUBLIST FUNCTION CALLER)
    775     (COND ((SYMBOLP SUBLIST)
    776            (COND ((EQ SUBLIST FUNCTION)
    777                   (FORMAT T "~%~S, an interpreted function uses ~S somehow." CALLER FUNCTION)
    778                   (*THROW 'WHO-CALLS NIL))))
    779           ((LISTP SUBLIST)
    780            (WHO-CALLS-AUX-LIST1 (CAR SUBLIST) FUNCTION CALLER)
    781            (WHO-CALLS-AUX-LIST1 (CDR SUBLIST) FUNCTION CALLER))))
     1051;;; Tree-walk CALLER looking for FUNCTION.  CALLER should be the function name,
     1052;;; and DEFN should be its definition.  Avoids listing symbols twice.
     1053(LOCAL-DECLARE ((SPECIAL SUPPRESS))
     1054(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX-LIST (CALLER DEFN)
     1055  (LET ((SUPPRESS NIL))
     1056    (FIND-CALLERS-OF-SYMBOLS-AUX-LIST1 CALLER DEFN)))
     1057
     1058(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX-LIST1 (CALLER DEFN)
     1059  (DO ((L DEFN (CDR L)))
     1060      ((ATOM L))
     1061    (COND ((AND (SYMBOLP (CAR L))
     1062                (NOT (MEMQ (CAR L) SUPPRESS))
     1063                (IF (ATOM SYMBOL) (EQ (CAR L) SYMBOL) (MEMQ (CAR L) SYMBOL)))
     1064           (PUSH (CAR L) SUPPRESS)
     1065           (FUNCALL FUNCTION CALLER (CAR L) NIL))
     1066          ((LISTP (CAR L))
     1067           (FIND-CALLERS-OF-SYMBOLS-AUX-LIST1 CALLER (CAR L))))))
     1068);close inner LOCAL-DECLARE
     1069);close LOCAL-DECLARE
     1070
    7821071
    7831072(DEFUN %MAKE-PAGE-READ-ONLY (P)
     
    8231112        (OTHERWISE (FERROR NIL "The MAR mode, ~O, is invalid." MODE)))))
    8241113
    825 ; This function sets up a 4 by 220 table, useful for keyboard dispatches.
    826 ; The table is set up from a list of four elements, called rows: one for each
    827 ; setting of the buckey bits, as follows: 0 = none, 1 = control, 2 = meta, 3 = control-meta.
    828 ; Each row is walked down, and as each element is reached, it is stored in the array, unless
    829 ; its car is recognized as a special function.
    830 ; Currently implemented special functions are:
    831 ;     (*REPEAT <times> <thing) --  <thing> is stored <times> times.
    832 ;     (*REPEAT-EVAL <times> <thing>) -- like *REPEAT except that <thing> gets EVALed
    833 ;                              before being stored.  The special variable SI:RPCNT will
    834 ;                              be set to 0 on the first iteration and incremented by 1
    835 ;                              throughout, like a MIDAS repeat loop.
    836 
    837 (DECLARE (SPECIAL RPCNT))
    838 
    839 (DEFUN SETUP-KEYBOARD-DISPATCH-TABLE (TABLE LISTS &AUX ENTRY TEM)
    840    (DO ((LISTS1 LISTS (CDR LISTS1))
    841         (IDX1 0 (1+ IDX1)))
    842        ((NULL LISTS1))
    843      (DO ((LIST (CAR LISTS1) (CDR LIST))
    844           (IDX2 0))                               ;THE AMOUNT THIS IS INCREMENTED DEPENDS!!
    845          ((NULL LIST)
    846           (COND ((NOT (= IDX2 220))
    847                  (FERROR NIL "Row ~S was ~S long, instead of 220."
    848                          IDX1 IDX2))))
    849        (SETQ ENTRY (CAR LIST))
    850        (COND ((ATOM ENTRY)
    851               (AS-2 ENTRY TABLE IDX1 IDX2)
    852               (SETQ IDX2 (1+ IDX2)))
    853              ((EQ (FIRST ENTRY) ':REPEAT)
    854               (SETQ TEM (SECOND ENTRY))
    855               (SETQ ENTRY (THIRD ENTRY))
    856               (DO I 0 (1+ I) (= I TEM)
    857                 (AS-2 ENTRY TABLE IDX1 IDX2)
    858                 (SETQ IDX2 (1+ IDX2))))
    859              ((EQ (FIRST ENTRY) ':REPEAT-EVAL)
    860               (SETQ TEM (SECOND ENTRY))
    861               (SETQ ENTRY (THIRD ENTRY))
    862               (DO RPCNT 0 (1+ RPCNT) (= RPCNT TEM)
    863                 (AS-2 (EVAL ENTRY) TABLE IDX1 IDX2)
    864                 (SETQ IDX2 (1+ IDX2))))
    865              ((EQ (FIRST ENTRY) ':EVAL)
    866               (AS-2 (EVAL (SECOND ENTRY)) TABLE IDX1 IDX2)
    867               (SETQ IDX2 (1+ IDX2)))
    868              (T
    869               (AS-2 ENTRY TABLE IDX1 IDX2)
    870               (SETQ IDX2 (1+ IDX2)))))))
    871 
    872 (DEFUN YES-OR-NO-P (&OPTIONAL MESSAGE (STREAM QUERY-IO))
    873     (COND ((AND MESSAGE (NOT (STRINGP MESSAGE)))
    874            ;; Temporary compatibility feature.
    875            (COND ((STRINGP STREAM)
    876                   (PSETQ MESSAGE STREAM STREAM MESSAGE))
    877                  (T (SETQ STREAM MESSAGE MESSAGE NIL)))))
    878     (PROG (STRING)
    879        (AND MESSAGE (FORMAT STREAM "~&~A" MESSAGE))
    880      RETRY
    881        (SETQ STRING (STRING-UPCASE (STRING-TRIM '(40 211 42 56) ;sp, tab, dot, double-quote
    882                                                 (READLINE STREAM))))
    883        (COND ((EQUAL STRING "YES")
    884               (RETURN T))
    885              ((EQUAL STRING "NO")
    886               (RETURN NIL))
    887              (T (AND MESSAGE (FORMAT STREAM "~&~A" MESSAGE))
    888                 (FORMAT STREAM "Please type /"Yes/" or /"No/". ")
    889                 (GO RETRY)))))
    890 
    8911114(DEFUN PAIRLIS (VARS VALS &AUX ALST)
    8921115       (SETQ ALST (MAKE-LIST DEFAULT-CONS-AREA (LENGTH VARS)))
     
    9541177    (BIND (VALUE-CELL-LOCATION (CAR VARS)) (CAR VALS))))
    9551178
     1179;;; (PROGW '((VAR-1 VAL-1) (VAR-2 VAL-2) ... (VAR-N VAL-N)) &BODY BODY)
     1180;;; Binds VAR-I to VAL-I (evaluated) during execution of BODY
     1181(DEFUN PROGW (VARS-AND-VALS &QUOTE &REST STUFF)
     1182  (DO-NAMED PROGW
     1183      ((VARS-AND-VALS VARS-AND-VALS (CDR VARS-AND-VALS)))
     1184      ((NULL VARS-AND-VALS)
     1185       (DO ((STUFF STUFF (CDR STUFF)))
     1186           (NIL)
     1187         (IF (NULL (CDR STUFF))
     1188             (RETURN-FROM PROGW (EVAL (CAR STUFF)))
     1189             (EVAL (CAR STUFF)))))
     1190    (BIND (VALUE-CELL-LOCATION (CAAR VARS-AND-VALS))
     1191          (EVAL (CADAR VARS-AND-VALS)))))
     1192
     1193;;; (LET-IF <COND> ((VAR-1 VAL-1) (VAR-2 VAL-2) ... (VAR-N VAL-N)) &BODY BODY)
     1194;;; If <COND> is not nil, binds VAR-I to VAL-I (evaluated) during execution of BODY,
     1195;;; otherwise just evaluates BODY.
     1196(DEFUN LET-IF (COND &QUOTE VAR-LIST &QUOTE &REST STUFF)
     1197  (PROGW (AND COND VAR-LIST)
     1198     (DO ((STUFF STUFF (CDR STUFF)))
     1199         (NIL)
     1200       (IF (NULL (CDR STUFF))
     1201           (RETURN (EVAL (CAR STUFF)))
     1202           (EVAL (CAR STUFF))))))
     1203
     1204;Interpreter version of UNWIND-PROTECT
     1205;(UNWIND-PROTECT risky-stuff forms-to-do-when-unwinding-this-frame...)
     1206;If risky-stuff returns, we return what it returns, doing forms-to-do
     1207;(just as PROG1 would do).  If risky-stuff does a throw, we let the throw
     1208;function as specified, but make sure that forms-to-do get done as well.
     1209(DEFUN UNWIND-PROTECT (&QUOTE BODY-FORM &REST CLEANUP-FORMS)
     1210  (UNWIND-PROTECT (EVAL BODY-FORM)
     1211    (DOLIST (FORM CLEANUP-FORMS)
     1212      (EVAL FORM))))
    9561213
    9571214
    9581215;;; This should really be fixed to expand more than just top level functions.
    959 (DEFUN MEXP NIL
     1216(DEFUN MEXP ()
    9601217    (DO ((TEM))
    9611218        (())
    9621219      (FORMAT T "~2%Macro form ")
    963       (SETQ TEM (READ-FOR-TOP-LEVEL))
    964       (AND (SYMBOLP TEM) (RETURN NIL))
    965       (DO EXP (MACROEXPAND-1 TEM) (MACROEXPAND-1 EXP) (EQ EXP TEM)
    966         ;(FORMAT T " ~S" (SETQ TEM EXP))
    967         (PRINC " ")
    968         (GRIND-TOP-LEVEL (SETQ TEM EXP))
    969         )))
    970 
    971 
    972 ;; STATUS AND SSTATUS
    973 
    974 (DECLARE (SPECIAL STATUS-FEATURE-LIST STATUS-STATUS-LIST STATUS-SSTATUS-LIST))
    975 
    976 ;;; These symbols are all on KWDPKG.
    977 (SETQ STATUS-FEATURE-LIST
    978       '(SORT FASLOAD STRING NEWIO ROMAN TRACE GRINDEF GRIND LISPM))
    979 
    980 (SETQ STATUS-STATUS-LIST '(FEATURE FEATURES NOFEATURE STATUS SSTATUS TABSIZE USERID))
    981 
    982 (SETQ STATUS-SSTATUS-LIST '(FEATURE NOFEATURE))
    983 
    984 (DEFUN RETURN-STATUS (STATUS-LIST ITEM)
    985        (COND ((NULL ITEM) STATUS-LIST)
    986              (T (NOT (NULL (MEMQ ITEM STATUS-LIST))))))
    987 
    988 (DEFUN STATUS (&QUOTE STATUS-FUNCTION &OPTIONAL ITEM)
    989        (SELECTQ STATUS-FUNCTION
    990                 ((FEATURE FEATURES) (RETURN-STATUS STATUS-FEATURE-LIST ITEM))
    991                 (NOFEATURE (COND ((NULL ITEM)
    992                                   (FERROR NIL "Too few args to STATUS NOFEATURE"))
    993                                  (T (NOT (RETURN-STATUS STATUS-FEATURE-LIST ITEM)))))
    994                 (STATUS (RETURN-STATUS STATUS-STATUS-LIST ITEM))
    995                 (SSTATUS (RETURN-STATUS STATUS-SSTATUS-LIST ITEM))
    996                 (TABSIZE 8)
    997                 (USERID USER-ID)
    998                 (OTHERWISE (FERROR NIL "~S is not a legal STATUS request" STATUS-FUNCTION))))
    999 
    1000 (DEFUN SSTATUS (&QUOTE STATUS-FUNCTION ITEM)
    1001        (SELECTQ STATUS-FUNCTION
    1002                 (FEATURE (COND ((NOT (MEMQ ITEM STATUS-FEATURE-LIST))
    1003                                 (SETQ STATUS-FEATURE-LIST
    1004                                       (CONS ITEM STATUS-FEATURE-LIST))))
    1005                                  ITEM)
    1006                 (NOFEATURE (COND ((MEMQ ITEM STATUS-FEATURE-LIST)
    1007                                   (SETQ STATUS-FEATURE-LIST
    1008                                         (DELQ ITEM STATUS-FEATURE-LIST))))
    1009                                    ITEM)
    1010                 (OTHERWISE (FERROR NIL "~S is not a legal SSTATUS request" STATUS-FUNCTION))))
    1011 
    1012 ;;; Describe all files "related" to this file name
    1013 (DEFUN DESCRIBE-FILE (FILE-NAME &AUX USER-FILE-SYMBOL QFASL-FILE-SYMBOL FILE-GROUP-SYMBOL)
    1014   (SETQ FILE-NAME (FS:FILE-PARSE-NAME FILE-NAME))
    1015   (SETQ USER-FILE-SYMBOL (INTERN-LOCAL-SOFT (FUNCALL FILE-NAME ':STRING-FOR-PRINTING)
    1016                                             PKG-FILE-PACKAGE))
    1017   (MULTIPLE-VALUE (QFASL-FILE-SYMBOL FILE-GROUP-SYMBOL)
    1018     (FS:GET-FILE-SYMBOLS (FUNCALL FILE-NAME ':COPY-WITH-TYPE ':QFASL)))
    1019   (AND USER-FILE-SYMBOL (DESCRIBE-FILE-1 USER-FILE-SYMBOL))
    1020   (AND (NEQ QFASL-FILE-SYMBOL USER-FILE-SYMBOL) (DESCRIBE-FILE-1 QFASL-FILE-SYMBOL))
    1021   (AND (NEQ FILE-GROUP-SYMBOL USER-FILE-SYMBOL) (DESCRIBE-FILE-1 FILE-GROUP-SYMBOL))
    1022   NIL)
    1023 
    1024 ;;; Describe a particular file-symbol
    1025 (DEFUN DESCRIBE-FILE-1 (FILE-SYMBOL &AUX TEM IDX VERSION CREATION-DATE)
    1026   (AND (SETQ TEM (GET FILE-SYMBOL ':PACKAGE))
    1027        (FORMAT STANDARD-OUTPUT "~%File ~A is in package ~A." FILE-SYMBOL TEM))
    1028   (DOLIST (PKG-ID (GET FILE-SYMBOL ':FILE-ID-PACKAGE-ALIST))
    1029     (SETQ TEM (CADR PKG-ID))    ;The FILE-ID for this package
    1030     (SETQ IDX (STRING-SEARCH-CHAR #\SP TEM))
    1031     (SETQ VERSION (SUBSTRING TEM 0 IDX)
    1032           CREATION-DATE (NSUBSTRING TEM (1+ IDX) (STRING-LENGTH TEM)))
    1033     (COND ((EQUAL VERSION "-1")
    1034            (FORMAT STANDARD-OUTPUT "~%Version of file ~A in package ~A was created ~A."
    1035                                         FILE-SYMBOL (CAR PKG-ID) CREATION-DATE))
    1036           ((FORMAT STANDARD-OUTPUT "~%Version of file ~A in package ~A is ~A, created ~A."
    1037                                         FILE-SYMBOL (CAR PKG-ID) VERSION CREATION-DATE))))
    1038   NIL)
    1039 
     1220      (FUNCALL STANDARD-INPUT ':UNTYI (FUNCALL STANDARD-INPUT ':TYI))   ;Allow abort to exit
     1221      (*CATCH 'COMMAND-LEVEL            ;Stay in mexp if abort out of input, **more**
     1222        (SETQ TEM (READ-FOR-TOP-LEVEL))
     1223        (AND (SYMBOLP TEM) (RETURN NIL))
     1224        (DO EXP (MACROEXPAND-1 TEM) (MACROEXPAND-1 EXP) (EQ EXP TEM)
     1225          ;(FORMAT T " ~S" (SETQ TEM EXP))
     1226          (PRINC " ")
     1227          (GRIND-TOP-LEVEL (SETQ TEM EXP))
     1228          ))))
     1229
     1230
     1231;; STATUS and SSTATUS
     1232;; Note that these have to be Maclisp compatible and therefore have to work
     1233;; independent of packages.  All symbols on feature lists are in the keyword package.
     1234
     1235(DEFVAR STATUS-FEATURE-LIST
     1236        '(:SORT :FASLOAD :STRING :NEWIO :ROMAN :TRACE :GRINDEF :GRIND :LISPM))
     1237
     1238(DEFVAR STATUS-STATUS-LIST '(:FEATURE :FEATURES :NOFEATURE :STATUS :SSTATUS :TABSIZE
     1239                             :USERID :SITE :OPSYS))
     1240
     1241(DEFVAR STATUS-SSTATUS-LIST '(:FEATURE :NOFEATURE))
     1242
     1243(DEFUN RETURN-STATUS (STATUS-LIST ITEM ITEM-P)
     1244       (COND ((NOT ITEM-P) STATUS-LIST)
     1245             (T (NOT (NULL (MEM #'STRING-EQUAL ITEM STATUS-LIST))))))
     1246
     1247(DEFUN STATUS (&QUOTE STATUS-FUNCTION &OPTIONAL (ITEM NIL ITEM-P))
     1248  (SELECTOR STATUS-FUNCTION STRING-EQUAL
     1249    (('FEATURE 'FEATURES) (RETURN-STATUS STATUS-FEATURE-LIST ITEM ITEM-P))
     1250    (('NOFEATURE) (COND ((NOT ITEM-P)
     1251                         (FERROR NIL "Too few args to STATUS NOFEATURE"))
     1252                        (T (NOT (RETURN-STATUS STATUS-FEATURE-LIST ITEM ITEM-P)))))
     1253    (('STATUS) (RETURN-STATUS STATUS-STATUS-LIST ITEM ITEM-P))
     1254    (('SSTATUS) (RETURN-STATUS STATUS-SSTATUS-LIST ITEM ITEM-P))
     1255    (('TABSIZE) 8)
     1256    (('USERID) USER-ID)
     1257    (('SITE) LOCAL-HOST-NAME)
     1258    (('OPSYS) ':LISPM)
     1259    (OTHERWISE (FERROR NIL "~S is not a legal STATUS request" STATUS-FUNCTION))))
     1260
     1261(DEFUN SSTATUS (&QUOTE STATUS-FUNCTION ITEM
     1262                &AUX (DEFAULT-CONS-AREA WORKING-STORAGE-AREA))
     1263  (SETQ ITEM (INTERN (STRING ITEM) ""))         ;These are all keywords
     1264  (SELECTOR STATUS-FUNCTION STRING-EQUAL
     1265    (('FEATURE) (COND ((NOT (MEMQ ITEM STATUS-FEATURE-LIST))
     1266                       (SETQ STATUS-FEATURE-LIST
     1267                             (CONS ITEM STATUS-FEATURE-LIST))))
     1268                ITEM)
     1269    (('NOFEATURE) (COND ((MEMQ ITEM STATUS-FEATURE-LIST)
     1270                         (SETQ STATUS-FEATURE-LIST
     1271                               (DELQ ITEM STATUS-FEATURE-LIST))))
     1272                  ITEM)
     1273    (OTHERWISE (FERROR NIL "~S is not a legal SSTATUS request" STATUS-FUNCTION))))
     1274
     1275;The ADD-OPTIMIZER for this is in QCOPT, so that things work in the cold-load
     1276(DEFUN STATUS-OPTIMIZER (FORM)
     1277  (LET ((STATUS-FUNCTION (CADR FORM))
     1278        ;(ITEM (CADDR FORM))
     1279        (ITEM-P (CDDR FORM)))
     1280    (SELECTOR STATUS-FUNCTION STRING-EQUAL
     1281      (('FEATURE 'FEATURES) (IF ITEM-P FORM `STATUS-FEATURE-LIST))
     1282      (('TABSIZE) `8)
     1283      (('USERID) `USER-ID)
     1284      (('SITE) `LOCAL-HOST-NAME)
     1285      (('OPSYS) `':LISPM)
     1286      (OTHERWISE (OR (MEM #'STRING-EQUAL STATUS-FUNCTION STATUS-STATUS-LIST)
     1287                     (COMPILER:BARF FORM "Unknown STATUS function" 'COMPILER:WARN))
     1288                 FORM))))
     1289
     1290
     1291;;; Site stuff
     1292(DEFVAR SITE-NAME)                              ;Setup by the cold load generator
     1293(DEFVAR SITE-OPTION-ALIST NIL)
     1294
     1295;;; This function is used to change the site in an already build world load.
     1296;;; NEW-SITE is the site keyword, such as :MIT.
     1297;;; SYS-HOST is the host that should be used as SYS: for loading the new site declaration.
     1298;;; SYS-DIRECTORY is the directory to be used to getting the SITE file if this system
     1299;;; doesn't follow the same directory naming convention as the original.
     1300;;; HOST-TABLE-BOOTSTRAP is a filename to be loaded.  This is necessary either
     1301;;; if SYS: is to point at a host not currently in the host table, or if there
     1302;;; are file server hosts which are not SYS:.
     1303(DEFUN SET-SITE (NEW-SITE &OPTIONAL SYS-HOST SYS-DIRECTORY HOST-TABLE-BOOTSTRAP)
     1304  (SETQ STATUS-FEATURE-LIST (CONS NEW-SITE (DELQ SITE-NAME STATUS-FEATURE-LIST)))
     1305  (SETQ SITE-NAME NEW-SITE)
     1306  (AND HOST-TABLE-BOOTSTRAP (LOAD HOST-TABLE-BOOTSTRAP))
     1307  (COND (SYS-HOST
     1308         (FS:CHANGE-LOGICAL-PATHNAME-HOST "SYS" SYS-HOST)
     1309         (SETQ SYS-HOST (FS:GET-PATHNAME-HOST SYS-HOST)))
     1310        (T
     1311         (LET ((SYS-LOGICAL-HOST (FS:GET-PATHNAME-HOST "SYS")))
     1312           (AND SYS-LOGICAL-HOST (SETQ SYS-HOST (FUNCALL SYS-LOGICAL-HOST ':HOST))))))
     1313  (AND SYS-HOST (FUNCALL SYS-HOST ':SET-SITE NEW-SITE))
     1314  (AND SYS-DIRECTORY (FS:CHANGE-LOGICAL-PATHNAME-DIRECTORY "SYS" "SYS" SYS-DIRECTORY))
     1315  (MAYBE-MINI-LOAD-FILE-ALIST SITE-FILE-ALIST)
     1316  (INITIALIZATIONS 'SITE-INITIALIZATION-LIST T))
     1317
     1318(DEFMACRO DEFSITE (SITE &BODY OPTIONS)
     1319  `(DEFSITE-1 ',SITE ',OPTIONS))
     1320
     1321(DEFUN DEFSITE-1 (SITE OPTIONS)
     1322  (AND (EQ SITE SITE-NAME)
     1323       (SETQ SITE-OPTION-ALIST (LOOP FOR (KEY EXP) IN OPTIONS
     1324                                     COLLECT `(,KEY . ,(EVAL EXP))))))
     1325
     1326(DEFUN GET-SITE-OPTION (KEY)
     1327  (CDR (ASSQ KEY SITE-OPTION-ALIST)))
     1328
     1329(DEFMACRO DEFINE-SITE-VARIABLE (VAR KEY)
     1330  `(PROGN 'COMPILE
     1331     (DEFVAR ,VAR)
     1332     (ADD-INITIALIZATION ,(FORMAT NIL "SITE:~A" VAR)
     1333                         `(SETQ ,',VAR (GET-SITE-OPTION ',',KEY))
     1334                         '(SITE))))
     1335
     1336(DEFMACRO DEFINE-SITE-HOST-LIST (VAR KEY)
     1337  `(PROGN 'COMPILE
     1338     (DEFVAR ,VAR)
     1339     (ADD-INITIALIZATION ,(FORMAT NIL "SITE:~A" VAR)
     1340                         `(SETQ ,',VAR (MAPCAR 'PARSE-HOST (GET-SITE-OPTION ',',KEY)))
     1341                         '(SITE))))
     1342
     1343;;; This NORMAL is so that it doesn't happen right away before enough is loaded to work.
     1344(ADD-INITIALIZATION "HOST-TABLE-INITIALIZATION"
     1345                    '(MAYBE-MINI-LOAD-FILE-ALIST HOST-TABLE-FILE-ALIST) '(SITE NORMAL))
     1346
     1347;;; Interfaces to chaosnet physical support facilities
     1348(DEFUN CALL-ELEVATOR ()
     1349  (COND ((TECH-SQUARE-FLOOR-P 8)
     1350         (CHAOS:HACK-DOOR "8"))
     1351        ((TECH-SQUARE-FLOOR-P 9)
     1352         (CHAOS:HACK-DOOR "9"))
     1353        (T (TV:NOTIFY NIL "I don't know how to get an elevator to your location."))))
     1354
     1355(DEFUN BUZZ-DOOR ()
     1356  (COND ((TECH-SQUARE-FLOOR-P 9) (CHAOS:HACK-DOOR "D"))
     1357        (T (TV:NOTIFY NIL "I can only open the 9th floor door at Tech square"))))
     1358
     1359(DEFUN TECH-SQUARE-FLOOR-P (FLOOR)
     1360  (AND LOCAL-FLOOR-LOCATION
     1361       (EQ (FIRST LOCAL-FLOOR-LOCATION) 'MIT-NE43)
     1362       (= (SECOND LOCAL-FLOOR-LOCATION) FLOOR)))
     1363
     1364
     1365;;; Stuff for function specs
    10401366
    10411367;These are here because they must be loaded after the package system is operational
    1042 
    1043 ;; Give the function definition corresponding to a function specifier.
    1044 ;; A function-specifier is just a way of talking about a function
    1045 ;; for purposes other than applying it.  It can be a symbol, in which case
    1046 ;; the function cell of the symbol is used.  Or it can be a list of one of
    1047 ;; these formats:
    1048 ;; (:METHOD class-name operation) refers to the method in that class for
    1049 ;;   that operation; this works for both Class methods and Flavor methods.
    1050 ;;   In the case of Flavor methods, the specification may also be of the form
    1051 ;;   (:METHOD flavor-name time operation).
    1052 ;; (:INSTANCE-METHOD exp operation).  exp should evaluate to an DTP-INSTANCE.
    1053 ;;   Reference is then to the operation directly on that instance.
    1054 ;; (:PROPERTY symbol property) refers to (GET symbol property).
    1055 ;; One place you can use a function specifier is in DEFUN.
    1056 ;; Because of this, for Maclisp compatibility, a list whose car is
    1057 ;; not recognized is taken to be a list of a symbol and a property.
    1058 
    1059 (DEFUN FDEFINITION (FUNCTION-SPEC)
    1060     (PROG ()
    1061           (CHECK-ARG FUNCTION-SPEC (OR (LISTP FUNCTION-SPEC) (SYMBOLP FUNCTION-SPEC))
    1062                      "a list or a symbol")
    1063           (AND (SYMBOLP FUNCTION-SPEC)
    1064                (RETURN (FSYMEVAL FUNCTION-SPEC)))
    1065           (RETURN
    1066             (SELECTQ (CAR FUNCTION-SPEC)
    1067               (:METHOD
    1068                  (COND ((GET (CADR FUNCTION-SPEC) 'FLAVOR)
    1069                         (FSYMEVAL (FLAVOR-METHOD-SYMBOL FUNCTION-SPEC)))
    1070                        ((FSYMEVAL
    1071                          (<- (SYMEVAL (CADR FUNCTION-SPEC))
    1072                              ':METHOD-FOR
    1073                              (CADDR FUNCTION-SPEC))))))
    1074               (:INSTANCE-METHOD (<- (CLASS (EVAL (CADR FUNCTION-SPEC)))
    1075                                     ':METHOD-FOR
    1076                                     (CADDR FUNCTION-SPEC)))
    1077               (:PROPERTY (APPLY 'GET (CDR FUNCTION-SPEC)))
    1078               (OTHERWISE (APPLY 'GET FUNCTION-SPEC))))))
    1079 
    1080 ;; Is a function specifier defined?  A generalization of FBOUNDP.
    1081 (DEFUN FDEFINEDP (FUNCTION-SPEC)
    1082     (COND ((SYMBOLP FUNCTION-SPEC)
    1083            (FBOUNDP FUNCTION-SPEC))
    1084           ((EQ (CAR FUNCTION-SPEC) ':METHOD)
    1085            (COND ((GET (CADR FUNCTION-SPEC) 'FLAVOR)
    1086                   (FBOUNDP (FLAVOR-METHOD-SYMBOL FUNCTION-SPEC)))
    1087                  ((AND (BOUNDP (CADR FUNCTION-SPEC))
    1088                        (<- (SYMEVAL (CADR FUNCTION-SPEC))
    1089                            ':METHOD-FOR
    1090                            (CADDR FUNCTION-SPEC))))))
    1091           ((EQ (CAR FUNCTION-SPEC) ':INSTANCE-METHOD)
    1092            (<- (CLASS (EVAL (CADR FUNCTION-SPEC)))
    1093                ':METHOD-FOR
    1094                (CADDR FUNCTION-SPEC)))
    1095           (T (FDEFINITION FUNCTION-SPEC))))  ;Assumed to be property list
    1096 
    1097 (DECLARE (SPECIAL FDEFINE-FILE-SYMBOL INHIBIT-FDEFINE-WARNINGS))
    1098 ;(OR (BOUNDP 'FDEFINE-FILE-SYMBOL)  ;This loses since FASLOAD binds this variable.
    1099 ;    (SETQ FDEFINE-FILE-SYMBOL NIL))
    1100 (OR (BOUNDP 'INHIBIT-FDEFINE-WARNINGS)
    1101     (SETQ INHIBIT-FDEFINE-WARNINGS NIL))
    1102 
    1103 (DEFUN FDEFINE (FUNCTION-SPEC DEFINITION &OPTIONAL CAREFULLY-FLAG FORCE-FLAG
    1104                 &AUX TEM TEM1 (PACKAGE-PROBLEM NIL) (MULTI-FILE-PROBLEM NIL))
    1105 "Alter the function definition of a function specifier.
    1106 CAREFULLY-FLAG means save the old definition, when possible,
    1107 and query about crossing package lines (but FORCE-FLAG inhibits this).
    1108 If FDEFINE-FILE-SYMBOL is non-NIL, then it is the file which this definition
    1109 was read from, and we make a note of that fact when possible."
    1110   (PROG FDEFINE ()
    1111     (CHECK-ARG FUNCTION-SPEC (OR (LISTP FUNCTION-SPEC) (SYMBOLP FUNCTION-SPEC))
    1112                "a list or a symbol")
    1113     (COND ((SYMBOLP FUNCTION-SPEC)
    1114            (OR FORCE-FLAG (NOT CAREFULLY-FLAG)
    1115                INHIBIT-FDEFINE-WARNINGS
    1116                (NULL (SETQ TEM (CDR (PACKAGE-CELL-LOCATION FUNCTION-SPEC))))
    1117                (EQ TEM PACKAGE)
    1118                (EQ (SETQ TEM1 (PKG-EXTERNAL-LIST PACKAGE)) T)
    1119                (MEM #'STRING-EQUAL FUNCTION-SPEC TEM1)
    1120                (SETQ PACKAGE-PROBLEM TEM))
    1121            ;; Save previous definition if desired and there was one.
    1122            (COND ((AND CAREFULLY-FLAG (FBOUNDP FUNCTION-SPEC))
    1123                   (SETQ TEM (FSYMEVAL FUNCTION-SPEC))
    1124                   ;; If it's traced, get the pre-traced definition to save.
    1125                   (ERRSET
    1126                     (AND (LISTP TEM) (EQ (CAR TEM) 'NAMED-LAMBDA)
    1127                          (LISTP (CADR TEM))
    1128                          (ASSQ 'TRACE (CDADR TEM))
    1129                          (SETQ TEM (FDEFINITION (CADR (ASSQ 'TRACE (CDADR TEM))))))
    1130                     NIL)
    1131                   (AND (LISTP TEM)
    1132                        (NOT (AND (EQ (CAR TEM) 'MACRO)
    1133                                  (= (%DATA-TYPE (CDR TEM)) DTP-FEF-POINTER)))
    1134                        (PUTPROP FUNCTION-SPEC TEM ':PREVIOUS-EXPR-DEFINITION))
    1135                   (PUTPROP FUNCTION-SPEC TEM ':PREVIOUS-DEFINITION)))
    1136            (AND (BOUNDP 'FDEFINE-FILE-SYMBOL)  ;Just initializing it doesnt win since it is
    1137                 FDEFINE-FILE-SYMBOL            ; bound by FASLOAD.
    1138                 (FBOUNDP 'FORMAT)              ;dont bomb during cold load
    1139                                                ; (redefining accessor methods)
    1140                 (SETQ TEM (GET FUNCTION-SPEC ':SOURCE-FILE-NAME))
    1141                 (NEQ TEM FDEFINE-FILE-SYMBOL)
    1142                 (NOT (MEMQ TEM (GET FDEFINE-FILE-SYMBOL ':REDEFINES-FILES)))
    1143                 (NOT INHIBIT-FDEFINE-WARNINGS)
    1144                 (SETQ MULTI-FILE-PROBLEM TEM))
    1145            ;; If there are any problems, consult the user before proceeding
    1146            (COND ((OR PACKAGE-PROBLEM MULTI-FILE-PROBLEM)
    1147                   (FORMAT QUERY-IO
    1148 "~&WARNING: Function ~S being illegally ~:[~;re~]defined~:[~; by file ~:*~A~].
    1149 ~:[~;The function belongs to the ~:*~A package.~]~
    1150 ~:[~;~&It was previously defined by file ~:*~A.~]  OK? (type Y, N, E, or P) "
    1151                           FUNCTION-SPEC (FBOUNDP FUNCTION-SPEC) FDEFINE-FILE-SYMBOL
    1152                           PACKAGE-PROBLEM MULTI-FILE-PROBLEM)
    1153                   (FUNCALL QUERY-IO ':CLEAR-INPUT)
    1154                   (DO () (NIL)
    1155                     (SELECTQ (CHAR-UPCASE (FUNCALL QUERY-IO ':TYI))
    1156                       ((#/Y #/T #\SP) (PRINC "Yes." QUERY-IO) (RETURN))
    1157                       ((#/E) (PRINC "Error." QUERY-IO)
    1158                              (RETURN (FDEFINE (CERROR T NIL ':ILLEGAL-FUNCTION-DEFINITION
    1159  "Function ~S being illegally ~:[~;re~]defined~:[~; by file ~:*~A~].
    1160 ~:[~;The function belongs to the ~:*~A package.~]~
    1161 ~:[~;~&It was previously defined by file ~:*~A.~]"
    1162                                                       FUNCTION-SPEC (FBOUNDP FUNCTION-SPEC)
    1163                                                       FDEFINE-FILE-SYMBOL
    1164                                                       PACKAGE-PROBLEM MULTI-FILE-PROBLEM)
    1165                                               DEFINITION CAREFULLY-FLAG FORCE-FLAG)))
    1166                       ((#/N #\RUBOUT) (PRINC "No." QUERY-IO) (RETURN-FROM FDEFINE NIL))
    1167                       (#/P (PRINC "Proceed." QUERY-IO)
    1168                            (AND MULTI-FILE-PROBLEM
    1169                                 (PUSH MULTI-FILE-PROBLEM
    1170                                       (GET FDEFINE-FILE-SYMBOL ':REDEFINES-FILES)))
    1171                            (RETURN))
    1172                       ((#/? #\HELP) (PRINC "
     1368;(or maybe only because they aren't needed in the cold load?)
     1369
     1370;This is useful for sorting function specs
     1371(DEFUN FUNCTION-SPEC-LESSP (FS1 FS2)
     1372  (STRING-LESSP (IF (SYMBOLP FS1) FS1 (SECOND FS1))
     1373                (IF (SYMBOLP FS2) FS2 (SECOND FS2))))
     1374
     1375(DEFUN FUNDEFINE (FUNCTION-SPEC &AUX TYPE)
     1376  "Makes a function spec not have a function definition"
     1377  ;; First, validate the function spec and determine its type
     1378  (CHECK-ARG FUNCTION-SPEC
     1379             (SETQ TYPE (VALIDATE-FUNCTION-SPEC FUNCTION-SPEC))
     1380             "a symbol or a function-spec list")
     1381  (IF (SYMBOLP FUNCTION-SPEC) (FMAKUNBOUND FUNCTION-SPEC)
     1382      (FUNCALL (GET TYPE 'FUNCTION-SPEC-HANDLER) 'FUNDEFINE FUNCTION-SPEC)))
     1383
     1384(DEFUN FDEFINITION-LOCATION (FUNCTION-SPEC &AUX TYPE)
     1385  "Returns a locative pointer to the cell containing the function spec's definition"
     1386  ;; First, validate the function spec and determine its type
     1387  (CHECK-ARG FUNCTION-SPEC
     1388             (SETQ TYPE (VALIDATE-FUNCTION-SPEC FUNCTION-SPEC))
     1389             "a symbol or a function-spec list")
     1390  (IF (SYMBOLP FUNCTION-SPEC) (LOCF (FSYMEVAL FUNCTION-SPEC))
     1391      (FUNCALL (GET TYPE 'FUNCTION-SPEC-HANDLER) 'FDEFINITION-LOCATION FUNCTION-SPEC)))
     1392
     1393(DEFUN FUNCTION-PARENT (FUNCTION-SPEC &AUX TYPE DEF TEM)
     1394  (DECLARE (RETURN-LIST NAME TYPE))
     1395  "Returns NIL or the name of another definition which has the same source code.
     1396The second value is the type of that definition (which can be NIL).
     1397This is used for things like internal functions, methods automatically
     1398created by a defflavor, and macros automatically created by a defstruct."
     1399  ;; First, validate the function spec and determine its type
     1400  (CHECK-ARG FUNCTION-SPEC
     1401             (SETQ TYPE (VALIDATE-FUNCTION-SPEC FUNCTION-SPEC))
     1402             "a symbol or a function-spec list")
     1403  (COND ((AND (FDEFINEDP FUNCTION-SPEC)
     1404              (SETQ TEM (CDR (ASSQ 'FUNCTION-PARENT
     1405                                   (DEBUGGING-INFO (SETQ DEF (FDEFINITION FUNCTION-SPEC)))))))
     1406         (VALUES (CAR TEM) (CADR TEM)))
     1407        ((AND (LISTP DEF) (EQ (CAR DEF) 'MACRO) (SYMBOLP (CDR DEF))  ;for DEFSTRUCT
     1408              (SETQ DEF (GET (CDR DEF) 'MACROEXPANDER-FUNCTION-PARENT)))
     1409         (FUNCALL DEF FUNCTION-SPEC))
     1410        ((NOT (SYMBOLP FUNCTION-SPEC))
     1411         (FUNCALL (GET TYPE 'FUNCTION-SPEC-HANDLER) 'FUNCTION-PARENT FUNCTION-SPEC))))
     1412
     1413;; (:LOCATION locative-or-list-pointer) refers to the CDR of the pointer.
     1414;; This is for pointing at an arbitrary place which there is no special
     1415;; way to describe.
     1416(DEFPROP :LOCATION LOCATION-FUNCTION-SPEC-HANDLER FUNCTION-SPEC-HANDLER)
     1417(DEFUN LOCATION-FUNCTION-SPEC-HANDLER (FUNCTION FUNCTION-SPEC &OPTIONAL ARG1 ARG2)
     1418  (LET ((LOC (SECOND FUNCTION-SPEC)))
     1419    (SELECTQ FUNCTION
     1420      (VALIDATE-FUNCTION-SPEC (AND (= (LENGTH FUNCTION-SPEC) 2)
     1421                                   (OR (= (%DATA-TYPE LOC) DTP-LOCATIVE)
     1422                                       (= (%DATA-TYPE LOC) DTP-LIST))))
     1423      (FDEFINE (RPLACD LOC ARG1))
     1424      (FDEFINITION (CDR LOC))
     1425      (FDEFINEDP (AND ( (%P-DATA-TYPE LOC) DTP-NULL) (NOT (NULL (CDR LOC)))))
     1426      (FDEFINITION-LOCATION LOC)
     1427        ;FUNDEFINE could store DTP-NULL, which would only be right sometimes
     1428      (OTHERWISE (FUNCTION-SPEC-DEFAULT-HANDLER FUNCTION FUNCTION-SPEC ARG1 ARG2)))))
     1429
     1430;Convert old Maclisp-style property function specs
     1431(DEFUN STANDARDIZE-FUNCTION-SPEC (FUNCTION-SPEC)
     1432  (AND (LISTP FUNCTION-SPEC)
     1433       (= (LENGTH FUNCTION-SPEC) 2)
     1434       (SYMBOLP (CAR FUNCTION-SPEC))
     1435       (NOT (GET (CAR FUNCTION-SPEC) 'FUNCTION-SPEC-HANDLER))
     1436       (SETQ FUNCTION-SPEC (CONS ':PROPERTY FUNCTION-SPEC)))
     1437  (OR (VALIDATE-FUNCTION-SPEC FUNCTION-SPEC)
     1438      (FERROR NIL "~S is not a valid function spec" FUNCTION-SPEC))
     1439  FUNCTION-SPEC)
     1440
     1441(DEFPROP DEFUN "Function" DEFINITION-TYPE-NAME)
     1442(DEFPROP DEFVAR "Variable" DEFINITION-TYPE-NAME)
     1443
     1444;; Query about any irregularities about redefining the given function symbol now.
     1445;; Return T to tell caller to go ahead and redefine the symbol
     1446;; (no problems or user says ok), NIL to leave it unchanged.
     1447(DEFUN QUERY-ABOUT-REDEFINITION (FUNCTION-SPEC NEW-PATHNAME TYPE OLD-PATHNAME)
     1448  ;; Detect any cross-file redefinition worth complaining about.
     1449  (COND ((OR (EQ (IF (STRINGP OLD-PATHNAME) OLD-PATHNAME
     1450                     (FUNCALL OLD-PATHNAME ':TRANSLATED-PATHNAME))
     1451                 (IF (STRINGP NEW-PATHNAME) NEW-PATHNAME
     1452                     (FUNCALL NEW-PATHNAME ':TRANSLATED-PATHNAME)))
     1453             (MEMQ OLD-PATHNAME (FUNCALL NEW-PATHNAME ':GET ':REDEFINES-FILES)))
     1454         T)
     1455        (T
     1456         (FORMAT QUERY-IO
     1457"~&WARNING: ~A ~S being illegally redefined by file ~A.
     1458It was previously defined by file ~A."
     1459                 (OR (GET TYPE 'DEFINITION-TYPE-NAME) TYPE) FUNCTION-SPEC
     1460                 NEW-PATHNAME OLD-PATHNAME)
     1461         (COND ((EQ INHIBIT-FDEFINE-WARNINGS ':JUST-WARN))
     1462               (T
     1463                (FORMAT QUERY-IO " OK? (type Y, N, E, P or [HELP]) ")
     1464                (FUNCALL QUERY-IO ':CLEAR-INPUT)
     1465                (DO () (NIL)
     1466                  (SELECTQ (CHAR-UPCASE (FUNCALL QUERY-IO ':TYI))
     1467                    ((#/Y #/T #\SP)
     1468                     (PRINC "Yes." QUERY-IO)
     1469                     (RETURN T))
     1470                    ((#/E)
     1471                     (PRINC "Error." QUERY-IO)
     1472                     (CERROR T NIL ':ILLEGAL-FUNCTION-DEFINITION
     1473                       "~A ~S being illegally redefined by file ~A.
     1474It was previously defined by file ~A."
     1475                             (OR (GET TYPE 'DEFINITION-TYPE-NAME) TYPE) FUNCTION-SPEC
     1476                             NEW-PATHNAME OLD-PATHNAME)
     1477                     (RETURN T))
     1478                    ((#/N #\RUBOUT)
     1479                     (PRINC "No." QUERY-IO)
     1480                     (RETURN NIL))
     1481                    (#/P
     1482                     (PRINC "Proceed." QUERY-IO)
     1483                     (PUSH OLD-PATHNAME (FUNCALL NEW-PATHNAME ':GET ':REDEFINES-FILES))
     1484                     (RETURN T))
     1485                    ((#/? #\HELP)
     1486                     (PRINC "
    11731487Type Y to proceed to redefine the function, N to not redefine it, E to go into the
    1174  error handler, or P to proceed and not ask in the future (for this pair of files): "
    1175                                            QUERY-IO))
    1176                       (OTHERWISE (FORMAT QUERY-IO "~& Type Y, N, E, P or [HELP]: "))))))
    1177            (RECORD-SOURCE-FILE-NAME FUNCTION-SPEC)
    1178            (FSET FUNCTION-SPEC DEFINITION)
    1179            (RETURN-FROM FDEFINE T))
    1180           (T
    1181            (RETURN-FROM FDEFINE
    1182              (SELECTQ (CAR FUNCTION-SPEC)
    1183                (:METHOD
    1184                 (LET ((CS (CADR FUNCTION-SPEC))
    1185                       (OP (CADDR FUNCTION-SPEC)))
    1186                   (COND ((GET CS 'FLAVOR)
    1187                          (FDEFINE-FLAVOR FUNCTION-SPEC DEFINITION CAREFULLY-FLAG FORCE-FLAG))
    1188                         ((NOT (CLASS-SYMBOLP CS))
    1189                          (FERROR NIL "Attempt to define method on ~S, which is not a CLASS"
    1190                                  CS))
    1191                         (T
    1192                          (LET ((MN (MAKE-METHOD-NAME CS OP)))
    1193                            (COND ((FDEFINE MN DEFINITION CAREFULLY-FLAG FORCE-FLAG)
    1194                                   ;; Can't send message because this has to work during
    1195                                   ;; loadup before messages work.
    1196                                   (ADD-METHOD CS
    1197                                               (SYMEVAL-IN-CLOSURE (SYMEVAL CS)
    1198                                                                   'CLASS-METHOD-SYMBOL)
    1199                                               OP
    1200                                               MN)
    1201                                   T)))))))
    1202                (:INSTANCE-METHOD
    1203                 (LET ((INST (EVAL (CADR FUNCTION-SPEC)))
    1204                       (OP (CADDR FUNCTION-SPEC)))
    1205                   (LET ((MN (MAKE-INSTANCE-METHOD-NAME INST OP)))
    1206                     (COND ((FDEFINE MN DEFINITION CAREFULLY-FLAG FORCE-FLAG)
    1207                            (ADD-INSTANCE-METHOD INST OP MN)
    1208                            T)))))
    1209                (:PROPERTY
    1210                 (PUTPROP (CADR FUNCTION-SPEC) DEFINITION (CADDR FUNCTION-SPEC))
    1211                 T)
    1212                (OTHERWISE
    1213                 (PUTPROP (CAR FUNCTION-SPEC) DEFINITION (CADR FUNCTION-SPEC))
    1214                 T)))))))
    1215 
    1216 ;; This is an old name which everyone uses.
    1217 ;; It must be defined after FDEFINE since we are clobbering a
    1218 ;; temporary patch which is made so that FASLOAD can load before QMISC is loaded.
    1219 
    1220 (DEFUN FSET-CAREFULLY (FUNCTION-SPEC DEFINITION &OPTIONAL FORCE-FLAG)
    1221     (FDEFINE FUNCTION-SPEC DEFINITION T FORCE-FLAG))
     1488error handler, or P to proceed and not ask in the future (for this pair of files): "
     1489                            QUERY-IO))
     1490                    (OTHERWISE (FORMAT QUERY-IO "~& Type Y, N, E, or [HELP]: ")))))))))
    12221491
    12231492;Restore the saved previous function definition of a symbol.
    1224 (DEFUN UNDEFUN (SYMBOL &AUX TEM)
    1225     (SETQ TEM (GET SYMBOL ':PREVIOUS-DEFINITION))
    1226     (OR TEM (FERROR NIL "~S has no previous function definition" SYMBOL))
    1227     (FSET-CAREFULLY SYMBOL TEM T))
    1228 
    1229 ;Get the documentation string for a function
     1493(DEFUN UNDEFUN (FUNCTION-SPEC &AUX TEM)
     1494    (SETQ TEM (FUNCTION-SPEC-GET FUNCTION-SPEC ':PREVIOUS-DEFINITION))
     1495    (OR TEM (FERROR NIL "~S has no previous function definition" FUNCTION-SPEC))
     1496    (FSET-CAREFULLY FUNCTION-SPEC TEM T))
     1497
     1498;;; Some source file stuff that does not need to be in QRAND
     1499(DEFUN GET-SOURCE-FILE-NAME (FUNCTION-SPEC &OPTIONAL TYPE)
     1500  (DECLARE (RETURN-LIST PATHNAME TYPE))
     1501  (LET ((PROPERTY (FUNCTION-SPEC-GET FUNCTION-SPEC ':SOURCE-FILE-NAME)))
     1502    (COND ((NULL PROPERTY) NIL)
     1503          ((NLISTP PROPERTY)
     1504           (AND (MEMQ TYPE '(DEFUN NIL))
     1505                (VALUES PROPERTY 'DEFUN)))
     1506          (T
     1507           (LET ((LIST (IF TYPE (ASSQ TYPE PROPERTY) (CAR PROPERTY))))
     1508             (LOOP FOR FILE IN (CDR LIST)
     1509                   WHEN (NOT (FUNCALL FILE ':GET ':PATCH-FILE))
     1510                   RETURN (VALUES FILE (CAR LIST))))))))
     1511
     1512(DEFUN GET-ALL-SOURCE-FILE-NAMES (FUNCTION-SPEC)
     1513  (LET ((PROPERTY (FUNCTION-SPEC-GET FUNCTION-SPEC ':SOURCE-FILE-NAME)))
     1514    (COND ((NULL PROPERTY) NIL)
     1515          ((NLISTP PROPERTY)
     1516           (SETQ PROPERTY `((DEFUN ,PROPERTY)))
     1517           ;; May as well save this consing.
     1518           (FUNCTION-SPEC-PUTPROP FUNCTION-SPEC PROPERTY ':SOURCE-FILE-NAME)
     1519           PROPERTY)
     1520          (T PROPERTY))))
     1521
     1522;Get the documentation string for a function or function spec.
    12301523;NIL if not defined or no documentation
    1231 (DEFUN FUNCTION-DOCUMENTATION (FCN)
     1524(DEFUN DOCUMENTATION (FCN)
    12321525  (COND ((SYMBOLP FCN)
    1233          (OR (AND (FBOUNDP FCN) (FUNCTION-DOCUMENTATION (FSYMEVAL FCN)))
     1526         (OR (AND (FBOUNDP FCN) (DOCUMENTATION (FSYMEVAL FCN)))
    12341527             (GET FCN ':DOCUMENTATION)))
    12351528        ((LISTP FCN)
    1236          (COND ((MEMQ (CAR FCN) '(LAMBDA NAMED-LAMBDA))
    1237                 (AND (EQ (CAR FCN) 'NAMED-LAMBDA)
     1529         (COND ((MEMQ (CAR FCN) '(LAMBDA NAMED-LAMBDA SUBST NAMED-SUBST))
     1530                (AND (MEMQ (CAR FCN) '(NAMED-LAMBDA NAMED-SUBST))
    12381531                     (SETQ FCN (CDR FCN)))
    12391532                (SETQ FCN (CDDR FCN))
     
    12451538                     (CAR FCN)))
    12461539               ((EQ (CAR FCN) 'MACRO)
    1247                 (FUNCTION-DOCUMENTATION (CDR FCN)))
     1540                (DOCUMENTATION (CDR FCN)))
    12481541               (T
    1249                 (AND (FDEFINEDP FCN) (FUNCTION-DOCUMENTATION (FDEFINITION FCN))))))
     1542                (AND (FDEFINEDP FCN) (DOCUMENTATION (FDEFINITION FCN))))))
    12501543        ((= (%DATA-TYPE FCN) DTP-FEF-POINTER)
    12511544         (CADR (ASSQ ':DOCUMENTATION (FUNCTION-DEBUGGING-INFO FCN))))))
     1545
     1546;Old name.
     1547(DEFF FUNCTION-DOCUMENTATION 'DOCUMENTATION)
    12521548
    12531549;These are for reading in QCOM, and the like
     
    13321628
    13331629
    1334 (DEFUN DISK-RESTORE (&OPTIONAL PARTITION)
    1335     (LET ((L (DISK-RESTORE-DECODE PARTITION)))
    1336          (AND (YES-OR-NO-P "Do you really want to reload? (Yes or No)")
    1337               (%DISK-RESTORE (CAR L) (CADR L)))))
     1630(DEFUN DISK-RESTORE (&OPTIONAL PARTITION &AUX NAME COMMENT DESIRED-UCODE)
     1631  (LET ((L (DISK-RESTORE-DECODE PARTITION)) (RQB NIL) BLOCK)
     1632    (UNWIND-PROTECT
     1633      (PROGN (SETQ RQB (GET-DISK-RQB))
     1634             (READ-DISK-LABEL RQB 0)
     1635             (SETQ NAME (IF PARTITION
     1636                            (STRING-APPEND (LDB 0010 (CADR L)) (LDB 1010 (CADR L))
     1637                                           (LDB 0010 (CAR L)) (LDB 1010 (CAR L)))
     1638                            (GET-DISK-STRING RQB 7 4)))
     1639             (SETQ BLOCK (FIND-DISK-PARTITION-FOR-READ NAME RQB)
     1640                   COMMENT (PARTITION-COMMENT NAME 0))
     1641             (DISK-READ RQB 0 (1+ BLOCK))
     1642             (SETQ DESIRED-UCODE (AREF (RQB-BUFFER RQB)
     1643                                       (* 2 %SYS-COM-DESIRED-MICROCODE-VERSION))))
     1644      (RETURN-DISK-RQB RQB))
     1645    (AND ( DESIRED-UCODE %MICROCODE-VERSION-NUMBER)
     1646         (NOT (ZEROP DESIRED-UCODE))            ;Not stored yet
     1647         (FORMAT QUERY-IO
     1648                 "~&That band prefers microcode ~D but the running microcode is ~D.~%"
     1649                 DESIRED-UCODE %MICROCODE-VERSION-NUMBER))
     1650    (COND ((FQUERY FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS
     1651                   "Do you really want to reload ~A (~A)? " NAME COMMENT)
     1652           (TV:CLOSE-ALL-SERVERS "Disk-Restoring")
     1653           (%DISK-RESTORE (CAR L) (CADR L))))))
    13381654
    13391655(DEFVAR WHO-LINE-JUST-COLD-BOOTED-P NIL) ;Set to T upon cold boot for who-line's benefit
     
    13441660                                   (LDB 0010 (CAR L)) (LDB 1010 (CAR L))))
    13451661         PART-SIZE)
    1346     (COND ((YES-OR-NO-P (FORMAT NIL "Do you really want to clobber partition ~A? (Yes or No)"
    1347                                     PART-NAME))
    1348            (GET-NEW-SYSTEM-VERSION)     ;Update system version ID
    1349            (UPDATE-PARTITION-COMMENT PART-NAME SYSTEM-VERSION-STRING 0)
    1350            (MULTIPLE-VALUE (NIL PART-SIZE) (FIND-DISK-PARTITION PART-NAME))
    1351            (LOGOUT)
    1352            (CHAOS:RESET)
    1353            
    1354            ;Cause cold boot initializations to happen when rebooted
    1355            ;and do the BEFORE-COLD initializations now
    1356            (INITIALIZATIONS 'BEFORE-COLD-INITIALIZATION-LIST T)
    1357            (RESET-INITIALIZATIONS 'COLD-INITIALIZATION-LIST)
    1358            (SETQ WHO-LINE-JUST-COLD-BOOTED-P T)
    1359            
    1360            ;Determine size of storage used.  Hope no region-consing happens
    1361            ;after this (presumably no one is doing anything).  Just to be
    1362            ;sure, we inhibit scheduling.
    1363            (DO ((INHIBIT-SCHEDULING-FLAG T)
    1364                 (REGION 0 (1+ REGION))
    1365                 (MAX-ADDR 0))
    1366                ((= REGION (REGION-LENGTH REGION-LENGTH))
    1367                 (SETQ CURRENT-PROCESS NIL)      ;Prevent error message upon coming up
    1368                 (SETQ MAX-ADDR (// MAX-ADDR PAGE-SIZE)) ;Number of pages
    1369                 (AND (> MAX-ADDR PART-SIZE) (FERROR NIL "Cannot save, partition too small"))
    1370                 ;; Store the size in words rather than pages.  But don't get a bignum!
    1371                 (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-VALID-SIZE) (LSH MAX-ADDR 8))
    1372                 (DO I 600 (1+ I) (= I 640)      ;Clear the disk error log
    1373                   (%P-STORE-TAG-AND-POINTER I 0 0))
    1374                 (%DISK-SAVE (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE)
    1375                             (CAR L) (CADR L)))
    1376              (COND ((NOT (= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION))
    1377                             %REGION-SPACE-FREE))
    1378                     (SETQ MAX-ADDR (MAX MAX-ADDR (+ (REGION-ORIGIN REGION)
    1379                                                     (REGION-LENGTH REGION)))))))))))
     1662    (MULTIPLE-VALUE (NIL PART-SIZE) (FIND-DISK-PARTITION-FOR-WRITE PART-NAME))
     1663    (ASSURE-CC-SYMBOLS-LOADED)
     1664    (IF (> (FIND-MAX-ADDR) PART-SIZE)
     1665        ;; This test is not necessarily accurate, since we have not
     1666        ;; yet shut off the world.  However, it should catch most cases,
     1667        ;; so that this error will be detected before the partition comment
     1668        ;; gets clobbered.
     1669        (FERROR NIL "Cannot save, partition too small"))
     1670    (UPDATE-PARTITION-COMMENT PART-NAME (GET-NEW-SYSTEM-VERSION) 0)
     1671    (LOGOUT)
     1672   
     1673    ;; Cause cold boot initializations to happen when rebooted
     1674    ;; and do the BEFORE-COLD initializations now
     1675    (INITIALIZATIONS 'BEFORE-COLD-INITIALIZATION-LIST T)
     1676    (RESET-INITIALIZATIONS 'COLD-INITIALIZATION-LIST)
     1677    (SETQ WHO-LINE-JUST-COLD-BOOTED-P T)
     1678   
     1679    ;; Now shut down the world and check the partition size for real, just
     1680    ;; to make sure that we didn't exceed the size very recently.
     1681    (DOLIST (S TV:ALL-THE-SCREENS) (TV:SHEET-GET-LOCK S))
     1682    (TV:WITH-MOUSE-USURPED
     1683      (WITHOUT-INTERRUPTS
     1684        (SETQ TV:MOUSE-SHEET NIL)
     1685        (DOLIST (S TV:ALL-THE-SCREENS)
     1686          (FUNCALL S ':DEEXPOSE)
     1687          (TV:SHEET-RELEASE-LOCK S))
     1688        (SETQ CURRENT-PROCESS NIL)      ;Prevent error message upon coming up
     1689        (LET ((MAX-ADDR (FIND-MAX-ADDR)))
     1690          (COND ((> MAX-ADDR PART-SIZE)
     1691                 (FUNCALL TV:MAIN-SCREEN ':EXPOSE)
     1692                 (FERROR NIL "Cannot save, partition too small.  Warm Boot please.")))
     1693          ;; Store the size in words rather than pages.  But don't get a bignum!
     1694          (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-VALID-SIZE) (LSH MAX-ADDR 8))
     1695          (DO I 600 (1+ I) (= I 640)    ;Clear the disk error log
     1696              (%P-STORE-TAG-AND-POINTER I 0 0))
     1697          (%DISK-SAVE (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE)
     1698                      (CAR L) (CADR L)))))))
     1699
     1700(DEFUN ASSURE-CC-SYMBOLS-LOADED ()
     1701  (MULTIPLE-VALUE-BIND (NIL CURRENT-VERSION)
     1702      (AND CADR:CC-FILE-SYMBOLS-LOADED-FROM
     1703           (FUNCALL CADR:CC-FILE-SYMBOLS-LOADED-FROM ':TYPE-AND-VERSION))
     1704    (COND ((NEQ CURRENT-VERSION %MICROCODE-VERSION-NUMBER)
     1705           (FORMAT T "~%Loading CC symbols for UCADR version ~D~%" %MICROCODE-VERSION-NUMBER)
     1706           (LET ((IBASE 8))
     1707             (PKG-BIND "CADR"
     1708               (CADR:CC-LOAD-UCODE-SYMBOLS-FOR-VERSION %MICROCODE-VERSION-NUMBER)))))))
     1709
     1710;;; Find the highest address in the virtual memory.  If you call this without
     1711;;; inhibiting interrupts, the result is not strictly correct since some
     1712;;; other process could invalidate it at any time by CONSing.  However,
     1713;;; it gives you a good idea and a lower bound.  The answer is in number
     1714;;; of pages.
     1715(DEFUN FIND-MAX-ADDR ()
     1716  (DO ((REGION 0 (1+ REGION))
     1717       (MAX-ADDR 0))
     1718      ((= REGION (REGION-LENGTH REGION-LENGTH))
     1719       (// MAX-ADDR PAGE-SIZE))
     1720    ;; Check each region.  If it is free, ignore it.  Otherwise,
     1721    ;; find the highest address of that region, and get the
     1722    ;; highest such address.
     1723    (COND ((NOT (= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION))
     1724                   %REGION-SPACE-FREE))   
     1725           (SETQ MAX-ADDR (MAX MAX-ADDR (+ (REGION-ORIGIN-TRUE-VALUE REGION)
     1726                                           (REGION-LENGTH REGION))))))))
     1727
     1728(DEFUN REGION-ORIGIN-TRUE-VALUE (REGION)
     1729        ;below crock avoids returning a negative number if region starts above
     1730        ; half way point in address space.  It can make a bignum so be careful!
     1731  (MAKE-24-BIT-UNSIGNED (REGION-ORIGIN REGION)))
     1732
    13801733
    13811734(DEFUN DISK-RESTORE-DECODE (PARTITION &AUX LOW-16-BITS HI-16-BITS)
     
    13861739           (SETQ HI-16-BITS (+ #/D (LSH (+ #/0 PARTITION) 8))))
    13871740          ((STRINGP PARTITION)
    1388            (SETQ LOW-16-BITS (+ (AR-1 PARTITION 0) (LSH (AR-1 PARTITION 1) 8)))
    1389            (SETQ HI-16-BITS (+ (AR-1 PARTITION 2) (LSH (AR-1 PARTITION 3) 8))))
     1741           (SETQ LOW-16-BITS (+ (CHAR-UPCASE (AR-1 PARTITION 0))
     1742                                (LSH (CHAR-UPCASE (AR-1 PARTITION 1)) 8)))
     1743           (SETQ HI-16-BITS (+ (CHAR-UPCASE (AR-1 PARTITION 2))
     1744                               (LSH (CHAR-UPCASE (AR-1 PARTITION 3)) 8))))
    13901745          (T (FERROR NIL "~S is not a valid partition name" PARTITION)))
    13911746    (LIST HI-16-BITS LOW-16-BITS))
    1392 
    1393 ;This is a temporary function, which turns on the "extra-pdl" feature
    1394 (DEFUN NUMBER-GC-ON (&OPTIONAL (ON-P T))
    1395   (SETQ NUMBER-CONS-AREA
    1396         (COND (ON-P EXTRA-PDL-AREA)
    1397               (T WORKING-STORAGE-AREA))))
    1398 
    1399 (DEFUN PRINT-MODIFICATION-RECORD ()
    1400     (FORMAT T "~&System:~18TModification:")
    1401     (DO ((L (REVERSE SYSTEM-MODIFICATION-RECORD) (CDR L)))
    1402         ((NULL L))
    1403       (FORMAT T "~%~A ~18T~A" (CAAR L) (CADAR L)))
    1404     (TERPRI))
    14051747
    14061748(DEFUN GET-FROM-ALTERNATING-LIST (L KEY)
    14071749"Retreive associated item from an alternating list
    14081750Like GET, but no initial CAR"
    1409   (PROG NIL
    1410      L  (COND ((NULL L)(RETURN NIL))
    1411               ((EQ KEY (CAR L))
    1412                (RETURN (CADR L))))
    1413         (SETQ L (CDDR L))
    1414         (GO L)))
     1751  (GET (LOCF L) KEY))
    14151752
    14161753(DEFUN PUT-ON-ALTERNATING-LIST (ITEM L KEY)
     
    14631800  (OR (= (%P-LDB-OFFSET %%ARRAY-DISPLACED-BIT ARRAY 0) 1)
    14641801      (FERROR NIL "~S is not a displaced array" ARRAY))
    1465   (CHECK-ARG DISPLACED-P ARRAYP "an array to indirect to")
     1802  (CHECK-ARG DISPLACED-P (OR (ARRAYP DISPLACED-P) (FIXP DISPLACED-P))
     1803             "an array or physical address to indirect to")
    14661804  (CHECK-ARG TYPE               ;TEM gets the numeric array type
    14671805             (SETQ TEM (COND ((NUMBERP TYPE) (LDB %%ARRAY-TYPE-FIELD TYPE))
     
    15161854             OLD-VALUE (COND ((BOUNDP SYM)
    15171855                              (CAR ADR)))
    1518              NEW-ARRAY (MAKE-ARRAY NIL ART-Q-LIST 2))
     1856             NEW-ARRAY (MAKE-ARRAY 2 ':TYPE ART-Q-LIST))
    15191857       (AS-1 OLD-VALUE NEW-ARRAY 0)   ;MOVE CURRENT VALUE TO NEW PLACE
    15201858       (AS-1 MONITOR-FUNCTION NEW-ARRAY 1)
     
    15421880  (FORMAT T "~%Changing ~S from ~S to ~S" SYM OLD NEW))
    15431881)
     1882
     1883(DEFUN IGNORE (&REST IGNORE) NIL)
     1884
     1885;;; Read a number out of a string (starting at FROM, in the given RADIX).
     1886;;; Returns the number, or NIL if no number was seen.
     1887;;; Second value returned is where in the string the number ended
     1888;;; (index of first non-digit).
     1889(DEFUN PARSE-NUMBER (STRING &OPTIONAL (FROM 0) TO (RADIX 10.))
     1890  (DO ((I FROM (1+ I))
     1891       (CH)
     1892       (NUM 0)
     1893       (FIRSTP T NIL)
     1894       (LIM (OR TO (STRING-LENGTH STRING))))
     1895      (NIL)
     1896    (AND (
     1897 I LIM)
     1898         (RETURN (AND (NOT FIRSTP) NUM) I))
     1899    (SETQ CH (AREF STRING I))
     1900    (COND ((OR (< CH #/0)
     1901               (> CH #/9))
     1902           (RETURN (AND (NOT FIRSTP) NUM) I)))
     1903    (SETQ NUM (+ (* NUM RADIX) (- CH #/0)))))
     1904
     1905;;; "Print" a number into an array the fast way
     1906(DEFUN NUMBER-INTO-ARRAY (ARRAY N &OPTIONAL (RADIX BASE) (AT-INDEX 0) (MIN-COLUMNS 0)
     1907                                  &AUX QUOT)
     1908  (IF (ZEROP (SETQ QUOT (// N RADIX)))
     1909      (DOTIMES (I (1- MIN-COLUMNS))
     1910        (ASET #\SP ARRAY AT-INDEX)
     1911        (SETQ AT-INDEX (1+ AT-INDEX)))
     1912      (SETQ AT-INDEX (NUMBER-INTO-ARRAY ARRAY QUOT RADIX AT-INDEX (1- MIN-COLUMNS))))
     1913  (ASET (+ #/0 (\ N RADIX)) ARRAY AT-INDEX)
     1914  (1+ AT-INDEX))
     1915
     1916;;; Add an array to the end of another
     1917(DEFUN APPEND-TO-ARRAY (TO-ARRAY FROM-ARRAY &OPTIONAL (FROM-START 0) FROM-END
     1918                                            &AUX OLD-LENGTH NEW-LENGTH)
     1919  (OR FROM-END (SETQ FROM-END (ARRAY-ACTIVE-LENGTH FROM-ARRAY)))
     1920  (SETQ NEW-LENGTH (+ (SETQ OLD-LENGTH (ARRAY-LEADER TO-ARRAY 0)) (- FROM-END FROM-START)))
     1921  (AND (< (ARRAY-LENGTH TO-ARRAY) NEW-LENGTH) (ADJUST-ARRAY-SIZE TO-ARRAY NEW-LENGTH))
     1922  (COPY-ARRAY-PORTION FROM-ARRAY FROM-START FROM-END TO-ARRAY OLD-LENGTH NEW-LENGTH)
     1923  (STORE-ARRAY-LEADER NEW-LENGTH TO-ARRAY 0))
Note: See TracChangeset for help on using the changeset viewer.