001 (ns beowulf.io
002 "Non-standard extensions to Lisp 1.5 to read and write to the filesystem.
003
004 Lisp 1.5 had only `READ`, which read one S-Expression at a time, and
005 various forms of `PRIN*` functions, which printed to the line printer.
006 There was also `PUNCH`, which wrote to a card punch. It does not seem
007 that there was any concept of an interactive terminal.
008
009 See Appendix E, `OVERLORD - THE MONITOR`, and Appendix F, `LISP INPUT
010 AND OUTPUT`.
011
012 For our purposes, to save the current state of the Lisp system it should
013 be sufficient to print the current contents of the oblist to file; and to
014 restore a previous state from file, to overwrite the contents of the
015 oblist with data from that file.
016
017 Hence functions SYSOUT and SYSIN, which do just that."
018 (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell
019 pretty-print]]
020 [beowulf.host :refer [CADR CAR CDDR CDR]]
021 [beowulf.interop :refer [interpret-qualified-name
022 listify-qualified-name]]
023 [beowulf.oblist :refer [*options* NIL oblist]]
024 [beowulf.read :refer [READ]]
025 [clojure.java.io :refer [file resource]]
026 [clojure.string :refer [ends-with?]]
027 [java-time.api :refer [local-date local-date-time]]))
028
029 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
030 ;;;
031 ;;; Copyright (C) 2022-2023 Simon Brooke
032 ;;;
033 ;;; This program is free software; you can redistribute it and/or
034 ;;; modify it under the terms of the GNU General Public License
035 ;;; as published by the Free Software Foundation; either version 2
036 ;;; of the License, or (at your option) any later version.
037 ;;;
038 ;;; This program is distributed in the hope that it will be useful,
039 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
040 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
041 ;;; GNU General Public License for more details.
042 ;;;
043 ;;; You should have received a copy of the GNU General Public License
044 ;;; along with this program; if not, write to the Free Software
045 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
046 ;;;
047 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
048
049 (def ^:constant default-sysout "lisp1.5.lsp")
050
051 (defn- full-path
052 [fp]
053 (str
054 (if (:filepath *options*)
055 (str (:filepath *options*) (java.io.File/separator))
056 "")
057 (if (and (string? fp)
058 (> (count fp) 0)
059 (not= fp "NIL"))
060 fp
061 (str "Sysout-" (local-date)))
062 (if (ends-with? fp ".lsp")
063 ""
064 ".lsp")))
065
066 ;; (find-var (symbol "beowulf.io/SYSIN"))
067 ;; (@(resolve (symbol "beowulf.host/TIMES")) 2 2)
068
069 (defn safely-wrap-subr
070 [entry]
071 (cond (= entry NIL) NIL
072 (= (CAR entry) 'SUBR) (make-cons-cell
073 (CAR entry)
074 (make-cons-cell
075 (listify-qualified-name (CADR entry))
076 (CDDR entry)))
077 :else (make-cons-cell
078 (CAR entry) (safely-wrap-subr (CDR entry)))))
079
080 (defn safely-wrap-subrs
081 [objects]
082 (make-beowulf-list (map safely-wrap-subr objects)))
083
084 (defn SYSOUT
085 "Dump the current content of the object list to file. If no `filepath` is
086 specified, a file name will be constructed of the symbol `Sysout` and
087 the current date. File paths will be considered relative to the filepath
088 set when starting Lisp.
089
090 **NOTE THAT** this is an extension function, not available in strct mode."
091 ([]
092 (SYSOUT nil))
093 ([filepath]
094 (spit (full-path (str filepath))
095 (with-out-str
096 (println (apply str (repeat 79 ";")))
097 (println (format ";; Beowulf %s Sysout file generated at %s"
098 (or (System/getProperty "beowulf.version") "")
099 (local-date-time)))
100 (when (System/getenv "USER")
101 (println (format ";; generated by %s" (System/getenv "USER"))))
102 (println (apply str (repeat 79 ";")))
103 (println)
104 (let [output (safely-wrap-subrs @oblist)]
105 (pretty-print output)
106 )))))
107
108 (defn resolve-subr
109 "If this oblist `entry` references a subroutine, attempt to fix up that
110 reference."
111 ([entry]
112 (or (resolve-subr entry 'SUBR)
113 (resolve-subr entry 'FSUBR)))
114 ([entry prop]
115 (cond (= entry NIL) NIL
116 (= (CAR entry) prop) (try
117 (make-cons-cell
118 (CAR entry)
119 (make-cons-cell
120 (interpret-qualified-name
121 (CADR entry))
122 (CDDR entry)))
123 (catch Exception _
124 (print "Warnung: ne can āfinde "
125 (CADR entry))
126 (CDDR entry)))
127 :else (make-cons-cell
128 (CAR entry) (resolve-subr (CDR entry))))))
129
130
131 (defn- resolve-subroutines
132 "Attempt to fix up the references to subroutines (Clojure functions) among
133 these `objects`, being new content for the object list."
134 [objects]
135 (make-beowulf-list
136 (map
137 resolve-subr
138 objects)))
139
140 (defn SYSIN
141 "Read the contents of the file at this `filename` into the object list.
142
143 If the file is not a valid Beowulf sysout file, this will probably
144 corrupt the system, you have been warned. File paths will be considered
145 relative to the filepath set when starting Lisp.
146
147 It is intended that sysout files can be read both from resources within
148 the jar file, and from the file system. If a named file exists in both the
149 file system and the resources, the file system will be preferred.
150
151 **NOTE THAT** if the provided `filename` does not end with `.lsp` (which,
152 if you're writing it from the Lisp REPL, it won't), the extension `.lsp`
153 will be appended.
154
155 **NOTE THAT** this is an extension function, not available in strct mode."
156 ([]
157 (SYSIN (or (:read *options*) (str "resources/" default-sysout))))
158 ([filename]
159 (let [fp (file (full-path (str filename)))
160 file (when (and (.exists fp) (.canRead fp)) fp)
161 res (try (resource filename)
162 (catch Throwable _ nil))
163 content (try (READ (slurp (or file res)))
164 (catch Throwable _
165 (throw (ex-info "Ne can ārǣde"
166 {:context "SYSIN"
167 :filename filename
168 :filepath fp}))))]
169 (swap! oblist
170 #(when (or % (seq content))
171 (resolve-subroutines content))))))