(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