;; The beastie runtime, containing the functionality of the program ;; layered above the basic parsing functions. ;; ;; I am somewhat inconsisent about which functions are starred ;; -- loosely indicating internal-only -- and which are not. Some of ;; the functions here with a prefix naming a parser, such as ;; authors:make, are tightly integrated with, for example, calls in ;; the bison parsers, and should never be called from anywhere else. ;; A bit of renaming would be useful. ;; ;; Note: s7 takes 'a to be equivalent to (#_quote a), not (quote a). ;; ;; This file is part of Beastie ;; SPDX-FileCopyrightText: 2023 Norman Gray ;; SPDX-License-Identifier: BSD-2-Clause (define *verbosity-normal* 1) (define *verbosity-info* 2) (define *verbosity-trace* 3) (define *verbosity* *verbosity-normal*) (define *verbosity-debug-flags* #xffff) (define (verbosity arg) ;; if the argument is 'up or 'down, then adjust *verbosity*; ;; if it's an integer, then set the debug-flags variable to that integer. (cond ((integer? arg) (set! *verbosity-debug-flags* arg)) ((eqv? arg 'up) (set! *verbosity* (+ *verbosity* 1))) ((eqv? arg 'down) (when (> *verbosity* 0) (set! *verbosity* (- *verbosity* 1)))) (else (beastie-error "verbosity: unexpected argument ~s" arg)))) ;; The macro %module-verbosity-flag% should be redeclared ;; appropriately in each module which uses print-info or print-trace macros. (define-macro (%module-verbosity-flag%) 1) ;for the runtime module (define-macro (verbosity? level) ;; (verbosity? info) : evaluates to #t if *verbosity* is at least *verbosity-info* ;; internal function (despite no stars): is the verbosity at least 'normal/'info/'trace? `(and (>= *verbosity* ,(case level ((normal) *verbosity-normal*) ((info) *verbosity-info*) ((trace) *verbosity-trace*) (else ; programmer error (beastie-error "bad argument to verbosity?: ~s" level)))) (> (logand (%module-verbosity-flag%) *verbosity-debug-flags*) 0))) ;; for convenience, and prettiness (define λ lambda) ;; CONFIG : symbol? -> any ;; CONFIG : symbol? any -> any ;; Sets a configuration value if given two arguments, retrieves it (#f if absent) if given one. ;; This might make more sense as a varlet environment, ;; which would allow things like let-temporarily. (define config (let ((*vars* (make-hash-table 8 eqv?))) (lambda (k . val) (if (null? val) (*vars* k) (hash-table-set! *vars* k (car val)))))) (define (initialise-runtime! target-env) (define (path->list s) ;; (string-split isn't available at this point) (define (add1 i) (+ i 1)) (let ((slen (string-length s))) (let loop ((start 0) (idx 0) (res '())) ;(eprintf "(~s,~s) res=~s~%" start idx res) (cond ((> start slen) (reverse! res)) ((or (= idx slen) (char=? (string-ref s idx) #\:)) (let ((idx1 (add1 idx))) (if (= idx start) (loop idx1 idx1 (cons "." res)) (let ((element (substring s start idx))) (if (directory? element) (loop idx1 idx1 (cons element res)) (loop idx1 idx1 res)))))) (else (loop start (add1 idx) res)))))) (let ((load-path-envvar (getenv "BEASTIE_LOAD_PATH"))) ;; Split this environment variable at colons, and add directories to ;; *load-path*. An empty element is filled in with ".". (when load-path-envvar (set! *load-path* (path->list load-path-envvar)))) ;; load everything exposed by scheme-utils.scm into the top-level (module/let* 'utils target-env #f) ;; load _selected_ things from the ustrings module, ;; so that readermacros.scm:dquotes-reader* will work (module/let* 'unicode target-env '(make-ustring ustring-append! unicode-decode1/port/utf8)) ;; these reader macros were loaded when we called initialise_runtime() ;; in beastie.c (set! *#readers* `((#\" . ,dquotes-reader*) (#\; . ,srfi62-comments) . ,*#readers*))) (define (basic-repl*) (display "1> ") (let loop ((n 2) (expr (read))) (unless (eof-object? expr) (call/error-handler (lambda () ;; the following is basically (write (eval expr (rootlet))), ;; but it behaves well if expr returns multiple values ((lambda args (for-each (λ (v) (write v) (newline)) args)) (eval expr (rootlet)))) `((repl ,n))) (printf "~a> " n) (catch #t (λ () (loop (+ n 1) (read))) (λ (tag info) (let ((msg (apply sprintf info))) (eprintf "read error (~s): ~a~%" tag msg) (loop (+ n 1) (read)))))))) ;; Call the thunk, catching errors and responding in a program-standard way. ;; Returns what (thunk) returns, or #f on error. (define (call/error-handler thunk . context) (catch #t (λ () (catch 'beastie thunk (λ (tag info) ;; this has been thrown by beastie-error/assoc ;(eprintf "call/error-handler: beastie error tag=~s info=~s~%" tag info) ;; At trace verbosity, the INFO includes a stacktrace string, ;; which does appear to be informative ;; ;; info is ("msg" ((key . value) ...)) (eprintf "beastie error: ~a~%" (car info)) (for-each (lambda (p) (eprintf " [~a: ~s]~%" (car p) (cdr p))) (cadr info)) #f))) (λ (tag info) (eprintf "call/error-handler (general, tag=~s): info=~s~%" tag info) (let ((msg (apply sprintf info))) (eprintf "error (~s): ~a~%" tag msg) (when (verbosity? info) ;; display the contents of (owlet) -- this is _occasionally_ useful (for-each (λ (p) (eprintf " ~s -> ~s~%" (car p) (cdr p))) (owlet)) (when (verbosity? trace) ;; this is almost never useful! ;; In fact, this is _so_ un-useful I strongly suspect I'm using it wrongly. ;(eprintf "stacktrace: ~s~%" (((owlet) 'stacktrace))) (eprintf "stacktrace:~%") (display (((owlet) 'stacktrace))) (newline))) (unless (null? context) (eprintf "Context: ~s~%" context)) #f)))) ;; put this early so that we can trace functions below, if necessary (define-macro (trace! fn) "`(trace! fn)` : redefine function `fn` so that it displays calls" `(define ,fn (let ((fn* ,fn)) (λ args (let ((res (catch #t (λ () (apply fn* args)) (λ (tag info) (eprintf "~s -> [error ~s ~s]~%" (cons (quote ,fn) args) tag info) (apply throw (cons tag info)))))) (eprintf "~s -> ~s~%" (cons (quote ,fn) args) res) res))))) (define (printf fmt . args) #"""`(printf fmt arg...)` : format and print to stdout. The format string argument can include a list of escapes, to indicate where the following arguments should be placed. These escapes can be: * `~a` to print an argument in the most natural way. * `~s` to print it in an unambiguous way (eg, strings will format as `"str"` rather than plain `str`). * `~%` output a newline. * `~~` output a tilde. """ (apply format `(#t ,fmt . ,args))) (define (sprintf fmt . args) "`(sprintf fmt arg...)` : like `printf`, except returning a string" (apply format `(#f ,fmt . ,args))) (define (eprintf fmt . args) "`(eprintf fmt arg...)` : like `printf`, except printing to stderr" (apply format `(,(current-error-port) ,fmt . ,args))) (define (load/error-handler filename) (call/error-handler (lambda () (if filename (load filename) (let () (let loop ((form (read))) (unless (eof-object? form) (eval form (outlet (curlet))) (loop (read))))))) `((action load) (filename ,(or filename "*stdin*"))))) ;; BEASTIE-ERROR : string? any... -> no return ;; BEASTIE-ERROR : symbol? string? any... -> no return ;; Format the FMT with the ARGS, and raise an error with tag 'beastie. ;; If the first argument is a symbol, then the second argument is the format, ;; and we should raise an error with the symbol as 'subtag' ;; ;; When we catch this with ;; ;; (catch 'beastie ;; (λ () ...) ;; (λ (tag info . rest) ...) ;; ;; the 'tag' is 'beastie ;; and the info is ("msg" ((key . value) ...)), where the key can (currently) be ;; 'possible-location, 'subtag, or 'stack. ;; ;; I have changed my mind multiple times about the best thing to do ;; here, best compatible with s7's rather hand-waving description of ;; its own default error behaviour. (define (beastie-error fmt . args) (let ((msg (cond ((string? fmt) (apply sprintf (cons fmt args))) ((null? args) "[no error message!]") ((symbol? fmt) (apply sprintf args)) (else (eprintf "Weird call to beastie-error, with fmt=~s" fmt) (apply sprintf args)))) (alist ;; this location may or may not be useful (cons `(possible-location . ,(sprintf "~a:~a" (port-filename) (port-line-number))) (if (symbol? fmt) `((subtag . ,fmt)) '())))) (if (verbosity? info) (beastie-error/assoc msg (cons (cons 'stack (stacktrace)) alist)) (beastie-error/assoc msg alist)))) ;; BEASTIE-ERROR/ASSOC : string? assq? -> no return ;; Raise an error tagged 'beastie, with the assoc as extra information. ;; The alist argument is a (listof (symbol? . any)...) ;; ;; s7's throw is a bit confusing, but (throw tag x y z ...) results in ;; a handler (lambda args ...) receiving args = (tag (x y z ...)) (define (beastie-error/assoc msg alist) ;(eprintf "beastie-error/assoc: msg=~s~%alist=~s~%" msg alist) (throw 'beastie msg alist)) ;; make a circular list, for warning messages ;; (cl 'add "msg") -- add to the list ;; (cl 'get-count) -- return the number of messges added ;; (cl 'get-list) -- return at most `size` messages, and reset the count (define (make-circular-list size) (let ((l (make-list size #f)) (count 0)) (set-cdr! (list-tail l (- size 1)) l) (λ (cmd . rest) (case cmd ((add) (set! count (+ count 1)) (set-car! l (car rest)) (set! l (cdr l)) count) ((get-count) count) ((get-list) (let ((returncount (if (< count size) count size)) (skip (if (< count size) (- size count) 0))) (set! count 0) (let loop ((ll (if (= skip 0) l (list-tail l skip))) (n returncount)) (if (= n 0) '() (cons (car ll) (loop (cdr ll) (- n 1))))))) (else (beastie-error "make-warnings-list: bad command ~s" cmd)))))) ;; PRINT-WARNING : string? ... -> unspecified ; prints warning ;; PRINT-WARNING : 'get-count -> integer? ; number of warnings so far ;; (but don't reset count) ;; PRINT-WARNING : 'get-list -> listof string? ; return the warnings and reset the list ;; PRINT-WARNING : 'push output-port? ; send warnings to new port (can be #f to discard) ;; PRINT-WARNING : 'pop ; pop the output stack and return the previous top (define print-warning (let ((*warnings* (make-circular-list 8)) (*port* (list (current-error-port)))) (lambda (fmt . args) #"""`(print-warning fmt args...)` : print a warning to stderr (visible at normal verbosity). With a string `fmt`, this prints the warning and returns the assembled message. This function has a few variants, intended to be useful for manipulating a stream of warnings: * `(print-warning 'get-count)` : returns the number of warnings so far. * `(print-warning 'get-list)` : returns the most recent few of the collection of warnings so far, and resets the list. * `(print-warning 'push )` : sends warnings to a new output-port?, which can be `#f` to discard them. * `(print-warning 'pop)` : pops the output stack and return the previous top-of-stack. The warning is generated and stored at all verbosity levels, even quiet, but is not printed when we are being quiet.""" ;; the placement of the verbosity test is important: ;; we want warnings to be recorded at all verbosity levels, ;; independently of the *verbosity-debug-flags* value; ;; if we simply test ((not (verbosity? normal)) #f) at the top, ;; then (print-warning 'get-count) returns #f which confuses things, ;; and warnings are not stored. (cond ((string? fmt) (let ((msg (apply format `(#f ,fmt . ,args)))) (when (and (>= *verbosity* *verbosity-normal*) (car *port*)) (format (car *port*) "~a~%" msg)) (*warnings* 'add msg) msg)) ((symbol? fmt) (case fmt ((get-count) (*warnings* 'get-count)) ((get-list) (*warnings* 'get-list)) ((push) (cond ((null? args) (print-warning "No argument to print-warning 'push")) ((or (output-port? (car args)) (not (car args))) (set! *port* (cons (car args) *port*))) (else (print-warning "Invalid print-warning port ~s ignored" (car args))))) ((pop) (if (= (length *port*) 1) (print-warning "print-warning: can't pop enpty output stack!") (let ((p (car *port*))) (set! *port* (cdr *port*)) p))) (else (print-warning "Unexpected print-warning argument: ~s" fmt)))) (else (print-warning "Unexpected print-warning argument: ~s" fmt)))))) ;; print-info and print-trace avoid evaluating their arguments unless they are about to print them (define-macro (print-info fmt . args) "`(print-info fmt ...)` : print an informational message to stderr (visible at hightened verbosity)" `(when (verbosity? info) (let ((msg (eval '(apply format (list #f ,fmt . ,args))))) (#_format (current-error-port) "# ~a~%" msg)))) (define-macro (print-trace fmt . args) "`(print-trace fmt ...)` : print an informational message to stderr (visible at debug verbosity)" `(when (verbosity? trace) (let ((msg (eval '(apply format (list #f ,fmt . ,args))))) (#_format (current-error-port) "## ~a~%" msg)))) ;;;; Regular expressions ;; The regexp functions below are closely inspired by the regexp ;; interface described in the Racket docs ;; , though with ;; regexp-match-positions* renamed to regexp-match-positions/multi. ;; ;; Some regexp implementations -- most notably Python's -- distinguish ;; a regexp-match procedure from a regexp-search one, where the former ;; will match only at the beginning of a string. There's an argument ;; that I should do the same here, but (a) I've never really seen the ;; point of the distinction (so it would be only a least-surprise ;; principle), and (b) there isn't an easy way to do it (there isn't a ;; corresponding flag in the standard regexp API). Just stick with ;; the Racket-like implementation. (define* (regexp-match-positions re s (start 0)) #"""`(regexp-match-positions re s (start 0))` : match the regular expression `re` _once_ against the string `s`, returning a list of pairs, or `#f` if there is no match. The regexp can also be passed as a string, which will be compiled to a regexp on the fly. The match found is that closest to the start of the string, but it is not anchored to the start (unless the pattern starts with `"^"`). The resulting list is a list of `(start . end)` pairs, where the `start` integer is the index, within `s`, of the start of the match, and `end` is the index of the character position one after the match. The first pair in the list is the match of the whole regexp; subsequent ones are the positions of any parenthesized subexpressions in the regexp. If a subexpression did not participate in the match, then the corresponding element in the list is returned as `#f`. If `start` is given, it is the index at which to start matching. The offsets in the result are from the start of S, not from this start index. If `start` is beyond the end of the string, then the match fails.""" (cond ((regexp? re) (regexp-match** re s start 0)) ((string? re) (regexp-match** (regexp re) s start 0)) (else (beastie-error "regexp-match-positions: regexp argument should be re? or string?, not ~s" re)))) (define* (regexp-match re s (start 0)) #"""Like `regexp-match-positions`, except that the returned list contains substrings taken from `s`, rather than their offsets.""" (cond ((regexp? re) (regexp-match** re s start 2)) ((string? re) (regexp-match** (regexp re) s start 2)) (else (beastie-error "regexp-match: regexp argument should be re? or string?, not ~s" re)))) (define* (regexp-match-positions/multi re s (start 0) (match-select car)) #"""Like `regexp-match-positions`, except that the result is a list of non-overlapping position pairs indicating a sequence of matches of the regexp RE within S. The `:match-select` keyword argument selects which of the possibly multiple results is passed on. If the RE contains submatches, then (as described in `regexp-match-positions`) the result will be a sequence of ranges. The default value of this keyword argument is `car`, which selects the first pair, indicating the whole matched string, but `cadr`, for example, will select the content of the first submatch, and `values`, as the identity function, will select the full set of matches. Empty matches are handled like other matches, returning a zero-length range string, but the pattern is restricted from matching an empty sequence immediately after an empty match. If `start` is beyond the end of the string, then the match fails, returning `#f`. Examples: > (regexp-match-positions/multi (regexp "x.") "12x4x6") '((2 . 4) (4 . 6)) ; ie, '("x4" "x6") > (regexp-match-positions/multi (regexp "x*") "12x4x6") '((0 . 0) (1 . 1) (2 . 3) (3 . 3) (4 . 5) (5 . 5) (6 . 6)) ;ie, '("" "" "x" "" "x" "" "") """ (cond ((regexp? re) ;; (when (verbosity? info) ;; (eprintf "re: ~s ~s ->~%" re s)) (let loop ((i start) (res '())) (cond ((regexp-match** re s i 0) => (λ (m) (let ((end-index (cdar m))) ;; (when (verbosity? info) ;; (eprintf " (~a ~a)~%" i end-index)) (if (and end-index (= i end-index)) (loop (+ end-index 1) ;zero length match: avoid an endless-loop (cons (match-select m) res)) (loop end-index ;normal case (cons (match-select m) res)))))) (else (when (verbosity? info) (eprintf " --~%")) (reverse! res))))) ((string? re) (regexp-match-positions/multi (regexp re) s start match-select)) (else (beastie-error "regexp-match-positions/multi: regexp argument should be re? or string?, not ~s" re)))) (define* (regexp-match/multi re s (start 0) (match-select car)) #"""This bears the same relationship to `regexp-match` as `regexp-match-positions/multi` bears to `regexp-match-positions`.""" (let ((m (regexp-match-positions/multi re s start match-select))) (and m (map (λ (se) (let ((si (car se)) (ei (cdr se))) (and (>= si 0) (substring s si ei)))) m)))) (define* (regexp-split/positions re s (start 0)) (cond ((regexp? re) ;(eprintf "regexp-split: ~s -- ~s ->~%" re s) (let loop ((search-idx start) ;where we start the search (match-idx start) ;where the start of the match is reported (res '())) ;; search-idx and match-idx will be the same, except with ;; the regexp matches an empty string: in this case the ;; loop starts searching one place along the string, but ;; holds the match one back (cond ((regexp-match** re s search-idx 0) => (λ (m) (let ((m1 (car m))) ;(eprintf " ~s/~s -> ~s~%" search-idx match-idx m1) (if (= (car m1) (cdr m1)) (loop (+ (cdr m1) 1) ;zero length match (cdr m1) (cons (cons match-idx (car m1)) res)) (loop (cdr m1) (cdr m1) (cons (cons match-idx (car m1)) res)))))) (else (if (<= match-idx (string-length s)) (reverse! (cons (cons match-idx (string-length s)) res)) (reverse! res)))))) ((string? re) (regexp-split/positions (regexp re) s start)) (else (beastie-error "regexp-split/positions: regexp argument should be re? or string?, not ~s" re)))) (define* (regexp-split re s (start 0)) #"""`(regexp-split re s)` : split a string at a regexp. The result is a list of strings from `s` that are separated by matches to `re`. Adjacent matches are separated with `""`. If `s` contains no matches (in the range from `start` to the end of the string), the result is a list containing the content of `s` (from `start`) as a single element. If a match occurs at the beginning of `s` (at `start`), the resulting list will start with an empty string or byte string, and if a match occurs at the end, the list will end with an empty string or byte string. Examples: > (regexp-split (regexp " +") "12 34") '("12" "34") > (regexp-split (regexp ".") "12 34") '("" "" "" "" "" "" "") > (regexp-split (regexp "") "12 34") '("" "1" "2" " " " " "3" "4" "") > (regexp-split (regexp " *") "12 34") '("" "1" "2" "" "3" "4" "") > (regexp-split (regexp " +") "") '("") """ ;(eprintf "regexp-split: s=~s re=~s~%" s re) (let ((positions (regexp-split/positions re s start))) ;(eprintf " positions of ~s : ~s~%" s positions) (and positions (map (λ (p) (cond ((cdr p) (substring s (car p) (cdr p))) (())) (if (cdr p) (substring s (car p) (cdr p)) (substring s (car p)))) positions)))) (define* (regexp-match? re s (start 0)) #"""`(regexp-match? re s (start 0))` : match the regexp `re` against the string `s`, returning `#t` if it matches and `#f` if not. The match is done between position `start` and the end of the string. The regexp can be a regexp compiled with `regexp`, or a string.""" (cond ((regexp? re) (regexp-match** re s start 1)) ((string? re) (regexp-match** (regexp re 'no-substitute) s start 1)) (else (beastie-error "regexp-match?: regexp argument should be re? or string?, not ~s" re)))) ;; Support basic 'module' infrastructure. ;; ;; The expression (module "file.scm") loads the contents of the file ;; and (module 'foo) loads the named built-in module. See the ;; documentation of MODULE below. ;; ;; The s7 load function loads into the top level environment by ;; default. The s7 autoload mechanism would seem to do some of what's ;; required here, but (a) requires that all of the API symbols are ;; known outside the module, and (b) loads everything in the ;; autoloaded file, rather than just the symbol required. ;; ;; The MODULE function requires that there is a *PROVIDES* variable. ;; It would be reasonable to change this so that, if there is no such ;; variable, we simply import everything into the current environment. ;; Add functions to this environment with (PROVIDE fn) (define-macro (module-provide sym . syms) "(module-provide f ...) : provide the function or functions f... to a caller" `(begin (unless (defined? '*provides* (curlet) #t) (define *provides* (inlet))) (varlet *provides* . ,(apply append (map (λ (s) `((#_quote ,s) ,s)) (cons sym syms)))))) ;; (DEFINE/PROVIDE (fn args...) body...) ;; This is like ;; ;; (define (fn args...) body...) ;; (module-provide fn) ;; ;; Note, this doesn't support (define/provide foo 1), ;; since that may be undesirable in a module. (define-macro (define/provide arglist . args) `(begin (define ,arglist . ,args) (module-provide ,(car arglist)))) (define-macro (define/provide* arglist . args) `(begin (define* ,arglist . ,args) (module-provide ,(car arglist)))) (define-macro (define-macro/provide arglist . args) `(begin (define-macro ,arglist . ,args) (module-provide ,(car arglist)))) ;; DEFINE/PROVIDE/DELAYED : fn ... ;; For each FN in the list, declare it as a function to be loaded from ;; core.c when the corresponding module is loaded. ;; This must appear at most once in a module. ;; ;; SKIPPED: right now, it seems more straightforward to define ;; *requires-implementation-functions* by hand in module files. #;(define-macro (define/provide/delayed fn . fns) (let* ((all-fns `(,fn . ,fns))) `(begin (define *requires-implementation-functions* (#_quote ,all-fns)) ,@(map (lambda (f) `(begin (define ,f #f) (provide ,f))) all-fns)))) ;; Loading builtin modules. ;; ;; These are modules that can be loaded with (module 'foo). They can ;; be a mix of scheme code and references to C-implemented code. ;; GET-BUILTIN-MODULE/NAME* : (symbol? -> (symbol? let? let?) ;; ;; Given a symbol NAME, this retrieves the compiled contents of the ;; module as a let, using core function load-builtin-module/name* (see ;; core.c). ;; ;; The module _must_ include a variable *PROVIDES*, ;; which is a 'let'. Typically, but not necessarily, this will be ;; constructed by a sequence of calls to MODULE-PROVIDE. ;; ;; If the loaded definitions include a variable ;; *REQUIRES-IMPLEMENTATION-FUNCTIONS*, then this is a list of ;; functions defined in core.c, which we now load into this ;; environment. We do not immediately provide these functions, since ;; they are typically module-local. ;; ;; The variable *PROVIDES-IMPLEMENTATION-FUNCTIONS* is similar, except ;; that we additionally provide these functions to the environment. ;; ;; We typically return a list (name *PROVIDES* env), containing the ;; module name, the let containing the symbols provided from the module, ;; and a let containing all of the symbols in the module. ;; ;; If *MODULE-LOAD-HOOK* is defined, then it is a symbol, naming a ;; function (not the function itself, which may be defined only ;; because it is named in *requires-implementation-functions* and is ;; thus defined only after scheme loading is complete). If it ;; is defined, then the function it names is called with three arguments, ;; (name *provides* env), and it is the return value from the function which ;; is returned from this function. This hook function must therefore ;; return a three-element list (name *provides* env). Typically, the hook ;; function will define the various functions required for C-objects, ;; and leave function definitions to the table in core.c, but it is ;; also possible, and would not be unreasonable, to define these ;; functions within the hook function. ;; ;; That is, we might define, in C-code, a function ;; `define-foo-functions*` which calls s7_make_function and friends, ;; declare that in core.c, and list it in *requires-implementation-functions*. ;; We then additionally (define *module-load-hook* 'define-foo-functions*). ;; Thus the `define-foo-functions*` function will be called, and the new ;; functions defined into the provides and everything-env which are returned. ;; ;; Note 1: the contents of modules probably shouldn't define anything at ;; their top levels, since these may not be reinitialised as naively expected. ;; ;; Note 2: there are multiple ways to get the following wrong. The ;; following is much, much simpler than some of the rococo excitement ;; I tried on the way here. (define (get-builtin-module/name* name) (let () (define *module-name* name) (cond ((load-builtin-module/name* name (curlet)) => (λ (env) (if (defined? '*provides* env #t) (let ((requires (append (if (defined? '*requires-implementation-functions* env #t) (map (λ (name) (cons name #f)) *requires-implementation-functions*) '()) (if (defined? '*provides-implementation-functions* env #t) (map (λ (name) (cons name #t)) *provides-implementation-functions*) '())))) (unless (null? requires) (print-info "(get-builtin-module/name* ~a): requiring ~s" name ;(map car requires) requires) (for-each (λ (fname+provide) (let ((fname (car fname+provide)) (provide? (cdr fname+provide))) (cond ((define-function/delayed/env* fname env) => (λ (f) (when provide? (print-info " providing ~s" fname) (varlet *provides* fname f)))) (else (print-warning "Unable to find delayed function ~s" fname))))) requires)) ;; return (name provides all), ;; via load-hook if provided (if (defined? '*module-load-hook* env #t) ((eval *module-load-hook* env) name *provides* env) (list name *provides* env))) (beastie-error "builtin module ~s doesn't *provide* anything" name)))) (else (beastie-error "builtin module '~s not found" name))))) ;; GET-FILE-MODULE/FILE* : string? -> (string? let? let?) ;; ;; Load a module from a file, similarly to get-builtin-module/name* above. (define (get-file-module/file* fn) ;; A conversation with Bill Schottstadt reveals that: ;; ;; unlet is more of a filter than an ;; honest let; that is it makes sure the built-in ;; names have their built-in values by interposing ;; those values, so (outlet (curlet)) is the ;; actual let -- maybe curlet should return that ;; if it gets unlet as an argument? ;; ;; The (outlet (curlet)) makes this explicit. (let () (define *module-name* fn) (with-let (unlet) (print-info "get-file-module/file*: (load ~s)" fn) (load fn (outlet (curlet)))) (list fn (and (defined? '*provides* (curlet) #t) *provides*) (curlet)))) ;; MODULE/LET* : ((or/c symbol? string?) let? boolean?) -> (or/c symbol? string?) ;; ;; Given a module NAME, locate it, and load it into the given ;; TARGET-ENV. If EXPOSE is false, then load only the symbols given ;; in the '*provides* let of the module; if it is `#t`, then load all of the ;; newly-defined symbols; and if is a list of symbols, then expose only those. ;; ;; Returns the first argument, NAME. ;; ;; The logic here is arguably slightly defective, in that it loads too ;; much in the 'expose' case. Ideally, when loading/exposing a module ;; 'foo, only the symbols defined by 'foo would be loaded into ;; TARGET-ENV, excluding symbols provided _to_ that module by submodules. ;; This, however, would require some intricate reworking of the ;; module/let* support in runtime.scm (‘intricate’ = I tried, and got ;; more confused than it was worth while pursuing, even though it ;; _seemed_ like the required let-juggling should be relatively easy). ;; There are some tests commented out in test-misc.scm, qv. (define module/let* (let ((*found-modules* (make-hash-table 8 equal?))) (λ (name target-env expose) (define (install-into-env name+provides+all) (let ((name (car name+provides+all)) (provides (cadr name+provides+all)) (all (caddr name+provides+all)) (target-name (if (defined? '*module-name* target-env #t) (let-ref target-env '*module-name*) "root?"))) (let ((source-let (cond ((list? expose) (apply inlet (map (λ (sym) (cons sym (eval sym all))) expose))) (expose (if (boolean? expose) ;ie, it's #t all (error 'wrong-type-arg "module/let*: expose must be #f, #t, or list, not ~s" expose))) (provides) (else (beastie-error "no *provide* in ~s (did you want (module/expose ~s) ?" name name))))) (print-info "module/let*: module ~s into ~s, ~a ~s" name target-name (if expose "exposing" "providing") (map car source-let)) ;; The following is essentially (varlet target-env source-let) ;; except that that fails if a binding is already present ;; in target-env (since s7 of July 2026). This would ;; (probably) not be required if the expose-all behaviour, ;; discussed above, could be avoided. (for-each (λ (p) (or (defined? (car p) target-env #t) (varlet target-env (car p) (cdr p)))) source-let)) name)) ;evaluate to just the name (unless (or (string? name) (symbol? name)) (beastie-error "module/let* bad call: argument ~s isn't a symbol or string" name)) (let ((n+p+a (*found-modules* name))) ;; n+p+a is (name provides-symbols all-symbols) (cond ((not n+p+a) ;load it (hash-table-set! *found-modules* name name) ;add sentinel (print-info "module/let*: loading ~a..." name) (cond ((if (string? name) (get-file-module/file* name) (get-builtin-module/name* name)) => (λ (new-n+p+a) (print-info "module/let*: ...loaded ~a" name) (hash-table-set! *found-modules* name new-n+p+a) (install-into-env new-n+p+a))) (else (hash-table-set! *found-modules* name #f) (print-warning "Can't load module ~s" name) #f))) ((list? n+p+a) (print-info "module/let*: already have ~s" (car n+p+a)) (install-into-env n+p+a)) (else ;found sentinel ;; Loading loop: we are being asked to load a module ;; which, further up the load stack, is attempting to load this one. ;; ;; There's nothing we can do here: ;; We can't just ignore this, and wait until the stack ;; of loads is unwound, since the module that is ;; loading this one may be wanting to actually evaluate ;; code which uses the to-be-loaded module. ;; ;; We could potentially make this message better, ;; if we left more information in the *found-modules* hash, ;; but this is good enough for now. (beastie-error "loading loop: can't re-load ~s (add -v to trace)" name))))))) (define-macro (module name . names) #"""(module 'mod) or (module "foo.scm") : An alternative to the built-in LOAD, which loads the given definitions into a new environment, and imports into the current environment the definitions provided (with MODULE-PROVIDE or DEFINE/PROVIDE) within that environment. Raises an error if there is nothing provided there. If NAME is a string, it is a file of scheme definitions. If it is a symbol, it refers to a beastie built-in module.""" `(begin . ,(map (λ (n) `(if (or (string? ,n) (symbol? ,n)) (module/let* ,n (curlet) #f) (beastie-error "Bad argument: (module ~s)" ,n))) (cons name names)))) (define-macro (module/expose name) #"""As MODULE, but load all of the definitions into the current environment, not just those provided for export.""" `(or (module/let* ,name (curlet) #t) (beastie-error "Bad argument: (module/expose ~s)" ,name))) (define (env->string/debug e) (if (let? e) (let ((l (let->list e))) (if (defined? '*envname* e) (sprintf "ENV:~a (~a)" (e '*envname*) (length l)) (sprintf "ENV:~a (~a ...)" (length l) (if (null? l) '() (car l))))) (sprintf "~s" e))) ;;;; Other useful procedures and macros (define (symprintf fmt . args) (string->symbol (apply sprintf (cons fmt args)))) (define-macro (struct name . fields) #"""`(struct id v1 v2 ... [:guard (λ (v1 v2 ...) ...)])` : creates a structure with fields v1, v2, .... This defines functions: * `(make-id 1 2)` : construct an `id` object. * `(id? x)` : true if the object `x` was constructed by `make-id` * `(id-v1 x)` : return the `v1` field (etc), throwing an error if `x` is not an `id?` If a field definition is given, not as `vi`, but instead as `(vi :mutable)`, then this additionally defines `(set-id-vi! x 99)`, which will set the `vi` field of `x` to 99, and throw an error if `x` is not an `id?`. If the guard procedure is present, then it is a function which is given arguments `v1 v2 ...`, and returns the same number of multiple values (ie, with `(values...)`). It is the return values from this guard procedure that are assigned to the structure. If the input values are unacceptable, then the guard procedure may throw an exception. """ (let ((guard+field-names (let loop ((n 1) (ff fields) (guard #f) (res '())) (cond ((null? ff) (cons guard (reverse! res))) ((eqv? (car ff) :guard) (if (null? (cdr ff)) (beastie-error "malformed (struct...): no guard procedure") (loop n (cddr ff) (cadr ff) res))) (else (loop (+ n 1) (cdr ff) guard (cons (let ((mutable? (and (list? (car ff)) (memq :mutable (car ff)))) (f1 (if (list? (car ff)) (caar ff) (car ff)))) `(,n ;number ,f1 ;name (,(symprintf "get-~a" n) ;internal getter name . ,(and mutable? (symprintf "set-~a" n))) ;...and setter or #f (,(symprintf "~a-~a" name f1) ;external getter name . ,(and mutable? (symprintf "set-~a-~a!" name f1))))) res))))))) (let ((guard (car guard+field-names)) (field-names (cdr guard+field-names))) `(define-values (,(symprintf "make-~a" name) ,(symprintf "~a?" name) ,@(map (λ (nm) (car (cadddr nm))) field-names) ,@(filter values (map (λ (nm) (cdr (cadddr nm))) field-names))) (let ((*tag* ,(symbol->string name))) ;; this tag can't be a symbol, since s7 regards all symbols ;; as equivalent in eq? terms; a string works, though (define make (let ((+documentation ,(sprintf "Construct a new '~a' structure: ~s" name (cons (symprintf "make-~a" name) (map cadr field-names))))) (lambda ,(map cadr field-names) ,(if guard `(list->vector (list *tag* (,guard . ,(map cadr field-names)))) `(list->vector (list *tag* . ,(map cadr field-names))))))) (define pred? (let ((+documentation+ ,(sprintf "Return true if the argument is a valid '~a' structure, as constructed by `make-~a`" name name))) (λ (x) (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) *tag*))))) ,@(map (λ (num+name) (let ((num (car num+name)) (field-name (cadr num+name)) (internal-name (car (caddr num+name))) (accessor-name (car (cadddr num+name)))) `(define ,internal-name (let ((+documentation+ ,(sprintf "Retrieves the ~a field of the '~a' structure" field-name name))) (λ (x) (if (pred? x) (vector-ref x ,num) (beastie-error "error calling ~s on ~s~%" (quote ,accessor-name) x))))))) field-names) ,@(filter values (map (λ (num+name) (let ((num (car num+name)) (field-name (cadr num+name)) (internal-name (cdr (caddr num+name))) (setter-name (cdr (cadddr num+name)))) (and internal-name `(define ,internal-name (let ((+documentation+ ,(sprintf "Sets the ~a field of the '~a' structure" field-name name))) (λ (x newval) (if (pred? x) (vector-set! x ,num newval) (beastie-error "error calling ~s on ~s~%" (quote ,setter-name) x)))))))) field-names)) (values make pred? ,@(map caaddr field-names) ,@(filter values (map cdaddr field-names)))))))) (define global-strings-wrapper* (let ((*global-strings* (hash-table eqv? 16))) (λ (k . rest) (if (null? rest) (*global-strings* k) (let ((v (car rest))) (cond ((not (symbol? k)) (error 'wrong-type-args "global-string-set*!: expect symbol keyword, not ~s" k)) ((not (string? v)) (error 'wrong-type-args "global-string-set*!: expect string value, not ~s" v)) (else (hash-table-set! (*beastie* '_strings) k v)))))))) (define (global-string-get* k) (global-strings-wrapper* k)) (define (global-string-set!* k v) (global-strings-wrapper* k v)) ;; Given a file name, add the path to that file to the *load-path*, ;; if it isn't already there. ;; We don't (currently) check that the given file exists. (define (add-to-load-path! fn) (when (and fn (string? fn)) (receive (dir file must-be-dir?) (split-path fn) (unless (or (not dir) (eqv? dir 'relative) (member dir *load-path*)) (set! *load-path* (cons dir *load-path*)))))) ;;; Main program(s) (define (main/bib arguments output-type) (let ((infile (if (null? arguments) #f (car arguments)))) ;; infile being #f means stdin (module 'bibtex) (add-to-load-path! infile) (let ((db (parse-bibtex-file infile))) (if db (case output-type ((json) (write-bibtex/json! db)) ((python) (beastie-error "We can't currently write -Opython output")) ((bib) (write-bibtex/bib! db)) ((sexp) (write-bibtex/sexp! db)) (else (write-bibtex/bib! db))) (beastie-error "BibTeX parse of file ~a failed" (or infile "")))))) (define (main/bst arguments output-type) (let ((bst-source (if (null? arguments) #f (car arguments)))) ;; bst-source being #f means stdin (module 'bst) (add-to-load-path! bst-source) (let ((result (parse-bst-file bst-source))) (case output-type ((bstscm) (write/bstscm! result)) (else (write result) (newline)))))) ;; The arguments should be an list containing a single .aux file name, ;; or '(). ;; In the former case, we write the generated .bbl output to a ;; similarly-named output file. ;; In the latter, we write it to stdout. (define (main/aux arguments output-type) ;; we ignore output-type (let ((aux-source (if (null? arguments) #f (car arguments)))) ;; aux-source being #f means stdin (module 'aux 'bst) (add-to-load-path! aux-source) (define (do-it) (call-with-aux-file aux-source (λ (citations bibdata bibstyle) (process-bibs/bst citations (or bibdata (beastie-error 'bst "no bibdata command found in aux file ~a" (or aux-source ""))) (or bibstyle (beastie-error 'bst "no bibliography style file found in aux file ~a" (or aux-source ""))))))) (if aux-source (let ((bbl-path (path-replace-extension aux-source ".bbl"))) (with-output-to-file bbl-path do-it)) (do-it)))) (define (main/json arguments output-type) (let ((json-source (if (null? arguments) #f (car arguments))) (write-sexp! (λ (e) (write e) (newline)))) (module 'json) (let ((outputter (case output-type ((sexp) write-sexp!) ((json) write-json!) (else (eprintf "can't write JSON as ~s~%" output-type) write-sexp!)))) (outputter (parse-json-file json-source))))) (define (main/scm arguments output-type) (let ((scm-file (if (null? arguments) #f (car arguments)))) (add-to-load-path! scm-file) (load/error-handler scm-file))) (define (main/markdown arguments output-type) (let ((mdfile (if (null? arguments) #f (car arguments)))) (module 'markdown 'xexpr) (add-to-load-path! mdfile) (receive (doc metadata) (parse-markdown-file/metadata mdfile) (case output-type ((xml) (xexpr-write/xml! doc)) ((xhtml) (xexpr-write/xhtml! doc (metadata/type metadata 'annotation))) ((python) (xexpr-write/python! doc)) (else (xexpr-write/sexp! doc)))))) ;; The REPL isn't completely satisfactory yet. ;; It looks like one rather heavyweight strategy to make this better ;; integrated with Emacs is to implement the interface ;; layer for geiser. See eg . ;; That said, a working strategy is simply to turn off geiser ;; mode in each buffer, and play dumb. (define (main/repl/s7 arguments output-type) ;; This version depends on the repl.scm support in the s7 ;; distribution. To enable this, build s7/libc_s7.so (see Makefile) ;; and make that available to load, possibly using BEASTIE_LOAD_PATH. (printf "beastie: ~a (s7 repl)~%Using s7 version ~a~a~a~%" (*beastie* 'version-string) (*s7* 'version) (if (provided? 'debugging) " (with s7 debugging enabled)" "") (cond ((*beastie* 'icu-version) => (λ (icu) (sprintf " (with ICU ~a)" icu))) (else ""))) ((*repl* 'run))) (define (main/repl/basic arguments output-type) ;; This one is pretty simple-minded, but it doesn't depend on the s7 ;; libraries. If it suffices for inferior-scheme mode in Emacs, ;; then that's enough. That does seem to be slightly complicated, ;; and I don't really know what happens between geiser-mode and the ;; inferior scheme process, but the process would simply hang if ;; run from there. That's why there's more than one implementation ;; of the REPL here (one which is a function basic-repl* in ;; runtime.scm, and one where I scan an expr by hand and evaluate it ;; with s7_eval_c_string), as I tried to work out what was going on. ;; I don't really have a preference, right now. ;; ;; At any rate, it seems that _disabling_ geiser mode ;; in each buffer suffices for now ;; (use `geiser-mode`, if geiser has got itself loaded). (printf "beastie: ~a (basic repl)~%Using s7 version ~a~a~a; UCD ~a~%" (*beastie* 'version-string) (*s7* 'version) (if (provided? 'debugging) " (with s7 debugging enabled)" "") (cond ((*beastie* 'icu-version-string) => (λ (icu) (sprintf "; with ICU ~a" icu))) (else "")) (*beastie* 'unicode-version)) (basic-repl*)) (define (main/version . ignored) (printf "beastie, ~a.~%~a.~%Home page: ~a~%" (*beastie* 'version-string) (*beastie* '_copyright+licence) (*beastie* '_homepage)) (printf "Using ~a~a" (*s7* 'version) (if (provided? 'debugging) " (with s7 debugging enabled)" "")) (cond ((*beastie* 'icu-version-string) => (λ (icu-version) (printf "; with ICU ~a" icu-version))) (else (printf "; without ICU"))) (printf "; UCD ~a~%" (*beastie* 'unicode-version)) (printf "Built on ~a, running on ~a.~%" (*beastie* 'build-platform) (*beastie* 'run-platform)) (when (verbosity? info) (printf "~%Repo ~a~%" (*beastie* '_repository-info)))) (define (main input-type output-type arguments) (let ((actual-main (case input-type ((bib) main/bib) ((bst) main/bst) ((aux) main/aux) ((scm) main/scm) ((markdown) main/markdown) ((json) main/json) ((repl/basic) main/repl/basic) ((repl/s7) main/repl/s7) ((show-version) main/version) (else (beastie-error "Unexpected input-type ~s" input-type))))) (call/error-handler (λ () (if (actual-main arguments output-type) 0 1)))))