(FILECREATED "27-Mar-86 10:40:58" {GENIE}LISP:<LISPLIBRARY.KOTO>CMLPATCH.;131 40130
changes to: (MACROS IN-PACKAGE CONDITIONAL-CODE FIND-PACKAGE)
(VARS CMLPATCHCOMS)
(FNS CREATE-STRUCTURE ROUND FLOOR CEILING TRUNCATE)
previous date: "24-Mar-86 17:52:20" {GENIE}LISP:<LISPLIBRARY.KOTO>CMLPATCH.;130)
(* Copyright (c) 1986, 1901 by public domain. All rights reserved.)
(PRETTYCOMPRINT CMLPATCHCOMS)
(RPAQQ CMLPATCHCOMS ((E (* * Patches for the CML Library Packages))
(LOCALVARS . T)
(COMS (* Common Lisp Boolean constants defintions.)
(CONSTANTS (BOOLE-CLR 0)
(BOOLE-SET 1)
(BOOLE-1 2)
(BOOLE-2 3)
(BOOLE-C1 4)
(BOOLE-C2 5)
(BOOLE-AND 6)
(BOOLE-IOR 7)
(BOOLE-XOR 8)
(BOOLE-EQV 9)
(BOOLE-NAND 10)
(BOOLE-NOR 11)
(BOOLE-ANDC1 12)
(BOOLE-ANDC2 13)
(BOOLE-ORC1 14)
(BOOLE-ORC2 15)))
(COMS (* Bug fixing of already existing functions/macros in the cml package.)
(ADVISE CONSTANTEXPRESSIONP DRAWLINE-IN-PRINT.BLACKLINE)
(PROP COMPILE.FILE.EXPRESSION DEFSTRUCT DEFUN)
(MACROS /= CATCH DOLIST MULTIPLE-VALUE-LIST ROTATEF SETF SPREADAPPLY* THE THROW)
(FNS :TYPE CMLTRANSLATE COMPILE.FILE.DEFSTRUCT COMPILE.FILE.DEFUN CONSP FLOOR MOD
ROUND \CHECK-TYPE-FAIL \CL-LAMBDA-FNTYP)
(P (COND ((AND (GETPROP 'LISTFILES1 'CODE)
(MOVD? 'LISTFILES1 'LISTFILES1.CML))
(* nasty bug in the cml listfiles1. But under the form listfiles1.cml it
is useable.)
(UNSAVEDEF 'LISTFILES1)))))
(COMS
(* Comment function to be used when under the Common Lisp Listener.)
(PROP COMPILE.FILE.EXPRESSION IL:*)
(MACROS IL:*)
(P
(* Remove the print-to-file function for * because it has a bad formatting aspect.)
(REMPROP '* 'PRINT-TO-FILE)
(MOVD? '* 'IL:*)
(* Install the new comment in the background menu. When the Common Lisp listener in
active the commentflg is set to IL:*)
(COND
((ASSOC 'Lisp% Listener BackgroundMenuCommands)
(RPLACA
(CDDDR (ASSOC 'Lisp% Listener BackgroundMenuCommands))
'(SUBITEMS
(Interlisp '(AddNewLispListener))
("Common Lisp" `(AddNewLispListener
'(LET ((\CML.READPREFIX "#"))
(RESETVAR COMMENTFLG 'IL:* (EVALQT
`,CMLPROMPT)))))))
(SETQ BackgroundMenu NIL)))))
(COMS (* New extension to the cml package.)
(MACROS ASH BUTLAST CASE CL:ASSOC CL:BLOCK CL:ERROR CL:FIND CL:MAPC CL:POSITION
CL:PUSHNEW CONCATENATE DECF DELETE DO-FORMS ECASE EVAL-WHEN EVAL.WHEN
FIRST IGNORE INCF INTERN KEYWORDP MULTIPLE-VALUE-BIND MULTIPLE-VALUE-LIST
MULTIPLE-VALUE-SETQ NRECONC NREVERSE NTHCDR REMOVE-DUPLICATES REMOVE-IF
REMOVE-IF-NOT RETURN-FROM SECOND SET-DIFFERENCE STRING SUBSEQ SYMBOL-NAME
SYMBOL-VALUE TAGBODY THIRD VALUES)
(MACROS IN-PACKAGE CONDITIONAL-CODE FIND-PACKAGE)
(DEFSETF SYMBOL-FUNCTION)
(FNS CEILING CL:NTH CREATE-STRUCTURE TRUNCATE COLLAPSE-APPLY ECASE.ERROR KEYWORDP
SETF-SYMBOL-FUNCTION SIMPLE-LIST-POSITION SIMPLE-POSITION-DISPATCH
SIMPLE-STRING-POSITION STRING-LESSP STRING-RIGHT-TRIM SYMBOL-FUNCTION
VALUES-LIST \CASE.TRANSLATE \ECASE.TRANSLATE \EVAL-WHEN-TRANSLATE)
(CONSTANTS (EVAL-WHEN-SITUATION-ALIST '((LOAD . DOEVAL@LOAD)
(COMPILE . DOEVAL@COMPILE)
(EVAL . DOEVAL@LOAD)
(COPY . DOCOPY)
(DONTCOPY . DONTCOPY))))
(ADDVARS (CMLTRANSLATIONS (assoc . CL:ASSOC)
(block . CL:BLOCK)
(error . CL:ERROR)
(find . CL:FIND)
(mapc . CL:MAPC)
(nth . CL:NTH)
(pushnew . CL:PUSHNEW)
(setq . CL:SETQ)))
(INITVARS (*PACKAGE* NIL))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD? 'REMAINDER 'REM)
(MOVD? 'DECLARE 'CL:DECLARE)
(MOVD? 'DEFINEDP 'FUNCTIONP)
(MOVD? 'MKSTRING 'PRINC-TO-STRING)
(MOVD? 'FRESHLINE 'FRESH-LINE)
(MOVD 'FQUOTIENT '%%/))))
(COMS (* Advise makefile so that it doesn't use Fonts or Right-Brackets for printing
files.)
(ADVISE MAKEFILE))
(COMS (* New implementation of the TTYIN ?= function to allow treatment of keywords)
(ADVISE SMARTARGLIST)
(VARS TTYIN?=FN)
(FNS NEW.TTYIN?=FN))
(COMS (* Bug fixing of DEFSTRUCT.TRANSLATE)
(FNS NEW.DEFSTRUCT.TRANSLATE)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (AND (MOVD? 'DEFSTRUCT.TRANSLATE '
OLD.DEFSTRUCT.TRANSLATE)
(MOVD 'NEW.DEFSTRUCT.TRANSLATE
'DEFSTRUCT.TRANSLATE)))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA STRING-LESSP)
))))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(* Common Lisp Boolean constants defintions.)
(DECLARE: EVAL@COMPILE
(CONSTANTS BOOLE-CLR BOOLE-SET BOOLE-1 BOOLE-2 BOOLE-C1 BOOLE-C2 BOOLE-AND BOOLE-IOR BOOLE-XOR
BOOLE-EQV BOOLE-NAND BOOLE-NOR BOOLE-ANDC1 BOOLE-ANDC2 BOOLE-ORC1 BOOLE-ORC2)
(RPAQQ BOOLE-CLR 0)
(RPAQQ BOOLE-SET 1)
(RPAQQ BOOLE-1 2)
(RPAQQ BOOLE-2 3)
(RPAQQ BOOLE-C1 4)
(RPAQQ BOOLE-C2 5)
(RPAQQ BOOLE-AND 6)
(RPAQQ BOOLE-IOR 7)
(RPAQQ BOOLE-XOR 8)
(RPAQQ BOOLE-EQV 9)
(RPAQQ BOOLE-NAND 10)
(RPAQQ BOOLE-NOR 11)
(RPAQQ BOOLE-ANDC1 12)
(RPAQQ BOOLE-ANDC2 13)
(RPAQQ BOOLE-ORC1 14)
(RPAQQ BOOLE-ORC2 15)
)
(* Bug fixing of already existing functions/macros in the cml package.)
(PUTPROPS CONSTANTEXPRESSIONP READVICE (NIL (BEFORE NIL (AND (KEYWORDP FORM)
(RETURN (LIST FORM))))))
(PUTPROPS DRAWLINE-IN-PRINT.BLACKLINE READVICE ((PRINT.BLACKLINE . DRAWLINE)
(BEFORE NIL (COND ((MINUSP WIDTH)
(SETQ WIDTH (MINUS WIDTH))))
)))
(READVISE CONSTANTEXPRESSIONP DRAWLINE-IN-PRINT.BLACKLINE)
(PUTPROPS DEFSTRUCT COMPILE.FILE.EXPRESSION COMPILE.FILE.DEFSTRUCT)
(PUTPROPS DEFUN COMPILE.FILE.EXPRESSION COMPILE.FILE.DEFUN)
(DECLARE: EVAL@COMPILE
(PUTPROPS
/= DMACRO
(DEFMACRO
(N &REST NS)
"CommonLisp ALL DIFFERENT test"
(COND
(NS
(COND
((CDR NS)
(LET
((VARS (for X in (CONS N NS)
collect
(LIST (GENSYM '/=)
X))))
`((OPENLAMBDA ,(MAPCAR VARS 'CAR)
(AND ,@(for X on VARS join
(for Y on (CDR X)
collect
`(NOT (= ,(CAAR X)
,(CAAR Y)))))))
,@(MAPCAR VARS 'CADR))))
(T `(NOT (= %, N %, (CAR NS))))))
(T T))))
(PUTPROPS CATCH DMACRO (DEFMACRO
(TAGFORM &REST FORMS)
(LET ((Y (LISPFORM.SIMPLIFY (MKPROGN FORMS)
T))
(CTAG (CONSTANTEXPRESSIONP TAGFORM)))
(COND (CTAG (SETQ CTAG (\CATCH.TAG.INTERN (CAR CTAG)))
(SUBPAIR '(X FORM)
(LIST CTAG Y)
'(\CATCHRUNFUN (FUNCTION (LAMBDA NIL
((LAMBDA
(X)
(DECLARE (SPECVARS
X))
FORM)
(\MYALINK)))))))
(T (LIST '\CATCH.AUX TAGFORM `(FUNCTION (LAMBDA NIL ,Y))))))))
(DEFMACRO DOLIST ((X L &OPTIONAL RESULT)
&BODY BODY)
`(for ,X in ,L do ,@BODY finally (RETURN ,RESULT)))
(DEFMACRO MULTIPLE-VALUE-LIST (FORM)
`(CONS ,FORM *VALUES-STACK*))
(PUTPROPS ROTATEF MACRO ((X Y)
(SETF X (PROG1 Y (SETF Y X)))))
(DEFMACRO SETF (&REST ACCESS-VALUE-FORMS)
"CommonLisp SETF Special form. TranLe 2/4/86"
(COND ((LEQ (LENGTH ACCESS-VALUE-FORMS)
2)
`(CHANGE ,(CAR ACCESS-VALUE-FORMS)
,(CADR ACCESS-VALUE-FORMS)))
((LISTP ACCESS-VALUE-FORMS)
`(PROGN ,@(CL:DO ((ACCESS ACCESS-VALUE-FORMS (CDDR ACCESS))
(VALUE (CDR ACCESS-VALUE-FORMS)
(CDDR VALUE))
SETFLST)
((NULL ACCESS)
SETFLST)
(SETQ SETFLST (NCONC1 SETFLST
`(CHANGE ,(CAR ACCESS)
,(CAR VALUE)))))))))
(PUTPROPS SPREADAPPLY* DMACRO (DEFMACRO (ARGS &REST FORM)
`((LAMBDA ($$FN)
(.APPLYFN. ,@FORM ,(LENGTH FORM)
$$FN))
,ARGS)))
(DEFMACRO THE (TYPESPEC PLACE)
(LET ((VAL (GENSYM "THE-")))
`(PROG ((,VAL ,PLACE))
RETRY
(COND ((TYPEP ,VAL ',TYPESPEC)
(RETURN ,VAL))
(T (SETQ ,VAL (\CHECK-TYPE-FAIL ,VAL ',TYPESPEC))
(GO RETRY))))))
(PUTPROPS THROW DMACRO (DEFMACRO (TAG RESULT)
(PROG ((Y (LISPFORM.SIMPLIFY (CONS 'PROGN (LIST TAG RESULT))
T))
TAGFORM)
(SETQ Y (CDR Y))
(RETURN (COND ((SETQ TAGFORM (CONSTANTEXPRESSIONP
(CAR Y)))
(LIST '\THROW.AUX (\CATCH.TAG.INTERN
(CAR TAGFORM))
(KWOTE (CAR TAGFORM))
(CADR Y)))
(T 'IGNOREMACRO))))))
)
(DEFINEQ
(:TYPE
(LAMBDA (CLASS-TYPE) (* tlm: "10-Feb-86 15:04")
(* * Bug somewhere in DEFSTRUCT.TRANSLATE need that function.)
CLASS-TYPE))
(CMLTRANSLATE
(LAMBDA (X) (* tlm: "26-Feb-86 15:19")
(DECLARE (GLOBALVARS CMLTRANSLATIONS))
(* * Translate CommonLisp forms to Interlisp Forms. This a modification of the function in the
cml package in the sense that it use cmltranslation only on the car of list which might be a
function name at other place it does just an u-case.)
(* * X -
list or atom to translate.)
(* * environment -
This function is called from within ttyinread.)
(* * operation -
If we receive a string then don't do anything. If it is an atom then transform it to its
uppercase version. If it is a list beginning with the commentflg and the commentflg is not "*"
then return the list as it is. Otherwise use the assoc list cmltranslations to translate the
car of the list and map the cdr through cmltranslate.)
(* * value -
an Interlisp form)
(COND
((NLISTP X)
(COND
((STRINGP X) (* Don't change strings.)
X)
(T (* Put all the other atoms to uppercase.)
(U-CASE X))))
((AND (NEQ COMMENTFLG (QUOTE *))
(EQ (CAR X)
COMMENTFLG)) (* Put back standard Interlisp comment
character.)
(RPLACA X (QUOTE *))
X)
((LISTP (CAR X))
(MAPCAR X (FUNCTION CMLTRANSLATE)))
(T (CONS (OR (CDR (FASSOC (CAR X)
CMLTRANSLATIONS))
(U-CASE (CAR X)))
(MAPCAR (CDR X)
(FUNCTION CMLTRANSLATE)))))))
(COMPILE.FILE.DEFSTRUCT
(LAMBDA (FORM LCFIL RDTBL) (* tlm: "11-Feb-86 16:59")
(* * Dummy function for printing out defstruct construct for the Commonlisp compiler
COMPILE-FILE)
(LET ((DEFSTRUCT-TRANSLATION (DEFSTRUCT.TRANSLATE (CDR FORM))))
(* print the defstruct definition on compiler
output file.)
(PRINT FORM LCFIL RDTBL) (* compile all the method resulting from the
defstruct.)
(RESETVAR FILEPKGFLG NIL (for DFORM in DEFSTRUCT-TRANSLATION
do (AND (CADR DFORM)
(SELECTQ (CAR DFORM)
(DEFUN
(* do file compilation for defineq and defun
generated from the defstruct definition.)
(COMPILE.FILE.DEFUN
DFORM LCFIL RDTBL))
(DEFINEQ
(* do file compilation for defineq and defun
generated from the defstruct definition.)
(COMPILE.FILE.DEFINEQ
DFORM LCFIL RDTBL))
NIL)))))))
(COMPILE.FILE.DEFUN
(LAMBDA (FORM LCFIL RDTBL) (* tlm: "11-Feb-86 11:34")
(AND (CADR FORM)
(COMPILE.FILE.DEFINEQ (BQUOTE (DEFINEQ ((\, (CADR FORM))
(CL:LAMBDA (\,@ (CDDR FORM))))))
LCFIL RDTBL))))
(CONSP
(LAMBDA (Object) (* tlm: " 6-Mar-86 19:31")
(* * Common Lisp CONSP function.)
(COND
((LISTP Object)
T))))
(FLOOR
(LAMBDA (NUMBER DIVISOR) (* JPG: "27-Mar-86 10:33")
(LET ((RESULT (if DIVISOR
then (FQUOTIENT NUMBER DIVISOR)
else NUMBER)))
(DECLARE (LOCALVARS RESULT))
(* VALUES (if (AND (NOT (EQP RESULT (SETQ RESULT (FIX RESULT)))) (MINUSP RESULT)) then
(SUB1 RESULT) else RESULT) (if DIVISOR then (REMAINDER NUMBER DIVISOR) else 0))
(if (AND (NOT (EQP RESULT (SETQ RESULT (FIX RESULT))))
(MINUSP RESULT))
then (SUB1 RESULT)
else RESULT))))
(MOD
(LAMBDA (X Y) (* tlm: " 6-Feb-86 17:22")
(* This is like IMOD except uses mixed
arithmetic. -
Doesnt have the bugs IMOD has.)
(COND
((ZEROP Y)
0)
((EQ (PLUSP Y)
(PLUSP X))
(REMAINDER X Y))
(T (PLUS (REMAINDER X Y)
Y)))))
(ROUND
(LAMBDA (X DIVISOR) (* JPG: "27-Mar-86 10:32")
(* * Rounds the number X to the nearest integer; if X is exactly halfway between two integers
(that is, of the form integer+0.5), then it is rounded to the nearest even integer.
-
DIVISOR, if specified, then the result is the ROUNDing of the value produced by dividing X by
DIVISOR.)
(* COND ((AND DIVISOR (NOT (EQP DIVISOR 1))) (LET ((QUOTIENT (ROUND (QUOTIENT X DIVISOR))))
(VALUES QUOTIENT (DIFFERENCE X (TIMES DIVISOR QUOTIENT))))) (T (LET* ((QUOTIENT
(FIXR X))) (* VALUES QUOTIENT (DIFFERENCE X QUOTIENT)) QUOTIENT)))
(COND
((AND DIVISOR (NOT (EQP DIVISOR 1)))
(FIXR (FQUOTIENT X DIVISOR)))
(T (FIXR X)))))
(\CHECK-TYPE-FAIL
(LAMBDA (ARG TYPESPEC) (* tlm: " 9-Jan-86 10:41")
(* * This function is used by the CML function CHECK-TYPE -)
(* * OPERATION -
go to the break window. If an OK or RETURN if entered then ask for new value of ARG to return
to CHECK-TYPE otherwise the break package allow with ↑ to go to the top level)
(LET ((ARGVAL (OR (AND (BOUNDP ARG)
(EVAL ARG))
(QUOTE UNBOUND))))
(printout T "Error: The value of " ARG ", " ARGVAL " is not " TYPESPEC T)
(BREAK1 NIL T CHECK-TYPE)
(printout T "Enter an expression to be evaluated as the new value for " ARG " : ")
(EVAL (READ)))))
(\CL-LAMBDA-FNTYP
(LAMBDA (EXP) (* tlm: " 3-Mar-86 10:50")
(* * This function return the function type for Common Lisp
(CL:LAMBDA) functions.)
(* * EXP -
The cl:lambda definition of the function to be analyzed.)
(* * environment -
This function is called by fntyp when the car of a function definition is
cl:lambda.)
(* * operation -
If &rest or &body is in the arguments list of the function then it is a
expr* (undefined number of evaluated argument) otherwise all Common Lisp
function are expr (fixed number of evaluated arguments) If the argument-list
is not a list then return an error.)
(* * value -
either EXPR* or EXPR.)
(LET ((ARGS (CADR EXP)))
(COND
((LISTP ARGS)
(COND
((OR (FMEMB (QUOTE &REST)
ARGS)
(FMEMB (QUOTE &BODY)
ARGS))
(QUOTE EXPR*))
(T (QUOTE EXPR))))
((NULL ARGS)
(QUOTE EXPR))
((SHOULDNT "Common Lisp LAMBDA-LIST should be a list of argument"))))))
)
(COND ((AND (GETPROP 'LISTFILES1 'CODE)
(MOVD? 'LISTFILES1 'LISTFILES1.CML))
(* nasty bug in the cml listfiles1. But under the form listfiles1.cml it is useable.)
(UNSAVEDEF 'LISTFILES1)))
(* Comment function to be used when under the Common Lisp Listener.)
(PUTPROPS IL:* COMPILE.FILE.EXPRESSION NILL)
(DECLARE: EVAL@COMPILE
(PUTPROPS IL:* BYTEMACRO COMP.COMMENT)
)
(* Remove the print-to-file function for * because it has a bad formatting aspect.)
(REMPROP '* 'PRINT-TO-FILE)
(MOVD? '* 'IL:*)
(* Install the new comment in the background menu. When the Common Lisp listener in active the
commentflg is set to IL:*)
(COND
((ASSOC 'Lisp% Listener BackgroundMenuCommands)
(RPLACA (CDDDR (ASSOC 'Lisp% Listener BackgroundMenuCommands))
'(SUBITEMS (Interlisp '(AddNewLispListener))
("Common Lisp"
`(AddNewLispListener '(LET ((\CML.READPREFIX "#"))
(RESETVAR COMMENTFLG 'IL:*
(EVALQT `,CMLPROMPT)))))))
(SETQ BackgroundMenu NIL)))
(* New extension to the cml package.)
(DECLARE: EVAL@COMPILE
(DEFMACRO ASH (INTEGER COUNT)
"Common Lisp arithmetic left shift"
`(LSH ,INTEGER ,COUNT))
(DEFMACRO BUTLAST (LST &OPTIONAL (N 1))
(LET ((L (GENSYM)))
`(LET ((,L (COPY ,LST)))
(FRPTQ ,N (SETF (LAST ,L)
NIL))
,L)))
(DEFMACRO CASE (KEY &REST FORMS)
"Common Lisp CASE macro."
(\CASE.TRANSLATE KEY FORMS))
(DEFMACRO CL:ASSOC (ITEM LIST &KEY (TEST (FUNCTION EQL)
TESTFN?))
"Assoc function for CommonLisp. This version is not fully implemented"
(LET ((TESTFN (COND (TESTFN? (CAR (CONSTANTEXPRESSIONP TEST)))
(T TEST))))
(COND ((EQ TESTFN (FUNCTION EQ))
`(FASSOC ,ITEM ,LIST))
((EQ TESTFN (FUNCTION EQUAL))
`(SASSOC ,ITEM ,LIST))
(T `(for X in ,LIST do (RETURN X)
when
,(COND (TESTFN `(,TESTFN ,ITEM X))
(T `(APPLY* ,TEST ,ITEM X))))))))
(DEFMACRO CL:BLOCK (NAME &REST FORMS)
"CommonLisp special form form BLOCK"
`(CATCH ',NAME ,@FORMS))
(DEFMACRO CL:ERROR (FORMAT-STRING &REST ARGS)
"Macro version of the CommonLisp function ERROR"
`(ERROR "Error: " (FORMAT NIL (THE SIMPLE-STRING ,FORMAT-STRING)
\, ARGS)))
(DEFMACRO CL:FIND (ITEM SEQ &KEY (TEST (FUNCTION EQL))
KEY)
"CommonLisp FIND funcion."
(COND ((AND (CONSTANTEXPRESSIONP TEST)
(CONSTANTEXPRESSIONP KEY))
(SETQ TEST (EVAL TEST))
(SETQ KEY (EVAL KEY))
`(for IT in ,SEQ until ,(COND (KEY `(,TEST (,KEY IT)
,ITEM))
(T `(,TEST IT ,ITEM)))
finally
(RETURN IT)))
(T (ERROR "Find is not yet implemented for variable TEST or KEY."))))
(DEFMACRO CL:MAPC (FN LIST)
"CommonLisp MAPC function"
`(MAPC ,LIST ,FN))
(DEFMACRO CL:POSITION (ITEM SEQUENCE &KEY FROM-END TEST TEST-NOT START END KEY)
(CL:UNLESS (OR FROM-END TEST TEST-NOT START END)
`(SIMPLE-POSITION-DISPATCH ,ITEM ,SEQUENCE)))
(DEFMACRO CL:PUSHNEW (LST ITEM &KEY TEST)
"Common Lisp pushnew macro."
(COND ((OR (AND (LISTP LST)
(NEQ (CAR LST)
'QUOTE))
(AND (LISTP ITEM)
(NEQ (CAR ITEM)
'QUOTE)))
`(LET ((LL ,LST)
(II ,ITEM))
(DECLARE (LOCALVARS LL II))
(COND ((NOT (CL:MEMBER II LL :TEST ,TEST))
(CL:PUSH II LL)))))
(T `(COND ((NOT (CL:MEMBER ,ITEM ,LST :TEST ,TEST))
(CL:PUSH ,ITEM ,LST))))))
(DEFMACRO CONCATENATE (TYPE &REST ARGS)
(CL:IF (CONSTANTEXPRESSIONP TYPE)
(CL:IF (OR (EQ (EVAL TYPE)
'STRING)
(EQ (EVAL TYPE)
'SIMPLE-STRING))
`(CONCAT ,@ARGS)
(ERROR "CONCATENATE no supported for type " (EVAL TYPE)))
(ERROR "cannot compile non-constant types in CONCATENATE")))
(DEFMACRO DECF (X)
`(SETF ,X (1- ,X)))
(DEFMACRO DELETE (ITEM SEQUENCE &KEY (TEST (FUNCTION EQL)
TEST?)
KEY)
"CommonLisp DELETE function. This function is not fully implemented"
(LET ((TESTFN (COND (TEST? (CAR (CONSTANTEXPRESSIONP TEST)))
(T TEST)))
(KEYFN (COND ((CONSTANTEXPRESSIONP KEY)
(EVAL KEY))
(T (ERROR "DELETE cannot handle for now non constant KEY function.")
)))
(RES (GENSYM "DELETE-"))
(SEQ (GENSYM "DELETE-"))
SEQX)
(SETQ SEQX (COND (KEYFN `(,KEYFN (CAR ,SEQ)))
(T `(CAR ,SEQ))))
(SETQ TESTFN (COND (TESTFN `(,TESTFN ,ITEM ,SEQX))
(T `(APPLY* ,TEST ,ITEM ,SEQX))))
(COND ((AND (NULL KEY)
(EQ (CAR (CONSTANTEXPRESSIONP TEST))
'EQ))
`(DREMOVE ,ITEM ,SEQUENCE))
((AND (NULL KEY)
(EQ (CAR (CONSTANTEXPRESSIONP TEST))
'EQUAL))
`(REMOVE ,ITEM ,SEQUENCE))
(T `(LET (,RES (,SEQ ,SEQUENCE))
(SETQ ,RES ,SEQ)
(COND ((EQLENGTH ,SEQ 1)
(COND (,TESTFN (SETQ ,RES NIL))
(T ,RES)))
(T (RPTQ (FLENGTH ,SEQ)
(COND (,TESTFN (FRPLNODE ,SEQ (CADR ,SEQ)
(CDDR ,SEQ)))
(T (SETQ ,SEQ (CDR ,SEQ)))))))
,RES)))))
(DEFMACRO DO-FORMS (FORMS)
`(MAPC ,FORMS (FUNCTION EVAL)))
(DEFMACRO ECASE (&WHOLE FORM)
(\ECASE.TRANSLATE FORM))
(DEFMACRO EVAL-WHEN (SITUATIONS-LIST &REST FORMS)
"CommonLisp EVAL-WHEN Special Form"
(\EVAL-WHEN-TRANSLATE SITUATIONS-LIST FORMS))
(DEFMACRO EVAL.WHEN (SITUATIONS-LIST &REST FORMS)
"CommonLisp EVAL-WHEN Special Form"
(\EVAL-WHEN-TRANSLATE SITUATIONS-LIST FORMS))
(DEFMACRO FIRST (LST)
`(CAR ,LST))
(DEFMACRO IGNORE (&REST ARGS)
"Ignore the Arguments for a function" NIL)
(DEFMACRO INCF (X)
`(SETF ,X (1+ ,X)))
(DEFMACRO INTERN (STRING &OPTIONAL (PKG *PACKAGE* PKG?))
"The INTERN function for the CML PACKAGE do nothing but a MKATOM"
(COND (PKG? `(MKATOM (if ,PKG then (CONCAT ,PKG ":" ,STRING)
else
,STRING)))
(T `(MKATOM (if *PACKAGE* then (CONCAT *PACKAGE* ":" ,STRING)
else
,STRING)))))
(DEFMACRO KEYWORDP (OBJECT)
"CommonLisp function for testing if OBJECT is a KEYWORD"
`(TYPEP ,OBJECT 'KEYWORD))
(DEFMACRO MULTIPLE-VALUE-BIND (VARS-LIST VALUES-FORM &REST FORMS)
"CommonLisp MULTIPLE-VALUE-BIND macro"
`(LET (,@VARS-LIST *VALUES-STACK*)
(DECLARE (SPECVARS *VALUES-STACK*))
(SETQ ,(CAR VARS-LIST)
,VALUES-FORM)
,@(for VARS in (CDR VARS-LIST)
collect
`(SETQ ,VARS (pop *VALUES-STACK*)))
,@FORMS))
(DEFMACRO MULTIPLE-VALUE-LIST (FORM)
`(CONS ,FORM *VALUES-STACK*))
(DEFMACRO MULTIPLE-VALUE-SETQ (VARIABLES FORM)
"CommonLisp MULTIPLE-VALUE-SETQ macro"
(COND ((EQLENGTH VARIABLES 1)
`(LET (*VALUES-STACK*)
(DECLARE (SPECVARS *VALUES-STACK*))
(SETQ ,(CAR VARIABLES)
,FORM)))
(T `(LET (*VALUES-STACK*)
(DECLARE (SPECVARS *VALUES-STACK*))
(SETQ ,(CAR VARIABLES)
,FORM)
,@(for VAR in (CDR VARIABLES)
collect
`(SETQ ,VAR (pop *VALUES-STACK*)))
,(CAR VARIABLES)))))
(DEFMACRO NRECONC (X Y)
`(NCONC (DREVERSE ,X)
,Y))
(DEFMACRO NREVERSE (SEQUENCE)
"destructive version of REVERSE"
`(DREVERSE ,SEQUENCE))
(DEFMACRO NTHCDR (N LST)
"Common Lisp NTHCDR Function."
`(NTH ,LST (ADD1 ,N)))
(PUTPROPS REMOVE-DUPLICATES MACRO (OPENLAMBDA (X)
(INTERSECTION X X)))
(DEFMACRO REMOVE-IF (FN LST)
`(FOR ITEM IN ,LST UNLESS ,(COLLAPSE-APPLY FN 'ITEM)
COLLECT ITEM))
(DEFMACRO REMOVE-IF-NOT (FN LST)
"CommonLisp function REMOVE-IF-NOT"
`(FOR ITEM IN ,LST WHEN ,(COLLAPSE-APPLY FN 'ITEM)
COLLECT ITEM))
(DEFMACRO RETURN-FROM (NAME &OPTIONAL VALUE)
"CommonLisp RETURN-FORM special form"
`(THROW ',NAME ,VALUE))
(DEFMACRO SECOND (LST)
`(CADR ,LST))
(DEFMACRO SET-DIFFERENCE (L1 L2)
`(LDIFFERENCE ,L1 ,L2))
(PUTPROPS STRING MACRO (= . MKSTRING))
(PUTPROPS SUBSEQ MACRO (= . SUBSTRING))
(PUTPROPS SYMBOL-NAME MACRO (OPENLAMBDA (X)
(CL:IF (CL:ATOM X)
(MKSTRING X)
(ERROR))))
(PUTPROPS SYMBOL-VALUE MACRO (= . \EVAL))
(DEFMACRO TAGBODY (&WHOLE BODY)
"CommonLisp special form TAGBODY"
`(PROG NIL ,@(CDR BODY)))
(DEFMACRO THIRD (LST)
`(CADDR ,LST))
(DEFMACRO VALUES (&REST ARGS)
"CommonLisp VALUES function"
`(PROG1 ,(CAR ARGS)
(SETQ *VALUES-STACK* NIL)
,@(MAPCONC (REVERSE (CDR ARGS))
(FUNCTION (LAMBDA (ARG)
`((push *VALUES-STACK* ,ARG)))))))
)
(DECLARE: EVAL@COMPILE
(DEFMACRO IN-PACKAGE (&REST IGNORE)
NIL)
(DEFMACRO CONDITIONAL-CODE (&REST IGNORE)
NIL)
(DEFMACRO FIND-PACKAGE (&REST IGNORE)
NIL)
)
(DEFSETF SYMBOL-FUNCTION SETF-SYMBOL-FUNCTION)
(DEFINEQ
(CEILING
(LAMBDA (NUMBER DIVISOR) (* JPG: "27-Mar-86 10:34")
(* * Common Lisp version of ceiling.)
(LET ((RESULT (if DIVISOR
then (FQUOTIENT NUMBER DIVISOR)
else NUMBER)))
(DECLARE (LOCALVARS RESULT))
(* VALUES (if (AND (NOT (EQP RESULT (SETQ RESULT (FIX RESULT)))) (NOT (MINUSP RESULT))) then
(ADD1 RESULT) else RESULT) (if DIVISOR then (REMAINDER NUMBER DIVISOR) else 0))
(if (AND (NOT (EQP RESULT (SETQ RESULT (FIX RESULT))))
(NOT (MINUSP RESULT)))
then (ADD1 RESULT)
else RESULT))))
(CL:NTH
[LAMBDA (N LST) (* R.Noble "19-Feb-86 11:24")
(if (IGREATERP 1 N)
then (CAR LST)
else (CL:NTH (1- N)
(CDR LST])
(CREATE-STRUCTURE
(LAMBDA (A) (* JPG: "27-Mar-86 10:09")
(SETQ A (U-CASE-ATOMS A))
(DBIND (STRUCTURE-TYPE . ARGS)
A
(APPLY (PACK* 'MAKE- STRUCTURE-TYPE)
ARGS))))
(TRUNCATE
(LAMBDA (NUMBER DIVISOR) (* JPG: "27-Mar-86 10:37")
(* COND (DIVISOR (VALUES
(FIX (QUOTIENT NUMBER DIVISOR))
(REMAINDER NUMBER DIVISOR)))
(T (VALUES (FIX NUMBER) 0)))
(COND
(DIVISOR (FIX (QUOTIENT NUMBER DIVISOR)))
(T (FIX NUMBER)))))
(COLLAPSE-APPLY
(LAMBDA (FN ITEM) (* R.Noble "18-Feb-86 04:50")
(COND
((CONSTANTEXPRESSIONP FN)
(LIST (EVAL FN)
ITEM))
(T (LIST (QUOTE FUNCALL)
FN ITEM)))))
(ECASE.ERROR
(LAMBDA (VALUE LEGAL.VALS) (* R.Noble "12-Dec-85 14:56")
(ERROR (CONCAT VALUE "is not in legal values: ")
LEGAL.VALS)))
(KEYWORDP
(LAMBDA (OBJECT) (* tlm: "15-Jan-86 14:41")
(* * CommonLisp function for testing if OBJECT is a KEYWORD)
(TYPEP OBJECT (QUOTE KEYWORD))))
(SETF-SYMBOL-FUNCTION
(LAMBDA (FN DEF) (* tlm: " 9-Jan-86 09:44")
(PUT (THE SYMBOL FN)
DEF)))
(SIMPLE-LIST-POSITION
[LAMBDA (ITEM LST) (* R.Noble "19-Feb-86 09:55")
(for ELEM in LST as I from 0 when (EQ ELEM ITEM) do (RETURN I])
(SIMPLE-POSITION-DISPATCH
[LAMBDA (ITEM SEQUENCE) (* R.Noble "19-Feb-86 10:05")
(TYPECASE SEQUENCE (STRING (SIMPLE-STRING-POSITION ITEM SEQUENCE))
(CONS (SIMPLE-LIST-POSITION ITEM SEQUENCE])
(SIMPLE-STRING-POSITION
[LAMBDA (ITEM STRING) (* R.Noble "19-Feb-86 10:03")
(LET ((RESULT (STRPOSL (RPLACA (CONSTANT (CONS NIL))
(CHCON1 ITEM))
STRING)))
(if RESULT
then (1- RESULT])
(STRING-LESSP
(CL:LAMBDA (STRING1 STRING2 &KEY (START1 0)
(END1 MAX.SMALLP)
(START2 0)
(END2 MAX.SMALLP)) (* tlm: "11-Mar-86 11:32")
(* * Common Lisp STRING-LESSP function.)
(* * STRING1 -
First string or atom to compare.)
(* * STRING2 -
Second string or atom to compare.)
(* * START1 -
Start of the first string. By default it is 0)
(* * END1 -
End of the first string. By default the whole string will be used.)
(* * START2 -
Start of the second string. By default it is 0)
(* * END2 -
End of the second string. By default the whole string will be used.)
(* * operation -
Set the string pointers to start1 and start2 and compare character by
character the 2 string with case ignored for the character.)
(* * value -
NIL or T.)
(CL:DO ((PTR1 (ADD1 START1)
(ADD1 PTR1))
(PTR2 (ADD1 START2)
(ADD1 PTR2))
CH1 CH2)
((COND
((IGREATERP PTR1 END1)
(RETURN (AND (ILEQ PTR2 END2)
(NTHCHARCODE STRING2 PTR2))))
((IGREATERP PTR2 END2)
(RETURN NIL))
((NULL (SETQ CH1 (NTHCHARCODE STRING1 PTR1)))
(RETURN (NTHCHARCODE STRING2 PTR2)))
((NULL (SETQ CH2 (NTHCHARCODE STRING2 PTR2)))
(RETURN NIL))
((NEQ (SETQ CH1 (CHCON1 (U-CASE (CHARACTER CH1))))
(SETQ CH2 (CHCON1 (U-CASE (CHARACTER CH2)))))
(RETURN (ILESSP CH1 CH2)))
(T NIL))))))
(STRING-RIGHT-TRIM
(LAMBDA (CHAR-SET STRING) (* R.Noble "18-Dec-85 01:36")
(SUBSTRING STRING 1 (OR (STRPOSL (MAKEBITTABLE (CHCON CHAR-SET)
T)
STRING -1 NIL T)
0))))
(SYMBOL-FUNCTION
(LAMBDA (FN) (* tlm: " 9-Jan-86 09:38")
(GETD (THE SYMBOL FN))))
(VALUES-LIST
(LAMBDA (ARGLIST)
(DECLARE (SPECVARS ARGLIST)) (* tlm: "17-Jan-86 09:45")
(* * CommonLisp VALUES-LIST function)
(LET ((ARGS-TO-STACK (CDR ARGLIST))
TEMP-VALUES-STACK)
(DECLARE (SPECVARS *VALUES-STACK*))
(for ARG in ARGS-TO-STACK do (push TEMP-VALUES-STACK ARG))
(SETQ *VALUES-STACK* (DREVERSE TEMP-VALUES-STACK))
(CAR ARGLIST))))
(\CASE.TRANSLATE
(LAMBDA (KEY FORMS) (* tlm: " 9-Feb-86 20:27")
(LET ((KV (GENSYM "CASE-"))
(CLAUSES NIL))
(CL:DO
((C FORMS (CDR C)))
((CL:ATOM C))
(COND
((CL:ATOM (CAR C))
(CL:ERROR "~S -- Bad clause in CASE." (CAR C)))
((MEMQ (CAAR C)
(QUOTE (T OTHERWISE)))
(CL:PUSH (BQUOTE (T (\,@ (CDAR C))))
CLAUSES)
(RETURN NIL))
((NULL (CAAR C))
(CL:PUSH (BQUOTE ((NULL (\, KV))
(\,@ (CDAR C))))
CLAUSES))
((NOT (CONSP (CAAR C)))
(CL:PUSH (BQUOTE ((EQL (QUOTE (\, (CAAR C)))
(\, KV))
(\,@ (CDAR C))))
CLAUSES))
(T
(CL:PUSH
(BQUOTE
((OR (\,@ (CL:DO ((X (CAAR C)
(CDR X))
(Y NIL))
((CL:ATOM X)
(REVERSE Y))
(CL:PUSH (BQUOTE (EQL (QUOTE (\, (CAR X)))
(\, KV)))
Y))))
(\,@ (CDAR C))))
CLAUSES))))
(BQUOTE (LET (((\, KV)
(\, KEY)))
(COND
(\,@ (REVERSE CLAUSES))))))))
(\ECASE.TRANSLATE
(LAMBDA (FORM) (* tlm: "10-Jan-86 16:44")
(LET (CLAUSES CASES)
(CL:DO
((C (CDDR FORM)
(CDR C)))
((CL:ATOM C))
(COND
((OR (CL:ATOM (CAR C))
(MEMQ (CAAR C)
(QUOTE (T OTHERWISE))))
(CL:ERROR "~S -- Bad clause in ECASE." (CAR C)))
((NULL (CAAR C))
(CL:PUSH (BQUOTE ((NULL KV)
(\,@ (CDAR C))))
CLAUSES))
((NOT (CONSP (CAAR C)))
(CL:PUSH (CAAR C)
CASES)
(CL:PUSH (COND
((NUMBERP (CAAR C))
(BQUOTE ((EQL (QUOTE (\, (CAAR C)))
KV)
(\,@ (CDAR C)))))
(T (BQUOTE ((EQ (QUOTE (\, (CAAR C)))
KV)
(\,@ (CDAR C))))))
CLAUSES))
(T
(SETQ CASES (APPEND (REVERSE (CAAR C))
CASES))
(CL:PUSH
(BQUOTE
((OR
(\,@ (CL:DO ((X (CAAR C)
(CDR X))
(Y NIL))
((CL:ATOM X)
(REVERSE Y))
(CL:PUSH (COND
((NUMBERP (CAR X))
(BQUOTE (EQL (QUOTE (\, (CAR X)))
KV)))
(T (BQUOTE (EQ (QUOTE (\, (CAR X)))
KV))))
Y))))
(\,@ (CDAR C))))
CLAUSES))))
(BQUOTE ((OPENLAMBDA (KV)
(COND
(\,@ (REVERSE CLAUSES))
(T (ECASE.ERROR KV (QUOTE (\, (REVERSE CASES)))))))
(\, (CADR FORM)))))))
(\EVAL-WHEN-TRANSLATE
(LAMBDA (SITUATIONS-LIST FORMS) (* tlm: "16-Jan-86 17:33")
(* * Translator function for the CommonLisp special form EVAL-WHEN)
(BQUOTE (DECLARE: (\,@ (LET (FLAGS)
(MAPC SITUATIONS-LIST (FUNCTION (LAMBDA (SITUATION)
(SETQ SITUATION (CDR (ASSOC SITUATION
EVAL-WHEN-SITUATION-ALIST)))
(COND
((NULL SITUATION)
(ERROR
"Error: unknow EVAL-WHEN situation -"
SITUATION))
((NOT (MEMB SITUATION FLAGS))
(push FLAGS SITUATION))))))
FLAGS))
(\,@ FORMS)))))
)
(DECLARE: EVAL@COMPILE
(CONSTANTS EVAL-WHEN-SITUATION-ALIST)
(RPAQQ EVAL-WHEN-SITUATION-ALIST ((LOAD . DOEVAL@LOAD)
(COMPILE . DOEVAL@COMPILE)
(EVAL . DOEVAL@LOAD)
(COPY . DOCOPY)
(DONTCOPY . DONTCOPY)))
)
(ADDTOVAR CMLTRANSLATIONS (assoc . CL:ASSOC)
(block . CL:BLOCK)
(error . CL:ERROR)
(find . CL:FIND)
(mapc . CL:MAPC)
(nth . CL:NTH)
(pushnew . CL:PUSHNEW)
(setq . CL:SETQ))
(RPAQ? *PACKAGE* NIL)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD? 'REMAINDER 'REM)
(MOVD? 'DECLARE 'CL:DECLARE)
(MOVD? 'DEFINEDP 'FUNCTIONP)
(MOVD? 'MKSTRING 'PRINC-TO-STRING)
(MOVD? 'FRESHLINE 'FRESH-LINE)
(MOVD 'FQUOTIENT '%%/)
)
(* Advise makefile so that it doesn't use Fonts or Right-Brackets for printing files.)
(PUTPROPS MAKEFILE READVICE (NIL (AROUND NIL (RESETVARS (%#RPARS)
(RETURN *)))))
(READVISE MAKEFILE)
(* New implementation of the TTYIN ?= function to allow treatment of keywords)
(PUTPROPS SMARTARGLIST READVICE (NIL (AROUND NIL (PROG ((MACRODEF (OR (GETPROP FN
'DMACRO)
(GETPROP FN
'MACRO))))
(COND
((AND MACRODEF
(NULL (GETPROP FN 'ARGNAMES))
(MEMB (CAR MACRODEF)
'(DEFMACRO OPENLAMBDA)))
(RETURN (CADR MACRODEF)))
(T (RETURN *)))))))
(READVISE SMARTARGLIST)
(RPAQQ TTYIN?=FN NEW.TTYIN?=FN)
(DEFINEQ
(NEW.TTYIN?=FN
(LAMBDA (FN)
(DECLARE (SPECVARS FN)) (* tlm: "20-Feb-86 15:27")
(* * New function for TTYIN response to the command ?=.)
(* * FN -
Name of the current function.)
(* * environment -
This function should be set to use by TTYIN by setting the variable TTYIN?=FN to
NEW.TTYIN?=FN.)
(* * operation -
Get the arglist of the function or macro and the arguments already typed by the user.
Parse the arglist according to the Keyword defined in lambda-list-keywords.)
(* * effects -
Print the arguments of FN and the user already typed values.)
(* * value -
T)
(LET ((ARGTYPE (ARGTYPE FN))
(DEF (OR (GETDEF FN (QUOTE FNS)
(QUOTE CURRENT)
(QUOTE (NOERROR)))
(GETPROP FN (QUOTE DMACRO))
(GETPROP FN (QUOTE MACRO))))
ACTUALS ARGS ARGNAMES AL.INIT MACRO.ARGS MACRO.ARGS.&REST)
(SETQ AL.INIT (COND
((AND (FUNCTIONP FN)
(OR (LISTP (SETQ ARGNAMES (SMARTARGLIST FN)))
(LISTP (SETQ ARGNAMES (CADR (GETPROP FN (QUOTE ARGNAMES))))
)))
ARGNAMES)
((OR (GETDEF FN (QUOTE FNS)
(QUOTE CURRENT)
(QUOTE (NOERROR)))
(FMEMB (CAR DEF)
(QUOTE (DEFMACRO OPENLAMBDA))))
(* arguments for lambda, nlambda, glambda,
cl:lambda and defmacro)
(CADR DEF))
((HASDEF FN (QUOTE MACROS)) (* arguments for standard Interlisp macros.)
(SETQ MACRO.ARGS (CAR DEF))
(COND
((LITATOM MACRO.ARGS)
(SETQ ARGS MACRO.ARGS)
(SETQ ARGTYPE 3)
(SETQ ACTUALS (TTYIN.READ?=ARGS))
NIL)
((AND (SETQ MACRO.ARGS.&REST (CDR MACRO.ARGS))
(NLISTP MACRO.ARGS.&REST)) (* Standard Interlisp macro with a doted pair)
(CONS (CAR MACRO.ARGS)
(CONS (QUOTE &REST)
(LIST MACRO.ARGS.&REST))))
(T MACRO.ARGS)))
(T (SMARTARGLIST FN))))
(CL:DO ((AL AL.INIT (CDR AL))
(AC (TTYIN.READ?=ARGS))
KEYWORD KEY VALUE ARG ARGL ARGC)
((OR (NULL AL)
(NULL AC))
(AND AL (SETQ ARGS (NCONC ARGS (OR (AND KEYWORD (CONS KEYWORD AL))
AL)))))
(SETQ ARGL (CAR AL))
(SETQ ARGC (CAR AC))
(COND
((FMEMB ARGL (CONSTANT LAMBDA-LIST-KEYWORDS))
(SETQ KEYWORD ARGL))
((NULL KEYWORD)
(SETQ ARGS (NCONC1 ARGS ARGL))
(SETQ ACTUALS (NCONC1 ACTUALS ARGC))
(SETQ AC (CDR AC)))
((EQ KEYWORD (QUOTE &OPTIONAL))
(SETQ ARGS (NCONC1 ARGS (OR (AND (LISTP ARGL)
(CAR ARGL))
ARGL)))
(SETQ ACTUALS (NCONC1 ACTUALS ARGC))
(SETQ AC (CDR AC)))
((FMEMB KEYWORD (QUOTE (&REST &WHOLE &BODY)))
(SETQ ARGS (NCONC1 ARGS ARGL))
(SETQ ACTUALS (NCONC1 ACTUALS AC))
(SETQ AC NIL))
((AND (EQ KEYWORD (QUOTE &KEY))
(FMEMB (SETQ KEY (MKATOM (CONCAT (QUOTE :)
(OR (AND (LISTP ARGL)
(CAR ARGL))
ARGL))))
AC))
(SETQ AC (NCONC (for X on AC until (EQ (CAR X)
KEY)
collect (CAR X) finally (SETQ VALUE
(CADR X)))
(COND
((EQ (QUOTE :)
(NTHCHAR VALUE 1))
(SETQ VALUE NIL)
(CDR (FMEMB KEY AC)))
(T (CDDR (FMEMB KEY AC))))))
(SETQ ARGS (NCONC1 ARGS KEY))
(SETQ ACTUALS (NCONC1 ACTUALS VALUE)))))
(TTYIN.PRINTARGS FN ARGS ACTUALS ARGTYPE)
T)))
)
(* Bug fixing of DEFSTRUCT.TRANSLATE)
(DEFINEQ
(NEW.DEFSTRUCT.TRANSLATE
(LAMBDA (TAIL) (* tlm: "12-Feb-86 11:21")
(LET ((DEFSTRUCT.DEF (OLD.DEFSTRUCT.TRANSLATE TAIL)))
(COND
((EQ (CAAR DEFSTRUCT.DEF)
(QUOTE RECORD))
(NCONC1 (CAR DEFSTRUCT.DEF)
(BQUOTE (TYPE? (EQLENGTH DATUM (\, (LENGTH (CADDAR
DEFSTRUCT.DEF)))))
))))
(DELETE (QUOTE DEFUN)
(CDR DEFSTRUCT.DEF)
:TEST
(FUNCTION (LAMBDA (IT EL)
(AND (EQ (CAR EL)
IT)
(NULL (CADR EL))))))
DEFSTRUCT.DEF)))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(AND (MOVD? 'DEFSTRUCT.TRANSLATE 'OLD.DEFSTRUCT.TRANSLATE)
(MOVD 'NEW.DEFSTRUCT.TRANSLATE 'DEFSTRUCT.TRANSLATE))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA STRING-LESSP)
)
(PUTPROPS CMLPATCH COPYRIGHT ("public domain" 1986 1901))
(DECLARE: DONTCOPY
(FILEMAP (NIL (8569 16049 (:TYPE 8579 . 8774) (CMLTRANSLATE 8776 . 10561) (COMPILE.FILE.DEFSTRUCT
10563 . 11843) (COMPILE.FILE.DEFUN 11845 . 12130) (CONSP 12132 . 12308) (FLOOR 12310 . 12928) (
MOD 12930 . 13357) (ROUND 13359 . 14195) (\CHECK-TYPE-FAIL 14197 . 14960) (\CL-LAMBDA-FNTYP 14962
. 16047)) (24453 33546 (CEILING 24463 . 25154) (CL:NTH 25156 . 25382) (CREATE-STRUCTURE 25384 .
25637) (TRUNCATE 25639 . 26060) (COLLAPSE-APPLY 26062 . 26311) (ECASE.ERROR 26313 . 26501) (
KEYWORDP 26503 . 26727) (SETF-SYMBOL-FUNCTION 26729 . 26882) (SIMPLE-LIST-POSITION 26884 . 27103)
(SIMPLE-POSITION-DISPATCH 27105 . 27363) (SIMPLE-STRING-POSITION 27365 . 27667) (STRING-LESSP
27669 . 29166) (STRING-RIGHT-TRIM 29168 . 29417) (SYMBOL-FUNCTION 29419 . 29560) (VALUES-LIST
29562 . 30050) (\CASE.TRANSLATE 30052 . 31269) (\ECASE.TRANSLATE 31271 . 32869) (
\EVAL-WHEN-TRANSLATE 32871 . 33544)) (34973 39060 (NEW.TTYIN?=FN 34983 . 39058)) (39107 39754 (
NEW.DEFSTRUCT.TRANSLATE 39117 . 39752)))))
STOP