(FILECREATED "24-Jan-86 13:05:54" {ERIS}<LISPCORE>LIBRARY>CMLSYMBOL.;6 5517
changes to: (VARS CMLSYMBOLCOMS)
previous date: "19-Dec-85 03:54:10" {ERIS}<LISPCORE>LIBRARY>CMLSYMBOL.;5)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSYMBOLCOMS)
(RPAQQ CMLSYMBOLCOMS [(* * CMLSYMBOL -- Covers parts of Chapters 7.0 and 10.0 *)
(* * SET BOUNDP REMPROP GENSYM already in Interlisp. GENSYM needs a little work
to be faithfully implemented. SYMBOL-PACKAGE COPY-SYMBOL GENTEMP KEYWORDP
use packages and are not faithfully implemented. GET doesn't currently
handle defaults correctly. *)
(INITVARS (GENSYM-PREFIX "G")
(GENSYM-COUNTER 0))
(FNS MAKUNBOUND FMAKUNBOUND FBOUNDP GET GETF GET-PROPERTIES COPY-SYMBOL
KEYWORDP)
(P (MOVD (QUOTE EVALV)
(QUOTE SYMBOL-VALUE))
(MOVD (QUOTE GETD)
(QUOTE SYMBOL-FUNCTION))
(MOVD (QUOTE GETPROPLIST)
(QUOTE SYMBOL-PLIST))
(MOVD (QUOTE MKSTRING)
(QUOTE SYMBOL-NAME))
(MOVD (QUOTE NILL)
(QUOTE SYMBOL-PACKAGE))
(MOVD (QUOTE MKATOM)
(QUOTE MAKE-SYMBOL))
(MOVD (QUOTE GENSYM)
(QUOTE GENTEMP)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA COPY-SYMBOL])
(* * CMLSYMBOL -- Covers parts of Chapters 7.0 and 10.0 *)
(* * SET BOUNDP REMPROP GENSYM already in Interlisp. GENSYM needs a little work to be
faithfully implemented. SYMBOL-PACKAGE COPY-SYMBOL GENTEMP KEYWORDP use packages and are not
faithfully implemented. GET doesn't currently handle defaults correctly. *)
(RPAQ? GENSYM-PREFIX "G")
(RPAQ? GENSYM-COUNTER 0)
(DEFINEQ
(MAKUNBOUND
[LAMBDA (VARIABLE) (* kbr: "29-Aug-85 15:49")
(SET VARIABLE (QUOTE NOBIND])
(FMAKUNBOUND
[LAMBDA (VARIABLE) (* kbr: "29-Aug-85 15:50")
(PUTD VARIABLE NIL])
(FBOUNDP
[LAMBDA (VARIABLE) (* kbr: "29-Aug-85 15:56")
(NOT (NULL (GETD VARIABLE])
(GET
[LAMBDA (SYMBOL INDICATOR DEFAULT) (* kbr: "29-Aug-85 16:04")
(* Look on the property list of SYMBOL for the
specified INDICATOR. If this is found, return the
associated value, else return DEFAULT.
*)
(OR (GETPROP SYMBOL INDICATOR)
DEFAULT])
(GETF
[LAMBDA (PLACE INDICATOR DEFAULT) (* kbr: "29-Aug-85 16:06")
(* 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. *)
(OR (LISTGET PLACE INDICATOR)
DEFAULT])
(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])
(COPY-SYMBOL
(CL:LAMBDA (SYMBOL &OPTIONAL (COPY-PROPS NIL)
&AUX NEW-SYMBOL) (* kbr: "29-Aug-85 17:11")
(SETQ NEW-SYMBOL (GENSYM SYMBOL))
[COND
(COPY-PROPS (SETPROPLIST NEW-SYMBOL (COPY-LIST (SYMBOL-PLIST SYMBOL]
NEW-SYMBOL))
(KEYWORDP
[LAMBDA (SYMBOL) (* kbr: "29-Aug-85 16:21")
(* Returns T if the Symbol belongs to the Keyword
package, Nil otherwise. *)
(* NOTE: KEYWORDP uses packages.
This implementation is not strictly correct.
*)
(EQ (CHCON1 SYMBOL)
(CHARCODE :])
)
(MOVD (QUOTE EVALV)
(QUOTE SYMBOL-VALUE))
(MOVD (QUOTE GETD)
(QUOTE SYMBOL-FUNCTION))
(MOVD (QUOTE GETPROPLIST)
(QUOTE SYMBOL-PLIST))
(MOVD (QUOTE MKSTRING)
(QUOTE SYMBOL-NAME))
(MOVD (QUOTE NILL)
(QUOTE SYMBOL-PACKAGE))
(MOVD (QUOTE MKATOM)
(QUOTE MAKE-SYMBOL))
(MOVD (QUOTE GENSYM)
(QUOTE GENTEMP))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA COPY-SYMBOL)
)
(PUTPROPS CMLSYMBOL COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2273 4958 (MAKUNBOUND 2283 . 2432) (FMAKUNBOUND 2434 . 2571) (FBOUNDP 2573 . 2721) (GET
2723 . 3133) (GETF 3135 . 3483) (GET-PROPERTIES 3485 . 4147) (COPY-SYMBOL 4149 . 4455) (KEYWORDP 4457
. 4956)))))
STOP