;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 123.281 ;;; Reason: ;;; When you try Meta-. on (:special-form sys:with-self-accessible) you get ;;; Read (sys:with-self-accessible) from what file? ;;; This is because ZWEI doesn't reduce (:special-form XXX) into XXX. ;;; BUT: When you try Meta-. on sys:with-self-accessible, you get gibberish: ;;; The definition of sys:with-self-accessible has the name ;;; (:internal si:special-form-funcall-error-maker 0) ;;; Visit (:internal si:special-form-funcall-error-maker 0)? ;;; This is because the :source-file-name is recorded only for (:special-form XXX) ;;; and not for XXX. ;;; ;;; Fix to (si:special-form-function-spec-handler) to put properties onto ;;; the symbol as well as storing in the function-spec hash table. ;;; Fix to ZWEI to reduce (:special-form XXX) into XXX. ;;; ;;; These changes affect only freshly loaded special forms. ;;; Wait for System 124... ;;; Written 13-May-88 18:16:32 by pld at site Gigamos Cambridge ;;; while running on Azathoth from band 3 ;;; with Experimental System 123.280, Experimental Local-File 73.6, Experimental FILE-Server 22.5, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.2, Experimental Lambda-Diag 15.0, Experimental Tape 22.4, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones. ; From modified file DJ: L.SYS; EVAL.LISP#182 at 13-May-88 19:01:15 #10R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; EVAL  " (DEFUN SPECIAL-FORM-FUNCTION-SPEC-HANDLER (FUNCTION FUNCTION-SPEC &OPTIONAL ARG1 ARG2) (LET ((SYMBOL (SECOND FUNCTION-SPEC))) (OR (EQ FUNCTION 'VALIDATE-FUNCTION-SPEC) (SPECIAL-FORM-FUNCTION-SPEC-HANDLER 'VALIDATE-FUNCTION-SPEC FUNCTION-SPEC) (FERROR 'SYS:INVALID-FUNCTION-SPEC "Invalid function spec ~S." FUNCTION-SPEC)) (CASE FUNCTION (VALIDATE-FUNCTION-SPEC (AND (= (LENGTH FUNCTION-SPEC) 2) (SYMBOLP SYMBOL))) (FDEFINE (FSET SYMBOL (SPECIAL-FORM-FUNCALL-ERROR-MAKER SYMBOL)) (SETF (INTERPRETER-SPECIAL-FORM SYMBOL) (IF (TYPEP ARG1 'INTERPRETER-SPECIAL-FORM) ARG1 (MAKE-INTERPRETER-SPECIAL-FORM NAME SYMBOL HANDLER ARG1)))) ((FDEFINITION FDEFINEDP) (INTERPRETER-SPECIAL-FORM SYMBOL)) (FDEFINITION-LOCATION (LOCF (INTERPRETER-SPECIAL-FORM SYMBOL))) (FUNDEFINE (SETF (INTERPRETER-SPECIAL-FORM SYMBOL) NIL)) (putprop (putprop symbol arg1 arg2) ;Save property for the symbol itself too (function-spec-default-handler function function-spec arg1 arg2)) (push-property (push arg1 (get symbol arg2)) (function-spec-default-handler function function-spec arg1 arg2)) (remprop (remprop symbol arg1) ;Delete property for the symbol itself too (function-spec-default-handler 'putprop function-spec nil arg1)) (OTHERWISE (FUNCTION-SPEC-DEFAULT-HANDLER FUNCTION FUNCTION-SPEC ARG1 ARG2))))) )) ; From modified file DJ: L.ZWEI; SECTIO.LISP#292 at 13-May-88 19:04:20 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  " (DEFUN SYMBOL-FROM-STRING (STR &OPTIONAL LINE OK-TO-ASK SYM &AUX ERROR-P) "Given a string STR as found after DEF..., return the name of the object being defined. LINE is the line that the string was found in. It is used for finding the particular defining construct used; this affects the result since (DEFUN (FOO BAR) defines (:PROPERTY FOO BAR) while (DEFMETHOD (FOO BAR) defines (:METHOD FOO BAR). OK-TO-ASK means in certain circumstances where things are not clear, ask the user. Otherwise we guess. The arg can also be an object; then its printed representation is used as the string. The second value is a canonicalized string for the object (maybe the same string specified, maybe not). The third is T if there was a problem in parsing the string (such as unbalanced parens). You can pass the read-in form of the object as the fourth arg if you already know it." (DECLARE (VALUES SYM STR ERROR-P)) (IF (ARRAYP STR) (UNLESS SYM (CONDITION-CASE () (SETQ SYM (CL:READ-FROM-STRING STR)) (SYS:PARSE-ERROR (SETQ ERROR-P T)))) (SETQ SYM STR STR (FORMAT NIL "~S" STR))) (COND (ERROR-P (VALUES NIL NIL ERROR-P)) ((SYMBOLP SYM) (VALUES SYM (SYMBOL-NAME SYM))) ((ATOM SYM) (VALUES NIL NIL T)) (T ;; Here SYM is a list. Certain types of function specs have two ways to ;; type them, with and without the leading type keyword. Also certain types ;; of functions and other definitions do not follow the standard form ;; of (DEFxxx name options...). What we do here is to recognize and ;; standardize those cases. The variables are: ;; TYPE - the type of function spec or non-function definition ;; SYM - the function spec or definition name ;; SPEC - the variant of SYM which appears in the source code ;; STR - SPEC converted to a string ;; :HANDLER doesn't appear in source files, but gets translated into ;; an appropriate :METHOD here, by analyzing the combined method. ;; :INTERNAL doesn't appear in source files, but might be given as the argument ;; to M-X Disassemble. The code here just tries not to destory it. (LET ((TYPE (CAR SYM)) DELIM-IDX SPEC) (IF (GET TYPE 'SI:FUNCTION-SPEC-HANDLER) (SETQ SPEC (CDR SYM) STR (DEFINITION-NAME-AS-STRING TYPE SPEC)) (SETQ SPEC SYM DELIM-IDX (AND LINE (STRING-SEARCH-SET "( " LINE 1)) TYPE (COND ((NULL LINE) ':MAYBE-METHOD) ((AND (EQ DELIM-IDX 12) (%STRING-EQUAL LINE 0 "(DEFMETHOD" 0 12)) ':ALWAYS-METHOD) ((AND (EQ DELIM-IDX 13) (%STRING-EQUAL LINE 0 "(DEFWRAPPER" 0 13)) (SETQ SPEC (LIST (CAR SPEC) ':WRAPPER (SECOND SPEC))) ':ALWAYS-METHOD) ((AND (EQ DELIM-IDX 12) (%STRING-EQUAL LINE 0 "(DEFSTRUCT" 0 12)) ':DEFSTRUCT) ((AND (EQ DELIM-IDX 12) (%STRING-EQUAL LINE 0 "(DEFSELECT" 0 12)) ':DEFSELECT) (T ':PROPERTY)))) (OR (SELECTQ TYPE (:INSTANCE-METHOD (AND (BOUNDP (CAR SPEC)) (SETQ SYM (FUNCALL (SI:CLASS (SYMBOL-VALUE (CAR SPEC))) :METHOD-FOR (CADR SPEC))))) (:ALWAYS-METHOD (SETQ SYM (CONS ':METHOD SPEC))) ((:METHOD :HANDLER :MAYBE-METHOD) (LET ((FLAVOR (CAR SPEC)) (MESSAGE (IF (CDDR SPEC) (CADDR SPEC) (CADR SPEC))) FL) (COND ((SETQ FL (GET FLAVOR 'SI:FLAVOR))) ((AND (VALIDATE-2-LONG-LIST SPEC) (SI:CLASS-SYMBOLP FLAVOR)) (SETQ SYM (FUNCALL (SYMBOL-VALUE FLAVOR) :METHOD-FOR (CADR SPEC)) FL T)) (OK-TO-ASK (DOLIST (SYMBOL (PACKAGE-LOOKALIKE-SYMBOLS FLAVOR NIL '(SI:FLAVOR))) (IF (FQUERY () "Do you mean ~S? " `(:METHOD ,SYMBOL . ,(CDR SPEC))) (RETURN (SETQ FLAVOR SYMBOL SPEC (CONS FLAVOR (CDR SPEC)) FL (GET FLAVOR 'SI:FLAVOR))))))) (COND ((SYMBOLP FL) ;T or NIL (AND (EQ TYPE ':MAYBE-METHOD) (VALIDATE-2-LONG-LIST SPEC) (SETQ SYM (CONS ':PROPERTY SPEC)))) ((FDEFINEDP `(:METHOD . ,SPEC)) (SETQ SYM `(:METHOD . ,SPEC))) (OK-TO-ASK (DOLIST (SYMBOL (OR (FIND-COMBINED-METHODS FLAVOR MESSAGE NIL) (SI:FLAVOR-ALL-INHERITABLE-METHODS FLAVOR MESSAGE))) (IF (FQUERY () "Do you mean ~S? " SYMBOL) (RETURN (SETQ SYM SYMBOL)))))))) ((:DEFSTRUCT :SPECIAL-FORM) (SETQ SYM (CAR SPEC) STR (GET-PNAME SYM))) (:DEFSELECT (SETQ SYM (CAR SPEC)) (IF (SYMBOLP SYM) (SETQ STR (GET-PNAME SYM)) (MULTIPLE-VALUE-SETQ (SYM STR) (SYMBOL-FROM-STRING SYM)))) (:PROPERTY (AND (VALIDATE-2-LONG-LIST SPEC) (SETQ SYM (CONS TYPE SPEC)))) (:INTERNAL (SETQ SYM (CONS TYPE SPEC)) (SETQ STR (DEFINITION-NAME-AS-STRING NIL (CAR SPEC))))) ;; Something we don't understand, make a bogus symbol to use as a property ;; list to remember the location of this definition (SETQ SYM (INTERN STR *UTILITY-PACKAGE*)))) (IF (NOT (SYS:VALIDATE-FUNCTION-SPEC SYM)) (VALUES NIL NIL T) (VALUES SYM STR))))) ))