diff --git a/docs/cloverage/beowulf/bootstrap.clj.html b/docs/cloverage/beowulf/bootstrap.clj.html index 8a1fa87..a9efdd4 100644 --- a/docs/cloverage/beowulf/bootstrap.clj.html +++ b/docs/cloverage/beowulf/bootstrap.clj.html @@ -44,1231 +44,1459 @@ 013                                         pretty-print T]]
- 014              [beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR GET + 014              [beowulf.host :refer [ASSOC ATOM CAAR CAADR CADAR CADDR CADR CAR CDR
- 015                                    LIST NUMBERP PAIRLIS traced?]] + 015                                    CONS ERROR GET LIST NUMBERP PAIRLIS traced?]]
- 016              [beowulf.oblist :refer [*options* NIL oblist]]) + 016              [beowulf.oblist :refer [*options* NIL]]
- 017    (:import [beowulf.cons_cell ConsCell] + 017              [clojure.string :as s]
- 018             [clojure.lang Symbol])) + 018              [clojure.tools.trace :refer [deftrace]]) +
+ + 019    (:import [beowulf.cons_cell ConsCell] +
+ + 020             [clojure.lang Symbol]))
- 019   + 021  
- 020  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -
- - 021  ;;; -
- - 022  ;;; Copyright (C) 2022-2023 Simon Brooke + 022  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
023  ;;;
- 024  ;;; This program is free software; you can redistribute it and/or + 024  ;;; Copyright (C) 2022-2023 Simon Brooke
- 025  ;;; modify it under the terms of the GNU General Public License + 025  ;;;
- 026  ;;; as published by the Free Software Foundation; either version 2 + 026  ;;; This program is free software; you can redistribute it and/or
- 027  ;;; of the License, or (at your option) any later version. + 027  ;;; modify it under the terms of the GNU General Public License
- 028  ;;;  + 028  ;;; as published by the Free Software Foundation; either version 2
- 029  ;;; This program is distributed in the hope that it will be useful, + 029  ;;; of the License, or (at your option) any later version.
- 030  ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of + 030  ;;; 
- 031  ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the + 031  ;;; This program is distributed in the hope that it will be useful,
- 032  ;;; GNU General Public License for more details. + 032  ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- 033  ;;;  + 033  ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- 034  ;;; You should have received a copy of the GNU General Public License + 034  ;;; GNU General Public License for more details.
- 035  ;;; along with this program; if not, write to the Free Software + 035  ;;; 
- 036  ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA. + 036  ;;; You should have received a copy of the GNU General Public License
- 037  ;;; + 037  ;;; along with this program; if not, write to the Free Software
- 038  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + 038  ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
- - 039   + + 039  ;;;
- - 040  (declare APPLY EVAL prog-eval) + + 040  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
041  
- - 042  ;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + 042  (declare APPLY EVAL EVCON prog-eval)
043  
- - 044  (def find-target -
- - 045    (memoize -
- - 046     (fn [target body] -
- - 047       (loop [body' body] -
- - 048         (cond -
- - 049           (= body' NIL) (throw (ex-info (str "Mislar GO miercels: `" target "`") -
- - 050                                         {:phase :lisp -
- 051                                          :function 'PROG -
- - 052                                          :type :lisp -
- - 053                                          :code :A6 -
- - 054                                          :target target})) -
- - 055           (= (.getCar body') target) body' -
- - 056           :else (recur (.getCdr body'))))))) + 044  ;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 057   -
- - 058  (defn- prog-cond -
- - 059    "Like `EVCON`, q.v. except using `prog-eval` instead of `EVAL` and not -
- - 060     throwing an error if no clause matches." -
- - 061    [clauses vars env depth] + 045  
- 062    (loop [clauses' clauses] + 046  (def ^:dynamic
- - 063      (if-not (= clauses' NIL) + + 047    *depth*
- - 064        (let [test (prog-eval (CAAR clauses') vars env depth)] + + 048    "Stack depth. Unfortunately we need to be able to pass round depth for 
- - 065          (if (not (#{NIL F} test)) + + 049     functions which call EVAL/APPLY but do not know about depth."
- - 066            (prog-eval (CADAR clauses') vars env depth) + + 050    0) +
+ + 051  
- 067            (recur (.getCdr clauses')))) + 052  (defn- trace-indent +
+ + 053    ([] (trace-indent *depth*)) +
+ + 054    ([d] (s/join (repeat d " ")))) +
+ + 055   +
+ + 056  (def find-target +
+ + 057    (memoize +
+ + 058     (fn [target body] +
+ + 059       (loop [body' body] +
+ + 060         (cond +
+ + 061           (= body' NIL) (throw (ex-info (str "Mislar GO miercels: `" target "`") +
+ + 062                                         {:phase :lisp +
+ + 063                                          :function 'PROG +
+ + 064                                          :type :lisp +
+ + 065                                          :code :A6
- 068        NIL))) + 066                                          :target target})) +
+ + 067           (= (.getCar body') target) body' +
+ + 068           :else (recur (.getCdr body')))))))
069  
- 070  (defn- merge-vars [vars env] + 070  (defn- prog-cond
- - 071    (reduce + + 071    "Like `EVCON`, q.v. except using `prog-eval` instead of `EVAL` and not +
+ + 072     throwing an error if no clause matches." +
+ + 073    [clauses vars env depth]
- 072     #(make-cons-cell -
- - 073       (make-cons-cell %2 (@vars %2)) -
- - 074       env) -
- - 075     env -
- - 076     (keys @vars))) -
- - 077   -
- - 078  (defn prog-eval -
- - 079    "Like `EVAL`, q.v., except handling symbols, and expressions starting -
- - 080     `GO`, `RETURN`, `SET` and `SETQ` specially." -
- - 081    [expr vars env depth] -
- - 082    (cond -
- - 083      (number? expr) expr -
- - 084      (symbol? expr) (@vars expr) -
- - 085      (instance? ConsCell expr) (case (.getCar expr) -
- - 086                                  COND (prog-cond (.getCdr expr) -
- - 087                                                  vars env depth) -
- - 088                                  GO (make-cons-cell -
- - 089                                      '*PROGGO* (.getCar (.getCdr expr))) -
- - 090                                  RETURN (make-cons-cell -
- - 091                                          '*PROGRETURN* -
- - 092                                          (prog-eval (.getCar (.getCdr expr)) -
- - 093                                                     vars env depth)) -
- - 094                                  SET (let [v (CADDR expr)] -
- - 095                                        (swap! vars -
- - 096                                               assoc -
- - 097                                               (prog-eval (CADR expr) -
- - 098                                                          vars env depth) -
- - 099                                               (prog-eval (CADDR expr) -
- - 100                                                          vars env depth)) -
- - 101                                        v) -
- - 102                                  SETQ (let [v (CADDR expr)] -
- - 103                                         (swap! vars -
- - 104                                                assoc -
- - 105                                                (CADR expr) -
- - 106                                                (prog-eval v -
- - 107                                                           vars env depth)) -
- - 108                                         v) -
- - 109                                   ;; else -
- - 110                                  (beowulf.bootstrap/EVAL expr -
- - 111                                                          (merge-vars vars env) -
- - 112                                                          depth)))) -
- - 113   -
- - 114  (defn PROG -
- - 115    "The accursed `PROG` feature. See page 71 of the manual. -
- - 116      -
- - 117     Lisp 1.5 introduced `PROG`, and most Lisps have been stuck with it ever  -
- - 118     since. It introduces imperative programming into what should be a pure  -
- - 119     functional language, and consequently it's going to be a pig to implement. -
- - 120      -
- - 121     Broadly, `PROG` is a variadic pseudo function called as a `FEXPR` (or  -
- - 122     possibly an `FSUBR`, although I'm not presently sure that would even work.) -
- - 123   -
- - 124     The arguments, which are unevaluated, are a list of forms, the first of  -
- - 125     which is expected to be a list of symbols which will be treated as names  -
- - 126     of variables within the program, and the rest of which (the 'program body') -
- - 127     are either lists or symbols. Lists are treated as Lisp expressions which -
- - 128     may be evaulated in turn. Symbols are treated as targets for the `GO`  -
- - 129     statement.  -
- - 130         -
- - 131     **GO:**  -
- - 132     A `GO` statement takes the form of `(GO target)`, where  -
- - 133     `target` should be one of the symbols which occur at top level among that -
- - 134     particular invocation of `PROG`s arguments. A `GO` statement may occur at  -
- - 135     top level in a PROG, or in a clause of a `COND` statement in a `PROG`, but -
- - 136     not in a function called from the `PROG` statement. When a `GO` statement -
- - 137     is evaluated, execution should transfer immediately to the expression which -
- - 138     is the argument list immediately following the symbol which is its target. -
- - 139   -
- - 140     If the target is not found, an error with the code `A6` should be thrown. -
- - 141   -
- - 142     **RETURN:**  -
- - 143     A `RETURN` statement takes the form `(RETURN value)`, where  -
- - 144     `value` is any value. Following the evaluation of a `RETURN` statement,  -
- - 145     the `PROG` should immediately exit without executing any further  -
- - 146     expressions, returning the  value. -
- - 147   -
- - 148     **SET and SETQ:** -
- - 149     In addition to the above, if a `SET` or `SETQ` expression is encountered -
- - 150     in any expression within the `PROG` body, it should affect not the global -
- - 151     object list but instead only the local variables of the program. -
- - 152   -
- - 153     **COND:** -
- - 154     In **strict** mode, when in normal execution, a `COND` statement none of  -
- - 155     whose clauses match should not return `NIL` but should throw an error with -
- - 156     the code `A3`... *except* that inside a `PROG` body, it should not do so. -
- - 157     *sigh*. -
- - 158   -
- - 159     **Flow of control:** -
- - 160     Apart from the exceptions specified above, expressions in the program body -
- - 161     are evaluated sequentially. If execution reaches the end of the program  -
- - 162     body, `NIL` is returned. -
- - 163   -
- - 164     Got all that? -
- - 165   -
- - 166     Good." -
- - 167    [program env depth] -
- - 168    (let [trace (traced? 'PROG) -
- - 169          vars (atom (reduce merge (map #(assoc {} % NIL) (.getCar program)))) -
- - 170          body (.getCdr program) + 074    (loop [clauses' clauses]
- 171          targets (set (filter symbol? body))] + 075      (if-not (= clauses' NIL)
- - 172      (when trace (do + + 076        (let [test (prog-eval (CAAR clauses') vars env depth)]
- - 173                    (println "Program:") + + 077          (if (not (#{NIL F} test))
- - 174                    (pretty-print program))) ;; for debugging + + 078            (prog-eval (CADAR clauses') vars env depth)
- - 175      (loop [cursor body] + + 079            (recur (.getCdr clauses'))))
- - 176        (let [step (.getCar cursor)] + + 080        NIL)))
- - 177          (when trace (do (println "Executing step: " step) + + 081  
- - 178                          (println "  with vars: " @vars))) -
- - 179          (cond (= cursor NIL) NIL -
- - 180                (symbol? step) (recur (.getCdr cursor)) -
- - 181                :else (let [v (prog-eval (.getCar cursor) vars env depth)] -
- - 182                        (when trace (println "  --> " v)) -
- - 183                        (if (instance? ConsCell v) + + 082  (defn- merge-vars [vars env]
- 184                          (case (.getCar v) + 083    (reduce
- 185                            *PROGGO* (let [target (.getCdr v)] + 084     #(make-cons-cell
- - 186                                       (if (targets target) + + 085       (make-cons-cell %2 (@vars %2))
- 187                                         (recur (find-target target body)) -
- - 188                                         (throw (ex-info (str "Uncynlic GO miercels `" -
- - 189                                                              target "`") -
- - 190                                                         {:phase :lisp -
- - 191                                                          :function 'PROG -
- - 192                                                          :args program -
- - 193                                                          :type :lisp -
- - 194                                                          :code :A6 -
- - 195                                                          :target target -
- - 196                                                          :targets targets})))) + 086       env)
- 197                            *PROGRETURN* (.getCdr v) -
- - 198                          ;; else -
- - 199                            (recur (.getCdr cursor))) -
- - 200                          (recur (.getCdr cursor))))))))) -
- - 201   -
- - 202  ;;;; Tracing execution ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -
- - 203   -
- - 204  (defn- trace-call -
- - 205    "Show a trace of a call to the function named by this `function-symbol`  -
- - 206    with these `args` at this depth." -
- - 207    [function-symbol args depth] -
- - 208    (when (traced? function-symbol) -
- - 209      (let [indent (apply str (repeat depth "-"))] -
- - 210        (println (str indent "> " function-symbol " " args))))) -
- - 211   -
- - 212  (defn- trace-response -
- - 213    "Show a trace of this `response` from the function named by this -
- - 214     `function-symbol` at this depth." -
- - 215    [function-symbol response depth] -
- - 216    (when (traced? function-symbol) -
- - 217      (let [indent (apply str (repeat depth "-"))] -
- - 218        (println (str "<" indent " " function-symbol " " response)))) -
- - 219    response) -
- - 220   -
- - 221  (defn- value -
- - 222    "Seek a value for this symbol `s` by checking each of these indicators in -
- - 223     turn." -
- - 224    ([s] -
- - 225     (value s (list 'APVAL 'EXPR 'FEXPR 'SUBR 'FSUBR))) -
- - 226    ([s indicators] + 087     env
- 227     (when (symbol? s) + 088     (keys @vars)))
- - 228       (first (remove #(= % NIL) (map #(GET s %) + + 089  
- 229                                      indicators)))))) + 090  (defn prog-eval +
+ + 091    "Like `EVAL`, q.v., except handling symbols, and expressions starting +
+ + 092     `GO`, `RETURN`, `SET` and `SETQ` specially." +
+ + 093    [expr vars env depth] +
+ + 094    (cond +
+ + 095      (number? expr) expr +
+ + 096      (symbol? expr) (@vars expr) +
+ + 097      (instance? ConsCell expr) (case (CAR expr) +
+ + 098                                  COND (prog-cond (CDR expr) +
+ + 099                                                  vars env depth) +
+ + 100                                  GO (let [target (CADR expr)] +
+ + 101                                       (when (traced? 'PROG) +
+ + 102                                         (println "  PROG:GO: Goto " target)) +
+ + 103                                       (make-cons-cell +
+ + 104                                        '*PROGGO* target)) +
+ + 105                                  RETURN (let [val (prog-eval +
+ + 106                                                    (CADR expr) +
+ + 107                                                    vars env depth)] +
+ + 108                                           (when (traced? 'PROG) +
+ + 109                                             (println "  PROG:RETURN: Returning " +
+ + 110                                                      val)) +
+ + 111                                           (make-cons-cell +
+ + 112                                            '*PROGRETURN* +
+ + 113                                            val)) +
+ + 114                                  SET (let [var (prog-eval (CADR expr) +
+ + 115                                                           vars env depth) +
+ + 116                                            val (prog-eval (CADDR expr) +
+ + 117                                                           vars env depth)] +
+ + 118                                        (when (traced? 'PROG) +
+ + 119                                          (println "  PROG:SET: Setting " +
+ + 120                                                   var " to " val)) +
+ + 121                                        (swap! vars +
+ + 122                                               assoc +
+ + 123                                               var +
+ + 124                                               val) +
+ + 125                                        val) +
+ + 126                                  SETQ (let [var (CADDR expr) +
+ + 127                                             val (prog-eval var +
+ + 128                                                            vars env depth)] +
+ + 129                                         (when (traced? 'PROG) +
+ + 130                                           (println "  PROG:SETQ: Setting " var " to " val)) +
+ + 131                                         (swap! vars +
+ + 132                                                assoc +
+ + 133                                                (CADR expr) +
+ + 134                                                val) +
+ + 135                                         val) +
+ + 136                                   ;; else +
+ + 137                                  (beowulf.bootstrap/EVAL expr +
+ + 138                                                          (merge-vars vars env) +
+ + 139                                                          depth)))) +
+ + 140   +
+ + 141  (defn PROG +
+ + 142    "The accursed `PROG` feature. See page 71 of the manual. +
+ + 143      +
+ + 144     Lisp 1.5 introduced `PROG`, and most Lisps have been stuck with it ever  +
+ + 145     since. It introduces imperative programming into what should be a pure  +
+ + 146     functional language, and consequently it's going to be a pig to implement. +
+ + 147      +
+ + 148     Broadly, `PROG` is a variadic pseudo function called as a `FEXPR` (or  +
+ + 149     possibly an `FSUBR`, although I'm not presently sure that would even work.) +
+ + 150   +
+ + 151     The arguments, which are unevaluated, are a list of forms, the first of  +
+ + 152     which is expected to be a list of symbols which will be treated as names  +
+ + 153     of variables within the program, and the rest of which (the 'program body') +
+ + 154     are either lists or symbols. Lists are treated as Lisp expressions which +
+ + 155     may be evaulated in turn. Symbols are treated as targets for the `GO`  +
+ + 156     statement.  +
+ + 157         +
+ + 158     **GO:**  +
+ + 159     A `GO` statement takes the form of `(GO target)`, where  +
+ + 160     `target` should be one of the symbols which occur at top level among that +
+ + 161     particular invocation of `PROG`s arguments. A `GO` statement may occur at  +
+ + 162     top level in a PROG, or in a clause of a `COND` statement in a `PROG`, but +
+ + 163     not in a function called from the `PROG` statement. When a `GO` statement +
+ + 164     is evaluated, execution should transfer immediately to the expression which +
+ + 165     is the argument list immediately following the symbol which is its target. +
+ + 166   +
+ + 167     If the target is not found, an error with the code `A6` should be thrown. +
+ + 168   +
+ + 169     **RETURN:**  +
+ + 170     A `RETURN` statement takes the form `(RETURN value)`, where  +
+ + 171     `value` is any value. Following the evaluation of a `RETURN` statement,  +
+ + 172     the `PROG` should immediately exit without executing any further  +
+ + 173     expressions, returning the  value. +
+ + 174   +
+ + 175     **SET and SETQ:** +
+ + 176     In addition to the above, if a `SET` or `SETQ` expression is encountered +
+ + 177     in any expression within the `PROG` body, it should affect not the global +
+ + 178     object list but instead only the local variables of the program. +
+ + 179   +
+ + 180     **COND:** +
+ + 181     In **strict** mode, when in normal execution, a `COND` statement none of  +
+ + 182     whose clauses match should not return `NIL` but should throw an error with +
+ + 183     the code `A3`... *except* that inside a `PROG` body, it should not do so. +
+ + 184     *sigh*. +
+ + 185   +
+ + 186     **Flow of control:** +
+ + 187     Apart from the exceptions specified above, expressions in the program body +
+ + 188     are evaluated sequentially. If execution reaches the end of the program  +
+ + 189     body, `NIL` is returned. +
+ + 190   +
+ + 191     Got all that? +
+ + 192   +
+ + 193     Good." +
+ + 194    [program env depth] +
+ + 195    (let [trace (traced? 'PROG) +
+ + 196          vars (atom (reduce merge (map #(assoc {} % NIL) (.getCar program)))) +
+ + 197          body (.getCdr program) +
+ + 198          targets (set (filter symbol? body))] +
+ + 199      (when trace (do +
+ + 200                    (println "Program:") +
+ + 201                    (pretty-print program))) ;; for debugging +
+ + 202      (loop [cursor body] +
+ + 203        (let [step (if (= NIL cursor) NIL (.getCar cursor))] +
+ + 204          (when trace (do (println "Executing step: " step) +
+ + 205                          (println "  with vars: " @vars))) +
+ + 206          (cond (= cursor NIL) NIL +
+ + 207                (symbol? step) (recur (.getCdr cursor)) +
+ + 208                :else (let [v (prog-eval (.getCar cursor) vars env depth)] +
+ + 209                        (when trace (println "  --> " v)) +
+ + 210                        (if (instance? ConsCell v) +
+ + 211                          (case (.getCar v) +
+ + 212                            *PROGGO* (let [target (.getCdr v)] +
+ + 213                                       (if (targets target) +
+ + 214                                         (recur (find-target target body)) +
+ + 215                                         (throw (ex-info (str "Uncynlic GO miercels `" +
+ + 216                                                              target "`") +
+ + 217                                                         {:phase :lisp +
+ + 218                                                          :function 'PROG +
+ + 219                                                          :args program +
+ + 220                                                          :type :lisp +
+ + 221                                                          :code :A6 +
+ + 222                                                          :target target +
+ + 223                                                          :targets targets})))) +
+ + 224                            *PROGRETURN* (.getCdr v) +
+ + 225                          ;; else +
+ + 226                            (recur (.getCdr cursor))) +
+ + 227                          (recur (.getCdr cursor))))))))) +
+ + 228   +
+ + 229  ;;;; Tracing execution ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
230  
- - 231  ;;;; APPLY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -
- - 232   -
- 233  (defn try-resolve-subroutine + 231  (defn- trace-call
- 234    "Attempt to resolve this `subr` with these `args`." + 232    "Show a trace of a call to the function named by this `function-symbol` 
- 235    [subr args] -
- - 236    (when (and subr (not= subr NIL)) -
- - 237      (try @(resolve subr) + 233    with these `args` at this depth."
- 238           (catch Throwable any + 234    [function-symbol args depth] +
+ + 235    (when (traced? function-symbol)
- 239             (throw (ex-info "þegnung (SUBR) ne āfand" + 236      (let [indent (trace-indent depth)]
- - 240                             {:phase :apply -
- - 241                              :function subr -
- - 242                              :args args -
- - 243                              :type :beowulf} -
- - 244                             any)))))) + + 237        (println (str indent "> " function-symbol " " args)))))
- 245   + 238  
- 246  (defn- apply-symbolic + 239  (defn- trace-response
- 247    "Apply this `funtion-symbol` to these `args` in this `environment` and  + 240    "Show a trace of this `response` from the function named by this
- 248     return the result." + 241     `function-symbol` at this depth."
- 249    [^Symbol function-symbol args ^ConsCell environment depth] + 242    [function-symbol response depth]
- - 250    (trace-call function-symbol args depth) + + 243    (when (traced? function-symbol)
- - 251    (let [lisp-fn (value function-symbol '(EXPR FEXPR)) + + 244      (let [indent (apply str (trace-indent depth))]
- - 252          args' (cond (= NIL args) args + + 245        (println (str "<" indent " " function-symbol " " response))))
- - 253                      (empty? args) NIL + + 246    response)
- - 254                      (instance? ConsCell args) args + + 247  
- - 255                      :else (make-beowulf-list args)) + + 248  ;;;; Support functions for interpreter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- - 256          subr (value function-symbol '(SUBR FSUBR)) + + 249  
- - 257          host-fn (try-resolve-subroutine subr args') + + 250  (defn value
- - 258          result (cond (and lisp-fn + + 251    "Seek a value for this symbol `s` by checking each of these indicators in
- - 259                            (not= lisp-fn NIL)) (APPLY lisp-fn args' environment depth) + + 252     turn."
- - 260                       host-fn (try + + 253    ([s]
- 261                                 (apply host-fn (when (instance? ConsCell args') args')) + 254     (value s (list 'APVAL 'EXPR 'FEXPR 'SUBR 'FSUBR)))
- 262                                 (catch Exception any -
- - 263                                   (throw (ex-info (str "Uncynlic þegnung: " -
- - 264                                                        (.getMessage any)) -
- - 265                                                   {:phase :apply -
- - 266                                                    :function function-symbol -
- - 267                                                    :args args -
- - 268                                                    :type :beowulf} -
- - 269                                                   any)))) -
- - 270                       :else (ex-info "þegnung ne āfand" -
- - 271                                      {:phase :apply -
- - 272                                       :function function-symbol -
- - 273                                       :args args -
- - 274                                       :type :beowulf}))] + 255    ([s indicators]
- 275      (trace-response function-symbol result depth) + 256     (when (symbol? s) +
+ + 257       (first (remove #(= % NIL) (map #(GET s %)
- 276      result)) + 258                                      indicators))))))
- 277   + 259  
- 278  (defn APPLY + 260  (defn SASSOC
- 279    "Apply this `function` to these `arguments` in this `environment` and return + 261    "Like `ASSOC`, but with an action to take if no value is found.
- 280     the result. + 262     
- 281      + 263     From the manual, page 60:
- 282     For bootstrapping, at least, a version of APPLY written in Clojure. + 264     
- 283     All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. + 265     'The function `sassoc` searches `y`, which is a list of dotted pairs, for 
- 284     See page 13 of the Lisp 1.5 Programmers Manual." + 266     a pair whose first element that is `x`. If such a pair is found, the value 
- 285    [function args environment depth] + 267     of `sassoc` is this pair. Otherwise the function `u` of no arguments is 
- - 286    (trace-call 'APPLY (list function args environment) depth) + + 268     taken as the value of `sassoc`.'"
- - 287    (let [result (cond + + 269    [x y u]
- - 288                   (= NIL function) (if (:strict *options*) + + 270    (let [v (ASSOC x y)]
- - 289                                      NIL + + 271      (if-not (= v NIL) v +
+ + 272              (APPLY u NIL NIL)))) +
+ + 273   +
+ + 274   +
+ + 275  ;;;; APPLY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +
+ + 276   +
+ + 277  (defn try-resolve-subroutine +
+ + 278    "Attempt to resolve this `subr` with these `args`." +
+ + 279    [subr args] +
+ + 280    (when (and subr (not= subr NIL)) +
+ + 281      (try @(resolve subr) +
+ + 282           (catch Throwable any
- 290                                      (throw (ex-info "NIL sí ne þegnung" + 283             (throw (ex-info "þegnung (SUBR) ne āfand" +
+ + 284                             {:phase :apply +
+ + 285                              :function subr +
+ + 286                              :args args +
+ + 287                              :type :beowulf} +
+ + 288                             any)))))) +
+ + 289   +
+ + 290  (defn- apply-symbolic +
+ + 291    "Apply this `funtion-symbol` to these `args` in this `environment` and  +
+ + 292     return the result." +
+ + 293    [^Symbol function-symbol args ^ConsCell environment depth] +
+ + 294    (trace-call function-symbol args depth) +
+ + 295    (let [lisp-fn (value function-symbol '(EXPR FEXPR))  ;; <-- should these be handled differently? I think so! +
+ + 296          args' (cond (= NIL args) args +
+ + 297                      (empty? args) NIL +
+ + 298                      (instance? ConsCell args) args +
+ + 299                      :else (make-beowulf-list args)) +
+ + 300          subr (value function-symbol '(SUBR FSUBR)) +
+ + 301          host-fn (try-resolve-subroutine subr args') +
+ + 302          result (cond (and lisp-fn +
+ + 303                            (not= lisp-fn NIL)) (APPLY lisp-fn args' environment depth) +
+ + 304                       host-fn (try +
+ + 305                                 (apply host-fn (when (instance? ConsCell args') args')) +
+ + 306                                 (catch Exception any +
+ + 307                                   (throw (ex-info (str "Uncynlic þegnung: " +
+ + 308                                                        (.getMessage any)) +
+ + 309                                                   {:phase :apply +
+ + 310                                                    :function function-symbol +
+ + 311                                                    :args args +
+ + 312                                                    :type :beowulf} +
+ + 313                                                   any)))) +
+ + 314                       :else (ex-info "þegnung ne āfand" +
+ + 315                                      {:phase :apply +
+ + 316                                       :function function-symbol +
+ + 317                                       :args args +
+ + 318                                       :type :beowulf}))] +
+ + 319      (trace-response function-symbol result depth) +
+ + 320      result)) +
+ + 321   +
+ + 322  ;; (LABEL ARGS  +
+ + 323  ;;        (COND ((COND ((ONEP (LENGTH ARGS)) ARGS)  +
+ + 324  ;;                     (T (ATTRIB (CAR ARGS) (APPLY CONC (CDR ARGS) NIL))))  +
+ + 325  ;;               ARGS)))  +
+ + 326  ;; ((1 2 3 4) (5 6 7 8) (9 10 11 12))  +
+ + 327  ;; NIL +
+ + 328  ;; (def function (make-beowulf-list '(LABEL ARGS (COND  +
+ + 329  ;;    ((COND ((ONEP (LENGTH ARGS)) ARGS)  +
+ + 330  ;;           (T (ATTRIB (CAR ARGS)  +
+ + 331  ;;                      (APPLY CONC (CDR ARGS) NIL)))) +
+ + 332  ;;     ARGS))))) +
+ + 333  ;; (def args (make-beowulf-list '((1 2 3 4) (5 6 7 8) (9 10 11 12)))) +
+ + 334   +
+ + 335  ;; function +
+ + 336  ;; (CADR function) +
+ + 337  ;; (CADDR function) +
+ + 338   +
+ + 339  (defn apply-label +
+ + 340    "Apply in the special case that the first element in the function is `LABEL`." +
+ + 341    [function args environment depth] +
+ + 342    (EVAL +
+ + 343     (CADDR function) +
+ + 344     (CONS +
+ + 345      (CONS (CADR function) args) +
+ + 346      environment) +
+ + 347     depth)) +
+ + 348   +
+ + 349  ;; (apply-label function args NIL 1) +
+ + 350  ;; (APPLY function args NIL 1) +
+ + 351   +
+ + 352  (defn- apply-lambda +
+ + 353    "Apply in the special case that the first element in the function is `LAMBDA`." +
+ + 354    [function args environment depth] +
+ + 355    (EVAL +
+ + 356     (CADDR function) +
+ + 357     (PAIRLIS (CADR function) args environment) depth)) +
+ + 358   +
+ + 359  (defn APPLY +
+ + 360    "Apply this `function` to these `arguments` in this `environment` and return +
+ + 361     the result. +
+ + 362      +
+ + 363     For bootstrapping, at least, a version of APPLY written in Clojure. +
+ + 364     All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. +
+ + 365     See page 13 of the Lisp 1.5 Programmers Manual." +
+ + 366    ([function args environment] +
+ + 367     (APPLY function args environment *depth*)) +
+ + 368    ([function args environment depth] +
+ + 369     (binding [*depth* (inc depth)] +
+ + 370       (trace-call 'APPLY (list function args environment) depth) +
+ + 371       (let [result (cond +
+ + 372                      (= NIL function) (if (:strict *options*) +
+ + 373                                         NIL +
+ + 374                                         (throw (ex-info "NIL sí ne þegnung"
- 291                                                      {:phase :apply + 375                                                         {:phase :apply
- 292                                                       :function "NIL" + 376                                                          :function "NIL"
- 293                                                       :args args + 377                                                          :args args
- 294                                                       :type :beowulf}))) + 378                                                          :type :beowulf})))
- 295                   (= (ATOM function) T) (apply-symbolic function args environment (inc depth)) + 379                      (= (ATOM function) T) (apply-symbolic function args environment (inc depth))
- 296                   :else (case (first function) -
- - 297                           LABEL (APPLY -
- - 298                                  (CADDR function) -
- - 299                                  args -
- - 300                                  (make-cons-cell -
- - 301                                   (make-cons-cell -
- - 302                                    (CADR function) -
- - 303                                    (CADDR function)) -
- - 304                                   environment) -
- - 305                                  depth) -
- - 306                           FUNARG (APPLY (CADR function) args (CADDR function) depth) -
- - 307                           LAMBDA (EVAL -
- - 308                                   (CADDR function) -
- - 309                                   (PAIRLIS (CADR function) args environment) depth) -
- - 310                           (throw (ex-info "Ungecnáwen wyrþan sí þegnung-weard" -
- - 311                                           {:phase :apply -
- - 312                                            :function function -
- - 313                                            :args args -
- - 314                                            :type :beowulf}))))] -
- - 315      (trace-response 'APPLY result depth) -
- - 316      result)) -
- - 317   -
- - 318  ;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -
- - 319   -
- - 320  (defn- EVCON -
- - 321    "Inner guts of primitive COND. All `clauses` are assumed to be -
- - 322    `beowulf.cons-cell/ConsCell` objects. Note that tests in Lisp 1.5 -
- - 323     often return `F`, not `NIL`, on failure. If no clause matches, -
- - 324     then, strictly, we throw an error with code `:A3`. -
- - 325   -
- - 326     See pages 13 and 71 of the Lisp 1.5 Programmers Manual." -
- - 327    [clauses env depth] -
- - 328    (loop [clauses' clauses] + 380                      :else (case (first function)
- 329      (if-not (= clauses' NIL) -
- - 330        (let [test (EVAL (CAAR clauses') env depth)] -
- - 331          (if (not (#{NIL F} test)) -
- - 332           ;; (and (not= test NIL) (not= test F)) -
- - 333            (EVAL (CADAR clauses') env depth) -
- - 334            (recur (.getCdr clauses')))) -
- - 335        (if (:strict *options*) -
- - 336          (throw (ex-info "Ne ġefōg dǣl in COND" + 381                              LABEL (apply-label function args environment depth)
- 337                          {:phase :eval + 382                              FUNARG (APPLY (CADR function) args (CADDR function) depth) +
+ + 383                              LAMBDA (apply-lambda function args environment depth)
- 338                           :function 'COND -
- - 339                           :args (list clauses) + 384                              ;; else
- 340                           :type :lisp + 385                              ;; OK, this is *not* what is says in the manual...
- 341                           :code :A3})) + 386                              ;; COND (EVCON ???) +
+ + 387                              (throw (ex-info "Ungecnáwen wyrþan sí þegnung-weard" +
+ + 388                                              {:phase :apply
- 342          NIL)))) + 389                                               :function function
- - 343   -
- - 344  (defn- EVLIS + + 390                                               :args args
- 345    "Map `EVAL` across this list of `args` in the context of this -
- - 346    `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects. -
- - 347    See page 13 of the Lisp 1.5 Programmers Manual." -
- - 348    [args env depth] -
- - 349    (cond -
- - 350      (= NIL args) NIL -
- - 351      :else -
- - 352      (make-cons-cell -
- - 353       (EVAL (CAR args) env depth) -
- - 354       (EVLIS (CDR args) env depth)))) -
- - 355   -
- - 356  (defn- eval-symbolic -
- - 357    [expr env depth] + 391                                               :type :beowulf}))))]
- 358    (let [v (ASSOC expr env) + 392         (trace-response 'APPLY result depth) +
+ + 393         result)))) +
+ + 394   +
+ + 395  ;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +
+ + 396   +
+ + 397  (defn- EVCON +
+ + 398    "Inner guts of primitive COND. All `clauses` are assumed to be +
+ + 399    `beowulf.cons-cell/ConsCell` objects. Note that tests in Lisp 1.5 +
+ + 400     often return `F`, not `NIL`, on failure. If no clause matches, +
+ + 401     then, strictly, we throw an error with code `:A3`. +
+ + 402   +
+ + 403     See pages 13 and 71 of the Lisp 1.5 Programmers Manual." +
+ + 404    [clauses env depth] +
+ + 405    (loop [clauses' clauses] +
+ + 406      (if-not (= clauses' NIL) +
+ + 407        (let [test (EVAL (CAAR clauses') env depth)] +
+ + 408          (if (not (#{NIL F} test)) +
+ + 409           ;; (and (not= test NIL) (not= test F))
- 359          indent (apply str (repeat depth "-"))] + 410            (EVAL (CADAR clauses') env depth) +
+ + 411            (recur (.getCdr clauses')))) +
+ + 412        (if (:strict *options*) +
+ + 413          (throw (ex-info "Ne ġefōg dǣl in COND" +
+ + 414                          {:phase :eval +
+ + 415                           :function 'COND +
+ + 416                           :args (list clauses) +
+ + 417                           :type :lisp +
+ + 418                           :code :A3})) +
+ + 419          NIL)))) +
+ + 420   +
+ + 421  (defn- EVLIS +
+ + 422    "Map `EVAL` across this list of `args` in the context of this +
+ + 423    `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects. +
+ + 424    See page 13 of the Lisp 1.5 Programmers Manual." +
+ + 425    [args env depth] +
+ + 426    (cond +
+ + 427      (= NIL args) NIL +
+ + 428      :else +
+ + 429      (make-cons-cell +
+ + 430       (EVAL (CAR args) env depth) +
+ + 431       (EVLIS (CDR args) env depth)))) +
+ + 432   +
+ + 433  (defn- eval-symbolic +
+ + 434    [expr env depth] +
+ + 435    (let [v (ASSOC expr env) +
+ + 436          indent (apply str (repeat depth "-"))]
- 360      (when (traced? 'EVAL) + 437      (when (traced? 'EVAL)
- 361        (println (str indent ": EVAL: sceald bindele: " (or v "nil")))) + 438        (println (str indent ": EVAL: sceald bindele: " (or v "nil"))))
- 362      (if (instance? ConsCell v) + 439      (if (instance? ConsCell v)
- 363        (.getCdr v) -
- - 364        (let [v' (value expr (list 'APVAL))] -
- - 365          (when (traced? 'EVAL) -
- - 366            (println (str indent ": EVAL: deóp bindele: (" expr " . " (or v' "nil") ")"))) -
- - 367          (if v' -
- - 368            v' -
- - 369            (throw (ex-info "Ne tácen-bindele āfand" -
- - 370                            {:phase :eval -
- - 371                             :function 'EVAL -
- - 372                             :args (list expr env depth) -
- - 373                             :type :lisp -
- - 374                             :code :A8}))))))) -
- - 375   -
- - 376  (defn EVAL -
- - 377    "Evaluate this `expr` and return the result. If `environment` is not passed, -
- - 378     it defaults to the current value of the global object list. The `depth` -
- - 379     argument is part of the tracing system and should not be set by user code. -
- - 380   -
- - 381     All args are assumed to be numbers, symbols or `beowulf.cons-cell/ConsCell`  -
- - 382     objects. However, if called with just a single arg, `expr`, I'll assume it's -
- - 383     being called from the Clojure REPL and will coerce the `expr` to `ConsCell`." -
- - 384    ([expr] -
- - 385     (let [expr' (if (and (coll? expr) (not (instance? ConsCell expr))) -
- - 386                   (make-beowulf-list expr) -
- - 387                   expr)] -
- - 388       (EVAL expr' NIL 0))) -
- - 389    ([expr env depth] -
- - 390     (trace-call 'EVAL (list expr env depth) depth) -
- - 391     (let [result (cond + 440        (.getCdr v)
- 392                    (= NIL expr) NIL ;; it was probably a mistake to make Lisp  + 441        (let [v' (value expr)]
- - 393                                     ;; NIL distinct from Clojure nil + + 442          (when (traced? 'EVAL)
- - 394                    (= (NUMBERP expr) T) expr -
- - 395                    (symbol? expr) (eval-symbolic expr env depth) -
- - 396                    (string? expr) (if (:strict *options*) -
- - 397                                     (throw -
- - 398                                      (ex-info -
- - 399                                       (str "EVAL: strings not allowed in strict mode: \"" expr "\"") -
- - 400                                       {:phase  :eval -
- - 401                                        :detail :strict -
- - 402                                        :expr   expr})) -
- - 403                                     (symbol expr)) -
- - 404                    (= (ATOM (CAR expr)) T) (case (CAR expr) -
- - 405                                              COND (EVCON (CDR expr) env depth) -
- - 406                                              FUNCTION (LIST 'FUNARG (CADR expr)) -
- - 407                                              PROG (PROG (CDR expr) env depth) -
- - 408                                              QUOTE (CADR expr) -
- - 409             ;; else  + + 443            (println (str indent ": EVAL: deóp bindele: (" expr " . " (or v' "nil") ")")))
- 410                                              (APPLY + 444          (if v'
- - 411                                               (CAR expr) + + 445            v'
- 412                                               (EVLIS (CDR expr) env depth) + 446            (throw (ex-info (format "Ne tácen-bindele āfand: `%s`" expr)
- - 413                                               env + + 447                            {:phase :eval
- - 414                                               depth)) -
- - 415                    :else (APPLY -
- - 416                           (CAR expr) -
- - 417                           (EVLIS (CDR expr) env depth) -
- - 418                           env -
- - 419                           depth))] + + 448                             :function 'EVAL
- 420       (trace-response 'EVAL result depth) + 449                             :args (list expr env depth)
- - 421       result))) + + 450                             :type :lisp +
+ + 451                             :code :A8})))))))
- 422   + 452   +
+ + 453  (defn EVAL +
+ + 454    "Evaluate this `expr` and return the result. If `environment` is not passed, +
+ + 455     it defaults to the current value of the global object list. The `depth` +
+ + 456     argument is part of the tracing system and should not be set by user code. +
+ + 457   +
+ + 458     All args are assumed to be numbers, symbols or `beowulf.cons-cell/ConsCell`  +
+ + 459     objects. However, if called with just a single arg, `expr`, I'll assume it's +
+ + 460     being called from the Clojure REPL and will coerce the `expr` to `ConsCell`." +
+ + 461    ([expr] +
+ + 462     (let [expr' (if (and (coll? expr) (not (instance? ConsCell expr))) +
+ + 463                   (make-beowulf-list expr) +
+ + 464                   expr)] +
+ + 465       (EVAL expr' NIL 0))) +
+ + 466    ([expr env depth] +
+ + 467     (trace-call 'EVAL (list expr env depth) depth) +
+ + 468     (let [result (cond +
+ + 469                    (= NIL expr) NIL ;; it was probably a mistake to make Lisp  +
+ + 470                                     ;; NIL distinct from Clojure nil +
+ + 471                    (= (NUMBERP expr) T) expr +
+ + 472                    (symbol? expr) (eval-symbolic expr env depth) +
+ + 473                    (string? expr) (if (:strict *options*) +
+ + 474                                     (throw +
+ + 475                                      (ex-info +
+ + 476                                       (str "EVAL: strings not allowed in strict mode: \"" expr "\"") +
+ + 477                                       {:phase  :eval +
+ + 478                                        :detail :strict +
+ + 479                                        :expr   expr})) +
+ + 480                                     (symbol expr)) +
+ + 481                    (= (ATOM (CAR expr)) T) (case (CAR expr) +
+ + 482                                              COND (EVCON (CDR expr) env depth) +
+ + 483                                              FUNCTION (LIST 'FUNARG (CADR expr)) +
+ + 484                                              PROG (PROG (CDR expr) env depth) +
+ + 485                                              QUOTE (CADR expr) +
+ + 486             ;; else  +
+ + 487                                              (APPLY +
+ + 488                                               (CAR expr) +
+ + 489                                               (EVLIS (CDR expr) env depth) +
+ + 490                                               env +
+ + 491                                               depth)) +
+ + 492                    :else (EVAL (CONS (CDR (SASSOC (CAR expr) env (fn [] (ERROR 'A9)))) +
+ + 493                                      (CDR expr)) +
+ + 494                                env +
+ + 495                                (inc depth)))] +
+ + 496       (trace-response 'EVAL result depth) +
+ + 497       result))) +
+ + 498  
diff --git a/docs/cloverage/beowulf/host.clj.html b/docs/cloverage/beowulf/host.clj.html index e11a000..69b2501 100644 --- a/docs/cloverage/beowulf/host.clj.html +++ b/docs/cloverage/beowulf/host.clj.html @@ -659,7 +659,7 @@ 218               :args (list cell value)
- 219               :type :beowulf}))));; PLUS + 219               :type :beowulf}))))
220   @@ -1352,424 +1352,478 @@ 449  
- 450  (defn PUT + 450  (defn ATTRIB
- 451    "Put this `value` as the value of the property indicated by this `indicator`  + 451    "Destructive append. From page 59 of the manual:
- 452     of this `symbol`. Return `value` on success. + 452     
- 453      + 453     The function `attrib` concatenates its two arguments by changing the last 
- 454     NOTE THAT there is no `PUT` defined in the manual, but it would have been  + 454     element of its first argument to point to the second argument. Thus it
- 455     easy to have defined it so I don't think this fully counts as an extension." + 455     is commonly used to tack something onto the end of a property list. 
- 456    [symbol indicator value] + 456     The value of `attrib` is the second argument. +
+ + 457   +
+ + 458     For example +
+ + 459     ``` +
+ + 460     attrib[FF; (EXPR (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR x))))))] +
+ + 461     ``` +
+ + 462     would put EXPR followed by the LAMBDA expression for FF onto the end of  +
+ + 463     the property list for FF." +
+ + 464    [x e] +
+ + 465    (loop [l x] +
+ + 466      (cond
- 457    (let [binding (ASSOC symbol @oblist)] -
- - 458      (if (instance? ConsCell binding) + 467        (instance? ConsCell (CDR l)) (recur (CDR l))
- 459        (let [prop (hit-or-miss-assoc indicator (CDDR binding))] + 468        :else (when (RPLACD l e) e)))) +
+ + 469   +
+ + 470  (defn PUT +
+ + 471    "Put this `value` as the value of the property indicated by this `indicator`  +
+ + 472     of this `symbol`. Return `value` on success. +
+ + 473      +
+ + 474     NOTE THAT there is no `PUT` defined in the manual, but it would have been  +
+ + 475     easy to have defined it so I don't think this fully counts as an extension." +
+ + 476    [symbol indicator value] +
+ + 477    (let [binding (ASSOC symbol @oblist)]
- 460          (if (instance? ConsCell prop) + 478      (if (instance? ConsCell binding) +
+ + 479        (let [prop (hit-or-miss-assoc indicator (CDDR binding))] +
+ + 480          (if (instance? ConsCell prop)
- 461            (RPLACA (CDR prop) value) + 481            (RPLACA (CDR prop) value) +
+ + 482            ;; The implication is ATTRIB was used here, but I have not made that +
+ + 483            ;; work and this does work, so if it ain't broke don't fix it.
- 462            (RPLACD binding + 484            (RPLACD binding
- 463                    (make-cons-cell + 485                    (make-cons-cell
- 464                     magic-marker + 486                     magic-marker
- 465                     (make-cons-cell + 487                     (make-cons-cell
- 466                      indicator + 488                      indicator
- 467                      (make-cons-cell value (CDDR binding))))))) + 489                      (make-cons-cell value (CDDR binding)))))))
- 468        (swap! + 490        (swap!
- 469         oblist + 491         oblist
- 470         (fn [ob s p v] + 492         (fn [ob s p v]
- 471           (make-cons-cell + 493           (make-cons-cell
- 472            (make-beowulf-list (list s magic-marker p v)) + 494            (make-beowulf-list (list s magic-marker p v))
- 473            ob)) + 495            ob))
- 474         symbol indicator value))) + 496         symbol indicator value)))
- 475    value) + 497    value)
- 476   + 498  
- 477  (defn GET + 499  (defn GET
- 478    "From the manual: + 500    "From the manual:
- 479      + 501     
- 480     '`get` is somewhat like `prop`; however its value is car of the rest of + 502     '`get` is somewhat like `prop`; however its value is car of the rest of
- 481     the list if the `indicator` is found, and NIL otherwise.' + 503     the list if the `indicator` is found, and NIL otherwise.'
- 482      + 504     
- 483     It's clear that `GET` is expected to be defined in terms of `PROP`, but + 505     It's clear that `GET` is expected to be defined in terms of `PROP`, but
- 484     we can't implement `PROP` here because we lack `EVAL`; and we can't have + 506     we can't implement `PROP` here because we lack `EVAL`; and we can't have
- 485     `EVAL` here because both it and `APPLY` depends on `GET`. + 507     `EVAL` here because both it and `APPLY` depends on `GET`.
- 486      + 508     
- 487     OK, It's worse than that: the statement of the definition of `GET` (and  + 509     OK, It's worse than that: the statement of the definition of `GET` (and 
- 488     of) `PROP` on page 59 says that the first argument to each must be a list; + 510     of) `PROP` on page 59 says that the first argument to each must be a list;
- 489     But the in the definition of `ASSOC` on page 70, when `GET` is called its + 511     But the in the definition of `ASSOC` on page 70, when `GET` is called its
- 490     first argument is always an atom. Since it's `ASSOC` and `EVAL` which I  + 512     first argument is always an atom. Since it's `ASSOC` and `EVAL` which I 
- 491     need to make work, I'm going to assume that page 59 is wrong." + 513     need to make work, I'm going to assume that page 59 is wrong."
- 492    [symbol indicator] + 514    [symbol indicator]
- 493    (let [binding (ASSOC symbol @oblist) + 515    (let [binding (ASSOC symbol @oblist)
- 494          val (cond + 516          val (cond
- 495                (= binding NIL) NIL + 517                (= binding NIL) NIL
- 496                (= magic-marker + 518                (= magic-marker
- - 497                   (CADR binding)) (loop [b binding] -
- - 498                                    ;;  (println "GET loop, seeking " indicator ":") -
- - 499                                    ;;  (pretty-print b) -
- - 500                                     (if (instance? ConsCell b) + + 519                   (CADR binding)) (let [p (hit-or-miss-assoc indicator binding)]
- 501                                       (if (= (CAR b) indicator) + 520                                     (if-not (= NIL p)
- 502                                         (CADR b) ;; <- this is what we should actually be returning + 521                                       (CADR p)
- 503                                         (recur (CDR b))) -
- - 504                                       NIL)) + 522                                       NIL))
- 505                :else (throw + 523                :else (throw
- 506                       (ex-info "Misformatted property list (missing magic marker)" + 524                       (ex-info "Misformatted property list (missing magic marker)"
- 507                                {:phase :host + 525                                {:phase :host
- 508                                 :function :get + 526                                 :function :get
- 509                                 :args (list symbol indicator) + 527                                 :args (list symbol indicator)
- 510                                 :type :beowulf})))] + 528                                 :type :beowulf})))]
- 511      ;; (println "<< GET returning: " val) + 529      ;; (println "<< GET returning: " val)
- 512      val)) + 530      val))
- 513   + 531  
- 514  (defn DEFLIST + 532  (defn DEFLIST
- 515    "For each pair in this association list `a-list`, set the property with this + 533    "For each pair in this association list `a-list`, set the property with this
- 516     `indicator` of the symbol which is the first element of the pair to the  + 534     `indicator` of the symbol which is the first element of the pair to the 
- 517     value which is the second element of the pair. See page 58 of the manual." + 535     value which is the second element of the pair. See page 58 of the manual."
- 518    [a-list indicator] + 536    [a-list indicator]
- 519    (doall + 537    (doall
- 520     (map + 538     (map
- 521      #(when (PUT (CAR %) indicator (CDR %)) (CAR %)) + 539      #(when (PUT (CAR %) indicator (CDR %)) (CAR %))
- 522      a-list))) + 540      a-list)))
- 523   + 541  
- 524  (defn DEFINE + 542  (defn DEFINE
- 525    "Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten  + 543    "Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten 
- 526    in LISP.  + 544    in LISP. 
- 527   + 545  
- 528    The single argument to `DEFINE` should be an association list of symbols to + 546    The single argument to `DEFINE` should be an association list of symbols to
- 529     lambda functions. See page 58 of the manual." + 547     lambda functions. See page 58 of the manual."
- 530    [a-list] + 548    [a-list]
- 531    (DEFLIST a-list 'EXPR)) -
- - 532   -
- - 533  (defn SET -
- - 534    "Implementation of SET in Clojure. Add to the `oblist` a binding of the -
- - 535     value of `var` to the value of `val`. NOTE WELL: this is not SETQ!" -
- - 536    [symbol val] -
- - 537    (PUT symbol 'APVAL val)) -
- - 538   -
- - 539  ;;;; TRACE and friends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -
- - 540   -
- - 541  (def traced-symbols -
- - 542    "Symbols currently being traced." -
- - 543    (atom #{})) -
- - 544   -
- - 545  (defn traced? -
- - 546    "Return `true` iff `s` is a symbol currently being traced, else `nil`." -
- - 547    [s] -
- - 548    (try (contains? @traced-symbols s) -
- - 549         (catch Throwable _ nil))) + 549    (DEFLIST a-list 'EXPR))
550  
- 551  (defn TRACE + 551  (defn SET
- 552    "Add this `s` to the set of symbols currently being traced. If `s` + 552    "Implementation of SET in Clojure. Add to the `oblist` a binding of the
- 553     is not a symbol or sequence of symbols, does nothing." + 553     value of `var` to the value of `val`. NOTE WELL: this is not SETQ!"
- 554    [s] -
- - 555    (swap! traced-symbols -
- - 556           #(cond -
- - 557              (symbol? s) (conj % s) -
- - 558              (and (seq? s) (every? symbol? s)) (union % (set s)) -
- - 559              :else %))) -
- - 560   -
- - 561  (defn UNTRACE -
- - 562    "Remove this `s` from the set of symbols currently being traced. If `s` -
- - 563     is not a symbol or sequence of symbols, does nothing." -
- - 564    [s] -
- - 565    (cond -
- - 566      (symbol? s) (swap! traced-symbols #(set (remove (fn [x] (= s x)) %))) -
- - 567      (and (seq? s) (every? symbol? s)) (map UNTRACE s)) -
- - 568    @traced-symbols) -
- - 569   -
- - 570  ;;;; Extensions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -
- - 571   -
- - 572  (defn DOC -
- - 573    "Open the page for this `symbol` in the Lisp 1.5 manual, if known, in the  -
- - 574      default web browser. -
- - 575      -
- - 576     **NOTE THAT** this is an extension function, not available in strct mode." -
- - 577    [symbol] -
- - 578    (when (lax? 'DOC) -
- - 579      (open-doc symbol))) -
- - 580   -
- - 581  (defn CONSP -
- - 582    "Return `T` if object `o` is a cons cell, else `F`. -
- - 583      -
- - 584     **NOTE THAT** this is an extension function, not available in strct mode.  -
- - 585     I believe that Lisp 1.5 did not have any mechanism for testing whether an -
- - 586     argument was, or was not, a cons cell." -
- - 587    [o] + 554    [symbol val]
- 588    (when (lax? 'CONSP) + 555    (PUT symbol 'APVAL val)) +
+ + 556   +
+ + 557  ;;;; TRACE and friends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +
+ + 558   +
+ + 559  (def traced-symbols +
+ + 560    "Symbols currently being traced." +
+ + 561    (atom #{})) +
+ + 562   +
+ + 563  (defn traced? +
+ + 564    "Return `true` iff `s` is a symbol currently being traced, else `nil`." +
+ + 565    [s] +
+ + 566    (try (contains? @traced-symbols s) +
+ + 567         (catch Throwable _ nil))) +
+ + 568   +
+ + 569  (defn TRACE +
+ + 570    "Add this `s` to the set of symbols currently being traced. If `s` +
+ + 571     is not a symbol or sequence of symbols, does nothing." +
+ + 572    [s] +
+ + 573    (swap! traced-symbols +
+ + 574           #(cond +
+ + 575              (symbol? s) (conj % s) +
+ + 576              (and (seq? s) (every? symbol? s)) (union % (set s)) +
+ + 577              :else %))) +
+ + 578   +
+ + 579  (defn UNTRACE +
+ + 580    "Remove this `s` from the set of symbols currently being traced. If `s` +
+ + 581     is not a symbol or sequence of symbols, does nothing." +
+ + 582    [s] +
+ + 583    (cond +
+ + 584      (symbol? s) (swap! traced-symbols #(set (remove (fn [x] (= s x)) %))) +
+ + 585      (and (seq? s) (every? symbol? s)) (map UNTRACE s)) +
+ + 586    @traced-symbols) +
+ + 587   +
+ + 588  ;;;; Extensions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +
+ + 589   +
+ + 590  (defn DOC +
+ + 591    "Open the page for this `symbol` in the Lisp 1.5 manual, if known, in the  +
+ + 592      default web browser. +
+ + 593      +
+ + 594     **NOTE THAT** this is an extension function, not available in strct mode." +
+ + 595    [symbol] +
+ + 596    (when (lax? 'DOC) +
+ + 597      (open-doc symbol))) +
+ + 598   +
+ + 599  (defn CONSP +
+ + 600    "Return `T` if object `o` is a cons cell, else `F`. +
+ + 601      +
+ + 602     **NOTE THAT** this is an extension function, not available in strct mode.  +
+ + 603     I believe that Lisp 1.5 did not have any mechanism for testing whether an +
+ + 604     argument was, or was not, a cons cell." +
+ + 605    [o] +
+ + 606    (when (lax? 'CONSP)
- 589      (if (instance? ConsCell o) 'T 'F))) + 607      (if (instance? ConsCell o) 'T 'F)))
diff --git a/docs/cloverage/beowulf/io.clj.html b/docs/cloverage/beowulf/io.clj.html index 0eb19d4..aaf97e7 100644 --- a/docs/cloverage/beowulf/io.clj.html +++ b/docs/cloverage/beowulf/io.clj.html @@ -283,239 +283,248 @@ 093    ([filepath]
- - 094     (spit (full-path (str filepath)) + + 094     (let [destination (full-path (str filepath))] +
+ + 095      (spit destination
- 095           (with-out-str + 096           (with-out-str
- 096             (println (apply str (repeat 79 ";"))) + 097             (println (apply str (repeat 79 ";")))
- 097             (println (format ";; Beowulf %s Sysout file generated at %s" + 098             (println (format ";; Beowulf %s Sysout file generated at %s"
- 098                              (or (System/getProperty "beowulf.version") "") + 099                              (or (System/getProperty "beowulf.version") "")
- 099                              (local-date-time))) + 100                              (local-date-time)))
- 100             (when (System/getenv "USER") + 101             (when (System/getenv "USER")
- 101               (println (format ";; generated by %s" (System/getenv "USER")))) + 102               (println (format ";; generated by %s" (System/getenv "USER"))))
- 102             (println (apply str (repeat 79 ";"))) + 103             (println (apply str (repeat 79 ";")))
- 103             (println) + 104             (println)
- 104             (let [output (safely-wrap-subrs @oblist)] + 105             (let [output (safely-wrap-subrs @oblist)]
- 105               (pretty-print output) + 106               (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 _ + 107               )))
- 165                          (throw (ex-info "Ne can ārǣde" -
- - 166                                          {:context "SYSIN" + 108       (println "Saved sysout to " destination)
- 167                                           :filename filename + 109       NIL)))
- - 168                                           :filepath fp}))))] + + 110  
- - 169       (swap! oblist + + 111  (defn resolve-subr
- - 170              #(when (or % (seq content)) + + 112    "If this oblist `entry` references a subroutine, attempt to fix up that +
+ + 113     reference." +
+ + 114    ([entry] +
+ + 115     (or (resolve-subr entry 'SUBR) +
+ + 116         (resolve-subr entry 'FSUBR))) +
+ + 117    ([entry prop] +
+ + 118     (cond (= entry NIL) NIL +
+ + 119          (= (CAR entry) prop) (try +
+ + 120                                  (make-cons-cell
- 171                 (resolve-subroutines content)))))) + 121                                   (CAR entry) +
+ + 122                                   (make-cons-cell +
+ + 123                                    (interpret-qualified-name +
+ + 124                                           (CADR entry)) +
+ + 125                                    (CDDR entry))) +
+ + 126                                  (catch Exception _ +
+ + 127                                    (print "Warnung: ne can āfinde " +
+ + 128                                           (CADR entry)) +
+ + 129                                    (CDDR entry))) +
+ + 130          :else (make-cons-cell +
+ + 131                 (CAR entry) (resolve-subr (CDR entry)))))) +
+ + 132   +
+ + 133   +
+ + 134  (defn- resolve-subroutines +
+ + 135    "Attempt to fix up the references to subroutines (Clojure functions) among +
+ + 136     these `objects`, being new content for the object list." +
+ + 137    [objects] +
+ + 138    (make-beowulf-list +
+ + 139     (map +
+ + 140      resolve-subr +
+ + 141      objects))) +
+ + 142   +
+ + 143  (defn SYSIN +
+ + 144    "Read the contents of the file at this `filename` into the object list.  +
+ + 145      +
+ + 146     If the file is not a valid Beowulf sysout file, this will probably  +
+ + 147     corrupt the system, you have been warned. File paths will be considered  +
+ + 148     relative to the filepath set when starting Lisp. +
+ + 149   +
+ + 150     It is intended that sysout files can be read both from resources within +
+ + 151     the jar file, and from the file system. If a named file exists in both the +
+ + 152     file system and the resources, the file system will be preferred. +
+ + 153      +
+ + 154     **NOTE THAT** if the provided `filename` does not end with `.lsp` (which, +
+ + 155     if you're writing it from the Lisp REPL, it won't), the extension `.lsp` +
+ + 156     will be appended. +
+ + 157      +
+ + 158     **NOTE THAT** this is an extension function, not available in strct mode." +
+ + 159    ([] +
+ + 160     (SYSIN (or (:read *options*) (str "resources/" default-sysout)))) +
+ + 161    ([filename] +
+ + 162     (let [fp (file (full-path (str filename))) +
+ + 163           file (when (and (.exists fp) (.canRead fp)) fp) +
+ + 164           res (try (resource filename) +
+ + 165                    (catch Throwable _ nil)) +
+ + 166           content (try (READ (slurp (or file res))) +
+ + 167                        (catch Throwable _ +
+ + 168                          (throw (ex-info "Ne can ārǣde" +
+ + 169                                          {:context "SYSIN" +
+ + 170                                           :filename filename +
+ + 171                                           :filepath fp}))))] +
+ + 172       (swap! oblist +
+ + 173              #(when (or % (seq content)) +
+ + 174                 (resolve-subroutines content))))))
diff --git a/docs/cloverage/index.html b/docs/cloverage/index.html index dbe60af..bb572ba 100644 --- a/docs/cloverage/index.html +++ b/docs/cloverage/index.html @@ -16,20 +16,20 @@ beowulf.bootstrap
625
351
-64.04 % + style="width:68.25251601097895%; + float:left;"> 746
347
+68.25 %
138
19
75
-67.67 % -42233232 + style="width:64.31372549019608%; + float:left;"> 164
21
70
+72.55 % +49843255 beowulf.cons-cell
beowulf.host
1389
1072
-56.44 % + style="width:56.92369802180057%; + float:left;"> 1410
1067
+56.92 %
199
203
32
33
-87.50 % -58967264 + style="width:11.985018726591761%; + float:left;"> 32 +88.01 % +60769267 beowulf.interop
beowulf.io
142
181
-43.96 % + style="width:56.96969696969697%; + float:left;"> 188
+43.03 %
33
6
33
-54.17 % -1711272 + style="width:42.666666666666664%; + float:left;"> 32
7
36
+52.00 % +1741275 beowulf.manual
Totals: -68.60 % +69.16 % -77.76 % +78.39 %