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

Update from System 78.

Files:
1 modified

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))) 
    426505           (RETURN T))))) 
    427506 
    428  
    429 (SPECIAL RANDOM-ARRAY) 
     507(DEFVAR RANDOM-ARRAY) 
    430508 
    431509(DEFSTRUCT (RANDOM-NUMBER-TABLE ARRAY-LEADER) 
     
    433511    RANDOM-SEED 
    434512    RANDOM-POINTER-1 
    435     RANDOM-POINTER-2 
    436     ) 
    437  
    438 (DEFUN RANDOM-CREATE-ARRAY (SIZE OFFSET SEED &OPTIONAL (AREA NIL) &AUX ARRAY) 
    439     (SETQ ARRAY (MAKE-RANDOM-NUMBER-TABLE 
    440                         MAKE-ARRAY (AREA ART-Q-LIST SIZE))) 
    441     (SETF (RANDOM-FILL-POINTER ARRAY) SIZE) 
    442     (SETF (RANDOM-SEED ARRAY) SEED) 
    443     (SETF (RANDOM-POINTER-1 ARRAY) 0) 
    444     (SETF (RANDOM-POINTER-2 ARRAY) OFFSET) 
    445     (RANDOM-INITIALIZE ARRAY) 
    446     ARRAY) 
    447  
    448 (DEFUN RANDOM-INITIALIZE (ARRAY &AUX SIZE X BYTE-SPEC POINTER) 
     513    RANDOM-POINTER-2) 
     514 
     515(DEFUN RANDOM-CREATE-ARRAY (SIZE OFFSET SEED &OPTIONAL (AREA NIL)) 
     516    (LET ((ARRAY (MAKE-RANDOM-NUMBER-TABLE 
     517                   MAKE-ARRAY (:AREA AREA 
     518                               :TYPE 'ART-Q-LIST 
     519                               :LENGTH SIZE) 
     520                   RANDOM-FILL-POINTER SIZE 
     521                   RANDOM-SEED SEED 
     522                   RANDOM-POINTER-1 0 
     523                   RANDOM-POINTER-2 OFFSET))) 
     524      (RANDOM-INITIALIZE ARRAY) 
     525      ARRAY)) 
     526 
     527(DEFUN RANDOM-INITIALIZE (ARRAY &OPTIONAL NEW-SEED &AUX SIZE X BYTE-SPEC POINTER) 
     528   (IF (NOT (NULL NEW-SEED)) 
     529       (SETF (RANDOM-SEED ARRAY) NEW-SEED)) 
    449530   (SETQ SIZE (RANDOM-FILL-POINTER ARRAY) 
    450531         POINTER (AP-1 ARRAY 0)) 
     532   (SETF (RANDOM-POINTER-2 ARRAY) (\ (+ SIZE (- (RANDOM-POINTER-2 ARRAY) 
     533                                                (RANDOM-POINTER-1 ARRAY))) 
     534                                     SIZE)) 
     535   (SETF (RANDOM-POINTER-1 ARRAY) 0) 
    451536   (DO I 0 (1+ I) (= I SIZE) 
    452      (AS-1 0 ARRAY I)) 
     537     (ASET 0 ARRAY I)) 
    453538   (SETQ X (RANDOM-SEED ARRAY)) 
    454539   (DO L '(1414 0014) (CDR L) (NULL L) 
     
    456541     (DO I 0 (1+ I) (= I SIZE) 
    457542       (SETQ X (%24-BIT-TIMES X 4093.))                 ;4093. is a prime number. 
    458        (%P-DPB-OFFSET (LDB 1314 X) BYTE-SPEC POINTER I))) 
    459    (SETF (RANDOM-SEED ARRAY) X)) 
     543       (%P-DPB-OFFSET (LDB 1314 X) BYTE-SPEC POINTER I)))) 
    460544 
    461545(DEFUN RANDOM (&OPTIONAL ARG ARRAY &AUX PTR1 PTR2 SIZE ANS) 
     
    475559      (SETF (RANDOM-POINTER-2 ARRAY) PTR2) 
    476560      (SETQ ANS (%24-BIT-PLUS (AR-1 ARRAY PTR1) (AR-1 ARRAY PTR2))) 
    477       (AS-1 ANS ARRAY PTR2)) 
     561      (ASET ANS ARRAY PTR2)) 
    478562    (COND (ARG (\ (LOGAND ANS 37777777) ARG))   ;ASSURE POSITIVE ANSWER 
    479563          (T ANS))) 
     
    545629(DECLARE (SPECIAL APROPOS-SUBSTRING)) 
    546630 
    547 (DEFUN APROPOS (APROPOS-SUBSTRING &OPTIONAL (PKG PKG-GLOBAL-PACKAGE)) 
    548     (MAPATOMS-ALL 
    549      (FUNCTION (LAMBDA (SYMBOL) 
    550          (COND ((STRING-SEARCH APROPOS-SUBSTRING (GET-PNAME SYMBOL)) 
    551                 (LET ((PACKAGE (CAR (PACKAGE-CELL-LOCATION SYMBOL)))) 
    552                      ;;Binding PACKAGE is to prevent printing of a package prefix. 
    553                   (FORMAT T "~%~A:~S" PACKAGE SYMBOL)) ;ALWAYS get a prefix 
    554                 (AND (FBOUNDP SYMBOL) 
    555                      (FORMAT T " - Function ~:S" (ARGLIST SYMBOL))) 
    556                 (AND (BOUNDP SYMBOL) 
    557                      (COND ((FBOUNDP SYMBOL) (PRINC ", Bound")) 
    558                            (T (PRINC " - Bound")))))))) 
    559      PKG)) 
     631(LOCAL-DECLARE ((SPECIAL RETURN-LIST)) 
     632(DEFUN APROPOS (APROPOS-SUBSTRING &OPTIONAL PKG (DO-INFERIORS T) DO-SUPERIORS 
     633                &AUX RETURN-LIST) 
     634  (SETQ PKG (IF (NULL PKG) PKG-GLOBAL-PACKAGE (PKG-FIND-PACKAGE PKG))) 
     635  (MAPATOMS #'APROPOS-1 PKG DO-SUPERIORS) 
     636  (AND DO-INFERIORS 
     637       (DOLIST (P (PKG-SUBPACKAGES PKG)) 
     638         (MAPATOMS-ALL #'APROPOS-1 P))) 
     639  RETURN-LIST) 
     640 
     641(DEFUN APROPOS-1 (SYMBOL) 
     642  (COND ((STRING-SEARCH APROPOS-SUBSTRING (GET-PNAME SYMBOL)) 
     643         (PUSH SYMBOL RETURN-LIST) 
     644         ;; Binding the package to NIL forces the package to be printed. 
     645         ;; This is better than explicitly printing the package, because 
     646         ;; this way you get the "short" version. 
     647         (LET ((PACKAGE NIL)) 
     648           (FORMAT T "~%~S" SYMBOL)) 
     649         (AND (FBOUNDP SYMBOL) 
     650              (FORMAT T " - Function ~:S" (ARGLIST SYMBOL))) 
     651         (AND (BOUNDP SYMBOL) 
     652              (COND ((FBOUNDP SYMBOL) (PRINC ", Bound")) 
     653                    (T (PRINC " - Bound"))))))) 
     654);End of LOCAL-DECLARE 
    560655 
    561656(DEFUN SYMEVAL-IN-CLOSURE (CLOSURE PTR) 
     
    598693(DEFUN ENTITYP (X) 
    599694    (= (%DATA-TYPE X) DTP-ENTITY)) 
    600  
    601 (DEFUN LOCATIVEP (X) 
    602     (= (%DATA-TYPE X) DTP-LOCATIVE)) 
    603695 
    604696;ARRAY-POP, eventually to be micro-coded 
     
    619711        (RETURN VAL))) 
    620712 
    621 ;FILLARRAY as in Maclisp, eventually to be micro-coded. 
    622 ;SOURCE may be an array or a list. 
    623 ;Order of subscripts is currently incompatible with Maclisp for multi-dimensional 
    624 ;arrays.  In any case, will not bother supporting multi-dimensional until it's micro-coded. 
     713;;; The following definitions of FILLARRAY and LISTARRAY should be completely 
     714;;; compatible with Maclisp.  Slow, maybe, but compatible. 
     715 
     716;;; When filling from an array, extra elements in the destination get the default initial 
     717;;; value for the array type.  When filling from a list it sticks at the last element. 
     718;;; Extra elements in the source are ignored.  copy-array-contents 
     719;;; does the right thing for one-d arrays, but for multi-dimensional arrays 
     720;;; uses column-major rather than row-major order. 
     721 
     722(DEFRESOURCE FILLARRAY-INDEX-ARRAYS () 
     723        :CONSTRUCTOR (MAKE-ARRAY 10) 
     724        :INITIAL-COPIES 2) 
     725 
    625726(DEFUN FILLARRAY (ARRAY SOURCE) 
    626   (AND (SYMBOLP ARRAY) (SETQ ARRAY (FSYMEVAL ARRAY))) 
    627   (COND ((ARRAYP SOURCE) 
    628          (COPY-ARRAY-CONTENTS SOURCE ARRAY)) 
    629         (T (DO ((I 0 (1+ I)) 
    630                 (N (ARRAY-LENGTH ARRAY)) 
    631                 (L SOURCE (OR (CDR L) L))) 
    632                ((>= I N)) 
    633              (AS-1 (CAR L) ARRAY I)))) 
     727  (LET ((DEST (IF (SYMBOLP ARRAY) (FSYMEVAL ARRAY) ARRAY))) 
     728    (CHECK-ARG ARRAY (ARRAYP DEST) "an array or a symbol FBOUND to an array") 
     729    ;; Note, I really mean LISTP here -- Maclisp does not allow NIL, and that is right. 
     730    ;; Well, there is code in the system that depends on the empty list working as a source, 
     731    ;; at least for zero-length arrays.  This code says filling from () means fill 
     732    ;; with the default initial value for the destination array type. 
     733    (CHECK-ARG SOURCE (OR (ARRAYP SOURCE) (LISTP SOURCE) (NULL SOURCE)) "an array or a list") 
     734    (LET ((DEST-NDIMS (ARRAY-#-DIMS DEST)) 
     735          (SOURCE-IS-AN-ARRAY-P (ARRAYP SOURCE))) 
     736      (COND (SOURCE-IS-AN-ARRAY-P 
     737             (LET ((SOURCE-NDIMS (ARRAY-#-DIMS SOURCE))) 
     738               (COND ((AND (= DEST-NDIMS 1) 
     739                           (= SOURCE-NDIMS 1)) 
     740                      ;; One-D array into a one-D array is in microcode! 
     741                      (LET ((N-ELEMENTS (MIN (ARRAY-LENGTH SOURCE) 
     742                                             (ARRAY-LENGTH DEST)))) 
     743                        (COPY-ARRAY-PORTION SOURCE 0 N-ELEMENTS DEST 0 N-ELEMENTS))) 
     744                     (T 
     745                      ;; Hairy case, some array is multi-dimensional. 
     746                      (USING-RESOURCE (SOURCE-INDEX-ARRAY FILLARRAY-INDEX-ARRAYS) 
     747                        (USING-RESOURCE (DEST-INDEX-ARRAY FILLARRAY-INDEX-ARRAYS) 
     748                          (DOTIMES (I 10) 
     749                            (ASET 0 SOURCE-INDEX-ARRAY I) 
     750                            (ASET 0 DEST-INDEX-ARRAY I)) 
     751                          (LET ((SOURCE-ELEMENTS (ARRAY-LENGTH SOURCE)) 
     752                                (DEST-ELEMENTS (ARRAY-LENGTH DEST))) 
     753                            (DOTIMES (I (MIN SOURCE-ELEMENTS DEST-ELEMENTS)) 
     754                              (FILLARRAY-PUT (FILLARRAY-GET SOURCE 
     755                                                            SOURCE-INDEX-ARRAY 
     756                                                            SOURCE-NDIMS) 
     757                                             DEST DEST-INDEX-ARRAY DEST-NDIMS))))))))) 
     758            ((NULL SOURCE) (COPY-ARRAY-PORTION DEST 0 0 DEST 0 (ARRAY-LENGTH DEST))) 
     759            (T 
     760             ;; Source is a list. 
     761             (COND ((= DEST-NDIMS 1) 
     762                    (DOTIMES (X (ARRAY-DIMENSION-N 1 DEST)) 
     763                      (ASET (CAR SOURCE) DEST X) 
     764                      (IF (NOT (NULL (CDR SOURCE))) (SETQ SOURCE (CDR SOURCE))))) 
     765                   ((= DEST-NDIMS 2) 
     766                    (DOTIMES (X (ARRAY-DIMENSION-N 1 DEST)) 
     767                      (DOTIMES (Y (ARRAY-DIMENSION-N 2 DEST)) 
     768                        (ASET (CAR SOURCE) DEST X Y) 
     769                        (IF (NOT (NULL (CDR SOURCE))) (SETQ SOURCE (CDR SOURCE)))))) 
     770                   ((= DEST-NDIMS 3) 
     771                    (DOTIMES (X (ARRAY-DIMENSION-N 1 DEST)) 
     772                      (DOTIMES (Y (ARRAY-DIMENSION-N 2 DEST)) 
     773                        (DOTIMES (Z (ARRAY-DIMENSION-N 3 DEST)) 
     774                          (ASET (CAR SOURCE) DEST X Y Z) 
     775                          (IF (NOT (NULL (CDR SOURCE))) (SETQ SOURCE (CDR SOURCE))))))) 
     776                   (T 
     777                    (USING-RESOURCE (DEST-INDEX-ARRAY FILLARRAY-INDEX-ARRAYS) 
     778                      (DOTIMES (I 10) 
     779                        (ASET 0 DEST-INDEX-ARRAY I)) 
     780                      (DOTIMES (I (ARRAY-LENGTH DEST)) 
     781                        (FILLARRAY-PUT (CAR SOURCE) DEST DEST-INDEX-ARRAY DEST-NDIMS) 
     782                        (IF (NOT (NULL (CDR SOURCE))) (SETQ SOURCE (CDR SOURCE))))))))))) 
    634783  ARRAY) 
    635784 
    636 (DEFUN LISTARRAY (ARRAY &OPTIONAL LIMIT &AUX LST) 
    637   (AND (SYMBOLP ARRAY) (SETQ ARRAY (FSYMEVAL ARRAY))) 
    638   (OR LIMIT 
    639       (SETQ LIMIT (ARRAY-ACTIVE-LENGTH ARRAY))) 
    640   (SETQ LST (MAKE-LIST DEFAULT-CONS-AREA LIMIT)) 
    641   (DO ((I 0 (1+ I)) 
    642        (L LST (CDR L))) 
    643       ((>= I LIMIT) 
    644        LST) 
    645     (RPLACA L (AR-1 ARRAY I)))) 
     785(DEFUN FILLARRAY-GET (ARRAY INDEX-ARRAY NDIMS) 
     786  (%OPEN-CALL-BLOCK ARRAY 0 1)                  ;d-stack 
     787  (%ASSURE-PDL-ROOM NDIMS) 
     788  (DOTIMES (I NDIMS) 
     789    (%PUSH (AREF INDEX-ARRAY I))) 
     790  (%ACTIVATE-OPEN-CALL-BLOCK) 
     791  (FILLARRAY-INCREMENT-INDEX ARRAY INDEX-ARRAY NDIMS) 
     792  (%POP)) 
     793 
     794(DEFUN FILLARRAY-PUT (VALUE ARRAY INDEX-ARRAY NDIMS) 
     795  (%OPEN-CALL-BLOCK ARRAY 0 0)                  ;d-ignore 
     796  (%ASSURE-PDL-ROOM NDIMS) 
     797  (DOTIMES (I NDIMS) 
     798    (%PUSH (AREF INDEX-ARRAY I))) 
     799  (%ACTIVATE-OPEN-CALL-BLOCK) 
     800  (STORE NIL VALUE) 
     801  (FILLARRAY-INCREMENT-INDEX ARRAY INDEX-ARRAY NDIMS)) 
     802 
     803(DEFUN FILLARRAY-INCREMENT-INDEX (ARRAY INDEX-ARRAY NDIMS) 
     804  (DO ((DIM NDIMS (1- DIM))) 
     805      (( 
     806 DIM 0)) 
     807    (LET ((VAL (1+ (AREF INDEX-ARRAY (1- DIM))))) 
     808      (COND ((< VAL (ARRAY-DIMENSION-N DIM ARRAY)) 
     809             (ASET VAL INDEX-ARRAY (1- DIM)) 
     810             (RETURN)) 
     811            (T 
     812             (ASET 0 INDEX-ARRAY (1- DIM))))))) 
     813 
     814;;; LISTARRAY of a one-dimensional array respects the fill pointer, but 
     815;;; for multi-dimensional arrays it ignores the fill pointer. 
     816(DEFUN LISTARRAY (ARRAY &OPTIONAL LIMIT) 
     817  (IF (SYMBOLP ARRAY) 
     818      (SETQ ARRAY (FSYMEVAL ARRAY))) 
     819  (CHECK-ARG ARRAY ARRAYP "an array or a symbol FBOUND to an array") 
     820  (CHECK-ARG LIMIT (OR (NULL LIMIT) (FIXP LIMIT)) "NIL or a fixnum") 
     821  (LET* ((NDIMS (ARRAY-#-DIMS ARRAY)) 
     822         (ELEMENTS (IF (= NDIMS 1) 
     823                       (ARRAY-ACTIVE-LENGTH ARRAY) 
     824                       (ARRAY-LENGTH ARRAY))) 
     825         (TIMES (IF (NULL LIMIT) 
     826                    ELEMENTS 
     827                    (MIN LIMIT ELEMENTS))) 
     828         (LIST (MAKE-LIST TIMES)) 
     829         (L LIST) 
     830         (COUNT 0)) 
     831    (COND ((= NDIMS 1) 
     832           (DOTIMES (X (ARRAY-ACTIVE-LENGTH ARRAY)) 
     833             (SETQ COUNT (1+ COUNT)) 
     834             (IF (> COUNT TIMES) 
     835                 (RETURN)) 
     836             (RPLACA L (AREF ARRAY X)) 
     837             (SETQ L (CDR L)))) 
     838          ((= NDIMS 2) 
     839           (DOTIMES (X (ARRAY-DIMENSION-N 1 ARRAY)) 
     840             (DOTIMES (Y (ARRAY-DIMENSION-N 2 ARRAY)) 
     841               (SETQ COUNT (1+ COUNT)) 
     842               (IF (> COUNT TIMES) 
     843                   (RETURN)) 
     844               (RPLACA L (AREF ARRAY X Y)) 
     845               (SETQ L (CDR L))))) 
     846          ((= NDIMS 3) 
     847           (DOTIMES (X (ARRAY-DIMENSION-N 1 ARRAY)) 
     848             (DOTIMES (Y (ARRAY-DIMENSION-N 2 ARRAY)) 
     849               (DOTIMES (Z (ARRAY-DIMENSION-N 3 ARRAY)) 
     850                 (SETQ COUNT (1+ COUNT)) 
     851                 (IF (> COUNT TIMES) 
     852                     (RETURN)) 
     853                 (RPLACA L (AREF ARRAY X Y Z)) 
     854                 (SETQ L (CDR L)))))) 
     855          (T 
     856           (USING-RESOURCE (INDEX-ARRAY FILLARRAY-INDEX-ARRAYS) 
     857             (DOTIMES (I 10) (ASET 0 INDEX-ARRAY I)) 
     858             (DOTIMES (I TIMES) 
     859               (RPLACA L (FILLARRAY-GET ARRAY INDEX-ARRAY NDIMS)) 
     860               (SETQ L (CDR L)))))) 
     861    LIST)) 
    646862 
    647863(DEFUN LIST-ARRAY-LEADER (ARRAY &OPTIONAL LIMIT &AUX LST) 
     
    665881(DEFUN DATA-TYPE (X) 
    666882    (AR-1 (FSYMEVAL 'Q-DATA-TYPES) (%DATA-TYPE X))) 
    667  
    668 (LOCAL-DECLARE ((SPECIAL FUNCTION)) 
    669 (DEFUN WHO-CALLS (FUNCTION &OPTIONAL (PKG PKG-GLOBAL-PACKAGE)) 
    670     (SETQ PKG (PKG-FIND-PACKAGE PKG)) 
    671     (AND (STRINGP FUNCTION) (SETQ FUNCTION (INTERN FUNCTION))) 
    672     (CHECK-ARG FUNCTION SYMBOLP "a symbol") 
    673     (MAPATOMS-ALL (FUNCTION WHO-CALLS-AUX) PKG) 
    674     NIL)) 
    675  
    676  
    677 ;; This attempts to reduce page faults 
    678 ;; but it only saves as much time as the sort uses up. 
    679 ;; Maybe with explicit swap-out it will be faster. 
    680 (COMMENT 
    681 (LOCAL-DECLARE ((SPECIAL FUNCTION ARRAY)) 
    682 (DEFUN WHO-CALLS (FUNCTION &OPTIONAL (PKG PKG-GLOBAL-PACKAGE)) 
    683     (SETQ PKG (PKG-FIND-PACKAGE PKG)) 
    684     (AND (STRINGP FUNCTION) (SETQ FUNCTION (INTERN FUNCTION))) 
    685     (CHECK-ARG FUNCTION SYMBOLP "a symbol") 
    686     (LET ((ARRAY (MAKE-ARRAY NIL ART-Q 10000. NIL 1))) 
    687         (SETF (ARRAY-LEADER ARRAY 0) 0) 
    688         (MAPATOMS-ALL (FUNCTION (LAMBDA (SYMBOL) 
    689                           (AND (FBOUNDP SYMBOL) 
    690                                (ARRAY-PUSH-EXTEND ARRAY SYMBOL (ARRAY-ACTIVE-LENGTH ARRAY))))) 
    691                       PKG) 
    692         (SORT ARRAY (FUNCTION (LAMBDA (X Y) 
    693                         (< (%POINTER (FSYMEVAL X)) (%POINTER (FSYMEVAL Y)))))) 
    694         (DO I (1- (ARRAY-ACTIVE-LENGTH ARRAY)) (1- I) (< I 0) 
    695            (WHO-CALLS-AUX (AR-1 ARRAY I))) 
    696         (RETURN-ARRAY ARRAY)) 
    697     NIL))) 
    698 (DEFUN WHO-USES (FUNCTION &OPTIONAL (PKG PKG-GLOBAL-PACKAGE)) (WHO-CALLS FUNCTION PKG)) 
    699  
    700 ;Print out CALLER if it refers to the symbol in the special variable FUNCTION, 
    701 ;either as a function call, as a variable reference, or as a constant reference. 
    702 ;The symbol UNBOUND-FUNCTION is treated specially. 
    703 (LOCAL-DECLARE ((SPECIAL FUNCTION)) 
    704 (DEFUN WHO-CALLS-AUX (CALLER &AUX DEFN) 
    705    ;; Ignore all symbols which are forwarded to others, to avoid duplication. 
    706    (COND ((NOT (= (%P-LDB-OFFSET %%Q-DATA-TYPE CALLER 1) DTP-ONE-Q-FORWARD)) 
    707           (COND ((FBOUNDP CALLER) 
    708                  (SETQ DEFN (FSYMEVAL CALLER)) 
    709                  ;; Don't be fooled by macros, interpreted or compiled. 
    710                  (AND (LISTP DEFN) (EQ (CAR DEFN) 'MACRO) (SETQ DEFN (CDR DEFN))) 
    711                  (COND ((LISTP DEFN) 
    712                         (WHO-CALLS-AUX-LIST CALLER FUNCTION DEFN)) 
    713                        ((= (%DATA-TYPE DEFN) DTP-FEF-POINTER) 
    714                         (WHO-CALLS-AUX-FEF CALLER FUNCTION DEFN))))) 
    715           (DO ((L (PLIST CALLER) (CDDR L))) 
    716               ((NULL L)) 
    717             (COND ((= (%DATA-TYPE (CADR L)) DTP-FEF-POINTER) 
    718                    (WHO-CALLS-AUX-FEF (LIST CALLER (CAR L)) FUNCTION (CADR L))))))))) 
     883 
     884;;; Facilities for looking through all functions in the world 
     885;;; and finding out what they do. 
     886 
     887(LOCAL-DECLARE ((SPECIAL RETURN-LIST)) 
     888(DEFUN WHO-CALLS (SYMBOL &OPTIONAL PKG (DO-INFERIORS T) (DO-SUPERIORS T) &AUX RETURN-LIST) 
     889  (OR PKG (SETQ PKG PKG-GLOBAL-PACKAGE)) 
     890  (FIND-CALLERS-OF-SYMBOLS SYMBOL PKG 
     891        #'(LAMBDA (CALLER CALLEE HOW) 
     892            (FORMAT T "~&~S" CALLER) 
     893            (FORMAT T (SELECTQ HOW 
     894                        (:VARIABLE " uses ~S as a variable.") 
     895                        (:FUNCTION " calls ~S as a function.") 
     896                        (:MISC-FUNCTION " calls ~S via a 'misc' instruction.") 
     897                        (:CONSTANT " uses ~S as a constant.") 
     898                        (:UNBOUND-FUNCTION " calls ~S, an undefined function.") 
     899                        (NIL ", an interpreted function, uses ~S somehow.")) 
     900                    CALLEE) 
     901            (PUSH CALLER RETURN-LIST)) DO-INFERIORS DO-SUPERIORS) 
     902  RETURN-LIST) 
     903) 
     904 
     905(DEFF WHO-USES 'WHO-CALLS) 
     906 
     907(DEFUN WHAT-FILES-CALL (SYMBOL-OR-SYMBOLS &OPTIONAL PKG (DO-INFERIORS T) (DO-SUPERIORS T)) 
     908  (OR PKG (SETQ PKG PKG-GLOBAL-PACKAGE)) 
     909  (LOCAL-DECLARE ((SPECIAL L)) 
     910    (LET ((L NIL)) 
     911      (FIND-CALLERS-OF-SYMBOLS SYMBOL-OR-SYMBOLS PKG 
     912        #'(LAMBDA (CALLER IGNORE IGNORE) 
     913            (AND (SETQ CALLER (GET-SOURCE-FILE-NAME CALLER 'DEFUN)) 
     914                 (NOT (MEMQ CALLER L)) 
     915                 (PUSH CALLER L))) 
     916        DO-INFERIORS DO-SUPERIORS) 
     917      L))) 
     918 
     919(LOCAL-DECLARE ((SPECIAL SYMBOL FUNCTION)) 
     920(DEFUN FIND-CALLERS-OF-SYMBOLS (SYMBOL PKG FUNCTION 
     921                                &OPTIONAL (DO-INFERIORS T) (DO-SUPERIORS T)) 
     922  "This is the main driving function for WHO-CALLS and friends. 
     923   Looks at all symbols in PKG and its inferiors and its superiors (does not 
     924   do its sisters, cousins, and aunts). 
     925   Looks at each symbol's function definition and if it 
     926   refers to SYMBOL calls FUNCTION with the function name, the symbol used, 
     927   and the type of use (:VARIABLE, :FUNCTION, :MISC-FUNCTION, :CONSTANT, :UNBOUND-FUNCTION, 
     928   or NIL if used in an unknown way in an interpreted function.) 
     929   SYMBOL can be a single symbol or a list of symbols. 
     930   The symbol :UNBOUND-FUNCTION is treated specially." 
     931  ;; Sorting first, in order of function definitions, didn't help much when 
     932  ;; tried in the previous generation of this function. 
     933  (SETQ PKG (PKG-FIND-PACKAGE PKG)) 
     934  (CHECK-ARG SYMBOL 
     935             (OR (SYMBOLP SYMBOL) 
     936                 (LOOP FOR SYM IN SYMBOL ALWAYS (SYMBOLP SYM))) 
     937             "a symbol or a list of symbols") 
     938  (IF (SYMBOLP SYMBOL) 
     939      (SETQ SYMBOL (ADD-SYMBOLS-OPTIMIZED-INTO SYMBOL SYMBOL)) 
     940      (DOLIST (SYM SYMBOL) 
     941        (SETQ SYMBOL (ADD-SYMBOLS-OPTIMIZED-INTO SYM SYMBOL)))) 
     942  (MAPATOMS #'FIND-CALLERS-OF-SYMBOLS-AUX PKG DO-SUPERIORS) 
     943  (AND DO-INFERIORS 
     944       (DOLIST (P (PKG-SUBPACKAGES PKG)) 
     945         (MAPATOMS-ALL #'FIND-CALLERS-OF-SYMBOLS-AUX P))) 
     946  NIL) 
     947 
     948(DEFUN ADD-SYMBOLS-OPTIMIZED-INTO (SYM LIST) 
     949  (DOLIST (SYM1 (GET SYM 'COMPILER:OPTIMIZED-INTO)) 
     950    (IF (SYMBOLP LIST) (SETQ LIST (LIST LIST))) 
     951    (OR (MEMQ SYM1 LIST) 
     952        (SETQ LIST (ADD-SYMBOLS-OPTIMIZED-INTO SYM1 (CONS SYM1 LIST))))) 
     953  LIST) 
     954 
     955(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX (CALLER &AUX FL) 
     956  ;; Ignore all symbols which are forwarded to others, to avoid duplication. 
     957  (AND ( (%P-LDB-OFFSET %%Q-DATA-TYPE CALLER 2) DTP-ONE-Q-FORWARD) 
     958       (FBOUNDP CALLER) 
     959       (FIND-CALLERS-OF-SYMBOLS-AUX1 CALLER (FSYMEVAL CALLER))) 
     960  (COND (( (%P-LDB-OFFSET %%Q-DATA-TYPE CALLER 3) DTP-ONE-Q-FORWARD) 
     961         ;; Also look for properties 
     962         (DO ((L (PLIST CALLER) (CDDR L))) 
     963             ((NULL L)) 
     964           (COND ((= (%DATA-TYPE (CADR L)) DTP-FEF-POINTER) 
     965                  (FIND-CALLERS-OF-SYMBOLS-AUX-FEF 
     966                    (LIST ':PROPERTY CALLER (CAR L)) (CADR L))))) 
     967         ;; Also look for flavor methods 
     968         (AND (SETQ FL (GET CALLER 'FLAVOR)) 
     969              (ARRAYP FL)               ;Could be T 
     970              (DOLIST (MTE (FLAVOR-METHOD-TABLE FL)) 
     971                (DOLIST (METH (CDDDR MTE)) 
     972                  (IF (METH-DEFINEDP METH) 
     973                      (FIND-CALLERS-OF-SYMBOLS-AUX1 (METH-FUNCTION-SPEC METH) 
     974                                                    (METH-DEFINITION METH)))))) 
     975         ;; Also look for initializations 
     976         (IF (GET CALLER 'INITIALIZATION-LIST) 
     977             ;; It is an initialization list. 
     978             (DOLIST (INIT-LIST-ENTRY (SYMEVAL CALLER)) 
     979               (FIND-CALLERS-OF-SYMBOLS-AUX-LIST CALLER (INIT-FORM INIT-LIST-ENTRY))))))) 
     980 
     981(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX1 (CALLER DEFN) 
     982  ;; Don't be fooled by macros, interpreted or compiled. 
     983  (AND (LISTP DEFN) (EQ (CAR DEFN) 'MACRO) (SETQ DEFN (CDR DEFN))) 
     984  (COND ((LISTP DEFN) 
     985         (FIND-CALLERS-OF-SYMBOLS-AUX-LIST CALLER DEFN)) 
     986        ((= (%DATA-TYPE DEFN) DTP-FEF-POINTER) 
     987         (FIND-CALLERS-OF-SYMBOLS-AUX-FEF CALLER DEFN))) 
     988  ;; If this function is traced, advised, etc. 
     989  ;; then look through the actual definition. 
     990  (LET* ((DEBUG-INFO (FUNCTION-DEBUGGING-INFO DEFN)) 
     991         (INNER (ASSQ 'SI:ENCAPSULATED-DEFINITION DEBUG-INFO))) 
     992    (AND INNER (FIND-CALLERS-OF-SYMBOLS-AUX (CADR INNER))))) 
    719993                  
    720 (DEFUN WHO-CALLS-AUX-FEF (CALLER FUNCTION DEFN &AUX TEM OFFSET SYM) 
    721     (DO ((I %FEF-HEADER-LENGTH (1+ I)) 
    722          (LIM (// (FEF-INITIAL-PC DEFN) 2))) 
    723         ((>= I LIM) NIL) 
    724       (COND ((= (%P-LDB-OFFSET %%Q-DATA-TYPE DEFN I) 
    725                 DTP-EXTERNAL-VALUE-CELL-POINTER) 
    726              (SETQ TEM (%P-CONTENTS-AS-LOCATIVE-OFFSET DEFN I) 
    727                    SYM (%FIND-STRUCTURE-HEADER TEM) 
    728                    OFFSET (%POINTER-DIFFERENCE TEM SYM)) 
    729              (COND ((EQ FUNCTION 'UNBOUND-FUNCTION) 
    730                     (COND ((AND (= OFFSET 2) 
    731                                 (NOT (FBOUNDP SYM))) 
    732                            (FORMAT STANDARD-OUTPUT " 
    733 ~S calls ~S, which is currently an unbound function." CALLER SYM)))) 
    734                    ((EQ SYM FUNCTION) 
    735                     (FORMAT T "~%~S ~A ~S." 
    736                             CALLER 
    737                             (NTH OFFSET '("gets the print name of" 
    738                                           "uses" 
    739                                           "calls" 
    740                                           "gets the property list of")) 
    741                             FUNCTION)))) 
    742             ((EQ (%P-CONTENTS-OFFSET DEFN I) FUNCTION) 
    743              (FORMAT T "~%~S uses ~S as a constant." CALLER FUNCTION)))) 
    744     ;; See if we have a function reference compiled into a misc instruction 
    745     ;; This won't work for LIST and LIST-IN-AREA 
    746     (AND (FEF-CALLS-MISC-FUNCTION DEFN FUNCTION) 
    747          (FORMAT STANDARD-OUTPUT " 
    748 ~S calls ~S via a misc-instruction." CALLER FUNCTION))) 
     994(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX-FEF (CALLER DEFN &AUX TEM OFFSET SYM) 
     995  (DO ((I %FEF-HEADER-LENGTH (1+ I)) 
     996       (LIM (// (FEF-INITIAL-PC DEFN) 2))) 
     997      ((>= I LIM) NIL) 
     998    (COND ((= (%P-LDB-OFFSET %%Q-DATA-TYPE DEFN I) DTP-EXTERNAL-VALUE-CELL-POINTER) 
     999           (SETQ TEM (%P-CONTENTS-AS-LOCATIVE-OFFSET DEFN I) 
     1000                 SYM (%FIND-STRUCTURE-HEADER TEM) 
     1001                 OFFSET (%POINTER-DIFFERENCE TEM SYM)) 
     1002           (COND ((NOT (SYMBOLP SYM))) 
     1003                 ((= OFFSET 2)                  ;Function cell reference 
     1004                  (IF (IF (ATOM SYMBOL) (EQ SYM SYMBOL) (MEMQ SYM SYMBOL)) 
     1005                      (FUNCALL FUNCTION CALLER SYM ':FUNCTION) 
     1006                      (AND (IF (ATOM SYMBOL) (EQ ':UNBOUND-FUNCTION SYMBOL) 
     1007                               (MEMQ ':UNBOUND-FUNCTION SYMBOL)) 
     1008                           (NOT (FBOUNDP SYM)) 
     1009                           (FUNCALL FUNCTION CALLER SYM ':UNBOUND-FUNCTION)))) 
     1010                 (T                             ;Value reference presumably 
     1011                  (IF (IF (ATOM SYMBOL) (EQ SYM SYMBOL) (MEMQ SYM SYMBOL)) 
     1012                      (FUNCALL FUNCTION CALLER SYM ':VARIABLE))))) 
     1013          ((SYMBOLP (SETQ SYM (%P-CONTENTS-OFFSET DEFN I))) 
     1014           (IF (IF (ATOM SYMBOL) (EQ SYM SYMBOL) (MEMQ SYM SYMBOL)) 
     1015               (FUNCALL FUNCTION CALLER SYM ':CONSTANT))))) 
     1016  ;; See if we have a function reference compiled into a misc instruction 
     1017  ;; This won't work for LIST and LIST-IN-AREA 
     1018  (IF (SYMBOLP SYMBOL) 
     1019      (IF (FEF-CALLS-MISC-FUNCTION DEFN SYMBOL) 
     1020          (FUNCALL FUNCTION CALLER SYMBOL ':MISC-FUNCTION)) 
     1021      (DOLIST (SYM SYMBOL) 
     1022        (IF (FEF-CALLS-MISC-FUNCTION DEFN SYM) 
     1023            (FUNCALL FUNCTION CALLER SYM ':MISC-FUNCTION)))) 
     1024  (AND (LDB-TEST %%FEFHI-MS-DEBUG-INFO-PRESENT 
     1025                 (%P-CONTENTS-OFFSET DEFN %FEFHI-MISC)) 
     1026       (SETQ TEM (CDR (ASSQ ':INTERNAL-FEF-OFFSETS 
     1027                            (%P-CONTENTS-OFFSET DEFN (1- (%P-LDB %%FEFH-PC-IN-WORDS DEFN)))))) 
     1028       (LOOP FOR OFFSET IN TEM 
     1029             FOR I FROM 0 
     1030             DO (FIND-CALLERS-OF-SYMBOLS-AUX-FEF `(:INTERNAL ,CALLER ,I) 
     1031                                                 (%P-CONTENTS-OFFSET DEFN OFFSET))))) 
    7491032 
    7501033;;; See if this FEF uses a certain MISC instruction 
     
    7641047               ((= INST LONGJUMP) (SETQ PC (1+ PC))))))) 
    7651048 
    766 ;;; Tree-walk CALLER looking for FUNCTION.  If it appears, print a message 
    767 ;;; to that effect and stop looking.  CALLER should be the function name, 
    768 ;;; and LIST should be its definition. 
    769  
    770 (DEFUN WHO-CALLS-AUX-LIST (CALLER FUNCTION DEFN) 
    771     (*CATCH 'WHO-CALLS (WHO-CALLS-AUX-LIST1 DEFN FUNCTION CALLER))) 
    772  
    773 (DEFUN WHO-CALLS-AUX-LIST1 (SUBLIST FUNCTION CALLER) 
    774     (COND ((SYMBOLP SUBLIST) 
    775            (COND ((EQ SUBLIST FUNCTION) 
    776                   (FORMAT T "~%~S, an interpreted function uses ~S somehow." CALLER FUNCTION) 
    777                   (*THROW 'WHO-CALLS NIL)))) 
    778           ((LISTP SUBLIST) 
    779            (WHO-CALLS-AUX-LIST1 (CAR SUBLIST) FUNCTION CALLER) 
    780            (WHO-CALLS-AUX-LIST1 (CDR SUBLIST) FUNCTION CALLER)))) 
    781  
     1049;;; Tree-walk CALLER looking for FUNCTION.  CALLER should be the function name, 
     1050;;; and DEFN should be its definition.  Avoids listing symbols twice. 
     1051(LOCAL-DECLARE ((SPECIAL SUPPRESS)) 
     1052(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX-LIST (CALLER DEFN) 
     1053  (LET ((SUPPRESS NIL)) 
     1054    (FIND-CALLERS-OF-SYMBOLS-AUX-LIST1 CALLER DEFN))) 
     1055 
     1056(DEFUN FIND-CALLERS-OF-SYMBOLS-AUX-LIST1 (CALLER DEFN) 
     1057  (DO ((L DEFN (CDR L))) 
     1058      ((ATOM L)) 
     1059    (COND ((AND (SYMBOLP (CAR L)) 
     1060                (NOT (MEMQ (CAR L) SUPPRESS)) 
     1061                (IF (ATOM SYMBOL) (EQ (CAR L) SYMBOL) (MEMQ (CAR L) SYMBOL))) 
     1062           (PUSH (CAR L) SUPPRESS) 
     1063           (FUNCALL FUNCTION CALLER (CAR L) NIL)) 
     1064          ((LISTP (CAR L)) 
     1065           (FIND-CALLERS-OF-SYMBOLS-AUX-LIST1 CALLER (CAR L)))))) 
     1066);close inner LOCAL-DECLARE 
     1067);close LOCAL-DECLARE 
     1068 
    7821069(DEFUN %MAKE-PAGE-READ-ONLY (P) 
    7831070  (%CHANGE-PAGE-STATUS P NIL (DPB 2 0603 (LDB %%REGION-MAP-BITS  ;CHANGE MAP-STATUS 
     
    8221109        (OTHERWISE (FERROR NIL "The MAR mode, ~O, is invalid." MODE))))) 
    8231110 
    824 ; This function sets up a 4 by 220 table, useful for keyboard dispatches. 
    825 ; The table is set up from a list of four elements, called rows: one for each 
    826 ; setting of the buckey bits, as follows: 0 = none, 1 = control, 2 = meta, 3 = control-meta. 
    827 ; Each row is walked down, and as each element is reached, it is stored in the array, unless 
    828 ; its car is recognized as a special function. 
    829 ; Currently implemented special functions are: 
    830 ;     (*REPEAT <times> <thing) --  <thing> is stored <times> times. 
    831 ;     (*REPEAT-EVAL <times> <thing>) -- like *REPEAT except that <thing> gets EVALed 
    832 ;                              before being stored.  The special variable SI:RPCNT will 
    833 ;                              be set to 0 on the first iteration and incremented by 1 
    834 ;                              throughout, like a MIDAS repeat loop. 
    835  
    836 (DECLARE (SPECIAL RPCNT)) 
    837  
    838 (DEFUN SETUP-KEYBOARD-DISPATCH-TABLE (TABLE LISTS &AUX ENTRY TEM) 
    839    (DO ((LISTS1 LISTS (CDR LISTS1)) 
    840         (IDX1 0 (1+ IDX1))) 
    841        ((NULL LISTS1)) 
    842      (DO ((LIST (CAR LISTS1) (CDR LIST)) 
    843           (IDX2 0))                               ;THE AMOUNT THIS IS INCREMENTED DEPENDS!! 
    844          ((NULL LIST) 
    845           (COND ((NOT (= IDX2 220)) 
    846                  (FERROR NIL "Row ~S was ~S long, instead of 220." 
    847                          IDX1 IDX2)))) 
    848        (SETQ ENTRY (CAR LIST)) 
    849        (COND ((ATOM ENTRY) 
    850               (AS-2 ENTRY TABLE IDX1 IDX2) 
    851               (SETQ IDX2 (1+ IDX2))) 
    852              ((EQ (FIRST ENTRY) ':REPEAT) 
    853               (SETQ TEM (SECOND ENTRY)) 
    854               (SETQ ENTRY (THIRD ENTRY)) 
    855               (DO I 0 (1+ I) (= I TEM) 
    856                 (AS-2 ENTRY TABLE IDX1 IDX2) 
    857                 (SETQ IDX2 (1+ IDX2)))) 
    858              ((EQ (FIRST ENTRY) ':REPEAT-EVAL) 
    859               (SETQ TEM (SECOND ENTRY)) 
    860               (SETQ ENTRY (THIRD ENTRY)) 
    861               (DO RPCNT 0 (1+ RPCNT) (= RPCNT TEM) 
    862                 (AS-2 (EVAL ENTRY) TABLE IDX1 IDX2) 
    863                 (SETQ IDX2 (1+ IDX2)))) 
    864              ((EQ (FIRST ENTRY) ':EVAL) 
    865               (AS-2 (EVAL (SECOND ENTRY)) TABLE IDX1 IDX2) 
    866               (SETQ IDX2 (1+ IDX2))) 
    867              (T 
    868               (AS-2 ENTRY TABLE IDX1 IDX2) 
    869               (SETQ IDX2 (1+ IDX2))))))) 
    870  
    871 (DEFUN YES-OR-NO-P (&OPTIONAL MESSAGE (STREAM QUERY-IO)) 
    872     (COND ((AND MESSAGE (NOT (STRINGP MESSAGE))) 
    873            ;; Temporary compatibility feature. 
    874            (COND ((STRINGP STREAM) 
    875                   (PSETQ MESSAGE STREAM STREAM MESSAGE)) 
    876                  (T (SETQ STREAM MESSAGE MESSAGE NIL))))) 
    877     (PROG (STRING) 
    878        (AND MESSAGE (FORMAT STREAM "~&~A" MESSAGE)) 
    879      RETRY 
    880        (SETQ STRING (STRING-UPCASE (STRING-TRIM '(40 211 42 56) ;sp, tab, dot, double-quote 
    881                                                 (READLINE STREAM)))) 
    882        (COND ((EQUAL STRING "YES") 
    883               (RETURN T)) 
    884              ((EQUAL STRING "NO") 
    885               (RETURN NIL)) 
    886              (T (AND MESSAGE (FORMAT STREAM "~&~A" MESSAGE)) 
    887                 (FORMAT STREAM "Please type /"Yes/" or /"No/". ") 
    888                 (GO RETRY))))) 
    889  
    8901111(DEFUN PAIRLIS (VARS VALS &AUX ALST) 
    8911112       (SETQ ALST (MAKE-LIST DEFAULT-CONS-AREA (LENGTH VARS))) 
     
    9521173                 ((EVAL (CAR STUFF)))))) 
    9531174    (BIND (VALUE-CELL-LOCATION (CAR VARS)) (CAR VALS)))) 
     1175 
     1176;;; (PROGW '((VAR-1 VAL-1) (VAR-2 VAL-2) ... (VAR-N VAL-N)) &BODY BODY) 
     1177;;; Binds VAR-I to VAL-I (evaluated) during execution of BODY 
     1178(DEFUN PROGW (VARS-AND-VALS &QUOTE &REST STUFF) 
     1179  (DO-NAMED PROGW 
     1180      ((VARS-AND-VALS VARS-AND-VALS (CDR VARS-AND-VALS))) 
     1181      ((NULL VARS-AND-VALS) 
     1182       (DO ((STUFF STUFF (CDR STUFF))) 
     1183           (NIL) 
     1184         (IF (NULL (CDR STUFF)) 
     1185             (RETURN-FROM PROGW (EVAL (CAR STUFF))) 
     1186             (EVAL (CAR STUFF))))) 
     1187    (BIND (VALUE-CELL-LOCATION (CAAR VARS-AND-VALS)) 
     1188          (EVAL (CADAR VARS-AND-VALS))))) 
     1189 
     1190;;; (LET-IF <COND> ((VAR-1 VAL-1) (VAR-2 VAL-2) ... (VAR-N VAL-N)) &BODY BODY) 
     1191;;; If <COND> is not nil, binds VAR-I to VAL-I (evaluated) during execution of BODY, 
     1192;;; otherwise just evaluates BODY. 
     1193(DEFUN LET-IF (COND &QUOTE VAR-LIST &QUOTE &REST STUFF) 
     1194  (PROGW (AND COND VAR-LIST) 
     1195     (DO ((STUFF STUFF (CDR STUFF))) 
     1196         (NIL) 
     1197       (IF (NULL (CDR STUFF)) 
     1198           (RETURN (EVAL (CAR STUFF))) 
     1199           (EVAL (CAR STUFF)))))) 
     1200 
     1201;Interpreter version of UNWIND-PROTECT 
     1202;(UNWIND-PROTECT risky-stuff forms-to-do-when-unwinding-this-frame...) 
     1203;If risky-stuff returns, we return what it returns, doing forms-to-do 
     1204;(just as PROG1 would do).  If risky-stuff does a throw, we let the throw 
     1205;function as specified, but make sure that forms-to-do get done as well. 
     1206(DEFUN UNWIND-PROTECT (&QUOTE BODY-FORM &REST CLEANUP-FORMS) 
     1207  (UNWIND-PROTECT (EVAL BODY-FORM) 
     1208    (DOLIST (FORM CLEANUP-FORMS) 
     1209      (EVAL FORM)))) 
    9541210 
    955  
    9561211;;; This should really be fixed to expand more than just top level functions. 
    957 (DEFUN MEXP NIL 
     1212(DEFUN MEXP () 
    9581213    (DO ((TEM)) 
    9591214        (()) 
    9601215      (FORMAT T "~2%Macro form ") 
    961       (SETQ TEM (READ-FOR-TOP-LEVEL)) 
    962       (AND (SYMBOLP TEM) (RETURN NIL)) 
    963       (DO EXP (MACROEXPAND-1 TEM) (MACROEXPAND-1 EXP) (EQ EXP TEM) 
    964         ;(FORMAT T " ~S" (SETQ TEM EXP)) 
    965         (PRINC " ") 
    966         (GRIND-TOP-LEVEL (SETQ TEM EXP)) 
    967         ))) 
    968  
    969  
    970 ;; STATUS AND SSTATUS  
    971  
    972 (DECLARE (SPECIAL STATUS-FEATURE-LIST STATUS-STATUS-LIST STATUS-SSTATUS-LIST)) 
    973  
    974 ;;; These symbols are all on KWDPKG. 
    975 (SETQ STATUS-FEATURE-LIST 
    976       '(SORT FASLOAD STRING NEWIO ROMAN TRACE GRINDEF GRIND LISPM)) 
    977  
    978 (SETQ STATUS-STATUS-LIST '(FEATURE FEATURES NOFEATURE STATUS SSTATUS TABSIZE USERID)) 
    979  
    980 (SETQ STATUS-SSTATUS-LIST '(FEATURE NOFEATURE)) 
    981  
    982 (DEFUN RETURN-STATUS (STATUS-LIST ITEM) 
    983        (COND ((NULL ITEM) STATUS-LIST) 
    984              (T (NOT (NULL (MEMQ ITEM STATUS-LIST)))))) 
    985  
    986 (DEFUN STATUS (&QUOTE STATUS-FUNCTION &OPTIONAL ITEM) 
    987        (SELECTQ STATUS-FUNCTION 
    988                 ((FEATURE FEATURES) (RETURN-STATUS STATUS-FEATURE-LIST ITEM)) 
    989                 (NOFEATURE (COND ((NULL ITEM) 
    990                                   (FERROR NIL "Too few args to STATUS NOFEATURE")) 
    991                                  (T (NOT (RETURN-STATUS STATUS-FEATURE-LIST ITEM))))) 
    992                 (STATUS (RETURN-STATUS STATUS-STATUS-LIST ITEM)) 
    993                 (SSTATUS (RETURN-STATUS STATUS-SSTATUS-LIST ITEM)) 
    994                 (TABSIZE 8) 
    995                 (USERID USER-ID) 
    996                 (OTHERWISE (FERROR NIL "~S is not a legal STATUS request" STATUS-FUNCTION)))) 
    997  
    998 (DEFUN SSTATUS (&QUOTE STATUS-FUNCTION ITEM) 
    999        (SELECTQ STATUS-FUNCTION 
    1000                 (FEATURE (COND ((NOT (MEMQ ITEM STATUS-FEATURE-LIST)) 
    1001                                 (SETQ STATUS-FEATURE-LIST 
    1002                                       (CONS ITEM STATUS-FEATURE-LIST)))) 
    1003                                  ITEM) 
    1004                 (NOFEATURE (COND ((MEMQ ITEM STATUS-FEATURE-LIST) 
    1005                                   (SETQ STATUS-FEATURE-LIST 
    1006                                         (DELQ ITEM STATUS-FEATURE-LIST)))) 
    1007                                    ITEM) 
    1008                 (OTHERWISE (FERROR NIL "~S is not a legal SSTATUS request" STATUS-FUNCTION)))) 
    1009  
    1010 ;;; Describe all files "related" to this file name 
    1011 (DEFUN DESCRIBE-FILE (FILE-NAME &AUX USER-FILE-SYMBOL QFASL-FILE-SYMBOL FILE-GROUP-SYMBOL) 
    1012   (SETQ FILE-NAME (FS:FILE-PARSE-NAME FILE-NAME)) 
    1013   (SETQ USER-FILE-SYMBOL (INTERN-LOCAL-SOFT (FUNCALL FILE-NAME ':STRING-FOR-PRINTING) 
    1014                                             PKG-FILE-PACKAGE)) 
    1015   (MULTIPLE-VALUE (QFASL-FILE-SYMBOL FILE-GROUP-SYMBOL) 
    1016     (FS:GET-FILE-SYMBOLS (FUNCALL FILE-NAME ':COPY-WITH-TYPE ':QFASL))) 
    1017   (AND USER-FILE-SYMBOL (DESCRIBE-FILE-1 USER-FILE-SYMBOL)) 
    1018   (AND (NEQ QFASL-FILE-SYMBOL USER-FILE-SYMBOL) (DESCRIBE-FILE-1 QFASL-FILE-SYMBOL)) 
    1019   (AND (NEQ FILE-GROUP-SYMBOL USER-FILE-SYMBOL) (DESCRIBE-FILE-1 FILE-GROUP-SYMBOL)) 
    1020   NIL) 
    1021  
    1022 ;;; Describe a particular file-symbol 
    1023 (DEFUN DESCRIBE-FILE-1 (FILE-SYMBOL &AUX TEM IDX VERSION CREATION-DATE) 
    1024   (AND (SETQ TEM (GET FILE-SYMBOL ':PACKAGE)) 
    1025        (FORMAT STANDARD-OUTPUT "~%File ~A is in package ~A." FILE-SYMBOL TEM)) 
    1026   (DOLIST (PKG-ID (GET FILE-SYMBOL ':FILE-ID-PACKAGE-ALIST)) 
    1027     (SETQ TEM (CADR PKG-ID))    ;The FILE-ID for this package 
    1028     (SETQ IDX (STRING-SEARCH-CHAR #\SP TEM)) 
    1029     (SETQ VERSION (SUBSTRING TEM 0 IDX) 
    1030           CREATION-DATE (NSUBSTRING TEM (1+ IDX) (STRING-LENGTH TEM))) 
    1031     (COND ((EQUAL VERSION "-1") 
    1032            (FORMAT STANDARD-OUTPUT "~%Version of file ~A in package ~A was created ~A." 
    1033                                         FILE-SYMBOL (CAR PKG-ID) CREATION-DATE)) 
    1034           ((FORMAT STANDARD-OUTPUT "~%Version of file ~A in package ~A is ~A, created ~A." 
    1035                                         FILE-SYMBOL (CAR PKG-ID) VERSION CREATION-DATE)))) 
    1036   NIL) 
     1216      (FUNCALL STANDARD-INPUT ':UNTYI (FUNCALL STANDARD-INPUT ':TYI))   ;Allow abort to exit 
     1217      (*CATCH 'COMMAND-LEVEL            ;Stay in mexp if abort out of input, **more** 
     1218        (SETQ TEM (READ-FOR-TOP-LEVEL)) 
     1219        (AND (SYMBOLP TEM) (RETURN NIL)) 
     1220        (DO EXP (MACROEXPAND-1 TEM) (MACROEXPAND-1 EXP) (EQ EXP TEM) 
     1221          ;(FORMAT T " ~S" (SETQ TEM EXP)) 
     1222          (PRINC " ") 
     1223          (GRIND-TOP-LEVEL (SETQ TEM EXP)) 
     1224          )))) 
     1225 
     1226 
     1227;; STATUS and SSTATUS  
     1228;; Note that these have to be Maclisp compatible and therefore have to work 
     1229;; independent of packages.  All symbols on feature lists are in the keyword package. 
     1230 
     1231(DEFVAR STATUS-FEATURE-LIST 
     1232        '(:SORT :FASLOAD :STRING :NEWIO :ROMAN :TRACE :GRINDEF :GRIND :LISPM)) 
     1233 
     1234(DEFVAR STATUS-STATUS-LIST '(:FEATURE :FEATURES :NOFEATURE :STATUS :SSTATUS :TABSIZE 
     1235                             :USERID :SITE :OPSYS)) 
     1236 
     1237(DEFVAR STATUS-SSTATUS-LIST '(:FEATURE :NOFEATURE)) 
     1238 
     1239(DEFUN RETURN-STATUS (STATUS-LIST ITEM ITEM-P) 
     1240       (COND ((NOT ITEM-P) STATUS-LIST) 
     1241             (T (NOT (NULL (MEM #'STRING-EQUAL ITEM STATUS-LIST)))))) 
     1242 
     1243(DEFUN STATUS (&QUOTE STATUS-FUNCTION &OPTIONAL (ITEM NIL ITEM-P)) 
     1244  (SELECTOR STATUS-FUNCTION STRING-EQUAL 
     1245    (('FEATURE 'FEATURES) (RETURN-STATUS STATUS-FEATURE-LIST ITEM ITEM-P)) 
     1246    (('NOFEATURE) (COND ((NOT ITEM-P) 
     1247                         (FERROR NIL "Too few args to STATUS NOFEATURE")) 
     1248                        (T (NOT (RETURN-STATUS STATUS-FEATURE-LIST ITEM ITEM-P))))) 
     1249    (('STATUS) (RETURN-STATUS STATUS-STATUS-LIST ITEM ITEM-P)) 
     1250    (('SSTATUS) (RETURN-STATUS STATUS-SSTATUS-LIST ITEM ITEM-P)) 
     1251    (('TABSIZE) 8) 
     1252    (('USERID) USER-ID) 
     1253    (('SITE) LOCAL-HOST-NAME) 
     1254    (('OPSYS) ':LISPM) 
     1255    (OTHERWISE (FERROR NIL "~S is not a legal STATUS request" STATUS-FUNCTION)))) 
     1256 
     1257(DEFUN SSTATUS (&QUOTE STATUS-FUNCTION ITEM 
     1258                &AUX (DEFAULT-CONS-AREA WORKING-STORAGE-AREA)) 
     1259  (SETQ ITEM (INTERN (STRING ITEM) ""))         ;These are all keywords 
     1260  (SELECTOR STATUS-FUNCTION STRING-EQUAL 
     1261    (('FEATURE) (COND ((NOT (MEMQ ITEM STATUS-FEATURE-LIST)) 
     1262                       (SETQ STATUS-FEATURE-LIST 
     1263                             (CONS ITEM STATUS-FEATURE-LIST)))) 
     1264                ITEM) 
     1265    (('NOFEATURE) (COND ((MEMQ ITEM STATUS-FEATURE-LIST) 
     1266                         (SETQ STATUS-FEATURE-LIST 
     1267                               (DELQ ITEM STATUS-FEATURE-LIST)))) 
     1268                  ITEM) 
     1269    (OTHERWISE (FERROR NIL "~S is not a legal SSTATUS request" STATUS-FUNCTION)))) 
     1270 
     1271;The ADD-OPTIMIZER for this is in QCOPT, so that things work in the cold-load 
     1272(DEFUN STATUS-OPTIMIZER (FORM) 
     1273  (LET ((STATUS-FUNCTION (CADR FORM)) 
     1274        ;(ITEM (CADDR FORM)) 
     1275        (ITEM-P (CDDR FORM))) 
     1276    (SELECTOR STATUS-FUNCTION STRING-EQUAL 
     1277      (('FEATURE 'FEATURES) (IF ITEM-P FORM `STATUS-FEATURE-LIST)) 
     1278      (('TABSIZE) `8) 
     1279      (('USERID) `USER-ID) 
     1280      (('SITE) `LOCAL-HOST-NAME) 
     1281      (('OPSYS) `':LISPM) 
     1282      (OTHERWISE (OR (MEM #'STRING-EQUAL STATUS-FUNCTION STATUS-STATUS-LIST) 
     1283                     (COMPILER:BARF FORM "Unknown STATUS function" 'COMPILER:WARN)) 
     1284                 FORM)))) 
    10371285 
     1286;;; Site stuff 
     1287(DEFVAR SITE-NAME)                              ;Setup by the cold load generator 
     1288(DEFVAR SITE-OPTION-ALIST NIL) 
     1289 
     1290;;; This function is used to change the site in an already build world load. 
     1291;;; NEW-SITE is the site keyword, such as :MIT. 
     1292;;; SYS-HOST is the host that should be used as SYS: for loading the new site declaration. 
     1293;;; SYS-DIRECTORY is the directory to be used to getting the SITE file if this system 
     1294;;; doesn't follow the same directory naming convention as the original. 
     1295;;; HOST-TABLE-BOOTSTRAP is a filename to be loaded.  This is necessary either 
     1296;;; if SYS: is to point at a host not currently in the host table, or if there 
     1297;;; are file server hosts which are not SYS:. 
     1298(DEFUN SET-SITE (NEW-SITE &OPTIONAL SYS-HOST SYS-DIRECTORY HOST-TABLE-BOOTSTRAP) 
     1299  (SETQ STATUS-FEATURE-LIST (CONS NEW-SITE (DELQ SITE-NAME STATUS-FEATURE-LIST))) 
     1300  (SETQ SITE-NAME NEW-SITE) 
     1301  (AND HOST-TABLE-BOOTSTRAP (LOAD HOST-TABLE-BOOTSTRAP)) 
     1302  (COND (SYS-HOST 
     1303         (FS:CHANGE-LOGICAL-PATHNAME-HOST "SYS" SYS-HOST) 
     1304         (SETQ SYS-HOST (FS:GET-PATHNAME-HOST SYS-HOST))) 
     1305        (T 
     1306         (LET ((SYS-LOGICAL-HOST (FS:GET-PATHNAME-HOST "SYS"))) 
     1307           (AND SYS-LOGICAL-HOST (SETQ SYS-HOST (FUNCALL SYS-LOGICAL-HOST ':HOST)))))) 
     1308  (AND SYS-HOST (FUNCALL SYS-HOST ':SET-SITE NEW-SITE)) 
     1309  (AND SYS-DIRECTORY (FS:CHANGE-LOGICAL-PATHNAME-DIRECTORY "SYS" "SYS" SYS-DIRECTORY)) 
     1310  (MAYBE-MINI-LOAD-FILE-ALIST SITE-FILE-ALIST) 
     1311  (INITIALIZATIONS 'SITE-INITIALIZATION-LIST T)) 
     1312 
     1313(DEFMACRO DEFSITE (SITE &BODY OPTIONS) 
     1314  `(DEFSITE-1 ',SITE ',OPTIONS)) 
     1315 
     1316(DEFUN DEFSITE-1 (SITE OPTIONS) 
     1317  (AND (EQ SITE SITE-NAME) 
     1318       (SETQ SITE-OPTION-ALIST (LOOP FOR (KEY EXP) IN OPTIONS 
     1319                                     COLLECT `(,KEY . ,(EVAL EXP)))))) 
     1320 
     1321(DEFUN GET-SITE-OPTION (KEY) 
     1322  (CDR (ASSQ KEY SITE-OPTION-ALIST))) 
     1323 
     1324(DEFMACRO DEFINE-SITE-VARIABLE (VAR KEY) 
     1325  `(PROGN 'COMPILE 
     1326     (DEFVAR ,VAR) 
     1327     (ADD-INITIALIZATION ,(FORMAT NIL "SITE:~A" VAR) 
     1328                         `(SETQ ,',VAR (GET-SITE-OPTION ',',KEY)) 
     1329                         '(SITE)))) 
     1330 
     1331(DEFMACRO DEFINE-SITE-HOST-LIST (VAR KEY) 
     1332  `(PROGN 'COMPILE 
     1333     (DEFVAR ,VAR) 
     1334     (ADD-INITIALIZATION ,(FORMAT NIL "SITE:~A" VAR) 
     1335                         `(SETQ ,',VAR (MAPCAR 'PARSE-HOST (GET-SITE-OPTION ',',KEY))) 
     1336                         '(SITE)))) 
     1337 
     1338;;; This NORMAL is so that it doesn't happen right away before enough is loaded to work. 
     1339(ADD-INITIALIZATION "HOST-TABLE-INITIALIZATION" 
     1340                    '(MAYBE-MINI-LOAD-FILE-ALIST HOST-TABLE-FILE-ALIST) '(SITE NORMAL)) 
     1341 
     1342;;; Interfaces to chaosnet physical support facilities 
     1343(DEFUN CALL-ELEVATOR () 
     1344  (COND ((TECH-SQUARE-FLOOR-P 8) 
     1345         (CHAOS:HACK-DOOR "8")) 
     1346        ((TECH-SQUARE-FLOOR-P 9) 
     1347         (CHAOS:HACK-DOOR "9")) 
     1348        (T (TV:NOTIFY NIL "I don't know how to get an elevator to your location.")))) 
     1349 
     1350(DEFUN BUZZ-DOOR () 
     1351  (COND ((TECH-SQUARE-FLOOR-P 9) (CHAOS:HACK-DOOR "D")) 
     1352        (T (TV:NOTIFY NIL "I can only open the 9th floor door at Tech square")))) 
     1353 
     1354(DEFUN TECH-SQUARE-FLOOR-P (FLOOR) 
     1355  (AND LOCAL-FLOOR-LOCATION 
     1356       (EQ (FIRST LOCAL-FLOOR-LOCATION) 'MIT-NE43) 
     1357       (= (SECOND LOCAL-FLOOR-LOCATION) FLOOR))) 
     1358 
     1359;;; Stuff for function specs 
     1360 
    10381361;These are here because they must be loaded after the package system is operational 
    1039  
    1040 ;; Give the function definition corresponding to a function specifier. 
    1041 ;; A function-specifier is just a way of talking about a function 
    1042 ;; for purposes other than applying it.  It can be a symbol, in which case 
    1043 ;; the function cell of the symbol is used.  Or it can be a list of one of 
    1044 ;; these formats: 
    1045 ;; (:METHOD class-name operation) refers to the method in that class for 
    1046 ;;   that operation; this works for both Class methods and Flavor methods. 
    1047 ;;   In the case of Flavor methods, the specification may also be of the form 
    1048 ;;   (:METHOD flavor-name time operation). 
    1049 ;; (:INSTANCE-METHOD exp operation).  exp should evaluate to an DTP-INSTANCE. 
    1050 ;;   Reference is then to the operation directly on that instance. 
    1051 ;; (:PROPERTY symbol property) refers to (GET symbol property). 
    1052 ;; One place you can use a function specifier is in DEFUN. 
    1053 ;; Because of this, for Maclisp compatibility, a list whose car is 
    1054 ;; not recognized is taken to be a list of a symbol and a property. 
    1055  
    1056 (DEFUN FDEFINITION (FUNCTION-SPEC) 
    1057     (PROG () 
    1058           (CHECK-ARG FUNCTION-SPEC (OR (LISTP FUNCTION-SPEC) (SYMBOLP FUNCTION-SPEC)) 
    1059                      "a list or a symbol") 
    1060           (AND (SYMBOLP FUNCTION-SPEC) 
    1061                (RETURN (FSYMEVAL FUNCTION-SPEC))) 
    1062           (RETURN 
    1063             (SELECTQ (CAR FUNCTION-SPEC) 
    1064               (:METHOD 
    1065                  (COND ((GET (CADR FUNCTION-SPEC) 'FLAVOR) 
    1066                         (FSYMEVAL (FLAVOR-METHOD-SYMBOL FUNCTION-SPEC))) 
    1067                        ((FSYMEVAL 
    1068                          (<- (SYMEVAL (CADR FUNCTION-SPEC)) 
    1069                              ':METHOD-FOR 
    1070                              (CADDR FUNCTION-SPEC)))))) 
    1071               (:INSTANCE-METHOD (<- (CLASS (EVAL (CADR FUNCTION-SPEC))) 
    1072                                     ':METHOD-FOR 
    1073                                     (CADDR FUNCTION-SPEC))) 
    1074               (:PROPERTY (APPLY 'GET (CDR FUNCTION-SPEC))) 
    1075               (OTHERWISE (APPLY 'GET FUNCTION-SPEC)))))) 
    1076  
    1077 ;; Is a function specifier defined?  A generalization of FBOUNDP. 
    1078 (DEFUN FDEFINEDP (FUNCTION-SPEC) 
    1079     (COND ((SYMBOLP FUNCTION-SPEC) 
    1080            (FBOUNDP FUNCTION-SPEC)) 
    1081           ((EQ (CAR FUNCTION-SPEC) ':METHOD) 
    1082            (COND ((GET (CADR FUNCTION-SPEC) 'FLAVOR) 
    1083                   (FBOUNDP (FLAVOR-METHOD-SYMBOL FUNCTION-SPEC))) 
    1084                  ((AND (BOUNDP (CADR FUNCTION-SPEC)) 
    1085                        (<- (SYMEVAL (CADR FUNCTION-SPEC)) 
    1086                            ':METHOD-FOR 
    1087                            (CADDR FUNCTION-SPEC)))))) 
    1088           ((EQ (CAR FUNCTION-SPEC) ':INSTANCE-METHOD) 
    1089            (<- (CLASS (EVAL (CADR FUNCTION-SPEC))) 
    1090                ':METHOD-FOR 
    1091                (CADDR FUNCTION-SPEC))) 
    1092           (T (FDEFINITION FUNCTION-SPEC))))  ;Assumed to be property list 
    1093  
    1094 (DECLARE (SPECIAL FDEFINE-FILE-SYMBOL INHIBIT-FDEFINE-WARNINGS)) 
    1095 ;(OR (BOUNDP 'FDEFINE-FILE-SYMBOL)  ;This loses since FASLOAD binds this variable. 
    1096 ;    (SETQ FDEFINE-FILE-SYMBOL NIL)) 
    1097 (OR (BOUNDP 'INHIBIT-FDEFINE-WARNINGS) 
    1098     (SETQ INHIBIT-FDEFINE-WARNINGS NIL)) 
    1099  
    1100 (DEFUN FDEFINE (FUNCTION-SPEC DEFINITION &OPTIONAL CAREFULLY-FLAG FORCE-FLAG 
    1101                 &AUX TEM TEM1 (PACKAGE-PROBLEM NIL) (MULTI-FILE-PROBLEM NIL)) 
    1102 "Alter the function definition of a function specifier. 
    1103 CAREFULLY-FLAG means save the old definition, when possible, 
    1104 and query about crossing package lines (but FORCE-FLAG inhibits this). 
    1105 If FDEFINE-FILE-SYMBOL is non-NIL, then it is the file which this definition 
    1106 was read from, and we make a note of that fact when possible." 
    1107   (PROG FDEFINE () 
    1108     (CHECK-ARG FUNCTION-SPEC (OR (LISTP FUNCTION-SPEC) (SYMBOLP FUNCTION-SPEC)) 
    1109                "a list or a symbol") 
    1110     (COND ((SYMBOLP FUNCTION-SPEC) 
    1111            (OR FORCE-FLAG (NOT CAREFULLY-FLAG) 
    1112                INHIBIT-FDEFINE-WARNINGS 
    1113                (NULL (SETQ TEM (CDR (PACKAGE-CELL-LOCATION FUNCTION-SPEC)))) 
    1114                (EQ TEM PACKAGE) 
    1115                (EQ (SETQ TEM1 (PKG-EXTERNAL-LIST PACKAGE)) T) 
    1116                (MEM #'STRING-EQUAL FUNCTION-SPEC TEM1) 
    1117                (SETQ PACKAGE-PROBLEM TEM)) 
    1118            ;; Save previous definition if desired and there was one. 
    1119            (COND ((AND CAREFULLY-FLAG (FBOUNDP FUNCTION-SPEC)) 
    1120                   (SETQ TEM (FSYMEVAL FUNCTION-SPEC)) 
    1121                   ;; If it's traced, get the pre-traced definition to save. 
    1122                   (ERRSET 
    1123                     (AND (LISTP TEM) (EQ (CAR TEM) 'NAMED-LAMBDA) 
    1124                          (LISTP (CADR TEM)) 
    1125                          (ASSQ 'TRACE (CDADR TEM)) 
    1126                          (SETQ TEM (FDEFINITION (CADR (ASSQ 'TRACE (CDADR TEM)))))) 
    1127                     NIL) 
    1128                   (AND (LISTP TEM) 
    1129                        (NOT (AND (EQ (CAR TEM) 'MACRO) 
    1130                                  (= (%DATA-TYPE (CDR TEM)) DTP-FEF-POINTER))) 
    1131                        (PUTPROP FUNCTION-SPEC TEM ':PREVIOUS-EXPR-DEFINITION)) 
    1132                   (PUTPROP FUNCTION-SPEC TEM ':PREVIOUS-DEFINITION))) 
    1133            (AND (BOUNDP 'FDEFINE-FILE-SYMBOL)  ;Just initializing it doesnt win since it is 
    1134                 FDEFINE-FILE-SYMBOL            ; bound by FASLOAD. 
    1135                 (FBOUNDP 'FORMAT)              ;dont bomb during cold load 
    1136                                                ; (redefining accessor methods) 
    1137                 (SETQ TEM (GET FUNCTION-SPEC ':SOURCE-FILE-NAME)) 
    1138                 (NEQ TEM FDEFINE-FILE-SYMBOL) 
    1139                 (NOT (MEMQ TEM (GET FDEFINE-FILE-SYMBOL ':REDEFINES-FILES))) 
    1140                 (NOT INHIBIT-FDEFINE-WARNINGS) 
    1141                 (SETQ MULTI-FILE-PROBLEM TEM)) 
    1142            ;; If there are any problems, consult the user before proceeding 
    1143            (COND ((OR PACKAGE-PROBLEM MULTI-FILE-PROBLEM) 
    1144                   (FORMAT QUERY-IO 
    1145 "~&WARNING: Function ~S being illegally ~:[~;re~]defined~:[~; by file ~:*~A~]. 
    1146 ~:[~;The function belongs to the ~:*~A package.~]~ 
    1147 ~:[~;~&It was previously defined by file ~:*~A.~]  OK? (type Y, N, E, or P) " 
    1148                           FUNCTION-SPEC (FBOUNDP FUNCTION-SPEC) FDEFINE-FILE-SYMBOL 
    1149                           PACKAGE-PROBLEM MULTI-FILE-PROBLEM) 
    1150                   (FUNCALL QUERY-IO ':CLEAR-INPUT) 
    1151                   (DO () (NIL) 
    1152                     (SELECTQ (CHAR-UPCASE (FUNCALL QUERY-IO ':TYI)) 
    1153                       ((#/Y #/T #\SP) (PRINC "Yes." QUERY-IO) (RETURN)) 
    1154                       ((#/E) (PRINC "Error." QUERY-IO) 
    1155                              (RETURN (FDEFINE (CERROR T NIL ':ILLEGAL-FUNCTION-DEFINITION 
    1156  "Function ~S being illegally ~:[~;re~]defined~:[~; by file ~:*~A~]. 
    1157 ~:[~;The function belongs to the ~:*~A package.~]~ 
    1158 ~:[~;~&It was previously defined by file ~:*~A.~]" 
    1159                                                       FUNCTION-SPEC (FBOUNDP FUNCTION-SPEC) 
    1160                                                       FDEFINE-FILE-SYMBOL 
    1161                                                       PACKAGE-PROBLEM MULTI-FILE-PROBLEM) 
    1162                                               DEFINITION CAREFULLY-FLAG FORCE-FLAG))) 
    1163                       ((#/N #\RUBOUT) (PRINC "No." QUERY-IO) (RETURN-FROM FDEFINE NIL)) 
    1164                       (#/P (PRINC "Proceed." QUERY-IO) 
    1165                            (AND MULTI-FILE-PROBLEM 
    1166                                 (PUSH MULTI-FILE-PROBLEM 
    1167                                       (GET FDEFINE-FILE-SYMBOL ':REDEFINES-FILES))) 
    1168                            (RETURN)) 
    1169                       ((#/? #\HELP) (PRINC " 
     1362;(or maybe only because they aren't needed in the cold load?) 
     1363 
     1364;This is useful for sorting function specs 
     1365(DEFUN FUNCTION-SPEC-LESSP (FS1 FS2) 
     1366  (STRING-LESSP (IF (SYMBOLP FS1) FS1 (SECOND FS1)) 
     1367                (IF (SYMBOLP FS2) FS2 (SECOND FS2)))) 
     1368 
     1369(DEFUN FUNDEFINE (FUNCTION-SPEC &AUX TYPE) 
     1370  "Makes a function spec not have a function definition" 
     1371  ;; First, validate the function spec and determine its type 
     1372  (CHECK-ARG FUNCTION-SPEC 
     1373             (SETQ TYPE (VALIDATE-FUNCTION-SPEC FUNCTION-SPEC)) 
     1374             "a symbol or a function-spec list") 
     1375  (IF (SYMBOLP FUNCTION-SPEC) (FMAKUNBOUND FUNCTION-SPEC) 
     1376      (FUNCALL (GET TYPE 'FUNCTION-SPEC-HANDLER) 'FUNDEFINE FUNCTION-SPEC))) 
     1377 
     1378(DEFUN FDEFINITION-LOCATION (FUNCTION-SPEC &AUX TYPE) 
     1379  "Returns a locative pointer to the cell containing the function spec's definition" 
     1380  ;; First, validate the function spec and determine its type 
     1381  (CHECK-ARG FUNCTION-SPEC 
     1382             (SETQ TYPE (VALIDATE-FUNCTION-SPEC FUNCTION-SPEC)) 
     1383             "a symbol or a function-spec list") 
     1384  (IF (SYMBOLP FUNCTION-SPEC) (LOCF (FSYMEVAL FUNCTION-SPEC)) 
     1385      (FUNCALL (GET TYPE 'FUNCTION-SPEC-HANDLER) 'FDEFINITION-LOCATION FUNCTION-SPEC))) 
     1386 
     1387(DEFUN FUNCTION-PARENT (FUNCTION-SPEC &AUX TYPE DEF TEM) 
     1388  (DECLARE (RETURN-LIST NAME TYPE)) 
     1389  "Returns NIL or the name of another definition which has the same source code. 
     1390The second value is the type of that definition (which can be NIL). 
     1391This is used for things like internal functions, methods automatically 
     1392created by a defflavor, and macros automatically created by a defstruct." 
     1393  ;; First, validate the function spec and determine its type 
     1394  (CHECK-ARG FUNCTION-SPEC 
     1395             (SETQ TYPE (VALIDATE-FUNCTION-SPEC FUNCTION-SPEC)) 
     1396             "a symbol or a function-spec list") 
     1397  (COND ((AND (FDEFINEDP FUNCTION-SPEC) 
     1398              (SETQ TEM (CDR (ASSQ 'FUNCTION-PARENT 
     1399                                   (DEBUGGING-INFO (SETQ DEF (FDEFINITION FUNCTION-SPEC))))))) 
     1400         (VALUES (CAR TEM) (CADR TEM))) 
     1401        ((AND (LISTP DEF) (EQ (CAR DEF) 'MACRO) (SYMBOLP (CDR DEF))  ;for DEFSTRUCT 
     1402              (SETQ DEF (GET (CDR DEF) 'MACROEXPANDER-FUNCTION-PARENT))) 
     1403         (FUNCALL DEF FUNCTION-SPEC)) 
     1404        ((NOT (SYMBOLP FUNCTION-SPEC)) 
     1405         (FUNCALL (GET TYPE 'FUNCTION-SPEC-HANDLER) 'FUNCTION-PARENT FUNCTION-SPEC)))) 
     1406 
     1407;; (:LOCATION locative-or-list-pointer) refers to the CDR of the pointer. 
     1408;; This is for pointing at an arbitrary place which there is no special 
     1409;; way to describe. 
     1410(DEFPROP :LOCATION LOCATION-FUNCTION-SPEC-HANDLER FUNCTION-SPEC-HANDLER) 
     1411(DEFUN LOCATION-FUNCTION-SPEC-HANDLER (FUNCTION FUNCTION-SPEC &OPTIONAL ARG1 ARG2) 
     1412  (LET ((LOC (SECOND FUNCTION-SPEC))) 
     1413    (SELECTQ FUNCTION 
     1414      (VALIDATE-FUNCTION-SPEC (AND (= (LENGTH FUNCTION-SPEC) 2) 
     1415                                   (OR (= (%DATA-TYPE LOC) DTP-LOCATIVE) 
     1416                                       (= (%DATA-TYPE LOC) DTP-LIST)))) 
     1417      (FDEFINE (RPLACD LOC ARG1)) 
     1418      (FDEFINITION (CDR LOC)) 
     1419      (FDEFINEDP (AND ( (%P-DATA-TYPE LOC) DTP-NULL) (NOT (NULL (CDR LOC))))) 
     1420      (FDEFINITION-LOCATION LOC) 
     1421        ;FUNDEFINE could store DTP-NULL, which would only be right sometimes 
     1422      (OTHERWISE (FUNCTION-SPEC-DEFAULT-HANDLER FUNCTION FUNCTION-SPEC ARG1 ARG2))))) 
     1423 
     1424;Convert old Maclisp-style property function specs 
     1425(DEFUN STANDARDIZE-FUNCTION-SPEC (FUNCTION-SPEC) 
     1426  (AND (LISTP FUNCTION-SPEC) 
     1427       (= (LENGTH FUNCTION-SPEC) 2) 
     1428       (SYMBOLP (CAR FUNCTION-SPEC)) 
     1429       (NOT (GET (CAR FUNCTION-SPEC) 'FUNCTION-SPEC-HANDLER)) 
     1430       (SETQ FUNCTION-SPEC (CONS ':PROPERTY FUNCTION-SPEC))) 
     1431  (OR (VALIDATE-FUNCTION-SPEC FUNCTION-SPEC) 
     1432      (FERROR NIL "~S is not a valid function spec" FUNCTION-SPEC)) 
     1433  FUNCTION-SPEC) 
     1434 
     1435(DEFPROP DEFUN "Function" DEFINITION-TYPE-NAME) 
     1436(DEFPROP DEFVAR "Variable" DEFINITION-TYPE-NAME) 
     1437 
     1438;; Query about any irregularities about redefining the given function symbol now. 
     1439;; Return T to tell caller to go ahead and redefine the symbol 
     1440;; (no problems or user says ok), NIL to leave it unchanged. 
     1441(DEFUN QUERY-ABOUT-REDEFINITION (FUNCTION-SPEC NEW-PATHNAME TYPE OLD-PATHNAME) 
     1442  ;; Detect any cross-file redefinition worth complaining about. 
     1443  (COND ((OR (EQ (IF (STRINGP OLD-PATHNAME) OLD-PATHNAME 
     1444                     (FUNCALL OLD-PATHNAME ':TRANSLATED-PATHNAME)) 
     1445                 (IF (STRINGP NEW-PATHNAME) NEW-PATHNAME 
     1446                     (FUNCALL NEW-PATHNAME ':TRANSLATED-PATHNAME))) 
     1447             (MEMQ OLD-PATHNAME (FUNCALL NEW-PATHNAME ':GET ':REDEFINES-FILES))) 
     1448         T) 
     1449        (T 
     1450         (FORMAT QUERY-IO 
     1451"~&WARNING: ~A ~S being illegally redefined by file ~A. 
     1452It was previously defined by file ~A." 
     1453                 (OR (GET TYPE 'DEFINITION-TYPE-NAME) TYPE) FUNCTION-SPEC 
     1454                 NEW-PATHNAME OLD-PATHNAME) 
     1455         (COND ((EQ INHIBIT-FDEFINE-WARNINGS ':JUST-WARN)) 
     1456               (T 
     1457                (FORMAT QUERY-IO " OK? (type Y, N, E, P or [HELP]) ") 
     1458                (FUNCALL QUERY-IO ':CLEAR-INPUT) 
     1459                (DO () (NIL) 
     1460                  (SELECTQ (CHAR-UPCASE (FUNCALL QUERY-IO ':TYI)) 
     1461                    ((#/Y #/T #\SP) 
     1462                     (PRINC "Yes." QUERY-IO) 
     1463                     (RETURN T)) 
     1464                    ((#/E) 
     1465                     (PRINC "Error." QUERY-IO) 
     1466                     (CERROR T NIL ':ILLEGAL-FUNCTION-DEFINITION 
     1467                       "~A ~S being illegally redefined by file ~A. 
     1468It was previously defined by file ~A." 
     1469                             (OR (GET TYPE 'DEFINITION-TYPE-NAME) TYPE) FUNCTION-SPEC 
     1470                             NEW-PATHNAME OLD-PATHNAME) 
     1471                     (RETURN T)) 
     1472                    ((#/N #\RUBOUT) 
     1473                     (PRINC "No." QUERY-IO) 
     1474                     (RETURN NIL)) 
     1475                    (#/P 
     1476                     (PRINC "Proceed." QUERY-IO) 
     1477                     (PUSH OLD-PATHNAME (FUNCALL NEW-PATHNAME ':GET ':REDEFINES-FILES)) 
     1478                     (RETURN T)) 
     1479                    ((#/? #\HELP) 
     1480                     (PRINC " 
    11701481Type Y to proceed to redefine the function, N to not redefine it, E to go into the 
    1171  error handler, or P to proceed and not ask in the future (for this pair of files): " 
    1172                                            QUERY-IO)) 
    1173                       (OTHERWISE (FORMAT QUERY-IO "~& Type Y, N, E, P or [HELP]: ")))))) 
    1174            (RECORD-SOURCE-FILE-NAME FUNCTION-SPEC) 
    1175            (FSET FUNCTION-SPEC DEFINITION) 
    1176            (RETURN-FROM FDEFINE T)) 
    1177           (T 
    1178            (RETURN-FROM FDEFINE 
    1179              (SELECTQ (CAR FUNCTION-SPEC) 
    1180                (:METHOD 
    1181                 (LET ((CS (CADR FUNCTION-SPEC)) 
    1182                       (OP (CADDR FUNCTION-SPEC))) 
    1183                   (COND ((GET CS 'FLAVOR) 
    1184                          (FDEFINE-FLAVOR FUNCTION-SPEC DEFINITION CAREFULLY-FLAG FORCE-FLAG)) 
    1185                         ((NOT (CLASS-SYMBOLP CS)) 
    1186                          (FERROR NIL "Attempt to define method on ~S, which is not a CLASS" 
    1187                                  CS)) 
    1188                         (T 
    1189                          (LET ((MN (MAKE-METHOD-NAME CS OP))) 
    1190                            (COND ((FDEFINE MN DEFINITION CAREFULLY-FLAG FORCE-FLAG) 
    1191                                   ;; Can't send message because this has to work during 
    1192                                   ;; loadup before messages work. 
    1193                                   (ADD-METHOD CS 
    1194                                               (SYMEVAL-IN-CLOSURE (SYMEVAL CS) 
    1195                                                                   'CLASS-METHOD-SYMBOL) 
    1196                                               OP 
    1197                                               MN) 
    1198                                   T))))))) 
    1199                (:INSTANCE-METHOD 
    1200                 (LET ((INST (EVAL (CADR FUNCTION-SPEC))) 
    1201                       (OP (CADDR FUNCTION-SPEC))) 
    1202                   (LET ((MN (MAKE-INSTANCE-METHOD-NAME INST OP))) 
    1203                     (COND ((FDEFINE MN DEFINITION CAREFULLY-FLAG FORCE-FLAG) 
    1204                            (ADD-INSTANCE-METHOD INST OP MN) 
    1205                            T))))) 
    1206                (:PROPERTY 
    1207                 (PUTPROP (CADR FUNCTION-SPEC) DEFINITION (CADDR FUNCTION-SPEC)) 
    1208                 T) 
    1209                (OTHERWISE 
    1210                 (PUTPROP (CAR FUNCTION-SPEC) DEFINITION (CADR FUNCTION-SPEC)) 
    1211                 T))))))) 
    1212  
    1213 ;; This is an old name which everyone uses. 
    1214 ;; It must be defined after FDEFINE since we are clobbering a 
    1215 ;; temporary patch which is made so that FASLOAD can load before QMISC is loaded. 
    1216  
    1217 (DEFUN FSET-CAREFULLY (FUNCTION-SPEC DEFINITION &OPTIONAL FORCE-FLAG) 
    1218     (FDEFINE FUNCTION-SPEC DEFINITION T FORCE-FLAG)) 
     1482error handler, or P to proceed and not ask in the future (for this pair of files): " 
     1483                            QUERY-IO)) 
     1484                    (OTHERWISE (FORMAT QUERY-IO "~& Type Y, N, E, or [HELP]: "))))))))) 
    12191485 
    12201486;Restore the saved previous function definition of a symbol. 
    1221 (DEFUN UNDEFUN (SYMBOL &AUX TEM) 
    1222     (SETQ TEM (GET SYMBOL ':PREVIOUS-DEFINITION)) 
    1223     (OR TEM (FERROR NIL "~S has no previous function definition" SYMBOL)) 
    1224     (FSET-CAREFULLY SYMBOL TEM T)) 
    1225  
    1226 ;Get the documentation string for a function 
     1487(DEFUN UNDEFUN (FUNCTION-SPEC &AUX TEM) 
     1488    (SETQ TEM (FUNCTION-SPEC-GET FUNCTION-SPEC ':PREVIOUS-DEFINITION)) 
     1489    (OR TEM (FERROR NIL "~S has no previous function definition" FUNCTION-SPEC)) 
     1490    (FSET-CAREFULLY FUNCTION-SPEC TEM T)) 
     1491 
     1492;;; Some source file stuff that does not need to be in QRAND 
     1493(DEFUN GET-SOURCE-FILE-NAME (FUNCTION-SPEC &OPTIONAL TYPE) 
     1494  (DECLARE (RETURN-LIST PATHNAME TYPE)) 
     1495  (LET ((PROPERTY (FUNCTION-SPEC-GET FUNCTION-SPEC ':SOURCE-FILE-NAME))) 
     1496    (COND ((NULL PROPERTY) NIL) 
     1497          ((NLISTP PROPERTY) 
     1498           (AND (MEMQ TYPE '(DEFUN NIL)) 
     1499                (VALUES PROPERTY 'DEFUN))) 
     1500          (T 
     1501           (LET ((LIST (IF TYPE (ASSQ TYPE PROPERTY) (CAR PROPERTY)))) 
     1502             (LOOP FOR FILE IN (CDR LIST) 
     1503                   WHEN (NOT (FUNCALL FILE ':GET ':PATCH-FILE)) 
     1504                   RETURN (VALUES FILE (CAR LIST)))))))) 
     1505 
     1506(DEFUN GET-ALL-SOURCE-FILE-NAMES (FUNCTION-SPEC) 
     1507  (LET ((PROPERTY (FUNCTION-SPEC-GET FUNCTION-SPEC ':SOURCE-FILE-NAME))) 
     1508    (COND ((NULL PROPERTY) NIL) 
     1509          ((NLISTP PROPERTY) 
     1510           (SETQ PROPERTY `((DEFUN ,PROPERTY))) 
     1511           ;; May as well save this consing. 
     1512           (FUNCTION-SPEC-PUTPROP FUNCTION-SPEC PROPERTY ':SOURCE-FILE-NAME) 
     1513           PROPERTY) 
     1514          (T PROPERTY)))) 
     1515 
     1516;Get the documentation string for a function or function spec. 
    12271517;NIL if not defined or no documentation 
    1228 (DEFUN FUNCTION-DOCUMENTATION (FCN) 
     1518(DEFUN DOCUMENTATION (FCN) 
    12291519  (COND ((SYMBOLP FCN) 
    1230          (OR (AND (FBOUNDP FCN) (FUNCTION-DOCUMENTATION (FSYMEVAL FCN))) 
     1520         (OR (AND (FBOUNDP FCN) (DOCUMENTATION (FSYMEVAL FCN))) 
    12311521             (GET FCN ':DOCUMENTATION))) 
    12321522        ((LISTP FCN) 
    1233          (COND ((MEMQ (CAR FCN) '(LAMBDA NAMED-LAMBDA)) 
    1234                 (AND (EQ (CAR FCN) 'NAMED-LAMBDA) 
     1523         (COND ((MEMQ (CAR FCN) '(LAMBDA NAMED-LAMBDA SUBST NAMED-SUBST)) 
     1524                (AND (MEMQ (CAR FCN) '(NAMED-LAMBDA NAMED-SUBST)) 
    12351525                     (SETQ FCN (CDR FCN))) 
    12361526                (SETQ FCN (CDDR FCN)) 
     
    12421532                     (CAR FCN))) 
    12431533               ((EQ (CAR FCN) 'MACRO) 
    1244                 (FUNCTION-DOCUMENTATION (CDR FCN))) 
     1534                (DOCUMENTATION (CDR FCN))) 
    12451535               (T 
    1246                 (AND (FDEFINEDP FCN) (FUNCTION-DOCUMENTATION (FDEFINITION FCN)))))) 
     1536                (AND (FDEFINEDP FCN) (DOCUMENTATION (FDEFINITION FCN)))))) 
    12471537        ((= (%DATA-TYPE FCN) DTP-FEF-POINTER) 
    12481538         (CADR (ASSQ ':DOCUMENTATION (FUNCTION-DEBUGGING-INFO FCN)))))) 
     1539 
     1540;Old name. 
     1541(DEFF FUNCTION-DOCUMENTATION 'DOCUMENTATION) 
    12491542 
    12501543;These are for reading in QCOM, and the like 
     
    13281621    (EVAL `(LET ,BINDLIST . ,BODY))) 
    13291622 
    1330 (DEFUN DISK-RESTORE (&OPTIONAL PARTITION) 
    1331     (LET ((L (DISK-RESTORE-DECODE PARTITION))) 
    1332          (AND (YES-OR-NO-P "Do you really want to reload? (Yes or No)") 
    1333               (%DISK-RESTORE (CAR L) (CADR L))))) 
     1623(DEFUN DISK-RESTORE (&OPTIONAL PARTITION &AUX NAME COMMENT DESIRED-UCODE) 
     1624  (LET ((L (DISK-RESTORE-DECODE PARTITION)) (RQB NIL) BLOCK) 
     1625    (UNWIND-PROTECT 
     1626      (PROGN (SETQ RQB (GET-DISK-RQB)) 
     1627             (READ-DISK-LABEL RQB 0) 
     1628             (SETQ NAME (IF PARTITION 
     1629                            (STRING-APPEND (LDB 0010 (CADR L)) (LDB 1010 (CADR L)) 
     1630                                           (LDB 0010 (CAR L)) (LDB 1010 (CAR L))) 
     1631                            (GET-DISK-STRING RQB 7 4))) 
     1632             (SETQ BLOCK (FIND-DISK-PARTITION-FOR-READ NAME RQB) 
     1633                   COMMENT (PARTITION-COMMENT NAME 0)) 
     1634             (DISK-READ RQB 0 (1+ BLOCK)) 
     1635             (SETQ DESIRED-UCODE (AREF (RQB-BUFFER RQB) 
     1636                                       (* 2 %SYS-COM-DESIRED-MICROCODE-VERSION)))) 
     1637      (RETURN-DISK-RQB RQB)) 
     1638    (AND ( DESIRED-UCODE %MICROCODE-VERSION-NUMBER) 
     1639         (NOT (ZEROP DESIRED-UCODE))            ;Not stored yet 
     1640         (FORMAT QUERY-IO 
     1641                 "~&That band prefers microcode ~D but the running microcode is ~D.~%" 
     1642                 DESIRED-UCODE %MICROCODE-VERSION-NUMBER)) 
     1643    (COND ((FQUERY FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS 
     1644                   "Do you really want to reload ~A (~A)? " NAME COMMENT) 
     1645           (TV:CLOSE-ALL-SERVERS "Disk-Restoring") 
     1646           (%DISK-RESTORE (CAR L) (CADR L)))))) 
    13341647 
    13351648(DEFVAR WHO-LINE-JUST-COLD-BOOTED-P NIL) ;Set to T upon cold boot for who-line's benefit 
     
    13401653                                   (LDB 0010 (CAR L)) (LDB 1010 (CAR L)))) 
    13411654         PART-SIZE) 
    1342     (COND ((YES-OR-NO-P (FORMAT NIL "Do you really want to clobber partition ~A? (Yes or No)" 
    1343                                     PART-NAME)) 
    1344            (GET-NEW-SYSTEM-VERSION)     ;Update system version ID 
    1345            (UPDATE-PARTITION-COMMENT PART-NAME SYSTEM-VERSION-STRING 0) 
    1346            (MULTIPLE-VALUE (NIL PART-SIZE) (FIND-DISK-PARTITION PART-NAME)) 
    1347            (LOGOUT) 
    1348            (CHAOS:RESET) 
    1349             
    1350            ;Cause cold boot initializations to happen when rebooted 
    1351            ;and do the BEFORE-COLD initializations now 
    1352            (INITIALIZATIONS 'BEFORE-COLD-INITIALIZATION-LIST T) 
    1353            (RESET-INITIALIZATIONS 'COLD-INITIALIZATION-LIST) 
    1354            (SETQ WHO-LINE-JUST-COLD-BOOTED-P T) 
    1355             
    1356            ;Determine size of storage used.  Hope no region-consing happens 
    1357            ;after this (presumably no one is doing anything).  Just to be 
    1358            ;sure, we inhibit scheduling. 
    1359            (DO ((INHIBIT-SCHEDULING-FLAG T) 
    1360                 (REGION 0 (1+ REGION)) 
    1361                 (MAX-ADDR 0)) 
    1362                ((= REGION (REGION-LENGTH REGION-LENGTH)) 
    1363                 (SETQ CURRENT-PROCESS NIL)      ;Prevent error message upon coming up 
    1364                 (SETQ MAX-ADDR (// MAX-ADDR PAGE-SIZE)) ;Number of pages 
    1365                 (AND (> MAX-ADDR PART-SIZE) (FERROR NIL "Cannot save, partition too small")) 
    1366                 ;; Store the size in words rather than pages.  But don't get a bignum! 
    1367                 (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-VALID-SIZE) (LSH MAX-ADDR 8)) 
    1368                 (DO I 600 (1+ I) (= I 640)      ;Clear the disk error log 
    1369                   (%P-STORE-TAG-AND-POINTER I 0 0)) 
    1370                 (%DISK-SAVE (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE) 
    1371                             (CAR L) (CADR L))) 
    1372              (COND ((NOT (= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) 
    1373                             %REGION-SPACE-FREE)) 
    1374                     (SETQ MAX-ADDR (MAX MAX-ADDR (+ (REGION-ORIGIN REGION) 
    1375                                                     (REGION-LENGTH REGION))))))))))) 
     1655    (MULTIPLE-VALUE (NIL PART-SIZE) (FIND-DISK-PARTITION-FOR-WRITE PART-NAME)) 
     1656    (ASSURE-CC-SYMBOLS-LOADED) 
     1657    (IF (> (FIND-MAX-ADDR) PART-SIZE) 
     1658        ;; This test is not necessarily accurate, since we have not 
     1659        ;; yet shut off the world.  However, it should catch most cases, 
     1660        ;; so that this error will be detected before the partition comment 
     1661        ;; gets clobbered. 
     1662        (FERROR NIL "Cannot save, partition too small")) 
     1663    (UPDATE-PARTITION-COMMENT PART-NAME (GET-NEW-SYSTEM-VERSION) 0) 
     1664    (LOGOUT) 
     1665     
     1666    ;; Cause cold boot initializations to happen when rebooted 
     1667    ;; and do the BEFORE-COLD initializations now 
     1668    (INITIALIZATIONS 'BEFORE-COLD-INITIALIZATION-LIST T) 
     1669    (RESET-INITIALIZATIONS 'COLD-INITIALIZATION-LIST) 
     1670    (SETQ WHO-LINE-JUST-COLD-BOOTED-P T) 
     1671     
     1672    ;; Now shut down the world and check the partition size for real, just 
     1673    ;; to make sure that we didn't exceed the size very recently. 
     1674    (DOLIST (S TV:ALL-THE-SCREENS) (TV:SHEET-GET-LOCK S)) 
     1675    (TV:WITH-MOUSE-USURPED 
     1676      (WITHOUT-INTERRUPTS 
     1677        (SETQ TV:MOUSE-SHEET NIL) 
     1678        (DOLIST (S TV:ALL-THE-SCREENS) 
     1679          (FUNCALL S ':DEEXPOSE) 
     1680          (TV:SHEET-RELEASE-LOCK S)) 
     1681        (SETQ CURRENT-PROCESS NIL)      ;Prevent error message upon coming up 
     1682        (LET ((MAX-ADDR (FIND-MAX-ADDR))) 
     1683          (COND ((> MAX-ADDR PART-SIZE) 
     1684                 (FUNCALL TV:MAIN-SCREEN ':EXPOSE) 
     1685                 (FERROR NIL "Cannot save, partition too small.  Warm Boot please."))) 
     1686          ;; Store the size in words rather than pages.  But don't get a bignum! 
     1687          (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-VALID-SIZE) (LSH MAX-ADDR 8)) 
     1688          (DO I 600 (1+ I) (= I 640)    ;Clear the disk error log 
     1689              (%P-STORE-TAG-AND-POINTER I 0 0)) 
     1690          (%DISK-SAVE (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE) 
     1691                      (CAR L) (CADR L))))))) 
     1692 
     1693(DEFUN ASSURE-CC-SYMBOLS-LOADED () 
     1694  (MULTIPLE-VALUE-BIND (NIL CURRENT-VERSION) 
     1695      (AND CADR:CC-FILE-SYMBOLS-LOADED-FROM 
     1696           (FUNCALL CADR:CC-FILE-SYMBOLS-LOADED-FROM ':TYPE-AND-VERSION)) 
     1697    (COND ((NEQ CURRENT-VERSION %MICROCODE-VERSION-NUMBER) 
     1698           (FORMAT T "~%Loading CC symbols for UCADR version ~D~%" %MICROCODE-VERSION-NUMBER) 
     1699           (LET ((IBASE 8)) 
     1700             (PKG-BIND "CADR" 
     1701               (CADR:CC-LOAD-UCODE-SYMBOLS-FOR-VERSION %MICROCODE-VERSION-NUMBER))))))) 
     1702 
     1703;;; Find the highest address in the virtual memory.  If you call this without 
     1704;;; inhibiting interrupts, the result is not strictly correct since some 
     1705;;; other process could invalidate it at any time by CONSing.  However, 
     1706;;; it gives you a good idea and a lower bound.  The answer is in number 
     1707;;; of pages. 
     1708(DEFUN FIND-MAX-ADDR () 
     1709  (DO ((REGION 0 (1+ REGION)) 
     1710       (MAX-ADDR 0)) 
     1711      ((= REGION (REGION-LENGTH REGION-LENGTH)) 
     1712       (// MAX-ADDR PAGE-SIZE)) 
     1713    ;; Check each region.  If it is free, ignore it.  Otherwise, 
     1714    ;; find the highest address of that region, and get the 
     1715    ;; highest such address. 
     1716    (COND ((NOT (= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) 
     1717                   %REGION-SPACE-FREE))     
     1718           (SETQ MAX-ADDR (MAX MAX-ADDR (+ (REGION-ORIGIN-TRUE-VALUE REGION) 
     1719                                           (REGION-LENGTH REGION)))))))) 
     1720 
     1721(DEFUN REGION-ORIGIN-TRUE-VALUE (REGION) 
     1722        ;below crock avoids returning a negative number if region starts above 
     1723        ; half way point in address space.  It can make a bignum so be careful! 
     1724  (MAKE-24-BIT-UNSIGNED (REGION-ORIGIN REGION))) 
     1725 
    13761726 
    13771727(DEFUN DISK-RESTORE-DECODE (PARTITION &AUX LOW-16-BITS HI-16-BITS) 
     
    13821732           (SETQ HI-16-BITS (+ #/D (LSH (+ #/0 PARTITION) 8)))) 
    13831733          ((STRINGP PARTITION) 
    1384            (SETQ LOW-16-BITS (+ (AR-1 PARTITION 0) (LSH (AR-1 PARTITION 1) 8))) 
    1385            (SETQ HI-16-BITS (+ (AR-1 PARTITION 2) (LSH (AR-1 PARTITION 3) 8)))) 
     1734           (SETQ LOW-16-BITS (+ (CHAR-UPCASE (AR-1 PARTITION 0)) 
     1735                                (LSH (CHAR-UPCASE (AR-1 PARTITION 1)) 8))) 
     1736           (SETQ HI-16-BITS (+ (CHAR-UPCASE (AR-1 PARTITION 2)) 
     1737                               (LSH (CHAR-UPCASE (AR-1 PARTITION 3)) 8)))) 
    13861738          (T (FERROR NIL "~S is not a valid partition name" PARTITION))) 
    13871739    (LIST HI-16-BITS LOW-16-BITS)) 
    1388  
    1389 ;This is a temporary function, which turns on the "extra-pdl" feature 
    1390 (DEFUN NUMBER-GC-ON (&OPTIONAL (ON-P T)) 
    1391   (SETQ NUMBER-CONS-AREA 
    1392         (COND (ON-P EXTRA-PDL-AREA) 
    1393               (T WORKING-STORAGE-AREA)))) 
    1394  
    1395 (DEFUN PRINT-MODIFICATION-RECORD () 
    1396     (FORMAT T "~&System:~18TModification:") 
    1397     (DO ((L (REVERSE SYSTEM-MODIFICATION-RECORD) (CDR L))) 
    1398         ((NULL L)) 
    1399       (FORMAT T "~%~A ~18T~A" (CAAR L) (CADAR L))) 
    1400     (TERPRI)) 
    14011740 
    14021741(DEFUN GET-FROM-ALTERNATING-LIST (L KEY)  
    14031742"Retreive associated item from an alternating list 
    14041743Like GET, but no initial CAR" 
    1405   (PROG NIL 
    1406      L  (COND ((NULL L)(RETURN NIL)) 
    1407               ((EQ KEY (CAR L)) 
    1408                (RETURN (CADR L)))) 
    1409         (SETQ L (CDDR L)) 
    1410         (GO L))) 
     1744  (GET (LOCF L) KEY)) 
    14111745 
    14121746(DEFUN PUT-ON-ALTERNATING-LIST (ITEM L KEY) 
     
    14581792  (OR (= (%P-LDB-OFFSET %%ARRAY-DISPLACED-BIT ARRAY 0) 1) 
    14591793      (FERROR NIL "~S is not a displaced array" ARRAY)) 
    1460   (CHECK-ARG DISPLACED-P ARRAYP "an array to indirect to") 
     1794  (CHECK-ARG DISPLACED-P (OR (ARRAYP DISPLACED-P) (FIXP DISPLACED-P)) 
     1795             "an array or physical address to indirect to") 
    14611796  (CHECK-ARG TYPE               ;TEM gets the numeric array type 
    14621797             (SETQ TEM (COND ((NUMBERP TYPE) (LDB %%ARRAY-TYPE-FIELD TYPE)) 
     
    15111846             OLD-VALUE (COND ((BOUNDP SYM) 
    15121847                              (CAR ADR))) 
    1513              NEW-ARRAY (MAKE-ARRAY NIL ART-Q-LIST 2)) 
     1848             NEW-ARRAY (MAKE-ARRAY 2 ':TYPE ART-Q-LIST)) 
    15141849       (AS-1 OLD-VALUE NEW-ARRAY 0)   ;MOVE CURRENT VALUE TO NEW PLACE 
    15151850       (AS-1 MONITOR-FUNCTION NEW-ARRAY 1) 
     
    15371872  (FORMAT T "~%Changing ~S from ~S to ~S" SYM OLD NEW)) 
    15381873) 
     1874 
     1875(DEFUN IGNORE (&REST IGNORE) NIL) 
     1876 
     1877;;; Read a number out of a string (starting at FROM, in the given RADIX). 
     1878;;; Returns the number, or NIL if no number was seen. 
     1879;;; Second value returned is where in the string the number ended 
     1880;;; (index of first non-digit). 
     1881(DEFUN PARSE-NUMBER (STRING &OPTIONAL (FROM 0) TO (RADIX 10.)) 
     1882  (DO ((I FROM (1+ I)) 
     1883       (CH) 
     1884       (NUM 0) 
     1885       (FIRSTP T NIL) 
     1886       (LIM (OR TO (STRING-LENGTH STRING)))) 
     1887      (NIL) 
     1888    (AND ( 
     1889 I LIM) 
     1890         (RETURN (AND (NOT FIRSTP) NUM) I)) 
     1891    (SETQ CH (AREF STRING I)) 
     1892    (COND ((OR (< CH #/0) 
     1893               (> CH #/9)) 
     1894           (RETURN (AND (NOT FIRSTP) NUM) I))) 
     1895    (SETQ NUM (+ (* NUM RADIX) (- CH #/0))))) 
     1896 
     1897;;; "Print" a number into an array the fast way 
     1898(DEFUN NUMBER-INTO-ARRAY (ARRAY N &OPTIONAL (RADIX BASE) (AT-INDEX 0) (MIN-COLUMNS 0) 
     1899                                  &AUX QUOT) 
     1900  (IF (ZEROP (SETQ QUOT (// N RADIX))) 
     1901      (DOTIMES (I (1- MIN-COLUMNS)) 
     1902        (ASET #\SP ARRAY AT-INDEX) 
     1903        (SETQ AT-INDEX (1+ AT-INDEX))) 
     1904      (SETQ AT-INDEX (NUMBER-INTO-ARRAY ARRAY QUOT RADIX AT-INDEX (1- MIN-COLUMNS)))) 
     1905  (ASET (+ #/0 (\ N RADIX)) ARRAY AT-INDEX) 
     1906  (1+ AT-INDEX)) 
     1907 
     1908;;; Add an array to the end of another 
     1909(DEFUN APPEND-TO-ARRAY (TO-ARRAY FROM-ARRAY &OPTIONAL (FROM-START 0) FROM-END 
     1910                                            &AUX OLD-LENGTH NEW-LENGTH) 
     1911  (OR FROM-END (SETQ FROM-END (ARRAY-ACTIVE-LENGTH FROM-ARRAY))) 
     1912  (SETQ NEW-LENGTH (+ (SETQ OLD-LENGTH (ARRAY-LEADER TO-ARRAY 0)) (- FROM-END FROM-START))) 
     1913  (AND (< (ARRAY-LENGTH TO-ARRAY) NEW-LENGTH) (ADJUST-ARRAY-SIZE TO-ARRAY NEW-LENGTH)) 
     1914  (COPY-ARRAY-PORTION FROM-ARRAY FROM-START FROM-END TO-ARRAY OLD-LENGTH NEW-LENGTH) 
     1915  (STORE-ARRAY-LEADER NEW-LENGTH TO-ARRAY 0))