(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10) (IL:FILECREATED "15-Mar-2024 20:39:04" IL:|{DSK}larry>il>medley>sources>CMLSPECIALFORMS.;4| 19873 :EDIT-BY "lmm" :CHANGES-TO (IL:VARS IL:CMLSPECIALFORMSCOMS) :PREVIOUS-DATE "15-Mar-2024 10:39:44" IL:|{DSK}larry>il>medley>sources>CMLSPECIALFORMS.;2| ) (IL:PRETTYCOMPRINT IL:CMLSPECIALFORMSCOMS) (IL:RPAQQ IL:CMLSPECIALFORMSCOMS ((IL:COMS (IL:COMS (IL:FUNCTIONS IDENTITY) (XCL:OPTIMIZERS IDENTITY)) (IL:FUNCTIONS UNLESS WHEN)) (IL:FUNCTIONS FLET LABELS IL:SELECTQ) (IL:COMS (IL:* IL:|;;| "DO DO* and support.") (IL:FUNCTIONS DO DO*) (IL:FUNCTIONS %DO-TRANSLATE)) (IL:COMS (IL:FUNCTIONS DOLIST DOTIMES) (IL:FUNCTIONS CASE)) (IL:COMS (IL:* IL:|;;| "hacks, These probably shouldn't be here") (IL:COMS (IL:* IL:|;;| "Hacks for Interlisp NLAMBDAs that should look like functions") (IL:PROP IL:MACRO IL:FRPTQ IL:SETN IL:SUB1VAR IL:*)) (IL:COMS (IL:FNS IL:BQUOTIFY) (IL:USERMACROS . `IL:UNCOMMA) (IL:VARS IL:*BQUOTE-COMMA* IL:*BQUOTE-COMMA-ATSIGN* IL:*BQUOTE-COMMA-DOT*) (IL:GLOBALVARS IL:*BQUOTE-COMMA* IL:*BQUOTE-COMMA-ATSIGN* IL:*BQUOTE-COMMA-DOT*)) (IL:COMS (IL:FNS IL:CLEAR-CLISPARRAY) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:ADDVARS (IL:MARKASCHANGEDFNS IL:CLEAR-CLISPARRAY))) ) (IL:P (PROCLAIM '(SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*)) (PROCLAIM (CONS 'SPECIAL IL:SYSSPECVARS)))) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLSPECIALFORMS) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA))))) (DEFUN IDENTITY (THING) (IL:* IL:|;;| "Returns what was passed to it. Default for :key options.") THING) (XCL:DEFOPTIMIZER IDENTITY (X) X) (DEFMACRO UNLESS (TEST &BODY BODY) `(COND (,(IL:NEGATE TEST) ,@BODY))) (DEFMACRO WHEN (TEST &BODY BODY) `(COND (,TEST ,@BODY))) (DEFMACRO FLET (FUNCTION-BINDINGS &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "This is only used by the old interpreter and compiler. The new ones treat FLET specially.") (LET ((FUNCTIONS (MAPCAR #'(LAMBDA (X) (CONS (GENSYM) X)) FUNCTION-BINDINGS))) `(,'LET ,(MAPCAR #'(LAMBDA (X) (XCL:DESTRUCTURING-BIND (FN-NAME FN-ARGLIST &REST FN-BODY) (CDR X) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY FN-BODY ENV T) `(,(CAR X) #'(LAMBDA ,FN-ARGLIST ,@DECLS (BLOCK ,FN-NAME ,@BODY)))))) FUNCTIONS) ,(XCL:WALK-FORM `(LOCALLY ,@BODY) :ENVIRONMENT ENV :WALK-FUNCTION #'(LAMBDA (FORM CONTEXT) (IF (OR (ATOM FORM) (NOT (EQ CONTEXT :EVAL))) FORM (COND ((MEMBER (CAR FORM) '(IL:FUNCTION FUNCTION) :TEST #'EQ) (DOLIST (Z FUNCTIONS FORM) (IF (EQ (CADR FORM) (CADR Z)) (RETURN (CAR Z))))) (T (DOLIST (Z FUNCTIONS FORM) (IF (EQ (CAR FORM) (CADR Z)) (RETURN `(FUNCALL ,(CAR Z) ,@(CDR FORM))))))))))))) (DEFMACRO LABELS (FUNCTION-BINDINGS &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "This is only used by the old interpreter and compiler. The new ones treat LABELS specially.") (IL:* IL:|;;;| "(Actually, the new compiler still uses this, but it will soon stop doing so.)") (LET ((FUNCTIONS (MAPCAR #'(LAMBDA (X) (CONS (GENSYM) X)) FUNCTION-BINDINGS))) `(,'LET ,(MAPCAR #'CAR FUNCTIONS) ,(XCL:WALK-FORM `(PROGN ,@(MAPCAR #'(LAMBDA (X) (XCL:DESTRUCTURING-BIND (FN-NAME FN-ARGLIST &REST FN-BODY) (CDR X) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY FN-BODY ENV T) `(SETQ ,(CAR X) #'(LAMBDA ,FN-ARGLIST ,@DECLS (BLOCK ,FN-NAME ,@BODY)))))) FUNCTIONS) (LOCALLY ,@BODY)) :ENVIRONMENT ENV :WALK-FUNCTION #'(LAMBDA (FORM CONTEXT) (IF (OR (ATOM FORM) (NOT (EQ CONTEXT :EVAL))) FORM (COND ((MEMBER (CAR FORM) '(IL:FUNCTION FUNCTION) :TEST #'EQ) (DOLIST (Z FUNCTIONS FORM) (IF (EQ (CADR FORM) (CADR Z)) (RETURN (CAR Z))))) (T (DOLIST (Z FUNCTIONS FORM) (IF (EQ (CAR FORM) (CADR Z)) (RETURN `(FUNCALL ,(CAR Z) ,@(CDR FORM))))))))))))) (DEFMACRO IL:SELECTQ (SELECTOR &REST FORMS) (COND ((EQUAL SELECTOR '(IL:SYSTEMTYPE)) (IL:* IL:|;;| "Special case required by the IRM. (selectq (systemtype) ...) mustn't even look at the untaken arms.") (LET ((TYPE (EVAL SELECTOR)) (TAIL FORMS)) (LOOP (IF (NULL (CDR TAIL)) (IL:* IL:|;;| "No more possibilities, so use the default.") (RETURN (CAR TAIL)) (IL:* IL:|;;| "Normal clause. Is this the one we want?") (WHEN (OR (EQ TYPE (CAAR TAIL)) (AND (CONSP (CAAR TAIL)) (MEMBER TYPE (CAAR TAIL) :TEST #'EQ))) (RETURN `(PROGN ,@(CDAR TAIL))))) (SETQ TAIL (CDR TAIL))))) (T (LET* ((KV (IF (SYMBOLP SELECTOR) SELECTOR (GENSYM))) (CLAUSES (XCL:WITH-COLLECTION (DO ((C FORMS (CDR C))) ((NULL C)) (XCL:COLLECT (COND ((NULL (CDR C)) `(T ,(CAR C))) ((NOT (CONSP (CAAR C))) `((EQ ,KV ',(CAAR C)) ,@(CDAR C))) (T `((OR ,@(MAPCAR #'(LAMBDA (X) `(EQ ,KV ',X)) (CAAR C))) ,@(CDAR C))))))))) (IF (EQ KV SELECTOR) `(COND ,@CLAUSES) `(LET ((,KV ,SELECTOR)) (DECLARE (IL:LOCALVARS ,KV)) (COND ,@CLAUSES))))))) (IL:* IL:|;;| "DO DO* and support.") (DEFMACRO DO (VARS END-TEST &BODY BODY &ENVIRONMENT ENV) (%DO-TRANSLATE VARS END-TEST BODY NIL ENV)) (DEFMACRO DO* (BINDS END-TEST &REST BODY &ENVIRONMENT ENV) (%DO-TRANSLATE BINDS END-TEST BODY T ENV)) (DEFUN %DO-TRANSLATE (VARS END-TEST BODY SEQUENTIALP ENV) (LET ((VARS-AND-INITIAL-VALUES (MAPCAR #'(LAMBDA (X) (IF (CONSP X) (LIST (CAR X) (CADR X)) (LIST X NIL))) VARS)) (SUBSEQUENT-VALUES (MAPCAN #'(LAMBDA (X) (AND (CONSP X) (CDDR X) `((,(CAR X) ,(CADDR X))))) VARS)) (TAG (GENSYM))) (IF SUBSEQUENT-VALUES (SETQ SUBSEQUENT-VALUES (CONS (IF SEQUENTIALP 'SETQ 'PSETQ) (APPLY 'APPEND SUBSEQUENT-VALUES)))) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY BODY ENV) `(,(IF SEQUENTIALP 'PROG* 'PROG) ,VARS-AND-INITIAL-VALUES ,@DECLS ,TAG (COND (,(CAR END-TEST) (RETURN (PROGN ,@(CDR END-TEST))))) ,@BODY ,SUBSEQUENT-VALUES (GO ,TAG))))) (DEFMACRO DOLIST ((VAR LISTFORM &OPTIONAL RESULTFORM) &BODY BODY &ENVIRONMENT ENV) (LET ((TAIL (GENSYM))) (MULTIPLE-VALUE-BIND (BODY DECL) (XCL:PARSE-BODY BODY ENV) `(,'LET ((,TAIL ,LISTFORM) ,VAR) ,@DECL (LOOP (SETQ ,VAR (CAR (OR ,TAIL ,@(IF RESULTFORM `((SETQ ,VAR NIL))) (RETURN ,RESULTFORM)))) ,@BODY (SETQ ,TAIL (CDR ,TAIL))))))) (DEFMACRO DOTIMES ((VAR COUNTFORM &OPTIONAL RESULTFORM) &BODY BODY &ENVIRONMENT ENV) (LET ((MAX (GENSYM))) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY BODY ENV) `(LET ((,MAX ,COUNTFORM) (,VAR 0)) ,@DECLS (LOOP (IF (>= ,VAR ,MAX) (RETURN ,RESULTFORM)) ,@BODY (SETQ ,VAR (1+ ,VAR))))))) (DEFMACRO CASE (SELECTOR &REST CASES) (LET* ((KV (IF (SYMBOLP SELECTOR) SELECTOR (GENSYM))) (CLAUSES (MAPCAR #'(LAMBDA (CASE) (LET ((KEY-LIST (CAR CASE)) (CONSEQUENTS (OR (CDR CASE) (LIST NIL)))) (COND ((MEMBER KEY-LIST '(T OTHERWISE) :TEST #'EQ) `(T ,@CONSEQUENTS)) ((NULL KEY-LIST) (WARN "~S used as a singleton key in ~S. You probably meant to use (~S)." NIL 'CASE NIL) '(NIL)) ((ATOM KEY-LIST) `((EQL ,KV ',KEY-LIST) ,@CONSEQUENTS)) (T `((OR ,@(MAPCAR #'(LAMBDA (X) `(EQL ,KV ',X)) KEY-LIST)) ,@CONSEQUENTS))))) CASES))) (IF (EQ KV SELECTOR) `(COND ,@CLAUSES) `(LET ((,KV ,SELECTOR)) (COND ,@CLAUSES))))) (IL:* IL:|;;| "hacks, These probably shouldn't be here") (IL:* IL:|;;| "Hacks for Interlisp NLAMBDAs that should look like functions") (IL:PUTPROPS IL:FRPTQ IL:MACRO (= . IL:RPTQ)) (IL:PUTPROPS IL:SETN IL:MACRO (= . IL:SETQ)) (IL:PUTPROPS IL:SUB1VAR IL:MACRO ((IL:X) (IL:SETQ IL:X (IL:SUB1 IL:X)))) (IL:PUTPROPS IL:* IL:MACRO ((IL:X . IL:Y) 'IL:X)) (IL:DEFINEQ (il:bquotify (il:lambda (il:form) (il:* il:|bvm:| "10-Jun-86 17:07") (il:* il:|turn| il:form il:|into| il:\a il:bquote il:|if| il:|it| il:|can.|  il:i\f il:|so,| il:|return| il:|it| il:|as| il:\a il:|list,| il:|otherwise,|  il:|return| nil) (cond ((il:listp il:form) (let ((il:fn (car il:form)) (il:tail (cdr il:form))) (and (il:listp il:tail) (or (null (cdr il:tail)) (and (il:listp (cdr il:tail)) (or (null (cddr il:tail)) (il:selectq il:fn ((cons il:nconc1) (il:*  "These take exactly two args, so if there are more, it's an error") nil) t)))) (il:selectq il:fn ('il:bquote (and (null (cdr il:tail)) (list (car il:tail)))) (list (list (il:|for| il:x il:|in| il:tail il:|join| (or (il:bquotify il:x) (list (list il:*bquote-comma* il:x)))))) ((cons list*) (list (il:append (or (il:bquotify (car il:tail)) (list (list il:*bquote-comma* (car il:tail)))) (or (car (il:bquotify (il:setq il:tail (cond ((and (eq il:fn 'list*) (cddr il:tail)) (cons 'list* (cdr il:tail))) (t (cadr il:tail)))))) (list (list il:*bquote-comma-atsign* il:tail)))))) ((il:append nconc il:nconc1) (let ((il:default (cond ((eq il:fn 'il:append) il:*bquote-comma-atsign*) (t il:*bquote-comma-dot*))) (il:bqcar (il:bquotify (car il:tail)))) (list (il:append (cond ((and il:bqcar (il:|for| (il:tl il:_ (il:setq il:bqcar (car il:bqcar))) il:|by| (cdr il:tl) il:|while| il:tl il:|never| (il:nlistp il:tl))) (il:* "Second condition catches (APPEND (CONS A 0) --), where the (CONS A 0) turns into (,A . 0) and then the APPEND would lose it. It will lose it at runtime, too, of course, but let's not remove mistakes from the source.") il:bqcar) (t (list (list il:default (car il:tail))))) (cond ((eq il:fn 'il:nconc1) (il:*  "Second arg is an element, not a segment") (or (il:bquotify (il:setq il:tail (cadr il:tail))) (list (list il:*bquote-comma* il:tail)))) (t (or (car (il:bquotify (il:setq il:tail (cond ((cddr il:tail) (cons il:fn (cdr il:tail))) (t (cadr il:tail)))))) (list (list il:default il:tail))))))))) nil)))) ((or (il:numberp il:form) (il:stringp il:form) (eq il:form t) (null il:form)) (list il:form)) (t nil)))) ) (IL:ADDTOVAR IL:USERMACROS (IL:UNCOMMA NIL (IL:IF (EQ (IL:\## 1) 'IL:BQUOTE) NIL ((IL:IF (EQ (IL:\## IL:!0 1) 'IL:BQUOTE) (IL:!0)))) (IL:I 2 (IL:\\UNCOMMA (IL:\## 2))))) (IL:ADDTOVAR IL:EDITMACROS (IL:BQUOTE NIL IL:UP (IL:ORR ((IL:I 1 (OR (CONS 'IL:BQUOTE (OR (IL:BQUOTIFY (IL:\## 1)) (IL:ERROR!))) (IL:ERROR!)))) ((IL:E 'IL:BQUOTE?))) 1)) (IL:ADDTOVAR IL:EDITCOMSA IL:BQUOTE IL:UNCOMMA) (IL:RPAQQ IL:*BQUOTE-COMMA* IL:\\\,) (IL:RPAQQ IL:*BQUOTE-COMMA-ATSIGN* IL:\\\,@) (IL:RPAQQ IL:*BQUOTE-COMMA-DOT* IL:\\\,.) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS IL:*BQUOTE-COMMA* IL:*BQUOTE-COMMA-ATSIGN* IL:*BQUOTE-COMMA-DOT*) ) (IL:DEFINEQ (il:clear-clisparray (il:lambda (il:name type il:reason) (il:* il:|bvm:| "25-Jun-86 12:59") (il:selectq il:reason ((t il:clisp) (il:*  "New definition or changed only by CLISP translation") nil) (clrhash il:clisparray)))) ) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:ADDTOVAR IL:MARKASCHANGEDFNS IL:CLEAR-CLISPARRAY) ) (PROCLAIM '(SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*)) (PROCLAIM (CONS 'SPECIAL IL:SYSSPECVARS)) (IL:PUTPROPS IL:CMLSPECIALFORMS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CMLSPECIALFORMS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (2492 2613 (IDENTITY 2492 . 2613)) (2681 2773 (UNLESS 2681 . 2773)) (2775 2845 (WHEN 2775 . 2845)) (2847 4614 (FLET 2847 . 4614)) (4616 6669 (LABELS 4616 . 6669)) (6671 8466 (IL:SELECTQ 6671 . 8466)) (8513 8624 (DO 8513 . 8624)) (8626 8738 (DO* 8626 . 8738)) (8740 10291 (%DO-TRANSLATE 8740 . 10291)) (10293 10883 (DOLIST 10293 . 10883)) (10885 11388 (DOTIMES 10885 . 11388)) (11390 12562 (CASE 11390 . 12562)) (13026 17696 (IL:BQUOTIFY 13039 . 17694)) (18899 19305 (IL:CLEAR-CLISPARRAY 18912 . 19303))))) IL:STOP