(FILECREATED "22-Aug-86 17:52:04" {ERIS}<LISPCORE>LIBRARY>CMLSYMBOL.;25 14798
changes to: (VARS CMLSYMBOLCOMS)
(FUNCTIONS CL:GENSYM CL:MAKE-KEYWORD CL:GENTEMP)
previous date: "15-Aug-86 15:32:24" {ERIS}<LISPCORE>LIBRARY>CMLSYMBOL.;24)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSYMBOLCOMS)
(RPAQQ CMLSYMBOLCOMS ((* ;; "Bogus definitions needed until packages are in the loadup. DO NOT FORGET to remove the advice on COMP.USERFN in the BYTECOMPILER."
)
(FNS MAKE-SYMBOL COPY-SYMBOL INTERN MAKE-KEYWORD GENTEMP KEYWORDP DWIMKEYWORD)
(DECLARE: DONTEVAL@LOAD DOCOPY (ADDVARS (DWIMUSERFORMS (DWIMKEYWORD))))
(VARS CMLTRANSLATED)
(FNS CMLTRANSLATE)
(* ;; "%"Symbol functions. SET BOUNDP REMPROP are already in Interlisp%"")
(FNS MAKUNBOUND SYMBOL-NAME SYMBOL-VALUE GET GETF GET-PROPERTIES)
(PROP DMACRO GET GETF SYMBOL-PLIST)
(P (MOVD (QUOTE GETPROPLIST)
(QUOTE SYMBOL-PLIST)))
(SETFS GET SYMBOL-PLIST SYMBOL-VALUE SYMBOL-FUNCTION)
(FNS FBOUNDP FMAKUNBOUND SYMBOL-FUNCTION SETF-SYMBOL-FUNCTION)
(INITVARS (*GENSYM-COUNTER* 0)
(*GENSYM-PREFIX* "G"))
(FUNCTIONS CL:COPY-SYMBOL CL:GENSYM CL:MAKE-KEYWORD CL:GENTEMP CL:KEYWORDP)
(PROP FILETYPE CMLSYMBOL)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA GETF GET GENTEMP INTERN COPY-SYMBOL MAKE-SYMBOL)))))
(* ;;
"Bogus definitions needed until packages are in the loadup. DO NOT FORGET to remove the advice on COMP.USERFN in the BYTECOMPILER."
)
(DEFINEQ
(MAKE-SYMBOL
(CL:LAMBDA (NAME) (* raf " 8-Aug-86 12:19")
(COND
((STRINGP NAME)
(GENSYM NAME))
(T (GENSYM (CONCATENATE (QUOTE STRING)
NAME))))))
(COPY-SYMBOL
(CL:LAMBDA (SYMBOL &OPTIONAL COPY-PROPS) (* raf " 8-Aug-86 12:19")
(LET ((NEW-SYMBOL (GENSYM SYMBOL)))
(COND
(COPY-PROPS (SETPROPLIST NEW-SYMBOL (COPY-LIST (SYMBOL-PLIST SYMBOL)))))
NEW-SYMBOL)))
(INTERN
(CL:LAMBDA (STRING &OPTIONAL (PACKAGE (QUOTE PCL))) (* raf " 8-Aug-86 12:19")
(ECASE PACKAGE (KEYWORD (COND
((KEYWORDP STRING)
(SET (PACK* STRING)
(PACK* STRING)))
(T (SET (PACK* (QUOTE :)
STRING)
(PACK* (QUOTE :)
STRING)))))
((NIL PCL)
(PACK* STRING)))))
(MAKE-KEYWORD
(LAMBDA (X) (* raf " 8-Aug-86 12:20")
(* * "Same as (INTERN (SYMBOL-NAME X) *KEYWORD-PACKAGE*)")
(COND
((NEQ (CHCON1 X)
(CHARCODE ":"))
(SETQ X (PACK* ":" (COND
((AND (EQ (NTHCHARCODE X 3)
(CHARCODE ":"))
(OR (STRPOS "CL" X 1 NIL T)
(STRPOS "IL" X 1 NIL T)))
(* "Remove fake package prefix")
(SUBSTRING X 4))
(T X))))))
(SET X X)))
(GENTEMP
(CL:LAMBDA (&OPTIONAL PREFIX PACKAGE) (* raf " 8-Aug-86 12:35")
(GENSYM PREFIX NIL NIL T)))
(KEYWORDP
(LAMBDA (X) (* raf " 7-Aug-86 18:04")
(EQ (NTHCHARCODE X 1)
(CHARCODE ":"))))
(DWIMKEYWORD
(LAMBDA NIL (* raf " 7-Aug-86 18:04")
(AND (NULL FAULTAPPLYFLG)
(LITATOM FAULTX)
(EQ (NTHCHARCODE FAULTX 1)
(CHARCODE ":"))
(MAKE-KEYWORD FAULTX))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(ADDTOVAR DWIMUSERFORMS (DWIMKEYWORD))
)
(RPAQQ CMLTRANSLATED
(APPEND APPLY ARRAYP ASSERT ASSOC ATAN ATOM BLOCK BREAK CHARACTER COERCE COLLECT COMPILE COS
COUNT DELETE DO DO* ELT EQUAL ERROR EVAL EVALHOOK EVERY EXPT FINALLY FIND FIRST FLOOR
FUNCTION GCD GETHASH IF INITIALLY INTERSECTION JOIN LAMBDA LDIFF LENGTH LISTP LOG MAP
MAPC MAPC MAPCAR MAPCON MAPHASH MAPLIST MEMBER MERGE MOD NOTANY NOTEVERY NREVERSE NTH
POP POSITION PRIN1 PRINT PUSH PUSHNEW PUTHASH READ REMOVE REPLACE REVERSE SETQ SIN SOME
SORT SQRT STREAMP STRINGP SUBLIS SUBST SUM TAN TERPRI UNION UNLESS UNTIL WHEN ZEROP *))
(DEFINEQ
(CMLTRANSLATE
(LAMBDA (X) (* raf " 7-Aug-86 18:06")
(* "Pavel" " 8-May-86 17:25")
(COND
((LITATOM X)
(COND
((FMEMB X CMLTRANSLATED)
(PACK* "CL:" X))
((STRPOS "IL:" X 1 NIL T)
(SUBATOM X 4 NIL))
(T X)))
((LISTP X)
(WALK-RECONS X (CMLTRANSLATE (CAR X))
(CMLTRANSLATE (CDR X))))
(T X))))
)
(* ;; "%"Symbol functions. SET BOUNDP REMPROP are already in Interlisp%"")
(DEFINEQ
(MAKUNBOUND
(LAMBDA (SYMBOL) (* bvm: "25-Apr-86 16:08")
(* * Really should make it have no value at all --
need to have an "unbound" dynamic value)
(SET SYMBOL (QUOTE NOBIND))))
(SYMBOL-NAME
(LAMBDA (SYMBOL) (* bvm: " 9-May-86 22:58")
(MKSTRING (\DTEST SYMBOL (QUOTE LITATOM)))))
(SYMBOL-VALUE
(LAMBDA (SYMBOL) (* bvm: "25-Apr-86 15:59")
(* * Like EVALV, but must give error if unbound -
uses fact that \eval has an opcode which hooks into free variable microcode)
(\EVAL (\DTEST SYMBOL (QUOTE LITATOM)))))
(GET
(CL:LAMBDA (SYMBOL INDICATOR &OPTIONAL (DEFAULT NIL)) (* lmm "20-Mar-86 16:35")
(* Look on the property list of SYMBOL
for the specified INDICATOR.
If this is found, return the
associated value, else return DEFAULT.
*)
(GETF (GETPROPLIST SYMBOL)
INDICATOR DEFAULT)))
(GETF
(CL:LAMBDA (PLACE INDICATOR &OPTIONAL (DEFAULT NIL))
"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."
(CL:DO ((PLIST PLACE (CDDR PLIST)))
((NULL PLIST)
DEFAULT)
(COND
((CL:ATOM (CDR PLIST))
(CL:ERROR "~S is a malformed property list." PLACE))
((EQ (CAR PLIST)
INDICATOR)
(RETURN (CADR PLIST)))))))
(GET-PROPERTIES
(LAMBDA (PLACE INDICATOR-LIST) (* kbr: "29-Aug-85 16:08")
(* Like GETF, except that Indicator-List is a list of indicators which will be
looked for in the property list stored in Place.
Three values are returned, see manual for details.
*)
(CL:DO ((PLIST PLACE (CDDR PLIST)))
((NULL PLIST)
(VALUES NIL NIL NIL))
(COND
((CL:ATOM (CDR PLIST))
(CL:ERROR "~S is a malformed proprty list." PLACE))
((MEMQ (CAR PLIST)
INDICATOR-LIST)
(RETURN (VALUES (CAR PLIST)
(CADR PLIST)
PLIST)))))))
)
(PUTPROPS GET DMACRO (DEFMACRO (SYMBOL INDICATOR &REST TAIL) (BQUOTE (GETF (SYMBOL-PLIST (\, SYMBOL))
(\, INDICATOR)
(\,@ TAIL))) )
)
(PUTPROPS GETF DMACRO (DEFMACRO (PLACE INDICATOR &OPTIONAL DEFAULT) (COND (DEFAULT (QUOTE IGNOREMACRO
))
(T (LIST (QUOTE LISTGET)
PLACE INDICATOR)))
)
)
(PUTPROPS SYMBOL-PLIST DMACRO (= . GETPROPLIST))
(MOVD (QUOTE GETPROPLIST)
(QUOTE SYMBOL-PLIST))
(DEFINE-SETF-METHOD GET (SYMBOL PROP &OPTIONAL DEFAULT) "Get turns into %%put. Don't put in the default unless it really is supplied and
non-nil, so that we can transform into the get instruction whenever possible."
(LET ((SYMBOL-TEMP (GENSYM))
(PROP-TEMP (GENSYM))
(DEF-TEMP (GENSYM))
(NEWVAL (GENSYM)))
(VALUES (BQUOTE ((\, SYMBOL-TEMP)
(\, PROP-TEMP)
(\,@ (COND
(DEFAULT (BQUOTE ((\, DEF-TEMP))))))))
(BQUOTE ((\, SYMBOL)
(\, PROP)
(\,@ (COND
(DEFAULT (BQUOTE ((\, DEFAULT))))))))
(LIST NEWVAL)
(BQUOTE (PUTPROP (\, SYMBOL-TEMP)
(\, PROP-TEMP)
(\, NEWVAL)))
(BQUOTE (GET (\, SYMBOL-TEMP)
(\, PROP-TEMP)
(\,@ (COND
(DEFAULT (BQUOTE ((\, DEF-TEMP)))))))))))
(DEFSETF SYMBOL-PLIST SETPROPLIST)
(DEFSETF SYMBOL-VALUE SET)
(DEFSETF SYMBOL-FUNCTION SETF-SYMBOL-FUNCTION)
(DEFINEQ
(FBOUNDP
(LAMBDA (FN) (* lmm "25-Apr-86 16:50")
(AND (SYMBOLP FN)
(OR (SPECIAL-FORM-P FN)
(ARGTYPE FN)
(MACRO-FUNCTION FN))
T)))
(FMAKUNBOUND
(LAMBDA (SYMBOL) (* bvm: "25-Apr-86 16:07")
(PUTD SYMBOL NIL)))
(SYMBOL-FUNCTION
(LAMBDA (FN) (* lmm "29-Apr-86 14:47")
(OR (AND (SYMBOLP FN)
(NOT (SPECIAL-FORM-P FN))
(FMEMB (ARGTYPE FN)
(QUOTE (0 2)))
(GETD FN))
(LISPERROR "UNDEFINED FUNCTION" FN))))
(SETF-SYMBOL-FUNCTION
(LAMBDA (FN VAL) (* lmm "28-May-86 22:27")
(PUTD FN (if (CCODEP VAL)
then VAL elseif (EXPRP VAL)
then VAL elseif (LITATOM VAL)
then
(GETD VAL)
else VAL)
T)))
)
(RPAQ? *GENSYM-COUNTER* 0)
(RPAQ? *GENSYM-PREFIX* "G")
(DEFUN CL:COPY-SYMBOL (SYM &OPTIONAL COPY-PROPS) (CHECK-TYPE SYM SYMBOL)
(LET ((NEWSYM (MAKE-SYMBOL (SYMBOL-NAME SYM))))
(COND
(COPY-PROPS (SETF (SYMBOL-VALUE NEWSYM)
(SYMBOL-VALUE SYM))
(SETF (SYMBOL-FUNCTION NEWSYM)
(SYMBOL-FUNCTION SYM))
(SETF (SYMBOL-PLIST NEWSYM)
(COPY (SYMBOL-PLIST SYM)))))
NEWSYM))
(DEFUN CL:GENSYM (&OPTIONAL X) (DECLARE (SPECIAL *GENSYM-COUNTER* *GENSYM-PREFIX*))
(CHECK-TYPE X (OR NULL STRING (INTEGER 0 CL:*)))
(TYPECASE X (STRING (SETF *GENSYM-PREFIX* X))
(INTEGER (SETF *GENSYM-COUNTER* X)))
(PROG1 (CL:MAKE-SYMBOL (CONCATENATE (QUOTE SIMPLE-STRING)
*GENSYM-PREFIX*
(MKSTRING *GENSYM-COUNTER*)))
(INCF *GENSYM-COUNTER*)))
(DEFUN CL:MAKE-KEYWORD (SYMBOL) (DECLARE (SPECIAL *KEYWORD-PACKAGE*))
(CL:INTERN (SYMBOL-NAME SYMBOL)
*KEYWORD-PACKAGE*))
(DEFUN CL:GENTEMP (&OPTIONAL (PREFIX "T")
(PACKAGE *PACKAGE*)) (CHECK-TYPE PREFIX STRING)
(CHECK-TYPE PACKAGE PACKAGE)
(CL:DO ((COUNTER 0 (1+ COUNTER))
(NAMESTRING (CONCATENATE (QUOTE SIMPLE-STRING)
PREFIX
(MKSTRING COUNTER))))
((NULL (FIND-SYMBOL NAMESTRING PACKAGE))
(CL:INTERN NAMESTRING PACKAGE))))
(DEFUN CL:KEYWORDP (OBJECT) (AND (SYMBOLP OBJECT)
(EQ (SYMBOL-PACKAGE OBJECT)
*KEYWORD-PACKAGE*)))
(PUTPROPS CMLSYMBOL FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA GETF GET GENTEMP INTERN COPY-SYMBOL MAKE-SYMBOL)
)
(PUTPROPS CMLSYMBOL COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2028 4569 (MAKE-SYMBOL 2038 . 2312) (COPY-SYMBOL 2314 . 2608) (INTERN 2610 . 3245) (
MAKE-KEYWORD 3247 . 3987) (GENTEMP 3989 . 4133) (KEYWORDP 4135 . 4295) (DWIMKEYWORD 4297 . 4567)) (
5284 5831 (CMLTRANSLATE 5294 . 5829)) (5916 8728 (MAKUNBOUND 5926 . 6203) (SYMBOL-NAME 6205 . 6366) (
SYMBOL-VALUE 6368 . 6694) (GET 6696 . 7341) (GETF 7343 . 7939) (GET-PROPERTIES 7941 . 8726)) (10768
11811 (FBOUNDP 10778 . 11014) (FMAKUNBOUND 11016 . 11152) (SYMBOL-FUNCTION 11154 . 11473) (
SETF-SYMBOL-FUNCTION 11475 . 11809)))))
STOP