;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8 -*- ;;;Callers (what-files-call '(si:args-info si:%args-info)) (#FS::LOGICAL-PATHNAME "SYS: SYS; QMISC  " #FS::LOGICAL-PATHNAME "SYS: SYS; EVAL  " #FS::LOGICAL-PATHNAME "SYS: SYS; DESCRIBE  " #FS::LOGICAL-PATHNAME "SYS: SYS; QCP2  " #FS::LOGICAL-PATHNAME "SYS: SYS; QCP1  " #FS::LOGICAL-PATHNAME "SYS: DEBUGGER; EHC  " #FS::LOGICAL-PATHNAME "SYS: DEBUGGER; EH  " #FS::LOGICAL-PATHNAME "SYS: DEBUGGER; EHW  " #FS::LOGICAL-PATHNAME "SYS: DEBUGGER; CONDITION-FLAVORS  " #FS::LOGICAL-PATHNAME "SYS: SYS2; RESOUR  " #FS::LOGICAL-PATHNAME "SYS: SYS; QFCTNS  ") (who-calls '(si:%args-info si:args-info)) ARGS-INFO calls ARGS-INFO as a function. ARGS-INFO calls %ARGS-INFO via a "misc" instruction. ARGLIST calls %ARGS-INFO via a "misc" instruction. ALLOCATE-RESOURCE calls %ARGS-INFO via a "misc" instruction. (:METHOD EH::FUNCTION-ENTRY-ERROR :CASE :PROCEED-ASKING-USER :NEW-ARGUMENT-LIST) calls ARGS-INFO as a function. EH::SETUP-ARGS-WINDOW calls ARGS-INFO as a function. EH::SG-REST-ARG-VALUE calls ARGS-INFO as a function. EH::COM-REINVOKE-NEW-ARGS calls ARGS-INFO as a function. EH:SG-FRAME-ARG-VALUE calls ARGS-INFO as a function. EH::COM-SHOW-STACK-TEMPORARIES calls ARGS-INFO as a function. EH::PRINT-FRAME-ARGS calls ARGS-INFO as a function. EH::SG-NUMBER-OF-SPREAD-ARGS calls ARGS-INFO as a function. ARGLIST calls %ARGS-INFO via a "misc" instruction. ALLOCATE-RESOURCE calls %ARGS-INFO via a "misc" instruction. GLOBAL:FUNCTIONP calls %ARGS-INFO via a "misc" instruction. COMPILER::QCOMPILE0 calls ARGS-INFO as a function. (:PROPERTY COMPILER::QCOMPILE0 :PREVIOUS-DEFINITION) calls ARGS-INFO as a function. COMPILER::GETARGDESC calls %ARGS-INFO via a "misc" instruction. (:PROPERTY COMPILER::GETARGDESC :PREVIOUS-DEFINITION) calls %ARGS-INFO via a "misc" instruction. COMPILER::CHECK-NUMBER-OF-ARGS calls %ARGS-INFO via a "misc" instruction. (:PROPERTY COMPILER::CHECK-NUMBER-OF-ARGS :PREVIOUS-DEFINITION) calls %ARGS-INFO via a "misc" instruction. SI::CALL-MACRO-EXPANDER calls ARGS-INFO as a function. SI::AUTOMATIC-DISPLACE calls ARGS-INFO as a function. SI::DESCRIBE-ARGS-INFO calls ARGS-INFO as a function. SYSTEM:EVAL1 calls %ARGS-INFO via a "misc" instruction. (:PROPERTY SYSTEM:EVAL1 :PREVIOUS-DEFINITION) calls %ARGS-INFO via a "misc" instruction. GLOBAL:FUNCTIONP calls %ARGS-INFO via a "misc" instruction. ALLOCATE-RESOURCE calls %ARGS-INFO via a "misc" instruction. ARGS-INFO calls ARGS-INFO as a function. ARGS-INFO calls %ARGS-INFO via a "misc" instruction. CALL calls ARGS-INFO as a function. ARGLIST calls %ARGS-INFO via a "misc" instruction. ;;;Constant values -- bit fields, offsets ;;;From DJ: L.COLD; QCOM.LISP#> ;;; A "Numeric Argument Description" is what %ARGS-INFO and ARGS-INFO return. ;;; Such descriptors can also be hung on symbols' Q-ARGS-PROP properties. ;;; The "fast option Q" of a FEF is stored in this format. ;;; These symbols go in the real machine. (DEFCONST NUMERIC-ARG-DESC-INFO '( %ARG-DESC-QUOTED-REST 10000000 ;HAS QUOTED REST ARGUMENT %%ARG-DESC-QUOTED-REST 2501 %ARG-DESC-EVALED-REST 4000000 ;HAS EVALUATED REST ARGUMENT %%ARG-DESC-EVALED-REST 2401 %%ARG-DESC-ANY-REST 2402 ;NON-ZERO IF HAS EITHER KIND OF REST ARG %ARG-DESC-FEF-QUOTE-HAIR 2000000 ;MACRO COMPILED FCN WITH HAIRY QUOTING, %%ARG-DESC-FEF-QUOTE-HAIR 2301 ; CALLER MUST CHECK A-D-L FOR FULL INFO %ARG-DESC-INTERPRETED 1000000 ;THIS IS INTERPRETED FUNCTION, %%ARG-DESC-INTERPRETED 2201 ; NO INFORMATION AVAILABLE (VAL=1000077) %ARG-DESC-FEF-BIND-HAIR 400000 ;MACRO COMPILED FCN WITH HAIRY BINDING, %%ARG-DESC-FEF-BIND-HAIR 2101 ; LINEAR ENTER MUST CHECK A-D-L %%ARG-DESC-MIN-ARGS 0606 ;MINIMUM NUMBER OF REQUIRED ARGS %%ARG-DESC-MAX-ARGS 0006 ;MAXIMUM NUMBER OF REQUIRED+OPTIONAL ; ARGS. REST ARGS NOT COUNTED. )) (ASSIGN-ALTERNATE NUMERIC-ARG-DESC-INFO) (DEFCONST NUMERIC-ARG-DESC-FIELDS (SI::GET-ALTERNATE NUMERIC-ARG-DESC-INFO)) (DEFCONST ARG-DESC-FIELD-VALUES '( %FEF-ARG-SYNTAX 160 %FEF-QUOTE-STATUS 600 %FEF-DES-DT 17000 %FEF-INIT-OPTION 17 %FEF-SPECIAL-BIT 1_16 %FEF-NAME-PRESENT 1_20 ;; ***UNFORTUNATELY, ASSIGN-COMP-VALUES KNOWS ABOUT THESE TOO**** %%FEF-NAME-PRESENT 2001 %%FEF-SPECIAL-BIT 1601 %%FEF-SPECIALNESS 1602 %%FEF-FUNCTIONAL 1501 %%FEF-DES-DT 1104 %%FEF-QUOTE-STATUS 0702 %%FEF-ARG-SYNTAX 0403 %%FEF-INIT-OPTION 0004 )) (ASSIGN-ALTERNATE ARG-DESC-FIELD-VALUES) (DEFCONST ARG-DESC-FIELDS (SI::GET-ALTERNATE ARG-DESC-FIELD-VALUES)) ;ARG-DESC-FIELDS GETS SET TO A LIST CONSISTING OF THE ALTERNATING MEMBERS OF ;ARG-DESC-FIELD-VALUES (DEFCONST FEF-NAME-PRESENT '( FEF-NM-NO FEF-NM-YES )) (DEFCONST FEF-SPECIALNESS '( FEF-LOCAL FEF-SPECIAL FEF-SPECIALNESS-UNUSED FEF-REMOTE )) (DEFCONST FEF-FUNCTIONAL '( FEF-FUNCTIONAL-DONTKNOW FEF-FUNCTIONAL-ARG )) (DEFCONST FEF-DES-DT '( FEF-DT-DONTCARE FEF-DT-NUMBER FEF-DT-FIXNUM FEF-DT-SYM FEF-DT-ATOM FEF-DT-LIST FEF-DT-FRAME )) (DEFCONST FEF-QUOTE-STATUS '( FEF-QT-DONTCARE FEF-QT-EVAL FEF-QT-QT )) (DEFCONST FEF-ARG-SYNTAX '( FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-REST FEF-ARG-AUX FEF-ARG-FREE FEF-ARG-INTERNAL FEF-ARG-INTERNAL-AUX )) (DEFCONST FEF-INIT-OPTION '( FEF-INI-NONE FEF-INI-NIL FEF-INI-PNTR FEF-INI-C-PNTR FEF-INI-OPT-SA FEF-INI-COMP-C FEF-INI-EFF-ADR FEF-INI-SELF )) ;;;Tag Search for %%arg-desc ;;;From DJ: L.SYS; DESCRIBE.LISP#> (DEFUN DESCRIBE-NUMERIC-DESCRIPTOR-WORD (N &AUX (MIN (LDB %%ARG-DESC-MIN-ARGS N)) (MAX (LDB %%ARG-DESC-MAX-ARGS N))) (FORMAT T "~& ") (IF (BIT-TEST %ARG-DESC-QUOTED-REST N) (PRINC "Quoted rest arg, ")) (IF (BIT-TEST %ARG-DESC-EVALED-REST N) (PRINC "Evaluated rest arg, ")) (IF (BIT-TEST %ARG-DESC-FEF-QUOTE-HAIR N) (PRINC "Some args quoted, ")) (IF (BIT-TEST %ARG-DESC-INTERPRETED N) (PRINC "Interpreted function, ")) (IF (BIT-TEST %ARG-DESC-FEF-BIND-HAIR N) (PRINC "Linear enter must check ADL, ")) (FORMAT T "Takes ~:[between ~D and ~D~;~D~] args.~%" (= MAX MIN) MIN MAX)) ;;;From DJ: L.SYS; DESCRIBE.LISP#> ;;;;;;These were moved to QCOM.LISP ;(DEFCONST NUMERIC-ARG-DESC-INFO '( ;; %%ARG-DESC-QUOTED-REST 2501 ;; %%ARG-DESC-EVALED-REST 2401 ;; %%ARG-DESC-ANY-REST 2402 ;NON-ZERO IF HAS EITHER KIND OF REST ARG ;; %%ARG-DESC-FEF-QUOTE-HAIR 2301 ; CALLER MUST CHECK A-D-L FOR FULL INFO ;; %%ARG-DESC-INTERPRETED 2201 ; NO INFORMATION AVAILABLE (VAL=1000077) ;; %%ARG-DESC-FEF-BIND-HAIR 2101 ; LINEAR ENTER MUST CHECK A-D-L ; %%ARG-DESC-MIN-ARGS 0606 ;MINIMUM NUMBER OF REQUIRED ARGS ; %%ARG-DESC-MAX-ARGS 0006 ;MAXIMUM NUMBER OF REQUIRED+OPTIONAL ; ; ARGS. REST ARGS NOT COUNTED. ; )) (defun describe-args-info (args-info) (unless (fixnump args-info) (setq args-info (args-info args-info))) (dolist (x '((%%arg-desc-interpreted . "~%~:[C~;ompiled~;Non-c~]ompiled function") (%%arg-desc-any-rest . "~@[~%Has rest argument~]") (%%arg-desc-quoted-rest . "~@[~% Has quoted rest arg~]") (%%arg-desc-evaled-rest . "~@[~% Has evalled rest arg~]") (%%arg-desc-fef-quote-hair . "~@[~%Hairy fef arg quoting (caller must check FEF ADL)~]") (%%arg-desc-fef-bind-hair . "~@[~%Hairy fef binding~]") (%%arg-desc-min-args . "~*~%Minimum ~D. args.") (%%arg-desc-max-args . "~*~%Maximum ~D. args."))) (let ((tem (ldb (symbol-value (car x)) args-info))) (format t (cdr x) (not (zerop tem)) tem))) (fresh-line)) ;;;From DJ: L.SYS; EVAL.LISP#> ;;; This is the real guts of eval. It uses the current lexical context. ;;; If that context includes *INTERPRETER-FUNCTION-ENVIRONMENT* = T, ;;; then Zetalisp evaluation is done. ;;; All special forms call EVAL1 directly to eval their arguments. (defun eval1 (form &optional nohook) "Evaluate FORM in the current lexical environment, returning its value(s). If the current environment says /"traditional Zetalisp/", we do that. This is the function that special forms such as COND use to evaluate their subexpressions, as it allows the subexpressions to access lexical variables of the containing code. Contrast with EVAL." (declare (dbg:uninteresting-function eval)) ;; Make sure all instances of ARGNUM, below, are local slot 0. (let (argnum) argnum) (with-current-interpreter-environment (env) (cond ((and *evalhook* (not nohook)) (let ((tem *evalhook*) (*evalhook* nil) (*applyhook* nil)) (funcall tem form env))) ((symbolp form) (cond ((keywordp form) form) ((eq *interpreter-function-environment* t) (symbol-value form)) (t (interpreter-symeval form)))) ((atom form) form) (t (let* ((final-function (car form)) call-function arg-desc num-args tem) ;; Trace FINAL-FUNCTION through symbols and closures to get the ultimate function ;; which will tell us whether to evaluate the args. (tagbody loop (typecase final-function (symbol (setq final-function (COND ((EQ final-function '*CATCH) 'CATCH) ((eq *interpreter-function-environment* t) (OR (INTERPRETER-SPECIAL-FORM FINAL-FUNCTION) (symbol-function final-function))) ('ELSE (interpreter-fsymeval1 final-function)))) (go loop)) ((or closure entity) (setq tem (%make-pointer dtp-list final-function)) (or call-function (setq call-function final-function)) (setq final-function (car tem)) (go loop)) ;;>> sigh. (microcode-function ;; Detect ucode entry that is not actually microcoded. (and (bit-test %arg-desc-interpreted (%args-info final-function)) (not (integerp (aref (symbol-function 'sys:micro-code-entry-area) (%pointer final-function)))) (setq final-function (aref (symbol-function 'sys:micro-code-entry-area) (%pointer final-function))) (go loop))) (t nil))) (or call-function (setq call-function final-function)) (setq arg-desc (%args-info call-function)) (COND ((bit-test %arg-desc-interpreted arg-desc) (typecase final-function (cons (case (car final-function) ((lambda subst cl:subst) (eval-lambda (cadr final-function) call-function (cdr form) env)) ((named-lambda named-subst) (eval-lambda (caddr final-function) call-function (cdr form) env)) (macro (eval1 (error-restart (error "Retry macro expansion.") ;;>> UGH!! (let ((*macroexpand-environment* env)) (automatic-displace (cdr call-function) form))) t)) ((curry-before curry-after) (if *applyhook* (progn (%open-call-block 'applyhook1 0 2) ;d-return (%push env) (%push call-function)) (%open-call-block call-function 0 2)) (%assure-pdl-room (length (cdr form))) (do ((argl (cdr form) (cdr argl)) (argnum 0 (1+ argnum))) ((null argl)) (%push (eval1 (car argl)))) (%activate-open-call-block)) (t (if (lambda-macro-call-p call-function) (eval1 (cons (lambda-macro-expand call-function) (cdr form))) (invalid-function (car form) (cdr form) #'eval1 nohook))))) ((or select-method instance) (if *applyhook* (progn (%open-call-block 'applyhook1 0 2) ;d-return (%push env) (%push call-function)) (%open-call-block call-function 0 2)) (%assure-pdl-room (length (cdr form))) (do ((argl (cdr form) (cdr argl)) (argnum 0 (1+ argnum))) ((null argl)) (%push (eval1 (car argl)))) (%activate-open-call-block)) (t (invalid-function (car form) (cdr form) #'eval1 nohook)))) ((TYPEP FINAL-FUNCTION 'INTERPRETER-SPECIAL-FORM) (FUNCALL (INTERPRETER-SPECIAL-FORM-HANDLER FINAL-FUNCTION) FORM)) ((OR (bit-test %arg-desc-quoted-rest arg-desc) (bit-test %arg-desc-fef-quote-hair arg-desc)) (FERROR NIL "Obsolete special form. Recompile the definition of ~S" (CAR FORM))) ('ELSE (setq num-args (length (cdr form))) (when (not (< num-args call-arguments-limit)) (FERROR NIL "Too many arguments. This cant possibly work compiled:~%~S" FORM)) (if *applyhook* (progn (%open-call-block 'applyhook1 0 2) ;d-return (%push env) (%push call-function)) (%open-call-block call-function 0 2)) (%assure-pdl-room num-args) (dolist (arg (cdr form)) (%push (eval1 arg))) (%activate-open-call-block)))))))) ;;;From DJ: L.COLD; GLOBAL.LISP#> (DEFCONST INITIAL-GLOBAL-SYMBOLS '( ;;;; Useful byte-pointers and constants: %%ARG-DESC-EVALED-REST %%ARG-DESC-FEF-BIND-HAIR %%ARG-DESC-FEF-QUOTE-HAIR %%ARG-DESC-INTERPRETED %%ARG-DESC-MAX-ARGS %%ARG-DESC-MIN-ARGS %%ARG-DESC-QUOTED-REST ;;;From DJ: L.COLD; GLOBAL.LISP#> %ARG-DESC-EVALED-REST %ARG-DESC-FEF-BIND-HAIR %ARG-DESC-FEF-QUOTE-HAIR %ARG-DESC-INTERPRETED %ARG-DESC-QUOTED-REST ;;;From DJ: L.SYS; QFCTNS.LISP#> ;;; Used as the value of *MACROEXPAND-HOOK* to make all macros displace. (defun automatic-displace (expander-function original-form) (let ((expanded-form (if (> (ldb %%arg-desc-max-args (args-info expander-function)) 1) (funcall expander-function original-form *macroexpand-environment*) (funcall expander-function original-form)))) (if (or (eq expanded-form original-form) (eq (car original-form) 'displaced) inhibit-displacing-flag (not (= (%area-number original-form) working-storage-area)) (and (%pointerp expanded-form) (not (= (%area-number expanded-form) working-storage-area)))) expanded-form (displace original-form expanded-form)))) ;;;From DJ: L.SYS; QFCTNS.LISP#> (DEFUN FUNCTIONP (X &OPTIONAL ALLOW-SPECIAL-FORMS) "T if X is a function. ALLOW-SPECIAL-FORMS=T says count special forms as functions. Closures and select-methods are considered functions, but arrays, entities, instances and stack groups are not." (PROG () LOOP (RETURN (CASE (%DATA-TYPE X) ((#.DTP-FEF-POINTER #.DTP-U-ENTRY) (IF (BIT-TEST (LOGIOR %ARG-DESC-QUOTED-REST %ARG-DESC-FEF-QUOTE-HAIR) (%ARGS-INFO X)) (FERROR NIL "Obsolete special form. Recompile the definition of ~S" X)) T) ((#.DTP-LIST) (COND ((EQ (CAR X) 'LAMBDA) (IF (MEMQ '"E (CADR X)) (FERROR NIL "Obsolete special form: ~S" X)) T) ((EQ (CAR X) 'NAMED-LAMBDA) (IF (MEMQ '"E (CADDR X)) (FERROR NIL "Obsolete special form: ~S" X)) T) ((MEMQ (CAR X) '(SUBST CLI:SUBST NAMED-SUBST CURRY-BEFORE CURRY-AFTER)) T) ((EQ (CAR X) 'MACRO) ALLOW-SPECIAL-FORMS) ((LAMBDA-MACRO-CALL-P X) (SETQ X (LAMBDA-MACRO-EXPAND X)) (GO LOOP)))) ((#.DTP-SELECT-METHOD #.DTP-CLOSURE) T) ((#.DTP-SYMBOL) (COND ((NOT (FBOUNDP X)) (AND ALLOW-SPECIAL-FORMS (INTERPRETER-SPECIAL-FORM X) T)) ((ARRAYP (SETQ X (SYMBOL-FUNCTION X)))) (T (GO LOOP)))))))) ;;;From DJ: L.SYS; QFCTNS.LISP#> ;;; ARGLIST returns the list of argument names and the list of ;;; returned value names of the definition of a function spec. ;;; The first value is the arglist: a list of the names ;;; of the arguments, together with lambda list keywords. ;;; The second value is the list of returned value names. ;;; This list is present only if the definition of the function ;;; supplies one, and it is just a comment. Those names play no ;;; actual role in execution. ;;; The argument REAL-FLAG is T to inhibit the use of any declared ;;; (comment only) arglist information. Only the actual arglist of the function ;;; is returned. Normally the arglist specified for human comsumption ;;; with an arglist declaration overrides the real one. ;;; REAL-FLAG is COMPILE to get the arglist automatically generated by the ;;; compiler for functions whose lambda-list contains &keys args or specified-p args ;;; If no such arglist was generated, we return the what we would get with ;;; REAL-FLAG = T. ;;; REAL-FLAG also inhibits following encapsulations. ;;; So you get the arglist of the encapsulation rather than the ;;; original definition. ;;; T should be used by anything that requires a "legitimate" arglist ;;; that reliably corresponds to what the function does with its args. ;;; We accept both functions and function specs. (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)))) ;;;From DJ: L.SYS; QFCTNS.LISP#> ;;; Like %ARGS-INFO but also works for interpreted functions (DEFUN ARGS-INFO (FCN) "Returns a fixnum called the /"numeric argument descriptor,/" which describes the way it takes arguments. This is used internally by the microcode, the evaluator, and the compiler." ;; First, convert FCN from a function-spec to a function (LOOP WHILE (OR (SYMBOLP FCN) (AND (CONSP FCN) (NOT (MEMQ (CAR FCN) FUNCTION-START-SYMBOLS)))) DO (SETQ FCN (FDEFINITION FCN))) (COND ((CLOSUREP FCN) (ARGS-INFO (CLOSURE-FUNCTION FCN))) ((ATOM FCN) (%ARGS-INFO FCN)) ((MEMQ (CAR FCN) '(CURRY-BEFORE CURRY-AFTER MACRO)) %ARG-DESC-EVALED-REST) ;Most unspecific value (T (ARGS-INFO-FROM-LAMBDA-LIST (CAR (LAMBDA-EXP-ARGS-AND-BODY FCN)))))) ;;;From DJ: L.SYS; QFCTNS.LISP#> (DEFUN ARGS-INFO-FROM-LAMBDA-LIST (LL &AUX (FLAGS 0) QUOTE MIN (N 0)) (DOLIST (L LL) (CASE L ("E (SETQ QUOTE T)) (&EVAL (SETQ QUOTE NIL)) (&OPTIONAL (SETQ MIN N)) (&AUX (RETURN NIL)) (&REST (RETURN (SETQ FLAGS (LOGIOR FLAGS (COND (QUOTE %ARG-DESC-QUOTED-REST) (T %ARG-DESC-EVALED-REST)))))) (OTHERWISE ;A variable (COND ((NOT (MEMQ L LAMBDA-LIST-KEYWORDS)) (IF QUOTE ;Quoted regular args present (SETQ FLAGS (LOGIOR FLAGS (LOGIOR %ARG-DESC-INTERPRETED %ARG-DESC-FEF-QUOTE-HAIR)))) (INCF N)))))) (OR MIN (SETQ MIN N)) ;No optionals (DPB N %%ARG-DESC-MAX-ARGS (DPB MIN %%ARG-DESC-MIN-ARGS FLAGS))) ;;;From DJ: L.SYS; QFCTNS.LISP#> (defun call-macro-expander (expander macro-call environment) (let ((*macroexpand-environment* environment) (ainf (args-info expander))) (cond ((or (symbolp expander) ;; No check for explicit macro expanders (> (ldb %%arg-desc-max-args ainf) 1)) (values (funcall *macroexpand-hook* expander macro-call environment) t)) (t (values (funcall *macroexpand-hook* expander macro-call) t))))) ;;;From DJ: L.SYS; QMISC.LISP#> (DEFUN CALL (FN &REST ALTERNATES &AUX (MAX-ARGS #o100) (ARGS-INF (ARGS-INFO FN))) "The first argument is a function to call. The remaining arguments are in pairs, consisting of a descriptor arg and a data arg. The descriptor arg says what to do with the data arg. The descriptor arg value should be either a keyword or a list of keywords or NIL. NIL means that the data argument is to be treated as a single argument to the function. The allowed keywords are :SPREAD and :OPTIONAL. :SPREAD means that the data argument is a list of arguments rather than a single argument. :OPTIONAL means that the data argument can be ignored if the function being called doesn't ask for it. After the first :OPTIONAL, all args supplied are considered optional." (AND (ZEROP (LDB %%ARG-DESC-QUOTED-REST ARGS-INF)) (ZEROP (LDB %%ARG-DESC-EVALED-REST ARGS-INF)) (SETQ MAX-ARGS (LDB %%ARG-DESC-MAX-ARGS ARGS-INF))) (%OPEN-CALL-BLOCK FN 0 4) (DO ((Y ALTERNATES (CDDR Y)) (OPTIONAL-FLAG) (SPREAD-FLAG NIL NIL)) ((NULL Y)) (IF (AND (SYMBOLP (CAR Y)) (CAR Y)) (CASE (CAR Y) (:SPREAD (SETQ SPREAD-FLAG T)) (:OPTIONAL (SETQ OPTIONAL-FLAG T)) (OTHERWISE (FERROR "Invalid ~S keyword ~S." 'CALL (CAR Y)))) (DOLIST (X (CAR Y)) (CASE X (:SPREAD (SETQ SPREAD-FLAG T)) (:OPTIONAL (SETQ OPTIONAL-FLAG T)) (OTHERWISE (FERROR "Invalid ~S keyword ~S." 'CALL X))))) (AND OPTIONAL-FLAG ( MAX-ARGS 0) (RETURN NIL)) (IF SPREAD-FLAG (DOLIST (X (CADR Y)) (IF (AND OPTIONAL-FLAG ( MAX-ARGS 0)) (RETURN NIL) (%ASSURE-PDL-ROOM 1) (%PUSH X) (DECF MAX-ARGS))) (%ASSURE-PDL-ROOM 1) (%PUSH (CADR Y)) (DECF MAX-ARGS))) (%ACTIVATE-OPEN-CALL-BLOCK)) ;;;From DJ: L.SYS; QRAND.LISP#> (defun maybe-change-fef-type (fef-pointer &aux (sys:%inhibit-read-only t)) (check-type fef-pointer compiled-function) (cond ((= (%P-LDB-OFFSET %%HEADER-TYPE-FIELD FEF-POINTER %FEFHI-IPC) %header-type-fef) (let ((get-self-mapping-table (%p-ldb-offset %%fefh-get-self-mapping-table fef-pointer %fefhi-ipc)) (sv-bind (%p-ldb-offset %%fefh-sv-bind fef-pointer %fefhi-ipc)) (fast-arg (%p-ldb-offset %%fefh-fast-arg fef-pointer %fefhi-ipc)) (no-adl (%p-ldb-offset %%fefh-no-adl fef-pointer %fefhi-ipc)) (min-args (%p-ldb-offset %%ARG-DESC-MIN-ARGS fef-pointer %fefhi-fast-arg-opt)) (max-args (%p-ldb-offset %%ARG-DESC-MAX-ARGS fef-pointer %fefhi-fast-arg-opt)) (local-block (%p-ldb-offset %%FEFHI-MS-LOCAL-BLOCK-LENGTH fef-pointer %fefhi-misc)) (fast (%p-contents-offset fef-pointer %fefhi-fast-arg-opt))) (cond ((or (not (zerop get-self-mapping-table)) (not (zerop sv-bind)) (not (= fast-arg 1)) (bit-test %arg-desc-quoted-rest fast) (bit-test %arg-desc-evaled-rest fast) (bit-test %arg-desc-interpreted fast) (bit-test %arg-desc-fef-quote-hair fast) (bit-test %arg-desc-fef-bind-hair fast)) nil) ((and (= min-args max-args) (zerop local-block) (<= min-args (dpb -1 (logand 77 %%fefh-args-for-fanl) 0))) (%p-dpb-offset min-args %%fefh-args-for-fanl fef-pointer %fefhi-ipc) (%p-dpb-offset no-adl %%fefsl-no-adl fef-pointer %fefhi-storage-length) (%p-dpb-offset %HEADER-TYPE-FAST-FEF-FIXED-ARGS-NO-LOCALS %%header-type-field fef-pointer %fefhi-ipc) 'FIXED-ARGS-NO-LOCALS) ((and (zerop local-block) (<= min-args (dpb -1 (logand 77 %%fefh-min-args-for-vanl) 0)) (<= max-args (dpb -1 (logand 77 %%fefh-max-args-for-vanl) 0))) (%p-dpb-offset min-args %%fefh-min-args-for-vanl fef-pointer %fefhi-ipc) (%p-dpb-offset max-args %%fefh-max-args-for-vanl fef-pointer %fefhi-ipc) (%p-dpb-offset no-adl %%fefsl-no-adl fef-pointer %fefhi-storage-length) (%p-dpb-offset %HEADER-TYPE-FAST-FEF-VAR-ARGS-NO-LOCALS %%header-type-field fef-pointer %fefhi-ipc) 'VARIABLE-ARGS-NO-LOCALS) ((and (= min-args max-args) (<= min-args (dpb -1 (logand 77 %%fefh-args-for-fawl) 0)) (<= local-block (dpb -1 (logand 77 %%fefh-locals-for-fawl) 0))) (%p-dpb-offset min-args %%fefh-args-for-fawl fef-pointer %fefhi-ipc) (%p-dpb-offset local-block %%fefh-locals-for-fawl fef-pointer %fefhi-ipc) (%p-dpb-offset no-adl %%fefsl-no-adl fef-pointer %fefhi-storage-length) (%p-dpb-offset %HEADER-TYPE-FAST-FEF-FIXED-ARGS-WITH-LOCALS %%header-type-field fef-pointer %fefhi-ipc) 'FIXED-ARGS-WITH-LOCALS) ((and (<= min-args (dpb -1 (logand 77 %%fefh-min-args-for-vawl) 0)) (<= max-args (dpb -1 (logand 77 %%fefh-max-args-for-vawl) 0)) (<= local-block (dpb -1 (logand 77 %%fefh-locals-for-vawl) 0))) (%p-dpb-offset min-args %%fefh-min-args-for-vawl fef-pointer %fefhi-ipc) (%p-dpb-offset max-args %%fefh-max-args-for-vawl fef-pointer %fefhi-ipc) (%p-dpb-offset local-block %%fefh-locals-for-vawl fef-pointer %fefhi-ipc) (%p-dpb-offset no-adl %%fefsl-no-adl fef-pointer %fefhi-storage-length) (%p-dpb-offset %HEADER-TYPE-FAST-FEF-VAR-ARGS-WITH-LOCALS %%header-type-field fef-pointer %fefhi-ipc) 'VARIABLE-ARGS-WITH-LOCALS) (t nil)))))) ;;;From DJ: L.SYS2; RESOUR.LISP#> (DEFUN ALLOCATE-RESOURCE (RESOURCE-NAME &REST PARAMETERS &AUX RESOURCE (PARAMS PARAMETERS) ;Note PARAMS is UNSAFE! TEM INDEX (OLD INHIBIT-SCHEDULING-FLAG) INITIALIZER) "Allocate an object from resource RESOURCE-NAME according to PARAMETERS. An old object is reused if possible; otherwise a new one is created. The significance of the PARAMETERS is determined by the individual resource." ;the following CHECK-TYPE is amazingly slow, assume anything with a DEFRESOURCE must be OK. ; (CHECK-TYPE RESOURCE-NAME RESOURCE-NAME "the name of a resource") (cond ((null (SETQ RESOURCE (GET RESOURCE-NAME 'DEFRESOURCE))) (CHECK-TYPE RESOURCE-NAME RESOURCE-NAME "the name of a resource") ;The second try, it is a resource for sure (SETQ RESOURCE (GET RESOURCE-NAME 'DEFRESOURCE)))) (AND (SETQ TEM (RESOURCE-PARAMETIZER RESOURCE)) (< (LENGTH PARAMS) (LDB %%ARG-DESC-MAX-ARGS (%ARGS-INFO TEM))) (SETQ PARAMS (APPLY TEM PARAMS))) (WITHOUT-INTERRUPTS (COND ((SETQ TEM (RESOURCE-FINDER RESOURCE)) (SETQ TEM (APPLY TEM RESOURCE PARAMS))) ((RESOURCE-FREE-LIST-CELL RESOURCE) (DO ((CHECKER (RESOURCE-CHECKER RESOURCE)) (MATCHER (RESOURCE-MATCHER RESOURCE)) (CELL (LOCF (RESOURCE-FREE-LIST RESOURCE)) (FUNCALL (RESOURCE-FREE-LIST-CELL RESOURCE) (CONTENTS CELL)))) ((NULL (CONTENTS CELL)) ;; make new object. PARAMS not copied since it is assumed they will not be stored. (SETQ INHIBIT-SCHEDULING-FLAG OLD) (SETQ TEM (APPLY (RESOURCE-CONSTRUCTOR RESOURCE) RESOURCE PARAMS)) (SETQ INHIBIT-SCHEDULING-FLAG T)) (LET ((OBJ (CONTENTS CELL))) (WHEN (AND (or (null CHECKER) (APPLY CHECKER RESOURCE OBJ NIL PARAMS)) ;IN-USE-P NIL (IF MATCHER (APPLY MATCHER RESOURCE OBJ PARAMS) (NULL PARAMS))) ;PARAMS not retained. (SETF (CONTENTS CELL) (CONTENTS (FUNCALL (RESOURCE-FREE-LIST-CELL RESOURCE) OBJ))) (RETURN (SETQ TEM OBJ)))))) ((LOOP WITH CHECKER = (RESOURCE-CHECKER RESOURCE) WITH MATCHER = (RESOURCE-MATCHER RESOURCE) WITH N-OBJECTS = (RESOURCE-N-OBJECTS RESOURCE) FOR N FROM (1- N-OBJECTS) DOWNTO 0 AS IN-USE-P = (RESOURCE-IN-USE-P RESOURCE N) AS OBJ = (RESOURCE-OBJECT RESOURCE N) WHEN (AND (IF CHECKER (APPLY CHECKER RESOURCE OBJ IN-USE-P PARAMS) (NOT IN-USE-P)) (IF MATCHER (APPLY MATCHER RESOURCE OBJ PARAMS) (OR (NULL PARAMS) (EQUAL (RESOURCE-PARAMETERS RESOURCE N) PARAMS)))) DO (SETF (RESOURCE-IN-USE-P RESOURCE N) T) (RETURN (SETQ TEM OBJ)))) (T (SETQ INHIBIT-SCHEDULING-FLAG OLD) (SETQ PARAMS (COPY-LIST PARAMS)) (SETQ TEM (APPLY (RESOURCE-CONSTRUCTOR RESOURCE) RESOURCE PARAMS)) (SETQ INHIBIT-SCHEDULING-FLAG T) (SETF (RESOURCE-N-OBJECTS RESOURCE) (1+ (SETQ INDEX (RESOURCE-N-OBJECTS RESOURCE)))) (WHEN ( INDEX (ARRAY-DIMENSION RESOURCE 0)) (SETF (GET (RESOURCE-NAME RESOURCE) 'DEFRESOURCE) (SETQ RESOURCE (ARRAY-GROW RESOURCE (+ INDEX (MAX 20. (TRUNCATE INDEX 2))) 3)))) (SETF (RESOURCE-OBJECT RESOURCE INDEX) TEM) (SETF (RESOURCE-IN-USE-P RESOURCE INDEX) T) (SETF (RESOURCE-PARAMETERS RESOURCE INDEX) ;Avoid lossage with (IF (EQ PARAMS PARAMETERS) (COPY-LIST PARAMS) ;as little consing PARAMS))))) ;as possible. ;; TEM now is the object (WHEN (SETQ INITIALIZER (RESOURCE-INITIALIZER RESOURCE)) (APPLY INITIALIZER RESOURCE TEM PARAMS)) TEM) ;;;From DJ: L.SYS; QCP1.LISP#> ;;;(From qcompile0) (WHEN SUBST-FLAG (LET* ((ARGS-INFO (ARGS-INFO EXP)) (DUMMY-FORM (CONS 'FOO (MAKE-LIST (+ (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO) (IF (LDB-TEST %ARG-DESC-EVALED-REST ARGS-INFO) 1 0)) :INITIAL-ELEMENT '(gensymbol "DUMMY"))))) ;;;From DJ: L.SYS; QCP1.LISP#> ;;; Given a non-atomic form issue any warnings required because of wrong number of arguments. ;;; This function has some of the same knowledge as GETARGDESC but doesn't call ;;; it because GETARGDESC has to do a lot more. ;;; This function should never get an error and never warn about ;;; anything that gets warned about elsewhere. (DEFUN CHECK-NUMBER-OF-ARGS (FORM &OPTIONAL FUNCTION) (IF (NULL FUNCTION) (SETQ FUNCTION (CAR FORM))) (LET* (TEM ARGLIST NARGS (MIN NIL) (MAX 0) (MAX1 0) (ARGS-INFO NIL) (LOCALP NIL) (FN FUNCTION)) (AND (SYMBOLP FN) ;; If FN is a name defined lexically by FLET or LABELS, use its definition. (SETQ LOCALP (FSYMEVAL-IN-FUNCTION-ENVIRONMENT FN)) (SETQ FN LOCALP)) (FLET ((BAD-ARGUMENTS (MSG) (WARN 'WRONG-NUMBER-OF-ARGUMENTS :PROBABLY-ERROR (IF LOCALP "~S (locally defined function) called with ~A" "~S called with ~A") (CAR FORM) MSG))) (TAGBODY TOP (IF LOCALP (SETQ ARGLIST (CASE (CAR FN) ((MACRO) (RETURN-FROM CHECK-NUMBER-OF-ARGS NIL)) ((NAMED-LAMBDA NAMED-SUBST) (CADDR FN)) (T (CADR FN)))) (SETQ FN (LAMBDA-MACRO-EXPAND FN)) (COND ((AND (SYMBOLP FN) (NOT (FBOUNDP FN))) (SETQ ARGLIST NIL)) (T (SETQ ARGLIST (IGNORE-ERRORS (ARGLIST FN 'COMPILE))) (IF (EQ ARGLIST 'MACRO) (RETURN-FROM CHECK-NUMBER-OF-ARGS NIL))))) (COND ((OR LOCALP (MEMQ (CAR-SAFE FN) '(LAMBDA NAMED-LAMBDA ZL:SUBST CL:SUBST NAMED-SUBST))) (DOLIST (X ARGLIST) (COND ((EQ X '&OPTIONAL) (SETQ MIN MAX)) ((OR (EQ X '&REST) (EQ X '&BODY) (EQ X '&KEY)) (UNLESS MIN (SETQ MIN MAX)) (SETQ MAX MOST-POSITIVE-FIXNUM) (RETURN)) ((EQ X '&AUX) (RETURN)) ((MEMQ X LAMBDA-LIST-KEYWORDS)) (T (INCF MAX) (INCF MAX1))))) ((NOT (SYMBOLP FN)) ;; Unknown type, don't check (RETURN-FROM CHECK-NUMBER-OF-ARGS NIL)) ((SETQ TEM (GET FN 'ARGDESC)) (DOLIST (X TEM) (COND ((MEMQ 'FEF-ARG-REQ (CADR X)) (INCF MAX (CAR X)) (INCF MAX1 (CAR X))) ((MEMQ 'FEF-ARG-OPT (CADR X)) (OR MIN (SETQ MIN MAX)) (INCF MAX (CAR X)) (INCF MAX1 (CAR X))) ((MEMQ 'FEF-ARG-REST (CADR X)) (OR MIN (SETQ MIN MAX)) (SETQ MAX MOST-POSITIVE-FIXNUM))))) ((SETQ TEM (GET FN 'QINTCMP)) (SETQ MAX TEM MAX1 TEM)) ;>> used?? ((SETQ TEM (GET FN 'Q-ARGS-PROP)) (SETQ ARGS-INFO TEM)) ;; Take care of recursive calls to function being compiled. ((AND (EQ FN THIS-FUNCTION-ARGLIST-FUNCTION-NAME) (NOT LOCALP)) (DOLIST (X THIS-FUNCTION-ARGLIST) (COND ((EQ X '&OPTIONAL) (SETQ MIN MAX)) ((OR (EQ X '&REST) (EQ X '&BODY) (EQ X '&KEY)) (UNLESS MIN (SETQ MIN MAX)) (SETQ MAX MOST-POSITIVE-FIXNUM) (RETURN)) ((EQ X '&AUX) (RETURN)) ((MEMQ X LAMBDA-LIST-KEYWORDS)) (T (INCF MAX) (INCF MAX1))))) ;;>> doesn't look at definitions earlier in the file ((FBOUNDP FN) (SETQ TEM (SI:UNENCAPSULATE-FUNCTION-SPEC FN)) (UNLESS (EQ TEM FN) (SETQ FN TEM) (GO TOP)) (SETQ TEM (SYMBOL-FUNCTION FN)) (COND ((OR (SYMBOLP TEM) (CONSP TEM)) (SETQ FN TEM) (GO TOP)) (T (SETQ ARGS-INFO (%ARGS-INFO TEM))))) (T ;;No information available (RETURN-FROM CHECK-NUMBER-OF-ARGS NIL)))) (WHEN ARGS-INFO (SETQ MIN (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO) MAX1 (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO) MAX (IF (BIT-TEST (LOGIOR %ARG-DESC-QUOTED-REST %ARG-DESC-EVALED-REST) ARGS-INFO) MOST-POSITIVE-FIXNUM MAX1))) (SETQ NARGS (LENGTH (CDR FORM))) ;Now that we know it's not a macro (COND ((< NARGS (OR MIN MAX)) (BAD-ARGUMENTS "too few arguments")) ((> NARGS MAX) (BAD-ARGUMENTS "too many arguments")) ((CONSP ARGLIST) (LET* ((KEYARGS (MEMQ '&KEY ARGLIST)) (KEYFORM (NTHCDR (OR MAX1 MIN) (CDR FORM)))) (WHEN (AND KEYARGS KEYFORM) (IF (ODDP (LENGTH KEYFORM)) (BAD-ARGUMENTS "no value supplied for some keyword argument") (LET ((ALLOW-OTHER-KEYS (OR (MEMQ '&ALLOW-OTHER-KEYS ARGLIST) (GETF KEYFORM ':ALLOW-OTHER-KEYS)))) (LOOP FOR KEY IN KEYFORM BY 'CDDR WHEN (AND (EQ (CAR-SAFE KEY) 'QUOTE) (SELF-EVALUATING-P (CADR KEY))) DO (SETQ KEY (CADR KEY)) DOING (COND ((KEYWORDP KEY) (UNLESS (OR ALLOW-OTHER-KEYS (DOLIST (X KEYARGS) (IF (MEMQ X LAMBDA-LIST-KEYWORDS) NIL (IF (IF (CONSP X) (IF (CONSP (CAR X)) ;; ((:frob foo) bar) (EQ KEY (CAAR X)) ;; (foo bar) (STRING= KEY (CAR X))) ;; foo (STRING= KEY X)) (RETURN T))))) (BAD-ARGUMENTS (FORMAT NIL "the unrecognized keyword ~S" KEY)))) ((SELF-EVALUATING-P KEY) (BAD-ARGUMENTS (FORMAT NIL "~S appearing where a keyword should" KEY)))))))))))))) ;;;From DJ: L.SYS; QCP2.LISP#> ;;; Arg desc list -- a list of lists ;;; Each list ( ) ;;; Token list has things like FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-REST, ;;; and FEF-QT-EVAL FEF-QT-QT. (DEFUN GETARGDESC (X &AUX TEM) ;second value T if this is a guess. (COND ((SETQ TEM (GET X 'ARGDESC)) TEM) ((SETQ TEM (GET X 'QINTCMP)) (LIST (CONS TEM '((FEF-ARG-REQ FEF-QT-EVAL))))) ((SETQ TEM (GET X 'Q-ARGS-PROP)) (GET-ARGDESC-PROP-FROM-Q-ARGS-PROP TEM X)) ((EQ X THIS-FUNCTION-ARGLIST-FUNCTION-NAME) (GET-ARGDESC-PROP-FROM-LAMBDA-LIST THIS-FUNCTION-ARGLIST)) ((SETQ TEM (DECLARED-DEFINITION X)) (COND ((SYMBOLP TEM) (GETARGDESC TEM)) ((CONSP TEM) (SETQ TEM (LAMBDA-MACRO-EXPAND TEM)) (GET-ARGDESC-PROP-FROM-LAMBDA-LIST (CAR (SI::LAMBDA-EXP-ARGS-AND-BODY TEM)))) ((AND (TYPEP TEM ':COMPILED-FUNCTION) (SETQ TEM (GET-MACRO-ARG-DESC-POINTER TEM))) ;; Use ADL in preference to %ARGS-INFO so that we ;; find things like FEF-ARG-FUNCTIONAL. ;; The only reason we would have an ADL if the ;; %ARGS-INFO would otherwise be correct ;; is if things like FEF-ARG-FUNCTIONAL are present. (GET-ARGDESC-PROP-FROM-ADL TEM)) (T (SETQ TEM (%ARGS-INFO X)) (IF (BIT-TEST %ARG-DESC-INTERPRETED TEM) '((#o1005 (FEF-ARG-OPT FEF-QT-EVAL))) (GET-ARGDESC-PROP-FROM-Q-ARGS-PROP TEM X))))) (T (VALUES '((#o1005 (FEF-ARG-OPT FEF-QT-EVAL))) ;make a guess T)))) (DEFUN GET-ARGDESC-PROP-FROM-Q-ARGS-PROP (ARG-PROP FN-NAME &AUX ANS MIN-ARGS OPT-ARGS) (IF ( 0 (LOGAND %ARG-DESC-FEF-QUOTE-HAIR ARG-PROP)) (GET-ARGDESC-PROP-FROM-ADL (GET-MACRO-ARG-DESC-POINTER (FSYMEVAL FN-NAME)))) (IF ( 0 (SETQ MIN-ARGS (LDB %%ARG-DESC-MIN-ARGS ARG-PROP))) (SETQ ANS (NCONC ANS (LIST (CONS MIN-ARGS '((FEF-ARG-REQ FEF-QT-EVAL))))))) (IF ( 0 (SETQ OPT-ARGS (- (LDB %%ARG-DESC-MAX-ARGS ARG-PROP) MIN-ARGS))) (SETQ ANS (NCONC ANS (LIST (CONS OPT-ARGS '((FEF-ARG-OPT FEF-QT-EVAL))))))) (IF ( 0 (LOGAND %ARG-DESC-QUOTED-REST ARG-PROP)) (SETQ ANS (NCONC ANS (LIST '(1 (FEF-ARG-REST FEF-QT-QT)))))) (IF ( 0 (LOGAND %ARG-DESC-EVALED-REST ARG-PROP)) (SETQ ANS (NCONC ANS (LIST '(1 (FEF-ARG-REST FEF-QT-EVAL)))))) ANS) ;;;From DJ: L.SYS; QCLAP.LISP#> ;;; This function is called before pass 1 and duplicates some of the work done in ;;; pass 2 by LAP-MFEF, in order to determine whether the A-D-L will be required. ;;; This organization is somewhat poor... (DEFUN COMPUTE-A-D-L-NEEDED-P () (LET (QFEFHI-FAST-ARG-OPT-OPERATIVE S-V-BITMAP-ACTIVE FA) (COMPUTE-S-V-MAP) ;Compute S-V-BITMAP-ACTIVE (SETQ FA (COMPUTE-FAST-OPT-Q)) ;Compute QFEFHI-FAST-ARG-OPT-OPERATIVE (SETQ A-D-L-NEEDED-P (OR (BIT-TEST %ARG-DESC-FEF-QUOTE-HAIR FA) ;Needed by interpreter (NOT QFEFHI-FAST-ARG-OPT-OPERATIVE) ;Needed by microcode (DOLIST (V *ALLVARS*) ;Needed for extra info on args (OR (LAP-ARGP V) (RETURN NIL)) ;(such as &functional) (AND (NOT (ZEROP (LIST-SUM (VAR-MISC V)))) (RETURN T)))))) NIL) ;;;From DJ: L.SYS; QCLAP.LISP#> (DEFUN COMPUTE-FAST-OPT-Q () ;Sets spec var QFEFHI-FAST-ARG-OPT-OPERATIVE (SETQ QFEFHI-FAST-ARG-OPT-OPERATIVE NIL) ;Assume inoperative (OR HAIRY-INIT-FLAG ;Check reasons not to have fast opt operative (NULL S-V-BITMAP-ACTIVE) ;Ucode doesn't feel like handling this case.. ; (going to have to grubble through A-D-L ; anyway, so might as do slow enter). (SETQ QFEFHI-FAST-ARG-OPT-OPERATIVE T)) (+ (COND ((NULL REST-ARG) 0) ((EQ (VAR-EVAL REST-ARG) 'FEF-QT-QT) %ARG-DESC-QUOTED-REST) (T %ARG-DESC-EVALED-REST)) (+ (COND ((AND SM-ARGS-NOT-EVALD (> MAX-ARGS 0)) ;If quoted reg args, %ARG-DESC-FEF-QUOTE-HAIR) ; fast arg not operative for caller (T 0)) (+ (COND (QFEFHI-FAST-ARG-OPT-OPERATIVE 0) (T %ARG-DESC-FEF-BIND-HAIR)) (+ (LSH MIN-ARGS 6) MAX-ARGS))))) ;;;From DJ: L.DEBUGGER; EH.LISP#> (DEFUN SG-FRAME-ARG-VALUE (SG FRAME ARGNUM &OPTIONAL (ERRORP T)) "Return the value and location of arg number ARGNUM in FRAME in SG. Checks ARGNUM for being in bounds, if the frame is active /(for an open frame, it is not known how many args there are). The second value is where the value is located when SG is running; this may be a symbol value cell, etc., if the arg is special. ERRORP non-NIL means signal an error if ARGNUM is invalid. ERRORP NIL means retrun a third value which describes the problem, if any." (DECLARE (VALUES VALUE LOCATION BARF)) (CHECK-TYPE ARGNUM (OR SYMBOL STRING NUMBER)) (LET* ((FUNCTION (RP-FUNCTION-WORD (SG-REGULAR-PDL SG) FRAME)) (NUM-ARGS (SG-NUMBER-OF-SPREAD-ARGS SG FRAME)) (REST-ARG-P (AND (LEGITIMATE-FUNCTION-P FUNCTION) (LDB-TEST %%ARG-DESC-ANY-REST (ARGS-INFO FUNCTION)))) ARG-NAME ERROR-STRING) (IF (SYMBOLP ARGNUM) (OR (DOTIMES (I NUM-ARGS) (IF (STRING= (STRING (ARG-NAME FUNCTION I)) (STRING ARGNUM)) (RETURN (SETQ ARGNUM I)))) ;; If this function takes a rest arg and we have ;; specified its name, handle it (it is local number 0). (AND REST-ARG-P (STRING= (STRING (LOCAL-NAME FUNCTION 0)) (STRING ARGNUM)) (RETURN-FROM SG-FRAME-ARG-VALUE (IF (CONSP FUNCTION) (VALUES (SG-REST-ARG-VALUE SG FRAME) T) (SG-FRAME-LOCAL-VALUE SG FRAME 0)))))) (COND ((SYMBOLP ARGNUM) (SETQ ERROR-STRING "No arg named ~S")) ((< ARGNUM 0) (SETQ ERROR-STRING "No argument number ~D, silly!")) (T (SETQ ARG-NAME (ARG-NAME FUNCTION ARGNUM)) (WHEN (AND ( ARGNUM NUM-ARGS) (SG-FRAME-ACTIVE-P SG FRAME)) (LET ((LOC (NTHCDR (- ARGNUM NUM-ARGS) (AND REST-ARG-P (SG-REST-ARG-VALUE SG FRAME))))) (IF LOC (RETURN-FROM SG-FRAME-ARG-VALUE (VALUES (CAR LOC) (LOCF (CAR LOC)))) (SETQ ERROR-STRING "Argument number ~D is out of range in current frame")))))) (IF ERROR-STRING (IF ERRORP (FERROR ERROR-STRING ARGNUM) (VALUES NIL NIL (FORMAT NIL ERROR-STRING ARGNUM))) ;; Is this variable bound special in THIS frame? (MULTIPLE-VALUE-BIND (START END) (SG-FRAME-SPECIAL-PDL-RANGE SG FRAME) (WHEN START (DO ((SP (SG-SPECIAL-PDL SG)) (I START (+ 2 I))) (( I END)) (AND (EQ ARG-NAME (SYMBOL-FROM-VALUE-CELL-LOCATION (AREF SP (1+ I)))) ;; Yes, it is, so return its special binding ;; and that binding's location when the SG is running. (RETURN-FROM SG-FRAME-ARG-VALUE (MULTIPLE-VALUE-BIND (VALUE NIL LOCATION) (SYMEVAL-IN-STACK-GROUP ARG-NAME SG FRAME T) (VALUES VALUE LOCATION))))))) (VALUES (AREF (SG-REGULAR-PDL SG) (+ FRAME ARGNUM 1)) (LOCF (AREF (SG-REGULAR-PDL SG) (+ FRAME ARGNUM 1))))))) ;;;From DJ: L.DEBUGGER; EH.LISP#> (DEFUN SG-REST-ARG-VALUE (SG FRAME &AUX (RP (SG-REGULAR-PDL SG)) (AP FRAME) LEXPR-CALL ARGS-INFO REST-ARG (FUNCTION (RP-FUNCTION-WORD RP AP)) (NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP AP)) (NARGS-EXPECTED NARGS-SUPPLIED)) "Get the value of the rest arg in FRAME in SG. The first value is the value of the rest arg (nil if the frame has none). The second value is T if the function expects to have one. The third value indicates a rest arg that does not overlap the stack frame." (DECLARE (VALUES REST-ARG-VALUE REST-ARG-EXPECTED REST-ARG-EXPLICIT)) (WHEN (LEGITIMATE-FUNCTION-P FUNCTION) (SETQ ARGS-INFO (ARGS-INFO FUNCTION)) (SETQ REST-ARG (LDB-TEST %%ARG-DESC-ANY-REST ARGS-INFO)) (SETQ NARGS-EXPECTED (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO))) (WHEN (AND REST-ARG (TYPEP FUNCTION 'COMPILED-FUNCTION) (= (1+ NARGS-EXPECTED) (RP-LOCAL-BLOCK-ORIGIN RP AP)) (AREF RP (+ AP 1 NARGS-EXPECTED))) ;Local 0 (SETQ LEXPR-CALL T)) (VALUES (IF (TYPEP FUNCTION 'COMPILED-FUNCTION) (AREF RP (+ AP (RP-LOCAL-BLOCK-ORIGIN RP AP))) (IF (> NARGS-SUPPLIED NARGS-EXPECTED) (%MAKE-POINTER DTP-LIST (LOCF (AREF RP (+ AP NARGS-EXPECTED 1)))) NIL)) REST-ARG LEXPR-CALL)) ;;;From DJ: L.DEBUGGER; EH.LISP#> (DEFF SG-FRAME-NUMBER-OF-SPREAD-ARGS 'SG-NUMBER-OF-SPREAD-ARGS) (DEFUN SG-NUMBER-OF-SPREAD-ARGS (SG FRAME &AUX (RP (SG-REGULAR-PDL SG)) (AP FRAME) ARGS-INFO REST-ARG-P NARGS-EXPECTED (FUNCTION (RP-FUNCTION-WORD RP AP)) (NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP AP))) "Returns the number of spread args present in FRAME in SG. /"Spread/" args means that the elements of a rest arg normally do not count." (WHEN (LEGITIMATE-FUNCTION-P FUNCTION) (SETQ ARGS-INFO (ARGS-INFO FUNCTION)) (SETQ REST-ARG-P (LDB-TEST %%ARG-DESC-ANY-REST ARGS-INFO)) (SETQ NARGS-EXPECTED (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO))) ;; The args that can be asked for are the ones supplied, ;; except that FEFs make slots for all args they expect whether supplied or not, ;; and if there is a rest arg it any unexpected spread args ;; are considered to be part of that. (COND ((TYPEP FUNCTION 'COMPILED-FUNCTION) (IF REST-ARG-P NARGS-EXPECTED (MAX (1- (RP-LOCAL-BLOCK-ORIGIN RP AP)) NARGS-EXPECTED NARGS-SUPPLIED))) (T (IF REST-ARG-P (MIN NARGS-SUPPLIED NARGS-EXPECTED) NARGS-SUPPLIED)))) ;;;From DJ: L.DEBUGGER; EH.LISP#> (DEFF SG-FRAME-NUMBER-OF-SPREAD-ARGS 'SG-NUMBER-OF-SPREAD-ARGS) (DEFUN SG-NUMBER-OF-SPREAD-ARGS (SG FRAME &AUX (RP (SG-REGULAR-PDL SG)) (AP FRAME) ARGS-INFO REST-ARG-P NARGS-EXPECTED (FUNCTION (RP-FUNCTION-WORD RP AP)) (NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP AP))) "Returns the number of spread args present in FRAME in SG. /"Spread/" args means that the elements of a rest arg normally do not count." (WHEN (LEGITIMATE-FUNCTION-P FUNCTION) (SETQ ARGS-INFO (ARGS-INFO FUNCTION)) (SETQ REST-ARG-P (LDB-TEST %%ARG-DESC-ANY-REST ARGS-INFO)) (SETQ NARGS-EXPECTED (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO))) ;; The args that can be asked for are the ones supplied, ;; except that FEFs make slots for all args they expect whether supplied or not, ;; and if there is a rest arg it any unexpected spread args ;; are considered to be part of that. (COND ((TYPEP FUNCTION 'COMPILED-FUNCTION) (IF REST-ARG-P NARGS-EXPECTED (MAX (1- (RP-LOCAL-BLOCK-ORIGIN RP AP)) NARGS-EXPECTED NARGS-SUPPLIED))) (T (IF REST-ARG-P (MIN NARGS-SUPPLIED NARGS-EXPECTED) NARGS-SUPPLIED)))) ;;;From DJ: L.DEBUGGER; CONDITION-FLAVORS.LISP#> (defmethod (function-entry-error :case :proceed-asking-user :new-argument-list) (continuation read-object-function) (let* ((-function- (send self :function)) (-argument-list- (send self :argument-list)) (-nargs- (send self :nargs)) (form (cons -function- -argument-list-)) (args-info (args-info -function-)) (args-wanted (ldb %%arg-desc-min-args args-info)) (rest-flag (ldb-test %%arg-desc-any-rest args-info)) (max-args (ldb %%arg-desc-max-args args-info)) new-args) ;; Function may have been redefined to take the supplied number of arguments ;; so don't look at the original error, but check everything again. (cond ((< -nargs- args-wanted) (do ((i -nargs- (1+ i))) ((unless rest-flag (eq i max-args))) (multiple-value-bind (value flag) (funcall read-object-function (if ( i args-wanted) :eval-read-or-end :eval-read) (if ( i args-wanted) "~&Arg ~D~A, or ~C: " "~&Arg ~D~A: ") i (format:output nil (display-arg-name " (~A)" -function- i)) #\End) (if flag (return (values))) (setq new-args (nconc new-args (ncons value))))) (funcall continuation :new-argument-list (append (cdr form) new-args))) ((or ( -nargs- max-args) (ldb-test %%arg-desc-any-rest args-info)) (if (funcall read-object-function '(:fquery) "Try ~S again? " form) (funcall continuation :new-argument-list (cdr form)))) ((funcall read-object-function '(:fquery) "Call again with the last ~[~1;~:;~:*~D ~]argument~:P dropped? " (- -nargs- max-args)) (funcall continuation :new-argument-list (firstn max-args (cdr form))))))) ;;;From DJ: L.DEBUGGER; EHC.LISP#> (defun print-frame-args (sg frame indent &aux (*print-level* error-message-prinlevel) (*print-length* error-message-prinlength) function nargs-supplied nargs-to-print (rp (sg-regular-pdl sg)) nargs-expected nargs-required active-flag lexpr-call rest-arg-p rest-arg-value) "Print the arguments in FRAME, indenting lines by INDENT chars. Returns the number of args printed and a second value of T if the function called in FRAME wants a rest arg (so our caller can refrain from mentioning local 0, if he is going to print the locals)." (setq function (rp-function-word rp frame) nargs-supplied (rp-number-args-supplied rp frame)) (setq active-flag (sg-frame-active-p sg frame)) (cond (active-flag (when (legitimate-function-p function) (setq nargs-required (ldb %%arg-desc-min-args (args-info function))) (setq nargs-expected (ldb %%arg-desc-max-args (args-info function)))) (multiple-value-setq (rest-arg-value rest-arg-p lexpr-call) (sg-rest-arg-value sg frame)) (setq nargs-to-print (sg-number-of-spread-args sg frame))) (t (format t "~& Frame still accumulating args;~% possible args or stack temps follow:~%") (let ((tem (sg-previous-open sg frame))) (setq nargs-to-print (- (if tem (- tem 4) (sg-regular-pdl-pointer sg)) frame) nargs-supplied nargs-to-print)))) ;; Print the individual args. (dotimes (i nargs-to-print) (and (= i nargs-supplied) (if (and nargs-required (< i nargs-required)) (format t "~& --Missing args:--~%") (format t "~& --Defaulted args:--~%"))) ;These "args" weren't supplied (and nargs-required (< nargs-supplied nargs-required) (= i nargs-required) (format t "~& --Optional args:--~%")) ;End of truly missing args (and nargs-expected (= i nargs-expected) ;Called with too many args (format t "~& --Extraneous args:--~%")) (format t "~&~VTArg ~D" indent i) (and active-flag (display-arg-name " (~A)" function i)) ;; Print the arg value unless the arg is missing (val is garbage). (cond ((not (and nargs-required (> nargs-required nargs-supplied) ( i nargs-supplied))) (princ ": ") (catch-error (typecase (sg-frame-arg-value sg frame i) (string (print-string-as-local-or-arg (sg-frame-arg-value sg frame i))) (t (prin1 (sg-frame-arg-value sg frame i))))) nil)) (terpri)) ;; Print the rest arg if any. (cond (rest-arg-p (format t "~&~VTRest arg" indent) (display-local-name " (~A)" function 0) (princ ": ")) (lexpr-call (format t "~&~VTExtraneous Rest Arg: " indent))) (when (or rest-arg-p lexpr-call) (catch-error (prin1 rest-arg-value) nil) (terpri)) (values nargs-to-print rest-arg-p)) ;;;From DJ: L.DEBUGGER; EHC.LISP#> ;; Meta-Shift-T (defun com-show-stack-temporaries (sg ignore &optional arg &aux (*print-level* error-message-prinlevel) (*print-length* error-message-prinlength) (rp (sg-regular-pdl sg))) "With no argument, show arguments, locals, and temporary values pushed onto stack by this stack frame. With an argument of 0, also displays pending open frames, and arguments pushed for them (presumably as arguments) With an argument of -1, displays each word of the regular pdl from the current frame to the pdl-pointer. You don't -really- want to do this, do you?" (cond ((eq arg -1) (let ((end (sg-regular-pdl-pointer sg)) (rp (sg-regular-pdl sg))) (loop for i from (1+ *current-frame*) below end do (format t "~%~4D: " i) (p-prin1-careful-1 (locf (aref rp i)))))) (t (loop for this-frame = *current-frame* then (sg-previous-open sg this-frame) for firstp = t then nil while (and this-frame ( this-frame (sg-regular-pdl-pointer sg))) as function = (rp-function-word rp this-frame) as n-locals = 0 and nargs = 0 and nargs-expected = 0 as rest-arg-value = nil and rest-arg-p = nil and lexpr-call = nil until (and (not firstp) (or (eq arg 0) (sg-frame-active-p sg this-frame) (eq function #'foothold))) do (if (eq function #'foothold) (show-foothold sg this-frame) (when (sg-frame-active-p sg this-frame) (when (legitimate-function-p function) (setq nargs-expected (ldb %%arg-desc-max-args (args-info function))) (setq nargs (sg-number-of-spread-args sg this-frame)) (multiple-value-setq (rest-arg-value rest-arg-p lexpr-call) (sg-rest-arg-value sg this-frame)) (setq n-locals (fef-number-of-locals function)))) (let* ((prev-open (sg-previous-open sg this-frame)) (total (- (if prev-open (- prev-open 4) (sg-regular-pdl-pointer sg)) this-frame))) (catch-error (format t "~&~S" (function-name function)) nil) ;;;From DJ: L.DEBUGGER; EHC.LISP#> ;; Copied from LAD: RELEASE-3.DEBUGGER; EHC.LISP#258 on 2-Oct-86 06:04:49 ;; Meta-R (defun com-reinvoke-new-args (sg ignore &rest ignore) "Reinvoke the current function with possibly altered arguments." (cond ((null *error-handler-running*) (format t "You can only examine this stack group, not modify it.")) ((not (sg-frame-active-p sg *current-frame*)) (format t "This frame's args are still being computed; it cannot be reinvoked since it was never invoked.")) (t (let* ((form (get-frame-function-and-args sg *current-frame*)) (function-name (car form)) (function (rp-function-word (sg-regular-pdl sg) *current-frame*)) (argument-list (cdr form)) (nargs (length argument-list)) (args-info (args-info function)) (args-wanted (ldb %%arg-desc-min-args args-info)) (rest-flag (ldb-test %%arg-desc-any-rest args-info)) (max-args (ldb %%arg-desc-max-args args-info)) new-args (*print-level* error-message-prinlevel) (*print-length* error-message-prinlength)) (format t "~&Reinvoke ~S with possibly altered arguments." function-name) (do ((i 0 (1+ i))) ((unless rest-flag (eq i max-args))) (multiple-value-bind (value flag) (prompt-and-read (let ((keyword (if ( i args-wanted) :eval-read-or-end :eval-read))) (if (< i nargs) (list keyword :default (nth i argument-list)) keyword)) (if (< i nargs) (if ( i args-wanted) "~&Arg ~D~A, or ~\lozenged-character\ not to change it, or ~C: " "~&Arg ~D~A, or ~\lozenged-character\ not to change it: ") (if ( i args-wanted) "~&Arg ~D~A, or ~*~C: " "~&Arg ~D~A: ")) i (format:output nil (display-arg-name " (~A)" function i)) #/space #/end) (if (eq flag ':end) (return)) (if (eq flag ':default) (prin1 value)) (setq new-args (nconc new-args (ncons value))))) (setq form (cons function-name new-args)) (when (fquery nil "Reinvoking ~S, OK? " form) (setf (rp-trap-on-exit (sg-regular-pdl sg) *innermost-visible-frame*) 0) (sg-unwind-to-frame-and-reinvoke sg *current-frame* form) (leaving-error-handler) (without-interrupts (if *error-handler-running* (wipe-current-stack-group-and-resume sg) (stack-group-resume sg nil)))))))) ;;;From DJ: L.DEBUGGER; EHW.LISP#> ;;;Support routines for the args, locals, and specials windows ;;;Entries are fixed strings, or lists of name, val, and number ;;;Common arg is the type of entries present (DEFUN SETUP-ARGS-WINDOW (WINDOW SG AP &AUX (RP (SG-REGULAR-PDL SG)) LIST FUNCTION NARGS-SUPPLIED NARGS-TO-PRINT NARGS-EXPECTED NARGS-REQUIRED LEXPR-CALL REST-ARG-P REST-ARG-VALUE) (SETQ FUNCTION (RP-FUNCTION-WORD RP AP) NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP AP)) (COND ((OR (= (%DATA-TYPE FUNCTION) DTP-FEF-POINTER) (CONSP FUNCTION)) (SETQ NARGS-REQUIRED (LDB %%ARG-DESC-MIN-ARGS (ARGS-INFO FUNCTION))) (SETQ NARGS-EXPECTED (LDB %%ARG-DESC-MAX-ARGS (ARGS-INFO FUNCTION))))) (MULTIPLE-VALUE (REST-ARG-VALUE REST-ARG-P LEXPR-CALL) (SG-REST-ARG-VALUE SG AP)) (SETQ NARGS-TO-PRINT (SG-NUMBER-OF-SPREAD-ARGS SG AP)) ;; Store the individual args. (DOTIMES (I NARGS-TO-PRINT) (AND (= I NARGS-SUPPLIED) ;These "args" weren't supplied (PUSH (IF (AND NARGS-REQUIRED (< I NARGS-REQUIRED)) " --Missing args:--" " --Defaulted args:--") LIST)) (AND NARGS-EXPECTED (= I NARGS-EXPECTED) ;Called with too many args (PUSH " --Extraneous args:--" LIST)) (LET ((MISSING (AND NARGS-REQUIRED (> NARGS-REQUIRED NARGS-SUPPLIED) ( I NARGS-SUPPLIED)))) (PUSH (LIST (ARG-NAME FUNCTION I) ;Arg name (OR MISSING (AREF RP (+ AP I 1))) ;Value (IF (NOT MISSING) I (LIST ':NOVALUE I))) ;Number LIST))) ;; Print the rest arg if any. (AND (OR REST-ARG-P LEXPR-CALL) (PUSH (LIST (AND REST-ARG-P (LOCAL-NAME FUNCTION 0)) ;Name REST-ARG-VALUE ;Value (IF REST-ARG-P "Rest arg" "Extraneous rest arg")) LIST)) (VALUES (SEND WINDOW :SETUP (LIST 'PRINT-ARG-OR-LOCAL '(ARG "Arg") (NREVERSE LIST))) REST-ARG-P))