Google
 

Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/symbol.clisp
There are no other files named symbol.clisp in the archive.
;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

;;; Symbol manipulating functions for Spice Lisp.

;;; Written by Scott Fahlman.
;;; Hacked on and maintained by Skef Wholey.

;;; Many of these are trivial interpreter entries to functions
;;; open-coded by the compiler.

;;; **********************************************************************

(in-package 'lisp)

(export '(getf get-properties copy-symbol samenamep))

;20; most of this file is in the kernel

(defun getf (place indicator &optional (default ()))
  "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)
    (cond ((atom (cdr plist))
	   (error "~S is a malformed property list."
		  place))
	  ((eq (car plist) indicator)
	   (return (cadr plist))))))


(defun get-properties (place indicator-list)
  "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."
  (do ((plist place (cddr plist)))
      ((null plist) (values nil nil nil))
    (cond ((atom (cdr plist))
	   (error "~S is a malformed proprty list."
		  place))
	  ((memq (car plist) indicator-list)
	   (return (values (car plist) (cadr plist) plist))))))

(defun samenamep (sym1 sym2)
  "Returns T if the two symbols have equal print names.  Case is
  distinguished by this predicate."
  (string= (symbol-name sym1) (symbol-name sym2)))

(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
  "Make and return a new uninterned symbol with the same print name
  as SYMBOL.  If COPY-PROPS is null, the new symbol has no properties.
  Else, it has a copy of SYMBOL's property list."
  (setq new-symbol (make-symbol (symbol-name symbol)))
  (if copy-props
      (%set-plist new-symbol (copy-list (symbol-plist symbol))))
  new-symbol)