(FILECREATED " 8-Feb-86 15:07:51" {DSK}<LISPFILES2>IMPROVEDDCOMS>UTIL.;1 5624
changes to: (VARS UTILCOMS) (FNS CANONICAL.REST DEFMACROC.ARGLIST DEFMACROC.BODY))
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT UTILCOMS)
(RPAQQ UTILCOMS ((FNS CANONICAL.REST DEFCMD DEFFILES DEFMACROC DEFMACROC.ARGLIST DEFMACROC.BODY
EMACS.READIN KILLLINE QP.ADDTOFILE) (MACROS DEFRECORD DEFUNC EVAL.ON.LOAD INCF INCR MAKE.SURE.COMPILED
PUTPROPC) (P (PROGN (SETSYNTAX (QUOTE %;) (QUOTE (SPLICE FIRST ESCQUOTE NONIMMEDIATE KILLLINE)) T) (
SETSYNTAX (QUOTE %;) (QUOTE (SPLICE FIRST ESCQUOTE NONIMMEDIATE KILLLINE)) FILERDTBL)))))
(DEFINEQ
(CANONICAL.REST
(CL:LAMBDA (ARGS) (COND ((NOT (NULL (CDR (LAST ARGS)))) (LET ((LASTN (LASTN ARGS 1))) (CONS (CDR LASTN
) (CAR LASTN)))) (T (LET ((LASTN (LASTN ARGS 2))) (COND ((MEMB (CADR LASTN) (QUOTE (&REST &rest))) (
CONS (CADDR LASTN) (CAR LASTN))) (T (CONS NIL ARGS))))))))
(DEFCMD
(NLAMBDA (CMD) (QP.ADDTOFILE CMD (QUOTE P)) (EVAL CMD)))
(DEFFILES
(NLAMBDA FILES (FOR FILE IN (REVERSE FILES) DO (QP.ADDTOFILE FILE (QUOTE FILES))) (APPLY (FUNCTION
FILESLOAD) FILES)))
(DEFMACROC
(NLAMBDA ARGLIST (LET* ((NAME (CAR ARGLIST)) (ARGS (CANONICAL.REST (CADR ARGLIST))) (REST.ARG (CAR
ARGS)) (REG.ARGS (CDR ARGS)) (BODY (CDDR ARGLIST))) (PUTPROP NAME (QUOTE MACRO) (LIST (QUOTE
**MACROARG**) (BQUOTE (LET (\, (DEFMACROC.ARGLIST REG.ARGS REST.ARG)) (\,@ BODY))))) (QP.ADDTOFILE
NAME (QUOTE MACROS)) NAME)))
(DEFMACROC.ARGLIST
(CL:LAMBDA (REG.ARGS REST.ARG) (LET* ((LENGTH (LENGTH REG.ARGS)) (REG.ARG.PART (COND ((NULL REG.ARGS)
NIL) (T (for I from 1 to LENGTH collect (BQUOTE ((\, (CAR (NTH REG.ARGS I))) (CAR (NTH **MACROARG** (
\, I))))))))) (REST.ARG.PART (COND ((NULL REST.ARG) NIL) (T (BQUOTE (((\, REST.ARG) (NTH **MACROARG**
(\, (ADD1 LENGTH)))))))))) (NCONC REG.ARG.PART REST.ARG.PART))))
(DEFMACROC.BODY
(CL:LAMBDA (ARGBODY) (COND ((EQP (LENGTH ARGBODY) 1) (CAR ARGBODY)) (T (CONS (QUOTE LIST) ARGBODY)))))
(EMACS.READIN
(LAMBDA NIL (LET ((FILEPKGFLG NIL) (QP.SOURCE.FILE (QUOTE .XFER.LSP))) (PRIN1 (QUOTE
Emacs% read% started...)) (LOADWELL {GOEDEL}/usr2/xerox/descartes/.xfer T T) (BKSYSBUF (QUOTE %
)) (PRIN1 (QUOTE Emacs% read% completed)))))
(KILLLINE
(LAMBDA (F R) (PROG (C) L (SETQ C (READC F R)) (COND ((NEQ C (QUOTE %
)) (GO L))) (RETURN NIL))))
(QP.ADDTOFILE
(LAMBDA (NAME TYPE) (COND ((AND (BOUNDP (QUOTE QP.SOURCE.FILE)) QP.SOURCE.FILE) (ADDTOFILE NAME TYPE
QP.SOURCE.FILE)))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS DEFRECORD MACRO (**MACROARG** (LET ((NAME (CAR (NTH **MACROARG** 1))) (TYPE (CAR (NTH
**MACROARG** 2))) (FIELDS (NTH **MACROARG** 3))) (LET* ((SLOTS (MAPCAR FIELDS (QUOTE (LAMBDA (FIELD) (
COND ((ATOM FIELD) FIELD) (T (CAR FIELD))))))) (ACCESSORS (MAPCAR SLOTS (QUOTE (LAMBDA (SLOT) (BQUOTE
(DEFMACROC (\, SLOT) (X) (LIST (QUOTE FETCH) (QUOTE (\, SLOT)) (QUOTE OF) X))))))) (SETFFORMS (MAPCAR
SLOTS (QUOTE (LAMBDA (SLOT) (BQUOTE (PUTPROP (QUOTE (\, SLOT)) (QUOTE SETFDEF) (QUOTE (REPLACE (\,
SLOT) OF DATUM WITH NEWVALUE))))))))) (QP.ADDTOFILE NAME (QUOTE RECORDS)) (for SLOT in SLOTS do (
QP.ADDTOFILE (LIST SLOT (QUOTE SETFDEF)) (QUOTE PROPS))) (BQUOTE (PROGN ((\, TYPE) (\, NAME) (\, SLOTS
)) (\,@ ACCESSORS) (\,@ SETFFORMS) (QUOTE (\, NAME))))))))
(PUTPROPS DEFUNC MACRO (**MACROARG** (LET ((NAME (CAR (NTH **MACROARG** 1))) (ARGS (CAR (NTH
**MACROARG** 2))) (BODY (NTH **MACROARG** 3))) (QP.ADDTOFILE NAME (QUOTE FNS)) (LIST (QUOTE PUTDQ)
NAME (COND ((EQ ARGS (QUOTE FEXPR)) (CONS (QUOTE NLAMBDA) BODY)) ((EQ ARGS (QUOTE EXPR)) (CONS (QUOTE
LAMBDA) BODY)) (T (CONS (QUOTE LAMBDA) (CONS ARGS BODY))))))))
(PUTPROPS EVAL.ON.LOAD MACRO (**MACROARG** (LET ((FORM (CAR (NTH **MACROARG** 1)))) (QP.ADDTOFILE FORM
(QUOTE P)) FORM)))
(PUTPROPS INCF MACRO (**MACROARG** (LET ((NAME (CAR (NTH **MACROARG** 1))) (COUNT (CAR (NTH
**MACROARG** 2)))) (BQUOTE (SETF (\, NAME) (PLUS (\, NAME) (\, (OR COUNT 1))))))))
(PUTPROPS INCR MACRO (**MACROARG** (LET ((NAME (CAR (NTH **MACROARG** 1))) (COUNT (CAR (NTH
**MACROARG** 2)))) (BQUOTE (SETQ (\, NAME) (PLUS (\, NAME) (\, (OR COUNT 1))))))))
(PUTPROPS MAKE.SURE.COMPILED MACRO (**MACROARG** (LET ((FUNCTION (CAR (NTH **MACROARG** 1)))) (BQUOTE
(COND ((NOT (EQ (TYPENAME (GETD (QUOTE (\, FUNCTION)))) (QUOTE CCODEP))) (COMPILE! (QUOTE (\, FUNCTION
)))))))))
(PUTPROPS PUTPROPC MACRO (**MACROARG** (LET ((ATOM (CAR (NTH **MACROARG** 1))) (PROPERTY (CAR (NTH
**MACROARG** 2))) (VALUE (CAR (NTH **MACROARG** 3)))) (QP.ADDTOFILE (LIST (EVAL ATOM) (EVAL PROPERTY))
(QUOTE PROPS)) (BQUOTE (PUTPROP (\, ATOM) (\, PROPERTY) (\, VALUE))))))
)
(PROGN (SETSYNTAX (QUOTE %;) (QUOTE (SPLICE FIRST ESCQUOTE NONIMMEDIATE KILLLINE)) T) (SETSYNTAX (
QUOTE %;) (QUOTE (SPLICE FIRST ESCQUOTE NONIMMEDIATE KILLLINE)) FILERDTBL))
(PRETTYCOMPRINT UTILCOMS)
(RPAQQ UTILCOMS ((FNS CANONICAL.REST DEFCMD DEFFILES DEFMACROC DEFMACROC.ARGLIST DEFMACROC.BODY
EMACS.READIN KILLLINE QP.ADDTOFILE) (MACROS DEFRECORD DEFUNC EVAL.ON.LOAD INCF INCR MAKE.SURE.COMPILED
PUTPROPC) (P (PROGN (SETSYNTAX (QUOTE %;) (QUOTE (SPLICE FIRST ESCQUOTE NONIMMEDIATE KILLLINE)) T) (
SETSYNTAX (QUOTE %;) (QUOTE (SPLICE FIRST ESCQUOTE NONIMMEDIATE KILLLINE)) FILERDTBL))) (DECLARE:
DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DEFMACROC DEFFILES) (NLAML DEFCMD)
(LAMA)))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DEFMACROC DEFFILES)
(ADDTOVAR NLAML DEFCMD)
(ADDTOVAR LAMA )
)
(PUTPROPS UTIL COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (682 2541 (CANONICAL.REST 692 . 974) (DEFCMD 976 . 1044) (DEFFILES 1046 . 1179) (
DEFMACROC 1181 . 1518) (DEFMACROC.ARGLIST 1520 . 1915) (DEFMACROC.BODY 1917 . 2039) (EMACS.READIN 2041
. 2285) (KILLLINE 2287 . 2398) (QP.ADDTOFILE 2400 . 2539)))))
STOP