;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Patch file for SYSTEM version 6.4 ;;; Reason: Fix CL package to have correct symbols. ;;; Add Common-Lisp version of GENSYM, FIND-SYMBOL, INTERN. ;;; Fix MX Common-Lisp package-use-list of COMMON-LISP package. ;;; Written 06/05/89 11:10:31 by SWEDE, ;;; while running on ERIK from band LODX ;;; With SYSTEM 6.3, VIRTUAL-MEMORY 6.1, EH 6.0, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.0, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.2, TV 6.6, DATALINK 6.0, CHAOSNET 6.0, GC 6.1, MEMORY-AUX 6.0, NVRAM 6.0, ;;; SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0, ;;; DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.0, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.0, TI-CLOS 6.5, CLEH 6.0, microcode 429, ;;; Band Name: Release 6.0 - 5/19 #!C ; From file SYMBOLS.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; INITIAL-PACKAGES-MX.#" ;; Fix the MX package-use-list of COMMON-LISP (eval-when (load eval) (dolist (x (package-use-list (find-package 'cl))) ; fix the cl package on MX's (let ((*package* (find-package 'cl))) (unuse-package (list x))))) (when (si:MX-P) (Defconstant INITIAL-PACKAGES '( ("KEYWORD" . (:NICKNAMES ("") :SIZE 5000. :USE NIL :AFTER-INTERN-DAEMON EXTERNALIZE-ALL-SYMBOLS :Prefix-Name "")) ("LISP" . (:NICKNAMES ("CLI" "COMMON-LISP-INCOMPATIBLE" "COMMON-LISP-GLOBAL") :SIZE 1009. :USE ("TICL") :PREFIX-NAME "LISP")) ("COMMON-LISP" . (:NICKNAMES ("CL") :USE NIL :SIZE 800. :PREFIX-NAME "COMMON-LISP")) ; JLM 6/5/89 ("TICL" . (:NICKNAMES ("EECL") :SIZE 719. :USE NIL)) ("SYSTEM" . (:NICKNAMES ("SYS" "SI" "SYSTEM-INTERNALS") :SIZE 11273. :PREFIX-NAME "SYS" :AREA *KERNEL-SYMBOL-AREA*)) ("ZLC" . (:SIZE 307. :USE ("LISP" "TICL") :Prefix-Name "ZLC")) ("GLOBAL" . (:NICKNAMES ("ZETALISP" "ZL" "ZETALISP-GLOBAL") :SIZE 1973. :USE NIL :Prefix-Name "GLOBAL")) ("COMPILER" . (:SIZE 2800. :NICKNAMES ("COMPILER2") :USE ("ZLC" "TICL" "LISP" "SYS") :AREA *COMPILER-SYMBOL-AREA* :Prefix-Name "COMPILER")) ("USER" . (:SIZE 2000. :USE ("ZLC" "TICL" "LISP") :Prefix-Name "USER" :AREA *USER-SYMBOL-AREA*)) ("COMMON-LISP-USER" . (:SIZE 2000. :USE ("COMMON-LISP") :NICKNAMES ("CL-USER") :PREFIX-NAME "CL-USER" :AREA *USER-SYMBOL-AREA*)) ("FORMAT" . (:size 400 :use ("LISP" "TICL") :Prefix-Name "FORMAT" :AREA *KERNEL-SYMBOL-AREA*)) ("FILE-SYSTEM" . (:SIZE 2500. :USE ("SYS" "TICL" "LISP") :NICKNAMES ("FS") :PREFIX-NAME "FS")) ("TV" . (:SIZE 4500. :USE ("LISP" "TICL" "SYS") :Prefix-Name "TV" :AREA *KERNEL-SYMBOL-AREA*)) ("W" . (:SIZE 1000. :USE ("LISP" "TICL" "SYS" "TV") :Prefix-Name "W")) ("EH" . (:SIZE 1500. :USE ("LISP" "TICL" "SYS") :NICKNAMES ("DBG" "DEBUGGER") :Prefix-Name "EH" :AREA *KERNEL-SYMBOL-AREA*)) ("TIME" . (:SIZE 1000. :Prefix-Name "TIME")) ("FONTS" . (:AUTO-EXPORT-P T :USE ("LISP" "TICL") :Prefix-Name "FONTS" :SHADOW ("SEARCH"))) ("MATH" . (:SIZE 150. :Prefix-Name "MATH")) ("NAME" . (:SIZE 1500. :USE ("TICL" "LISP") :Prefix-Name "NAME")) ;;("HOST" . (:SIZE 1500. :USE ("TICL" "LISP") :Prefix-Name "HOST")) ;;("NET-CONFIG" . (:USE ("SYS" "TICL" "LISP") :Prefix-Name "NET-CONFIG")) ("NET" . (:SIZE 1000. :USE ("SYS" "TICL" "LISP") :Prefix-Name "NET" :NICKNAMES ("HOST"))) ("ZWEI" . (:USE ("LISP" "TICL") :SIZE 6400. :Prefix-Name "ZWEI")) ;; The following two added temporarily for the addin-board prototype band: #+LX ("BN" . (:size 400. :use ("LISP" "TICL") :nicknames ("BUSNET") :prefix-name "BN")) #+LX ("LX" . (:size 700. :use ("LISP" "TICL"))) ;; The following added for the microExplorer: ("REMOTE-PROCEDURE-CALL" . ( :size 700. :use ("LISP" "TICL") :nicknames ("RPC" "Remote Procedure Call") :prefix-name "RPC")) ("NETWORK-FILE-SYSTEM" . ( :size 900. :use ("LISP" "TICL") :nicknames ("NFS" "Network File System") :prefix-name "NFS")) ("MACINTOSH" . (:size 600. :use ("LISP" "TICL") :nicknames ("MAC" "MAC-WINDOWS") :prefix-name "MAC")) ("MICRONET" . (:size 450 :use ("TICL" "LISP" "SYSTEM") :nicknames ("ADDIN" "ADD" "AC" "ADDIN-COMM") :prefix-name "ADD")) ("TICLOS" :size 1260 :use ("TICL" "LISP") :prefix-name "TICLOS") ("CLOS" :size 166 :use ("LISP") :prefix-name "CLOS") ("CONDITIONS" . (:nicknames "CLEH")) ))) )) #!C ; From file SYMBOLS.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; SYMBOLS.#" (eval-when (load eval) (let ((added-symbols '(COMPILER:*COMPILE-VERBOSE* COMPILER:*COMPILE-PRINT* SYS:*GENSYM-COUNTER* sys:*GENSYM-PREFIX* SYS:COMPLEMENT SYS:CONSTANTLY COMPILER:DEBUG TICL:DEFPACKAGE TICLOS:DESCRIBE-OBJECT TICL:DESTRUCTURING-BIND COMPILER:DYNAMIC-EXTENT TICL:FDEFINITION SYS:FUNCTION-LAMBDA-EXPRESSION COMPILER:LOAD-TIME-VALUE TICLOS:MAKE-LOAD-FORM TICLOS:MAKE-LOAD-FORM-SAVING-SLOTS TICL:NTH-VALUE TICLOS:OPEN-STREAM-P TICL:REAL TICL:REALP COMPILER:STYLE-WARNING SYS:UPGRADED-ARRAY-ELEMENT-TYPE SYS:BASE-CHARACTER SYS:EXTENDED-CHARACTER SYS:BASE-STRING SYS:SIMPLE-BASE-STRING )) (unneeded-symbols '(COMMON COMMONP COMPILER-LET PROVIDE REQUIRE *MODULES* CHAR-FONT-LIMIT CHAR-BITS-LIMIT INT-CHAR CHAR-BITS CHAR-FONT MAKE-CHAR CHAR-CONTROL-BIT CHAR-META-BIT CHAR-SUPER-BIT CHAR-HYPER-BIT CHAR-BIT SET-CHAR-BIT )) (clos-chap-1-2-symbols ;; Symbols from chapters 1 and 2 of the CLOS spec [88-002R]: '("ADD-METHOD" "BUILT-IN-CLASS" "CALL-METHOD" "CALL-NEXT-METHOD" "CHANGE-CLASS" "CLASS-NAME" "CLASS-OF" "COMPUTE-APPLICABLE-METHODS" "DEFCLASS" "DEFGENERIC" "DEFINE-METHOD-COMBINATION" "DEFMETHOD" "ENSURE-GENERIC-FUNCTION" "FIND-CLASS" "FIND-METHOD" "FUNCTION-KEYWORDS" "GENERIC-FLET" "GENERIC-FUNCTION" "GENERIC-LABELS" "INITIALIZE-INSTANCE" "INVALID-METHOD-ERROR" "MAKE-INSTANCE" "MAKE-INSTANCES-OBSOLETE" "METHOD-COMBINATION" "METHOD-COMBINATION-ERROR" "METHOD-QUALIFIERS" "NEXT-METHOD-P" "NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "PRINT-OBJECT" "REINITIALIZE-INSTANCE" "REMOVE-METHOD" "SHARED-INITIALIZE" "SLOT-BOUNDP" "SLOT-EXISTS-P" "SLOT-MAKUNBOUND" "SLOT-MISSING" "SLOT-UNBOUND" "SLOT-VALUE" "STANDARD" "STANDARD-CLASS" "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT" "STRUCTURE-CLASS" "SYMBOL-MACROLET" "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WITH-ADDED-METHODS" "WITH-SLOTS" "WITH-ACCESSORS"))) (dolist (x added-symbols) (export x 'cl)) (dolist (x unneeded-symbols) (unintern x 'cl)) (dolist (x clos-chap-1-2-symbols) (let ((cl-sym (find-symbol x 'cl))) (when cl-sym (unintern cl-sym 'cl))) (export (find-symbol x 'clos) 'cl)) (when (find-package 'cleh) (do-external-symbols (sym 'cleh) (when (find-symbol (symbol-name sym) 'cl) (unintern (find-symbol (symbol-name sym) 'cl) 'cl)) (export (find-symbol (symbol-name sym) 'cleh) 'cl))))) ;;; ;;; The following line is temporary and must be taken out at rev 7 ;;; Also remove the above definition of GENSYM and take off the CL: from the following def ;;; (eval-when (compile load) (when (find-symbol "GENSYM" 'CL) (unintern (find-symbol "GENSYM" 'CL) 'CL))) )) #!C ; From file SYMBOLS.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; SYMBOLS.#" (defun common-lisp:gensym (&optional arg) "Return a new uninterned symbol with a generated name. Arg must be a STRING or a POSITIVE INTEGER. If ARG is a STRING, the SYMBOL-PNAME will be formed using ARG and *GENSYM-COUNTER*. If ARG is a POSITIVE INTEGER, the SYMBOL-PNAME will be formed using *GENSYM-PREFIX* and the string representation of ARG." (declare (optimize (speed 3))) (let (pname-array counter int-length string-length) (flet ((compute-length (integer) (1+ (setf counter integer int-length (do ((int integer (truncate int 10.)) (count -1 (1+ count))) ((< int 1) (max 0 count)) ())))) (make-pname-array (len) (setf pname-array (si:%allocate-and-initialize-array (si:%logdpb 1 si:%%array-number-dimensions (si:%LOGDPB '#.(POSITION :art-string (The list array-type-keywords) :test #'EQ) si:%%array-type-field (si:%LOGDPB 1 si:%%array-simple-bit len))) len ;length nil ;leader-length nil ;area (1+ (ceiling len 4)) ;4 entries per Q +1 for header )))) (declare (inline compute-length make-pname-array)) (etypecase arg (null (make-pname-array (+ (compute-length *gensym-counter*) (setf string-length (array-active-length *gensym-prefix*)))) (incf *gensym-counter*) (dotimes (ch string-length) (setf (aref pname-array ch) (aref *gensym-prefix* ch)))) (string (make-pname-array (+ (compute-length *gensym-counter*) (setf string-length (array-active-length arg)))) (incf *gensym-counter*) (dotimes (ch string-length) (setf (aref pname-array ch) (aref arg ch)))) ((integer 0 *) (make-pname-array (+ (compute-length arg) (setf string-length (array-active-length *gensym-prefix*)))) (dotimes (ch string-length) (setf (aref pname-array ch) (aref *gensym-prefix* ch)))))) (do ((divisor (expt 10. int-length) (truncate divisor 10.)) (pos string-length (1+ pos))) ((< divisor 1)) (multiple-value-bind (num rem) (truncate counter divisor) (setf (aref pname-array pos) (+ (char-code #\0) num) ;offset this number by ASCII code 0 (#o60) counter rem))) (si:%allocate-and-initialize-symbol pname-array nil))) ;;;remove the following line at rev 7 (export (find-symbol "GENSYM" 'CL) 'CL) )) #!C ; From file PACKAGES.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; PACKAGES.#" (EVAL-WHEN (compile) (Defmacro WHEN-SYMBOL-PRESENT ((pkg string hashcode word1 word0 &OPTIONAL (index (GENSYM))) &BODY body) ;; this macro expands into code which searches for a symbol in whose name matches . ;; In the event a candidate symbol is located, words 0 and 1 of its symbol table entry are placed ;; into and respectively and the forms in are executed. `(LET* ((symtab (PACK-SYMBOL-TABLE ,pkg)) ;; fetch the symbol table (length (P-NUMBER-OF-ENTRIES symtab)) ;; compute length for hashing ,word0 ,word1) (DO ((,index (REM ,hashcode length))) (()) ;; exit will occur when an entry with a null word0 is encountered or ;; possibly by code executed within (IF (SETQ ,word0 (P-WORD0 symtab ,index)) (PROGN (WHEN (AND (P-ACTIVE-ENTRY ,word0) (= ,hashcode (P-EXTRACT-CODE ,word0)) (EQUAL ,string ;; case-sensitive, font-sensitive comparison (SYMBOL-NAME (setq ,word1 (P-WORD1 symtab ,index))))) ,@body (RETURN)) (INCF ,index) ;; faster than doing "(rem hashcode length)" (WHEN (>= ,index length) (SETQ ,index 0))) (RETURN)) ;; else word0 is Nil -- terminate search. ))) (Defmacro WHEN-INTERNING ((pkg symbol hashcode &OPTIONAL (index (GENSYM))) &BODY body) ;; this macro expands into code which installs in and afterwhich executes ;; the forms in . `(LET* ((symtab (PACK-SYMBOL-TABLE ,pkg)) (length (P-NUMBER-OF-ENTRIES symtab))) (DO ((,index (REM ,hashcode length) (REM (1+ ,index) length))) ;; the DO has no body ((P-INACTIVE-ENTRY (P-WORD0 symtab ,index)) ;; upon exit, execute the following (SETF (P-WORD0 symtab ,index) ,hashcode) (SETF (P-WORD1 symtab ,index) ,symbol) (PROGN . ,body))))) ;;12/10/87 CLM - quoted ART-FAT-STRING (spr 7013). (Defmacro PARSE-STRING-ARGUMENT (string) `(IF (STRINGP ,string) (IF (EQ (ARRAY-TYPE ,string) 'ART-FAT-STRING) ;; watch out for fonted strings (STRING-REMOVE-FONTS ,string) ,string) (STRING ,string))) (Defmacro PARSE-PACKAGE-ARGUMENT (pkg) ;; expands into code which attempts to produce a package object from the argument ;; and default to *PACKAGE* if omitted. ;; Most package functions, e.g. intern, expect a package object as the second argument. `(COND ((NULL ,pkg) *PACKAGE*) ((FIND-PACKAGE ,pkg)) ;; at this point, should be a package object (T (PACKAGE-DOES-NOT-EXIST-ERROR ,pkg)))) (Defmacro SYMBOL-STRING-TO-HASH (string) `(SYS:%SXHASH-STRING ,string #xFF)) ) (eval-when (compile load) (when (find-symbol "FIND-SYMBOL" 'CL) (unintern (find-symbol "FIND-SYMBOL" 'CL) 'CL))) (EVAL-WHEN (compile load) (when (find-symbol "INTERN" 'CL) (unintern (find-symbol "INTERN" 'CL) 'CL))) )) #!C ; From file PACKAGES.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; PACKAGES.#" (Defun COMMON-LISP:FIND-SYMBOL (string &OPTIONAL pkg) "FIND-SYMBOL searches for a symbol with the print name ACCESSIBLE in package . - the search begins with itself. If such a symbol is found, it is returned. Otherwise each package USEd by is searched for an EXTERNAL symbol with print name until either such a symbol is found, in which case it is returned, or all USEd packages have been searched, in which case NIL is returned. - must be a string object - FIND-SYMBOL returns two values, the symbol found and an indicator keyword which is :external - if the symbol is present in and an external symbol of :internal - if the symbol is present in and not external :inherited - if the symbol is inherited by from some package it USEs NIL - if the symbol is not accessible in . - FIND-SYMBOL never creates a new symbol nor has any side-effects on (cf. INTERN)." (DECLARE (VALUES symbol indicator)) (CHECK-TYPE string string "a string") (LET* ((pkg (PARSE-PACKAGE-ARGUMENT pkg)) (string (PARSE-STRING-ARGUMENT string)) (hashcode (SYMBOL-STRING-TO-HASH string))) (WITHOUT-INTERRUPTS (WHEN-SYMBOL-PRESENT (pkg string hashcode entry-symbol entry-info) ;; search this package (RETURN-FROM CL:FIND-SYMBOL (VALUES entry-symbol (IF (P-EXTERNAL-SYMBOL entry-info) :EXTERNAL :INTERNAL)))) (DOLIST (pack (PACK-USE-LIST pkg)) ;; search packages used by this package (WHEN-SYMBOL-PRESENT (pack string hashcode entry-symbol entry-info) (WHEN (P-EXTERNAL-SYMBOL entry-info) ;; only external symbols are inheritable (RETURN-FROM CL:FIND-SYMBOL (VALUES entry-symbol :INHERITED)))))))) (export (find-symbol "FIND-SYMBOL" 'CL) 'CL) (Defun COMMON-LISP:INTERN (string &OPTIONAL pkg) "INTERN returns the symbol with print name ACCESSIBLE in package . - the search begins with itself. If such a symbol is found, it is returned. Otherwise each package USEd by is searched for an EXTERNAL symbol with print name until either such a symbol is found, in which case it is returned, or all USEd packages have been searched, in which case a new symbol is created with home package . - must be a string object to be a symbol. - INTERN returns two values, the symbol found and an indicator keyword which is :external - if the symbol is present in and an external symbol of :internal - if the symbol is present in and not external :inherited - if the symbol is inherited by from some package it USEs NIL - if the symbol is newly created." (DECLARE (VALUES SYMBOL ALREADY-INTERNED-FLAG)) (CHECK-TYPE string string "a string") (LET* ((pkg (PARSE-PACKAGE-ARGUMENT pkg)) (string (PARSE-STRING-ARGUMENT string)) (hashcode (SYMBOL-STRING-TO-HASH string))) (WITHOUT-INTERRUPTS (WHEN-SYMBOL-PRESENT (pkg string hashcode entry-symbol entry-info) ;; search this package (RETURN-FROM cl:intern (VALUES entry-symbol (IF (P-EXTERNAL-SYMBOL entry-info) :EXTERNAL :INTERNAL)))) (DOLIST (pack (PACK-USE-LIST pkg)) ;; search packages used by this package (WHEN-SYMBOL-PRESENT (pack string hashcode entry-symbol entry-info) (WHEN (P-EXTERNAL-SYMBOL entry-info) ;; only external symbols are inheritable (RETURN-FROM cl:intern (VALUES entry-symbol :INHERITED))))) (LET ((store-function (PACK-STORE-FUNCTION pkg)) (symbol (MAKE-SYMBOL-IN-AREA string (PACK-INTERN-AREA pkg)))) (IF store-function ;; store the symbol (FUNCALL store-function hashcode symbol pkg) (WHEN-INTERNING (pkg symbol hashcode index) (WHEN (SYMBOLP (SYMBOL-PACKAGE symbol)) ;; when no 'home' package (SETF (SYMBOL-PACKAGE symbol) pkg)) (WHEN (PACK-AFTER-INTERN-DAEMON pkg) (FUNCALL (PACK-AFTER-INTERN-DAEMON pkg) symbol pkg symtab index)) (WHEN (> (INCF (PACK-NUMBER-OF-SYMBOLS pkg)) ;; increment symbol count (PACK-MAX-NUMBER-OF-SYMBOLS pkg)) (PACKAGE-REHASH pkg)))) (VALUES symbol nil) )))) (export (find-symbol "INTERN" 'Cl) 'CL) ))