(FILECREATED " 1-Oct-86 11:42:09" {ERIS}<LISPCORE>SOURCES>CMLDEFFER.;14 16659
changes to: (FUNCTIONS DEF-DEFINE-TYPE)
(VARIABLES *DEFINITION-HASH-TABLE*)
previous date: " 1-Oct-86 01:47:11" {ERIS}<LISPCORE>SOURCES>CMLDEFFER.;12)
(* "
Copyright (c) 1986, 1900 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLDEFFERCOMS)
(RPAQQ CMLDEFFERCOMS ((* ;;;
"DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities."
)
(* ;; "BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!! It is heavily self-referential and thick with bootstrapping problems. All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water... You have been warned."
)
(COMS (INITVARS (FILEPKGFLG))
(COMS (FNS PPRINT-DEFINER \DEFINE-TYPE-GETDEF REMOVE-COMMENTS)
(FUNCTIONS \DEFINE-TYPE-SAVE-DEFN)))
(VARIABLES *DEFINITION-HASH-TABLE*)
(DEFINE-TYPES DEFINE-TYPES FUNCTIONS VARIABLES)
(FUNCTIONS DEFDEFINER DEF-DEFINE-TYPE WITHOUT-FILEPKG)
(FUNCTIONS DEFUN DEFINLINE DEFMACRO)
(FUNCTIONS DEFVAR DEFPARAMETER DEFCONSTANT DEFGLOBALVAR DEFGLOBALPARAMETER)
(* ;; "Don't note file package changes to macro-fn.")
(PROP PROPTYPE MACRO-FN)
(* ;; "Arrange for the correct compiler to be used.")
(PROP FILETYPE CMLDEFFER)))
(* ;;;
"DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities."
)
(* ;;
"BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!! It is heavily self-referential and thick with bootstrapping problems. All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water... You have been warned."
)
(RPAQ? FILEPKGFLG )
(DEFINEQ
(PPRINT-DEFINER
(LAMBDA (DEFINE-EXPRESSION) (* lmm "24-May-86 15:10")
(LET ((DEFINER (pop DEFINE-EXPRESSION))
(DEFINED (pop DEFINE-EXPRESSION))
(CURRENT (DSPXPOSITION))
(#RPARS))
(DECLARE (SPECVARS #RPARS))
(PRINTOUT NIL "(" .P2 DEFINER ,)
(if (LISTP DEFINED)
then
(PRINTOUT NIL "(" .FONT PRETTYCOMFONT .P2 (CAR DEFINED)
.FONT DEFAULTFONT , # (PRINTDEF (CDR DEFINED)
T T T)
")")
else
(PRINTOUT NIL .FONT PRETTYCOMFONT .P2 DEFINED .FONT DEFAULTFONT))
(if (LISTP (CAR DEFINE-EXPRESSION))
then
(SPACES 1)
(PRINTDEF (pop DEFINE-EXPRESSION)
T NIL))
(if (OR (STRINGP (CAR DEFINE-EXPRESSION))
(EQ (CAR (LISTP (CAR DEFINE-EXPRESSION)))
COMMENTFLG))
then
(SPACES 1)
(PRINTDEF (pop DEFINE-EXPRESSION)
T T))
(if (NOT (FITP DEFINE-EXPRESSION T T))
then
(TERPRI)
(DSPXPOSITION CURRENT)
(SPACES 3)
else
(SPACES 1))
(PROGN (PRINTDEF DEFINE-EXPRESSION T T T)
(PRIN1 ")" NIL)
(TERPRI NIL)))))
(\DEFINE-TYPE-GETDEF
(LAMBDA (NAME TYPE OPTIONS) (* Pavel " 1-Oct-86 01:18")
(* ;; "GETDEF method for all definers. The EDIT is so that when you say EDITDEF you get a copy & can know when you made edits.")
(* ;;
"The GET can be removed when we're sure that no more property-list DEFINERS remain in the system.")
(LET* ((HASH-TABLE (CL:GETHASH TYPE *DEFINITION-HASH-TABLE*))
(DEFN (OR (AND HASH-TABLE (CL:GETHASH NAME HASH-TABLE))
(AND (SYMBOLP NAME)
(GET NAME TYPE)))))
(CL:IF (EQMEMB (QUOTE EDIT)
OPTIONS)
(COPY DEFN)
DEFN))))
(REMOVE-COMMENTS
(LAMBDA (X) (* lmm " 8-AUG-83 23:26")
(COND
((NLISTP X)
X)
((EQ (CAR (LISTP (CAR X)))
COMMENTFLG)
(REMOVE-COMMENTS (CDR X)))
(T (PROG ((A (REMOVE-COMMENTS (CAR X)))
(D (REMOVE-COMMENTS (CDR X))))
(RETURN (COND
((AND (EQ A (CAR X))
(EQ D (CDR X)))
X)
(T (CONS A D)))))))))
)
(DEFUN \DEFINE-TYPE-SAVE-DEFN (NAME TYPE DEFINITION)
(* ;;
"The REMPROP can be removed once we're sure that no more property-list definers are left.")
(REMPROP NAME TYPE)
(LET ((HASH-TABLE (CL:GETHASH TYPE *DEFINITION-HASH-TABLE*)))
(CL:WHEN (NULL HASH-TABLE)
(CL:ERROR "\DEFINE-TYPE-PUTDEF: Can't find hash table for type ~S" TYPE))
(SETF (CL:GETHASH NAME HASH-TABLE)
DEFINITION))
(MARKASCHANGED NAME TYPE (QUOTE CHANGED)))
(DEFGLOBALVAR *DEFINITION-HASH-TABLE* (* ;;; "This is the repository for all DEFDEFINERs' definitions. It is a two-level hash-table. The first level hashes on the name of the type of the definition, using an EQ test. Each type maps to another hash-table that, in turn, maps the names of items into their definitions. The second-level hash-tables use an EQUAL test so as to allow non-atomic ``names''."
) (* ;;
"HASHARRAY is used here instead of MAKE-HASH-ARRAY because it's earlier in the loadup...")
(HASHARRAY 20))
(DEF-DEFINE-TYPE DEFINE-TYPES "Common Lisp definition type" )
(DEF-DEFINE-TYPE FUNCTIONS "Common Lisp functions" )
(DEF-DEFINE-TYPE VARIABLES "Common Lisp variables" )
(DEFDEFINER DEFDEFINER
FUNCTIONS
(NAME TYPE ARGLIST &BODY BODY)
(BQUOTE (PROGN (DEFMACRO (\, NAME) (&WHOLE %%ORIGINAL-DEFINITION (\,@ ARGLIST))
(BQUOTE (PROGN (WITHOUT-FILEPKG (\, (PROGN (\,@ BODY))))
(EVAL-WHEN (CL:EVAL)
(AND FILEPKGFLG (\DEFINE-TYPE-SAVE-DEFN
(QUOTE (\, NAME))
(QUOTE (\, (QUOTE (\, TYPE))))
(QUOTE (\, %%ORIGINAL-DEFINITION)))))
(QUOTE (\, NAME)))))
(WITHOUT-FILEPKG (ADDTOVAR PRETTYPRINTMACROS ((\, NAME) . PPRINT-DEFINER)))
(QUOTE (\, NAME)))))
(DEFDEFINER DEF-DEFINE-TYPE
DEFINE-TYPES (NAME DESCRIPTION) (* ;; "This definition is a hokey way of defining a file package type that works even before the file package is loaded.")
(* ;; "The PROPTYPE form at the end can be removed when we are sure that no more property-list DEFINER's still exist.")
(* ;; "The quoted keywords in the call to make-hash-table are there because unquoted keywords don't work that early in the loadup. That can be removed when packages are in for good.")
(BQUOTE (PROGN (ADDTOVAR PRETTYDEFMACROS
((\, NAME)
X
(P * (MAPCAR (QUOTE X)
(FUNCTION (LAMBDA (ITEM)
(CL:DO ((DEF (GETDEF ITEM (QUOTE (\, NAME))))
)
(DEF DEF)
(CERROR "Re-fetch the definition"
"No ~S definition for ~S"
(QUOTE (\, NAME))
ITEM))))))))
(ADDTOVAR PRETTYTYPELST ((\, (LET ((VAR (PACK* "CHANGED" NAME "LST")))
(OR (BOUNDP VAR)
(SET VAR))
VAR))
(\, NAME)
(\, DESCRIPTION)))
(SETF (CL:GETHASH (QUOTE (\, NAME))
*DEFINITION-HASH-TABLE*)
(MAKE-HASH-TABLE (QUOTE :TEST)
(QUOTE CL:EQUAL)
(QUOTE :SIZE)
50
(QUOTE :REHASH-SIZE)
50))
(ADDTOVAR FILEPKGTYPES (\, NAME))
(PUTPROPS (\, NAME)
GETDEF \DEFINE-TYPE-GETDEF)
(PUTPROPS (\, NAME)
FILEPKGCONTENTS NILL)
(PUTPROPS (\, NAME)
PROPTYPE
(\, NAME)))))
(DEFMACRO WITHOUT-FILEPKG (&BODY BODY) (BQUOTE (PROGN (EVAL-WHEN (CL:LOAD)
(\,@ BODY))
(EVAL-WHEN
(CL:EVAL)
(AND (NEQ DFNFLG (QUOTE PROP))
(LET (FILEPKGFLG (DFNFLG T))
(DECLARE (SPECIAL FILEPKGFLG DFNFLG)
)
(\,@ BODY)))))))
(DEFDEFINER DEFUN FUNCTIONS (NAME ARGS &BODY (BODY DECLS DOCUMENTATION))
(BQUOTE (SETF (SYMBOL-FUNCTION (QUOTE (\, NAME)))
(CL:FUNCTION (CL:LAMBDA (\, ARGS)
(\,@ DECLS)
(CL:BLOCK (\, NAME)
(\,@ BODY)))))))
(DEFDEFINER DEFINLINE FUNCTIONS (NAME ARGLIST &BODY BODY &ENVIRONMENT ENV)
(* ;;; "This is an INTERIM version of DEFINLINE. Eventually, this will just turn into a DEFUN and a PROCLAIM INLINE. (It says so right here.) If you're using this one, DO NOT make any recursive calls in the body of the DEFINLINE. If you do, the compiler will run forever trying to expand the optimizer... Once the INLINE version gets working (in the PavCompiler only) that restriction will be lifted.")
(MULTIPLE-VALUE-BIND
(CODE DECLS DOC)
(PARSE-BODY BODY ENV T)
(LET ((NEW-LAMBDA (BQUOTE (CL:LAMBDA (\, ARGLIST)
(\,@ DECLS)
(CL:BLOCK (\, NAME)
(\,@ CODE))))))
(BQUOTE (PROGN (DEFUN (\, NAME) (\, ARGLIST) (\,@ BODY))
(DEFOPTIMIZER (\, NAME) (\, (PACK* (QUOTE defsubst-)
NAME))
(&REST ARGS)
(CONS (QUOTE (\, NEW-LAMBDA))
ARGS))
)))))
(DEFDEFINER DEFMACRO FUNCTIONS (NAME DEFMACRO-ARGS &BODY DEFMACRO-BODY)
(CL:UNLESS (AND NAME (SYMBOLP NAME))
(CL:ERROR "Illegal name used in DEFMACRO: ~S" NAME))
(LET ((CMACRONAME (PACK* "expand-" NAME)))
(MULTIPLE-VALUE-BIND
(PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING)
(PARSE-DEFMACRO DEFMACRO-ARGS (QUOTE $$MACRO-FORM)
DEFMACRO-BODY NAME NIL :ENVIRONMENT (QUOTE
$$MACRO-ENVIRONMENT
))
(BQUOTE (EVAL-WHEN (CL:EVAL CL:COMPILE CL:LOAD)
(SETF (SYMBOL-FUNCTION (QUOTE (\, CMACRONAME)))
(CL:FUNCTION (CL:LAMBDA ($$MACRO-FORM
$$MACRO-ENVIRONMENT
)
(\,@ PARSED-DECLARATIONS)
(CL:BLOCK (\, NAME)
(\, PARSED-BODY)))))
(SETF (MACRO-FUNCTION (QUOTE (\, NAME)))
(QUOTE (\, CMACRONAME))))))))
(DEFDEFINER DEFVAR VARIABLES
(NAME &OPTIONAL (INITIAL-VALUE NIL IVP)
DOCUMENTATION)
(BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (\, NAME))))
(\,@ (if IVP
then (BQUOTE ((OR (BOUNDP (QUOTE (\, NAME)))
(SETQ (\, NAME)
(\, INITIAL-VALUE))))))))))
(DEFDEFINER DEFPARAMETER VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION)
(BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (\, NAME))))
(SETQ (\, NAME)
(\, INITIAL-VALUE)))))
(DEFDEFINER DEFCONSTANT VARIABLES (NAME VALUE &OPTIONAL DOCUMENTATION)
(BQUOTE (PROGN (SETQ (\, NAME)
(\, VALUE))
(PUTHASH (QUOTE (\, NAME))
(QUOTE (CONSTANT (\, NAME)))
COMPVARMACROHASH))))
(DEFDEFINER DEFGLOBALVAR VARIABLES
(NAME &OPTIONAL (INITIAL-VALUE NIL IVP)
DOCUMENTATION)
(BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (\, NAME))))
(\,@ (AND IVP (BQUOTE ((OR (BOUNDP (QUOTE (\, NAME)))
(SETQ (\, NAME)
(\, INITIAL-VALUE))))))))))
(DEFDEFINER DEFGLOBALPARAMETER VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION)
(BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (\, NAME))))
(SETQ (\, NAME)
(\, INITIAL-VALUE)))))
(* ;; "Don't note file package changes to macro-fn.")
(PUTPROPS MACRO-FN PROPTYPE FUNCTIONS)
(* ;; "Arrange for the correct compiler to be used.")
(PUTPROPS CMLDEFFER FILETYPE COMPILE-FILE)
(PUTPROPS CMLDEFFER COPYRIGHT ("Xerox Corporation" 1986 1900))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2123 4952 (PPRINT-DEFINER 2133 . 3557) (\DEFINE-TYPE-GETDEF 3559 . 4386) (
REMOVE-COMMENTS 4388 . 4950)))))
STOP