001 (ns beowulf.reader.generate
002 "Generating S-Expressions from parse trees.
003
004 ## From Lisp 1.5 Programmers Manual, page 10
005 *Note that I've retyped much of this, since copy/pasting out of PDF is less
006 than reliable. Any typos are mine.*
007
008 *Quote starts:*
009
010 We are now in a position to define the universal LISP function
011 `evalquote[fn;args]`, When evalquote is given a function and a list of arguments
012 for that function, it computes the value of the function applied to the arguments.
013 LISP functions have S-expressions as arguments. In particular, the argument `fn`
014 of the function evalquote must be an S-expression. Since we have been
015 writing functions as M-expressions, it is necessary to translate them into
016 S-expressions.
017
018 The following rules define a method of translating functions written in the
019 meta-language into S-expressions.
020 1. If the function is represented by its name, it is translated by changing
021 all of the letters to upper case, making it an atomic symbol. Thus `car` is
022 translated to `CAR`.
023 2. If the function uses the lambda notation, then the expression
024 `λ[[x ..;xn]; ε]` is translated into `(LAMBDA (X1 ...XN) ε*)`, where ε* is the translation
025 of ε.
026 3. If the function begins with label, then the translation of
027 `label[α;ε]` is `(LABEL α* ε*)`.
028
029 Forms are translated as follows:
030 1. A variable, like a function name, is translated by using uppercase letters.
031 Thus the translation of `var1` is `VAR1`.
032 2. The obvious translation of letting a constant translate into itself will not
033 work. Since the translation of `x` is `X`, the translation of `X` must be something
034 else to avoid ambiguity. The solution is to quote it. Thus `X` is translated
035 into `(QUOTE X)`.
036 3. The form `fn[argl;. ..;argn]` is translated into `(fn* argl* ...argn*)`
037 4. The conditional expression `[pl-el;...;pn-en]` is translated into
038 `(COND (p1* e1*)...(pn* en*))`
039
040 ## Examples
041 ```
042 M-expressions S-expressions
043
044 x X
045 car CAR
046 car[x] (CAR X)
047 T (QUOTE T)
048 ff[car [x]] (FF (CAR X))
049 [atom[x]->x; T->ff[car[x]]] (COND ((ATOM X) X)
050 ((QUOTE T)(FF (CAR X))))
051 label[ff;λ[[x];[atom[x]->x; (LABEL FF (LAMBDA (X)
052 T->ff[car[x]]]]] (COND ((ATOM X) X)
053 ((QUOTE T)(FF (CAR X))))))
054 ```
055
056 *quote ends*
057 "
058 (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell]]
059 [beowulf.reader.macros :refer [expand-macros]]
060 [beowulf.oblist :refer [NIL]]
061 [clojure.math.numeric-tower :refer [expt]]
062 [clojure.string :refer [upper-case]]
063 [clojure.tools.trace :refer [deftrace]]))
064
065 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
066 ;;;
067 ;;; Copyright (C) 2022-2023 Simon Brooke
068 ;;;
069 ;;; This program is free software; you can redistribute it and/or
070 ;;; modify it under the terms of the GNU General Public License
071 ;;; as published by the Free Software Foundation; either version 2
072 ;;; of the License, or (at your option) any later version.
073 ;;;
074 ;;; This program is distributed in the hope that it will be useful,
075 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
076 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
077 ;;; GNU General Public License for more details.
078 ;;;
079 ;;; You should have received a copy of the GNU General Public License
080 ;;; along with this program; if not, write to the Free Software
081 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
082 ;;;
083 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
084
085 (declare generate)
086
087 (defn gen-cond-clause
088 "Generate a cond clause from this simplified parse tree fragment `p`;
089 returns `nil` if `p` does not represent a cond clause."
090 [p context]
091 (when
092 (and (coll? p) (= :cond-clause (first p)))
093 (make-beowulf-list
094 (list (if (= (nth p 1) [:quoted-expr [:atom "T"]])
095 'T
096 (generate (nth p 1) context))
097 (generate (nth p 2) context)))))
098
099 (defn gen-cond
100 "Generate a cond statement from this simplified parse tree fragment `p`;
101 returns `nil` if `p` does not represent a (MEXPR) cond statement."
102 [p context]
103 (when
104 (and (coll? p) (= :cond (first p)))
105 (make-beowulf-list
106 (cons
107 'COND
108 (map
109 #(generate % (if (= context :mexpr) :cond-mexpr context))
110 (rest p))))))
111
112 (defn gen-fn-call
113 "Generate a function call from this simplified parse tree fragment `p`;
114 returns `nil` if `p` does not represent a (MEXPR) function call."
115 [p context]
116 (when
117 (and (coll? p) (= :fncall (first p)) (= :mvar (first (second p))))
118 (make-cons-cell
119 (generate (second p) context)
120 (generate (nth p 2) context))))
121
122
123 (defn gen-dot-terminated-list
124 "Generate a list, which may be dot-terminated, from this partial parse tree
125 'p'. Note that the function acts recursively and progressively decapitates
126 its argument, so that the argument will not always be a valid parse tree."
127 [p]
128 (cond
129 (empty? p)
130 NIL
131 (and (coll? (first p)) (= :dot-terminal (first (first p))))
132 (let [dt (first p)]
133 (make-cons-cell
134 (generate (nth dt 1))
135 (generate (nth dt 2))))
136 :else
137 (make-cons-cell
138 (generate (first p))
139 (gen-dot-terminated-list (rest p)))))
140
141 ;; null[x] = [x = NIL -> T; T -> F]
142 ;; [:defn
143 ;; [:mexpr [:fncall [:mvar "null"] [:bindings [:args [:mexpr [:mvar "x"]]]]]]
144 ;; "="
145 ;; [:mexpr [:cond
146 ;; [:cond-clause [:mexpr [:iexpr [:lhs [:mexpr [:mvar "x"]]] [:iop "="] [:rhs [:mexpr [:mconst "NIL"]]]]] [:mexpr [:mconst "T"]]]
147 ;; [:cond-clause [:mexpr [:mconst "T"]] [:mexpr [:mconst "F"]]]]]]
148
149 (defn generate-defn
150 [tree context]
151 (if (= :mexpr (first tree))
152 (generate-defn (second tree) context)
153 (make-beowulf-list
154 (list 'PUT
155 (list 'QUOTE (generate (-> tree second second second) context))
156 (list 'QUOTE 'EXPR)
157 (list 'QUOTE
158 (cons 'LAMBDA
159 (list (generate (nth (-> tree second second) 2) context)
160 (generate (nth tree 3) context))))))))
161
162 (defn gen-iexpr
163 [tree context]
164 (let [bundle (reduce #(assoc %1 (first %2) %2)
165 {}
166 (rest tree))]
167 (list (generate (:iop bundle) context)
168 (generate (:lhs bundle) context)
169 (generate (:rhs bundle) context))))
170
171 (defn generate-set
172 "Actually not sure what the mexpr representation of set looks like"
173 [tree context]
174 (throw (ex-info "Not Yet Implemented" {:feature "generate-set"})))
175
176 (defn generate-assign
177 "Generate an assignment statement based on this `tree`. If the thing
178 being assigned to is a function signature, then we have to do something
179 different to if it's an atom."
180 [tree context]
181 (case (first (second tree))
182 :fncall (generate-defn tree context)
183 :mexpr (map #(generate % context) (rest (second tree)))
184 (:mvar :atom) (generate-set tree context)))
185
186 (defn strip-leading-zeros
187 "`read-string` interprets strings with leading zeros as octal; strip
188 any from this string `s`. If what's left is empty (i.e. there were
189 only zeros, return `\"0\"`."
190 ([s]
191 (strip-leading-zeros s ""))
192 ([s prefix]
193 (if
194 (empty? s) "0"
195 (case (first s)
196 (\+ \-) (strip-leading-zeros (subs s 1) (str (first s) prefix))
197 "0" (strip-leading-zeros (subs s 1) prefix)
198 (str prefix s)))))
199
200 (defn generate
201 "Generate lisp structure from this parse tree `p`. It is assumed that
202 `p` has been simplified."
203 ([p]
204 (generate p :expr))
205 ([p context]
206 (try
207 (expand-macros
208 (if
209 (coll? p)
210 (case (first p)
211 :λ "LAMBDA"
212 :λexpr (make-cons-cell
213 (generate (nth p 1) context)
214 (make-cons-cell (generate (nth p 2) context)
215 (generate (nth p 3) context)))
216 :args (make-beowulf-list (map #(generate % context) (rest p)))
217 :atom (symbol (second p))
218 :bindings (generate (second p) context)
219 :body (make-beowulf-list (map #(generate % context) (rest p)))
220 (:coefficient :exponent) (generate (second p) context)
221 :cond (gen-cond p (if (= context :mexpr) :cond-mexpr context))
222 :cond-clause (gen-cond-clause p context)
223 :decimal (read-string (apply str (map second (rest p))))
224 :defn (generate-defn p context)
225 :dotted-pair (make-cons-cell
226 (generate (nth p 1) context)
227 (generate (nth p 2) context))
228 :fncall (gen-fn-call p context)
229 :iexpr (gen-iexpr p context)
230 :integer (read-string (strip-leading-zeros (second p)))
231 :iop (case (second p)
232 "/" 'DIFFERENCE
233 "=" 'EQUAL
234 ">" 'GREATERP
235 "<" 'LESSP
236 "+" 'PLUS
237 "*" 'TIMES
238 ;; else
239 (throw (ex-info "Unrecognised infix operator symbol"
240 {:phase :generate
241 :fragment p})))
242 :list (gen-dot-terminated-list (rest p))
243 (:lhs :rhs) (generate (second p) context)
244 :mexpr (generate (second p) (if (= context :cond-mexpr) context :mexpr))
245 :mconst (if (= context :cond-mexpr)
246 (case (second p)
247 ("T" "F" "NIL") (symbol (second p))
248 ;; else
249 (list 'QUOTE (symbol (second p))))
250 ;; else
251 (list 'QUOTE (symbol (second p))))
252 :mvar (symbol (upper-case (second p)))
253 :number (generate (second p) context)
254 :octal (let [n (read-string (strip-leading-zeros (second p) "0"))
255 scale (generate (nth p 3) context)]
256 (* n (expt 8 scale)))
257
258 ;; the quote read macro (which probably didn't exist in Lisp 1.5, but...)
259 :quoted-expr (make-beowulf-list (list 'QUOTE (generate (second p) context)))
260 :scale-factor (if
261 (empty? (second p)) 0
262 (read-string (strip-leading-zeros (second p))))
263 :scientific (let [n (generate (second p) context)
264 exponent (generate (nth p 3) context)]
265 (* n (expt 10 exponent)))
266 :sexpr (generate (second p) :sexpr)
267 :subr (symbol (second p))
268
269 ;; default
270 (throw (ex-info (str "Unrecognised head: " (first p))
271 {:generating p})))
272 p))
273 (catch Throwable any
274 (throw (ex-info "Could not generate"
275 {:generating p}
276 any))))))