(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")

(IL:FILECREATED "16-May-90 14:43:08" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;2|
 20313  

      IL:|changes| IL:|to:|  (IL:VARS IL:CMLSPECIALFORMSCOMS)

      IL:|previous| IL:|date:| "13-Jun-88 18:25:25" 
IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)


; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:CMLSPECIALFORMSCOMS)

(IL:RPAQQ IL:CMLSPECIALFORMSCOMS

          ((IL:COMS (IL:FUNCTIONS LOOP)
                  (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)))))

(DEFMACRO LOOP
 (&REST FORMS)
   (LET ((TAG (GENSYM)))
        `(PROG NIL
               ,TAG
               ,@FORMS
               (GO ,TAG))))

(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:PUTPROPS IL:CMLSPECIALFORMS IL:COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 
1988 1990))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (13354 18024 (IL:BQUOTIFY 13367 . 18022)) (19227 19633 (IL:CLEAR-CLISPARRAY 19240 . 
19631)))))
IL:STOP