-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathXCL-BRIDGE
93 lines (44 loc) · 22.4 KB
/
XCL-BRIDGE
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
(il:filecreated "15-Feb-89 15:42:25" il:|{DSK}/pooh/pedersen/lisp/XCL-BRIDGE.;2| 22921
il:|changes| il:|to:| (il:vars il:xcl-bridgecoms) (il:variables *bridging*) (il:functions managed-to-text-file text-to-managed-file)
il:|previous| il:|date:| " 6-Dec-88 17:22:36" il:|{DSK}/pooh/pedersen/lisp/XCL-BRIDGE.;1|)
; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:xcl-bridgecoms)
(il:rpaqq il:xcl-bridgecoms ((il:declare\: il:docopy il:donteval@load il:donteval@compile (il:p (export (quote (text-to-managed-file managed-to-text-file *bridging*)) (find-package "XCL")))) (il:coms (il:* il:|;;| " indicator free variable") (il:variables *bridging*)) (il:coms (il:* il:|;;| "From Text to manager format") (il:variables *eof-marker*) (il:functions text-to-managed-file) (il:functions construct-coms install-file) (il:functions read-semicolon-comment make-semicolon-comment probe-for-mode-line) (il:functions combine-comments comment-p comment-combineable-p do-combine-comments) (il:functions process-definitions definer-type find-definition)) (il:coms (il:* il:|;;| "From manager to text format ") (il:functions managed-to-text-file) (il:functions construct-mode-line get-coms-forms make-comment)) (file-environments "XCL-BRIDGE") (il:coms (il:* il:|;;| "comment identity preservation hack") (il:variables *preserve-comment-start-char* *preserve-comment-start-charcode*) (il:functions initial-comment-line-p fix-comment-?) (il:advice (il:concat :in il:prin2-long-string) (il:prin1 :in il:prin2-long-string)))))
(il:declare\: il:docopy il:donteval@load il:donteval@compile
(export (quote (text-to-managed-file managed-to-text-file *bridging*)) (find-package "XCL"))
)
(il:* il:|;;| " indicator free variable")
(defvar *bridging* nil "True while dynamically within the XCL-BRIDGE")
(il:* il:|;;| "From Text to manager format")
(defparameter *eof-marker* "eof")
(defun text-to-managed-file (pathname filename &key (package "USER" package-p) (readtable "XCL" readtable-p) (read-base 10 read-base-p) (compiler :compile-file) (combine-comments-p t)) (prog ((rootname (intern (string filename) (find-package "INTERLISP"))) forms first-form coms) (with-open-file (stream pathname :direction :input) (multiple-value-setq (package readtable read-base first-form) (probe-for-mode-line stream package package-p readtable readtable-p read-base read-base-p)) (il:* il:|;;| "Declare read environment") (format t "Using the following read environment:~%Package: ~a Readtable: ~a Read-base: ~a~%" package readtable read-base) (unless (y-or-n-p "Do you wish to continue? ") (return nil)) (let ((*package* (find-package package)) (*readtable* (copy-readtable (il:find-readtable readtable))) (*read-base* read-base) (*bridging* t)) (il:* il:|;;| "Setup for reading comments properly") (set-macro-character #\; (quote read-semicolon-comment) nil *readtable*) (setq forms (with-collection (do ((form (read stream nil *eof-marker*) (read stream nil *eof-marker*))) ((eq form *eof-marker*)) (unless package-p (if (eq (car form) (quote in-package)) (let ((new-package-name (string (eval (second form))))) (when (not (string= new-package-name package)) (warn "*** Encountered in-package form: Changing to ~a package" new-package-name) (setq package (package-name (eval form))))))) (collect form)))) (if first-form (setq forms (cons first-form forms))) (when combine-comments-p (format t "Combining comments..~%") (setq forms (combine-comments forms))))) (when (y-or-n-p "Edit the forms read prior to constructing a coms list? ") (sedit:sedit forms) (unless (y-or-n-p "Do you wish to continue? ") (return nil))) (setq coms (construct-coms forms)) (when (y-or-n-p "Edit the coms prior to installing the file? ") (sedit:sedit coms) (unless (y-or-n-p "Do you wish to continue? ") (return nil))) (when (y-or-n-p "Install file? ") (return (install-file rootname coms forms :package package :readtable readtable :read-base read-base :compiler compiler)))))
(defun construct-coms (forms) (il:* il:|;;| "Constructs a file coms expression for a list of top-level forms") (let ((coms nil) (current-definitions nil) (current-type :none) (definer-type nil)) (dolist (form forms) (setq definer-type (definer-type form)) (when (and (not (eq current-type definer-type)) current-definitions) (setq coms (process-definitions current-definitions current-type coms)) (setq current-definitions nil current-type :none)) (cond ((eq definer-type :eval-when) (setq coms (nconc coms (il:bquote ((eval-when (il:\\\, (cadr form)) (il:\\\,@ (construct-coms (cddr form))))))))) (t (setq current-type definer-type) (push form current-definitions)))) (when current-definitions (setq coms (process-definitions current-definitions current-type coms))) coms))
(defun install-file (name coms forms &key (package "USER") (readtable "XCL") (read-base 10) (compiler :compile-file)) (labels ((install-definitions (coms forms) (dolist (form forms) (let ((def-type (definer-type form)) name) (cond ((eq def-type :eval-when) (install-definitions coms (cddr form))) ((and def-type (not (eq def-type :comment))) (setq name (%definer-name (car form) (remove-comments form))) (when (find-definition name def-type coms) (il:* il:|;;| "Save Definition") (%define-type-save-defn name def-type form)))))))) (setq forms (nconc forms (il:bquote ((define-file-environment (il:\\\, (string name)) :package (il:\\\, package) :readtable (il:\\\, readtable) :base (il:\\\, read-base) :compiler (il:\\\, compiler)))))) (setq coms (nconc coms (il:bquote ((file-environments (il:\\\, (string name))))))) (install-definitions coms forms) (let ((root-name (intern (string name) (find-package "INTERLISP")))) (set (il:filecoms root-name) coms) (il:addfile name) (setf (get root-name (quote il:filetype)) compiler) (setf (get root-name (quote il:makefile-environment)) (il:bquote (:readtable (il:\\\, readtable) :package (il:\\\, package) :base (il:\\\, read-base)))) root-name)))
(defun read-semicolon-comment (stream &optional disp-char) (il:* il:|;;| "Adjacent comments of the same level are smashed together during an after-read pass over the structure.") (declare (ignore disp-char)) (let ((level (let ((value 0) (ch nil)) (loop (when (not (eql (setq ch (read-char stream)) #\;)) (unread-char ch stream) (return value)) (incf value))))) (make-semicolon-comment (read-line stream) level)))
(defun make-semicolon-comment (string level) (il:bquote (il:* (il:\\\, (cdr (assoc (mod level 3) (quote ((0 . il:\;) (1 . il:|;;|) (2 . il:|;;;|))) :test (function eq)))) (il:\\\, (string-trim (quote (#\Space #\Tab)) string)))))
(defun probe-for-mode-line (stream package package-p readtable readtable-p read-base read-base-p) (il:* il:\; "Edited 4-Aug-88 15:13 by ht:") (let* ((mode-form (do ((ch (read-char stream) (read-char stream))) ((not (member ch (quote (#\Space #\Newline #\Tab)) :test (function eq))) (unread-char ch stream) (if (eq ch #\;) (read-semicolon-comment stream))))) (mode-string (and mode-form (string= (third mode-form) "-*-" :end1 3) (string-upcase (third mode-form) :start 3)))) (when mode-string (let ((package-marker "PACKAGE:") (syntax-marker "SYNTAX:") (base-marker "BASE:") mode-position mode-name) (when (and (null package-p) (setq mode-position (search package-marker mode-string))) (let* ((package-form (read-from-string mode-string nil nil :start (+ mode-position (length package-marker)))) (package-name (string (if (consp package-form) (car package-form) package-form)))) (setq package (if (find-package package-name) package-name (progn (cerror "Create it and carry on" "~&Non-existent package: ~S~%" package-name) (if (consp package-form) (let ((use-list (or (second (member :use package-form :test (function eq))) (second package-form))) (nicknames (second (member :nicknames package-form :test (function eq))))) (make-package package-name :use (or use-list "LISP") :nicknames nicknames)) (make-package package-name))))))) (when (packagep package) (setq package (string (package-name package)))) (when (and (null readtable-p) (setq mode-position (search syntax-marker mode-string))) (setq mode-name (string (read-from-string mode-string nil nil :start (+ mode-position (length syntax-marker))))) (if (or (string= mode-name "LISP") (string= mode-name "COMMON-LISP")) (setq mode-name "XCL")) (if (not (il:find-readtable mode-name)) (error "~&Non-existent readtable: ~A~%" mode-name)) (setq readtable mode-name)) (when (readtablep readtable) (let ((name (il:readtableprop readtable (quote il:name)))) (if (null name) (error "Readtable ~s has no name." readtable) (setq readtable name)))) (when (and (null read-base-p) (setq mode-position (search base-marker mode-string))) (setq mode-name (read-from-string mode-string nil nil :start (+ mode-position (length base-marker)))) (if (not (and (numberp mode-name) (> mode-name 0))) (error "~&Bad read base: ~A~%" mode-name)) (setq read-base mode-name)))) (values package readtable read-base (il:* il:|;;| "Return a non-mode line comment, if necessary") (and (null mode-string) mode-form))))
(defun combine-comments (x) (il:* il:\; "Edited 10-Aug-88 10:19 by ht:") (il:* il:|;;;| "Smash together adjacent sedit comments at the same level.") (cond ((not (consp x)) x) ((and (comment-p (car x)) (comment-p (cadr x)) (comment-combineable-p (car x) (cadr x))) (il:* il:|;;| "At least two adjacent comments at the same level ") (let ((tail (cddr x)) (matcher (cadr (car x))) (comments (list (car x) (cadr x)))) (nconc comments (with-collection (loop (if (not (and (comment-p (car tail)) (eq (cadr (car tail)) matcher) (not (initial-comment-line-p (caddr (car tail)))))) (return nil)) (collect (car tail)) (setq tail (cdr tail))))) (fix-comment-? (car comments)) (cons (do-combine-comments comments matcher) (combine-comments tail)))) (t (fix-comment-? x) (let ((a (combine-comments (car x))) (d (combine-comments (cdr x)))) (if (and (eq a (car x)) (eq d (cdr x))) x (cons a d))))))
(defun comment-p (form) (and (consp form) (eq (car form) (quote il:*)) (consp (cdr form)) (member (cadr form) (quote (il:\; il:|;;| il:|;;;|)) :test (function eq)) t))
(defun comment-combineable-p (c1 c2) (il:* il:\; "Edited 10-Aug-88 10:19 by ht:") (and (eq (cadr c1) (cadr c2)) (not (initial-comment-line-p (caddr c2)))))
(defun do-combine-comments (comments level) (il:* il:|;;| "COMMENTS is a list of sedit like comments at the same level") (il:bquote (il:* (il:\\\, level) (il:\\\, (apply (quote concatenate) (quote string) (with-collection (dolist (comment comments) (let ((string (third comment))) (when (> (length string) 0) (collect string) (collect " "))))))))))
(defun process-definitions (definitions type coms) (case type (:comment (nconc coms (nreverse definitions))) ((nil) (il:* il:|;;| "Untyped forms ") (nconc coms (il:bquote ((il:p (il:\\\,. (nreverse definitions))))))) (otherwise (il:* il:|;;| "Typed definitions") (nconc coms (il:bquote (((il:\\\, type) (il:\\\,. (let ((names nil) def) (loop (if (null (setq def (pop definitions))) (return names)) (push (%definer-name (car def) (remove-comments def)) names)))))))))))
(defun definer-type (form) (cond ((comment-p form) :comment) ((and (consp form) (symbolp (car form)) (or (if (eq (car form) (quote eval-when)) :eval-when) (get (car form) :definer-for))))))
(defun find-definition (name type coms) (dolist (expr coms nil) (let ((first (car expr))) (cond ((eq first type) (if (member name (cdr expr) :test (quote equal)) (return t))) ((eq first (quote eval-when)) (if (find-definition name type (cddr expr)) (return t))) ((eq first (quote il:coms)) (if (find-definition name type (cdr expr)) (return t)))))))
(il:* il:|;;| "From manager to text format ")
(defun managed-to-text-file (filename pathname &key (package "USER" package-p) (readtable "LISP" readtable-p) (print-base 10 print-base-p) (linelength 72) (comments :preserve)) (let ((root-name (intern (string filename) (find-package "INTERLISP"))) mode-line package-form) (multiple-value-setq (package readtable print-base mode-line package-form) (construct-mode-line root-name package package-p readtable readtable-p print-base print-base-p)) (let ((*bridging* t) (*package* (find-package package)) (*readtable* (il:find-readtable readtable)) (*print-base* print-base) (*print-case* :downcase) (*print-array* t) (*print-level* nil) (*print-length* nil) (*print-structure* t) (il:* il:|;;| "Interlisp gorp that controls pretty printing") (il:*print-semicolon-comments* (or comments t)) (il:fontchangeflg nil) (il:\#rpars nil) (il:**comment**flg nil)) (declare (global il:filelinelength il:prettyflg)) (declare (special il:fontchangeflg il:\#rpars il:**comment**flg il:*print-semicolon-comments*)) (with-open-file (stream (make-pathname :type "LISP" :version :newest :defaults pathname) :direction :output) (il:linelength linelength stream) (il:resetvars (il:* il:|;;| "Interlisp gorp that controls pretty printing") ((il:filelinelength linelength) (il:prettyflg t)) (il:* il:|;;| "First printout mode-line") (format stream "~A~%" mode-line) (il:* il:|;;| "Identifier") (format stream "~2%;;; File converted on ~A from source ~A" (il:date) root-name) (let ((dates (get root-name (quote il:filedates)))) (when dates (format stream "~&~%;;; Original source ~A created ~A" (cdar dates) (caar dates)))) (terpri stream) (terpri stream) (il:* il:|;;| "Copyright notice") (let ((owner (get root-name (quote il:copyright)))) (when (and owner (consp owner)) (format stream "~&~%;;; Copyright (c) ") (do ((tail (cdr owner) (cdr tail))) ((null tail)) (format stream "~4d" (car tail)) (if (cdr tail) (princ ", " stream))) (format stream " by ~a~%" (car owner)))) (terpri stream) (il:* il:|;;| "Provide form") (pprint (il:bquote (provide (il:\\\, (string filename)))) stream) (terpri stream) (il:* il:|;;| "In-package form ") (and package-form (pprint package-form stream)) (format stream "~2%;;; Shadow, Export, Require, Use-package, and Import forms should follow here~2%") (dolist (com (symbol-value (il:filecoms root-name))) (dolist (form (get-coms-forms com stream)) (pprint form stream) (terpri stream) (il:block)))) (namestring stream)))))
(defun construct-mode-line (root-name package package-p readtable readtable-p print-base print-base-p) (let* ((define-file-environment-form (let ((name (car (il:filecomslst root-name (quote file-environments))))) (and name (remove-comments (il:getdef name (quote file-environments) (quote il:current)))))) (makefile-environment (get root-name (quote il:makefile-environment))) (package-form (second (or (member :package define-file-environment-form :test (function eq)) (member :package makefile-environment :test (function eq))))) (readtable-form (second (or (member :readtable define-file-environment-form :test (function eq)) (member :readtable makefile-environment :test (function eq))))) (base-form (second (or (member :base define-file-environment-form :test (function eq)) (member :base makefile-environment :test (function eq))))) set-package-form mode-line-package-form mode-string) (when (and (null package-p) package-form) (setq package package-form)) (if (packagep package) (setq package (package-name package))) (setq set-package-form (cond ((stringp package) (setq mode-line-package-form package) (il:bquote (in-package (il:\\\, package)))) ((and (consp package) (eq (car package) (quote defpackage))) (let ((name (string (second package))) (use-list (cdr (assoc :use package :test (function eq)))) (nicknames (cdr (assoc :nicknames package :test (function eq)))) (exports (cdr (assoc :export package :test (function eq)))) form) (setq form (il:bquote (in-package (il:\\\, name) (il:\\\,@ (if use-list (il:bquote (:use (quote (il:\\\, use-list)))))) (il:\\\,@ (if nicknames (il:bquote (:nicknames (quote (il:\\\, nicknames))))))))) (setq package name) (setq mode-line-package-form (il:bquote ((il:\\\, package) (il:\\\,@ (if use-list (il:bquote (":USE" (il:\\\, use-list))))) (il:\\\,@ (if nicknames (il:bquote (":NICKNAMES" (il:\\\, nicknames)))))))) (if exports (il:bquote (progn (il:\\\, form) (export (quote (il:\\\, exports))))) form))) ((and (consp package) (eq (car package) (quote in-package))) (let ((name (string (second package))) (use-list (eval (cadr (member :use package :test (function eq))))) (nicknames (eval (cadr (member :nicknames package :test (function eq))))) form) (setq form package) (setq package name) (setq mode-line-package-form (il:bquote ((il:\\\, package) (il:\\\,@ (if use-list (il:bquote (":USE" (il:\\\, use-list))))) (il:\\\,@ (if nicknames (il:bquote (":NICKNAMES" (il:\\\, nicknames)))))))) form)) (t (error "Can't parse package form: ~s" package)))) (when (and (null readtable-p) readtable-form) (setq readtable readtable-form)) (if (readtablep readtable) (setq readtable (il:readtableprop readtable (quote il:name)))) (if (string= readtable "XCL") (setq readtable "LISP")) (when (and (null print-base-p) base-form) (setq print-base base-form)) (if (not (typep print-base (quote (integer 0 *)))) (error "Incorrect print-base form: ~s" print-base)) (setq mode-string (concatenate (quote string) ";;;-*- Package: " (princ-to-string mode-line-package-form) "; Syntax: " (if (string= readtable "LISP") "Common-Lisp" readtable) "; Mode: Lisp; Base: " (princ-to-string print-base) " -*-")) (values package readtable print-base mode-string set-package-form)))
(defun get-coms-forms (command stream) (il:* il:\; "Edited 2-Aug-88 15:37 by ht:") (let ((unsupported-types (quote (il:fns il:specvars il:globalvars il:localvars il:initvars il:alists il:defs il:initrecords il:lispxmacros il:macros il:props il:records il:sysrecords il:usermacros il:vars il:constants export il:resources il:initresources il:globalresources il:i.s.oprs il:horriblevars il:uglyvars il:bitmaps il:cursors il:advice il:advise il:courierprograms il:templates))) (filepkgtype (car command))) (if (member filepkgtype unsupported-types :test (function eq)) (list (make-comment "Filepkg type ~s not supported: ~s" filepkgtype command)) (case filepkgtype (il:p (cdr command)) (il:e (il:* il:|;;| "done this way so the comment doesn't get in the way of any tricky printing done under the E") (pprint (make-semicolon-comment (format nil "~S" command) 1) stream) (let ((*standard-output* stream)) (mapc (function eval) (cdr command))) nil) (il:coms (il:* il:|;;| "Recurse") (mapcan (function (lambda (x) (get-coms-forms x stream))) (cdr command))) ((eval-when il:eval-when) (il:bquote ((eval-when (il:\\\, (mapcar (function (lambda (sym) (intern (string sym) (find-package "LISP")))) (second command))) (il:\\\,@ (mapcan (function (lambda (x) (get-coms-forms x stream))) (cddr command))))))) (il:declare\: (with-collection (let ((context (quote (load eval)))) (dolist (token (cdr command)) (case token ((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))) ((il:first il:notfirst il:eval@loadwhen il:eval@compilewhen il:copywhen il:compilervars) (il:* il:|;;| "IGNORE") (warn "Ignoring ~s declaration" token)) (otherwise (collect (il:bquote (eval-when (il:\\\, context) (il:\\\,@ (get-coms-forms token stream))))))))))) ((il:*) (il:* il:|;;| "Comment ") (list command)) (il:files (let ((file-names (mapcan (function (lambda (token) (if (not (consp token)) (list token)))) (remove-comments (cdr command))))) (il:bquote ((il:\\\, (make-comment "Translated ~s to require forms" command)) (il:\\\,@ (with-collection (dolist (file file-names) (collect (il:bquote (require (il:\\\, (string file)))))))))))) (il:prop (il:* il:|;;| "Throw out makefile props") (let ((props (second (remove-comments command)))) (if (not (listp props)) (setq props (list props))) (if (set-difference props (quote (il:filetype il:makefile-environment))) (make-comment "Ignoring prop ~s coms: ~s" props command)))) (t (il:* il:|;;| "Should the filepkgtype of a definer") (let ((ignored-definers (quote (file-environments il:define-types optimizers il:sedit-formats advised-functions il:commands il:special-forms profiles walker-templates))) (definer-type (il:getfilepkgtype filepkgtype (quote il:commands) t))) (if (member definer-type ignored-definers :test (function eq)) (unless (eq definer-type (quote file-environments)) (list (make-comment "Ignoring definer coms: ~s" command))) (let* ((get-def-method (and definer-type (get definer-type :defined-by) (get definer-type (quote il:getdef)))) (defs (and get-def-method (mapcar (function (lambda (name) (if (comment-p name) name (funcall get-def-method name definer-type)))) (cdr command))))) (setq defs (case definer-type (il:functions (il:* il:|;;| "Transform defdefiners to defmacros") (mapcan (function (lambda (def) (if (and (not (comment-p def)) (eq (car def) (quote defdefiner))) (let* ((cleaned-form (remove-comments def)) (name (second cleaned-form)) (definer-for (third cleaned-form)) (body (cdr (member definer-for def)))) (list (make-comment "Transforming defdefiner (~s ~s ~s ... ) to defmacro" (first def) (second def) (third def)) (il:bquote (defmacro (il:\\\, (if (consp name) (car name) name)) (il:\\\,@ body))))) (list def)))) defs)) (otherwise defs))) (or defs (list (make-comment "Can't parse: ~s" command)))))))))))
(defun make-comment (&rest args) (apply (function warn) args) (make-semicolon-comment (apply (function format) nil args) 1))
(define-file-environment "XCL-BRIDGE" :package "XCL" :readtable "XCL" :compiler :compile-file)
(il:* il:|;;| "comment identity preservation hack")
(defparameter *preserve-comment-start-char* #\.)
(defparameter *preserve-comment-start-charcode* 46 "used at beginning of comments to preserve comment start info if IL:*PRINT-SEMICOLON-COMMENTS* is :PRESERVE")
(defun initial-comment-line-p (string) (il:* il:\; "Edited 10-Aug-88 10:17 by ht:") (and (> (length string) 0) (eq (char string 0) *preserve-comment-start-char*)))
(defun fix-comment-? (x) (il:* il:\; "Edited 10-Aug-88 10:23 by ht:") (when (and (comment-p x) (initial-comment-line-p (caddr x))) (il:* il:|;;| "remove the preserve key char and the following spaces, if any") (il:gnc (caddr x)) (loop (if (eq (il:nthcharcode (caddr x) 1) 32) (il:gnc (caddr x)) (return)))))
(reinstall-advice (quote (il:concat :in il:prin2-long-string)) :after (quote ((:last (cond ((eq il:*print-semicolon-comments* (quote :preserve)) (il:rplcharcode il:!value -1 *preserve-comment-start-charcode*)))))))
(reinstall-advice (quote (il:prin1 :in il:prin2-long-string)) :after (quote ((:last (cond ((eq il:x il:semistring) (il:rplcharcode il:x -1 32)))))))
(il:putprops il:xcl-bridge il:copyright ("Xerox Corporation" 1988 1989))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop