;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.28 ;;; Reason: ;;; ARGLIST knows about COMPILATION-ENVIRONMENTs ;;; Written 9-Aug-88 20:41:39 by smh (Steve Haflich) at site Gigamos Cambridge ;;; while running on Harpo from band 3 ;;; with Experimental System 126.23, ZWEI 125.14, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.12, SDU ROM 102, kold 4aug88. ; From modified file DJ: L.SYS; QFCTNS.LISP#852 at 9-Aug-88 20:41:45 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  " (DEFUN ARGLIST (FUNCTION &OPTIONAL REAL-FLAG &AUX TEM DEBUG-INFO ARG-MAP LOCAL-MAP) "Return the argument list of FUNCTION, and its value-list. FUNCTION may be a function or a function spec. If REAL-FLAG is T, return the actual argument list, good for compilation, calling, etc. If REAL-FLAG is COMPILE, return the argument list generated by the compiler, if FUNCTION is compiled. This arglist includes the names of the keys for &KEY arguments, if any, and the forms used for defaulting optional args. /"Supplied-p/" args are not included If the function is not compiled, this is the same as REAL-FLAG = T Otherwise, return an argument list intended as documentation for humans. This will be the same as if REAL-FLAG were COMPILE, unless there was an explicit (DECLARE (ARGLIST ...)) in the defintiion of FUNCTION. The second value is the value-list, only for documentation for humans. The third value is NIL, SUBST or MACRO." (DECLARE (VALUES ARGLIST VALUES TYPE)) (TYPECASE FUNCTION (SYMBOL (COND ((and (boundp 'compiler:*compilation-environment*) (do ((env compiler:*compilation-environment* (compiler:compilation-environment-next env))) ((null env)) (unless (eq (setq tem (getf (gethash function (compiler:compilation-environment-plist-hashtab env)) 'compiler:compiler-arglist :no)) :no) (return-from arglist tem))))) ((GET FUNCTION 'ARGLIST)) ;Handles names defined only in the compiler. ((INTERPRETER-SPECIAL-FORM FUNCTION) (ARGLIST (INTERPRETER-SPECIAL-FORM-HANDLER (INTERPRETER-SPECIAL-FORM FUNCTION)) REAL-FLAG)) ('ELSE (ARGLIST (FSYMEVAL FUNCTION) REAL-FLAG)))) (CONS (COND ((EQ (CAR FUNCTION) 'LAMBDA) (LDIFF (CADR FUNCTION) (MEMQ '&AUX (CADR FUNCTION)))) ((MEMQ (CAR FUNCTION) '(SUBST CLI:SUBST)) (VALUES (CADR FUNCTION) NIL 'SUBST)) ((MEMQ (CAR FUNCTION) '(NAMED-SUBST NAMED-LAMBDA)) (SETQ DEBUG-INFO (DEBUGGING-INFO FUNCTION)) (COND ((AND (MEMQ REAL-FLAG '(NIL COMPILE)) (ASSQ 'ENCAPSULATED-DEFINITION DEBUG-INFO)) (ARGLIST (CADR (ASSQ 'ENCAPSULATED-DEFINITION DEBUG-INFO)) REAL-FLAG)) (T (VALUES (LET ((TEM (OR (IF (EQ REAL-FLAG 'NIL) (ASSQ 'ARGLIST DEBUG-INFO)) (IF (MEMQ REAL-FLAG '(COMPILE NIL)) (ASSQ 'COMPILER::COMPILER-ARGLIST DEBUG-INFO))))) (IF TEM (CDR TEM) (LDIFF (CADDR FUNCTION) (MEMQ '&AUX (CADDR FUNCTION))))) (CDR (ASSQ 'VALUES DEBUG-INFO)) (AND (EQ (CAR FUNCTION) 'NAMED-SUBST) 'SUBST))))) ((MEMQ (CAR FUNCTION) '(CURRY-BEFORE CURRY-AFTER)) '(&REST ARGLIST)) ((EQ (CAR FUNCTION) 'MACRO) ;; Look for (DECLARE (ARGLIST ...)) type arglist (SETQ DEBUG-INFO (DEBUGGING-INFO (CDR FUNCTION))) (VALUES (CDR (OR (IF (EQ REAL-FLAG 'NIL) (ASSQ 'ARGLIST DEBUG-INFO)) (IF (MEMQ REAL-FLAG '(COMPILE NIL)) (ASSQ 'COMPILER::COMPILER-ARGLIST DEBUG-INFO)) '(NIL . MACRO))) (CDR (ASSQ 'VALUES (DEBUGGING-INFO (CDR FUNCTION)))) 'MACRO)) ((VALIDATE-FUNCTION-SPEC FUNCTION) (ARGLIST (FDEFINITION FUNCTION) REAL-FLAG)) (T (FERROR "~S not a recognized function" FUNCTION)))) (STACK-GROUP '(STACK-GROUP-ARG)) (ARRAY (DO ((I (%P-LDB %%ARRAY-NUMBER-DIMENSIONS FUNCTION) (1- I)) (L NIL)) (( I 0) L) (SETQ L (CONS (INTERN (FORMAT NIL "DIM-~D" I) PKG-SYSTEM-INTERNALS-PACKAGE) L)))) ((OR CLOSURE ENTITY) (ARGLIST (CAR (%MAKE-POINTER DTP-LIST FUNCTION)) REAL-FLAG)) ((OR SELECT-METHOD INSTANCE) ;; Can't tell arglist, shouldn't give error though '(OP &REST SELECT-METHOD-ARGS-VARY)) (COMPILED-FUNCTION (SETQ DEBUG-INFO (DEBUGGING-INFO FUNCTION)) (SETQ ARG-MAP (CADR (ASSQ 'COMPILER::ARG-MAP DEBUG-INFO))) (SETQ LOCAL-MAP (CADR (ASSQ 'COMPILER::LOCAL-MAP DEBUG-INFO))) (VALUES (COND ((AND (EQ REAL-FLAG 'NIL) (CDR (ASSQ 'ARGLIST DEBUG-INFO)))) ((AND (MEMQ REAL-FLAG '(COMPILE NIL)) (CDR (ASSQ 'COMPILER::COMPILER-ARGLIST DEBUG-INFO)))) ((SETQ TEM (GET-MACRO-ARG-DESC-POINTER FUNCTION)) (DO ((ADL TEM (CDR ADL)) (ARGNUM 0 (1+ ARGNUM)) (ARGNAME) (OPTIONALP NIL) (SPECIAL FEF-LOCAL) (INIT) (INITP T T) (ADLWORD) (ARGLIS NIL)) ((NULL ADL) (NREVERSE ARGLIS)) (SETQ ADLWORD (CAR ADL)) (SELECT (MASK-FIELD %%FEF-ARG-SYNTAX ADLWORD) (FEF-ARG-REQ (AND OPTIONALP (FERROR "Required args after optionals in ~S" FUNCTION))) (FEF-ARG-OPT (OR OPTIONALP (SETQ ARGLIS (CONS '&OPTIONAL ARGLIS))) (SETQ OPTIONALP T)) (FEF-ARG-REST (SETQ ARGLIS (CONS '&REST ARGLIS))) (OTHERWISE (RETURN (NREVERSE ARGLIS)))) (SELECT (MASK-FIELD %%FEF-QUOTE-STATUS ADLWORD) (FEF-QT-QT (FERROR NIL "Obsolete special form, recompile the definition of ~S" FUNCTION)) (FEF-QT-EVAL)) (SETQ TEM (LDB %%FEF-DES-DT ADLWORD)) (SETQ TEM (LDB %%FEF-SPECIAL-BIT ADLWORD)) ;handle remote some time? (WHEN (NEQ TEM SPECIAL) (SETQ SPECIAL TEM) (SETQ ARGLIS (CONS (NTH TEM '(&LOCAL &SPECIAL)) ARGLIS))) (SETQ ARGNAME (COND ((= (LOGAND ADLWORD %FEF-NAME-PRESENT) FEF-NM-YES) (SETQ ADL (CDR ADL)) (CAR ADL)) (T (SETQ ARGNAME (COND (( (MASK-FIELD %%FEF-ARG-SYNTAX ADLWORD) FEF-ARG-REST) (NTH ARGNUM ARG-MAP)) (T (CAR LOCAL-MAP)))) (IF (SYMBOLP ARGNAME) ARGNAME (CAR ARGNAME))))) (SELECT (MASK-FIELD %%FEF-INIT-OPTION ADLWORD) (FEF-INI-NONE (SETQ INITP NIL)) (FEF-INI-NIL (SETQ INIT NIL)) (FEF-INI-PNTR (SETQ ADL (CDR ADL)) (SETQ INIT (CASE (%P-DATA-TYPE ADL) ((#.DTP-EXTERNAL-VALUE-CELL-POINTER) (MULTIPLE-VALUE-BIND (SYM CELL-FUNCTION) (DECODE-EVCP (%P-CONTENTS-AS-LOCATIVE ADL)) (CASE CELL-FUNCTION (SYMEVAL SYM) (FDEFINITION `(FUNCTION ,SYM)) (T `(,CELL-FUNCTION ',SYM))))) ((#.DTP-SELF-REF-POINTER) (FLAVOR-DECODE-SELF-REF-POINTER (FEF-FLAVOR-NAME FUNCTION) (%P-POINTER ADL))) (T `',(CAR ADL))))) (FEF-INI-C-PNTR (SETQ ADL (CDR ADL)) (COND ;((= (%P-DATA-TYPE ADL) DTP-EXTERNAL-VALUE-CELL-POINTER) ; (SETQ INIT ;THIS IS A BIT OF A KLUDGE ; (%FIND-STRUCTURE-HEADER (%P-CONTENTS-AS-LOCATIVE ADL)))) ;HOPE IT'S VALUE-CELL-LOCATION ((LOCATIVEP (CAR ADL)) (SETQ INIT (%FIND-STRUCTURE-HEADER (CAR ADL)))) ((SETQ INIT (CAAR ADL))))) (FEF-INI-OPT-SA (SETQ ADL (CDR ADL)) (SETQ INIT '*HAIRY*)) (FEF-INI-COMP-C (SETQ INIT '*HAIRY*)) (FEF-INI-EFF-ADR (SETQ ADL (CDR ADL)) (SETQ INIT '*HAIRY*)) (FEF-INI-SELF (SETQ INIT ARGNAME))) (SETQ ARGLIS (CONS (COND (INITP (LIST ARGNAME INIT)) (T ARGNAME)) ARGLIS)))) (T ;; No ADL. Use the fast-arg-option to get the general pattern ;; and the argmap for the names. (LET ((FAST-OPT (%ARGS-INFO FUNCTION)) (RES NIL)) (LET ((MIN-ARGS (LDB %%ARG-DESC-MIN-ARGS FAST-OPT)) (MAX-ARGS (LDB %%ARG-DESC-MAX-ARGS FAST-OPT)) (EVALED-REST (LDB %%ARG-DESC-EVALED-REST FAST-OPT))) (OR (ZEROP (LDB %%ARG-DESC-QUOTED-REST FAST-OPT)) (FERROR NIL "Obsolete special form, recompile the definition of ~S" FUNCTION)) (DOTIMES (I MIN-ARGS) (PUSH (CAAR ARG-MAP) RES) (SETQ ARG-MAP (CDR ARG-MAP))) (OR (= MIN-ARGS MAX-ARGS) (PUSH '&OPTIONAL RES)) (DOTIMES (I (- MAX-ARGS MIN-ARGS)) (PUSH (CAAR ARG-MAP) RES) (SETQ ARG-MAP (CDR ARG-MAP))) (WHEN (NOT (ZEROP EVALED-REST)) (PUSH '&REST RES) (PUSH (CAAR LOCAL-MAP) RES)) (NREVERSE RES))))) (CDR (ASSQ 'VALUES DEBUG-INFO)))) (MICROCODE-FUNCTION (MICRO-CODE-ENTRY-ARGLIST-AREA (%POINTER FUNCTION))) (T (FERROR "~S is not a function" FUNCTION)))) ))