(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