(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED " 4-Jan-92 12:51:42" IL:|{DSK}<usr>local>lde>lispcore>sources>LLSYMBOL.;2| 9415 IL:|changes| IL:|to:| (IL:FUNCTIONS FBOUNDP CL:FDEFINITION CL::SET-FDEFINITION FMAKUNBOUND) (IL:VARS IL:LLSYMBOLCOMS) (XCL:OPTIMIZERS CL:FDEFINITION) (IL:SETFS CL:FDEFINITION) IL:|previous| IL:|date:| "11-Jun-90 17:56:50" IL:|{DSK}<usr>local>lde>lispcore>sources>LLSYMBOL.;1|) ; Copyright (c) 1986, 1987, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:LLSYMBOLCOMS) (IL:RPAQQ IL:LLSYMBOLCOMS ((IL:* IL:|;;| "Symbol functions.") (IL:* IL:|;;| "SET , BOUNDP and REMPROP are the same as and shared with Interlisp-D") (IL:FUNCTIONS MAKUNBOUND SYMBOL-NAME SYMBOL-VALUE GET GETF GET-PROPERTIES) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:P (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)))) (IL:FUNCTIONS FBOUNDP FMAKUNBOUND SYMBOL-FUNCTION CL:FDEFINITION IL:SETF-SYMBOL-FUNCTION CL::SET-FDEFINITION) (XCL:OPTIMIZERS CL:FDEFINITION) (IL:COMS (IL:* IL:|;;| "GENSYM Code") (IL:VARIABLES *GENSYM-COUNTER* *GENSYM-PREFIX* *GENTEMP-COUNTER*) (IL:FUNCTIONS GENSYM GENTEMP)) (IL:FUNCTIONS COPY-SYMBOL IL:MAKE-KEYWORD KEYWORDP) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:LLSYMBOL))) (IL:* IL:|;;| "Symbol functions.") (IL:* IL:|;;| "SET , BOUNDP and REMPROP are the same as and shared with Interlisp-D") (DEFUN MAKUNBOUND (SYMBOL) (IL:* IL:|;;| "Make a symbol unbound.") (IL:* IL:|;;| " Unbound symbols are set to IL:NOBIND") (IF (CONSTANTP SYMBOL) (PROGN (XCL::SET-CONSTANTP SYMBOL NIL) (PROCLAIM (IL:BQUOTE (SPECIAL (IL:\\\, SYMBOL)))))) (SET SYMBOL (QUOTE IL:NOBIND)) SYMBOL) (DEFUN SYMBOL-NAME (SYMBOL) (IF (SYMBOLP SYMBOL) (IL:* IL:|;;| "Make a read-only string header displaced to the pname base") (IL:%MAKE-ONED-ARRAY (IL:|ffetch| (IL:LITATOM IL:PNAMELENGTH) IL:|of| SYMBOL) (QUOTE STRING-CHAR) NIL (IL:|ffetch| (IL:LITATOM IL:FATPNAMEP) IL:|of| SYMBOL) T NIL (IL:|ffetch| (IL:LITATOM IL:PNAMEBASE) IL:|of| SYMBOL) 1) (ERROR (QUOTE CONDITIONS:SIMPLE-TYPE-ERROR) :EXPECTED-TYPE (QUOTE SYMBOL) :CULPRIT SYMBOL))) (DEFUN SYMBOL-VALUE (SYMBOL) (IL:* IL:|;;| "Like EVALV, but must give error if unbound - uses fact that \\eval has an opcode which hooks into free variable microcode") (IF (SYMBOLP SYMBOL) (IL:\\EVAL SYMBOL) (ERROR (QUOTE CONDITIONS:SIMPLE-TYPE-ERROR) :EXPECTED-TYPE (QUOTE SYMBOL) :CULPRIT SYMBOL))) (DEFUN GET (SYMBOL INDICATOR &OPTIONAL (DEFAULT NIL)) (IL:* IL:|;;| "Look on the property list of SYMBOL for the specified INDICATOR. If this is found, return the associated value, else return DEFAULT.") (GETF (IL:GETPROPLIST SYMBOL) INDICATOR DEFAULT)) (DEFUN GETF (PLACE INDICATOR &OPTIONAL (DEFAULT NIL)) (IL:* IL:|;;| "Searches the property list stored in Place for an indicator EQ to Indicator. If one is found, the corresponding value is returned, else the Default is returned.") (DO ((PLIST PLACE (CDDR PLIST))) ((NULL PLIST) DEFAULT) (WHEN (EQ (CAR PLIST) INDICATOR) (IF (NOT (CONSP (CDR PLIST))) (ERROR "Malformed property list: ~s" PLACE) (RETURN (CADR PLIST)))))) (DEFUN GET-PROPERTIES (PLACE INDICATOR-LIST) (DO ((PLIST PLACE (CDDR PLIST))) ((NULL PLIST) (VALUES NIL NIL NIL)) (WHEN (MEMBER (CAR PLIST) INDICATOR-LIST :TEST (FUNCTION EQ)) (IF (NOT (CONSP (CDR PLIST))) (ERROR "Malformed p-list: ~s" PLACE) (RETURN (VALUES (CAR PLIST) (CADR PLIST) PLIST)))))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) ) (DEFUN FBOUNDP (FN) (OR (AND (SYMBOLP FN) (OR (IL:ARGTYPE FN) (MACRO-FUNCTION FN) (SPECIAL-FORM-P FN)) T) (AND (CL::SETF-NAME-P FN) (GET (CADR FN) :SETF-DEFUN) T))) (DEFUN FMAKUNBOUND (SYMBOL) (IL:* IL:|;;| "Has lots of special knowledge of prop list names") (SETF (SYMBOL-FUNCTION SYMBOL) NIL) (SETF (MACRO-FUNCTION SYMBOL) NIL) (REMPROP SYMBOL (QUOTE IL:SPECIAL-FORM)) (REMPROP SYMBOL (QUOTE IL:CODE)) (REMPROP SYMBOL (QUOTE IL:EXPR)) (LET ((CL::SETF-DEFUN (GET SYMBOL :SETF-DEFUN))) (WHEN CL::SETF-DEFUN (SETF (SYMBOL-FUNCTION CL::SETF-DEFUN) NIL) (REMPROP SYMBOL :SETF-DEFUN))) SYMBOL) (DEFUN SYMBOL-FUNCTION (SYMBOL &AUX (DEF (IL:GETD SYMBOL))) (IL:* IL:|;;| "this function is preformance-critical, as it is used in the compilation of #'FOO => (CL:SYMBOL-FUNCTION 'FOO). Thus, this definition checks for the GETD definition first. It might even be reasonable to open-code the GETD here. It *is* unreasonable to call MACRO-FUNCTION and SPECIAL-FORM-P first.") (COND (DEF) (IL:* IL:\; "GETD returned non-NIL") ((SETQ DEF (MACRO-FUNCTION SYMBOL)) (IL:* IL:\; "Return something representing the macro's implementation.") (CONS (QUOTE :MACRO) DEF)) ((SETQ DEF (SPECIAL-FORM-P SYMBOL)) (IL:* IL:\; "Return something representing the special-form's implementation.") (CONS (QUOTE :SPECIAL-FORM) DEF)) (T (ERROR (QUOTE XCL:UNDEFINED-FUNCTION) :NAME SYMBOL)))) (DEFUN CL:FDEFINITION (CL::FUNCTION-NAME) (IL:* IL:|;;| "CLtL2 doesn't say whether the result of (FDEFINITION '(SETF FOO)) should be executable or not. I vote yes with this code - JRB") (COND ((CL::SETF-NAME-P CL::FUNCTION-NAME) (LET ((CL::SETF-NAME (GET (CADR CL::FUNCTION-NAME) :SETF-DEFUN))) (IF CL::SETF-NAME (SYMBOL-FUNCTION CL::SETF-NAME) (ERROR (QUOTE XCL:UNDEFINED-FUNCTION) :NAME CL::FUNCTION-NAME)))) ((SYMBOLP CL::FUNCTION-NAME) (SYMBOL-FUNCTION CL::FUNCTION-NAME)) (T (ERROR "~s cannot name an FDEFINITION" CL::FUNCTION-NAME)))) (DEFUN IL:SETF-SYMBOL-FUNCTION (SYMBOL DEFINITION) (IL:* IL:|;;| "NOTE: If you change this, be sure to change the undoable version on CMLUNDO!") (IL:* IL:|;;| " inverse of SYMBOL-FUNCTION") (IL:VIRGINFN SYMBOL T) (COND ((CONSP DEFINITION) (IL:* IL:|;;| "Either it's a LAMBDA form or one of the special lists put together by SYMBOL-FUNCTION for macros and special forms.") (CASE (CAR DEFINITION) (:MACRO (SETF (MACRO-FUNCTION SYMBOL) (CDR DEFINITION))) (:SPECIAL-FORM (SETF (GET SYMBOL (QUOTE IL:SPECIAL-FORM)) (CDR DEFINITION))) (T (IL:PUTD SYMBOL DEFINITION T)))) (IL:* IL:|;;| "If it's (SETF (SYMBOL-FUNCTION 'FOO) 'BAR) then we give FOO the same definition as BAR. This isn't quite like Lucid and Symbolics, but it will do for now.") ((AND (SYMBOLP DEFINITION) (NOT (NULL DEFINITION))) (IL:PUTD SYMBOL (IL:GETD DEFINITION) T)) (IL:* IL:|;;| "It's probably a compiled-code object or an interpreted closure. In any case, go ahead and put it in there; if it's illegal, we'll find out when we try to apply it.") (T (IL:PUTD SYMBOL DEFINITION T))) (IL:* IL:|;;| "(SETF (SYMBOL-FUNCTION ...) ...) is supposed to remove macro definitions. We only remove the ones that could come from DEFMACRO.") (UNLESS (OR (NULL DEFINITION) (AND (CONSP DEFINITION) (EQ (CAR DEFINITION) :MACRO))) (REMPROP SYMBOL (QUOTE IL:MACRO-FN))) DEFINITION) (DEFUN CL::SET-FDEFINITION (CL::FUNCTION-NAME CL::NEWVALUE) (IL:* IL:|;;| "If you change this, be sure to change the undoable version on CMLUNDO.") (IF (CL::SETF-NAME-P CL::FUNCTION-NAME) (LET* ((CL::REAL-NAME (SECOND CL::FUNCTION-NAME)) (CL::DEFUN-SETF-NAME (XCL::DEFUN-SETF-NAME CL::REAL-NAME))) (IL:* IL:|;;| "We smash the SYMBOL-FUNCTION of DEFUN-SETF-NAME rather than just changing the :SETF-DEFUN property to insure the SETF function's having a consistent name") (SETF (GET CL::REAL-NAME :SETF-DEFUN) CL::DEFUN-SETF-NAME) (SETF (SYMBOL-FUNCTION CL::DEFUN-SETF-NAME) CL::NEWVALUE)) (IL:SETF-SYMBOL-FUNCTION CL::FUNCTION-NAME CL::NEWVALUE)) CL::NEWVALUE) (XCL:DEFOPTIMIZER CL:FDEFINITION (CL::FUNCTION-NAME) (IF (AND (CONSTANTP CL::FUNCTION-NAME) (SYMBOLP (EVAL CL::FUNCTION-NAME))) (IL:BQUOTE (SYMBOL-FUNCTION (IL:\\\, CL::FUNCTION-NAME))) (QUOTE COMPILER:PASS))) (IL:* IL:|;;| "GENSYM Code") (DEFVAR *GENSYM-COUNTER* 0) (DEFVAR *GENSYM-PREFIX* "G") (DEFVAR *GENTEMP-COUNTER* 0) (DEFUN GENSYM (&OPTIONAL (X NIL X-P)) (IF X-P (ETYPECASE X (STRING (SETQ *GENSYM-PREFIX* X)) (INTEGER (SETQ *GENSYM-COUNTER* X)))) (PROG1 (MAKE-SYMBOL (CONCATENATE (QUOTE STRING) *GENSYM-PREFIX* (IL:MKSTRING *GENSYM-COUNTER*))) (SETQ *GENSYM-COUNTER* (1+ *GENSYM-COUNTER*)))) (DEFUN GENTEMP (&OPTIONAL (PREFIX "T") (PACKAGE *PACKAGE*)) (IL:* IL:|;;| "*gentemp-counter* holds a good guess for the suffix ") (LET ((COUNTER *GENTEMP-COUNTER*) NAMESTRING) (IL:* IL:\; "Use IL:MKSTRING rather than princ-to-string, since princ-to-string occurs late in the loadup") (LOOP (SETQ NAMESTRING (CONCATENATE (QUOTE STRING) PREFIX (IL:MKSTRING COUNTER))) (WHEN (NULL (FIND-SYMBOL NAMESTRING PACKAGE)) (SETQ *GENTEMP-COUNTER* (1+ COUNTER)) (RETURN (INTERN NAMESTRING PACKAGE))) (SETQ COUNTER (1+ COUNTER))))) (DEFUN COPY-SYMBOL (SYM &OPTIONAL COPY-PROPS) (LET ((NEW-SYM (MAKE-SYMBOL (SYMBOL-NAME SYM)))) (WHEN COPY-PROPS (IF (BOUNDP SYM) (SETF (SYMBOL-VALUE NEW-SYM) (SYMBOL-VALUE SYM))) (IF (FBOUNDP SYM) (SETF (SYMBOL-FUNCTION NEW-SYM) (SYMBOL-FUNCTION SYM))) (SETF (SYMBOL-PLIST NEW-SYM) (COPY-LIST (SYMBOL-PLIST SYM)))) NEW-SYM)) (DEFUN IL:MAKE-KEYWORD (SYMBOL) (DECLARE (SPECIAL IL:*KEYWORD-PACKAGE*)) (VALUES (INTERN (SYMBOL-NAME SYMBOL) IL:*KEYWORD-PACKAGE*))) (DEFUN KEYWORDP (OBJECT) (AND (SYMBOLP OBJECT) (EQ (SYMBOL-PACKAGE OBJECT) IL:*KEYWORD-PACKAGE*))) (IL:PUTPROPS IL:LLSYMBOL IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:LLSYMBOL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:PUTPROPS IL:LLSYMBOL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP