(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL" BASE 10)
(il:filecreated "23-Dec-87 16:56:46" 
"{FireFS:CS:Univ Rochester}<Koomen>LispUsers>Lyric>PORT-CLFILE.;14" 13433  

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

      il:|previous| il:|date:| " 3-Nov-87 16:27:35" 
"{FireFS:CS:Univ Rochester}<Koomen>LispUsers>Lyric>PORT-CLFILE.;12")


; 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 (quote (import-clfile export-clfile)) (find-package "XCL")) (import (quote (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 #\; (function 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) (quote 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) (quote 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 (quote il:filetype)) :compile-file) (set (il:filecoms file-id) (nconc comslst (il:bquote ((il:prop (il:filetype il:makefile-environment) (il:\\\, file-id)))))) (pushnew file-id il:filelst) (il:markaschanged file-id (quote il:files) (quote 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)) (return (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 (quote il:makefile-environment))) (format t ";;; -*- Package: ~A; Syntax: ~A; Mode: Lisp; Base: ~D -*-" (string-capitalize (package-name *package*)) (let ((rdtblname (il:readtableprop *readtable* (quote 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 (il:dateformat il:no.leading.spaces)) (symbol-name file-id)) (let ((dates (get file-id (quote il:filedates)))) (when dates (format t "~&;;; Original source ~A created ~A" (cdar dates) (caar dates)))) (terpri) (terpri) (il:printcopyright file-id) (mapc (function clfile-export-filecom) (il:listp (il:gettopval (il:filecoms file-id)))) (namestring *standard-output*))))))
(export (quote (import-clfile export-clfile)) (find-package "XCL"))
(import (quote (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 (il:bquote (setf (get (quote (il:\\\, symbol)) (quote (il:\\\, prop))) (quote (il:\\\, val))))))))) (case (il:getfilepkgtype (car command) (quote command)) (il:fns (mapc (function (lambda (fn) (pprint (let ((def (il:getdef fn (quote il:fns)))) (ecase (car def) ((lambda) (il:bquote (defun (il:\\\, fn) (il:\\\,@ (cdr def))))) ((il:lambda) (il:bquote (defun (il:\\\, fn) (&optional (il:\\\,@ (second def))) (il:\\\,@ (cddr def)))))))))) (il:prettycom1 command t t))) (il:vars (mapc (function (lambda (var) (if (listp var) (il:bquote (defparameter (first var) (second var))) (il:bquote (defparameter (il:\\\, var) (quote (il:\\\, (il:gettopval var)))))))) (il:prettycom1 command t t))) (il:declare\: (let ((context (quote (load eval))) (when-clause t)) (do ((tail (il:prettycom1 command t t) (cdr tail))) ((null tail)) (case (car tail) ((il:eval@loadwhen) (pushnew (quote eval) context) (setq when-clause (if (eq when-clause t) (cadr tail) (il:bquote (and (il:\\\, (cadr tail)) (il:\\\, when-clause))))) (setq tail (cdr tail)) (il:* il:\; " consumes two tokens, one by the DO")) ((il:eval@compilewhen) (pushnew (quote compile) context) (setq when-clause (if (eq when-clause t) (cadr tail) (il:bquote (and (il:\\\, (cadr tail)) (il:\\\, when-clause))))) (setq tail (cdr tail))) ((il:copywhen) (pushnew (quote load) context) (setq when-clause (if (eq when-clause t) (cadr tail) (il:bquote (and (il:\\\, (cadr tail)) (il:\\\, 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 (quote load) context)) ((il:doeval@compile il:eval@compile) (pushnew (quote compile) context)) ((il:doeval@load il:eval@load) (pushnew (quote eval) context)) ((il:dontcopy) (setq context (remove (quote load) context))) ((il:donteval@compile) (setq context (remove (quote compile) context))) ((il:donteval@load) (setq context (remove (quote eval) context))) (t (format t "~&(eval-when &S " context) (clfile-export-filecom (car tail)) (format t ")")))))) ((il:specvars) (pprint (il:bquote (proclaim (quote (special (il:\\\,@ (il:prettycom1 command t t)))))))) ((il:globalvars) (pprint (il:bquote (proclaim (quote (global (il:\\\,@ (il:prettycom1 command t t)))))))) ((il:localvars) (pprint (il:bquote (proclaim (quote (lexical (il:\\\,@ (il:prettycom1 command t t)))))))) ((il:prop il:ifprop) (prog ((optional (eq (car command) (quote 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 (function (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 (function do-prop) props)) ((eq props (quote 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 (function (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 (function (lambda (x) (declare (special il:commentflg)) (pprint (cond ((listp x) (if (eq (car x) il:commentflg) x (il:bquote (defvar (il:\\\,@ x))))) (t (help)))))) (il:prettycom1 command t t))) (il:coms (mapc (function clfile-export-filecom) (il:prettycom1 command t))) ((il:*) (cond ((eq (cadr command) (quote 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 (function 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:bquote (il:p (il:\\\, clform)))) ((eq (car clform) (quote il:*)) clform) ((let ((comstype (get (car clform) (quote 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 (quote il:globalvars) (cdr declspec))) (special (cons (quote il:specvars) (cdr declspec))) (lexical (cons (quote 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:bquote (il:declare\: (il:\\\, (if evalflg (quote il:eval@load) (quote il:donteval@load))) (il:\\\, (if loadflg (quote il:copy) (quote il:dontcopy))) (il:\\\, (if compileflg (quote il:eval@compile) (quote il:donteval@compile))) (coms (il:\\\,@ (mapcar (function clfile-parse-form) (caddr clform)))))))))) (t (il:bquote (il:p (il:\\\, 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* (quote il:name) (il:readtableprop object (quote il:name))) (set-macro-character #\; (function 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 (quote il:makefile-environment)) (list :package (package-name *package*) :readtable (let ((rdtblname (il:readtableprop *readtable* (quote 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 (quote il:*) (cond ((> lvl 2) (quote il:|;;;|)) ((= lvl 2) (quote il:|;;|)) (t (quote il:\;))) (string-trim (quote (#\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