(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CL IN-PACKAGE (DEFPACKAGE
"TEXTMODULES" ( USE "LISP" "XCL") ( PREFIX-NAME "TM"))) (FILESLOAD EVAL-WHEN-PATCH) *PACKAGE*) BASE
10)
(il:filecreated "24-Sep-87 18:50:13" il:{dsk}<lispfiles>work>textmodules.\;14 28587
il:|changes| il:|to:| (il:functions read-hash-bar-comment read-prefix-quote translate-hash-comma translate-hash-dot read-read-time-conditional translate-read-time-conditional print-read-time-conditional make-lisp-file-readtable make-lisp-conditional-readtable read-disabled-hash untranslatable-presentation print-disabled-hash defpresentation translate-prefix-quote translate-form print-prefix-quote)
(il:vars il:textmodulescoms) (il:structures read-time-conditional) (il:variables specifier-types *delete-form* comment-level-markers)
(il:presentations disabled-hash hash-r hash-minus hash-plus hash-comma hash-dot)
il:|previous| il:|date:| "11-Sep-87 16:38:00" il:{dsk}<lispfiles>work>textmodules.\;1)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:textmodulescoms)
(il:rpaqq il:textmodulescoms ((il:* il:|;;;| "TEXTMODULES, a text file to file manager conversion utility.") (il:* il:|;;| "Semicolon comments are special cased in this code, because rewriting the SEdit support for that presentation would be hard.") (il:functions add-form after-print-functions after-read-functions before-make-textmodule-functions defpresentation form-specifier-type install-form install-read-macro load-textmodule make-lisp-file-readtable make-textmodule name-of parse-environment-setup-specifiers print-and-eval print-comment-line print-environment-forms print-form print-prefix-quote print-read-time-conditional print-semicolon-comment read-hash-bar-comment read-prefix-quote read-read-time-conditional read-semicolon-comment remove-presentation semicolon-comment-p specifier-of specifier-type top-level-form-form top-level-form-p translate-form translate-hash-comma translate-hash-dot translate-prefix-quote translate-read-time-conditional) (il:structures presentation prefix-quote presentation-ops read-time-conditional semicolon-comment specifier-type unknown-form unknown-specifier) (il:variables *delete-form* comment-level-markers eof-marker specifier-types) (il:p (make-lisp-file-readtable)) (il:define-types il:presentations) (il:presentations hash-b hash-comma hash-dot hash-minus hash-o hash-plus hash-x) (il:advise remove-comments (il:eval :in il:\\do-define-file-info)) (il:prop (il:filetype il:makefile-environment) il:textmodules))
)
(il:* il:|;;;| "TEXTMODULES, a text file to file manager conversion utility.")
(il:* il:|;;|
"Semicolon comments are special cased in this code, because rewriting the SEdit support for that presentation would be hard."
)
(defun add-form (form contents &optional (type (form-specifier-type form))) "Call appropriate functions to make definition editable, return new contents." (funcall (specifier-type-add type) form contents))
(defun after-print-functions (form) (if (eq (quote in-package) (first form)) (eval form)) form)
(defun after-read-functions (form) "Performs any processing on the form needed after it has been read." (il:* il:|;;| "Eventually this will be used to smash together adjacent same level comments.") form)
(defun before-make-textmodule-functions (module stream) "Things to do before the main body of the textmodule is printed." (print-comment-line (get module (quote il:makefile-environment)) stream) (print-environment-forms (get module (quote il:makefile-environment)) stream) (terpri stream))
(defdefiner defpresentation il:presentations (name &key fields include print-function (read-macro nil) (translator (function untranslatable-presentation))) "Define a presentation type." (il:bquote (progn (defstruct ((il:\\\, name) (:include (il:\\\,@ (if (null include) (list (quote presentation)) (etypecase include (symbol (list include)) (list include)))) (ops (make-presentation-ops :read-macro (quote (il:\\\, read-macro)) :translator (quote (il:\\\, translator))))) (:print-function (il:\\\, print-function))) (il:\\\,@ fields)) (il:\\\,@ (unless (null read-macro) (list (il:bquote (install-read-macro (quote (il:\\\, read-macro)) (il:find-readtable "LISP-FILE")))))) (quote (il:\\\, name)))))
(defun form-specifier-type (form) "If the form has a specifier return the specifier's defining structure." (or (some (function (lambda (type) (and (funcall (specifier-type-identifier type) form) type))) specifier-types) (il:nill (warn (quote unknown-form) :form form))))
(defun install-form (form &optional (type (form-specifier-type form))) "Install a definition as current and executable." (when (not (member il:dfnflg (quote (il:prop il:allprop)))) (funcall (specifier-type-installer type) form)))
(defun install-read-macro (read-macro table) (cond ((and (characterp (first read-macro)) (characterp (second read-macro))) (make-dispatch-macro-character (first read-macro) t table) (set-dispatch-macro-character (first read-macro) (second read-macro) (third read-macro) table)) ((characterp (first read-macro)) (set-macro-character (first read-macro) (second read-macro) t table)) (t (error "Bad read macro spec ~s" read-macro))))
(defun load-textmodule (pathname &key (module (pathname-name pathname)) (il:* il:\; "Name of module which has these contents.") (install t) (il:* il:\; "Install definitions as current?") (package (find-package "USER")) (il:* il:\; "Package to read file in.")) "Load a text file, creating a content description." (setq pathname (merge-pathnames pathname ".LISP")) (let ((il:dfnflg (if (null install) (quote il:prop) install)) (*package* (if (packagep package) package (find-package package))) (*readtable* (il:find-readtable "LISP-FILE")) (contents nil)) (with-open-file (stream pathname :direction :input) (let (form) (loop (setq form (read stream nil eof-marker)) (when (eq form eof-marker) (return nil)) (setq form (after-read-functions form)) (let ((type (form-specifier-type form))) (setq contents (add-form form contents type)) (install-form form type))))) (multiple-value-bind (contents environment) (parse-environment-setup-specifiers contents) (let* ((name (intern module "INTERLISP")) (filevar (il:filecoms name))) (setf (symbol-value filevar) contents) (il:addfile name) (setf (get name (quote il:filetype)) :compile-file) (il:addtofile (il:bquote ((il:\\\, name) il:filetype)) (quote il:props) name) (setf (get name (quote il:makefile-environment)) environment) (il:addtofile (il:bquote ((il:\\\, name) il:makefile-environment)) (quote il:props) name)))) module)
(defun make-lisp-file-readtable nil "Build and name the LISP-FILE readtable." (let ((table (or (il:find-readtable "LISP-FILE") (copy-readtable (il:find-readtable "LISP"))))) (install-read-macro (quote (#\; read-semicolon-comment)) table) (install-read-macro (quote (#\# #\| read-hash-bar-comment)) table) (il:readtableprop table (quote il:name) "LISP-FILE") table))
(defun make-textmodule (module &key (type ".LISP") (pathname (merge-pathnames module (merge-pathnames type))) (contents (symbol-value (il:filecoms module))) (width 80)) "Writes out the contents of the named module." (setq module (find-symbol (symbol-name module) "INTERLISP")) (let ((*package* (find-package "USER")) (*readtable* (il:find-readtable "LISP-FILE")) (il:*print-semicolon-comments* t) (*print-pretty* t)) (declare (special il:*print-semicolon-comments*)) (with-open-file (stream pathname :direction :output) (il:linelength width stream) (il:* il:\; "For Interlisp prettyprinter.") (before-make-textmodule-functions module stream) (dolist (specifier contents) (let ((type (specifier-type specifier))) (when type (write (after-print-functions (print-form specifier type)) :stream stream)))) module)))
(defun name-of (form) (funcall (get (car form) (quote il:definition-name)) (remove-comments form)))
(defun parse-environment-setup-specifiers (contents) "Parse out any environment specifiers, returning the reduced contents list and an environment object." (il:* il:|;;| "If you change anything in here you must change the printer in print-environment-forms.") (when (and (semicolon-comment-p (first contents)) (eql 0 (search "-*-" (semicolon-comment-string (first contents))))) (il:* il:\; "Discard EMACS comment line") (pop contents)) (let ((package-form nil) (il:* il:\; "Collects the package setup forms.") (base 10) (il:* il:\; "Default.")) (il:* il:|;;| "Most of the mechanism below handles comments between the setup forms in the filecoms. CONTENTS names the last parsed position. NEXT-TOP-LEVEL-FORM slides NEXT-TAIL past the comments to the next top-level form. WHEN-RECOGNIZED checks the form and if recognized pops the in-between comments onto PACKAGE-FORM.") (let ((next-tail contents) (il:* il:\; "Contains tail at next top-level form.") form (il:* il:\; "Contains next top level form.")) (block parse-complete (flet ((next-top-level-form nil (il:* il:|;;| "Find tail containing the next top level form.") (loop (when (null next-tail) (return nil)) (let ((head (first next-tail))) (cond ((top-level-form-p head) (setq form (top-level-form-form head)) (return nil)) ((not (semicolon-comment-p head) (return-from parse-complete nil))))) (pop next-tail))) (pop-forms nil (il:* il:|;;| "Comments between CONTENTS and (not including) NEXT-TAIL are popped onto PACKAGE-FORMs. The form in NEXT-TAIL is discarded and CONTENTS is updated.") (loop (when (eq contents next-tail) (return nil)) (push (pop contents) package-form)))) (macrolet ((when-recognized (test &body forms) (il:* il:|;;| "Find the next top level form. Use TEST to recognize whether its an environment setup form. Then execute the body and discard the processed form.") (il:bquote (progn (next-top-level-form) (when (il:\\\, test) (pop-forms) (il:\\\,@ forms) (pop next-tail) (setq contents next-tail)))))) (il:* il:|;;| "package setup forms") (when-recognized (eq (first form) (quote provide)) (push form package-form)) (when-recognized (eq (first form) (quote in-package)) (push form package-form)) (when-recognized (eq (first form) (quote shadow)) (push form package-form)) (when-recognized (eq (first form) (quote export)) (push form package-form)) (when-recognized (member (first form) (quote (require il:filesload)) :test (function eq)) (push form package-form)) (when-recognized (eq (first form) (quote use-package)) (push form package-form)) (when-recognized (eq (first form) (quote import)) (push form package-form)) (when-recognized (eq (first form) (quote shadowing-import)) (push form package-form)) (il:* il:|;;| "read-base") (when-recognized (and (eq (first form) (quote setf)) (eq (second form) (quote *read-base*))) (setq base (third form))))))) (il:* il:|;;| "Return the new contents and a environment.") (values contents (il:bquote (:readtable "XCL" :package (il:\\\, (if package-form (il:bquote (let ((*package* *package*)) (il:\\\,@ (reverse package-form)) *package*)) "USER")) :base (il:\\\, base))))))
(defmacro print-and-eval (form stream) (il:bquote (let ((form (il:\\\, form))) (write form :stream (il:\\\, stream)) (terpri (il:\\\, stream)) (eval form))))
(defun print-comment-line (environment stream) "Prints a mode line onto the STREAM based on the ENVIRONMENT." (format stream ";;; -*- Mode: LISP") (do ((tail environment (cddr tail))) ((null tail)) (let ((name (first tail)) (value (second tail))) (case name (:readtable) (:package (cond ((stringp value) (format stream "; Package: ~a" value)) ((eq (first value) (quote defpackage)) (format stream "; Package: (~a (~{~a~}) 1000)" (string (second value)) (or (mapcar (function string) (cdr (assoc :use (cddr value)))) (list "LISP")))) ((eq (first value) (quote let)) (let ((form (assoc (quote in-package) (cddr value)))) (format stream "; Package: (~a (~{~a~}) 1000)" (string (second form)) (or (mapcar (function string) (cdr (getf form :use nil))) (list "LISP"))))) (t (error "Unknown package specifier in environment ~s" value)))) (:base (format stream "; Base: ~a" value))))) (format stream " -*-") (terpri stream))
(defun print-environment-forms (environment stream) "Print the environment initializing forms from ENVIRONMENT onto STREAM." (do ((tail environment (cddr tail))) ((null tail)) (let ((name (first tail)) (value (second tail))) (ecase name (:readtable) (:package (typecase value (null (error "NIL given as package name")) ((or symbol string) (print-and-eval (il:bquote (in-package (il:\\\, value))) stream)) (cons (case (first value) (defpackage (il:* il:\; "We only cover the portable options to defpackage. Note that they're converted once but not back.") (print-and-eval (il:bquote (in-package (il:\\\, (string (second value))) (il:\\\,@ (let ((nicknames (cdr (assoc :nicknames (cddr value))))) (when nicknames (il:bquote (:nicknames (il:\\\, nicknames)))))))) stream) (mapc (function (lambda (option function) (let ((value (cdr (assoc :use (cddr value))))) (when value (print-and-eval (il:bquote ((il:\\\, function) (quote (il:\\\, value)))) stream))))) (quote (:shadow :export :use :import :shadowing-import)) (quote (shadow export use-package import shadowing-import)))) (let (il:* il:\; "A fancy LET environment!") (mapcar (function (lambda (form) (print-and-eval form stream))) (butlast (cddr value)) (il:* il:\; "Avoid the LET, its bindings and the returned *package*."))))) (t (error "Unknown package specifier in environment ~s" value)))) (:base (print-and-eval (il:bquote (setf *read-base* (il:\\\, value))) stream))))))
(defun print-form (specifier &optional (type (specifier-type specifier))) "Get the print form of a specifier." (funcall (specifier-type-print-form type) specifier))
(defun print-prefix-quote (object stream depth) (if (eq *print-case* :downcase) (princ (prefix-quote-prefix object) stream) (princ (string-upcase (prefix-quote-prefix object)) stream)) (princ (prefix-quote-contents object) stream))
(defun print-read-time-conditional (object stream depth) (princ #\# stream) (etypecase object (hash-plus (princ #\+ stream)) (hash-minus (princ #\- stream))) (let ((*package* il:*keyword-package*)) (prin1 (read-time-conditional-feature object) stream)) (if (read-time-conditional-unread-p object) (princ (read-time-conditional-form object) stream) (prin1 (read-time-conditional-form object) stream)))
(defun print-semicolon-comment (form stream) "Print a semicolon comment. Depends on IL:*PRINT-SEMICOLON-COMMENTS* being true." (write form :stream stream))
(defun read-hash-bar-comment (stream sub-char integer) "Read the characters of a hash bar comment, creating a comment object." (when integer (warn "Spurious integer argument to hash macro ignored.")) (let ((comment-buffer (make-array 1024 :element-type (quote character) :fill-pointer 0 :adjustable t))) (loop (setq sub-char (read-char stream nil eof-marker)) (when (eq sub-char eof-marker) (return (make-semicolon-comment :marker (quote il:\|) :string comment-buffer))) (when (eql sub-char #\|) (setq sub-char (read-char stream nil eof-marker)) (when (eql sub-char #\#) (return (make-semicolon-comment :marker (quote il:\|) :string comment-buffer))) (vector-push-extend #\| comment-buffer)) (vector-push-extend sub-char comment-buffer))))
(defun read-prefix-quote (stream sub-char integer) "Reads hash quoted forms." (when integer (warn "Spurious integer argument to hash macro ignored.")) (funcall (ecase sub-char (#\. (function make-hash-dot)) (#\, (function make-hash-comma)) ((#\O #\o) (function make-hash-o)) ((#\X #\x) (function make-hash-x)) ((#\B #\b) (function make-hash-b))) :contents (let ((*read-base* (ecase sub-char ((#\. #\,) *read-base*) ((#\B #\b) 2) ((#\O #\o) 8) ((#\X #\x) 16)))) (read stream nil t))))
(defun read-read-time-conditional (stream sub-char integer) (when integer (warn "Spurious integer argument to hash macro ignored.")) (let* ((feature (let ((*package* il:*keyword-package*)) (read stream))) (unread-p (ecase sub-char (#\- (il:cmlread.feature.parser feature)) (#\+ (not (il:cmlread.feature.parser feature))))) (form (cond (unread-p (let ((start (file-position stream))) (let ((*read-suppress* t)) (read stream)) (let ((length (- (file-position stream) start))) (file-position stream start) (let ((buffer (make-string length))) (dotimes (i length buffer) (setf (svref buffer i) (read-char stream))))))) (t (read stream))))) (funcall (case sub-char (#\+ (function make-hash-plus)) (#\- (function make-hash-minus))) :feature feature :unread-p unread-p :form form)))
(defun read-semicolon-comment (stream disp-char &aux char (il:* il:\; "Current character.") (level 0) (il:* il:\; "Comment level.") (starting t) (il:* il:\; "In semicolons?") (comment-buffer (make-array 128 :element-type (quote character) :fill-pointer 0 :adjustable t))) "Reads the characters of a comment, building a Xerox Lisp style comment." (il:* il:|;;| "Adjacent comments of the same level are smashed together during an after-read pass over the structure.") (loop (setq char (read-char stream nil eof-marker)) (when (or (eql char eof-marker) (eql char #\Newline)) (return (make-semicolon-comment :marker (elt comment-level-markers (min level (1- (length comment-level-markers)))) :string comment-buffer))) (if starting (setq starting (if (eql char #\;) (incf level) nil)) (vector-push-extend char comment-buffer))))
(defun remove-presentation (sequence index) "Translates a presentation by removing it." (cond ((eql index 0) (subseq sequence 1)) ((eql index (1- (length sequence))) (subseq sequence 0 index)) (t (concatenate (if (listp sequence) (quote list) (type-of sequence)) (subseq sequence 0 index) (subseq sequence (1+ index))))))
(defun semicolon-comment-p (form) "Is FORM a semicolon comment?" (il:* il:|;;| "All info about the structure of semicolon comments is encapsulated in this function and the semicolon-comment structure.") (and (consp form) (eq (first form) (quote il:*)) (member (second form) comment-level-markers :test (function eq)) (stringp (third form)) (null (nthcdr 3 form))))
(defun specifier-of (form) "Examines a form and returns its specifier (file command)." (get (car form) (quote il:definer-for)))
(defun specifier-type (specifier) "If the form has a specifier type return its defining structure." (or (some (function (lambda (type) (and (funcall (specifier-type-specifierp type) specifier) type))) specifier-types) (il:nill (warn (quote unknown-specifier) :specifier specifier))))
(defmacro top-level-form-form (place) "Return the form in the top-level form specifier." (il:bquote (second (second (il:\\\, place)))))
(defun top-level-form-p (specifier) (eq (quote il:p) (first specifier)))
(defun translate-form (sequence) "Create an evaluable form from one with presentations in it." (cond ((listp sequence) (setq sequence (copy-list sequence)) (il:* il:\; "An optimization for lists, since it would be terrible to ELT into them at each position.") (do ((tail sequence) (last nil)) ((not (consp tail)) sequence) (let ((head (first tail))) (cond ((semicolon-comment-p head) (il:* il:\; "Special case for old style comments.") (if (null last) (setq sequence (cdr tail)) (rplacd last (cdr tail))) (il:* il:\; "Last stays the same in either case.") (pop tail)) ((presentation-p head) (let* ((installer (presentation-ops-translator (presentation-ops head))) (result (if (eq installer :delete) *delete-form* (funcall installer head)))) (cond ((eq result *delete-form*) (if (null last) (setq sequence (cdr tail)) (rplacd last (cdr tail))) (il:* il:\; "Last stays the same in either case.") (pop tail)) (t (rplaca tail result) (setq last tail) (pop tail))))) ((typep head (quote sequence)) (rplaca tail (translate-form head)) (setq last tail) (pop tail)) (t (setq last tail) (pop tail)))))) ((and (not (stringp sequence)) (typep sequence (quote sequence))) (il:* il:\; "Optimization: avoid strings.") (setq sequence (copy-seq sequence)) (il:* il:\; "The general case of a sequence.") (do ((index 0) (length (length sequence))) ((eql index length) sequence) (let ((head (elt sequence index))) (cond ((presentation-p head) (let* ((installer (presentation-ops-translator (presentation-ops head))) (result (if (eq installer :delete) *delete-form* (funcall installer head)))) (cond ((eq result *delete-form*) (setq sequence (remove-presentation sequence index)) (decf length)) (t (setf (elt sequence index) result) (incf index))))) ((typep head (quote sequence)) (setf (elt sequence index) (translate-form head)) (incf index)) (t (incf index)))))) ((presentation-p sequence) (let* ((installer (presentation-ops-translator (presentation-ops sequence))) (result (if (eq installer :delete) *delete-form* (funcall installer sequence)))) (if (eq result *delete-form*) nil result))) (t sequence)))
(defun translate-hash-comma (object) (cond (*read-suppress* nil) (compiler::*compiler-is-reading* (compiler::make-eval-when-load :form (prefix-quote-contents object))) ((il:fetch (readtablep il:commonlisp) il:of *readtable*) (eval (prefix-quote-contents object))) (t (il:eval (prefix-quote-contents object)))))
(defun translate-hash-dot (object) (cond (*read-suppress* nil) ((il:fetch (readtablep il:commonlisp) il:of *readtable*) (eval (prefix-quote-contents object))) (t (il:eval (prefix-quote-contents object)))))
(defun translate-prefix-quote (object) (il:* il:\; "This only has to handle numeric base types.") (prefix-quote-contents object))
(defun translate-read-time-conditional (object) (if (etypecase object (hash-minus (not (il:cmlread.feature.parser (read-time-conditional-feature object)))) (hash-plus (il:cmlread.feature.parser (read-time-conditional-feature object)))) (if (read-time-conditional-unread-p object) (with-input-from-string (input-string (read-time-conditional-form object)) (let ((*readtable* (il:find-readtable "LISP"))) (read input-string nil t))) (read-time-conditional-form object)) *delete-form*))
(defstruct presentation ops)
(defstruct (prefix-quote (:include presentation) (:print-function print-prefix-quote)) type prefix contents)
(defstruct (presentation-ops (:type list)) read-macro (il:* il:\; "A list with one or two characters followed by a read macro function. Installed in the text file readtable to read this presentation.") translator (il:* il:\; "Either a function on PRESENTATION which translates it, or :DELETE which always removes it (eg, comments)."))
(defstruct (read-time-conditional (:include presentation) (:print-function print-read-time-conditional)) feature unread-p form)
(defstruct (semicolon-comment (:type list) (:predicate nil) (il:* il:\; "The real one is SEMICOLON-COMMENT-P")) (tag (quote il:*)) (marker (quote il:\;)) (string ""))
(defstruct (specifier-type (:type list)) name (il:* il:\; "A string naming the specifier.") specifierp (il:* il:\; "Predicate on FORM (a content specifier) which recognizes the specifier in the contents description of a file.") identifier (il:* il:\; "Predicate on FORM (a form from the text file), answers true if this is the specifier for the definition in FORM.") add (il:* il:\; "Function of FORM and CONTENTS which adds a specifier for FORM to the file CONTENTS description.") installer (il:* il:\; "Function of a FORM which installs the definition of FORM (may remove presentations). Should not actually install the definition if il:dfnflg is il:prop or il:allprop.") print-form (il:* il:\; "Function of SPECIFIER which returns the form to be printed."))
(define-condition unknown-form warning :report-function (lambda (condition stream) (format stream "Can't find specifier (filecom) for ~s" (unknown-form-form condition))) form)
(define-condition unknown-specifier warning :report-function (lambda (condition stream) (format stream "Unknown specifier (filecom) ~s" (unknown-specifier-specifier condition))) specifier)
(defvar *delete-form* "<delete form marker>")
(defconstant comment-level-markers (quote (il:\; il:|;;| il:|;;;| il:|;;;;| il:\|)) "Comment markers for availible levels.")
(defconstant eof-marker "eof" "Unique object passed through read at EOF.")
(defparameter specifier-types (list (make-specifier-type :name "Comment" :specifierp (function semicolon-comment-p) :identifier (function semicolon-comment-p) :add (function (lambda (form contents) (append contents (list form)))) :installer (function identity) :print-form (function identity)) (make-specifier-type :name "eval-when top level form" :specifierp (function (lambda (form) (eq (first form) (quote il:eval-when)))) :identifier (function (lambda (form) (and (listp form) (eq (first form) (quote eval-when))))) :add (function (lambda (form contents) (append contents (list (il:bquote (il:eval-when (il:\\\, (second form)) (il:\\\,@ (let ((contents nil)) (mapc (function (lambda (form) (setq contents (add-form form contents)))) (cddr form)) contents)))))))) :installer (function (lambda (form) (when (member (quote eval) (second form)) (dolist (form (cddr form)) (install-form form))))) :print-form (function (lambda (specifier) (il:bquote (eval-when (il:\\\, (second specifier)) (il:\\\,@ (mapcar (function (lambda (specifier) (print-form specifier))) (cddr specifier)))))))) (make-specifier-type :name "Definer" :specifierp (function (lambda (specifier) (get (first specifier) (quote il:defined-by)))) :identifier (function (lambda (form) (and (listp form) (get (car form) (quote il:definer-for))))) :add (function (lambda (form contents) (let ((il:dfnflg (quote il:prop))) (eval form)) (append contents (list (il:bquote ((il:\\\, (specifier-of form)) (il:\\\, (name-of form)))))))) :installer (function (lambda (form) (let ((il:dfnflg t)) (eval form)))) :print-form (function (lambda (specifier) (il:getdef (second specifier) (first specifier))))) (make-specifier-type :name "Top-level read-time conditional" :specifierp (function (lambda (form) nil)) :identifier (function read-time-conditional-p) :add (function (lambda (form contents) (append contents (list (il:bquote (il:p (translate-form (il:\\\, form)))))))) :installer (function (lambda (form) (eval (translate-form form)))) :print-form (function (lambda (specifier) (second (second specifier))))) (make-specifier-type :name "Top level form" :specifierp (function top-level-form-p) :identifier (function true) :add (function (lambda (form contents) (append contents (list (il:bquote (il:p (translate-form (il:\\\, form)))))))) :installer (function (lambda (form) (eval (translate-form form)))) :print-form (function (lambda (specifier) (top-level-form-form specifier))))) "A list of all content specifier types for text files.")
(make-lisp-file-readtable)
(def-define-type il:presentations "presentation types")
(defpresentation hash-b :include (prefix-quote (type :hash-b) (prefix "#b")) :print-function print-prefix-quote :read-macro (#\# #\b read-prefix-quote) :translator translate-prefix-quote)
(defpresentation hash-comma :include (prefix-quote (type :hash-comma) (prefix "#,")) :print-function print-prefix-quote :read-macro (#\# #\, read-prefix-quote) :translator translate-hash-comma)
(defpresentation hash-dot :include (prefix-quote (type :hash-dot) (prefix "#.")) :print-function print-prefix-quote :read-macro (#\# #\. read-prefix-quote) :translator translate-hash-dot)
(defpresentation hash-minus :include read-time-conditional :print-function print-read-time-conditional :read-macro (#\# #\+ read-read-time-conditional) :translator translate-read-time-conditional)
(defpresentation hash-o :include (prefix-quote (type :hash-o) (prefix "#o")) :print-function print-prefix-quote :read-macro (#\# #\o read-prefix-quote) :translator translate-prefix-quote)
(defpresentation hash-plus :include read-time-conditional :print-function print-read-time-conditional :read-macro (#\# #\+ read-read-time-conditional) :translator translate-read-time-conditional)
(defpresentation hash-x :include (prefix-quote (type :hash-x) (prefix "#x")) :print-function print-prefix-quote :read-macro (#\# #\x read-prefix-quote) :translator translate-prefix-quote)
(reinstall-advice (quote remove-comments) :around (quote ((:last (translate-form il:x)))))
(reinstall-advice (quote (il:eval :in il:\\do-define-file-info)) :before (quote ((:last (setq il:u (translate-form il:u))))))
(il:readvise remove-comments (il:eval :in il:\\do-define-file-info))
(il:putprops il:textmodules il:filetype :compile-file)
(il:putprops il:textmodules il:makefile-environment (:readtable "XCL" :package (let ((*package* *package*)) (in-package (defpackage "TEXTMODULES" (:use "LISP" "XCL") (:prefix-name "TM"))) (il:filesload il:eval-when-patch) *package*) :base 10)
)
(il:putprops il:textmodules il:copyright ("Xerox Corporation" 1987))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop