(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL" BASE 10)

(il:filecreated " 3-Nov-87 16:27:35" 
"{FireFS:CS:Univ Rochester}<Koomen>LispUsers>Lyric>PORT-CLFILE.;12"
 23613  

      il:|changes| il:|to:|  (il:functions export-clfile import-clfile clfile-export-filecom)

      il:|previous| il:|date:| "28-Oct-87 14:24:40" 
"{FireFS:CS:Univ Rochester}<Koomen>LispUsers>Lyric>PORT-CLFILE.;10")


; Copyright (c) 1987 by Johannes Koomen, Larry Masinter.  All rights reserved.

(il:prettycomprint il:port-clfilecoms)

(il:rpaqq il:port-clfilecoms
 ((il:functions import-clfile export-clfile)
                              (il:p (export '(import-clfile export-clfile) (find-package "XCL"))
                                    (import '(import-clfile export-clfile) (find-package "INTERLISP")
                                           ))
                              (il:functions clfile-export-filecom clfile-parse-form clfile-parse-mode 
                                     clfile-read-semi clfile-set-mode)
                              (il:prop (il:filetype il:makefile-environment)
                                     il:port-clfile)))

(defun import-clfile
 (filepath) 
                               "Load a standard CommonLisp file FILEPATH, creating COMS for FILEPATH"
   (with-open-file (*standard-input* filepath :direction :input)
          (declare
 (special *standard-input*))
          (let ((*package* (find-package "USER"))
                (*readtable* (copy-readtable nil))
                (*read-base* 10)
                (comslst nil)
                (eof-value (list :eof))
                (file-id (intern (string-upcase (pathname-name *standard-input*))
                                (find-package "INTERLISP"))))
               (declare
 (special *package* *readtable* *read-base*))
          
          (il:* il:|;;| "Copy readtable, change ; macro to preserve comments")


               (set-macro-character #\; #'clfile-read-semi nil *readtable*)
               (do ((clform (read nil nil eof-value)
                           (read nil nil eof-value))
                    (firstclformp t)
                    (nextcomsentry nil)
                    (lastcomsentry nil)
                    (nextcomsweirdp nil))
                   ((eq clform eof-value)
                    (if lastcomsentry (push lastcomsentry comslst))
                    (setq comslst (nreverse comslst)))
                   (when firstclformp (setq firstclformp nil)
                         (cond
                            ((and (consp clform)
                                  (eq (car clform)
                                      'il:*)
                                  (do ((cltail (cdr clform)
                                              (cdr cltail)))
                                      ((not (consp cltail))
                                       nil)
                                      (if (stringp (car cltail))
                                          (return (clfile-parse-mode (car cltail)
                                                         file-id)))))
                             (setq clform nil))))
                   (unless (null clform)
                          (eval clform)
                          (setq nextcomsentry (clfile-parse-form clform))
                          (setq nextcomsweirdp (or (eq (car nextcomsentry)
                                                       'il:*)
                                                   (consp (cddr nextcomsentry))))
                          (when (and lastcomsentry (or nextcomsweirdp (not (eq (car nextcomsentry)
                                                                               (car lastcomsentry))))
                                     )
                                (push lastcomsentry comslst)
                                (setq lastcomsentry nil))
                          (cond
                             (nextcomsweirdp (push nextcomsentry comslst))
                             (lastcomsentry (nconc lastcomsentry (cdr nextcomsentry)))
                             (t (setq lastcomsentry nextcomsentry)))))
               (setf (get file-id 'il:filetype)
                     :compile-file)
               (set (il:filecoms file-id)
                    (nconc comslst `((il:prop (il:filetype il:makefile-environment)
                                            ,file-id))))
               (pushnew file-id il:filelst)
               (il:markaschanged file-id 'il:files 'il:defined)
               file-id)))


(defun export-clfile
 (filepath &optional (linelength 72)) 
                                 "Write a standard CommonLisp file FILEPATH, using COMS for FILEPATH"
   (declare
 (global il:filelinelength))
   (il:resetvars ((il:filelinelength linelength))
                 (with-open-file (*standard-output* (make-pathname :type "LISP" :version :newest 
                                                           :defaults filepath)
                                        :direction :output)
                        (declare
 (special *standard-output*))
                        (let ((*package* (find-package "USER"))
                              (*readtable* (il:find-readtable "LISP"))
                              (*print-base* 10)
                              (*print-array* t)
                              (*print-level* nil)
                              (*print-length* nil)
                              (il:fontchangeflg nil)
                              (il:\#rpars nil)
                              (il:**comment**flg nil)
                              (il:*print-semicolon-comments* t)
                              (il:*print-structure* t)
                              (file-id (intern (string-upcase (pathname-name *standard-output*))
                                              (find-package "INTERLISP"))))
                             (declare
 (special *package* *readtable* *print-base* *print-array* 
                                             *print-level* *print-length* il:fontchangeflg il:\#rpars 
                                             il:**comment**flg il:*print-semicolon-comments* 
                                             il:*print-structure*))
                             (clfile-set-mode (get file-id 'il:makefile-environment))
                             (format t ";;; -*- Package: ~A; Syntax: ~A; Mode: Lisp; Base: ~D -*-"
                                    (string-capitalize (package-name *package*))
                                    (let ((rdtblname (il:readtableprop *readtable* 'il:name)))
                                         (cond
                                            ((or (not (stringp rdtblname))
                                                 (string-equal rdtblname "XCL")
                                                 (string-equal rdtblname "LISP"))
                                             "Common-Lisp")
                                            (t (string-capitalize rdtblname))))
                                    *print-base*)
                             (format t "~2%;;; File converted on ~A from source ~A" (il:date)
                                    file-id)
                             (let ((dates (get file-id 'il:filedates)))
                                  (when dates (format t "~&;;; Original source ~A created ~A"
                                                     (cdar dates)
                                                     (caar dates))))
                             (terpri)
                             (terpri)
                             (il:printcopyright file-id)
                             (mapc #'clfile-export-filecom (il:listp (il:gettopval (il:filecoms
                                                                                    file-id))))
                             (namestring *standard-output*)))))

(export '(import-clfile export-clfile) (find-package "XCL"))
(import '(import-clfile export-clfile) (find-package "INTERLISP"))

(defun clfile-export-filecom
 (command)
   (flet
    ((save-prop (symbol prop val)
            (case prop ((il:filetype il:makefile-environment)(il:* il:\; "IGNORE")


                        nil)
                  (t (pprint `(setf (get ',symbol ',prop)
                                    ',val))))))
    (case (il:getfilepkgtype (car command)
                 'command)
          (il:fns
           (mapc #'(lambda (fn)
                          (pprint (let ((def (il:getdef fn 'il:fns)))
                                       (ecase (car def)
                                              ((lambda)
                                               `(defun (il:\\\,
 fn) ,@(cdr def) )
)
                                              ((il:lambda)
                                               `(defun (il:\\\,
 fn) (&optional ,@(second def))
                                                   ,@(cddr def))
))))) (il:prettycom1 command t t)))
          (il:vars (mapc #'(lambda (var)
                                  (if (listp var)
                                      `(defparameter (first
 var) (second var) )

                                      `(defparameter (il:\\\,
 var) ',(il:gettopval var) )
)) (il:prettycom1 command t t)))
          (il:declare\:
 (let ((context '(load eval))
                              (when-clause t))
                             (do ((tail (il:prettycom1 command t t)
                                        (cdr tail)))
                                 ((null tail))
                                 (case (car tail)
                                       ((il:eval@loadwhen)
                                        (pushnew 'eval context)
                                        (setq when-clause (if (eq when-clause t)
                                                              (cadr tail)
                                                              `(and ,(cadr tail) ,when-clause)))
                                        (setq tail (cdr tail))
                                                             (il:* il:\; 

                                                             " consumes two tokens, one by the DO")


                                        )
                                       ((il:eval@compilewhen)
                                        (pushnew 'compile context)
                                        (setq when-clause (if (eq when-clause t)
                                                              (cadr tail)
                                                              `(and ,(cadr tail) ,when-clause)))
                                        (setq tail (cdr tail)))
                                       ((il:copywhen)
                                        (pushnew 'load context)
                                        (setq when-clause (if (eq when-clause t)
                                                              (cadr tail)
                                                              `(and ,(cadr tail) ,when-clause)))
                                        (setq tail (cdr tail)))
                                       ((il:first
 il:notfirst)
                                                             (il:* il:\; "IGNORE")


                                        )
                                       ((il:compilervars)
          
          (il:* il:|;;| "throw these out")


                                        (return-from clfile-export-filecom nil))
                                       ((il:copy il:docopy)
                                        (pushnew 'load context))
                                       ((il:doeval@compile il:eval@compile)
                                        (pushnew 'compile context))
                                       ((il:doeval@load il:eval@load)
                                        (pushnew 'eval context))
                                       ((il:dontcopy)
                                        (setq context (remove 'load context)))
                                       ((il:donteval@compile)
                                        (setq context (remove 'compile context)))
                                       ((il:donteval@load)
                                        (setq context (remove 'eval context)))
                                       (t (format t "~&(eval-when &S " context)
                                          (clfile-export-filecom (car tail))
                                          (format t ")"))))))
          ((il:specvars)
           (pprint `(proclaim '(special ,@(il:prettycom1 command t t)))))
          ((il:globalvars)
           (pprint `(proclaim '(global ,@(il:prettycom1 command t t)))))
          ((il:localvars)
           (pprint `(proclaim '(lexical ,@(il:prettycom1 command t t)))))
          ((il:prop il:ifprop)
           (prog ((optional (eq (car command)
                                'il:ifprop))
                  (props (cadr command))
                  (not-found "NOT ON ANY PROPERTY LIST")
                  (symbols (il:prettycom1 (cdr command)
                                  t t)))                     (il:* il:\; 

                                          "IFPROP only dumps those property values that are non-NIL.")


                 (mapc #'(lambda (symbol)
                                (declare
 (special il:sysprops))
                                (flet ((do-prop (prop)
                                              (unless (and optional (eq not-found
                                                                        (get symbol prop not-found)))
                                                     (save-prop symbol prop (get symbol prop)))))
                                      (cond
                                         ((consp props)
                                          (mapc #'do-prop props))
                                         ((eq props 'il:all)
                                          (do ((tail (symbol-plist symbol)
                                                     (cddr tail)))
                                              ((null tail))
                                              (unless (member (car tail)
                                                             il:sysprops)
                                                     (do-prop (car tail)))))
                                         (t (do-prop props))))) symbols)))
          (il:p (mapc #'(lambda (x)
                               (case (car x)
                                     ((il:putprops)
                                      (do ((tail (cdr x)
                                                 (cdddr tail)))
                                          ((null tail))
                                          (save-prop (first tail)
                                                 (second tail)
                                                 (third tail))))
                                     (t (pprint x)))) (il:prettycom1 command t)))
          (il:initvars (mapc #'(lambda (x)
                                      (declare
 (special il:commentflg))
                                      (pprint (cond
                                                 ((listp x)
                                                  (if (eq (car x)
                                                          il:commentflg)
                                                      x
                                                      `(defvar (il:\\\,@
 x) )
))
                                                 (t (help))))) (il:prettycom1 command t t)))
          (il:coms (mapc #'clfile-export-filecom (il:prettycom1 command t)))
          (                                                  (il:*)

           (cond
              ((eq (cadr command)
                   'il:*)                                    (il:* il:\; 

                 "Form-feed if super-comment indicated.  Use * no matter what current COMMENTFLG is.")


               (write-char #\Page)))
           (pprint command))
          (t (let ((def (cdr (assoc (car command)
                                    il:prettydefmacros))))
                  (if def (mapc #'clfile-export-filecom (il:subpair (car def)
                                                               (il:prettycom1 command t t)
                                                               (cdr def)))
                      (help "CAN'T HANDLE" (car command))))))))


(defun clfile-parse-form
 (clform) "Given CommonLisp FORM, creates (filepkgtype object)"
   (cond
      ((or (not (consp clform))
           (not (symbolp (car clform))))
       `(il:p ,clform))
      ((eq (car clform)
           'il:*)
       clform)
      ((let ((comstype (get (car clform)
                            'il:definer-for))
             (comsname (cadr clform)))
            (if comstype (list comstype (if (consp comsname) (il:* il:\; "e.g. STRUCTURES")


                                            (car comsname)
                                            comsname)))))
      ((case (car clform)
             (proclaim (let ((declspec (car (il:constantexpressionp (cadr clform)))))
                            (case (car declspec)
                                  (global (cons 'il:globalvars (cdr declspec)))
                                  (special (cons 'il:specvars (cdr declspec)))
                                  (lexical (cons 'il:localvars (cdr declspec))))))
             (eval-when (let (evalflg loadflg compileflg)
                             (do ((context (cadr clform)
                                         (cdr context)))
                                 ((null context))
                                 (case (car context)
                                       (eval (setq evalflg t))
                                       (load (setq loadflg t))
                                       (compile (setq compileflg t))))
                             `(il:declare\:
 ,(if evalflg 'il:eval@load 'il:donteval@load)
                                     ,(if loadflg 'il:copy 'il:dontcopy)
                                     ,(if compileflg 'il:eval@compile 'il:donteval@compile)
                                     (coms ,@(mapcar #'clfile-parse-form (caddr clform))))))))
      (t `(il:p ,clform))))


(defun clfile-parse-mode
 (mode-string &optional file-id) 
                         "Setf *PACKAGE*, *READTABLE* and *READ-BASE* according to file mode comment"
   (declare
 (special *package* *readtable* *read-base*))
   (when (search "-*-" mode-string :end2 3)
         (prog ((modestr (string-upcase mode-string))
                modepos modename object)
               (when (setq modepos (search "PACKAGE: " modestr))
                     (setq modename (string (read-from-string modestr nil nil :start
                                                   (+ modepos (length "PACKAGE: ")))))
                     (setq object (find-package modename))
                     (cond
                        ((packagep object)
                         (setq *package* object))
                        (t (error "~&Non-existent package: ~A~%" modename))))
               (when (setq modepos (search "SYNTAX: " modestr))
                     (setq modename (string (read-from-string modestr nil nil :start
                                                   (+ modepos (length "SYNTAX: ")))))
                     (if (string-equal modename "COMMON-LISP")
                         (setq modename "LISP"))
                     (setq object (il:find-readtable modename))
                     (cond
                        ((readtablep object)
          
          (il:* il:|;;| "Need to continue intercepting comments!")


                         (setq *readtable* (copy-readtable object))
                         (il:readtableprop *readtable* 'il:name (il:readtableprop object 'il:name))
                         (set-macro-character #\; #'clfile-read-semi nil *readtable*))
                        (t (error "~&Non-existent readtable: ~A~%" modename))))
               (when (setq modepos (search "BASE: " modestr))
                     (setq object (read-from-string modestr nil nil :start (+ modepos (length 
                                                                                             "BASE: "
                                                                                             ))))
                     (cond
                        ((and (numberp object)
                              (> object 0))
                         (setq *read-base* (truncate object)))
                        (t (error "~&Bad read base: ~A~%" object))))
               (when file-id (setf (get file-id 'il:makefile-environment)
                                   (list :package (package-name *package*)
                                         :readtable
                                         (let ((rdtblname (il:readtableprop *readtable* 'il:name)))
                                              (cond
                                                 ((or (not (stringp rdtblname))
                                                      (string-equal rdtblname "LISP"))
                                                  "XCL")
                                                 (t rdtblname)))
                                         :base *read-base*)))
               (return t))))


(defun clfile-read-semi
 (stream rdtbl) "A ; was seen.  Collect more ;'s, then wrap comment in IL:*"
   (declare
 (ignore rdtbl))
   (do ((ch (read-char stream)
            (read-char stream))
        (lvl 1)
        (comment ""))
       ((or (null ch)
            (not (char= ch #\;)))
        (unread-char ch stream)
        (cond
           ((setq comment (read-line stream))
            (list 'il:* (cond
                           ((> lvl 2)
                            'il:|;;;|)
                           ((= lvl 2)
                            'il:|;;|)
                           (t 'il:\;))
                  (string-trim '(#\Space #\Tab) comment)))))
       (incf lvl 1)))


(defun clfile-set-mode
 (makefile-environment) 

(il:* il:|;;;| "Using the MAKEFILE-ENVIRONMENT, sets the appropriate free vars (bound above in EXPORT-CLFILE) to the specified package, readtable and print base.")

 (declare
 (special *package* *readtable* *print-base*))
 (let ((file-package (getf makefile-environment :package))
       (read-table (getf makefile-environment :readtable))
       (print-base (getf makefile-environment :base)))
      (let ((pkg (if (stringp file-package)
                     (find-package file-package)
                     (eval file-package))))
           (when (packagep pkg)
                 (setq *package* pkg)))
      (let ((rdtbl (if (stringp read-table)
                       (il:find-readtable read-table)
                       (eval read-table))))
           (when (readtablep rdtbl)
                 (setq *readtable* rdtbl)))
      (let ((base (if (numberp print-base)
                      print-base
                      (eval print-base))))
           (when (numberp base)
                 (setq *print-base* base)))))


(il:putprops il:port-clfile il:filetype
 :compile-file)

(il:putprops il:port-clfile il:makefile-environment
 (:readtable "XCL" :package "XCL" :base 10))
(il:putprops il:port-clfile il:copyright ("Johannes Koomen, Larry Masinter" 1987))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop