commit b2a46bcfb8ede1eeb7416b495b924bb0c1612e21
parent 5d3b63d3d31b895f051bd1e4f555eb48bc38ee75
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Mon, 30 Oct 2023 12:48:53 +0200
Add more information about installation and whatnot.
Diffstat:
33 files changed, 8679 insertions(+), 5 deletions(-)
diff --git a/README.org b/README.org
@@ -2,8 +2,32 @@
#
# SPDX-License-Identifier: AGPL-3.0-or-later
+#+title: Spook: A brick falling game so bad it would spook you.
+
+* Playing:
+
+You can play it on [[https://yuvallangerontheroad.codeberg.org/spook/]] or
+[[https://kakafarm.itch.io/spook/]].
+
+* Installing, generally:
+
+You would generally need to:
+
+0. [[https://youtu.be/7s664NsLeFM][Invent a universe]].
+1. Get Chicken Scheme installed, somehow, and
+2. have some sort of a way of running `chicken-install spock` in a way
+ that installs Spock into a place your Chicken system knows about.
+3. Clone the spook repository.
+4. src_shell{cd spook} into spook's directory.
+5. src_shell{make all}.
+6. src_shell{cd pages/}.
+7. src_shell{python3 -m http.server}.
+8. Load http://localhost:8000 with your browser.
+
* Installing on Guix:
+First, you would need [[https://guix.gnu.org/][Guix]] installed. Follow the manual [[https://guix.gnu.org/en/manual/en/html_node/Installation.html][here]].
+
Run:
#+begin_src shell
@@ -21,11 +45,17 @@ Run:
Now open a browser and load http://localhost:8000/.
-Versions:
+** Versions used on my end while compiling main.scm circa the
+[[https://itch.io/jam/autumn-lisp-game-jam-2023/][https://itch.io/ Lisp 2023 Autumn Game Jam]]:
-- Chicken 5.2.0
-- Spock 0.2
-- Guix https://git.savannah.gnu.org/git/guix.git b96729e22d013cadf0a38536852a293f9dc2dfc5
+- Guix https://git.savannah.gnu.org/git/guix.git with the commit
+ b96729e22d013cadf0a38536852a293f9dc2dfc5.
+- Chicken 5.2.0 (installed from the Guix repository)
+- [[https://api.call-cc.org/5/doc/spock][Spock 0.2]] (installed from the [[https://eggs.call-cc.org/][Chicken Eggs repository]] using the
+ sommand src_shell{chicken-install spock}). The egg's contents are
+ provided in this repository in =./spock-0.2/= under their own
+ copyright this and that. I am not a lawyer, maaaan. I don't even
+ know birds law.
* Installing Chicken Spock on Termux:
@@ -48,4 +78,5 @@ Now you can run:
* License:
-Everything is under AGPL-3.0-or-later.
+Everything mine is under AGPL-3.0-or-later. Anything not mine is
+under its own license, unlicense, nonlicense, or whatever.
diff --git a/chicken-guix b/chicken-guix
@@ -4,6 +4,15 @@
#
# SPDX-License-Identifier: AGPL-3.0-or-later
+if [ -z "$(command -v guix)" ] ; then
+ printf "%s\n" \
+ "What are you doing here, kid?!
+You don't even have Guix installed!
+Come back once it's installed:
+https://guix.gnu.org/";
+ exit 1;
+fi
+
mkdir -p "$HOME/chicken-guix/home"
env CHICKEN_INCLUDE_PATH="$HOME/chicken" \
diff --git a/spock-0.2/TODO b/spock-0.2/TODO
@@ -0,0 +1,67 @@
+TODO -*- Outline -*-
+
+
+* bugs
+** doesn't run well on IE
+*** "->string" in test.scm fails
+**** might be solved with use of SPOCK.global, but only tested in full block-mode
+**** also dies when running test-suite
+*** also problems on conkeror on Windows (0.9.3)
+** self-build fails
+*** expand returns impossible values, somethings deeply wrong
+*** recent CPS-fix possibly helps
+** large files seem to exceed function nesting on Rhino
+*** exits 3, SM previously (before CPS clustering) gave "too much recursion"
+*** SM and d8 are ok
+*** seems to be a compile-time error
+
+* test suspensions
+
+* compiler
+** should have access to original variable names
+ keep map of temps -> old names (in state?)
+** threads.scm slightly broken
+*** inner loop creating threads mutates captured variable
+
+* optimizer
+** lifting may result in colliding names, if multiple compiled modules are loaded
+*** must be renamed or isolated, somehow
+** implement simple inlining of locally bound lambdas
+*** this is just cp
+*** only for small functions (for example expansion of "(match 1 (2 3))")
+
+* upgrade expander to newer version
+** needed?
+
+* count sufficient in user-lambdas?
+** or do we have to count in k-lambdas as well?
+** bug: zero-argument functions will currently not count
+
+* library
+** add section-dependencies
+** error-message will be misleading if primitives require mutable strings but get jstrings
+** put syntax.scm into library.scm ?
+** use case-lambda to specialize single/multiarg variants at expansion time?
+
+* foreign interface
+** passing explicit "this" (native-method) not really right
+*** perhaps handle %host-ref's in operator position differently?
+ needs to generate direct call
+** needs complete reconsideration
+** "...NAME1.NAME2" could retrieve NAME2 and bind it to NAME1
+*** but would need to check at runtime if NAME2 names a function
+** test -bind
+
+* runtime
+** SPOCK.error should split output at newlines and call console.log repeatedly
+*** console.log removes newlines, it seems
+** SPOCK.module is still missing
+
+* option "-namespace"
+** requires "-runtime"?
+** not really tested well
+
+* some dead code is generated after CPS calls
+** currently only in `if' forms and after `%continue'
+
+* finish Makefile in "stuff/" to have a working test-suite
diff --git a/spock-0.2/bind.scm b/spock-0.2/bind.scm
@@ -0,0 +1,198 @@
+;;;; bind.scm - highlevel foreign interface
+;
+; Binding syntax:
+;
+; ["function"] ID "(" [ARG {"," ARG}] ")" ["{" ... "}" | ";"]
+; "var" ID ["=" TYPE] {"," ID ["=" TYPE]} [";"]
+;
+; ARG = TYPE [ "..." ]
+; | "..."
+; TYPE = "number" | "string" | "function" | "object" | "null" | "undefined"
+; | "[" [ARG {"," ARG}] "]"
+; | "_" | "*"
+
+
+;; needs honu.scm and match.scm
+
+(define (method-name? str)
+ (and (memv #\. (string->list str)) #t))
+
+(define (method-name-split str)
+ (if (char-upper-case? (string-ref str 0))
+ str
+ (let ((res (string-split str ".")))
+ (if (= (length res) 1)
+ (car res)
+ (list (car res) (foldl (cut string-append <> "." <>)
+ "" (cdr res)))))))
+
+(define parse-bindings
+ (let ((semicolon (string->symbol ";"))
+ (comma (string->symbol ","))
+ (dot (string->symbol ".")))
+ (lambda (str)
+ (let ((tokens
+ (with-input-from-string str
+ (lambda ()
+ (let loop ((xs '()))
+ (let ((x (read-honu)))
+ (if (eof-object? x)
+ (reverse xs)
+ (loop (cons x xs))))))))
+ (code '()))
+ (define (add expr)
+ (set! code (cons expr code)))
+ (define (parse t)
+ (match t
+ (() (reverse code))
+ (('function . more)
+ (parse (function more)))
+ (('var . more)
+ (parse (var more)))
+ (((? symbol?) . _)
+ (parse (function t)))
+ (_ (error "invalid binding syntax" t))))
+ (define (function t0)
+ (match-let (((name . t) (parse-name t0)))
+ (match t
+ ((('%parens . args) . t)
+ (let ((tl (typelist args)))
+ (match t
+ (((or (? semicolon?) ('%braces . _)) . t2)
+ (set! t t2))
+ (_ #f))
+ (add (generate-function-binding name tl))
+ t))
+ (_ (error "invalid function binding syntax" t0)))))
+ (define (var t0)
+ (match-let (((name . t) (parse-name t0)))
+ (let ((type #f))
+ (match t
+ (('= type2 . t2)
+ (set! type (parse-type type2))
+ (set! t t2))
+ (_ #f))
+ (add (generate-variable-binding name type))
+ (match t
+ (((? semicolon?) . t2) t2)
+ (((? comma?) . t2) (var t2))
+ (_ t)))))
+ (define (semicolon? t) (eq? t semicolon))
+ (define (comma? t) (eq? t comma))
+ (define (dot? t) (eq? t dot))
+ (define (dots? t) (eq? t '...))
+ (define (parse-type type)
+ (case type
+ ((number string object null undefined function) type)
+ ((_ *) #f)
+ (else
+ (match type
+ (('%brackets) '())
+ (('%brackets . args) (typelist args))
+ (_ (error "invalid binding type" type))))))
+ (define (typelist lst)
+ (let loop ((lst lst) (tl '()))
+ (match lst
+ (() (reverse tl))
+ (((? dots?)) (reverse (cons '... tl)))
+ ((type (? dots?))
+ (reverse (cons (vector (parse-type type)) tl)))
+ ((type (? comma?) . lst)
+ (loop lst (cons (parse-type type) tl)))
+ ((type)
+ (reverse (cons (parse-type type) tl))))))
+ (define (parse-name t)
+ (match t
+ (((? symbol? s) . t)
+ (let loop ((t t) (name (symbol->string s)))
+ (match t
+ (((? dot?) (? symbol? s2) . t)
+ (loop t (string-append name "." (symbol->string s2))))
+ (_ (cons name t)))))
+ (_ (error "invalid binding name" t))))
+ (parse tokens)
+ `(begin ,@(reverse code))))))
+
+;; these must generate expanded code, as parsing of bind expressions happens
+;; during canonicalization
+(define (generate-function-binding name tl)
+ ;;XXX doesn't handle methods (do we need to?)
+ (let ((name (method-name-split name)))
+ (define (finish wraps tmps rest rtmp)
+ (let ((sname
+ (if (string? name)
+ name
+ (cadr name))))
+ `(define-syntax ,(string->symbol sname)
+ (syntax-rules ()
+ ((_ ,@tmps ,@(if rest (list rtmp '...) '()))
+ (%inline
+ ,sname
+ ,@wraps
+ ,@(cond ((eq? #t rest) (list rtmp '...))
+ (rest (list rest '...))
+ (else '())))))) ))
+ (define (wrap type tmp)
+ (case type
+ ((number function object null undefined)
+ `(%check ,(symbol->string type) ,tmp))
+ ((string)
+ `(%string->jstring ,tmp))
+ (else
+ (if (pair? type)
+ (wrap-vector type tmp)
+ tmp))))
+ (define (wrap-vector tl tmp)
+ (let loop ((tl tl) (cs '()) (f #f) (i 0))
+ (match tl
+ (()
+ (if f
+ `(vector ,@(reverse cs))
+ tmp))
+ ;;XXX currently not handled
+ ((type (? (cut eq? '... <>)))
+ (loop '() cs f i))
+ (((? (cut eq? <> '...)))
+ (if f
+ `(%inline
+ ".concat"
+ `(vector ,(reverse cs))
+ (%inline ".slice" ,tmp ,i))
+ tmp))
+ ((type . tl)
+ (let* ((wt `(vector-ref ,tmp ,i)) ;XXX nested access will be inefficient
+ (w (wrap type wt)))
+ (loop tl (cons w cs) (not (equal? w wt)) (+ i 1)))))))
+ (let loop ((tl tl) (wraps '()) (tmps '()))
+ ;; (write tl (current-error-port))
+ (match tl
+ (() (finish (reverse wraps) (reverse tmps) #f #f)) ; fixed
+ (((? (cut eq? <> '...)))
+ (finish (reverse wraps) (reverse tmps) #t (temp))) ; N + rest
+ ((#(type))
+ (let ((tmp (temp)))
+ (finish (reverse wraps) (reverse tmps) (wrap type tmp) tmp))) ; N + rest with type
+ ((type . tl)
+ (let ((tmp (temp)))
+ (loop tl (cons (wrap type tmp) wraps) (cons tmp tmps))))))))
+
+(define (generate-variable-binding name type)
+ (let ((sname (string->symbol name))
+ (tmp (temp))
+ (tmp2 (temp)))
+ `(begin
+ (define-syntax set!
+ (let-syntax ((old-set! set!))
+ (syntax-rules (,sname)
+ ((_ ,sname ,tmp)
+ (%host-set!
+ ,name
+ ,(case type
+ ((number function object null undefined)
+ `(%check ,(symbol->string type) x))
+ ((string)
+ `(%string->jstring x))
+ (else 'x))))
+ ((_ ,tmp tmp2)
+ (old-set! ,tmp ,tmp2)))))
+ (define-syntax ,sname (%host-ref ,name)))))
diff --git a/spock-0.2/build-runtime b/spock-0.2/build-runtime
@@ -0,0 +1,7 @@
+#!/bin/sh
+./chicken-spock -library-path spock -optimize -library -o library.js
+./chicken-spock -library-path spock -optimize -debug -library -o library-debug.js
+cat config.js runtime.js library.js > spock/spock-runtime.js
+cat config.js runtime.js debug.js library-debug.js > spock/spock-runtime-debug.js
+$CHICKEN_CSI -e '(begin (import jsmin) (display (jsmin-file "spock/spock-runtime.js")))' > spock/spock-runtime-min.js
+$CHICKEN_CSI -e '(begin (import jsmin) (display (jsmin-file "spock/spock-runtime-debug.js")))' > spock/spock-runtime-debug-min.js
diff --git a/spock-0.2/chicken-spock.scm b/spock-0.2/chicken-spock.scm
@@ -0,0 +1,17 @@
+;;;; chicken-spock.scm - command-line compiler
+
+
+(module main ()
+
+(import scheme (chicken base) (chicken process-context))
+(import spock-compiler matchable)
+
+(define fail error)
+
+(include "top.scm")
+
+(set! ##sys#warnings-enabled #f) ; disable reader warnings
+
+(run (command-line-arguments))
+
+)
diff --git a/spock-0.2/codegen.scm b/spock-0.2/codegen.scm
@@ -0,0 +1,275 @@
+;;;; codegen.scm - code-generation for JS target
+
+
+(define (generate-header state)
+ (let ((seal (test-option 'seal state)))
+ (emit "/* CODE GENERATED BY SPOCK " spock-version " */")
+ (when seal
+ (emit "\n(function() {"))
+ (when (test-option 'runtime state)
+ (emit "\n")
+ (read-library
+ state
+ (cond ((test-option 'debug state) "spock-runtime-debug.js")
+ (else "spock-runtime.js"))
+ copy-file-data))
+ (let ((namespace (test-option 'namespace state)))
+ (when namespace
+ (emit "\n" namespace " = SPOCK.module(\""
+ namespace "\");")))))
+
+(define (generate-trailer state)
+ (when (test-option 'seal state)
+ (emit "\n})();"))
+ (emit "\n/* END OF GENERATED CODE */\n"))
+
+(define (generate-code toplambdas state)
+ (let ((nl "\n")
+ (loop-llist #f)
+ (debug-mode (test-option 'debug state))
+ (namespace (test-option 'namespace state)))
+ (define (indent thunk)
+ (let ((nlold nl))
+ (set! nl (string-append nl " "))
+ (let ((x (thunk)))
+ (set! nl nlold)
+ x)))
+ (define (constant c)
+ (with-output-to-string
+ (lambda ()
+ (cond ((or (number? c) (string? c))
+ (write c))
+ ((char? c)
+ (emit "new SPOCK.Char(")
+ (write (string c))
+ (emit ")"))
+ ((boolean? c)
+ (emit (if c "true" "false")))
+ ((null? c) (emit "null"))
+ ((symbol? c)
+ (emit "SPOCK.intern(")
+ (write (symbol->string c))
+ (emit ")"))
+ ((pair? c)
+ (emit "new SPOCK.Pair(")
+ (emit (constant (car c)))
+ (emit ", ")
+ (emit (constant (cdr c)))
+ (emit ")"))
+ ((vector? c)
+ (emit "[")
+ (unless (zero? (vector-length c))
+ (emit (constant (vector-ref c 0)))
+ (for-each
+ (lambda (x)
+ (emit ", ")
+ (emit (constant x)))
+ (cdr (vector->list c))))
+ (emit "]"))
+ (else (fail "bad constant" c))))))
+ (define (walk x dest loc)
+ (match x
+ (('quote c)
+ (if (or (number? c) (string? c) (boolean? c))
+ (constant c)
+ (let ((t1 (temp)))
+ (emit nl "var " t1 " = ")
+ (emit (constant c))
+ (emit ";")
+ t1)))
+ ((? symbol?) x)
+ (('set! v x)
+ (let ((t (walk x v loc)))
+ (emit nl v " = " t ";\t// set! " v)
+ 'undefined))
+ (('lambda llist body)
+ (let ((t1 (temp)))
+ (match-let (((vars rest) (parse-llist llist)))
+ (emit nl "var " t1 " = function "
+ ;(if (and debug-mode dest) (identifier dest) "") <- gives trouble on IE
+ "(")
+ (emit-list vars)
+ (emit ") {")
+ (indent
+ (lambda ()
+ (when dest (emit "\t// " dest))
+ (when (and (pair? llist) (pair? (cdr llist))) ;XXX not really correct
+ (emit nl "var r = SPOCK.count(arguments"
+ (if (and debug-mode dest)
+ (string-append ", " (constant (stringify dest)))
+ "")
+ ");")
+ (emit nl "if(r) return r;"))
+ (when rest
+ (emit nl "var " rest " = SPOCK.rest(arguments, " (- (length vars) 1))
+ (when (and debug-mode dest)
+ (emit ", '" dest "'"))
+ (emit ");"))
+ (fluid-let ((loop-llist #f))
+ (walk body #f dest))))
+ (emit nl "};")
+ t1)))
+ (('%void) 'undefined)
+ (('%void? x)
+ (let ((t (temp))
+ (tx (walk x #f loc)))
+ (emit nl "var " t " = " tx " === undefined;")
+ t))
+ (('let (('%unused x)) body)
+ (walk x #f loc)
+ (walk body #f loc))
+ (('let ((v x)) body)
+ (let ((t (walk x v loc)))
+ (emit nl "var " v " = " t ";")
+ (walk body v loc)))
+ (('if x y z)
+ (let* ((t (temp))
+ (x (walk x #f loc)))
+ (emit nl "var " t ";" nl "if(" x " !== false) {")
+ (indent
+ (lambda ()
+ (let ((y (walk y dest loc)))
+ (unless (eq? y 'undefined) (emit nl t " = " y ";")))))
+ (emit nl "}" nl "else {")
+ (indent
+ (lambda ()
+ (let ((z (walk z dest loc)))
+ (unless (eq? z 'undefined) (emit nl t " = " z ";")))))
+ (emit nl "}")
+ t))
+ (('%host-ref name) name)
+ (('%host-set! name x)
+ (let ((t (walk x #f loc)))
+ (emit nl name " = " t)
+ 'undefined))
+ (('%property-ref name)
+ (let ((t (temp))
+ (k (temp "k")))
+ (emit nl "var " t " = function(" k ", x) { return " k
+ "(x." name "); }")
+ t))
+ (('%property-ref name x)
+ (let ((t (temp))
+ (ta (walk x #f loc)))
+ (emit nl "var " t " = " ta "." name ";")
+ t))
+ (('%property-set! name x y)
+ (let ((tx (walk x #f loc))
+ (ty (walk y #f loc)))
+ (emit nl tx "." name " = " ty ";")
+ ty))
+ (('%check type x)
+ (let ((t (temp))
+ (tx (walk x dest loc)))
+ (emit nl "var " t " = SPOCK.check(" tx ", ")
+ (if (pair? type)
+ (emit (car type))
+ (emit "'" type "'"))
+ (when (and loc debug-mode)
+ (emit ", " (constant (stringify loc))))
+ (emit ");")
+ t))
+ (('%code code ...)
+ (for-each (cut emit nl <>) code)
+ 'undefined)
+ (('%native-lambda code ...)
+ (let ((t (temp)))
+ (emit nl "var " t " = function(K) {")
+ (indent
+ (lambda ()
+ ;;XXX this will not unwind, but at least decrease the counter
+ (emit nl "SPOCK.count(arguments")
+ (if dest
+ (emit ", '" dest "');")
+ (emit ");"))
+ (for-each (cut emit nl <>) code)))
+ (emit nl "};")
+ t))
+ (('%inline name args ...)
+ (let ((t (temp))
+ (ta (map (cut walk <> #f loc) args)))
+ (emit nl "var " t " = ")
+ (cond ((pair? name)
+ (for-each
+ (lambda (x)
+ (if (number? x)
+ (emit "(" (list-ref ta (- x 1)) ")")
+ (emit " " x " ")))
+ name))
+ ((char=? #\. (string-ref (stringify name) 0))
+ (emit (car ta) name "(")
+ (emit-list (cdr ta))
+ (emit ")"))
+ (else
+ (emit name "(")
+ (emit-list ta)
+ (emit ")")))
+ (emit ";")
+ t))
+ (('%new arg1 args ...)
+ (let ((t1 (temp))
+ (t2 (walk arg1 #f loc))
+ (ta (map (cut walk <> #f loc) args)))
+ (emit nl "var " t1 " = new " t2 "(")
+ (emit-list ta)
+ (emit ");")
+ t1))
+ (('%global-ref v)
+ (if namespace
+ (string-append namespace "." (identifier v))
+ (identifier v)))
+ (('%global-set! v x)
+ (let ((t (walk x v loc)))
+ (emit nl (if namespace (string-append namespace ".") "")
+ (identifier v) " = " t ";\t// set! " v)
+ 'undefined))
+ (('%loop llist body)
+ (emit nl "loop: while(true) {")
+ (fluid-let ((loop-llist llist))
+ (let ((r (indent (cut walk body #f loc))))
+ (emit nl "}")
+ r)))
+ (('%continue op k args ...)
+ (if loop-llist
+ (let ((temps (map (lambda _ (temp)) args)))
+ ;; bind arguments to temporaries
+ (for-each
+ (lambda (t a)
+ (let ((r (walk a #f loc)))
+ (emit nl "var " t " = " r ";")))
+ temps args)
+ ;; set argument variables to temporaries
+ (let loop ((ll loop-llist) (temps temps))
+ (cond ((pair? ll) ; normal argument?
+ (cond ((null? temps) ; missing arguments?
+ (emit nl (car ll) " = undefined;")
+ (loop (cdr ll) '()))
+ (else
+ (emit nl (car ll) " = " (car temps) ";")
+ (loop (cdr ll) (cdr temps)))))
+ ((symbol? ll) ; rest argument?
+ (emit nl ll " = SPOCK.list(")
+ (emit-list temps)
+ (emit ");"))
+ (else
+ ;; set any surplus args to undefined
+ (for-each
+ (lambda (t) (emit nl t " = undefined;"))
+ temps))))
+ (emit nl "continue loop;")
+ 'undefined)
+ (walk (cdr x) dest loc)))
+ ((op args ...)
+ (let* ((to (walk op #f loc))
+ (ta (map (cut walk <> #f loc) args))
+ (t (temp)))
+ (emit nl "return " to "(")
+ (emit-list ta)
+ (emit ");")
+ 'undefined)))) ; does not return
+ (for-each
+ (lambda (top)
+ (let ((t (walk top #f #f)))
+ (emit nl "SPOCK.run(" t ");")))
+ toplambdas)
+ (emit nl "SPOCK.flush();")))
diff --git a/spock-0.2/config.js b/spock-0.2/config.js
@@ -0,0 +1,8 @@
+/* config.js - runtime-configuration for SPOCK */
+
+
+var SPOCK = {
+ STACKSIZE: 100,
+ THREADSLICE: 10,
+ TRACELENGTH: 32
+};
diff --git a/spock-0.2/config.scm b/spock-0.2/config.scm
@@ -0,0 +1,6 @@
+;;;; config.scm
+
+
+(define spock-version 0)
+(define library-path (list (make-pathname (chicken-home) "spock")))
+
diff --git a/spock-0.2/core.scm b/spock-0.2/core.scm
@@ -0,0 +1,350 @@
+;;;; core.scm
+
+
+(define (add-undefined var)
+ (unless (memq var undefined)
+ (set! undefined (cons var undefined))))
+
+(define (add-access var assign)
+ (let ((d (get var 'defined)))
+ (if d
+ (when (and (symbol? d) (not (memq d used-sections)))
+ (set! used-sections (cons d used-sections)))
+ (add-undefined var))
+ (cond (assign
+ (unless (get var 'assigned)
+ (put! var 'assigned #t)
+ (set! assigned (cons var assigned))))
+ ((not (get var 'referenced))
+ (put! var 'referenced #t)
+ (set! referenced (cons var referenced))))))
+
+(define (canonicalize form state)
+ (let ((looping #f)
+ (debug-mode (test-option 'debug state))
+ (xref-mode (test-option 'xref state))
+ (strict-mode (test-option 'strict state)))
+ (define (match-llist? llist args)
+ (let loop ((ll llist) (args args))
+ (cond ((null? ll) (null? args))
+ ((symbol? ll))
+ ((null? args) #f)
+ (else (loop (cdr ll) (cdr args))))))
+ (define (dotted? name)
+ (string-find-char #\. (stringify name)))
+ (define (normalize-ref ref)
+ (let* ((str (stringify ref))
+ (len (string-length str)))
+ (cond ((char=? #\. (string-ref str 0))
+ (normalize-ref (substring str 1 len)))
+ ((char=? #\. (string-ref str (- len 1)))
+ (normalize-ref (substring str 0 (- len 1))))
+ (else str))))
+ (define (walk x e tail ldest)
+ ;;(pp x)
+ (match x
+ ((or (? char?) (? number?) (? string?) (? boolean?))
+ `(quote ,x))
+ ((? symbol?)
+ (if (and (not strict-mode) (dotted? x))
+ (let ((str (symbol->string x)))
+ (cond ((char=? #\. (string-ref str 0))
+ `(%property-ref ,(normalize-ref str)))
+ (else
+ `(%host-ref ,(normalize-ref str)))))
+ (cond ((assq x e) => cdr)
+ (else
+ (when xref-mode (add-access x #f))
+ `(%global-ref ,x)))))
+ (('set! x y)
+ (let ((y (walk y e #f #f)))
+ (if (and (not strict-mode) (dotted? x))
+ `(%host-set! ,(normalize-ref x) ,y)
+ (cond ((assq x e) => (lambda (a) `(set! ,(cdr a) ,y)))
+ (else
+ (when xref-mode
+ (put! x 'assigned #t)
+ (add-access x #t))
+ `(%global-set! ,x ,y))))))
+ (('quote _) x)
+ (('if x y)
+ `(if ,(walk x e #f #f)
+ ,(walk y e tail ldest)
+ (%void)))
+ (('if x y z)
+ `(if ,(walk x e #f #f)
+ ,(walk y e tail ldest)
+ ,(walk z e tail ldest)))
+ ((('lambda _ ('%dispatch lambdas ...)) args ...)
+ (let loop ((ls lambdas))
+ (if (or (null? (cdr ls))
+ (match-llist? (cadar ls) args))
+ (walk `(,(car ls) ,@args) e tail ldest)
+ (loop (cdr ls)))))
+ ((('lambda () body ...))
+ (walk `(begin ,@body) e #t ldest))
+ ((('lambda llist body ...) args ...)
+ (match-let (((vars rest) (parse-llist llist)))
+ (let ((aliases (map (lambda (v) (cons v (temp))) vars)))
+ (let loop ((as aliases) (vars vars) (args args))
+ (cond ((null? as)
+ ;; handle surplus arguments
+ (let loop2 ((args args))
+ (if (null? args)
+ (walk
+ `(begin ,@body)
+ (append aliases e)
+ tail ldest)
+ `(let ((%unused ,(walk (car args) e #f #f)))
+ ,(loop2 (cdr args))))))
+ ((eq? rest (caar as))
+ `(let ((,(cdar as) ,(walk `(%list ,@args) e #f (car vars))))
+ ,(loop '() '() '())))
+ ((null? args)
+ `(let ((,(cdar as) (%void)))
+ ,(loop (cdr as) (cdr vars) '())))
+ (else
+ `(let ((,(cdar as) ,(walk (car args) e #f (car vars))))
+ ,(loop (cdr as) (cdr vars) (cdr args)))))))))
+ (('lambda _ ('%dispatch lambdas ...))
+ (walk (last lambdas) e tail ldest))
+ (('letrec () body ...)
+ (walk `(begin ,@body) e tail ldest))
+ (('letrec ((vars vals) ...) body ...)
+ (let* ((aliases (map (lambda (v) (cons v (temp))) vars))
+ (e2 (append aliases e)))
+ (let loop1 ((as aliases))
+ (if (null? as)
+ (if strict-mode
+ (let ((temps (map (lambda _ (temp)) aliases)))
+ (let loop2 ((tmps temps) (vals vals))
+ (if (null? tmps)
+ (let loop3 ((as aliases) (temps temps))
+ (if (null? as)
+ (walk `(begin ,@body) e2 tail #f)
+ `(let ((%unused (set! ,(cdar as) ,(car temps))))
+ ,(loop3 (cdr as) (cdr temps)))))
+ `(let ((,(car tmps) ,(walk (car vals) e2 #f #f)))
+ ,(loop2 (cdr tmps) (cdr vals))))))
+ (let loop2 ((as aliases) (vars vars) (vals vals))
+ (if (null? as)
+ (walk `(begin ,@body) e2 tail #f)
+ `(let ((%unused
+ (set! ,(cdar as) ,(walk (car vals) e2 #f (car vars)))))
+ ,(loop2 (cdr as) (cdr vars) (cdr vals))))))
+ `(let ((,(cdar as) (%void)))
+ ,(loop1 (cdr as)))))))
+ (('%check type x)
+ (if (not debug-mode)
+ (walk x e tail ldest)
+ `(%check ,type ,(walk x e tail ldest))))
+ (('%check x)
+ (if (not debug-mode)
+ ''#t
+ (walk x e tail ldest)))
+ (((or '%void '%void?) args ...)
+ `(,(car x) ,@(map (cut walk <> e #f #f) args)))
+ (('%host-ref (or ('quote name) name))
+ `(%host-ref ,(normalize-ref name)))
+ (('%host-set! (or ('quote name) name) x)
+ `(%host-set! ,(normalize-ref name) ,(walk x e #f #f)))
+ (('%syntax-error msg . arg)
+ (apply fail msg arg))
+ (('%new args ...)
+ `(%new ,@(map (cut walk <> e #f #f) args)))
+ (('%property-ref (or ('quote name) name) x)
+ `(%property-ref ,(normalize-ref name) ,(walk x e #f #f)))
+ (('%property-ref (or ('quote name) name))
+ `(%property-ref ,(normalize-ref name)))
+ (('%property-set! (or ('quote name) name) x y)
+ `(%property-set!
+ ,(normalize-ref name)
+ ,(walk x e #f #f)
+ ,(walk y e #f #f)))
+ (('%inline (or name ('quote name)) xs ...)
+ `(%inline ,name ,@(map (cut walk <> e #f #f) xs)))
+ (((or '%native-lambda '%code) code ...) x)
+ (('begin x) (walk x e tail ldest))
+ (('begin) '(%void))
+ (('begin x1 . more)
+ `(let ((%unused ,(walk x1 e #f #f)))
+ ,(walk `(begin ,@more) e tail ldest)))
+ (('lambda llist body ...)
+ (set! looping #f)
+ (match-let (((vars rest) (parse-llist llist)))
+ (let* ((aliases (map (lambda (v) (cons v (temp))) vars))
+ (newllist
+ (append
+ (map cdr (if rest (butlast aliases) aliases))
+ (if rest
+ (cdr (assq rest aliases))
+ '()))))
+ `(lambda ,newllist
+ ,(fluid-let ((looping #t))
+ ;; walking body checks for self-call in tail-pos. and sets `looping'
+ (let ((body (walk `(begin ,@body) (append aliases e) #t ldest)))
+ (if looping
+ `(%loop ,newllist ,body)
+ body)))))))
+ (('define v x)
+ (when (and xref-mode
+ (not (get v 'defined)))
+ (put! v 'defined #t)
+ (set! defined (cons v defined)))
+ `(%global-set! ,v ,(walk x e #f #f)))
+ ;;XXX we actually have to check `op' for not being a special form name
+ ((op args ...)
+ (cond ((and tail (symbol? op) (eq? op ldest)) ; tail + self call?
+ `(%continue ,@(map (cut walk <> e #f #f) x)))
+ (else
+ (set! looping #f)
+ (map (cut walk <> e #f #f) x))))
+ (_ (fail "bad expression" x))))
+ (walk form '() #t #f)))
+
+;; CPS-conversion algorithm from "Essentials of Programming Languages"
+(define (cps form)
+ (let ((toplambdas '()))
+ (define (zero x)
+ (let ((k (temp "k")))
+ `(lambda (,k) ,(one x k)))) ; Cpgm
+ (define (one x k)
+ (match x
+ (('let ((v x)) y) ; canonicalizer only generates single-var `let'
+ (if (simple? x)
+ `(let ((,v ,(two x))) ; Clet
+ ,(one y k))
+ (let ((t (temp))) ; Chead
+ (one x `(lambda (,t)
+ (let ((,v ,t))
+ ,(one y k)))))))
+ ((? simple?)
+ (callk k (lambda () x)))
+ ;; from here on `x' is non-simple
+ (((or 'set! '%global-set! '%host-set!) v y)
+ (let ((t (temp)))
+ (one y `(lambda (,t) ; Chead
+ (let ((%unused (,(car x) ,v ,t)))
+ ,(callk k (lambda () '(%void))))))))
+ (('if x y z)
+ (bindk
+ k
+ (lambda (k) ; Cif
+ (if (simple? x)
+ `(if ,(two x)
+ ,(one y k)
+ ,(one z k))
+ (let ((t (temp))) ; Chead
+ (one x `(lambda (,t)
+ (if ,t
+ ,(one y k)
+ ,(one z k)))))))))
+ (('%loop llist x) `(%loop ,llist ,(one x k)))
+ (('%continue args ...)
+ (head
+ args
+ (lambda (args2)
+ `(%continue ,(car args2) ,k ,@(cdr args2)))))
+ (((or '%property-set! '%inline) info xs ...)
+ ;; simple %inline/%property-set! form is already handled above
+ (head
+ xs
+ (lambda (xs2)
+ (callk k (lambda () `(,(car x) ,info ,@xs2))))))
+ (('%check type x) ; s.a.
+ (head
+ (list x)
+ (lambda (xs2)
+ (callk k (lambda () `(%check ,type ,@xs2))))))
+ (('%new args ...)
+ (head
+ args
+ (lambda (args2)
+ (callk k (lambda () `(%new ,@args2))))))
+ (((? simple?) ...) ; Capp
+ (cons (two (car x)) (cons k (map two (cdr x)))))
+ ((xs ...)
+ (head
+ xs
+ (lambda (xs2) (cons (car xs2) (cons k (cdr xs2))))))
+ (else (error "one" x k))))
+ (define (two x)
+ (match x
+ ((? symbol?) x)
+ (('lambda llist body) ; Cproc
+ (let ((k (temp "k")))
+ `(lambda (,k . ,llist) ,(one body k))))
+ (('if xs ...) `(if ,@(map two xs)))
+ (((or '%inline '%property-set!) info xs ...)
+ `(,(car x) ,info ,@(map two xs)))
+ (((or 'set! '%global-set! '%check) v y) `(,(car x) ,v ,(two y)))
+ (((or 'quote '%host-ref '%code '%native-lambda '%void) . _) x)
+ (('%property-ref parts) x)
+ (((or '%host-set! '%property-ref) parts y)
+ `(,(car x) ,parts ,(two y)))
+ (('let ((var x)) y)
+ `(let ((,var ,(two x))) ,(two y)))
+ (((or '%new '%continue '%void?) xs ...) `(,(car x) ,@(map two xs)))
+ ((xs ...) (map two xs))
+ (_ (error "two" x))))
+ (define (bindk k proc)
+ (if (symbol? k)
+ (proc k)
+ (let ((t (temp)))
+ `(let ((,t ,k))
+ ,(proc t)))))
+ (define (callk k thunk)
+ (if (symbol? k)
+ `(,k ,(two (thunk))) ; Csimplevar
+ (let ((v (caadr k))) ; Csimpleproc
+ `(let ((,v ,(two (thunk)))) ;XXX must we `two' here as well?
+ ,(caddr k)))))
+ (define (head xs wrap)
+ (let loop ((xs xs) (xs2 '())) ; Chead
+ (if (null? xs)
+ (wrap (reverse xs2))
+ (let ((x (car xs)))
+ (if (simple? x)
+ (loop (cdr xs) (cons (two x) xs2))
+ (let ((t (temp)))
+ (one x `(lambda (,t)
+ ,(loop (cdr xs) (cons t xs2))))))))))
+ (define (simple? x)
+ (match x
+ (((or '%host-ref '%code 'lambda 'quote '%global-ref '%void
+ '%native-lambda) . _)
+ #t)
+ (('%property-ref _) #t)
+ (((or '%host-set! '%property-ref) _ x) (simple? x))
+ ((? symbol?) #t)
+ (('if (? simple?) ...) #t)
+ (('%void? (? simple?)) #t)
+ (('let ((_ (? simple?))) (? simple?)) #t)
+ (((or 'set! '%inline '%global-set! '%check '%new '%property-set!) _ (? simple?) ...)
+ #t)
+ (((or '%loop '%continue) . _) #f)
+ (_ #f)))
+ (define (sequence parts)
+ (let loop ((parts parts))
+ (if (null? (cdr parts))
+ (car parts)
+ `(let (,(car parts))
+ ,(loop (cdr parts))))))
+ (define (toplambda parts)
+ (set! toplambdas (cons (zero (sequence parts)) toplambdas)))
+ (define (top x parts)
+ ;; perform "clustering": build groups of toplevel forms
+ ;; transformed together to reduce function nesting
+ ;; XXX is this still needed, or does this pay off?
+ (match x
+ (('let ((_ (? simple?))) y)
+ (top y (cons (caadr x) parts)))
+ (('let (('%unused z)) y)
+ (toplambda (reverse (cons z parts)))
+ (top y '()))
+ (_ (toplambda
+ (if (null? parts)
+ (list x)
+ (reverse (cons x parts)))))))
+ (top form '())
+ (reverse toplambdas)))
diff --git a/spock-0.2/debug.js b/spock-0.2/debug.js
@@ -0,0 +1,99 @@
+/* debug.js - debugging-support for SPOCK runtime */
+
+
+SPOCK.debug = true;
+SPOCK.toString = function() { return "#<SPOCK>"; };
+SPOCK.restartCount = 0;
+SPOCK.traceBuffer = [];
+SPOCK.traceOutput = false;
+SPOCK.traceHook = [];
+SPOCK.hasAlert = SPOCK.inBrowser;
+
+// Overrides SPOCK.error
+SPOCK.error = function(msg) { // "msg" may be a string or an error object
+ var args = Array.prototype.splice.call(arguments, 1);
+ var err;
+ var text;
+
+ if(typeof msg !== "string") { // an object?
+ err = msg;
+ msg = err.message;
+ }
+
+ text = msg;
+
+ if(args.length > 1)
+ text += ":\n " + SPOCK.map(SPOCK.stringify, args).join("\n ");
+
+ if(SPOCK.traceBuffer.length > 0)
+ text += "\n\nCall trace:\n\n" + SPOCK.getTrace();
+
+ if(SPOCK.hasAlert) {
+ alert("Error: " + text);
+ SPOCK.hasAlert = false; // disable to avoid endless repetition of alerts
+ }
+ else if(err) throw new (err.constructor)(text);
+ else throw new Error(text);
+};
+
+// Overrides SPOCK.count
+SPOCK.count = function(args, loc) {
+ if(--SPOCK.stack <= 0) {
+ ++SPOCK.restartCount;
+ return new SPOCK.Continuation(args.callee, Array.prototype.slice.call(args));
+ }
+
+ if(loc) SPOCK.trace(loc, args);
+
+ return false;
+};
+
+SPOCK.trace = function(name, args) {
+ var tb = SPOCK.traceBuffer;
+
+ for(var i in SPOCK.traceHook)
+ (SPOCK.traceHook[ i ])(name, args);
+
+ if(SPOCK.traceOutput)
+ SPOCK.log("[" + SPOCK.stack + "] " + name);
+
+ if(tb.length >= SPOCK.TRACELENGTH) tb.shift();
+
+ tb.push([name, Array.prototype.slice.call(args, 1)]); // skip continuation argument
+};
+
+SPOCK.getTrace = function() {
+ var tb = SPOCK.traceBuffer;
+ var trace = [];
+
+ for(var i in tb) {
+ var e = tb[ i ];
+ trace.push(" (" + e[ 0 ] + " " +
+ SPOCK.map(SPOCK.stringify, e[ 1 ]).join(" ") + ")");
+ }
+
+ SPOCK.traceBuffer = [];
+ return trace.join("\n") + " <---";
+};
+
+// Overrides empty SPOCK.statistics
+SPOCK.statistics = function() {
+ //if(SPOCK.restartCount > 0)
+ // SPOCK.log("restarts: ", SPOCK.restartCount);
+
+ SPOCK.traceBuffer = [];
+};
+
+// Overrides SPOCK.callback
+(function() {
+ var old = SPOCK.callback;
+
+ SPOCK.callback = function(proc) {
+ var cb = old(proc);
+ return function() {
+ var args = Array.prototype.slice.call(arguments);
+ SPOCK.trace("<callback>", args);
+ return cb.apply(this, args);
+ };
+ };
+})();
diff --git a/spock-0.2/driver.scm b/spock-0.2/driver.scm
@@ -0,0 +1,306 @@
+;;;; driver.scm - compiler-invocation
+
+
+(define dropped '())
+(define defined '())
+(define assigned '())
+(define referenced '())
+(define undefined '())
+(define used-sections '())
+(define default-xref-mode #f)
+
+
+(define (spock-help)
+ (display "(spock OPTION | FILENAME-OR-PORT ...)\n\n")
+ (display " Available options:\n\n")
+ (display " 'source show source forms\n")
+ (display " 'expand show forms after macro-expansion\n")
+ (display " 'canonicalized show forms after canonicalization\n")
+ (display " 'optimized show forms after optimization\n")
+ (display " 'cps show forms after CPS-conversion\n")
+ (display " 'strict enable strict mode\n")
+ (display " 'optimize enable optimizations\n")
+ (display " 'block enable block-compilation\n")
+ (display " 'library-path [DIR] add DIR to library path or return library path\n")
+ (display " 'namespace VAR put globals into module\n")
+ (display " 'xref show cross-reference\n")
+ (display " 'runtime include runtime-system in generated code\n")
+ (display " 'library compile runtime library\n")
+ (display " 'seal wrap toplevel definitions into local scope\n")
+ (display " 'debug enable debug-mode\n")
+ (display " 'usage PROC invoke PROC on usage-errors\n")
+ (display " 'fail PROC invoke PROC on compiler-errors\n")
+ (display " 'import FILENAME expand FILENAME\n")
+ (display " 'environment STORE provide syntactic environment\n")
+ (display " 'debug-syntax show debug-output during expansion\n")
+ (display " 'verbose show diagnostic messages\n")
+ (display " 'prepare just prepare state without compiling\n")
+ (display " 'code EXP code to be compiled instead of file\n")
+ (display " 'bind FILENAME generate bindings from specifications\n")
+ (display " 'output-file FILENAME specify output-file\n"))
+
+(define (spock . args)
+ (let ((output-file #f)
+ (include-runtime #f)
+ (extract-library #f)
+ (seal-toplevel #f)
+ (files '())
+ (mstore #f)
+ (code #f)
+ (prepare #f)
+ (optimize-mode #f)
+ (mstore-given #f)
+ (strict-mode #f)
+ (block-mode #f)
+ (debug-mode #f)
+ (xref-mode default-xref-mode)
+ (verbose-mode #f)
+ (debug-syntax #f)
+ (bindings '())
+ (fail error)
+ (namespace #f)
+ (imports '())
+ (show '()))
+ (define (usage opts)
+ (fail "unrecgnized option or missing argument" opts))
+ (define (sexpand exp dbg)
+ (match-let (((exp . store)
+ (expand-syntax exp fail mstore (and dbg debug-syntax))))
+ (set! mstore store)
+ exp))
+ (define (compile-files state files show)
+ (let ((forms
+ (or code
+ `(begin
+ ,@(map
+ read-forms
+ (note #f state files "reading source"))))))
+ (if (memq 'source show)
+ (pp forms)
+ (let ((forms
+ (sexpand
+ (note #f state forms "expanding syntax")
+ #t)))
+ (if (memq 'expand show)
+ (pp forms)
+ (let ((forms
+ (canonicalize
+ forms
+ (note #f state state "canonicalizing"))))
+ (cond ((memq 'canonicalized show)
+ (pp forms))
+ ((and block-mode (report-undefined)))
+ ((memq 'xref show)
+ (xref #t (note #f state #t "cross-referencing")))
+ (else
+ (let ((forms (if optimize-mode
+ (optimize
+ forms
+ (note #f state state "optimizing"))
+ forms)))
+ (if (and optimize-mode (memq 'optimized show))
+ (pp forms)
+ ;;XXX if "-runtime" + "-library":
+ ;; xref and add compiled library.scm
+ ;; of used definitions (sort sections topologically
+ ;; to determine order)
+ (let ((toplambdas
+ (cps
+ (note #f state forms "performing CPS conversion"))))
+ (if (memq 'cps show)
+ (for-each pp toplambdas)
+ (begin
+ (note
+ #f state
+ (generate-header state)
+ "generating code")
+ (generate-code toplambdas state)
+ (generate-trailer state)))
+ mstore)))))))))))
+ (call-with-current-continuation
+ (lambda (return)
+ (let loop ((args args))
+ (match args
+ (() (let ((files (reverse files))
+ (state `((strict . ,strict-mode)
+ (debug . ,debug-mode)
+ (xref . ,xref-mode)
+ (seal . ,seal-toplevel)
+ (block . ,block-mode)
+ (optimize . ,optimize-mode)
+ (verbose . ,verbose-mode)
+ (fail . ,fail)
+ (runtime . ,include-runtime)
+ (library-path . ,library-path)
+ (namespace . ,namespace))))
+ (when (and (not mstore-given) extract-library)
+ (set! files
+ (cons
+ (read-library state "library.scm" (lambda (x) x))
+ files)))
+ (when (and (not prepare) (null? files) (not code) (null? bindings))
+ (fail "nothing to compile"))
+ (when (not mstore-given)
+ (sexpand
+ (let ((m (cond (strict-mode '(default strict))
+ (debug-mode '(default debug))
+ (else '(default)))))
+ `(define-syntax define-library-section
+ (letrec-syntax
+ ((walk
+ (syntax-rules ,m
+ ((_ ()) (%void))
+ ,@(map (lambda (m)
+ `((_ ((,m def ...) . more))
+ (begin def ...)))
+ m)
+ ((_ (clause . more))
+ (walk more)))))
+ (syntax-rules ()
+ ((_ sec clause ...)
+ (begin
+ (walk (clause ...))))))))
+ #f)
+ (let ((features '(spock alexpander srfi-0 srfi-46)))
+ (when debug-mode (set! features (cons 'debug features)))
+ (when strict-mode (set! features (cons 'strict features)))
+ ;;XXX do this in a modular and extensible manner
+ (sexpand
+ `(define-syntax cond-expand
+ (syntax-rules (and or not else ,@features)
+ ((cond-expand) (syntax-error "no matching `cond-expand' clause"))
+ ,@(map (lambda (f)
+ `((cond-expand (,f body ...) . more-clauses)
+ (begin body ...)))
+ features)
+ ((cond-expand (else body ...)) (begin body ...))
+ ((cond-expand ((and) body ...) more-clauses ...) (begin body ...))
+ ((cond-expand ((and req1 req2 ...) body ...) more-clauses ...)
+ (cond-expand
+ (req1 (cond-expand
+ ((and req2 ...) body ...)
+ more-clauses ...))
+ more-clauses ...))
+ ((cond-expand ((or) body ...) more-clauses ...)
+ (cond-expand more-clauses ...))
+ ((cond-expand ((or req1 req2 ...) body ...) more-clauses ...)
+ (cond-expand
+ (req1 (begin body ...))
+ (else
+ (cond-expand
+ ((or req2 ...) body ...)
+ more-clauses ...))))
+ ((cond-expand ((not req) body ...) more-clauses ...)
+ (cond-expand
+ (req (cond-expand more-clauses ...))
+ (else body ...)))
+ ((cond-expand (feature-id body ...) more-clauses ...)
+ (cond-expand more-clauses ...))))
+ #f))
+ (sexpand (read-library state "syntax.scm") #f)
+ (sexpand (read-library state "library.scm") #f))
+ (for-each
+ (lambda (bound)
+ (let ((bs (parse-bindings (read-contents bound))))
+ (if (and (null? files) (not code))
+ (pp bs)
+ (sexpand bs #t))
+ bs))
+ (reverse bindings))
+ (for-each
+ (lambda (file) (sexpand (read-forms file) #t))
+ (reverse imports))
+ (cond (prepare mstore)
+ (output-file
+ (with-output-to-file output-file
+ (cut compile-files state files show)))
+ ((and (pair? bindings) (not code) (null? files)) #f)
+ (else (compile-files state files show)))))
+ (('help . _)
+ (spock-help))
+ (('output-file out . more)
+ (set! output-file out)
+ (loop more))
+ (('source . more)
+ (set! show (cons 'source show))
+ (loop more))
+ (('expand . more)
+ (set! show (cons 'expand show))
+ (loop more))
+ (('canonicalized . more)
+ (set! show (cons 'canonicalized show))
+ (loop more))
+ (('optimize . more)
+ (set! optimize-mode #t)
+ (loop more))
+ (('optimized . more)
+ (set! optimize-mode #t)
+ (set! show (cons 'optimized show))
+ (loop more))
+ (('cps . more)
+ (set! show (cons 'cps show))
+ (loop more))
+ (('strict . more)
+ (set! strict-mode #t)
+ (loop more))
+ (('block . more)
+ (set! block-mode #t)
+ (set! xref-mode #t)
+ (loop more))
+ (('import filename . more)
+ (set! imports (cons filename imports))
+ (loop more))
+ (('bind arg . more)
+ (set! bindings (cons arg bindings))
+ (loop more))
+ (('library-path)
+ (return library-path))
+ (('library-path dir . more)
+ (set! library-path (cons dir library-path))
+ (loop more))
+ (('namespace ns . more)
+ (set! namespace ns)
+ (loop more))
+ (('xref . more)
+ (set! show (cons 'xref show))
+ (set! xref-mode #t)
+ (loop more))
+ (('runtime . more)
+ (set! include-runtime #t)
+ (set! extract-library #t)
+ (loop more))
+ (('library . more)
+ (set! extract-library #t)
+ (loop more))
+ (('seal . more)
+ (set! seal-toplevel #t)
+ (loop more))
+ (('fail proc . more)
+ (set! fail proc)
+ (loop more))
+ (('usage proc . more)
+ (set! usage proc)
+ (loop more))
+ (('prepare . more)
+ (set! prepare #t)
+ (loop more))
+ (('debug . more)
+ (set! debug-mode #t)
+ (loop more))
+ (('environment store . more)
+ (set! mstore store)
+ (set! mstore-given #t)
+ (loop more))
+ (('verbose . more)
+ (set! verbose-mode #t)
+ (loop more))
+ (('debug-syntax . more)
+ (set! debug-syntax #t)
+ (loop more))
+ (('code exp . more)
+ (set! code exp)
+ (loop more))
+ (((or (? string? file) (? input-port? file)) . more)
+ (set! files (cons file files))
+ (loop more))
+ ((opts ...) (usage opts))))))))
diff --git a/spock-0.2/expand.scm b/spock-0.2/expand.scm
@@ -0,0 +1,1657 @@
+;; expand.scm: a macro expander for scheme.
+
+
+(define expand-syntax
+ (let ()
+
+;; Copyright 2002-2004 Al Petrofsky <alexpander@petrofsky.org>
+
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+
+; Redistributions of source code must retain the above copyright
+; notice, this list of conditions and the following disclaimer.
+
+; Redistributions in binary form must reproduce the above copyright
+; notice, this list of conditions and the following disclaimer in
+; the documentation and/or other materials provided with the
+; distribution.
+
+; Neither the name of the author nor the names of its contributors
+; may be used to endorse or promote products derived from this
+; software without specific prior written permission.
+
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
+; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
+; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
+; WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+;; INTRO:
+
+;; This file implements a macro-expander for r5rs scheme (plus some
+;; interesting extensions). There is no magic here to hook this into
+;; your native eval system: this is a simple data-in, data-out program
+;; that takes a macro-using program represented as scheme data and
+;; produces an equivalent macro-free program represented as scheme
+;; data.
+
+;; This is mostly intended as a demonstration. Although it certainly
+;; could be useful for adding macros to a simple scheme system that
+;; lacks any macros, it may not be feasible to get it to interact
+;; properly with a low-level macro system or a module system.
+
+;; The expander is written in portable r5rs scheme, except for one use
+;; of the pretty-print procedure which you can easily comment out.
+
+;; To try it out, just load the file and execute (alexpander-repl).
+;; Skip to the "BASIC USAGE" section for more information.
+
+
+;; EXTENSIONS:
+
+;; The expander supports all the features of the r5rs macro system,
+;; plus several extensions in the way syntaxes can be specified and
+;; used, which are best summarized in BNF:
+
+;; Modified r5rs productions:
+;; <expression> ---> <variable> | <literal> | <procedure call>
+;; | <lambda expression> | <conditional> | <assignment>
+;; | <derived expression> | <macro use> | <macro block>
+;; | <keyword>
+;; <syntax definition> ---> (define-syntax <keyword> <syntax or expression>)
+;; | (begin <syntax definition>*)
+;; | <macro use>
+;; <syntax spec> --> (<keyword> <syntax or expression>)
+;; <syntax or expression> --> <syntax> | <expression>
+;; <macro use> ---> (<syntax> <datum>*)
+;; <definition> ---> (define <variable> <expression>)
+;; | (define (<variable> <def formals>) <body>)
+;; | (define <expression>)
+;; | (begin <definition>*)
+;; | <macro use>
+;; | <syntax definition>
+;; <command or definition> ---> <command> | <definition>
+;; | (begin <command or definition>*)
+;; | <top-level macro block>
+;; | <macro use>
+
+;; New productions:
+;; <syntax> --> <transformer spec>
+;; | <keyword>
+;; | <macro use>
+;; | <syntax macro block>
+;; <syntax macro block> --> (<syntax-only block stuff> <syntax>)
+;; <top-level macro block>
+;; --> (<syntax-only block stuff> <command or definition>)
+;; <syntax-only block stuff>
+;; ---> <let-or-letrec-syntax> (<syntax spec>*) <syntax definition>*
+;; <let-or-letrec-syntax> ---> let-syntax | letrec-syntax
+
+;; These extensions all have the obvious meaning.
+
+;; Okay, I'll elaborate on that a little bit. Consider the intializer
+;; position of a syntax definition and the head position of a
+;; list-format expression:
+
+;; (define-syntax <keyword> <xxx>)
+
+;; (<yyy> <foo>*)
+
+;; In r5rs, <xxx> must be a transformer. <Yyy> may be an expression,
+;; in which case the enclosing expression is taken to be a procedure
+;; call and the <foo>s are the expressions for the operands, or <yyy>
+;; may be a keyword bound to a syntax (a builtin or transformer), in
+;; which case the <foo>s are processed according to that syntax.
+
+;; The core generalization in our system is that both <xxx> and <yyy>
+;; may be any type of expression or syntax. The four forms of syntax
+;; allowed are: a transformer (as allowed in the <xxx> position in
+;; r5rs), a keyword (as allowed in the <yyy> position in r5rs), a
+;; macro use that expands into a syntax, and a macro block (let-syntax
+;; or letrec-syntax) whose body is a syntax.
+
+;; Some examples:
+;;
+;; ;; a macro with a local macro
+;; (let-syntax ((foo (let-syntax ((bar (syntax-rules () ((bar x) (- x)))))
+;; (syntax-rules () ((foo) (bar 2))))))
+;; (foo))
+;; => -2
+;;
+;; ;; an anonymous let transformer, used directly in a macro call.
+;; ((syntax-rules ()
+;; ((_ ((var init) ...) . body)
+;; ((lambda (var ...) . body) init ...)))
+;; ((x 1) (y 2))
+;; (+ x y))
+;; => 3
+;;
+;; ;; a keyword used to initialize a keyword
+;; (let-syntax ((q quote)) (q x)) => x
+;;
+;; ;; Binding a keyword to an expression (which could also be thought
+;; ;; of as creating a macro that is called without arguments).
+;; (let ((n 0))
+;; (let-syntax ((x (set! n (+ n 1))))
+;; (begin x x x n)))
+;; => 3
+;;
+;; (let-syntax ((x append)) ((x x))) => ()
+
+
+;; Top-level macro blocks.
+
+;; At top level, if a macro block (a let-syntax or letrec-syntax form)
+;; has only one body element, that element need not be an expression
+;; (as would be required in r5rs). Instead, it may be anything
+;; allowed at top level: an expression, a definition, a begin sequence
+;; of top-level forms, or another macro block containing a top-level
+;; form.
+
+;; (let-syntax ((- quote))
+;; (define x (- 1)))
+;; (list x (- 1)) => (1 -1)
+
+;; Note that, unlike the similar extension in Chez scheme 6.0, this is
+;; still r5rs-compatible, because we only treat definitions within the
+;; last body element as top-level definitions (and r5rs does not allow
+;; internal definitions within a body's last element, even if it is a
+;; begin form):
+
+;; (begin
+;; (define x 1)
+;; (let-syntax ()
+;; (define x 2)
+;; 'blah)
+;; x)
+;; => 1, in r5rs and alexpander, but 2 in Chez scheme
+
+;; (begin
+;; (define x 1)
+;; (let-syntax ()
+;; (begin (define x 2)
+;; 'blah))
+;; x)
+;; => 2, in alexpander and in Chez scheme, but an error in r5rs.
+
+
+;; Expressions among internal definitions.
+
+;; A definition of the form (define <expression>) causes the
+;; expression to be evaluated at the conclusion of any enclosing set
+;; of internal definitons. That is, at top level, (define
+;; <expression>) is equivalent to just plain <expression>. As for
+;; internal definitions, the following are equivalent:
+
+;; (let ()
+;; (define v1 <init1>)
+;; (define <expr1>)
+;; (define <expr2>)
+;; (define v2 <init2>)
+;; (define <expr3>)
+;; (begin
+;; <expr4>
+;; <expr5>))
+;;
+;; (let ()
+;; (define v1 <init1>)
+;; (define v2 <init2>)
+;; (begin
+;; <expr1>
+;; <expr2>
+;; <expr3>
+;; <expr4>
+;; <expr5>))
+
+;; (Yes, it would probably be better to have a separate builtin for
+;; this rather than to overload define.)
+
+;; This feature makes it possible to implement a define-values that
+;; works properly both at top-level and among internal definitions:
+
+;; (define define-values-temp #f)
+;;
+;; (define-syntax define-values
+;; (syntax-rules ()
+;; ((define-values (var ...) init)
+;; (begin
+;; (define define-values-temp (call-with-values (lambda () init) list))
+;; (define var #f) ...
+;; (define
+;; (set!-values (var ...) (apply values define-values-temp)))))))
+
+;; (Set!-values is implementable using just r5rs features and is left
+;; as an exercise.)
+
+;; When used among internal definitions, the definition of
+;; define-values-temp in define-values's output creates a local
+;; binding, and thus the top-level binding of define-values-temp is
+;; irrelevant. When used at top-level, the definition of
+;; define-values-temp in the output does not create a binding, it
+;; mutates the top-level binding of define-values-temp. Thus, all
+;; top-level uses of define-values share a single temp variable. For
+;; internal-definition-level uses of define-values, a single shared
+;; temp would not be sufficient, but things work out okay because
+;; hygienic renaming causes each such use to create a distinct temp
+;; variable.
+
+;; The version below works the same way, but hides from the top-level
+;; environment the temp that is shared by top-level uses of
+;; define-values. For a bit of tutorial and rationale about this
+;; technique, see usenet article
+;; <8765tos2y9.fsf@radish.petrofsky.org>:
+
+;; (define-syntax define-values
+;; (let-syntax ((temp (syntax-rules ())))
+;; (syntax-rules ()
+;; ((define-values (var ...) init)
+;; (begin
+;; (define temp (call-with-values (lambda () init) list))
+;; (define var #f) ...
+;; (define (set!-values (var ...) (apply values temp))))))))
+
+
+;; Internal syntax definitions.
+
+;; Internal syntax definitions are supported wherever they would make
+;; sense (see the BNF) and have the letrec-syntax semantics you would
+;; expect. It is legal for the initializer of an internal variable
+;; definition to use one of the internal syntax definitions in the
+;; same body:
+
+;; (let ()
+;; (define x (y))
+;; (define-syntax y (syntax-rules () ((y) 1)))
+;; x)
+;; => 1
+
+;; It's also legal for internal syntax definitions to be mutually
+;; recursive transformers, but it is an error for the expansion of a
+;; syntax definition's initializer to require the result of another
+;; initializer:
+
+;; (let ()
+;; (define-syntax m1 (syntax-rules () ((m1) #f) ((m1 . args) (m2 . args))))
+;; (define-syntax m2 (syntax-rules () ((m2 arg . args) (m1 . args))))
+;; (m1 foo bar baz))
+;; => #f
+
+;; (let ()
+;; (define-syntax simple-transformer
+;; (syntax-rules ()
+;; ((simple-transformer pattern template)
+;; (syntax-rules () (pattern template)))))
+;; (define-syntax m (simple-transformer (m x) (- x)))
+;; (m 1))
+;; => error ("Premature use of keyword bound by an internal define-syntax")
+
+;; (let ()
+;; (define-syntax simple-transformer
+;; (syntax-rules ()
+;; ((simple-transformer pattern template)
+;; (syntax-rules () (pattern template)))))
+;; (let ()
+;; (define-syntax m (simple-transformer (m x) (- x)))
+;; (m 1)))
+;; => -1
+
+
+;; Syntax-rules ellipsis
+
+;; Per draft SRFI-46, syntax-rules transformers can specify the
+;; identifier to be used as the ellipsis (such a specification is
+;; treated as a hygienic binding), and a list pattern may contain
+;; subpatterns after an ellipsis as well as before it:
+
+;; <transformer spec> ---> (syntax-rules (<identifier>*) <syntax rule>*)
+;; | (syntax-rules <ellipsis> (<identifier>*) <syntax rule>*)
+;;
+;; <syntax rule> ---> (<pattern> <template>)
+;;
+;; <pattern> ---> <pattern identifier>
+;; | (<pattern>*)
+;; | (<pattern>+ . <pattern>)
+;; | (<pattern>* <pattern> <ellipsis> <pattern>*)
+;; | #(<pattern>*)
+;; | #(<pattern>* <pattern> <ellipsis> <pattern>*)
+;; | <pattern datum>
+;;
+;; <pattern identifier> ---> <identifier>
+;;
+;; <ellipsis> ---> <identifier>
+
+
+;; Improved nested unquote-splicing.
+
+;; Quasiquote is extended to make commas and comma-ats distributive
+;; over a nested comma-at, as in Common Lisp's backquote. See my
+;; 2004-09-03 usenet article <87pt53f9f2.fsf@radish.petrofsky.org>,
+;; Bawden's 1999 quasiquotation paper, and Appendix C of Steele's
+;; "Common Lisp the Language 2nd edition".
+
+;; <splicing unquotation 1> ---> ,@<qq template 0>
+;; | (unquote-splicing <qq template 0>)
+;;
+;; <splicing unquotation D> ---> ,@<qq template D-1>
+;; | ,<splicing unquotaion D-1>
+;; | ,@<splicing unquotaion D-1>
+;; | (unquote-splicing <qq template D-1>)
+;; | (unquote <splicing unquotaion D-1>)
+;; | (unquote-splicing <splicing unquotaion D-1>)
+
+;; When a comma at-sign and the expression that follows it are being
+;; replaced by the elements of the list that resulted from the
+;; expression's evaluation, any sequence of commas and comma at-signs
+;; that immediately preceeded the comma at-sign is also removed and is
+;; added to the front of each of the replacements.
+
+;; (let ((x '(a b c))) ``(,,x ,@,x ,,@x ,@,@x))
+;; => `(,(a b c) ,@(a b c) ,a ,b ,c ,@a ,@b ,@c)
+;;
+;; ``(,,@'() ,@,@(list))
+;; => `()
+;;
+;; `````(a ,(b c ,@,,@,@(list 'a 'b 'c)))
+;; => ````(a ,(b c ,@,,@a ,@,,@b ,@,,@c))
+;;
+;; (let ((vars '(x y)))
+;; (eval `(let ((x '(1 2)) (y '(3 4)))
+;; `(foo ,@,@vars))
+;; (null-environment 5)))
+;; => (foo 1 2 3 4)
+
+
+;; BASIC USAGE:
+
+;; There are four supported ways to use this:
+
+;; 1. (alexpander-repl)
+;; This starts a read-expand-print-loop. Type in a program
+;; and see its expansion as you go.
+;;
+;; 2. (expand-program list-of-the-top-level-forms-of-a-program)
+;; Returns a list of the top-level forms of an equivalent
+;; macro-free program.
+;;
+;; 3. (expand-top-level-forms! forms mstore)
+;; Returns some macro-expanded forms and side-effects mstore.
+;; First create an initial mutable store with (null-mstore), then
+;; you can pass a program in piecemeal, with the effects of
+;; top-level define-syntaxes saved in mstore between calls to
+;; expand-top-level-forms!.
+;;
+;; 4. (expand-top-level-forms forms store loc-n k)
+;; The purely-functional interface.
+;; Returns by making a tail call to k:
+;; (k expanded-forms new-store new-loc-n)
+;; Use null-store and null-loc-n for store and loc-n arguments
+;; when calling expand-top-level-forms with the first forms in a
+;; program.
+;;
+;; For options 3 and 4, you need to prepend null-output to the
+;; resulting program. Null-output contains some definitions like
+;; (define _eqv?_7 eqv?), which create alternate names for some of the
+;; builtin procedures. These names are used by the standard case and
+;; quasiquote macros so that they can keep working even if you
+;; redefine one of the standard procedures.
+
+;; The output programs use a small subset of the r5rs syntax, namely:
+;; begin, define, delay, if, lambda, letrec, quote, and set!.
+;; Furthermore, begin is only used for expressions; lambdas and
+;; letrecs always have a single body expression and no internal
+;; definitions; and defines are always of the simple (define
+;; <variable> <expression>) form. Any uses or definitions in the
+;; original program of a top-level variable whose name begins with
+;; "_", or whose name is one of the eight primitives just mentioned,
+;; will be renamed. This will only cause a problem if the program is
+;; trying to use some nonstandard library variable that starts with
+;; "_": any r5rs-conformant program will be translated to an
+;; equivalent macro-free r5rs program, it just might have some of its
+;; top-level variable names changed.
+
+
+;; INTERNALS
+
+;; [NOTE: this documentation is certainly not complete, and it kind of
+;; dissolves after a few pages from verbose paragraphs into cryptic
+;; sentence fragments. Nonetheless, it might be enough to help
+;; someone figure out the code.]
+
+;; ENVIRONMENTS AND STORES
+
+;; The two principal data structures are the environment and the
+;; store.
+
+;; These work similarly to the runtime environment and store described
+;; in r5rs: in both that system and in ours, to determine the meaning
+;; of an identifier, we lookup which location the environment
+;; associates with the identifier, and then check what value the store
+;; associates with that location.
+
+;; In the runtime system, the identifiers mapped by the environment
+;; are all variables, and the values in the store are the scheme
+;; values the variables currently hold. Environments may be locally
+;; extended by LAMBDA to map some identifiers to new locations that
+;; initially hold the values passed to the procedure. Environments
+;; may also be locally extended by internal DEFINE (a.k.a LETREC) to
+;; map some identifiers to new locations that are empty and illegal to
+;; access or SET! until the evaluation of all the initializers has
+;; completed (at which time the results are stored into the
+;; locations). The store is modified when a SET! or top-level DEFINE
+;; is evaluated, or when a set of internal DEFINE initializers'
+;; evaluations completes, but environments are immutable. The static
+;; top-level environment maps every variable name to some location,
+;; although most of these locations are illegal to access until the
+;; evaluation of the initializer of the first top-level DEFINE of the
+;; variable has completed. (The exceptions are the locations to which
+;; the standard procedure names are bound: these locations may be
+;; accessed at any time, but they may not be SET! until after the
+;; first top-level DEFINE of the procedure name.)
+
+;; (R5rs actually does not completely specify how the top-level
+;; environment works, and allows one to consider the top-level
+;; environment to be dynamically extended, but the model I just
+;; described fits within the r5rs parameters and plays well with our
+;; macro system. To recap: the difference between SET! and top-level
+;; DEFINE is not that top-level DEFINE is able to create a new
+;; binding, rather, the difference is that top-level DEFINE is allowed
+;; to store into any location and SET! is not always allowed to store
+;; into some locations.)
+
+;; In our syntactic system, a value in the store may be either a
+;; syntax (a builtin or a macro transformer), a variable name, or the
+;; expanded code for an expression. When we encounter a use of an
+;; identifier, we go through the environment and the store to fetch
+;; its value. If the value is a variable name, we emit that variable
+;; name. If the value is some code, we emit that code. If the value
+;; is a syntax, we proceed according to the rules of that syntax. As
+;; in the runtime system, environments are immutable and the static
+;; top-level environment is infinite. Environments may be locally
+;; extended by LAMBDA or internal DEFINE to map some identifiers to
+;; new locations that hold variable names. Environments may also be
+;; extended by LET-SYNTAX to map some identifiers to new locations
+;; that initially hold the syntaxes and/or code resulting from the
+;; expansion of the initializers. Lastly, environments may be
+;; extended by internal DEFINE-SYNTAX (a.k.a LETREC-SYNTAX) to map
+;; some identifiers to new locations that are empty and illegal to
+;; access until the expansion of their initializers has completed (at
+;; which time the resulting syntaxes and/or code are stored into the
+;; locations). The store is modified by top-level DEFINE and
+;; DEFINE-SYNTAX, and when a set of internal DEFINE-SYNTAX
+;; initializers' expansions completes. The store is not altered by a
+;; SET!, because a SET! does not change the fact that the identifier
+;; is a variable: from our perspective a SET! of a variable is simply
+;; a use of the variable. A top-level DEFINE only alters the store if
+;; an identifier whose location previously held a syntax is now being
+;; defined as a variable.
+
+;; The static top-level environment maps every name to some location.
+;; Initially, the locations to which the environment maps the names of
+;; the ten builtins (BEGIN DEFINE DEFINE-SYNTAX IF LAMBDA QUOTE SET!
+;; DELAY LET-SYNTAX SYNTAX-RULES) hold as their values those builtin
+;; syntaxes. All other names are bound to locations that hold the
+;; corresponding top-level variable name.
+
+;; I said the top-level environment contains a binding for "every
+;; name" rather than for "every identifier", because the new
+;; identifiers created by a syntax-rules macro expansion are given
+;; numbers rather than names, and the top-level environment has no
+;; bindings for these. If such an identifier is used in an
+;; environment with no binding for it, then the location to which the
+;; template literal in the macro was bound is used instead (to be
+;; prepared for such a contingency, this location is stored along with
+;; the numeric id in the "renamed-sid" (see below) that a macro
+;; expansion inserts into the code).
+
+;; REPRESENTATION OF ENVIRONMENTS AND STORES
+
+;; An environment is represented by an alist mapping ids to local
+;; (non-top-level) locations. All environments are derived from the
+;; top-level environment, so any symbolic id not in the alist is
+;; implicitly mapped to the corresponding top-level location.
+
+;; An id (identifier) is what we bind to a location in an environment.
+;; Original ids are the symbols directly occuring in the source code.
+;; Renamed ids are created by macro expansions and are represented by
+;; integers.
+
+;; id: original-id | renamed-id
+;; original-id: symbol
+;; renamed-id: integer
+
+;; The static top-level environment maps every symbol to a location.
+;; For simplicity, each of those locations is represented by the
+;; symbol that is bound to it. All other locations (those created by
+;; lambda, let-syntax, and internal definitions) are represented by
+;; integers.
+
+;; env: ((id . local-location) ...)
+;; store: ((location . val) ...)
+;; location: toplevel-location | local-location ;; a.k.a. symloc and intloc.
+;; toplevel-location: symbol
+;; local-location: integer
+;; val: variable | syntax | code
+;; variable: symbol ; the symbol that is used in the output, e.g. _foo_42.
+;; code: (output) ; the finished code for an expression.
+;; syntax: builtin | transformer
+;; builtin: (BUILTIN name)
+;; transformer: (synrules env)
+;; synrules: the unaltered sexp of the syntax-rules form.
+
+;; REPRESENTATION OF THE CODE UNDERGOING EXPANSION (SEXPS).
+
+;; Any variable named SEXP in the expander code holds a representation
+;; of some code undergoing expansion. It mostly looks like the
+;; ordinary representation of scheme code, but it may contain some
+;; identifiers that are encoded as two- or three-element vectors
+;; called renamed-sids. Any actual vector in the code will be
+;; represented as a one-element vector whose element is a list of the
+;; actual elements, i.e., each vector #(elt ...) is mapped to #((elt
+;; ...)), so that we can distinguish these vectors from renamed-sids.
+
+;; In contrast, a variable named OUTPUT is a bit of finished code, in
+;; which vectors represent themselves and all renamed identifiers have
+;; been mapped to suitable symbols.
+
+;; A sid is the representation of an id within a sexp.
+;; sid: original-id | renamed-sid
+
+;; A renamed-sid includes the id's original name, which we will need
+;; if the id gets used in a QUOTE expression. The renamed-sid also
+;; includes the location of the local binding (if any) of the template
+;; literal that created the id: this is the location to use if the id
+;; gets used freely (i.e., in an environment with no binding for it).
+;; renamed-sid: #(original-id renamed-id)
+;; | #(original-id renamed-id local-location)
+
+;; Procedures that take a SEXP argument usually also take an ID-N
+;; argument, which is the next higher number after the largest
+;; renamed-id that occurs in the SEXP argument. (This is to enable
+;; adding new ids without conflict.)
+;;
+;; Similarly, a STORE argument is usually accompanied by a LOC-N
+;; argument, which is the next higher number after the largest
+;; local-location in the STORE argument.
+
+;; SUMMARY OF MAJOR FUNCTIONS:
+
+;; (lookup-sid sid env) => location
+;; (lookup-location location store) => val | #f ;; #f means letrec violation.
+;; (lookup2 sid env store) => val ;; lookup-sid + lookup-location + fail if #f.
+;; (extend-env env id location) => env
+;; (extend-store store intloc val) => store
+;; (substitute-in-store store loc val) => store
+;; (compile-syntax-rules synrules env) => transformer
+;; (apply-transformer trans sexp id-n env k) => (k sexp id-n)
+;; (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
+;; => (ek output)
+;; | (sk syntax sexp store loc-n)
+;; | (dk builtin sexp id-n env store loc-n)
+;; | (bk sexp id-n env store loc-n)
+;; (expand-expr sexp id-n env store loc-n) => output
+;; (expand-val sexp id-n env store loc-n k) => (k val store loc-n)
+;; (expand-top-level-forms forms store loc-n k)
+;; => (k outputs store loc-n)
+;; (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
+;; => same as expand-any
+;; (expand-syntax-bindings bindings id-n syntax-env ienv store loc-n k)
+;; => (k store loc-n)
+
+
+
+(define expand-error-hook error)
+(define debug-syntax #f)
+
+(define (sid? sexp) (or (symbol? sexp) (renamed-sid? sexp)))
+(define (renamed-sid? sexp) (and (vector? sexp) (< 1 (vector-length sexp))))
+(define (svector? sexp) (and (vector? sexp) (= 1 (vector-length sexp))))
+(define (svector->list sexp) (vector-ref sexp 0))
+(define (list->svector l) (vector l))
+
+(define (make-sid name renamed-id location)
+ (if (eq? name location)
+ (vector name renamed-id)
+ (vector name renamed-id location)))
+
+(define (sid-name sid) (if (symbol? sid) sid (vector-ref sid 0)))
+(define (sid-id sid) (if (symbol? sid) sid (vector-ref sid 1)))
+(define (sid-location sid)
+ (if (symbol? sid) sid (vector-ref sid (if (= 2 (vector-length sid)) 0 2))))
+
+(define (list1? x) (and (pair? x) (null? (cdr x))))
+(define (list2? x) (and (pair? x) (list1? (cdr x))))
+
+;; Map-vecs does a deep map of x, replacing any vector v with (f v).
+;; We assume that f never returns #f.
+;; If a subpart contains no vectors, we don't waste space copying it.
+;; (Yes, this is grossly premature optimization.)
+(define (map-vecs f x)
+ ;; mv2 returns #f if there are no vectors in x.
+ (define (mv2 x)
+ (if (vector? x)
+ (f x)
+ (and (pair? x)
+ (let ((a (car x)) (b (cdr x)))
+ (let ((a-mapped (mv2 a)))
+ (if a-mapped
+ (cons a-mapped (mv b))
+ (let ((b-mapped (mv2 b)))
+ (and b-mapped (cons a b-mapped)))))))))
+ (define (mv x) (or (mv2 x) x))
+ (mv x))
+
+(define (wrap-vec v) (list->svector (wrap-vecs (vector->list v))))
+(define (wrap-vecs input) (map-vecs wrap-vec input))
+(define (unwrap-vec v-sexp)
+ (if (= 1 (vector-length v-sexp))
+ (list->vector (unwrap-vecs (svector->list v-sexp)))
+ (vector-ref v-sexp 0)))
+(define (unwrap-vecs sexp) (map-vecs unwrap-vec sexp))
+
+;; The store maps locations to vals.
+;; vals are variables, syntaxes, or code.
+
+(define (make-code output) (list output))
+(define (make-builtin name) (list 'builtin name))
+(define (make-transformer synrules env) (list synrules env))
+
+(define (variable? val) (symbol? val))
+(define (code? val) (list1? val))
+(define (code-output code) (car code))
+
+(define (syntax? val) (list2? val))
+
+(define (builtin? syntax) (eq? 'builtin (car syntax)))
+(define (builtin-name builtin) (cadr builtin))
+
+(define (transformer? syntax) (not (builtin? syntax)))
+(define (transformer-synrules trans) (car trans))
+(define (transformer-env trans) (cadr trans))
+
+(define (acons key val alist) (cons (cons key val) alist))
+
+(define empty-env '())
+(define empty-store '())
+
+;; Lookup-sid looks up a sid in an environment.
+;; If there is no binding in the environment, then:
+;; 1. For an original-id, we return the like-named location, because
+;; the static top-level environment maps every name to a location.
+;; 2. For a renamed id, we return the location to which the template
+;; literal that created it was bound.
+(define (lookup-sid sid env)
+ (cond ((assv (sid-id sid) env) => cdr)
+ ;; This works for both cases 1 and 2 above.
+ (else (sid-location sid))))
+
+;; Lookup-location looks up a location in the store.
+;; If there is no value explictly listed in the store, then:
+;; 1. For a top-level (named) location, return a top-level variable name.
+;; 2. For a local location, return #f. This can only happen for a
+;; location allocated by letrec-syntax or internal define-syntax
+;; and used before it is initialized,
+;; e.g. (letrec-syntax ((x x)) 1).
+(define (lookup-location location store)
+ (cond ((assv location store) => cdr)
+ ((symbol? location) (symloc->var location))
+ (else #f)))
+
+(define (lookup2 sid env store)
+ (or (lookup-location (lookup-sid sid env) store)
+ (expand-error "Premature use of keyword bound by letrec-syntax (or an internal define-syntax): "
+ sid)))
+
+(define (extend-env env id location) (acons id location env))
+(define (extend-store store loc val) (acons loc val store))
+
+;; Extend-store just adds to the front of the alist, whereas
+;; substitute-in-store actually bothers to remove the old entry, and
+;; to not add a new entry if it is just the default.
+;; Substitute-in-store is only used by top-level define and
+;; define-syntax. Because nothing is ever mutated, we could just use
+;; extend-store all the time, but we are endeavoring to keep down the
+;; size of the store to make it more easily printed and examined.
+(define (substitute-in-store store loc val)
+ (let ((store (if (assv loc store)
+ (let loop ((store store))
+ (let ((p (car store)))
+ (if (eqv? loc (car p))
+ (cdr store)
+ (cons p (loop (cdr store))))))
+ store)))
+ (if (and (symbol? loc) (eq? val (symloc->var loc)))
+ store
+ (acons loc val store))))
+
+;; Top-level variables must be renamed if they conflict with the
+;; primitives or local variable names we use in the output.
+(define (symloc->var sym)
+ (define str (symbol->string sym))
+ (define (rename) (string->symbol (string-append "_" str "_")))
+ (case sym
+ ((begin define delay if lambda letrec quote set!) (rename))
+ (else (if (and (positive? (string-length str))
+ (char=? #\_ (string-ref str 0)))
+ (rename)
+ sym))))
+
+;; intloc->var:
+;; A simple (string->symbol (string-append "_" (number->string intloc)))
+;; would work, but we use more verbose local variable names to make
+;; the output more decipherable to humans.
+(define (intloc->var intloc sid)
+ (let ((str (symbol->string (sid-name sid))))
+ (string->symbol (string-append "_" str "_" (number->string intloc)))))
+
+(define (loc->var loc sid)
+ (if (symbol? loc)
+ (symloc->var loc)
+ (intloc->var loc sid)))
+
+(define (make-begin outputs)
+ (if (list1? outputs) (car outputs) (cons 'begin outputs)))
+
+(define (expand-lambda formals expr id-n env store loc-n)
+ ;; (a b . c) => (a b c)
+ (define (flatten-dotted x)
+ (if (pair? x) (cons (car x) (flatten-dotted (cdr x))) (list x)))
+ ;; (a b c) => (a b . c)
+ (define (dot-flattened x)
+ (if (null? (cdr x)) (car x) (cons (car x) (dot-flattened (cdr x)))))
+ (let* ((dotted? (not (list? formals)))
+ (flattened (if dotted? (flatten-dotted formals) formals)))
+ (define (check x)
+ (or (sid? x) (expand-error "Non-identifier: " x " in lambda formals: " formals))
+ (if (member x (cdr (member x flattened)))
+ (expand-error "Duplicate variable: " x " in lambda formals: " formals)))
+ (begin
+ (for-each check flattened)
+ (let loop ((formals flattened) (rvars '())
+ (env env) (store store) (loc-n loc-n))
+ (if (not (null? formals))
+ (let* ((var (intloc->var loc-n (car formals)))
+ (env (extend-env env (sid-id (car formals)) loc-n))
+ (store (extend-store store loc-n var)))
+ (loop (cdr formals) (cons var rvars) env store (+ 1 loc-n)))
+ (let* ((vars (reverse rvars))
+ (vars (if dotted? (dot-flattened vars) vars)))
+ (list vars (expand-expr expr id-n env store loc-n))))))))
+
+(define (check-syntax-bindings bindings)
+ (or (list? bindings) (expand-error "Non-list syntax bindings list: " bindings))
+ (for-each (lambda (b) (or (and (list2? b) (sid? (car b)))
+ (expand-error "Malformed syntax binding: " b)))
+ bindings)
+ (do ((bs bindings (cdr bs)))
+ ((null? bs))
+ (let ((dup (assoc (caar bs) (cdr bs))))
+ (if dup (expand-error "Duplicate bindings for a keyword: "
+ (car bs) " and: " dup)))))
+
+;; returns (k store loc-n)
+(define (expand-syntax-bindings bindings id-n syntax-env ienv store loc-n k)
+ (let loop ((bs bindings) (vals '()) (store store) (loc-n loc-n))
+ (if (not (null? bs))
+ (expand-val (cadar bs) id-n syntax-env store loc-n
+ (lambda (val store loc-n)
+ (loop (cdr bs) (cons val vals) store loc-n)))
+ (let loop ((store store) (vals (reverse vals)) (bs bindings))
+ (if (not (null? vals))
+ (let* ((loc (lookup-sid (caar bs) ienv))
+ (store (extend-store store loc (car vals))))
+ (loop store (cdr vals) (cdr bs)))
+ (k store loc-n))))))
+
+
+;; (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
+;;
+;; Ek, sk, dk, and bk are continuations for expressions, syntaxes,
+;; definitions and begins:
+;;
+;; If sexp is an expression, returns (ek output).
+;;
+;; If sexp is a syntax, returns (sk syntax error-sexp store loc-n).
+;; The error-sexp is just for use in error messages if the syntax is
+;; subsequently misued. It is the sid that was bound to the syntax,
+;; unless the syntax is an anonymous transformer, as in
+;; ((syntax-rules () ((_ x) 'x)) foo), in which case the error-sexp
+;; will be the entire syntax-rules form.
+;;
+;; If sexp is a definition, returns (dk builtin sexp id-n env store
+;; loc-n), where builtin is define or define-syntax.
+;;
+;; If sexp is a begin, returns (bk sexp id-n env store loc-n).
+;;
+;; The car of the sexp passed to dk or bk is just for error reporting:
+;; it is the sid that was bound to begin, define, or define-syntax.
+;;
+;; Expand-any signals an error if a malformed e, s, d, or b is
+;; encountered. It also signals an error if ek, sk, dk, or bk is #f
+;; and the corresponding thing is encountered; however, if a begin is
+;; encountered and bk is #f, the begin is expanded as an expression
+;; and passed to ek.
+;;
+;; lsd? == Let-Syntax around Definitions is okay. If lsd? is #f and a
+;; let-syntax is encountered, it is assumed to start an expression or
+;; syntax, so if ek and sk are #f an error will be signalled. lsd? is
+;; only true at top-level. (Let-syntax around internal definitions is
+;; just too semantically bizarre.)
+(define (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
+ (define (get-k k sexp name)
+ (or k (expand-error (string-append name " used in bad context: ")
+ sexp)))
+ (define (get-ek sexp) (get-k ek sexp "Expression"))
+ (define (get-sk sexp) (get-k sk sexp "Syntax"))
+ (define (get-dk sexp) (get-k dk sexp "Definition"))
+ (define (get-bk sexp) (get-k bk sexp "Begin"))
+ (let again ((sexp sexp) (id-n id-n) (store store) (loc-n loc-n))
+ (define (expand-subexpr sexp) (expand-expr sexp id-n env store loc-n))
+ (define (handle-syntax-use syntax head store loc-n)
+ (let* ((tail (cdr sexp)) (sexp (cons head tail)))
+ (if (transformer? syntax)
+ (apply-transformer syntax sexp id-n env
+ (lambda (sexp id-n) (again sexp id-n store loc-n)))
+ (let ((builtin (builtin-name syntax)) (len (length tail)))
+ (define (handle-macro-block)
+ (or ek sk lsd?
+ (expand-error "Macro block used in bad context: " sexp))
+ (or (>= len 2) (expand-error "Malformed macro block: " sexp))
+ (let ((bindings (car tail)) (body (cdr tail)))
+ (check-syntax-bindings bindings)
+ (let loop ((bs bindings) (loc-n loc-n) (ienv env))
+ (if (not (null? bs))
+ (loop (cdr bs) (+ loc-n 1)
+ (extend-env ienv (sid-id (caar bs)) loc-n))
+ (expand-syntax-bindings
+ bindings id-n env ienv store loc-n
+ (lambda (store loc-n)
+ (expand-body body id-n ienv store loc-n
+ lsd? ek sk
+ (and lsd? dk) (and lsd? bk))))))))
+ (define (handle-expr-builtin)
+ (define (expr-assert test)
+ (or test (expand-error "Malformed " builtin " expression: " sexp)))
+ (cons builtin
+ (case builtin
+ ((lambda)
+ (expr-assert (= len 2))
+ (expand-lambda (car tail) (cadr tail)
+ id-n env store loc-n))
+ ((quote)
+ (expr-assert (= len 1))
+ (list (unwrap-vecs (car tail))))
+ ((set!)
+ (expr-assert (and (= len 2) (sid? (car tail))))
+ (let ((var (lookup2 (car tail) env store)))
+ (or (variable? var)
+ (expand-error "Attempt to set a keyword: " sexp))
+ (list var (expand-subexpr (cadr tail)))))
+ ((delay)
+ (expr-assert (= len 1))
+ (list (expand-subexpr (car tail))))
+ ((if)
+ (expr-assert (<= 2 len 3))
+ (map expand-subexpr tail)) ) ) )
+ (case builtin
+ ((let-syntax) (handle-macro-block))
+ ((syntax-rules)
+ (if (< len 1) (expand-error "Empty syntax-rules form: " sexp))
+ (let ((syn (compile-syntax-rules sexp env)))
+ ((get-sk sexp) syn sexp store loc-n)))
+ ((begin)
+ (or ek (get-bk sexp))
+ (cond (bk (bk sexp id-n env store loc-n))
+ ((null? tail) (expand-error "Empty begin expression: " sexp))
+ (else (ek (make-begin (map expand-subexpr tail))))))
+ ((define define-syntax)
+ (or (and (= 2 len) (sid? (car tail)))
+ (and (= 1 len) (eq? builtin 'define))
+ (expand-error "Malformed definition: " sexp))
+ ((get-dk sexp) builtin sexp id-n env store loc-n))
+ (else (get-ek sexp) (ek (handle-expr-builtin))))))))
+ (define (handle-combination output)
+ (ek (if (and (pair? output) (eq? 'lambda (car output))
+ (null? (cadr output)) (null? (cdr sexp)))
+ ;; simplifies ((lambda () <expr>)) to <expr>
+ (caddr output)
+ (cons output (map expand-subexpr (cdr sexp))))))
+ (when debug-syntax (pp sexp))
+ (cond ((sid? sexp)
+ (let ((val (lookup2 sexp env store)))
+ (if (syntax? val)
+ ((get-sk sexp) val sexp store loc-n)
+ ((get-ek sexp) (if (code? val) (code-output val) val)))))
+ ((and (pair? sexp) (list? sexp))
+ (expand-any (car sexp) id-n env store loc-n #f
+ (and ek handle-combination) handle-syntax-use #f #f))
+ ((or (number? sexp) (boolean? sexp) (string? sexp) (char? sexp)
+ (eof-object? sexp))
+ ((get-ek sexp) sexp))
+ (else (expand-error (cond ((pair? sexp) "Improper list: ")
+ ((null? sexp) "Empty list: ")
+ ((vector? sexp) "Vector: ")
+ (else "Non-S-Expression: "))
+ sexp
+ " used as an expression, syntax, or definition.")))))
+
+;; Expands an expression or syntax and returns (k val store loc-n).
+(define (expand-val sexp id-n env store loc-n k)
+ (expand-any sexp id-n env store loc-n #f
+ (lambda (output) (k (make-code output) store loc-n))
+ (lambda (syn error-sexp store loc-n) (k syn store loc-n))
+ #f #f))
+
+(define (expand-expr sexp id-n env store loc-n)
+ (expand-any sexp id-n env store loc-n #f (lambda (x) x) #f #f #f))
+
+;; args and return are as in expand-any.
+(define (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
+ ;; Expand-def expands a definition or begin sequence, adds entries
+ ;; to the vds and sds lists of variable and syntax definitons, adds
+ ;; entries to the exprs list of expressions from (define <expr>)
+ ;; forms, extends env, and returns (k vds sds exprs id-n env store
+ ;; loc-n).
+ ;; If sexp is an expression, we just return (dek output) instead.
+ (define (expand-def sexp vds sds exprs id-n env store loc-n k dek)
+ (define (dk builtin sexp id-n env store loc-n)
+ (or ek (eq? builtin 'define-syntax)
+ (expand-error "Non-syntax definition is a syntax body: " sexp))
+ (if (list2? sexp) ;; A (define <expression>) form.
+ (k vds sds (cons (cadr sexp) exprs) id-n env store loc-n)
+ (let* ((sid (cadr sexp))
+ (id (sid-id sid))
+ (env (extend-env env id loc-n)))
+ (define (check def)
+ (if (eqv? id (sid-id (cadr def)))
+ (expand-error "Duplicate internal definitions: "
+ def " and: " sexp)))
+ (begin
+ (for-each check sds)
+ (for-each check vds)
+ (case builtin
+ ((define-syntax)
+ (k vds (cons sexp sds) exprs id-n env store (+ loc-n 1)))
+ ((define)
+ (let* ((var (intloc->var loc-n sid))
+ (store (extend-store store loc-n var))
+ (loc-n (+ loc-n 1)))
+ (k (cons sexp vds) sds exprs id-n env store loc-n))))))))
+ (define (bk sexp id-n env store loc-n)
+ (let loop ((sexps (cdr sexp)) (vds vds) (sds sds) (exprs exprs)
+ (id-n id-n) (env env) (store store) (loc-n loc-n) (dek dek))
+ (if (null? sexps)
+ (k vds sds exprs id-n env store loc-n)
+ (expand-def (car sexps) vds sds exprs id-n env store loc-n
+ (lambda (vds sds exprs id-n env store loc-n)
+ (loop (cdr sexps) vds sds exprs id-n env store loc-n #f))
+ (and dek (lambda (out)
+ (define (expand-one sexp)
+ (expand-expr sexp id-n env store loc-n))
+ (let ((rest (map expand-one (cdr sexps))))
+ (dek (make-begin (cons out rest))))))))))
+ (expand-any sexp id-n env store loc-n #f dek #f dk bk))
+ (let loop ((first (car sexps)) (rest (cdr sexps))
+ (vds '()) (sds '()) (exprs '())
+ (id-n id-n) (env env) (store store) (loc-n loc-n))
+ (define (finish-body boundary-exp-output)
+ (expand-syntax-bindings (map cdr sds) id-n env env store loc-n
+ (lambda (store loc-n)
+ (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
+ (define (expand-vd vd)
+ (list (lookup2 (cadr vd) env store) (iexpand (caddr vd))))
+ (define (make-letrec bindings expr)
+ (if (null? bindings) expr (list 'letrec bindings expr)))
+ (if (and (null? rest) (null? vds) (null? exprs))
+ (expand-any first id-n env store loc-n lsd? ek sk dk bk)
+ (ek (make-letrec
+ (map expand-vd (reverse vds))
+ (let ((body-exprs-output
+ (if (null? rest)
+ (list (iexpand first))
+ (cons boundary-exp-output
+ (map iexpand rest)))))
+ (make-begin (append (map iexpand (reverse exprs))
+ body-exprs-output)))))))))
+ (if (null? rest)
+ (finish-body #f)
+ (expand-def first vds sds exprs id-n env store loc-n
+ (lambda (vds sds exprs id-n env store loc-n)
+ (loop (car rest) (cdr rest) vds sds exprs id-n env store loc-n))
+ (and ek finish-body)))))
+
+
+;; (returns (k outputs store loc-n))
+(define (expand-top-level-forms forms store loc-n k)
+ (define (finalize store loc-n acc)
+ (k (reverse acc) store loc-n))
+ ;; expand adds stuff to acc and returns (k store loc-n acc)
+ (let expand ((sexps (wrap-vecs forms)) (id-n 0) (env empty-env)
+ (store store) (loc-n loc-n) (acc '()) (k finalize))
+ (if (null? sexps)
+ (k store loc-n acc)
+ (let ((rest (cdr sexps)))
+ (define (ek output)
+ (expand rest id-n env store loc-n (cons output acc) k))
+ (define (dk builtin sexp id-n* env* store loc-n)
+ (if (list2? sexp) ;; A (define <expression>) form.
+ (ek (expand-expr (cadr sexp) id-n* env* store loc-n))
+ (let* ((tail (cdr sexp))
+ (sid (car tail))
+ (loc (lookup-sid sid env*))
+ (init (cadr tail)))
+ (if (eq? builtin 'define)
+ (let* ((expr (expand-expr init id-n* env* store loc-n))
+ (var (loc->var loc sid))
+ (acc (cons (list 'define var expr) acc))
+ (store (substitute-in-store store loc var)))
+ (expand rest id-n env store loc-n acc k))
+ (expand-val init id-n* env* store loc-n
+ (lambda (val store loc-n)
+ (let ((store (substitute-in-store store loc val)))
+ (expand rest id-n env store loc-n acc k))))))))
+ (define (bk sexp id-n* env* store loc-n)
+ (expand (cdr sexp) id-n* env* store loc-n acc
+ (lambda (store loc-n acc)
+ (expand rest id-n env store loc-n acc k))))
+ (expand-any (car sexps) id-n env store loc-n #t ek #f dk bk)))))
+
+;; Compile-syntax-rules:
+;; This doesn't actually compile, it just does verification.
+;; Detects all possible errors:
+;; pattern literals list is not a list of identifiers
+;; ellipsis in literals list
+;; rule is not a two-element list
+;; missing pattern keyword (pattern is not a pair whose car is an identifier)
+;; duplicate pattern variable
+;; ellipsis not preceded by a pattern or template.
+;; list or vector pattern with multiple ellipses.
+;; improper list pattern with an ellipsis.
+;; variable instance in template not at sufficient ellipsis depth.
+;; template ellipsis closes no variables.
+(define (compile-syntax-rules synrules env)
+ (define ellipsis-id (and (pair? (cddr synrules))
+ (sid? (cadr synrules))
+ (sid-id (cadr synrules))))
+ (define (ellipsis? x)
+ (and (sid? x)
+ (if ellipsis-id
+ (eqv? ellipsis-id (sid-id x))
+ (eq? '... (lookup-sid x env)))))
+
+ (define (check-lit lit)
+ (or (sid? lit)
+ (expand-error "Non-id: " lit " in literals list of: " synrules))
+ (if (ellipsis? lit)
+ (expand-error "Ellipsis " lit " in literals list of: " synrules)))
+
+ (let* ((rest (if ellipsis-id (cddr synrules) (cdr synrules)))
+ (pat-literal-sids (car rest))
+ (rules (cdr rest))
+ (pat-literals
+ (begin (or (list? pat-literal-sids)
+ (expand-error "Pattern literals list is not a list: "
+ pat-literal-sids))
+ (for-each check-lit pat-literal-sids)
+ (map sid-id pat-literal-sids))))
+
+ (define (ellipsis-pair? x)
+ (and (pair? x) (ellipsis? (car x))))
+
+ (define (check-ellipses pat/tmpl in-template?)
+ (define (bad-ellipsis x reason)
+ (expand-error (string-append reason ": ")
+ x
+ (if in-template? " in template: " " in pattern: ")
+ pat/tmpl))
+
+ (define (multi-ellipsis-error x)
+ (bad-ellipsis x "List or vector pattern with multiple ellipses"))
+
+ (define (ellipsis/tail-error x)
+ (bad-ellipsis x "Improper list pattern with an ellipsis"))
+
+ (define (ellipsis-follows x thing)
+ (bad-ellipsis x (string-append "Ellipsis following " thing)))
+
+ (let ((x (if in-template? pat/tmpl (cdr pat/tmpl))))
+ (if in-template?
+ (if (ellipsis? x)
+ (ellipsis-follows x "nothing"))
+ (cond ((ellipsis? x)
+ (ellipsis-follows pat/tmpl "a '.'"))
+ ((ellipsis-pair? x)
+ (ellipsis-follows pat/tmpl "the pattern keyword"))))
+ (let check ((x x))
+ (cond ((pair? x)
+ (if (ellipsis? (car x)) (ellipsis-follows x "a '('"))
+ (check (car x))
+ (if (ellipsis? (cdr x)) (ellipsis-follows x "a '.'"))
+ (if (ellipsis-pair? (cdr x))
+ (cond ((ellipsis? (cddr x))
+ (ellipsis-follows (cdr x) "a '.'"))
+ ((ellipsis-pair? (cddr x))
+ (ellipsis-follows (cdr x) "an ellipsis"))
+ (in-template? (check (cddr x)))
+ (else (or (list? x) (ellipsis/tail-error x))
+ (for-each (lambda (y)
+ (if (ellipsis? y)
+ (multi-ellipsis-error x))
+ (check y))
+ (cddr x))))
+
+ (check (cdr x))))
+ ((svector? x)
+ (let ((elts (svector->list x)))
+ (if (ellipsis-pair? elts)
+ (ellipsis-follows x "a '#('")
+ (check elts))))))))
+
+ ;; Returns an alist: ((pat-var . depth) ...)
+ (define (make-pat-env pat)
+ (let collect ((x (cdr pat)) (depth 0) (l '()))
+ (cond ((sid? x)
+ (let ((id (sid-id x)))
+ (cond ((memv id pat-literals) l)
+ ((assv id l)
+ (expand-error "Duplicate pattern var: " x
+ " in pattern: " pat))
+ (else (acons id depth l)))))
+ ((vector? x) (collect (svector->list x) depth l))
+ ((pair? x)
+ (if (ellipsis-pair? (cdr x))
+ (collect (car x) (+ 1 depth) (collect (cddr x) depth l))
+ (collect (car x) depth (collect (cdr x) depth l))))
+ (else l))))
+
+ ;; Checks var depths.
+ (define (check-var-depths tmpl pat-env)
+ (define (depth-error x)
+ (expand-error "Pattern var used at bad depth: " x " in template: " tmpl))
+ (define (close-error x)
+ (expand-error "Template ellipsis closes no variables: " x
+ " in template: " tmpl))
+ ;; collect returns #t if any vars occurred at DEPTH
+ (let collect ((x tmpl) (depth 0))
+ (cond ((sid? x)
+ (let ((p (assv (sid-id x) pat-env)))
+ (and p
+ (let* ((pat-depth (cdr p))
+ (same-depth? (= depth pat-depth)))
+ (if (and (positive? pat-depth) (not same-depth?))
+ (depth-error x))
+ same-depth?))))
+ ((vector? x) (collect (svector->list x) depth))
+ ((pair? x)
+ (let* ((ellip? (ellipsis-pair? (cdr x)))
+ (car-closed? (collect (car x)
+ (if ellip? (+ 1 depth) depth)))
+ (cdr-closed? (collect ((if ellip? cddr cdr) x)
+ depth)))
+ (and ellip? (not car-closed?) (close-error x))
+ (or car-closed? cdr-closed?)))
+ (else #f))))
+
+
+ ;; Checks rule and returns a list of the template literal ids.
+ (define (check-rule rule)
+ (or (list2? rule) (expand-error "Malformed syntax rule: " rule))
+ (let ((pat (car rule)) (tmpl (cadr rule)))
+ (or (and (pair? pat) (sid? (car pat)))
+ (expand-error "Malformed pattern: " pat))
+ (check-ellipses pat #f)
+ (check-ellipses tmpl #t)
+ (let ((pat-env (make-pat-env pat)))
+ (check-var-depths tmpl pat-env)
+ (let collect ((x tmpl) (lits '()))
+ (cond ((ellipsis? x) lits)
+ ((sid? x) (if (assv (sid-id x) pat-env)
+ lits
+ (cons (sid-id x) lits)))
+ ((vector? x) (collect (svector->list x) lits))
+ ((pair? x) (collect (car x) (collect (cdr x) lits)))
+ (else lits))))))
+
+ ;; Reduce-env: this optional hack cuts down on the clutter when
+ ;; manually examining the store. Returns an environment with only
+ ;; the bindings we need: those of pattern or template literals,
+ ;; and those of identifiers named "..." that prevent a "..." from
+ ;; being treated as an ellipsis, e.g. in
+ ;; (let ((... 1)) ((syntax-rules () ((_) ...)))) => 1.
+ (define (reduce-env lits)
+ (define (list-dots-ids x ids)
+ (cond ((sid? x) (if (eq? '... (sid-location x))
+ (cons (sid-id x) ids)
+ ids))
+ ((vector? x) (list-dots-ids (svector->list x) ids))
+ ((pair? x) (list-dots-ids (car x) (list-dots-ids (cdr x) ids)))
+ (else ids)))
+ (let loop ((ids (if ellipsis-id lits (list-dots-ids rules lits)))
+ (reduced-env empty-env))
+ (if (null? ids)
+ reduced-env
+ (loop (cdr ids)
+ (let ((id (car ids)))
+ (cond ((and (not (assv id reduced-env)) (assv id env))
+ => (lambda (binding) (cons binding reduced-env)))
+ (else reduced-env)))))))
+
+ (let* ((lits (apply append pat-literals (map check-rule rules)))
+ (env (reduce-env lits)))
+ (make-transformer synrules env))))
+
+
+;; returns (k sexp id-n)
+(define (apply-transformer transformer sexp id-n env k)
+ (let* ((synrules (transformer-synrules transformer))
+ (mac-env (transformer-env transformer))
+ (ellipsis-id (and (sid? (cadr synrules))
+ (sid-id (cadr synrules))))
+ (rest (if ellipsis-id (cddr synrules) (cdr synrules)))
+ (pat-literals (map sid-id (car rest)))
+ (rules (cdr rest)))
+
+ (define (pat-literal? id) (memv id pat-literals))
+ (define (not-pat-literal? id) (not (pat-literal? id)))
+ (define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x))))
+ (define (ellipsis? x)
+ (and (sid? x)
+ (if ellipsis-id
+ (eqv? ellipsis-id (sid-id x))
+ (eq? '... (lookup-sid x mac-env)))))
+
+ ;; List-ids returns a list of the non-ellipsis ids in a
+ ;; pattern or template for which (pred? id) is true. If
+ ;; include-scalars is false, we only include ids that are
+ ;; within the scope of at least one ellipsis.
+ (define (list-ids x include-scalars pred?)
+ (let collect ((x x) (inc include-scalars) (l '()))
+ (cond ((sid? x) (let ((id (sid-id x)))
+ (if (and inc (pred? id)) (cons id l) l)))
+ ((vector? x) (collect (svector->list x) inc l))
+ ((pair? x)
+ (if (ellipsis-pair? (cdr x))
+ (collect (car x) #t (collect (cddr x) inc l))
+ (collect (car x) inc (collect (cdr x) inc l))))
+ (else l))))
+
+
+ (define (matches? pat)
+ (let match ((pat pat) (sexp (cdr sexp)))
+ (cond ((sid? pat)
+ (or (not (pat-literal? (sid-id pat)))
+ (and (sid? sexp)
+ (eqv? (lookup-sid pat mac-env)
+ (lookup-sid sexp env)))))
+ ((svector? pat)
+ (and (svector? sexp)
+ (match (svector->list pat) (svector->list sexp))))
+ ((not (pair? pat)) (equal? pat sexp))
+ ((ellipsis-pair? (cdr pat))
+ (let skip ((p (cddr pat)) (s sexp))
+ (if (pair? p)
+ (and (pair? s) (skip (cdr p) (cdr s)))
+ (let match-cars ((sexp sexp) (s s))
+ (if (pair? s)
+ (and (match (car pat) (car sexp))
+ (match-cars (cdr sexp) (cdr s)))
+ (match (cddr pat) sexp))))))
+ (else (and (pair? sexp)
+ (match (car pat) (car sexp))
+ (match (cdr pat) (cdr sexp)))))))
+
+ ;; Returns an alist binding pattern variables to parts of the input.
+ ;; An ellipsis variable is bound to a list (or a list of lists, etc.).
+ (define (make-bindings pat)
+ (let collect ((pat pat) (sexp (cdr sexp)) (bindings '()))
+ (cond ((and (sid? pat) (not (pat-literal? (sid-id pat))))
+ (acons (sid-id pat) sexp bindings))
+ ((svector? pat)
+ (collect (svector->list pat) (svector->list sexp) bindings))
+ ((not (pair? pat)) bindings)
+ ((ellipsis-pair? (cdr pat))
+ (let* ((tail-len (length (cddr pat)))
+ (tail (list-tail sexp (- (length sexp) tail-len)))
+ (matches (reverse (list-tail (reverse sexp) tail-len)))
+ (vars (list-ids (car pat) #t not-pat-literal?)))
+ (define (collect1 match)
+ (map cdr (collect (car pat) match '())))
+ (append (apply map list vars (map collect1 matches))
+ (collect (cddr pat) tail bindings))))
+ (else (collect (car pat) (car sexp)
+ (collect (cdr pat) (cdr sexp) bindings))))))
+
+ ;; Remove duplicates from a list, using eqv?.
+ (define (remove-dups l)
+ (let loop ((l l) (result '()))
+ (if (null? l)
+ result
+ (loop (cdr l)
+ (let ((elt (car l)))
+ (if (memv elt result) result (cons elt result)))))))
+
+ (define (expand-template pat tmpl top-bindings)
+ (define tmpl-literals
+ (remove-dups (list-ids tmpl #t
+ (lambda (id) (not (assv id top-bindings))))))
+ (define ellipsis-vars (list-ids pat #f not-pat-literal?))
+ (define (list-ellipsis-vars subtmpl)
+ (list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
+ (define (expand tmpl bindings)
+ (let expand-part ((tmpl tmpl))
+ (cond
+ ((sid? tmpl)
+ (let ((id (sid-id tmpl)))
+ (cond ((assv id bindings) => cdr)
+ ((assv id top-bindings) => cdr)
+ (else
+ (let ((index (+ -1 (length (memv id tmpl-literals))))
+ (location (lookup-sid tmpl mac-env)))
+ (make-sid (sid-name tmpl) (+ id-n index) location))))))
+ ((vector? tmpl)
+ (list->svector (expand-part (svector->list tmpl))))
+ ((pair? tmpl)
+ (if (ellipsis-pair? (cdr tmpl))
+ (let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
+ (define (lookup var) (cdr (assv var bindings)))
+ (define (expand-using-vals . vals)
+ (expand (car tmpl) (map cons vars-to-iterate vals)))
+ (let ((val-lists (map lookup vars-to-iterate)))
+ (if (or (null? (cdr val-lists))
+ (apply = (map length val-lists)))
+ (append (apply map expand-using-vals val-lists)
+ (expand-part (cddr tmpl)))
+ (expand-error "Unequal sequence lengths for pattern vars: "
+ vars-to-iterate " in macro call: " sexp))))
+ (cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
+ (else tmpl))))
+ (k (expand tmpl top-bindings) (+ id-n (length tmpl-literals))))
+
+ (let loop ((rules rules))
+ (if (null? rules)
+ (expand-error "No matching rule for macro use: " sexp)
+ (let* ((rule (car rules)) (pat (cdar rule)) (tmpl (cadr rule)))
+ (if (matches? pat)
+ (expand-template pat tmpl (make-bindings pat))
+ (loop (cdr rules))))))))
+
+(define builtins-store
+ (let loop ((bs '(begin define define-syntax if lambda quote set! delay
+ let-syntax syntax-rules))
+ (store empty-store))
+ (if (null? bs)
+ store
+ (loop (cdr bs)
+ (extend-store store (car bs) (make-builtin (car bs)))))))
+
+;; null-prog is the preamble that defines all the standard macros that
+;; are in the null-store. (The "null-" name prefix was chosen to
+;; correspond to the name of r5rs's null-environment procedure, even
+;; though the null-store is far from empty.)
+(define null-prog
+ '((define-syntax letrec-syntax
+ (let-syntax ((let-syntax let-syntax) (define-syntax define-syntax))
+ (syntax-rules ()
+ ((_ ((kw init) ...) . body)
+ (let-syntax ()
+ (define-syntax kw init) ... (let-syntax () . body))))))
+ (let-syntax ()
+ (define-syntax multi-define
+ (syntax-rules ()
+ ((_ definer (id ...) (init ...))
+ (begin (definer id init) ...))))
+ ;; Define-protected-macros defines a set of macros with a
+ ;; private set of bindings for some keywords and variables. If
+ ;; any of the keywords or variables are later redefined at
+ ;; top-level, the macros will continue to work. The first
+ ;; argument to define-protected-macros is let-syntax or
+ ;; letrec-syntax; if it is letrec-syntax, then the macros will
+ ;; also have a private set of bindings for one another, and
+ ;; recursive calls made by the macros to themselves or to one
+ ;; another will not be affected by later top-level
+ ;; redefinitions.
+ ;;
+ ;; The private binding for a saved variable is created by a
+ ;; let-syntax, using a dummy syntax as the initializer. We
+ ;; later assign a value to it using a top-level define (and thus
+ ;; change the status of the binding from keyword to variable).
+ (define-syntax dummy (syntax-rules ()))
+ (define-syntax define-protected-macros
+ (syntax-rules (define-syntax)
+ ((_ let/letrec-syntax (saved-kw ...) (saved-var ...)
+ (define-syntax kw syntax) ...)
+ ((let-syntax ((saved-kw saved-kw) ... (saved-var dummy) ...)
+ (let/letrec-syntax ((kw syntax) ...)
+ (syntax-rules ()
+ ((_ top-level-kws top-level-vars)
+ (begin
+ (multi-define define (saved-var ...) top-level-vars)
+ (multi-define define-syntax top-level-kws (kw ...)))))))
+ (kw ...) (saved-var ...)))))
+ (begin
+ ;; Prototype-style define and lambda with internal definitions
+ ;; are implemented in define-protected-macros with let-syntax
+ ;; scope so that they can access the builtin define and lambda.
+ (define-protected-macros let-syntax (lambda define let-syntax) ()
+ (define-syntax lambda
+ (syntax-rules ()
+ ((lambda args . body)
+ (lambda args (let-syntax () . body)))))
+ (define-syntax define
+ (syntax-rules ()
+ ((_ expr) (define expr))
+ ((_ (var . args) . body)
+ (define var (lambda args (let-syntax () . body))))
+ ((_ var init) (define var init))))
+ (define-syntax letrec
+ (syntax-rules ()
+ ((_ ((var init) ...) . body)
+ (let () (define var init) ... (let () . body))))) )
+ (define-protected-macros letrec-syntax
+ (if lambda quote begin define letrec) ()
+ (define-syntax let
+ (syntax-rules ()
+ ((_ ((var init) ...) . body)
+ ((lambda (var ...) . body)
+ init ...))
+ ((_ name ((var init) ...) . body)
+ ((letrec ((name (lambda (var ...) . body)))
+ name)
+ init ...))))
+ (define-syntax let*
+ (syntax-rules ()
+ ((_ () . body) (let () . body))
+ ((let* ((var init) . bindings) . body)
+ (let ((var init)) (let* bindings . body)))))
+ (define-syntax do
+ (let-syntax ((do-step (syntax-rules () ((_ x) x) ((_ x y) y))))
+ (syntax-rules ()
+ ((_ ((var init step ...) ...)
+ (test expr ...)
+ command ...)
+ (let loop ((var init) ...)
+ (if test
+ (begin #f expr ...)
+ (let () command ...
+ (loop (do-step var step ...) ...))))))))
+ (define-syntax case
+ (letrec-syntax
+ ((compare
+ (syntax-rules ()
+ ((_ key ()) #f)
+ ((_ key (datum . data))
+ (if (eqv? key 'datum) #t (compare key data)))))
+ (case
+ (syntax-rules (else)
+ ((case key) #f)
+ ((case key (else result1 . results))
+ (begin result1 . results))
+ ((case key ((datum ...) result1 . results) . clauses)
+ (if (compare key (datum ...))
+ (begin result1 . results)
+ (case key . clauses))))))
+ (syntax-rules ()
+ ((_ expr clause1 clause ...)
+ (let ((key expr))
+ (case key clause1 clause ...))))))
+ (define-syntax cond
+ (syntax-rules (else =>)
+ ((_) #f)
+ ((_ (else . exps)) (let () (begin . exps)))
+ ((_ (x) . rest) (or x (cond . rest)))
+ ((_ (x => proc) . rest)
+ (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
+ ((_ (generator guard => receiver) . rest)
+ (let ((tmp generator))
+ (cond ((guard tmp) (receiver tmp))
+ . rest) ) )
+ ((_ (x . exps) . rest)
+ (if x (begin . exps) (cond . rest)))))
+ (define-syntax and
+ (syntax-rules ()
+ ((_) #t)
+ ((_ test) (let () test))
+ ((_ test . tests) (if test (and . tests) #f))))
+ (define-syntax or
+ (syntax-rules ()
+ ((_) #f)
+ ((_ test) (let () test))
+ ((_ test . tests) (let ((x test)) (if x x (or . tests))))))
+ (define-syntax delay
+ (syntax-rules ()
+ ((_ expr) (%make-promise (lambda () expr))))))
+ ;; Quasiquote uses let-syntax scope so that it can recognize
+ ;; nested uses of itself using a syntax-rules literal (that
+ ;; is, the quasiquote binding that is visible in the
+ ;; environment of the quasiquote transformer must be the same
+ ;; binding that is visible where quasiquote is used).
+ (define-protected-macros let-syntax
+ (lambda quote let) ()
+ (define-syntax quasiquote
+ (let-syntax
+ ((tail-preserving-syntax-rules
+ (syntax-rules ()
+ ((_ literals
+ ((subpattern ...) (subtemplate ...))
+ ...)
+ (syntax-rules literals
+ ((subpattern ... . tail) (subtemplate ... . tail))
+ ...)))))
+
+ (define-syntax qq
+ (tail-preserving-syntax-rules
+ (unquote unquote-splicing quasiquote)
+ ((_ ,x ()) (do-next x))
+ ((_ (,@x . y) ()) (qq y () make-splice x))
+ ((_ `x depth) (qq x (depth) make-list 'quasiquote))
+ ((_ ,x (depth)) (qq x depth make-list 'unquote))
+ ((_ (,x . y) (depth)) (qq-nested-unquote (,x . y) (depth)))
+ ((_ (,@x . y) (depth)) (qq-nested-unquote (,@x . y) (depth)))
+ ((_ ,@x depth) (unquote-splicing-error ,@x))
+ ((_ (x . y) depth) (qq x depth qq-cdr y depth make-pair))
+ ((_ #(x y ...) depth) (qq (x) depth qq-cdr #(y ...) depth
+ make-vector-splice))
+ ((_ x depth) (do-next 'x))))
+
+ (define-syntax do-next
+ (syntax-rules ()
+ ((_ expr original-template) expr)
+ ((_ expr next-macro . tail) (next-macro expr . tail))))
+
+ (define-syntax unquote-splicing-error
+ (syntax-rules ()
+ ((_ ,@x stack ... original-template)
+ (unquote-splicing-error (,@x in original-template)))))
+
+ (define-syntax qq-cdr
+ (tail-preserving-syntax-rules ()
+ ((_ car cdr depth combiner) (qq cdr depth combiner car))))
+
+ (define-syntax qq-nested-unquote
+ (tail-preserving-syntax-rules ()
+ ((_ ((sym x) . y) (depth))
+ (qq (x) depth make-map sym qq-cdr y (depth) make-splice))))
+
+ (define-syntax make-map
+ (tail-preserving-syntax-rules (quote list map lambda)
+ ((_ '(x) sym) (do-next '((sym x))))
+ ((_ (list x) sym) (do-next (list (list 'sym x))))
+ ((_ (map (lambda (x) y) z) sym)
+ (do-next (map (lambda (x) (list 'sym y)) z)))
+ ((_ expr sym)
+ (do-next (map (lambda (x) (list 'sym x)) expr)))))
+
+ (define-syntax make-pair
+ (tail-preserving-syntax-rules (quote list)
+ ((_ 'y 'x) (do-next '(x . y)))
+ ((_ '() x) (do-next (list x)))
+ ((_ (list . elts) x) (do-next (list x . elts)))
+ ((_ y x) (do-next (cons x y)))))
+
+ (define-syntax make-list
+ (tail-preserving-syntax-rules (quote)
+ ((_ y x) (make-pair '() y make-pair x))))
+
+ (define-syntax make-splice
+ (tail-preserving-syntax-rules ()
+ ((_ '() x) (do-next x))
+ ((_ y x) (do-next (append x y)))))
+
+ (define-syntax make-vector-splice
+ (tail-preserving-syntax-rules (quote list vector list->vector)
+ ((_ '#(y ...) '(x)) (do-next '#(x y ...)))
+ ((_ '#(y ...) (list x)) (do-next (vector x 'y ...)))
+ ((_ '#() x) (do-next (list->vector x)))
+ ((_ '#(y ...) x) (do-next (list->vector
+ (append x '(y ...)))))
+ ((_ y '(x)) (make-vector-splice y (list 'x)))
+ ((_ (vector y ...) (list x)) (do-next (vector x y ...)))
+ ((_ (vector y ...) x) (do-next (list->vector
+ (append x (list y ...)))))
+ ((_ (list->vector y) (list x)) (do-next (list->vector
+ (cons x y))))
+ ((_ (list->vector y) x) (do-next (list->vector
+ (append x y))))))
+
+ (syntax-rules ()
+ ((_ template) (let () (qq template () template)))))))
+ ))))
+
+(define null-stuff (expand-top-level-forms null-prog builtins-store 0 list))
+(define null-store (cadr null-stuff))
+(define null-loc-n (caddr null-stuff))
+
+;; an mstore is a mutable store.
+(define (null-mstore) (cons null-store null-loc-n))
+
+(define (expand-top-level-forms! forms mstore)
+ (expand-top-level-forms forms (car mstore) (cdr mstore)
+ (lambda (outputs store loc-n)
+ (set-car! mstore store)
+ (set-cdr! mstore loc-n)
+ outputs)))
+
+(define (expand-error . args)
+ (let ((msg (with-output-to-string
+ (lambda ()
+ (for-each display args)))))
+ (expand-error-hook msg)))
+
+(lambda (exp err store dbg)
+ (unless store
+ (set! store (null-mstore)))
+ (fluid-let ((expand-error-hook err)
+ (debug-syntax dbg))
+ (let ((forms (expand-top-level-forms! (list exp) store)))
+ (cons `(begin ,@forms) store))))
+
+))
diff --git a/spock-0.2/honu.scm b/spock-0.2/honu.scm
@@ -0,0 +1,175 @@
+;;; honu.scm - "honu"-syntax reader
+
+
+(define read-honu
+ (let ((comma (string->symbol ","))
+ (semicolon (string->symbol ";"))
+ (operator-chars
+ '(#\- #\+ #\/ #\? #\: #\* #\% #\& #\! #\. #\~ #\_ #\| #\> #\< #\= #\^) ))
+ (define (read-token pred . port)
+ (let* ((port (optional port (current-input-port)))
+ (out (open-output-string)))
+ (let loop ()
+ (let ([c (peek-char port)])
+ (cond ((and (not (eof-object? c)) (pred c))
+ (write-char (read-char port) out)
+ (loop) )
+ (else (get-output-string out) ) ) ) ) ) )
+ (define (read-line . port)
+ (let ((in (optional port (current-input-port))))
+ (let loop ((chars '()))
+ (let ((c (read-char in)))
+ (cond ((or (eof-object? c) (char=? #\newline c))
+ (list->string (reverse chars)))
+ (else (loop (cons c chars))))))))
+ (define (reverse-list->string lst)
+ (list->string (reverse lst)))
+ (lambda port
+ (let ((port (optional port (current-input-port))))
+ (define (err msg . args)
+ (apply error 'read-honu msg args))
+ (define (opchar? c) (memv c operator-chars))
+ (define (skip)
+ (let ((c (peek-char port)))
+ (cond ((eof-object? c) c)
+ ((char-whitespace? c)
+ (read-char port)
+ (skip) )
+ ((char=? #\/ c)
+ (read-char port)
+ (let ((c (peek-char port)))
+ (case c
+ ((#\/)
+ (read-line port)
+ (skip) )
+ ((#\*) (skip-comment) (skip))
+ (else
+ (if (opchar? c)
+ (let ((s (read-token opchar? port)))
+ (string->symbol (string-append "/" s) ) )
+ '/) ) ) ) )
+ (else #f) ) ) )
+ (define (scan)
+ (or (skip)
+ (let ((c (peek-char port)))
+ (if (eof-object? c)
+ (err "unexpected end of input")
+ (case c
+ ((#\#)
+ (read-char port)
+ (let ((c (peek-char port)))
+ (case c
+ ((#\;)
+ (read-char port)
+ (let* ((x1 (scan))
+ (x2 (scan)) )
+ (if x1
+ x2
+ (scan) ) ) )
+ (else
+ (let ((t (read-token char-alphabetic? port)))
+ (cond ((string=? "hx" t) (scan))
+ ((string=? "sx" t) (read port))
+ (else (err "invalid escape syntax" t)) ) ) ) ) ) )
+ ((#\')
+ (read-char port)
+ (let ((s (read-escaped (lambda (c) (char=? #\' c)))))
+ (if (zero? (string-length s))
+ (err "empty character literal")
+ (string-ref s 0) ) ) )
+ ((#\,) (read-char port) comma)
+ ((#\;) (read-char port) semicolon)
+ ((#\") (read-char port) (read-escaped (lambda (c) (char=? #\" c))))
+ ((#\() (read-char port) (read-sequence '%parens #\)))
+ ((#\[) (read-char port) (read-sequence '%brackets #\]))
+ ((#\{) (read-char port) (read-sequence '%braces #\}))
+ ((#\) #\] #\}) (err "unexpected closing delimiter" c))
+ (else
+ (cond ((char-numeric? c) (read-num))
+ ((or (char-alphabetic? c)
+ (char=? c #\_)
+ (char=? c #\$))
+ (string->symbol
+ (read-token
+ (lambda (c)
+ (or (char-alphabetic? c)
+ (char-numeric? c)
+ (char=? #\_ c)
+ (char=? #\$ c)))
+ port) ) )
+ ((opchar? c) (string->symbol (read-token opchar? port)))
+ (else (err "invalid character" c)) ) ) ) ) ) ) )
+ (define (read-num)
+ (string->number
+ (let ((e #f)
+ (d #f))
+ (let loop ((lst '()))
+ (let ((c (peek-char port)))
+ (if (eof-object? c)
+ (reverse-list->string lst)
+ (case c
+ ((#\e #\E)
+ (cond (e (reverse-list->string lst))
+ (else
+ (set! e #t)
+ (read-char port)
+ (case (peek-char port)
+ ((#\+ #\-) (loop (cons (read-char port) lst)))
+ (else (reverse-list->string lst)) ) ) ) )
+ ((#\.)
+ (cond (d (reverse-list->string lst))
+ (else
+ (set! d #t)
+ (loop (cons (read-char port) lst)))))
+ (else
+ (if (char-numeric? c)
+ (loop (cons (read-char port) lst))
+ (reverse-list->string lst) ) ) ) ) ) ) ) ) )
+ (define (read-escaped pred)
+ (with-input-from-string
+ (with-output-to-string
+ (lambda ()
+ (write-char #\")
+ (let loop ()
+ (let ((c (read-char port)))
+ (cond ((eof-object? c) (err "unexpected end of character sequence"))
+ ((pred c))
+ ((char=? #\\ c)
+ (write-char #\\)
+ (write-char (read-char port))
+ (loop) )
+ (else
+ (write-char c)
+ (loop) ) ) ) )
+ (write-char #\") ) )
+ read))
+ (define (skip-comment)
+ (let ((c (read-char port)))
+ (if (eof-object? c)
+ (err "unexpected end of comment")
+ (case c
+ ((#\*)
+ (let loop ()
+ (case (read-char port)
+ ((#\*) (loop))
+ ((#\/) #f)
+ (else (skip-comment)) ) ))
+ ((#\/)
+ (case (read-char port)
+ ((#\*) (skip-comment) (skip-comment))
+ (else (skip-comment)) ) )
+ (else (skip-comment)) ) ) ) )
+ (define (read-sequence tok del)
+ (cons
+ tok
+ (let loop ((lst '()))
+ (let ((s (skip)))
+ (if (and s (not (eof-object? s)))
+ (loop (cons s lst))
+ (let ((c (peek-char port)))
+ (cond ((eof-object? c) (err "unexpected end of sequence"))
+ ((char=? del c)
+ (read-char port)
+ (reverse lst) )
+ (else (loop (cons (scan) lst))) ) ) ) ) ) ) )
+ (scan) ))))
diff --git a/spock-0.2/misc.scm b/spock-0.2/misc.scm
@@ -0,0 +1,165 @@
+;;;; misc.scm - miscellaneous utility functions
+
+
+(define temp
+ (let ((count 1))
+ (lambda prefix
+ (let ((i count))
+ (set! count (+ count 1))
+ (string->symbol
+ (string-append
+ (if (pair? prefix)
+ (car prefix)
+ "t")
+ (number->string i)))))))
+
+(define (dribble . args)
+ (for-each
+ (cut display <> (current-error-port))
+ args)
+ (newline (current-error-port)))
+
+(define (read-forms file-or-port)
+ ((if (string? file-or-port)
+ call-with-input-file
+ (lambda (fp p) (p fp)))
+ file-or-port
+ (lambda (port)
+ (let loop ((xs '()))
+ (let ((x (read port)))
+ (if (eof-object? x)
+ `(begin ,@(reverse xs))
+ (loop (cons x xs))))))))
+
+(define (copy-file-data file)
+ (with-input-from-file file
+ (lambda ()
+ (let loop ()
+ (let ((c (read-char)))
+ (unless (eof-object? c)
+ (write-char c)
+ (loop)))))))
+
+(define (emit . xs)
+ (for-each display xs))
+
+(define (emit-list xs)
+ (match xs
+ (() #f)
+ ((x) (emit x))
+ ((x1 xs ...)
+ (emit x1)
+ (for-each (lambda (x) (emit ", " x)) xs))))
+
+(define (stringify x)
+ (cond ((symbol? x) (symbol->string x))
+ ((string? x) x)
+ (else (error "can't stringify" x))))
+
+(define (symbolify x)
+ (cond ((symbol? x) x)
+ ((string? x) (string->symbol x))
+ (else (error "can't symbolify" x))))
+
+(define (join xs sep)
+ (apply
+ string-append
+ (let loop ((xs xs))
+ (cond ((null? xs) '())
+ ((null? (cdr xs)) xs)
+ (else (cons (car xs) (cons sep (loop (cdr xs)))))))))
+
+(define (fail msg . arg)
+ (let ((out (current-error-port)))
+ (display "\nError: " out)
+ (display msg out)
+ (cond ((pair? arg)
+ (display ":\n\n" out)
+ (pp (car arg) out))
+ (else (newline out)))
+ (exit 1)))
+
+(define (symbol<? s1 s2)
+ (string<? (symbol->string s1) (symbol->string s2)))
+
+(define (butlast lst)
+ (let loop ((lst lst))
+ (if (null? (cdr lst))
+ '()
+ (cons (car lst) (loop (cdr lst))))))
+
+(define (last lst)
+ (let loop ((lst lst))
+ (if (null? (cdr lst))
+ (car lst)
+ (loop (cdr lst)))))
+
+(define (test-option opt state)
+ (cond ((assq opt state) => cdr)
+ (else #f)))
+
+(define (identifier id)
+ (let* ((str (stringify id))
+ (out (open-output-string))
+ (n (string-length str)))
+ (display "___" out)
+ (do ((i 0 (+ i 1)))
+ ((>= i n) (get-output-string out))
+ (let ((c (string-ref str i)))
+ (if (and (not (char-lower-case? c))
+ (or (not (char-numeric? c)) (= i 0)))
+ (let ((i (char->integer c)))
+ (write-char #\_ out)
+ (when (< i 16) (write-char #\0 out))
+ (display (number->string i 16) out))
+ (write-char c out))))))
+
+(define (read-library state name . reader)
+ (let loop ((lpath (test-option 'library-path state)))
+ (if (null? lpath)
+ ((or (test-option 'fail state) fail)
+ "library not found" name)
+ (let ((lib (file-exists? (string-append (car lpath) "/" name))))
+ (cond (lib
+ (when (test-option 'verbose state)
+ (dribble "reading library " lib))
+ ((if (pair? reader) (car reader) read-forms) lib))
+ (else (loop (cdr lpath))))))))
+
+(define (parse-llist llist)
+ (let loop ((ll llist) (vars '()))
+ (match ll
+ (() (list (reverse vars) #f))
+ ((? symbol?) (list (reverse (cons ll vars)) ll))
+ (((? symbol? v) . more)
+ (loop more (cons v vars)))
+ (_ (fail "bad lambda list" llist)))))
+
+(define (string-find-char c str)
+ (let ((len (string-length str)))
+ (let loop ((i 0))
+ (and (< i len)
+ (or (char=? c (string-ref str i))
+ (loop (+ i 1)))))))
+
+(define (note loc state x . args)
+ (when (or (not state) (test-option 'verbose state))
+ (apply
+ dribble
+ (append
+ (if loc
+ `("(" ,loc ") ")
+ '())
+ args)))
+ x)
+
+(define (read-contents filename)
+ (with-input-from-file filename
+ (lambda ()
+ (with-output-to-string
+ (lambda ()
+ (let loop ()
+ (let ((c (read-char)))
+ (unless (eof-object? c)
+ (write-char c)
+ (loop)))))))))
diff --git a/spock-0.2/opt.scm b/spock-0.2/opt.scm
@@ -0,0 +1,290 @@
+;;;; opt.scm - optimizer
+
+
+(define (optimize form state)
+ (let-syntax ((result
+ (syntax-rules ()
+ ((_ (a b c) x body ...)
+ (match-let ((#(a b c) x)) body ...)))))
+ (let ((debug (test-option 'debug state))
+ (block (test-option 'block state))
+ (local-env #f))
+ ;; (walk FORM ENV DEST LOC) -> #(FORM' VALUE SIDEEFFECT?)
+ ;;
+ ;; ENV = ((<variable1> <value1> <used?>) ...)
+ ;; VALUE = '<const> | <variable> | #f | (%void)
+ (define (walk form e dest loc)
+ (define (return form val se?)
+ ;;(pp `(RETURN: ,form ,val ,se?))
+ (vector form val se?))
+ ;;(pp `(WALK: ,form))
+ (match form
+ ;; * propagate variable value, if known
+ ((? symbol?)
+ (let ((px (propagate form form #f)))
+ (cond ((and (symbol? px) (assq px e)) =>
+ (lambda (a) (set-car! (cddr a) #t)))) ; mark as used
+ (return
+ (if (eq? px form)
+ form
+ (note
+ loc state
+ px
+ (string-append
+ "replaced reference to `" (symbol->string form) "' with: ")
+ px))
+ form #f)))
+ ;; * "straighten" `let' forms
+ ;;
+ ;;XXX disabled, because it results in too deeply nested
+ ;; functions (r4rstest.scm), even for v8
+;; (('let ((v1 ('let ((v2 x)) z))) y)
+;; (walk `(let ((,v2 ,x)) ; alpha-conversion should make this safe
+;; (let ((,v1 ,z)) ,y))
+;; e dest loc))
+ ;; * remove side-effect free unused bindings
+ (('let (('%unused x)) y)
+ (result
+ (x2 vx se) (walk x e #f loc)
+ (if se
+ (result
+ (y2 yv yse) (walk y e dest loc)
+ (return
+ `(let ((%unused ,x2))
+ ,y2)
+ yv #t))
+ (note
+ loc state
+ (walk y e dest loc)
+ "removed side-effect free expression: " x2))))
+ ;; * remove unused bindings
+ (('let ((v x)) y)
+ (result
+ (x2 xv xse) (walk x e v loc)
+ (let ((b (list v xv #f)))
+ (fluid-let ((local-env (cons b local-env)))
+ (result
+ (y2 yv yse) (walk y (cons b e) dest loc)
+ (return
+ (cond ((caddr b) ; variable used?
+ `(let ((,v ,x2))
+ ,y2))
+ (xse ; unused, but bound value has side-effect?
+ `(let ((%unused ,x2))
+ ,y2))
+ (else
+ (note loc state y2 "removed unused binding: " v)))
+ yv
+ (or xse yse)))))))
+ (('quote c) (return form form #f))
+ ;; * remove self-assignment
+ (('set! v x)
+ (result
+ (x2 xv _) (walk x e v loc)
+ (cond ((eq? v x2)
+ (note
+ loc state
+ (return '(%void) '(%void) #f)
+ "removing self-assignment: " v))
+ (else
+ (cond ((and xv (assq v local-env)) =>
+ (lambda (a) ; assign new value, if local
+ (set-car! (cddr a) #t) ; mark as used
+ (set-car! (cdr a) xv)))
+ ((assq v e) => ; otherwise invalidate
+ (lambda (a)
+ (set-car! (cddr a) #t)
+ (set-car! (cdr a) #f))))
+ (return `(set! ,v ,x2) '(%void) #t)))))
+ ;;
+ (('lambda llist body)
+ (match-let (((vars _) (parse-llist llist)))
+ (fluid-let ((local-env (map (cut list <> #f #f) vars)))
+ (result
+ (body2 _ _)
+ (walk body (append local-env e) #f dest)
+ (let ((form2 `(lambda ,llist ,body2)))
+ (return form2 #f #f))))))
+ ;;
+ (('%void) (return form form #f))
+ ;; * replace with constant, if argument known to be void or non-void
+ (('%void? x)
+ (result
+ (x2 xv se?) (walk x e #f loc)
+ (match xv
+ ('(%void)
+ (note
+ loc state
+ (return
+ (if se?
+ `(let ((%unused ,x2)) ''#t)
+ ''#t)
+ ''#t
+ se?)
+ "removed voidness-test (true)"))
+ (('quote _)
+ (note
+ loc state
+ (return
+ (if se?
+ `(let ((%unused ,x2)) ''#f)
+ ''#f)
+ ''#f
+ se?)
+ "removed voidness-test (false)"))
+ (_ (return `(%void? ,x2) #f se?)))))
+ ;; * "straighten" binding inside condition
+ (('if ('let binding x) . more)
+ (let ((t (temp)))
+ (walk
+ `(let ,binding
+ (let ((,t ,x))
+ (if ,t ,@more)))
+ e dest loc)))
+ ;; * replace side-effect free known condition and/or side-effect free branches
+ (('if x y z)
+ (result
+ (x2 xv xse) (walk x e #f loc)
+ (cond ((and (pair? xv) (eq? 'quote (car xv))) ; constant condition?
+ (let ((b (if (cadr xv) y z)))
+ (note
+ loc state
+ (if xse
+ (result ; execute condition, but ignore result
+ (b2 bv bse) (walk b e dest loc)
+ (return
+ `(let ((%unused ,x2)) ,b2)
+ b2 #t))
+ (note
+ loc state
+ (walk b e dest loc) ; drop alternative branch
+ "removed side-effect free conditional branch for: " x2))
+ "constant condition in conditional: " x2)))
+ (else
+ (result
+ (y2 yv yse) (walk y e dest loc)
+ (result
+ (z2 zv zse) (walk z e dest loc)
+ (return
+ `(if ,x2 ,y2 ,z2)
+ #f
+ (or xse yse zse))))))))
+ ;;
+ (('%host-ref _)
+ (return form #f debug))
+ ;;
+ (('%host-set! p x)
+ (result
+ (x2 xv xse) (walk x e p loc)
+ (return `(%host-set! ,p ,x2) #f #t)))
+ ;;
+ (('%property-ref _)
+ (return form #f debug))
+ ;;
+ (('%check type x)
+ ;;XXX remove unneeded `%check's (constant known value)
+ (result
+ (x2 xv xse) (walk x e dest loc)
+ (return `(%check ,type ,x2) #f (or xse debug))))
+ ;; ((%property-ref PARTS) X) ~> (%property-ref PARTS X)
+ ((('%property-ref parts) x)
+ (walk `(%property-ref ,parts ,x) e dest loc))
+ ;;
+ (('%property-ref parts x)
+ (result
+ (x2 xv xse) (walk x e dest loc)
+ (return `(%property-ref ,parts ,x2) #f (or xse debug))))
+ ;;
+ (('%property-set! p x y)
+ (result
+ (x2 _ xse) (walk x e #f loc)
+ (result
+ (y2 _ yse) (walk y e p loc)
+ (return `(%property-set! ,p ,x2 ,y2) #f #t))))
+ ;;
+ (('%code . code)
+ (return form #f #t))
+ ;;
+ (('%native-lambda . code)
+ (return form #f #f))
+ ;;
+ (('%inline name args ...)
+ (result
+ (xs _ _) (walk-many args e loc)
+ (return `(%inline ,name ,@xs) #f #t)))
+ ;;
+ (('%new args ...)
+ (result
+ (xs _ _) (walk-many args e loc)
+ (return `(%new ,@xs) #f #t)))
+ ;;
+ (('%global-ref _)
+ (return form #f debug))
+ ;; * remove global, if unused, if in block-mode and value has no side-effects
+ ;; * remove self-assignment
+ (('%global-set! v x)
+ (result
+ (x2 _ se) (walk x e v loc)
+ (cond ((eq? v x2)
+ (note
+ loc state
+ (return '(%void) '(%void) #f)
+ "removing global self-assignment: " v))
+ ((and block (not se)
+ (not (memq v referenced)))
+ (set! dropped (cons v dropped))
+ (note
+ loc state
+ (return '(%void) '(%void) #f)
+ "dropped unused global variable assignment: "
+ v))
+ (else
+ (return `(%global-set! ,v ,x2) '(%void) #t)))))
+ ;;
+ (('%loop llist body)
+ (result
+ (x2 xv xse) (walk body e dest loc)
+ (return `(%loop ,llist ,x2) xv xse)))
+ ;;
+ (('%continue . xs)
+ (result
+ (xs2 _ se) (walk-many xs e loc)
+ (return `(%continue ,@xs2) #f se))) ;XXX se?
+ ;;
+ ((op args ...)
+ (for-each (lambda (a) (set-car! (cdr a) #f)) e) ; invalidate all variables in env
+ (result
+ (xs2 _ se) (walk-many form e loc) ;XXX should we re-walk if op changed?
+ (return xs2 #f #t)))
+ (_ (error "opt: invalid form" form))))
+ (define (walk-many forms e loc)
+ (let loop ((forms forms) (xs '()) (vs '()) (se #f))
+ (if (null? forms)
+ (vector (reverse xs) (reverse vs) se)
+ (result
+ (x2 xv xse) (walk (car forms) e #f loc)
+ (loop (cdr forms)
+ (cons x2 xs)
+ (cons xv vs)
+ (or se xse))))))
+ ;; replace expression with known value, if possible and no side effects are caused
+ (define (propagate exp val se)
+ (if se
+ exp
+ (let loop ((val val))
+ (cond ((and (pair? val)
+ (or (and (eq? 'quote (car val))
+ ;; do not propagate complex constants
+ (not (pair? (cadr val)))
+ (not (vector? (cadr val))))
+ (eq? '%void (car val))))
+ val)
+ ((and (symbol? val) (assq val local-env)) =>
+ (lambda (a)
+ (if (cadr a)
+ (loop (cadr a))
+ val)))
+ (else exp)))))
+ (result
+ (form2 _ _) (walk form '() #f #f)
+ form2))))
diff --git a/spock-0.2/runtime.js b/spock-0.2/runtime.js
@@ -0,0 +1,626 @@
+/* runtime.js - SPOCK runtime (javascript part) */
+
+
+SPOCK.modules = {};
+SPOCK.symbolTable = {};
+SPOCK.stack = 0;
+SPOCK.limit = SPOCK.STACKSIZE;
+SPOCK.debug = false;
+SPOCK.running = false;
+SPOCK.runHook = [];
+SPOCK.inBrowser = "document" in this;
+SPOCK.global = this;
+
+SPOCK.Continuation = function(func, args) {
+ this.k_callee = func;
+ this.k_arguments = args;
+};
+
+SPOCK.Result = function(val) {
+ this.value = val;
+};
+
+SPOCK.Symbol = function(name) {
+ this.name = name;
+ this.plist = {};
+};
+
+SPOCK.Pair = function(car, cdr) {
+ this.car = car;
+ this.cdr = cdr;
+};
+
+SPOCK.String = function(chars) {
+ if(typeof chars === "string") {
+ this.parts = [chars];
+ this.length = chars.length;
+ }
+ else if(typeof chars === "number") this.parts = [chars.toString()];
+ else this.parts = chars; // assumes chars is array
+};
+
+SPOCK.Char = function(str) {
+ this.character = str.charAt(0);
+};
+
+SPOCK.Port = function(direction, methods) {
+ var port = this;
+ var read = methods.read || function() {
+ SPOCK.error("reading from non-input port", port);
+ };
+
+ function doread(n) {
+ if(n === 0) return "";
+ else if(this.peeked) {
+ var p = this.peeked;
+ this.peeked = false;
+
+ if(n === 1) return p;
+ else return p + read(n - 1);
+ }
+ else return read(n);
+ }
+
+ this.peeked = false;
+ this.direction = direction;
+ this.read = doread;
+ this.write = methods.write || function() {
+ SPOCK.error("writing to non-output port", port)
+ };
+ this.close = methods.close || function() {};
+ this.flush = methods.flush || function() {};
+ this.ready = methods.ready || function() { return true; };
+ this.closed = false;
+};
+
+SPOCK.Promise = function(thunk) {
+ this.thunk = thunk;
+};
+
+SPOCK.EndOfFile = function() {};
+SPOCK.EOF = new SPOCK.EndOfFile();
+
+SPOCK.check = function(val, type, loc) {
+ if(typeof type === "function" && val instanceof type) return val;
+ if(typeof val === type) return val;
+ else SPOCK.error((loc ? "(" + loc + ") " : "") +
+ "bad argument type" +
+ (typeof type === "string" ? " - expected `" + type + "'" : ""),
+ val);
+};
+
+SPOCK.intern = function(str) {
+ var old = SPOCK.symbolTable[ str ];
+
+ if(old) return old;
+ else return SPOCK.symbolTable[ str ] = new SPOCK.Symbol(str);
+};
+
+SPOCK.stringify = function(x, readable) {
+ if(readable === undefined) readable = true;
+
+ if(typeof x === "function") return "#<procedure>";
+ else if(x === undefined) return "#<undefined>";
+ else if(x === null) return "()";
+ else if(x instanceof SPOCK.Continuation) return "#<continuation>";
+ else if(x instanceof SPOCK.Symbol) return x.name;
+ else if(x instanceof SPOCK.Pair) {
+ var str = "(";
+ var f = false;
+
+ for(var p = x; p !== null && p instanceof SPOCK.Pair; p = p.cdr) {
+ if(f) str += " ";
+
+ str += SPOCK.stringify(p.car, readable);
+ f = true;
+ }
+
+ if(p !== null) str += " . " + SPOCK.stringify(p, readable);
+
+ return str + ")";
+ }
+ else if(x instanceof Array) {
+ var str = "#(";
+ var f = false;
+
+ for(var i in x) {
+ if(f) str += " ";
+
+ str += SPOCK.stringify(x[ i ], readable);
+ f = true;
+ }
+
+ return str + ")";
+ }
+ else if(x instanceof SPOCK.String) {
+ if(readable)
+ return "\"" + x.normalize() + "\""; // XXX does not escape embedded characters
+ else return x.normalize();
+ }
+ else if(x instanceof SPOCK.Char) {
+ if(readable) return x.character;
+
+ switch(x.character) {
+ case "\n": return "#\\newline";
+ case "\t": return "#\\tab";
+ case "\r": return "#\\return";
+ case " ": return "#\\space";
+ default: return "#\\" + x.character;
+ }
+ }
+ else if(x instanceof SPOCK.Port)
+ return "#<" + x.direction + " port" +
+ (x.name ? (" \"" + x.name + "\">") : ">");
+ else if(x instanceof SPOCK.Promise) return "#<promise>";
+ else if(x instanceof SPOCK.EndOfFile) return "#<eof>";
+ else return x.toString();
+};
+
+SPOCK.error = function(msg) {
+ var args = Array.prototype.splice.call(arguments, 1);
+
+ function argstr(x) {
+ return SPOCK.stringify(x, true);
+ }
+
+ if(args.length > 0)
+ msg = msg + ":\n " + SPOCK.map(argstr, args).join("\n ");
+
+ throw new Error(msg);
+};
+
+if(this.quit) SPOCK.exit = quit;
+else SPOCK.exit = function(code) {
+ SPOCK.error("no suitable primitive available for `exit'");
+ };
+
+SPOCK.String.prototype.normalize = function() {
+ if(this.parts.length === 0) return "";
+
+ this.parts = [this.parts.join("")];
+ return this.parts[ 0 ];
+};
+
+SPOCK.jstring = function(x) {
+ if(typeof x === "string") return x;
+ else if(x instanceof SPOCK.String) return x.normalize();
+ else return x;
+};
+
+SPOCK.list = function() {
+ var lst = null;
+ var len = arguments.length;
+
+ for(var i = len - 1; i >= 0; --i)
+ lst = new SPOCK.Pair(arguments[ i ], lst);
+
+ return lst;
+};
+
+SPOCK.length = function(lst) {
+ for(var n = 0; lst instanceof SPOCK.Pair; ++n)
+ lst = lst.cdr;
+
+ return n;
+};
+
+SPOCK.map = function(func, array) {
+ var len = array.length;
+ var a2 = new Array(len);
+
+ for(var i in array)
+ a2[ i ] = func(array[ i ]);
+
+ return a2;
+};
+
+SPOCK.eqvp = function(x, y) {
+ if(x === y) return true;
+ else if(x instanceof SPOCK.Char)
+ return y instanceof SPOCK.Char && x.character === y.character;
+ else return false;
+};
+
+SPOCK.equalp = function(x, y) {
+ if(x === y) return true;
+ else if(x instanceof SPOCK.Pair)
+ return y instanceof SPOCK.Pair &&
+ SPOCK.equalp(x.car, y.car) &&
+ SPOCK.equalp(x.cdr, y.cdr);
+ else if(x instanceof Array) {
+ var len = x.length;
+ if(!(y instanceof Array) || y.length != len) return false;
+ for(var i = 0; i < len; ++i) {
+ if(!SPOCK.equalp(x[ i ], y[ i ])) return false;
+ }
+ return true;
+ }
+ else if(x instanceof SPOCK.Char)
+ return y instanceof SPOCK.Char && x.characters === y.characters;
+ else if(x instanceof SPOCK.String) {
+ var s1 = x.normalize();
+
+ if(y instanceof SPOCK.String) return s1 === y.normalize();
+ else if(typeof y === 'string') return s1 === y;
+ else return false;
+ }
+ else if(typeof x === 'string') {
+ if(y instanceof SPOCK.String) return x === y.normalize();
+ else if(typeof y === 'string') return x === y;
+ else return false;
+ }
+ else return false;
+};
+
+SPOCK.count = function(args, loc) {
+ if(--SPOCK.stack <= 0)
+ return new SPOCK.Continuation(args.callee, Array.prototype.slice.call(args));
+ else return false;
+};
+
+SPOCK.rest = function(args, count, loc) {
+ var rest = null;
+
+ // this will not unwind, but decrease the counter
+ SPOCK.count(args, loc);
+
+ for(var i = args.length - 1; i >= count; --i)
+ rest = new SPOCK.Pair(args[ i ], rest);
+
+ return rest;
+};
+
+SPOCK.statistics = function() {};
+
+SPOCK.run = function(func) { // optional arguments
+ function terminate(result) {
+ return new SPOCK.Result(result);
+ }
+
+ var k = terminate;
+ var args = [k].concat(Array.prototype.slice.call(arguments, 1));
+ var oldstack = SPOCK.stack;
+ var oldlimit = SPOCK.limit;
+ var oldrunning = SPOCK.running;
+ SPOCK.limit = Math.max(10, oldlimit - oldstack);
+ SPOCK.stack = SPOCK.limit;
+ SPOCK.running = true;
+
+ function restore() {
+ SPOCK.stack = oldstack;
+ SPOCK.limit = oldlimit;
+ SPOCK.running = oldrunning;
+
+ if(!oldrunning) {
+ for(var i in SPOCK.runHook)
+ (SPOCK.runHook[ i ])(false);
+ }
+ }
+
+ var result;
+
+ if(!oldrunning) {
+ for(var i in SPOCK.runHook)
+ (SPOCK.runHook[ i ])(true);
+ }
+
+ while(true) {
+ result = func.apply(SPOCK.global, args);
+
+ if(result instanceof SPOCK.Continuation) {
+ SPOCK.stack = SPOCK.STACKSIZE;
+ func = result.k_callee;
+ args = result.k_arguments;
+ }
+ else if(result instanceof SPOCK.Result) {
+ restore();
+ return result.value;
+ }
+ else {
+ restore();
+ SPOCK.error("unexpected return of non-continuation", result);
+ }
+ }
+
+ return result;
+};
+
+SPOCK.callback = function(proc) {
+ return function() {
+ var args = Array.prototype.slice.call(arguments);
+ args.unshift(proc);
+ return SPOCK.run.apply(this, args);
+ };
+};
+
+SPOCK.callbackMethod = function(proc) {
+ var g = this;
+ return function() {
+ var args = Array.prototype.slice.call(arguments);
+ args.unshift(this);
+ args.unshift(proc);
+ return SPOCK.run.apply(g, args);
+ };
+};
+
+SPOCK.go = function(proc) {
+ (SPOCK.callback(proc))();
+};
+
+if("java" in this) { // rhino
+ SPOCK.makeJavaInputPort = function(jp) {
+ return new SPOCK.Port("input", {
+ read: function(n) {
+ var buffer = "";
+
+ while(n--) {
+ var b = jp.read();
+
+ if(b === -1) break;
+ else buffer += String.fromCharCode(b);
+ }
+
+ return buffer === "" ? SPOCK.EOF : buffer;
+ },
+
+ close: function() { jp.close(); }
+ });
+ };
+
+ SPOCK.makeJavaOutputPort = function(jp) {
+ return new SPOCK.Port("output", {
+ write: function(s) {
+ var len = s.length;
+
+ for(var i = 0; i < len; ++i)
+ jp.write(s.charCodeAt(i));
+ },
+
+ flush: function() { jp.flush(); },
+ close: function() { jp.close(); }
+ });
+ };
+
+ SPOCK.log = function() {
+ java.lang.System.err.println(Array.prototype.slice.call(arguments).join(""));
+ };
+
+ SPOCK.stdin = SPOCK.makeJavaInputPort(java.lang.System[ "in" ]);
+ SPOCK.stdout = SPOCK.makeJavaOutputPort(java.lang.System.out);
+ SPOCK.stderr = SPOCK.makeJavaOutputPort(java.lang.System.err);
+ SPOCK.stderr.name = "[stderr]";
+}
+else {
+ if("console" in this) SPOCK.log = console.log; // firebug
+ else if(SPOCK.inBrowser) // inside browser
+ SPOCK.log = function() {
+ var msg = arguments.join(" ");
+
+ if(msg.charAt(msg.length - 1) == "\n")
+ msg = msg.substring(0, msg.length - 1);
+
+ this.defaultStatus = msg;
+ };
+ else if("print" in this) SPOCK.log = print; // spidermonkey/v8
+ else if(typeof process !== undefined) SPOCK.log = console.log; // Node.JS
+ else SPOCK.error("no suitable output primitive available");
+
+ (function() {
+ var buffer = [];
+
+ function flush() {
+ if(buffer.length > 0) {
+ SPOCK.log(buffer.join(""));
+ buffer = [];
+ }
+ }
+
+ function write(s) {
+ var parts = SPOCK.stringify(s, false).split("\n");
+ var len = parts.length - 1;
+
+ if(len > 0) { // contains newline?
+ buffer.push(parts[ 0 ]);
+ flush();
+
+ if(len > 1) {
+ for(var i = 1; i < len; ++i)
+ SPOCK.log(parts[ i ]);
+ }
+
+ buffer.push(parts[ len ]);
+ }
+ else buffer.push(parts[ 0 ]);
+ }
+
+ SPOCK.stdout = new SPOCK.Port("output", { write: write, flush: flush });
+ var inp;
+ var ibuffer = "";
+
+ if(this.prompt) {
+ inp = function(n) {
+ while(true) {
+ if(ibuffer.length <= n) {
+ var part = ibuffer.slice(0, n);
+ ibuffer = ibuffer.slice(n);
+ return part;
+ }
+
+ var input = prompt("Expecting input for " + this.toString());
+
+ if(input === null) return SPOCK.EOF;
+ else ibuffer += input;
+ }
+ };
+ }
+ else {
+ inp = function(n) {
+ SPOCK.error("no input possible for standard input port");
+ };
+ }
+
+ SPOCK.stdin = new SPOCK.Port("input", { read: inp });
+ SPOCK.stderr = SPOCK.stdout;
+ })();
+}
+
+SPOCK.stdin.name = "[stdin]";
+SPOCK.stdout.name = "[stdout]";
+
+SPOCK.flush = function() {
+ // note that this always prints a newline when console.log or print is used
+ SPOCK.stdout.flush();
+
+ if(SPOCK.stderr !== SPOCK.stdout)
+ SPOCK.stderr.flush();
+
+ SPOCK.statistics();
+};
+
+if(this.gc) SPOCK.gc = gc;
+else SPOCK.gc = function() {};
+
+SPOCK.openInputUrlHook = function(url) {
+ SPOCK.error("can not open", url);
+};
+
+SPOCK.openOutputUrlHook = function(url) {
+ SPOCK.error("can not open", url);
+};
+
+if("java" in this) {
+ SPOCK.openInputFile = function(filename) {
+ var stream;
+
+ try {
+ stream = new java.io.FileInputStream(filename);
+ }
+ catch(e) {
+ SPOCK.error(e.message);
+ }
+
+ var port = SPOCK.makeJavaInputPort(stream);
+ port.name = filename;
+ return port;
+ };
+
+ SPOCK.openOutputFile = function(filename) {
+ var stream;
+
+ try {
+ stream = new java.io.FileOutputStream(filename);
+ }
+ catch(e) {
+ SPOCK.error(e.message);
+ }
+
+ var port = SPOCK.makeJavaOutputPort(stream);
+ port.name = filename;
+ return port;
+ };
+
+ SPOCK.fileExists = function(filename) {
+ return (new java.io.File(filename)).exists();
+ };
+}
+else {
+ if(SPOCK.inBrowser) {
+ SPOCK.openInputFile = function(filename) {
+ if(filename.match(/^[a-z0-9]+:/))
+ return SPOCK.openInputUrlHook(filename);
+
+ var cookies = document.cookie.split("; ");
+ var buffer = null;
+
+ for(var i = 0; i < cookies.length; ++i) {
+ var c = cookies[ i ];
+ var p = c.indexOf("=");
+
+ if(filename === c.substring(0, p)) {
+ buffer = c.substring(p + 1);
+ break;
+ }
+ }
+
+ if(!buffer) SPOCK.error("can not open file", filename);
+
+ var pos = 0;
+
+ return new SPOCK.Port("input", {
+ read: function(n) {
+ if(pos >= buffer.length) return SPOCK.EOF;
+ else if(pos + len >= buffer.length)
+ return buffer.substring(pos);
+
+ var p1 = pos;
+ pos += n;
+ return buffer.substring(p1, p1 + n);
+ },
+
+ ready: function() { return pos < buffer.length; }
+ });
+ };
+
+ SPOCK.openOutputFile = function(filename, expiry) {
+ if(filename.match(/^[a-z0-9]+:/))
+ return SPOCK.openOutputUrlHook(filename);
+
+ return new SPOCK.Port("output", {
+ write: function(s) { buffer += s; },
+ close: function() {
+ var now = (new Date()).getTime();
+ var exp = now + (expiry || (1000 * 60 * 60 * 24 * 365));
+ document.cookie = filename + "=" + encodeURIComponent(buffer) +
+ "; expires=" + (new Date(exp)).toGMTString();
+ }
+ });
+ };
+ }
+ else {
+ SPOCK.openInputFile = function(filename) {
+ SPOCK.error("file-I/O not available");
+ }
+
+ SPOCK.openOutputFile = function(filename) {
+ SPOCK.error("file-I/O not available");
+ }
+ }
+
+ SPOCK.fileExists = function(filename) {
+ SPOCK.error("`file-exists?' not available");
+ };
+}
+
+if("document" in this) { // browser?
+ SPOCK.load = function(url, k) {
+ // http://www.nczonline.net/blog/2009/07/28/the-best-way-to-load-external-javascript/
+ var script = document.createElement("script")
+
+ script.type = "text/javascript";
+ k = k || function() {};
+
+ if (script.readyState){ //IE
+ script.onreadystatechange = function(){
+ if (script.readyState == "loaded" || script.readyState == "complete"){
+ script.onreadystatechange = null;
+ k(url);
+ }
+ };
+ }
+ else { //Others
+ script.onload = function(){
+ k(url);
+ };
+ }
+
+ script.src = url;
+ document.getElementsByTagName("head")[0].appendChild(script);
+ };
+}
+else if("load" in this) { // rhino/SM
+ SPOCK.load = function(filename, k) {
+ load(filename);
+
+ if(k) k(filename);
+ };
+}
diff --git a/spock-0.2/sections.scm b/spock-0.2/sections.scm
@@ -0,0 +1,46 @@
+;;;; sections.scm - section handling for internal xref database
+
+
+;; this must be portable syntax-rules, since it runs in the
+;; host implementation
+
+(define-syntax define-library-section
+ (syntax-rules (default strict depends define define-syntax define-inline)
+ ((_ "walk" sec ())
+ (void))
+ ((_ "walk" sec ((default def ...) . more))
+ (begin
+ (define-library-section "walk-defs" sec (def ...))
+ (define-library-section "walk" sec more)))
+ ((_ "walk" sec ((strict def ...) . more))
+ (begin
+ (define-library-section "walk-defs" sec (def ...))
+ (define-library-section "walk" sec more)))
+ ((_ "walk" sec ((depends dep ...) . more))
+ (begin
+ (put! 'sec 'depends '(dep ...))
+ (define-library-section "walk" sec more)))
+ ((_ "walk" sec (clause . more))
+ (define-library-section "walk" sec more))
+ ((_ "walk-defs" sec ())
+ (void))
+ ((_ "walk-defs" sec ((define (name . llist) body ...) . more))
+ (begin
+ (put! 'name 'defined 'sec)
+ (define-library-section "walk-defs" sec more)))
+ ((_ "walk-defs" sec ((define name val) . more))
+ (begin
+ (put! 'name 'defined 'sec)
+ (define-library-section "walk-defs" sec more)))
+ ((_ "walk-defs" sec ((define-syntax name val) . more))
+ (begin
+ (put! 'name 'defined 'sec)
+ (define-library-section "walk-defs" sec more)))
+ ((_ "walk-defs" sec ((define-inline (name . llist) body ...) . more))
+ (begin
+ (put! 'name 'defined 'sec)
+ (define-library-section "walk-defs" sec more)))
+ ((_ "walk-defs" sec (form . more))
+ (define-library-section "walk-defs" sec more))
+ ((_ sec clauses ...)
+ (define-library-section "walk" sec (clauses ...)))))
diff --git a/spock-0.2/spock-compiler.scm b/spock-0.2/spock-compiler.scm
@@ -0,0 +1,55 @@
+;;;; spock-compiler.scm
+
+
+(module spock-compiler (make-spock-state
+ spock-state-mstore
+ spock-state-options
+ spock-state?
+ current-spock-state
+ spock
+ spock-initialize)
+
+(import scheme (except (chicken base) join butlast))
+(import matchable
+ (chicken file)
+ (chicken port)
+ (chicken pathname)
+ (chicken platform)
+ (chicken sort)
+ (chicken plist)
+ (chicken string)
+ (chicken pretty-print))
+
+(include "config")
+(include "misc")
+(include "expand")
+(include "core")
+(include "opt")
+(include "xref")
+(include "honu")
+(include "bind")
+(include "sections")
+(include "spock/library")
+(include "driver")
+(include "codegen")
+
+(define-record spock-state
+ mstore
+ options)
+
+;;
+(set! make-spock-state
+ (let ((make-spock-state make-spock-state)
+ (spock spock))
+ (lambda options
+ (make-spock-state (apply spock 'prepare options) options))))
+
+;;
+(define current-spock-state (make-parameter #f))
+
+;;
+(define (spock-initialize . options)
+ (current-spock-state
+ (apply make-spock-state options)))
+
+)
diff --git a/spock-0.2/spock-module.scm b/spock-0.2/spock-module.scm
@@ -0,0 +1,84 @@
+;;;; spock-module.scm - read-syntax and programming interface
+
+
+(module spock (<spock-header>
+ spock-script
+ <spock>)
+
+(import scheme (chicken base))
+(import matchable (chicken port) (chicken module))
+(import (chicken read-syntax))
+(import (chicken syntax))
+(import spock-compiler)
+(reexport spock-compiler)
+
+
+;;
+(define (<spock-header> #!key (minified #t) debug path)
+ (string-append
+ "<script type='text/javascript' src='"
+ (if path (string-append path "/") "")
+ "spock-runtime"
+ (if debug "-debug" "")
+ (if minified "-min" "")
+ ".js'></script>\n"))
+
+;;
+(define (spock-script x . options)
+ (let ((state (current-spock-state)))
+ (unless state
+ (set! state (make-spock-state))
+ (current-spock-state state))
+ (with-output-to-string
+ (lambda ()
+ (display "<script type='text/javascript'>\n")
+ (apply spock
+ 'code (strip-syntax x)
+ 'environment (spock-state-mstore state)
+ (append (spock-state-options state) options))
+ (display "\n</script>\n")))))
+
+;;
+(define-syntax <spock>
+ (er-macro-transformer
+ (lambda (x r c)
+ (let ((%cons (r 'cons))
+ (%append (r 'append))
+ (%list->vector (r 'list->vector))
+ (%spock-script (r 'spock-script)))
+ (define (unq x)
+ (cond ((pair? x)
+ (cond ((and (symbol? (car x))
+ (list? x)
+ (= (length x) 2)
+ (eq? '<unquote> (strip-syntax (car x))))
+ (cadr x))
+ ((and (pair? (car x))
+ (symbol? (caar x))
+ (list? (car x))
+ (= (length (car x)) 2)
+ (eq? '<unquote-splicing> (strip-syntax (caar x))))
+ `(,%append (cadar x) ,(unq (cdr x))))
+ (else `(,%cons ,(unq (car x)) ,(unq (cdr x)))))) ;XXX could be improved
+ ((vector? x)
+ `(,%list->vector ,(unq (vector->list x))))
+ (else `',x)))
+ `(,%spock-script ,(unq (cadr x)))))))
+
+
+;; read-syntax
+
+(set-sharp-read-syntax!
+ #\`
+ (lambda (port)
+ `(<spock> ,(read port))))
+
+(set-sharp-read-syntax!
+ #\^
+ (lambda (port)
+ (cond ((eqv? (peek-char port) #\@)
+ (read-char port)
+ `(<unquote-splicing> ,(read port)))
+ (else `(<unquote> ,(read port))))))
+
+)
diff --git a/spock-0.2/spock.egg b/spock-0.2/spock.egg
@@ -0,0 +1,40 @@
+((synopsis "A compiler and runtime system for R5RS Scheme on top of JavaScript")
+ (license "BSD")
+ (category web)
+ (dependencies jsmin matchable make)
+ (author "felix winkelmann")
+ (components (extension spock
+ (source "spock-module.scm")
+ (component-dependencies spock-compiler)
+ (csc-options "-O3" "-d1"))
+ (extension spock-compiler
+ (source-dependencies "misc.scm"
+ "expand.scm"
+ "core.scm"
+ "opt.scm"
+ "sections.scm"
+ "spock/library.scm"
+ "bind.scm"
+ "driver.scm"
+ "codegen.scm")
+ (csc-options "-O3" "-d1"))
+ (data spock-libs
+ (files "spock/spock-runtime.js"
+ "spock/spock-runtime-debug.js"
+ "spock/spock-runtime-min.js"
+ "spock/spock-runtime-debug-min.js"
+ "spock/syntax.scm"
+ "spock/library.scm"
+ "spock/match.scm")
+ (component-dependencies js-runtime))
+ (generated-source-file js-runtime
+ (component-dependencies chicken-spock)
+ (custom-build "build-runtime")
+ (source-dependencies "spock/library.scm"
+ "config.js"
+ "runtime.js"
+ "debug.js"))
+ (program chicken-spock
+ (source-dependencies "top.scm")
+ (component-dependencies spock spock-compiler)
+ (csc-options "-static" "-O3" "-d0" "-D" "standalone"))))
diff --git a/spock-0.2/spock/library.scm b/spock-0.2/spock/library.scm
@@ -0,0 +1,1959 @@
+;;;; library.scm - runtime-library (Scheme part)
+
+
+(let-syntax
+ ((case-lambda ; this is not the same as the usual `case-lambda'!
+ (letrec-syntax ((scan
+ (syntax-rules ()
+ ((_ (x) (lst ...)) (%dispatch lst ... x))
+ ((_ ((llist . body) . more) (lst ...))
+ (scan more (lst ... (lambda llist . body)))))))
+ (syntax-rules ()
+ ((_ clause ...)
+ (lambda args
+ (scan (clause ...) ()))))))
+ (define-inline
+ (syntax-rules
+ ___ ()
+ ((_ (name . args) body ___)
+ (define-syntax name
+ (lambda args body ___))))))
+ (begin
+
+ (define-library-section internal-essentials
+
+ (default
+
+ ;; (%string->jstring STRING) -> JSTRING
+ (define-inline (%string->jstring x) (%inline "SPOCK.jstring" x))
+
+ ;; (%jstring->string JSTRING) -> STRING
+ (define-inline (%jstring->string x) (%inline "new SPOCK.String" x))
+
+ ;; (%list ...) -> LIST
+ ;; used for manifest `lambda' with rest argument
+ (define (%list . xs) xs)
+
+ ;; (%car X) -> Y
+ (define-inline (%car x) (%property-ref "car" x))
+
+ ;; (%cdr X) -> Y
+ (define-inline (%cdr x) (%property-ref "cdr" x))
+
+ ))
+
+
+ (define-library-section essentials
+
+ (default
+
+ (define-inline (eq? x y)
+ (%inline (1 "===" 2) x y))
+
+ (define-inline (eqv? x y)
+ (%inline "SPOCK.eqvp" x y))
+
+ (define-inline (equal? x y) (%inline "SPOCK.equalp" x y))
+ (define-inline (not x) (if x #f #t))
+
+ ))
+
+
+ (define-library-section basic-type-predicates
+
+ (default
+
+ (define-inline (symbol? x) (%inline (1 "instanceof SPOCK.Symbol") x))
+ (define-inline (pair? x) (%inline (1 "instanceof SPOCK.Pair") x))
+ (define-inline (number? x) (eq? (%inline "typeof" x) "number"))
+ (define-inline (char? x) (%inline (1 "instanceof SPOCK.Char") x))
+ (define-inline (void? x) (%void? x))
+ (define-inline (vector? x) (%inline (1 "instanceof Array") x))
+ (define-inline (procedure? x) (eq? (%inline "typeof" x) "function"))
+ (define-inline (eof-object? x) (eq? x (%host-ref "SPOCK.EOF")))
+ (define-inline (boolean? x) (or (eq? x #t) (eq? x #f)))
+
+ (define-inline (string? x)
+ (or (eq? (%inline "typeof" x) "string")
+ (%inline (1 "instanceof SPOCK.String") x)))
+
+ ))
+
+
+ (define-library-section multiple-values
+
+ (default
+
+ (define values
+ (%native-lambda
+ "return K.apply(SPOCK.global, Array.prototype.slice.call(arguments, 1));"))
+
+ (define call-with-values
+ (%native-lambda
+ "var thunk = arguments[ 1 ];"
+ "var proc = arguments[ 2 ];"
+ "function k2() {"
+ " var args = Array.prototype.slice.call(arguments);"
+ " args.unshift(K);"
+ " return proc.apply(SPOCK.global, args);}"
+ "return thunk(k2);"))
+
+ ))
+
+
+ (define-library-section multiple-value-hacks
+
+ (default
+
+ ;; (%call-with-saved-values THUNK1 THUNK2)
+ (define %call-with-saved-values
+ (%native-lambda
+ "var t1 = arguments[ 1 ];"
+ "var t2 = arguments[ 2 ];"
+ "var args;"
+ "function k2() { return K.apply(SPOCK.global, args); }"
+ "function k1() {"
+ " args = Array.prototype.slice.call(arguments);"
+ " return t2(k2);}"
+ "return t1(k1);"))
+
+ ))
+
+
+ (define-library-section nonstandard-essentials
+
+ (default
+
+ (define-inline (void) (%void)) ; ignores extra arguments
+
+ ))
+
+
+ (define-library-section basic-list-operations
+
+ (default
+
+ (define-inline (null? x) (eq? x '()))
+ (define-inline (car x) (%car (%check ("SPOCK.Pair") x)))
+ (define-inline (cdr x) (%cdr (%check ("SPOCK.Pair") x)))
+ (define-inline (list . xs) xs)
+ (define-inline (cons x y) (%inline "new SPOCK.Pair" x y))
+
+ (define-inline (set-car! x y)
+ (%inline (1 ".car = " 2) (%check ("SPOCK.Pair") x) y))
+
+ (define-inline (set-cdr! x y)
+ (%inline (1 ".cdr = " 2) (%check ("SPOCK.Pair") x) y))
+
+ (define (list? x)
+ (let loop ((fast x) (slow x))
+ (or (null? fast)
+ (and (pair? fast)
+ (let ((fast (%cdr fast)))
+ (or (null? fast)
+ (and (pair? fast)
+ (let ((fast (%cdr fast))
+ (slow (%cdr slow)))
+ (and (not (eq? fast slow))
+ (loop fast slow))))))))))
+
+ (define-inline (caar x) (car (car x)))
+ (define-inline (cadr x) (car (cdr x)))
+ (define-inline (cdar x) (cdr (car x)))
+ (define-inline (cddr x) (cdr (cdr x)))
+ (define (caaar x) (car (car (car x))))
+ (define (caadr x) (car (car (cdr x))))
+ (define (cadar x) (car (cdr (car x))))
+ (define (caddr x) (car (cdr (cdr x))))
+ (define (cdaar x) (cdr (car (car x))))
+ (define (cdadr x) (cdr (car (cdr x))))
+ (define (cddar x) (cdr (cdr (car x))))
+ (define (cdddr x) (cdr (cdr (cdr x))))
+ (define (caaaar x) (car (car (car (car x)))))
+ (define (caaadr x) (car (car (car (cdr x)))))
+ (define (caadar x) (car (car (cdr (car x)))))
+ (define (caaddr x) (car (car (cdr (cdr x)))))
+ (define (cadaar x) (car (cdr (car (car x)))))
+ (define (cadadr x) (car (cdr (car (cdr x)))))
+ (define (caddar x) (car (cdr (cdr (car x)))))
+ (define (cadddr x) (car (cdr (cdr (cdr x)))))
+ (define (cdaaar x) (cdr (car (car (car x)))))
+ (define (cdaadr x) (cdr (car (car (cdr x)))))
+ (define (cdadar x) (cdr (car (cdr (car x)))))
+ (define (cdaddr x) (cdr (car (cdr (cdr x)))))
+ (define (cddaar x) (cdr (cdr (car (car x)))))
+ (define (cddadr x) (cdr (cdr (car (cdr x)))))
+ (define (cdddar x) (cdr (cdr (cdr (car x)))))
+ (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+ (define-inline (length lst) (%inline "SPOCK.length" lst))
+
+ (define (append . lsts)
+ (if (null? lsts)
+ '()
+ (let loop ((lsts lsts))
+ (if (null? (%cdr lsts))
+ (%car lsts)
+ (let copy ((node (%car lsts)))
+ (if (pair? node)
+ (cons (%car node) (copy (%cdr node)))
+ ;; ignores non-list node
+ (loop (%cdr lsts))))))))
+
+ (define (reverse lst)
+ (let loop ((lst lst) (rest '()))
+ (if (pair? lst)
+ (loop (%cdr lst) (cons (%car lst) rest))
+ ;; ignores non-list node
+ rest)))
+
+ (define (list-tail lst i)
+ (let loop ((i (%check "number" i))
+ (lst lst))
+ (if (%inline (1 " <= 0") i)
+ lst
+ (loop (%inline (1 " - 1") i)
+ (%cdr (%check ("SPOCK.Pair") lst))))))
+
+ (define list-ref
+ (let ((list-tail list-tail))
+ (lambda (lst i)
+ (%car (%check ("SPOCK.Pair") (list-tail lst i))))))
+
+ (define memq
+ (%native-lambda
+ "var x = arguments[ 1 ];"
+ "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
+ " if(n.car === x) return K(n);"
+ "}"
+ "return K(false);"))
+
+ (define memv
+ (%native-lambda
+ "var x = arguments[ 1 ];"
+ "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
+ " if(SPOCK.eqvp(n.car, x)) return K(n);"
+ "}"
+ "return K(false);"))
+
+ (define member
+ (%native-lambda
+ "var x = arguments[ 1 ];"
+ "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
+ " if(SPOCK.equalp(n.car, x)) return K(n);"
+ "}"
+ "return K(false);"))
+
+ (define assq
+ (%native-lambda
+ "var x = arguments[ 1 ];"
+ "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
+ " var p = n.car;"
+ " if(p instanceof SPOCK.Pair && p.car === x) return K(p);"
+ "}"
+ "return K(false);"))
+
+ (define assv
+ (%native-lambda
+ "var x = arguments[ 1 ];"
+ "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
+ " var p = n.car;"
+ " if(p instanceof SPOCK.Pair && SPOCK.eqvp(p.car, x)) return K(p);"
+ "}"
+ "return K(false);"))
+
+ (define assoc
+ (%native-lambda
+ "var x = arguments[ 1 ];"
+ "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
+ " var p = n.car;"
+ " if(p instanceof SPOCK.Pair && SPOCK.equalp(p.car, x)) return K(p);"
+ "}"
+ "return K(false);"))
+
+ ))
+
+
+ (define-library-section numeric-predicates
+
+ (default
+
+ (define-inline (zero? x) (eq? 0 (%check "number" x)))
+ (define-inline (positive? x) (%inline (1 ">" 2) (%check "number" x) 0))
+ (define-inline (negative? x) (%inline (1 "<" 2) (%check "number" x) 0))
+ (define-inline (odd? x) (not (eq? 0 (%inline (1 "%" 2) (%check "number" x) 2))))
+ (define-inline (even? x) (eq? 0 (%inline (1 "%" 2) (%check "number" x) 2)))
+ (define-inline (complex? x) (eq? (%inline "typeof" x) "number"))
+ (define-inline (rational? x) (eq? (%inline "typeof" x) "number"))
+ (define-inline (real? x) (eq? (%inline "typeof" x) "number"))
+
+ (define-inline (integer? x)
+ (and (eq? (%inline "typeof" x) "number")
+ (eq? x (%inline "Math.round" x) x)))
+
+ (define-inline (exact? x)
+ (let ((x (%check "number" x)))
+ (eq? x (%inline "Math.round" x) x)))
+
+ (define-inline (inexact? x) (not (exact? x)))
+
+ ))
+
+
+ (define-library-section native-basic-arithmetic
+
+ (debug
+
+ (define %+
+ (%native-lambda
+ "var len = arguments.length;"
+ "switch(len) {"
+ "case 1: return K(0);"
+ "case 2: return K(SPOCK.check(arguments[ 1 ], 'number', '+'));"
+ "default:"
+ " var p = SPOCK.check(arguments[ 1 ], 'number', '+');"
+ " for(var i = 2; i < len; ++i) {"
+ " p += SPOCK.check(arguments[ i ], 'number', '+');"
+ " }"
+ " return K(p);}"))
+
+ (define %-
+ (%native-lambda
+ "var len = arguments.length;"
+ "switch(len) {"
+ "case 1: SPOCK.error('(-) bad argument count', len);"
+ "case 2: return K(-SPOCK.check(arguments[ 1 ], 'number', '-'));"
+ "default:"
+ " var p = SPOCK.check(arguments[ 1 ], 'number', '-');"
+ " for(var i = 2; i < len; ++i) {"
+ " p -= SPOCK.check(arguments[ i ], 'number', '-');"
+ " }"
+ " return K(p);}"))
+
+ (define %*
+ (%native-lambda
+ "var len = arguments.length;"
+ "switch(len) {"
+ "case 1: return K(1);"
+ "case 2: return K(SPOCK.check(arguments[ 1 ], 'number', '*'));"
+ "default:"
+ " var p = SPOCK.check(arguments[ 1 ], 'number', '*');"
+ " for(var i = 2; i < len; ++i) {"
+ " p *= SPOCK.check(arguments[ i ], 'number', '*');"
+ " }"
+ " return K(p);}"))
+
+ (define %/
+ (%native-lambda
+ "var len = arguments.length;"
+ "switch(len) {"
+ "case 1: SPOCK.error('(/) bad argument count', len);"
+ "case 2: return K(1/SPOCK.check(arguments[ 1 ], 'number', '/'));"
+ "default:"
+ " var p = SPOCK.check(arguments[ 1 ], 'number', '/');"
+ " for(var i = 2; i < len; ++i) {"
+ " p /= SPOCK.check(arguments[ i ], 'number', '/');"
+ " }"
+ " return K(p);}"))
+
+ )
+
+ (default
+
+ (define %+
+ (%native-lambda
+ "var len = arguments.length;"
+ "switch(len) {"
+ "case 1: return K(0);"
+ "case 2: return K(arguments[ 1 ]);"
+ "default:"
+ " var p = arguments[ 1 ];"
+ " for(var i = 2; i < len; ++i) {"
+ " p += arguments[ i ];"
+ " }"
+ " return K(p);}"))
+
+ (define %-
+ (%native-lambda
+ "var len = arguments.length;"
+ "switch(len) {"
+ "case 2: return K(-arguments[ 1 ]);"
+ "default:"
+ " var p = arguments[ 1 ];"
+ " for(var i = 2; i < len; ++i) {"
+ " p -= arguments[ i ];"
+ " }"
+ " return K(p);}"))
+
+ (define %*
+ (%native-lambda
+ "var len = arguments.length;"
+ "switch(len) {"
+ "case 1: return K(1);"
+ "case 2: return K(arguments[ 1 ]);"
+ "default:"
+ " var p = arguments[ 1 ];"
+ " for(var i = 2; i < len; ++i) {"
+ " p *= arguments[ i ];"
+ " }"
+ " return K(p);}"))
+
+ (define %/
+ (%native-lambda
+ "var len = arguments.length;"
+ "switch(len) {"
+ "case 2: return K(1/arguments[ 1 ]);"
+ "default:"
+ " var p = arguments[ 1 ];"
+ " for(var i = 2; i < len; ++i) {"
+ " p /= arguments[ i ];"
+ " }"
+ " return K(p);}"))
+
+ ))
+
+
+ (define-library-section basic-arithmetic
+
+ (default
+
+ (define-syntax +
+ (case-lambda
+ (() 0)
+ ((n) (%check "number" n))
+ ((n1 n2)
+ (%inline (1 " + " 2) (%check "number" n1) (%check "number" n2)))
+ %+))
+
+ (define-syntax *
+ (case-lambda
+ (() 1)
+ ((n) (%check "number" n))
+ ((n1 n2)
+ (%inline (1 " * " 2) (%check "number" n1) (%check "number" n2)))
+ %*))
+
+ (define-syntax -
+ (case-lambda
+ ((n) (%inline ("-" 1) (%check number n)))
+ ((n1 n2)
+ (%inline (1 " - " 2) (%check number n1) (%check number n2)))
+ %-))
+
+ (define-syntax /
+ (case-lambda
+ ((n) (%inline ("1 / " 1) (%check number n)))
+ ((n1 n2)
+ (%inline (1 " / " 2) (%check number n1) (%check number n2)))
+ %/))
+
+ ))
+
+
+ (define-library-section native-numeric-comparison
+
+ ;;XXX need non-debug versions
+ (default
+
+ (define %=
+ (%native-lambda
+ "var argc = arguments.length;"
+ "var last = SPOCK.check(arguments[ 1 ], 'number', '=');"
+ "for(var i = 2; i < argc; ++i) {"
+ " var x = SPOCK.check(arguments[ i ], 'number', '=');"
+ " if(last !== x) return K(false);"
+ " else last = x;}"
+ "return K(true);"))
+
+ (define %>
+ (%native-lambda
+ "var argc = arguments.length;"
+ "var last = SPOCK.check(arguments[ 1 ], 'number', '>');"
+ "for(var i = 2; i < argc; ++i) {"
+ " var x = SPOCK.check(arguments[ i ], 'number', '>');"
+ " if(last <= x) return K(false);"
+ " else last = x;}"
+ "return K(true);"))
+
+ (define %<
+ (%native-lambda
+ "var argc = arguments.length;"
+ "var last = SPOCK.check(arguments[ 1 ], 'number', '<');"
+ "for(var i = 2; i < argc; ++i) {"
+ " var x = SPOCK.check(arguments[ i ], 'number', '<');"
+ " if(last >= x) return K(false);"
+ " else last = x;}"
+ "return K(true);"))
+
+ (define %>=
+ (%native-lambda
+ "var argc = arguments.length;"
+ "var last = SPOCK.check(arguments[ 1 ], 'number', '>=');"
+ "for(var i = 2; i < argc; ++i) {"
+ " var x = SPOCK.check(arguments[ i ], 'number', '>=');"
+ " if(last < x) return K(false);"
+ " else last = x;}"
+ "return K(true);"))
+
+ (define %<=
+ (%native-lambda
+ "var argc = arguments.length;"
+ "var last = SPOCK.check(arguments[ 1 ], 'number', '<=');"
+ "for(var i = 2; i < argc; ++i) {"
+ " var x = SPOCK.check(arguments[ i ], 'number', '<=');"
+ " if(last > x) return K(false);"
+ " else last = x;}"
+ "return K(true);"))
+
+ ))
+
+
+ (define-library-section numeric-comparison
+
+ (default
+
+ (define-syntax =
+ (case-lambda
+ ((n1 n2)
+ (%inline (1 " === " 2) (%check "number" n1) (%check "number" n2)))
+ %=))
+
+ (define-syntax >
+ (case-lambda
+ ((n1 n2)
+ (%inline (1 " > " 2) (%check "number" n1) (%check "number" n2)))
+ %>))
+
+ (define-syntax <
+ (case-lambda
+ ((n1 n2)
+ (%inline (1 " < " 2) (%check "number" n1) (%check "number" n2)))
+ %<))
+
+ (define-syntax >=
+ (case-lambda
+ ((n1 n2)
+ (%inline (1 " >= " 2) (%check "number" n1) (%check "number" n2)))
+ %>=))
+
+ (define-syntax <=
+ (case-lambda
+ ((n1 n2)
+ (%inline (1 " <= " 2) (%check "number" n1) (%check "number" n2)))
+ %<=))
+
+ ))
+
+
+ (define-library-section native-numeric-operations
+
+ (debug
+
+ (define %max
+ (%native-lambda
+ "var argc = arguments.length;"
+ "var n = SPOCK.check(arguments[ 1 ], 'number', 'max');"
+ "for(var i = 2; i < argc; ++i) {"
+ " var x = SPOCK.check(arguments[ i ], 'number', 'max');"
+ " if(n < x) n = x;}"
+ "return K(n);"))
+
+ (define %min
+ (%native-lambda
+ "var argc = arguments.length;"
+ "var n = SPOCK.check(arguments[ 1 ], 'number', 'max');"
+ "for(var i = 2; i < argc; ++i) {"
+ " var x = SPOCK.check(arguments[ i ], 'number', 'max');"
+ " if(n > x) n = x;}"
+ "return K(n);"))
+
+ )
+
+ (default
+
+ (define %max
+ (%native-lambda
+ "return K(Math.max.apply(SPOCK.global, arguments));"))
+
+ (define %max
+ (%native-lambda
+ "return K(Math.min.apply(SPOCK.global, arguments));"))
+
+ ))
+
+
+ (define-library-section numeric-operations
+
+ (default
+
+ (define-inline (round n) (%inline "Math.round" (%check "number" n)))
+ (define-inline (floor n) (%inline "Math.floor" (%check "number" n)))
+ (define-inline (ceiling n) (%inline "Math.ceil" (%check "number" n)))
+
+ (define-inline (truncate n)
+ (%check "number" n)
+ (if (%inline (1 " < 0") n)
+ (%inline "Math.ceil" n)
+ (%inline "Math.floor" n)))
+
+ (define-inline (log n) (%inline "Math.log" (%check "number" n)))
+ (define-inline (abs n) (%inline "Math.abs" (%check "number" n)))
+ (define-inline (sin n) (%inline "Math.sin" (%check "number" n)))
+ (define-inline (cos n) (%inline "Math.cos" (%check "number" n)))
+ (define-inline (tan n) (%inline "Math.tan" (%check "number" n)))
+ (define-inline (asin n) (%inline "Math.asin" (%check "number" n)))
+ (define-inline (acos n) (%inline "Math.acos" (%check "number" n)))
+ (define-inline (sqrt n) (%inline "Math.sqrt" (%check "number" n)))
+
+ (define-inline (expt n m)
+ (%inline "Math.pow" (%check "number" n) (%check "number" m)))
+
+ (define-inline (atan y x)
+ (if (void? x)
+ (%inline "Math.atan" (%check "number" y))
+ (%inline "Math.atan2" (%check "number" y) (%check "number" x))))
+
+ (define-syntax max
+ (case-lambda
+ ((n) (%check "number" n))
+ ((n1 n2)
+ (%inline "Math.max" (%check "number" n1) (%check "number" n2)))
+ %max))
+
+ (define-syntax min
+ (case-lambda
+ ((n) (%check "number" n))
+ ((n1 n2)
+ (%inline "Math.min" (%check "number" n1) (%check "number" n2)))
+ %min))
+
+ (define-inline (quotient x y)
+ (truncate (/ x y))) ;XXX correct?
+
+ (define-inline (remainder x y)
+ (- x (* (quotient x y) y)))
+
+ (define (modulo a b) ; copied from chibi scheme without asking Alex
+ (let ((res (remainder a b)))
+ (if (< b 0)
+ (if (<= res 0) res (+ res b))
+ (if (>= res 0) res (+ res b)))))
+
+ (define-inline (exact->inexact n) (%check "number" n))
+ (define-inline (inexact->exact n) (truncate n))
+
+ ;; not implemented: numerator denominator rationalize
+ ;; not implemented: make-rectangular make-polar imag-part real-part magnitude angle
+
+ ))
+
+
+ (define-library-section gcd-and-lcm
+
+ (default
+
+ ;;XXX slow
+
+ (define %gcd
+ (let ((remainder remainder))
+ (lambda (x y)
+ (let loop ((x x) (y y))
+ (if (zero? y)
+ (abs x)
+ (loop y (remainder x y)) ) ) ) ) )
+
+ (define (gcd . ns)
+ (if (null? ns)
+ 0
+ (let loop ((ns ns) (f #t))
+ (let ((head (%car ns))
+ (next (%cdr ns)))
+ (when f (%check "number" head))
+ (if (null? next)
+ (abs head)
+ (let ((n2 (%car next)))
+ (%check "number" n2)
+ (loop
+ (cons (%gcd head n2) (%cdr next))
+ #f) ) ) ) ) ) )
+
+ (define (%lcm x y)
+ (quotient (* x y) (%gcd x y)) )
+
+ (define (lcm . ns)
+ (if (null? ns)
+ 1
+ (let loop ((ns ns) (f #t))
+ (let ((head (%car ns))
+ (next (%cdr ns)))
+ (when f (%check "number" head))
+ (if (null? next)
+ (abs head)
+ (let ((n2 (%car next)))
+ (%check "number" n2)
+ (loop
+ (cons (%lcm head n2) (%cdr next))
+ #f) ) ) ) ) ) )
+
+ ))
+
+
+ (define-library-section characters
+
+ (default
+
+ (define-inline (char->integer c)
+ (%inline ".charCodeAt" (%property-ref "character" (%check ("SPOCK.Char") c)) 0))
+
+ (define-inline (integer->char c)
+ (%inline "new SPOCK.Char" (%inline "String.fromCharCode" (%check "number" c))))
+
+ (define-inline (char=? x y)
+ (eq? (%property-ref "character" (%check ("SPOCK.Char") x))
+ (%property-ref "character" (%check ("SPOCK.Char") y))))
+
+ (define-inline (char>? x y)
+ (%inline
+ (1 " > " 2)
+ (%property-ref "character" (%check ("SPOCK.Char") x))
+ (%property-ref "character" (%check ("SPOCK.Char") y))))
+
+ (define-inline (char<? x y)
+ (%inline
+ (1 " < " 2)
+ (%property-ref "character" (%check ("SPOCK.Char") x))
+ (%property-ref "character" (%check ("SPOCK.Char") y))))
+
+ (define-inline (char>=? x y)
+ (%inline
+ (1 " >= " 2)
+ (%property-ref "character" (%check ("SPOCK.Char") x))
+ (%property-ref "character" (%check ("SPOCK.Char") y))))
+
+ (define-inline (char<=? x y)
+ (%inline
+ (1 " <= " 2)
+ (%property-ref "character" (%check ("SPOCK.Char") x))
+ (%property-ref "character" (%check ("SPOCK.Char") y))))
+
+ (define-inline (char-ci=? x y)
+ (eq? (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
+
+ (define-inline (char-ci>? x y)
+ (%inline
+ (1 " > " 2)
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
+
+ (define-inline (char-ci<? x y)
+ (%inline
+ (1 " < " 2)
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
+
+ (define-inline (char-ci>=? x y)
+ (%inline
+ (1 " >= " 2)
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
+
+ (define-inline (char-ci<=? x y)
+ (%inline
+ (1 " <= " 2)
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
+ (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
+
+ (define-inline (char-upcase c)
+ (%inline
+ "new SPOCK.Char"
+ (%inline
+ ".toUpperCase"
+ (%property-ref "character" (%check ("SPOCK.Char") c)))))
+
+ (define-inline (char-downcase c)
+ (%inline
+ "new SPOCK.Char"
+ (%inline
+ ".toLowerCase"
+ (%property-ref "character" (%check ("SPOCK.Char") c)))))
+
+ (define-inline (char-alphabetic? c) ;XXX not unicode aware
+ (not
+ (null?
+ (%inline
+ (1 ".character.match(/^[A-Za-z]$/)")
+ (%check ("SPOCK.Char") c)))))
+
+ (define-inline (char-numeric? c) ;XXX not unicode aware?
+ (not (null? (%inline (1 ".character.match(/^\\d$/)") (%check ("SPOCK.Char") c)))))
+
+ (define-inline (char-whitespace? c)
+ (not (null? (%inline (1 ".character.match(/^\\s$/)") (%check ("SPOCK.Char") c)))))
+
+ (define-inline (char-upper-case? c) ;XXX not unicode aware
+ (not
+ (null?
+ (%inline
+ (1 ".character.match(/^[A-Z]$/)")
+ (%check ("SPOCK.Char") c)))))
+
+ (define-inline (char-lower-case? c) ;XXX not unicode aware
+ (not
+ (null?
+ (%inline
+ (1 ".character.match(/^[a-z]$/)")
+ (%check ("SPOCK.Char") c)))))
+
+ ))
+
+
+ (define-library-section symbols
+
+ (default
+
+ (define-inline (symbol->string sym)
+ (%property-ref "name" (%check ("SPOCK.Symbol") sym)))
+
+ (define string->symbol
+ (%native-lambda
+ "var str = SPOCK.jstring(arguments[ 1 ]);"
+ "return K(SPOCK.intern(str));"))
+
+ ))
+
+
+ (define-library-section property-lists
+
+ (default
+
+ (define (get sym prop)
+ (let ((val
+ (%inline
+ (1 ".plist[" 2 "]")
+ (%check ("SPOCK.Symbol") sym)
+ (%property-ref "name" (%check ("SPOCK.Symbol") prop)))))
+ (and (not (void? val)) val))) ;XXX doesn't allow storing void
+
+ (define (put! sym prop val)
+ (%inline
+ (1 ".plist[" 2 "] = " 3)
+ (%check ("SPOCK.Symbol") sym)
+ (%property-ref "name" (%check ("SPOCK.Symbol") prop))
+ val))
+
+ ))
+
+
+ (define-library-section strings
+
+ (default
+
+ (define-inline (string-length str)
+ (%property-ref "length" (%string->jstring str)))
+
+ (define string-append
+ (%native-lambda
+ "var args = Array.prototype.slice.call(arguments, 1);"
+ "var strs = SPOCK.map(function(x) { return SPOCK.jstring(x); }, args);"
+ "return K(new SPOCK.String(strs));"))
+
+ ;;XXX does no bounds/exactness check
+ (define-inline (substring str i j)
+ (let ((str (%string->jstring str)))
+ (%inline
+ ".substring" str
+ (%check "number" i)
+ (if (void? j)
+ (%property-ref "length" str)
+ (%check "number" j)))))
+
+ ;;XXX we need non-debug versions of all of these
+
+ (define string
+ (%native-lambda
+ "var str = [];"
+ "var len = arguments.length - 1;"
+ "for(var i = 1; i <= len; ++i) {"
+ " var x = arguments[ i ];"
+ " if(x instanceof SPOCK.Char) str.push(x.character);"
+ " else SPOCK.error('bad argument type - not a character', x);}"
+ "return K(new SPOCK.String(str.join('')));"))
+
+ (define string->list
+ (%native-lambda
+ "var str = SPOCK.jstring(arguments[ 1 ]);"
+ "var lst = null;"
+ "var len = str.length;"
+ "for(var i = len - 1; i >= 0; --i)"
+ " lst = new SPOCK.Pair(new SPOCK.Char(str.charAt(i)), lst);"
+ "return K(lst);"))
+
+ (define list->string
+ (%native-lambda
+ "var lst = arguments[ 1 ];"
+ "var str = [];"
+ "while(lst instanceof SPOCK.Pair) {"
+ " str.push(SPOCK.check(lst.car, SPOCK.Char).character);"
+ " lst = lst.cdr;}"
+ "return K(new SPOCK.String(str.join('')));"))
+
+ (define make-string
+ (%native-lambda
+ "var n = SPOCK.check(arguments[ 1 ], 'number', 'make-string');"
+ "var c = arguments[ 2 ];"
+ "var a = new Array(n);"
+ "if(c !== undefined)"
+ " c = SPOCK.check(c, SPOCK.Char, 'make-string').character;"
+ "else c = ' ';"
+ "for(var i = 0; i < n; ++i) a[ i ] = c;"
+ "return K(new SPOCK.String(a.join('')));"))
+
+ ;;XXX no bounds/exactness checks
+ (define string-ref ;XXX consider inlining the fast case
+ (%native-lambda
+ "var str = arguments[ 1 ];"
+ "var i = SPOCK.check(arguments[ 2 ], 'number', 'string-ref');"
+ "if(typeof str === 'string')"
+ " return K(new SPOCK.Char(str.charAt(i)));"
+ "else if(str instanceof SPOCK.String) {"
+ " var parts = str.parts;"
+ " for(var p in parts) {"
+ " var l = parts[ p ].length;"
+ " if(i <= l) return K(new SPOCK.Char(parts[ p ].charAt(i)));"
+ " else i -= l;}"
+ " SPOCK.error('`string-ref\\\' out of range', str, i);}"))
+
+ (define string-set!
+ (%native-lambda
+ "var str = arguments[ 1 ];"
+ "var i = SPOCK.check(arguments[ 2 ], 'number', 'string-set!');"
+ "var c = SPOCK.check(arguments[ 3 ], SPOCK.Char, 'string-set!');"
+ "if(typeof str === 'string')"
+ " SPOCK.error('argument to `string-set!\\\' is not a mutable string', str);"
+ "else if(str instanceof SPOCK.String) {"
+ " var parts = str.parts;"
+ " for(var p in parts) {"
+ " var part = parts[ p ];"
+ " var l = part.length;"
+ " if(i <= l) {"
+ " parts[ p ] = part.substring(0, i) + c.character + part.substring(i + 1);"
+ " return K(undefined);"
+ " } else i -= l;}"
+ " SPOCK.error('`string-set!\\\' out of range', str, i);}"))
+
+ (define-inline (string=? s1 s2)
+ (eq? (%string->jstring s1) (%string->jstring s2))) ;XXX may cons a lot
+
+ (define-inline (string>? s1 s2)
+ (%inline (1 " > " 2) (%string->jstring s1) (%string->jstring s2)))
+
+ (define-inline (string<? s1 s2)
+ (%inline (1 " < " 2) (%string->jstring s1) (%string->jstring s2)))
+
+ (define-inline (string>=? s1 s2)
+ (%inline (1 " >= " 2) (%string->jstring s1) (%string->jstring s2)))
+
+ (define-inline (string<=? s1 s2)
+ (%inline (1 " <= " 2) (%string->jstring s1) (%string->jstring s2)))
+
+ (define-inline (string-ci=? s1 s2) ;XXX ugly
+ (eq?
+ (%inline ".toLowerCase" (%string->jstring s1))
+ (%inline ".toLowerCase" (%string->jstring s2))))
+
+ (define-inline (string-ci>? s1 s2)
+ (%inline
+ (1 " > " 2)
+ (%inline ".toLowerCase" (%string->jstring s1))
+ (%inline ".toLowerCase" (%string->jstring s2))))
+
+ (define-inline (string-ci<? s1 s2)
+ (%inline
+ (1 " < " 2)
+ (%inline ".toLowerCase" (%string->jstring s1))
+ (%inline ".toLowerCase" (%string->jstring s2))))
+
+ (define-inline (string-ci>=? s1 s2)
+ (%inline
+ (1 " >= " 2)
+ (%inline ".toLowerCase" (%string->jstring s1))
+ (%inline ".toLowerCase" (%string->jstring s2))))
+
+ (define-inline (string-ci<=? s1 s2)
+ (%inline
+ (1 " <= " 2)
+ (%inline ".toLowerCase" (%string->jstring s1))
+ (%inline ".toLowerCase" (%string->jstring s2))))
+
+ (define (string-copy str from to)
+ (let* ((str (%string->jstring str))
+ (from (if (void? from) 0 (%check "number" from)))
+ (to (if (void? to) (%property-ref "length" str) (%check "number" to))))
+ (%jstring->string (%inline ".slice" str from to))))
+
+ (define (string-fill! str char from to)
+ (unless (%check (%inline (1 "instanceof SPOCK.String") str))
+ (%error "bad argument type - not a mutable string" str))
+ (let* ((text (%inline ".normalize" str))
+ (char (%check ("SPOCK.Char") char))
+ (from (if (void? from) 0 (%check "number" from)))
+ (to (if (void? to) (%property-ref "length" text) (%check "number" to))))
+ ((%native-lambda
+ "var str = arguments[ 1 ];"
+ "var from = arguments[ 2 ];"
+ "var to = arguments[ 3 ];"
+ "var c = arguments[ 4 ];"
+ "var snew = new Array(to - from);"
+ "for(var i in snew) snew[ i ] = c;"
+ "str.parts = [str.parts[ 0 ].substring(0, from), snew.join(''),"
+ " str.parts[ 0 ].substring(to)];"
+ "return K(str);")
+ str from to char)))
+
+ ))
+
+
+ (define-library-section vectors
+
+ ;;XXX add non-debug variants
+
+ (default
+
+ (define-inline (vector-length v)
+ (%property-ref "length" (%check ("Array") v)))
+
+ ;;XXX make these two safe (bounds-checking and exactness)
+ (define-inline (vector-ref v i)
+ (%inline (1 "[" 2 "]") (%check ("Array") v) (%check "number" i)))
+
+ (define-inline (vector-set! v i x)
+ (%inline (1 "[" 2 "] = " 3) (%check ("Array") v) (%check "number" i) x))
+
+ (define vector
+ (%native-lambda
+ "return K(Array.prototype.slice.call(arguments, 1));"))
+
+ (define make-vector
+ (%native-lambda
+ "var n = SPOCK.check(arguments[ 1 ], 'number', 'make-vector');"
+ "var x = arguments[ 2 ];"
+ "var a = new Array(n);"
+ "if(x !== undefined) {"
+ " for(var i = 0; i < n; ++i) a[ i ] = x;}"
+ "return K(a);"))
+
+ (define vector->list
+ (%native-lambda
+ "var vec = SPOCK.check(arguments[ 1 ], Array, 'vector->list');"
+ "var lst = null;"
+ "var len = vec.length;"
+ "for(var i = len - 1; i >= 0; --i)"
+ " lst = new SPOCK.Pair(vec[ i ], lst);"
+ "return K(lst);"))
+
+ (define list->vector
+ (%native-lambda
+ "var lst = arguments[ 1 ];"
+ "var vec = [];"
+ "while(lst instanceof SPOCK.Pair) {"
+ " vec.push(lst.car);"
+ " lst = lst.cdr;}"
+ "return K(vec);"))
+
+ (define vector-fill!
+ (%native-lambda
+ "var vec = SPOCK.check(arguments[ 1 ], Array, 'vector-fill!');"
+ "var x = arguments[ 2 ];"
+ "var from = arguments[ 3 ];"
+ "var to = arguments[ 4 ];"
+ "if(from === undefined) from = 0;"
+ "if(to === undefined) to = vec.length;"
+ "for(var i = from; i < to; ++i)"
+ " vec[ i ] = x;"
+ "return K(undefined);"))
+
+ ))
+
+
+ (define-library-section number-string-conversion
+
+ (default
+
+ (define-inline (number->string num base)
+ (%inline
+ "new SPOCK.String"
+ (%inline
+ ".toString"
+ (%check "number" num)
+ (if (void? base)
+ 10
+ (%check "number" base)))))
+
+ ;;XXX add non-debug version?
+ (define string->number
+ (%native-lambda
+ "var str = SPOCK.jstring(arguments[ 1 ]);"
+ "var base = arguments[ 2 ];"
+ "if(!base) base = 10;"
+ "else base = SPOCK.check(base, 'number', 'string->number');"
+ "var m = true, neg = 1;"
+ "while(m) {"
+ " m = str.match(/^#[eboxid]/);"
+ " if(m) {"
+ " switch(str[ 1 ]) {"
+ " case 'e':"
+ " case 'i': break;"
+ " case 'd': base = 10; break;"
+ " case 'o': base = 8; break;"
+ " case 'x': base = 16; break;"
+ " case 'b': base = 2; break;"
+ " default: return K(false);}"
+ " str = str.substring(2);}}"
+ "switch(str[ 0 ]) {"
+ "case '-': neg = -1; str = str.substring(1); break;"
+ "case '+': str = str.substring(1);}"
+ "var num, den = false;"
+ "if((m = str.match(/^([^\\/]+)\\/(.+)$/))) {"
+ " str = m[ 1 ];"
+ " den = m[ 2 ];}"
+ "function num3(s) {"
+ " var tr = null;"
+ " switch(base) {"
+ " case 2: tr = /^[0-1]+$/; break;"
+ " case 8: tr = /^[0-7]+$/; break;"
+ " case 10: tr = /^[#0-9]*\\.?[#0-9]+([esdfl][-+]?[0-9]+)?$/; break;"
+ " case 16: tr = /^[0-9a-fA-F]+$/;}"
+ " if(tr && !s.match(tr)) return false;"
+ " var s2 = s.replace(/#/g, '0');"
+ " if(base === 10) s2 = parseFloat(s2.replace(/[esdfl]/g, 'e'));"
+ " else if(s2 !== s) return false;"
+ " else s2 = parseInt(s2, base);"
+ " return isNaN(s2) ? false : s2;}"
+ "if((num = num3(str)) === false) return K(false);"
+ "if(den && !(den = num3(den))) return K(false);"
+ "return K(neg * num / (den || 1));"))
+
+ ))
+
+
+ (define-library-section unsafe-internal-i/o
+
+ (default
+
+ ;; (%show STRING PORT)
+ (define %show
+ (%native-lambda
+ "arguments[ 2 ].write(arguments[ 1 ]);"
+ "return K(undefined);"))
+
+ ;; (%fetch N PORT)
+ (define %fetch
+ (%native-lambda
+ "return K(arguments[ 2 ].read(arguments[ 1 ]));"))
+
+ ))
+
+
+ (define-library-section port-checks
+
+ (debug
+
+ ;; (%check-port X DIR LOC)
+ (define %check-port
+ (%native-lambda
+ "var port = arguments[ 1 ];"
+ "var dir = arguments[ 2 ];"
+ "if(port instanceof SPOCK.Port) {"
+ " if(port.closed)"
+ " SPOCK.error('port is already closed', port);"
+ " else if(port.direction !== dir)"
+ " SPOCK.error('bad argument type - not an ' + dir + ' port', port, arguments[ 3 ]);"
+ "}"
+ "else SPOCK.error('bad argument type - not a port', port, arguments[ 3 ]);"
+ "return K(port);"))
+ )
+
+ (default
+
+ (define-inline (%check-port x dir loc) x)
+
+ ))
+
+
+ (define-library-section basic-i/o
+
+ (default
+
+ (define-inline (current-input-port) (%host-ref "SPOCK.stdin"))
+ (define-inline (current-output-port) (%host-ref "SPOCK.stdout"))
+
+ (define (newline port)
+ (%show
+ "\n"
+ (if (void? port)
+ (%host-ref "SPOCK.stdout")
+ (%check-port port "output" "newline"))))
+
+ (define (read-char port)
+ (let ((s (%fetch
+ 1
+ (if (void? port)
+ (%host-ref "SPOCK.stdin")
+ (%check-port port "input" "read-char")))))
+ (if (eof-object? s)
+ s
+ (%inline "new SPOCK.Char" s))))
+
+ (define (write-char chr port)
+ (%show
+ (%property-ref "character" (%check ("SPOCK.Char") chr))
+ (if (void? port)
+ (%host-ref "SPOCK.stdout")
+ (%check-port port "output" "write-char"))))
+
+ (define peek-char
+ (let ((read-char read-char))
+ (lambda (port)
+ (let ((c (read-char port)))
+ (unless (eof-object? c)
+ (%inline (1 ".peeked = " 2) port (%property-ref "character" c)))
+ c))))
+
+ (define (char-ready? port)
+ (%check-port port "input" "char-ready?")
+ (%inline ".ready" port))
+
+ ))
+
+
+ (define-library-section data-output
+
+ (default
+
+ ;; (%print-hook X PORT READABLE?) called for unknown object
+ (define (%print-hook x port readable)
+ (%show "#<unknown object>" port))
+
+ (define (display x port)
+ (let ((port (if (void? port)
+ (%host-ref "SPOCK.stdout")
+ (%check-port port "output" "display"))))
+ (let show ((x x))
+ (cond ((null? x) (%show "()" port))
+ ((number? x)
+ ;;XXX this could be optimized
+ (%show (%string->jstring (number->string x)) port))
+ ((string? x)
+ (%show (%inline "SPOCK.jstring" x) port))
+ ((symbol? x)
+ (%show (%property-ref "name" x) port))
+ ((char? x)
+ (%show (%property-ref "character" x) port))
+ ((eof-object? x) (%show "#<eof>" port))
+ ((procedure? x) (%show "#<procedure>" port))
+ ((boolean? x) (%show (if x "#t" "#f") port))
+ ((pair? x)
+ (%show "(" port)
+ (let loop ((y x))
+ (cond ((null? y) (%show ")" port))
+ ((not (pair? y))
+ (%show " . " port)
+ (show y)
+ (%show ")" port))
+ (else
+ (unless (eq? x y) (%show " " port))
+ (show (%car y))
+ (loop (cdr y))))))
+ ((void? x) (%show "#<undefined>" port))
+ ((vector? x)
+ (let ((len (%property-ref "length" x)))
+ (%show "#(" port)
+ (do ((i 0 (%inline ("1+" 1) i)))
+ ((%inline (1 ">=" 2) i len)
+ (%show ")" port))
+ (unless (eq? i 0) (%show " " port))
+ (show (%inline (1 "[" 2 "]") x i)))))
+ ((%inline (1 "instanceof SPOCK.Port") x)
+ (%show (%inline "SPOCK.stringify" x) port))
+ ((%inline (1 "instanceof SPOCK.Promise") x)
+ (%show "#<promise>" port))
+ ((eq? "object" (%inline "typeof" x))
+ (%print-hook x port #f))
+ (else (%show "#<unknown object>" port))))))
+
+ (define write
+ (let ((display display))
+ (define escape
+ (%native-lambda
+ "var str = arguments[ 1 ];"
+ "var a = [];"
+ "var len = str.length;"
+ "for(var i = 0; i < len; ++i) {"
+ " var c = str.charAt(i);"
+ " switch(c) {"
+ " case '\\n': a.push('\\n'); break;"
+ " case '\\t': a.push('\\t'); break;"
+ " case '\\r': a.push('\\r'); break;"
+ " case '\\\"': a.push('\\\\\"'); break;"
+ " case '\\\\': a.push('\\\\'); break;"
+ " default: a.push(c);}}"
+ "return K(a.join(''));"))
+ (lambda (x port)
+ (let ((port (if (void? port)
+ (%host-ref "SPOCK.stdout")
+ (%check-port port "output" "write"))))
+ (let show ((x x))
+ (cond ((string? x)
+ (%show "\"" port)
+ (%show (escape (%inline "SPOCK.jstring" x)) port)
+ (%show "\"" port))
+ ((char? x)
+ (%show "#\\" port)
+ (%show
+ (let ((c (%property-ref "character" x)))
+ (case c
+ (("\n") "newline") ; don't worry
+ (("\r") "return")
+ (("\t") "tab")
+ ((" ") "space")
+ (else c)))
+ port))
+ ((pair? x)
+ (%show "(" port)
+ (let loop ((y x))
+ (cond ((null? y) (%show ")" port))
+ ((not (pair? y))
+ (%show " . " port)
+ (show y)
+ (%show ")" port))
+ (else
+ (unless (eq? x y) (%show " " port))
+ (show (%car y))
+ (loop (cdr y))))))
+ ((vector? x)
+ (let ((len (%property-ref "length" x)))
+ (%show "#(" port)
+ (do ((i 0 (%inline ("1+" 1) i)))
+ ((%inline (1 ">=" 2) i len)
+ (%show ")" port))
+ (unless (eq? i 0) (%show " " port))
+ (show (%inline (1 "[" 2 "]") x i)))))
+ (else (display x port))))))))
+
+ ))
+
+
+ (define-library-section extended-i/o
+
+ (default
+
+ (define-inline (current-error-port) (%host-ref "SPOCK.stderr"))
+
+ ))
+
+
+ (define-library-section higher-order-operations
+
+ (default
+
+ (define apply
+ (%native-lambda
+ "var proc = arguments[ 1 ];"
+ "var argc = arguments.length;"
+ "var lst = arguments[ argc - 1 ];"
+ "var vec = [K].concat(Array.prototype.slice.call(arguments, 2, argc - 1));"
+ "if(lst instanceof Array) vec = vec.concat(lst);"
+ "else{"
+ " var len = SPOCK.length(lst);"
+ " var vec2 = new Array(len);"
+ " for(var i = 0; lst instanceof SPOCK.Pair; lst = lst.cdr)"
+ " vec2[ i++ ] = lst.car;"
+ " vec = vec.concat(vec2);}"
+ "return proc.apply(SPOCK.global, vec);"))
+
+ (define (for-each proc lst1 . lsts)
+ (if (null? lsts)
+ (if (vector? lst1)
+ (let ((len (vector-length lst1)))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (proc (vector-ref lst1 i))))
+ (let loop ((lst lst1))
+ (when (pair? lst)
+ (proc (%car lst))
+ (loop (%cdr lst)))))
+ (let loop ((lsts (cons lst1 lsts)))
+ (let ((hds (let loop2 ((lsts lsts))
+ (if (null? lsts)
+ '()
+ (let ((x (%car lsts)))
+ (and (pair? x)
+ (cons (%car x) (loop2 (%cdr lsts)))))))))
+ (when hds
+ (apply proc hds)
+ (loop
+ (let loop3 ((lsts lsts))
+ (if (null? lsts)
+ '()
+ (cons (%cdr (%car lsts)) (loop3 (%cdr lsts)))))))))))
+
+ (define (map proc lst1 . lsts)
+ (if (null? lsts)
+ (if (vector? lst1)
+ (let* ((len (vector-length lst1))
+ (rv (make-vector len)))
+ (do ((i 0 (+ i 1)))
+ ((>= i len) rv)
+ (vector-set! rv i (proc (vector-ref lst1 i)))))
+ (let loop ((lst lst1))
+ (if (pair? lst)
+ (cons (proc (%car lst))
+ (loop (%cdr lst)))
+ '())))
+ (let loop ((lsts (cons lst1 lsts)))
+ (let ((hds (let loop2 ((lsts lsts))
+ (if (null? lsts)
+ '()
+ (let ((x (%car lsts)))
+ (and (pair? x)
+ (cons (%car x) (loop2 (%cdr lsts)))))))))
+ (if hds
+ (cons
+ (apply proc hds)
+ (loop
+ (let loop3 ((lsts lsts))
+ (if (null? lsts)
+ '()
+ (cons (%cdr (%car lsts)) (loop3 (%cdr lsts)))))))
+ '())))))
+
+ ))
+
+
+ (define-library-section continuations
+
+ (default
+
+ (define dynamic-wind
+ (let ((call-with-values call-with-values)
+ (values values))
+ (lambda (before thunk after)
+ (before)
+ (%host-set!
+ "SPOCK.dynwinds"
+ (cons (cons before after) (%host-ref "SPOCK.dynwinds")))
+ (%call-with-saved-values
+ thunk
+ (lambda ()
+ (%host-set! "SPOCK.dynwinds" (%cdr (%host-ref "SPOCK.dynwinds")))
+ (after))))))
+
+ ;; (%call-with-current-continuation PROC)
+ ;;
+ ;; - does not unwind
+ (define %call-with-current-continuation
+ (%native-lambda
+ "var proc = arguments[ 1 ];"
+ "function cont() {"
+ " return K.apply(SPOCK.global, Array.prototype.slice.call(arguments, 1));}"
+ "return proc(K, cont);"))
+
+ (define call-with-current-continuation
+ (let ()
+ (define (unwind winds n)
+ (cond ((eq? (%host-ref "SPOCK.dynwinds") winds))
+ ((< n 0)
+ (unwind (%cdr winds) (%inline (1 " + 1") n))
+ ((%car (%car winds)))
+ (%host-set! "SPOCK.dynwinds" winds))
+ (else
+ (let ((after (%cdr (%car (%host-ref "SPOCK.dynwinds")))))
+ (%host-set! "SPOCK.dynwinds" (%cdr (%host-ref "SPOCK.dynwinds")))
+ (after)
+ (unwind winds (%inline (1 " - 1") n)) ) )))
+ (lambda (proc)
+ (let ((winds (%host-ref "SPOCK.dynwinds")))
+ (%call-with-current-continuation
+ (lambda (cont)
+ (proc
+ (lambda results ;XXX suboptimal
+ (let ((winds2 (%host-ref "SPOCK.dynwinds")))
+ (unless (eq? winds2 winds)
+ (unwind winds (- (length winds2) (length winds))) )
+ (apply cont results) ) ) ) ) ) ))))
+
+ ))
+
+
+ (define-library-section suspensions
+
+ (default
+
+ (define (%get-context k)
+ (vector
+ k
+ (%host-ref "SPOCK.dynwinds")
+ (%host-ref "SPOCK.stdin")
+ (%host-ref "SPOCK.stdout")
+ (%host-ref "SPOCK.stderr")))
+
+ (define %restore-context
+ (%native-lambda
+ "var state = arguments[ 1 ];"
+ "SPOCK.dynwinds = state[ 1 ];"
+ "SPOCK.stdin = state[ 2 ];"
+ "SPOCK.stdout = state[ 3 ];"
+ "SPOCK.stderr = state[ 4 ];"
+ "return (state[ 0 ])(undefined);")) ; drops K
+
+ ;;XXX currently undocumented and untested
+ (define (suspend proc)
+ (%call-with-current-continuation
+ (lambda (k)
+ (proc (%get-context k))
+ ((%native-lambda "return new SPOCK.Result(undefined);")))))
+
+ ;;XXX currently undocumented and untested
+ (define-inline (resume state)
+ (%restore-context state))
+
+ ))
+
+
+ (define-library-section promises
+
+ (default
+
+ (define (%make-promise thunk)
+ (%inline
+ "new SPOCK.Promise"
+ (let ((ready #f)
+ (results #f))
+ (lambda ()
+ ;;XXX this can possibly be optimized
+ (if ready
+ (apply values results)
+ (call-with-values thunk
+ (lambda xs
+ (cond (ready (apply values results))
+ (else
+ (set! ready #t)
+ (set! results xs)
+ (apply values results))))))))))
+
+ (define (force p)
+ (if (%inline (1 " instanceof SPOCK.Promise") p)
+ ((%property-ref "thunk" p))
+ p))
+
+ ))
+
+
+ (define-library-section port-redirection
+
+ (default
+
+ (define with-input-from-port
+ (let ((dynamic-wind dynamic-wind))
+ (lambda (port thunk)
+ (%check-port port "input" "with-input-from-port")
+ (let ((old #f))
+ (dynamic-wind
+ (lambda ()
+ (set! old (%host-ref "SPOCK.stdin"))
+ (%host-set! "SPOCK.stdin" port))
+ thunk
+ (lambda ()
+ (%host-set! "SPOCK.stdin" old)))))))
+
+ (define with-output-to-port
+ (let ((dynamic-wind dynamic-wind))
+ (lambda (port thunk)
+ (%check-port port "output" "with-output-to-port")
+ (let ((old #f))
+ (dynamic-wind
+ (lambda ()
+ (set! old (%host-ref "SPOCK.stdout"))
+ (%host-set! "SPOCK.stdout" port))
+ thunk
+ (lambda ()
+ (%host-set! "SPOCK.stdout" old)))))))
+
+ ))
+
+
+ (define-library-section file-operations
+
+ (default
+
+ (define-inline (input-port? x)
+ (and (%inline (1 "instanceof SPOCK.Port") x)
+ (eq? "input" (%property-ref "direction" x))))
+
+ (define-inline (output-port? x)
+ (and (%inline (1 "instanceof SPOCK.Port") x)
+ (eq? "output" (%property-ref "direction" x))))
+
+ (define %close-port
+ (%native-lambda
+ "var port = arguments[ 1 ];"
+ "port.close();"
+ "port.closed = true;"
+ "return K(port);"))
+
+ (define open-input-file
+ (%native-lambda
+ "var fn = SPOCK.check(arguments[ 1 ], 'string', 'open-input-file');"
+ "return K(SPOCK.openInputFile(fn));"))
+
+ (define open-output-file
+ (%native-lambda
+ "var fn = SPOCK.check(arguments[ 1 ], 'string', 'open-input-file');"
+ "var exp = null;"
+ "if(arguments.length === 3)"
+ " exp = SPOCK.check(arguments[ 2 ], 'number', 'open-input-file');"
+ "return K(SPOCK.openOutputFile(fn, exp));"))
+
+ (define (close-input-port port)
+ (let ((port (%check-port port "input" "close-input-port")))
+ (%close-port port)))
+
+ (define (close-output-port port)
+ (let ((port (%check-port port "output" "close-output-port")))
+ (%close-port port)))
+
+ (define call-with-input-file
+ (let ((call-with-values call-with-values)
+ (open-input-file open-input-file)
+ (values values)
+ (apply apply))
+ (lambda (file proc)
+ (let ((in (open-input-file file)))
+ (%call-with-saved-values
+ (lambda () (proc in))
+ (lambda ()
+ (close-input-port in)))))))
+
+ (define call-with-output-file
+ (let ((call-with-values call-with-values)
+ (open-output-file open-output-file)
+ (values values)
+ (apply apply))
+ (lambda (file proc)
+ (let ((out (open-output-file file)))
+ (%call-with-saved-values
+ (lambda () (proc out))
+ (lambda ()
+ (close-output-port out)))))))
+
+ (define with-input-from-file
+ (let ((with-input-from-port with-input-from-port)
+ (open-input-file open-input-file)
+ (apply apply)
+ (values values)
+ (call-with-values call-with-values)
+ (close-input-port close-input-port))
+ (lambda (filename thunk)
+ (let ((in (open-input-file filename)))
+ (with-input-from-port in
+ (lambda ()
+ (%call-with-saved-values
+ thunk
+ (lambda ()
+ (close-input-port in)))))))))
+
+ (define with-output-to-file
+ (let ((with-output-to-port with-output-to-port)
+ (open-output-file open-output-file)
+ (apply apply)
+ (values values)
+ (call-with-values call-with-values)
+ (close-output-port close-output-port))
+ (lambda (filename thunk)
+ (let ((out (open-output-file filename)))
+ (with-output-to-port out
+ (lambda ()
+ (%call-with-saved-values
+ thunk
+ (lambda ()
+ (close-output-port out)))))))))
+
+ ))
+
+
+ (define-library-section string-ports
+
+ (default
+
+ (define (open-input-string str)
+ (define open
+ (%native-lambda
+ "var buffer = arguments[ 1 ];"
+ "var pos = 0;"
+ "var len = buffer.length;"
+ "function read(n) {"
+ " if(pos >= len) return SPOCK.EOF;"
+ " var str = buffer.substring(pos, pos + n);"
+ " pos += n;"
+ " return str;}"
+ "return K(new SPOCK.Port('input', { read: read }));"))
+ (open (%string->jstring str)))
+
+ (define open-output-string
+ (%native-lambda
+ "var buffer = [];"
+ "function write(s) { buffer.push(s); }"
+ "var port = new SPOCK.Port('output', { write: write });"
+ "port.buffer = buffer;"
+ "port.isStringPort = true;"
+ "return K(port);"))
+
+ (define (get-output-string port)
+ (let ((port (%check ("SPOCK.Port") port)))
+ (if (not (void? (%property-ref "isStringPort" port)))
+ (let ((str (%jstring->string
+ (%inline ".join" (%property-ref "buffer" port) ""))))
+ (%inline (1 ".buffer = []") port)
+ str)
+ ;;XXX unnecessary in non-debug mode
+ (%inline "SPOCK.error" "bad argument type - not a string port" port))))
+
+ (define (with-input-from-string str thunk)
+ (let ((in (open-input-string str)))
+ (with-input-from-port in thunk)))
+
+ (define (with-output-to-string thunk)
+ (let ((out (open-output-string)))
+ (with-output-to-port out thunk)
+ (get-output-string out)))
+
+ ))
+
+
+ (define-library-section reader
+
+ (default
+
+ (define read
+ (let ((read-char read-char)
+ (reverse reverse)
+ (peek-char peek-char)
+ (list->vector list->vector)
+ (list->string list->string)
+ (current-input-port current-input-port)
+ (string->number string->number))
+ (lambda (port)
+ (let ((port (if (void? port) (current-input-port) port)))
+ (define (parse-token t)
+ (or (string->number t)
+ (string->symbol t)))
+ (define (read1)
+ (let ((c (read-char port)))
+ (if (eof-object? c)
+ c
+ (case c
+ ((#\#) (read-sharp))
+ ((#\() (read-list #\)))
+ ((#\[) (read-list #\]))
+ ((#\{) (read-list #\}))
+ ((#\,) (if (eqv? (peek-char port) #\@)
+ (list 'unquote-splicing (read1))
+ (list 'unquote (read1))))
+ ((#\`) (list 'quasiquote (read1)))
+ ((#\') `',(read1))
+ ((#\;) (skip-line) (read1))
+ ((#\") (read-string))
+ ((#\) #\] #\}) (%error "unexpected delimiter" c))
+ (else
+ (if (char-whitespace? c)
+ (read1)
+ (parse-token (read-token (list c)))))))))
+ (define (skip-line)
+ (let ((c (read-char port)))
+ (unless (or (eof-object? c) (char=? #\newline c))
+ (skip-line))))
+ (define (skip-whitespace) ; returns peeked char
+ (let ((c (peek-char port)))
+ (cond ((char-whitespace? c)
+ (read-char port)
+ (skip-whitespace))
+ (else c))))
+ (define (read-sharp)
+ (let ((c (read-char port)))
+ (if (eof-object? c)
+ (%error "unexpected EOF after `#'")
+ (case c
+ ((#\t #\T) #t)
+ ((#\f #\F) #f)
+ ((#\() (list->vector (read-list #\))))
+ ((#\% #\!) (string->symbol (read-token (list c #\#))))
+ ((#\\)
+ (let ((t (read-token '())))
+ (cond ((string-ci=? "newline" t) #\newline)
+ ((string-ci=? "tab" t) #\tab)
+ ((string-ci=? "space" t) #\space)
+ ((zero? (string-length t))
+ (%error "invalid character syntax"))
+ (else (string-ref t 0)))))
+ (else (%error "invalid `#' syntax" c))))))
+ (define (read-list delim)
+ (let loop ((lst '()))
+ (let ((c (skip-whitespace)))
+ (cond ((eof-object? c)
+ (%error "unexpected EOF while reading list"))
+ ((char=? c delim)
+ (read-char port)
+ (reverse lst))
+ (else
+ (if (eqv? #\. c)
+ (let ((t (read-token '())))
+ (if (string=? "." t)
+ (let ((rest (read1)))
+ (skip-whitespace)
+ (if (eqv? (read-char port) delim)
+ (append (reverse lst) rest)
+ (%error "missing closing delimiter" delim)))
+ (loop (cons (parse-token t)) lst)))
+ (loop (cons (read1) lst))))))))
+ (define (read-string)
+ (let loop ((lst '()))
+ (let ((c (read-char port)))
+ (cond ((eof-object? c)
+ (%error "unexpected EOF while reading string"))
+ ((char=? #\" c)
+ (list->string (reverse lst)))
+ ((char=? #\\ c)
+ (let ((c (read-char port)))
+ (if (eof-object? c)
+ (%error "unexpected EOF while reading string")
+ (case c
+ ((#\n) (loop (cons #\newline lst)))
+ ((#\t) (loop (cons #\tab lst)))
+ (else (loop (cons c lst)))))))
+ (else (loop (cons c lst)))))))
+ (define (read-token prefix)
+ (let loop ((lst prefix)) ; prefix must be in reverse order
+ (let ((c (peek-char port)))
+ (if (or (eof-object? c)
+ (memv c '(#\{ #\} #\( #\) #\[ #\] #\; #\"))
+ (char-whitespace? c))
+ (list->string (reverse lst))
+ (loop (cons (read-char port) lst))))))
+ (read1)))))
+
+ ))
+
+
+ (define-library-section loading
+
+ (default
+
+ (define (load file k)
+ (%inline
+ "SPOCK.load"
+ (%string->jstring file)
+ (and (not (%void? k))
+ (callback k))))
+
+ ))
+
+
+ (define-library-section error-handling
+
+ (default
+
+ ;; (%error MESSAGE ARGUMENTS ...)
+ (define %error
+ (%native-lambda
+ "SPOCK.error.apply(SPOCK.global, Array.prototype.slice.call(arguments, 1));"))
+
+ (define error %error)
+
+ ))
+
+
+ (define-library-section miscellaneous
+
+ (default
+
+ (define (exit code)
+ (%inline "SPOCK.exit" (if (void? code) 0 (%check "number" code))))
+
+ (define (milliseconds thunk)
+ (let ((t0 (%inline "(new Date()).getTime")))
+ (if (void? thunk)
+ t0
+ (let* ((r (thunk)) ;XXX will not handle multiple values
+ (t1 (%inline "(new Date()).getTime")))
+ (%inline (1 "-" 2) t1 t0)))))
+
+ (define-inline (callback proc)
+ (%inline "SPOCK.callback" proc))
+
+ (define-inline (callback-method proc)
+ (%inline "SPOCK.callbackMethod" proc))
+
+ (define (print . args)
+ (for-each display args)
+ (newline))
+
+ (define-inline (id x) x)
+ (define-inline (const x) (lambda _ x))
+ (define-inline (compl f) (lambda (x) (not (f x))))
+
+ (define (o . fns) ;XXX optimize this
+ (if (null? fns)
+ id
+ (let loop ((fns fns))
+ (let ((h (%car fns))
+ (t (%cdr fns)) )
+ (if (null? t)
+ h
+ (lambda (x) (h ((loop t) x))))))))
+
+ (define %
+ (%native-lambda
+ "var o = {};"
+ "for(var i = 1; i < arguments.length; i += 2) {"
+ " var x = arguments[ i ];"
+ " if(typeof x === 'string') o[ x ] = arguments[ i + 1 ];"
+ " else if(x instanceof SPOCK.String)"
+ " o[ x.name ] = arguments[ i + 1 ];"
+ " else SPOCK.error('(%) object key not a string or symbol', x);}"
+ "return K(o);"))
+
+ (define native
+ (%native-lambda
+ "var func = arguments[ 1 ];"
+ "return K(function(k) {"
+ " var args = Array.prototype.splice.call(arguments, 1);"
+ " return k(func.apply(SPOCK.global, args));});"))
+
+ (define native-method
+ (%native-lambda
+ "var func = arguments[ 1 ];"
+ "return K(function(k) {"
+ " var args = Array.prototype.splice.call(arguments, 2);"
+ " return k(func.apply(arguments[ 1 ], args));});"))
+
+ (define bind-method
+ (%native-lambda
+ "var func = arguments[ 1 ];"
+ "var that = arguments[ 2 ];"
+ "return K(function() { return func.apply(that, arguments); });"))
+
+ (define-inline (file-exists? filename)
+ (%inline "SPOCK.fileExists" (%string->jstring filename)))
+
+ (define jstring
+ (%native-lambda
+ "var x = arguments[ 1 ];"
+ "if(typeof x === 'string') return K(x);"
+ "else if(x instanceof SPOCK.String) return K(x.normalize());"
+ "else if(x instanceof SPOCK.Char) return K(x.character);"
+ "else return K(x);"))
+
+ ))
+
+ ))
diff --git a/spock-0.2/spock/match.scm b/spock-0.2/spock/match.scm
@@ -0,0 +1,551 @@
+;;;; matchable.scm -- portable hygienic pattern matcher
+;;
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain. All warranties are disclaimed.
+
+;; Written in fully portable SYNTAX-RULES, with a few non-portable
+;; bits at the end of the file conditioned out with COND-EXPAND.
+
+;; This is a simple generative pattern matcher - each pattern is
+;; expanded into the required tests, calling a failure continuation if
+;; the tests pass. This makes the logic easy to follow and extend,
+;; but produces sub-optimal code in cases where you have many similar
+;; clauses due to repeating the same tests. Nonetheless a smart
+;; compiler should be able to remove the redundant tests. For
+;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
+;; hit.
+
+;; 2008/03/20 - fixing bug where (a ...) matched non-lists
+;; 2008/03/15 - removing redundant check in vector patterns
+;; 2007/09/04 - fixing quasiquote patterns
+;; 2007/07/21 - allowing ellipse patterns in non-final list positions
+;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
+;; (thanks to Taylor Campbell)
+;; 2007/04/08 - clean up, commenting
+;; 2006/12/24 - bugfixes
+;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This is always passed a message, yet won't match the message, and
+;; thus always results in a compile-time error.
+
+(define-syntax match-syntax-error
+ (syntax-rules ()
+ ((_)
+ (match-syntax-error "invalid match-syntax-error usage"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; The basic interface. MATCH just performs some basic syntax
+;; validation, binds the match expression to a temporary variable, and
+;; passes it on to MATCH-NEXT.
+
+(define-syntax match
+ (syntax-rules ()
+ ((match)
+ (match-syntax-error "missing match expression"))
+ ((match atom)
+ (match-syntax-error "missing match clause"))
+ ((match (app ...) (pat . body) ...)
+ (let ((v (app ...)))
+ (match-next v (app ...) (set! (app ...)) (pat . body) ...)))
+ ((match #(vec ...) (pat . body) ...)
+ (let ((v #(vec ...)))
+ (match-next v v (set! v) (pat . body) ...)))
+ ((match atom (pat . body) ...)
+ (match-next atom atom (set! atom) (pat . body) ...))
+ ))
+
+;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
+;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
+;; clauses.
+
+(define-syntax match-next
+ (syntax-rules (=>)
+ ;; no more clauses, the match failed
+ ((match-next v g s)
+ (%check (%error "no matching pattern")))
+ ;; named failure continuation
+ ((match-next v g s (pat (=> failure) . body) . rest)
+ (let ((failure (lambda () (match-next v g s . rest))))
+ ;; match-one analyzes the pattern for us
+ (match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
+ ;; anonymous failure continuation, give it a dummy name
+ ((match-next v g s (pat . body) . rest)
+ (match-next v g s (pat (=> failure) . body) . rest))))
+
+;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
+;; MATCH-TWO.
+
+(define-syntax match-one
+ (syntax-rules ()
+ ;; If it's a list of two values, check to see if the second one is
+ ;; an ellipse and handle accordingly, otherwise go to MATCH-TWO.
+ ((match-one v (p q . r) g s sk fk i)
+ (match-check-ellipse
+ q
+ (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())
+ (match-two v (p q . r) g s sk fk i)))
+ ;; Otherwise, go directly to MATCH-TWO.
+ ((match-one . x)
+ (match-two . x))))
+
+;; This is the guts of the pattern matcher. We are passed a lot of
+;; information in the form:
+;;
+;; (match-two var pattern getter setter success-k fail-k (ids ...))
+;;
+;; where VAR is the symbol name of the current variable we are
+;; matching, PATTERN is the current pattern, getter and setter are the
+;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
+;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
+;; continuation (which is just a thunk call and is thus safe to expand
+;; multiple times) and IDS are the list of identifiers bound in the
+;; pattern so far.
+
+(define-syntax match-two
+ (syntax-rules (_ ___ quote quasiquote ? $ = and or not set! get!)
+ ((match-two v () g s (sk ...) fk i)
+ (if (null? v) (sk ... i) fk))
+ ((match-two v (quote p) g s (sk ...) fk i)
+ (if (equal? v 'p) (sk ... i) fk))
+ ((match-two v (quasiquote p) g s sk fk i)
+ (match-quasiquote v p g s sk fk i))
+ ((match-two v (and) g s (sk ...) fk i) (sk ... i))
+ ((match-two v (and p q ...) g s sk fk i)
+ (match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
+ ((match-two v (or) g s sk fk i) fk)
+ ((match-two v (or p) g s sk fk i)
+ (match-one v p g s sk fk i))
+ ((match-two v (or p ...) g s sk fk i)
+ (match-extract-vars (or p ...)
+ (match-gen-or v (p ...) g s sk fk i)
+ i
+ ()))
+ ((match-two v (not p) g s (sk ...) fk i)
+ (match-one v p g s (match-drop-ids fk) (sk ... i) i))
+ ((match-two v (get! getter) g s (sk ...) fk i)
+ (let ((getter (lambda () g))) (sk ... i)))
+ ((match-two v (set! setter) g (s ...) (sk ...) fk i)
+ (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
+ ((match-two v (? pred p ...) g s sk fk i)
+ (if (pred v) (match-one v (and p ...) g s sk fk i) fk))
+ ((match-two v (= proc p) g s sk fk i)
+ (let ((w (proc v)))
+ (match-one w p g s sk fk i)))
+ ((match-two v (p ___ . r) g s sk fk i)
+ (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()))
+ ((match-two v (p) g s sk fk i)
+ (if (and (pair? v) (null? (cdr v)))
+ (let ((w (car v)))
+ (match-one w p (car v) (set-car! v) sk fk i))
+ fk))
+ ((match-two v (p . q) g s sk fk i)
+ (if (pair? v)
+ (let ((w (car v)) (x (cdr v)))
+ (match-one w p (car v) (set-car! v)
+ (match-one x q (cdr v) (set-cdr! v) sk fk)
+ fk
+ i))
+ fk))
+ ((match-two v #(p ...) g s sk fk i)
+ (match-vector v 0 () (p ...) sk fk i))
+ ((match-two v _ g s (sk ...) fk i) (sk ... i))
+ ;; Not a pair or vector or special literal, test to see if it's a
+ ;; new symbol, in which case we just bind it, or if it's an
+ ;; already bound symbol or some other literal, in which case we
+ ;; compare it with EQUAL?.
+ ((match-two v x g s (sk ...) fk (id ...))
+ (let-syntax
+ ((new-sym?
+ (syntax-rules (id ...)
+ ((new-sym? x sk2 fk2) sk2)
+ ((new-sym? y sk2 fk2) fk2))))
+ (new-sym? abracadabra ; thanks Oleg
+ (let ((x v)) (sk ... (id ... x)))
+ (if (equal? v x) (sk ... (id ...)) fk))))
+ ))
+
+;; QUASIQUOTE patterns
+
+(define-syntax match-quasiquote
+ (syntax-rules (unquote unquote-splicing quasiquote)
+ ((_ v (unquote p) g s sk fk i)
+ (match-one v p g s sk fk i))
+ ((_ v ((unquote-splicing p) . rest) g s sk fk i)
+ (if (pair? v)
+ (match-one v
+ (p . tmp)
+ (match-quasiquote tmp rest g s sk fk)
+ fk
+ i)
+ fk))
+ ((_ v (quasiquote p) g s sk fk i . depth)
+ (match-quasiquote v p g s sk fk i #f . depth))
+ ((_ v (unquote p) g s sk fk i x . depth)
+ (match-quasiquote v p g s sk fk i . depth))
+ ((_ v (unquote-splicing p) g s sk fk i x . depth)
+ (match-quasiquote v p g s sk fk i . depth))
+ ((_ v (p . q) g s sk fk i . depth)
+ (if (pair? v)
+ (let ((w (car v)) (x (cdr v)))
+ (match-quasiquote
+ w p g s
+ (match-quasiquote-step x q g s sk fk depth)
+ fk i . depth))
+ fk))
+ ((_ v #(elt ...) g s sk fk i . depth)
+ (if (vector? v)
+ (let ((ls (vector->list v)))
+ (match-quasiquote ls (elt ...) g s sk fk i . depth))
+ fk))
+ ((_ v x g s sk fk i . depth)
+ (match-one v 'x g s sk fk i))))
+
+(define-syntax match-quasiquote-step
+ (syntax-rules ()
+ ((match-quasiquote-step x q g s sk fk depth i)
+ (match-quasiquote x q g s sk fk i . depth))
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+;; A CPS utility that takes two values and just expands into the
+;; first.
+(define-syntax match-drop-ids
+ (syntax-rules ()
+ ((_ expr ids ...) expr)))
+
+;; Generating OR clauses just involves binding the success
+;; continuation into a thunk which takes the identifiers common to
+;; each OR clause, and trying each clause, calling the thunk as soon
+;; as we succeed.
+
+(define-syntax match-gen-or
+ (syntax-rules ()
+ ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
+ (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
+ (match-gen-or-step
+ v p g s (match-drop-ids (sk2 id ...)) fk (i ...))))))
+
+(define-syntax match-gen-or-step
+ (syntax-rules ()
+ ((_ v () g s sk fk i)
+ ;; no OR clauses, call the failure continuation
+ fk)
+ ((_ v (p) g s sk fk i)
+ ;; last (or only) OR clause, just expand normally
+ (match-one v p g s sk fk i))
+ ((_ v (p . q) g s sk fk i)
+ ;; match one and try the remaining on failure
+ (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))
+ ))
+
+;; We match a pattern (p ...) by matching the pattern p in a loop on
+;; each element of the variable, accumulating the bound ids into lists
+
+;; Look at the body - it's just a named let loop, matching each
+;; element in turn to the same pattern. This illustrates the
+;; simplicity of this generative-style pattern matching. It would be
+;; just as easy to implement a tree searching pattern.
+
+(define-syntax match-gen-ellipses
+ (syntax-rules ()
+ ((_ v p () g s (sk ...) fk i ((id id-ls) ...))
+ (match-check-identifier p
+ (let ((p v))
+ (if (list? p)
+ (sk ... i)
+ fk))
+ (let loop ((ls v) (id-ls '()) ...)
+ (cond
+ ((null? ls)
+ (let ((id (reverse id-ls)) ...) (sk ... i)))
+ ((pair? ls)
+ (let ((w (car ls)))
+ (match-one w p (car ls) (set-car! ls)
+ (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
+ fk i)))
+ (else
+ fk)))))
+ ((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...))
+ (match-verify-no-ellipses
+ (r ...)
+ (let* ((tail-len (length '(r ...)))
+ (ls v)
+ (len (length ls)))
+ (if (< len tail-len)
+ fk
+ (let loop ((ls ls) (n len) (id-ls '()) ...)
+ (cond
+ ((= n tail-len)
+ (let ((id (reverse id-ls)) ...)
+ (match-one ls (r ...) #f #f (sk ... i) fk i)))
+ ((pair? ls)
+ (let ((w (car ls)))
+ (match-one w p (car ls) (set-car! ls)
+ (match-drop-ids
+ (loop (cdr ls) (- n 1) (cons id id-ls) ...))
+ fk
+ i)))
+ (else
+ fk)))))))
+ ))
+
+(define-syntax match-verify-no-ellipses
+ (syntax-rules ()
+ ((_ (x . y) sk)
+ (match-check-ellipse
+ x
+ (match-syntax-error
+ "multiple ellipse patterns not allowed at same level")
+ (match-verify-no-ellipses y sk)))
+ ((_ x sk) sk)
+ ))
+
+;; Vector patterns are just more of the same, with the slight
+;; exception that we pass around the current vector index being
+;; matched.
+
+(define-syntax match-vector
+ (syntax-rules (___)
+ ((_ v n pats (p q) sk fk i)
+ (match-check-ellipse q
+ (match-vector-ellipses v n pats p sk fk i)
+ (match-vector-two v n pats (p q) sk fk i)))
+ ((_ v n pats (p ___) sk fk i)
+ (match-vector-ellipses v n pats p sk fk i))
+ ((_ . x)
+ (match-vector-two . x))))
+
+;; Check the exact vector length, then check each element in turn.
+
+(define-syntax match-vector-two
+ (syntax-rules ()
+ ((_ v n ((pat index) ...) () sk fk i)
+ (if (vector? v)
+ (let ((len (vector-length v)))
+ (if (= len n)
+ (match-vector-step v ((pat index) ...) sk fk i)
+ fk))
+ fk))
+ ((_ v n (pats ...) (p . q) sk fk i)
+ (match-vector v (+ n 1) (pats ... (p n)) q sk fk i))
+ ))
+
+(define-syntax match-vector-step
+ (syntax-rules ()
+ ((_ v () (sk ...) fk i) (sk ... i))
+ ((_ v ((pat index) . rest) sk fk i)
+ (let ((w (vector-ref v index)))
+ (match-one w pat (vector-ref v index) (vector-set! v index)
+ (match-vector-step v rest sk fk)
+ fk i)))))
+
+;; With a vector ellipse pattern we first check to see if the vector
+;; length is at least the required length.
+
+(define-syntax match-vector-ellipses
+ (syntax-rules ()
+ ((_ v n ((pat index) ...) p sk fk i)
+ (if (vector? v)
+ (let ((len (vector-length v)))
+ (if (>= len n)
+ (match-vector-step v ((pat index) ...)
+ (match-vector-tail v p n len sk fk)
+ fk i)
+ fk))
+ fk))))
+
+(define-syntax match-vector-tail
+ (syntax-rules ()
+ ((_ v p n len sk fk i)
+ (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
+
+(define-syntax match-vector-tail-two
+ (syntax-rules ()
+ ((_ v p n len (sk ...) fk i ((id id-ls) ...))
+ (let loop ((j n) (id-ls '()) ...)
+ (if (>= j len)
+ (let ((id (reverse id-ls)) ...) (sk ... i))
+ (let ((w (vector-ref v j)))
+ (match-one w p (vector-ref v j) (vetor-set! v j)
+ (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
+ fk i)))))))
+
+;; Extract all identifiers in a pattern. A little more complicated
+;; than just looking for symbols, we need to ignore special keywords
+;; and not pattern forms (such as the predicate expression in ?
+;; patterns).
+;;
+;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
+
+(define-syntax match-extract-vars
+ (syntax-rules (_ ___ ? $ = quote quasiquote and or not get! set!)
+ ((match-extract-vars (? pred . p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars ($ rec . p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars (= proc p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars (quote x) (k ...) i v)
+ (k ... v))
+ ((match-extract-vars (quasiquote x) k i v)
+ (match-extract-quasiquote-vars x k i v (#t)))
+ ((match-extract-vars (and . p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars (or . p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars (not . p) k i v)
+ (match-extract-vars p k i v))
+ ;; A non-keyword pair, expand the CAR with a continuation to
+ ;; expand the CDR.
+ ((match-extract-vars (p q . r) k i v)
+ (match-check-ellipse
+ q
+ (match-extract-vars (p . r) k i v)
+ (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
+ ((match-extract-vars (p . q) k i v)
+ (match-extract-vars p (match-extract-vars-step q k i v) i ()))
+ ((match-extract-vars #(p ...) k i v)
+ (match-extract-vars (p ...) k i v))
+ ((match-extract-vars _ (k ...) i v) (k ... v))
+ ((match-extract-vars ___ (k ...) i v) (k ... v))
+ ;; This is the main part, the only place where we might add a new
+ ;; var if it's an unbound symbol.
+ ((match-extract-vars p (k ...) (i ...) v)
+ (let-syntax
+ ((new-sym?
+ (syntax-rules (i ...)
+ ((new-sym? p sk fk) sk)
+ ((new-sym? x sk fk) fk))))
+ (new-sym? random-sym-to-match
+ (k ... ((p p-ls) . v))
+ (k ... v))))
+ ))
+
+;; Stepper used in the above so it can expand the CAR and CDR
+;; separately.
+
+(define-syntax match-extract-vars-step
+ (syntax-rules ()
+ ((_ p k i v ((v2 v2-ls) ...))
+ (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
+ ))
+
+(define-syntax match-extract-quasiquote-vars
+ (syntax-rules (quasiquote unquote unquote-splicing)
+ ((match-extract-quasiquote-vars (quasiquote x) k i v d)
+ (match-extract-quasiquote-vars x k i v (#t . d)))
+ ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
+ (match-extract-quasiquote-vars (unquote x) k i v d))
+ ((match-extract-quasiquote-vars (unquote x) k i v (#t))
+ (match-extract-vars x k i v))
+ ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
+ (match-extract-quasiquote-vars x k i v d))
+ ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
+ (match-extract-quasiquote-vars
+ x
+ (match-extract-quasiquote-vars-step y k i v d) i ()))
+ ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
+ (match-extract-quasiquote-vars (x ...) k i v d))
+ ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
+ (k ... v))
+ ))
+
+(define-syntax match-extract-quasiquote-vars-step
+ (syntax-rules ()
+ ((_ x k i v d ((v2 v2-ls) ...))
+ (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
+ ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gimme some sugar baby.
+
+(define-syntax match-lambda
+ (syntax-rules ()
+ ((_ clause ...) (lambda (expr) (match expr clause ...)))))
+
+(define-syntax match-lambda*
+ (syntax-rules ()
+ ((_ clause ...) (lambda expr (match expr clause ...)))))
+
+(define-syntax match-let
+ (syntax-rules ()
+ ((_ (vars ...) . body)
+ (match-let/helper let () () (vars ...) . body))
+ ((_ loop . rest)
+ (match-named-let loop () . rest))))
+
+(define-syntax match-letrec
+ (syntax-rules ()
+ ((_ vars . body) (match-let/helper letrec () () vars . body))))
+
+(define-syntax match-let/helper
+ (syntax-rules ()
+ ((_ let ((var expr) ...) () () . body)
+ (let ((var expr) ...) . body))
+ ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
+ (let ((var expr) ...)
+ (match-let* ((pat tmp) ...)
+ . body)))
+ ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
+ (match-let/helper
+ let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
+ ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
+ (match-let/helper
+ let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
+ ((_ let (v ...) (p ...) ((a expr) . rest) . body)
+ (match-let/helper let (v ... (a expr)) (p ...) rest . body))
+ ))
+
+(define-syntax match-named-let
+ (syntax-rules ()
+ ((_ loop ((pat expr var) ...) () . body)
+ (let loop ((var expr) ...)
+ (match-let ((pat var) ...)
+ . body)))
+ ((_ loop (v ...) ((pat expr) . rest) . body)
+ (match-named-let loop (v ... (pat expr tmp)) rest . body))))
+
+(define-syntax match-let*
+ (syntax-rules ()
+ ((_ () . body)
+ (begin . body))
+ ((_ ((pat expr) . rest) . body)
+ (match expr (pat (match-let* rest . body))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Not quite portable bits.
+
+;; Matching ellipses `...' is tricky. A strict interpretation of R5RS
+;; would suggest that `...' in the literals list would treat it as a
+;; literal in pattern, however no SYNTAX-RULES implementation I'm
+;; aware of currently supports this. SRFI-46 support would makes this
+;; easy, but SRFI-46 also is widely unsupported.
+
+;; In the meantime we conditionally implement this in whatever
+;; low-level macro system is available, defaulting to an
+;; implementation which doesn't support `...' and requires the user to
+;; match with `___'.
+
+(define-syntax match-check-ellipse
+ (syntax-rules ___ (...)
+ ((_ ... sk fk) sk)
+ ((_ x sk fk) fk)))
+
+(define-syntax match-check-identifier
+ (syntax-rules ()
+ ((_ (x . y) sk fk) fk)
+ ((_ #(x ...) sk fk) fk)
+ ((_ x sk fk)
+ (let-syntax
+ ((sym?
+ (syntax-rules ()
+ ((sym? x sk2 fk2) sk2)
+ ((sym? y sk2 fk2) fk2))))
+ (sym? abracadabra sk fk))) ))
diff --git a/spock-0.2/spock/syntax.scm b/spock-0.2/spock/syntax.scm
@@ -0,0 +1,95 @@
+;;;; syntax.scm - various useful macros
+
+
+(define-syntax define-syntax-rule
+ (syntax-rules ___ ()
+ ((_ (name args ___) rule)
+ (define-syntax name
+ (syntax-rules ()
+ ((_ args ___) rule))))))
+
+(define-syntax-rule (when x y z ...)
+ (if x (begin y z ...)))
+
+(define-syntax-rule (unless x y z ...)
+ (if (not x) (begin y z ...)))
+
+(define-syntax cut
+ (syntax-rules (<> <...>)
+ ;; construct fixed- or variable-arity procedure:
+ ((_ "1" (slot-name ...) (proc arg ...))
+ (lambda (slot-name ...) (proc arg ...)))
+ ((_ "1" (slot-name ...) (proc arg ...) <...>)
+ (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot)))
+ ;; process one slot-or-expr
+ ((_ "1" (slot-name ...) (position ...) <> . se)
+ (cut "1" (slot-name ... x) (position ... x) . se))
+ ((_ "1" (slot-name ...) (position ...) nse . se)
+ (cut "1" (slot-name ...) (position ... nse) . se))
+ ((_ . slots-or-exprs)
+ (cut "1" () () . slots-or-exprs))) )
+
+(define-syntax fluid-let
+ (syntax-rules ()
+ ((_ ((v1 e1) ...) b1 b2 ...)
+ (fluid-let "temps" () ((v1 e1) ...) b1 b2 ...))
+ ((_ "temps" (t ...) ((v1 e1) x ...) b1 b2 ...)
+ (let ((temp e1))
+ (fluid-let "temps" ((temp e1 v1) t ...) (x ...) b1 b2 ...)))
+ ((_ "temps" ((t e v) ...) () b1 b2 ...)
+ (let-syntax ((swap!
+ (syntax-rules ()
+ ((swap! a b)
+ (let ((tmp a))
+ (set! a b)
+ (set! b tmp))))))
+ (dynamic-wind
+ (lambda ()
+ (swap! t v) ...)
+ (lambda ()
+ b1 b2 ...)
+ (lambda ()
+ (swap! t v) ...))))))
+
+(define-syntax-rule (begin1 x1 x2 ...)
+ (%call-with-saved-values
+ (lambda () x1)
+ (lambda () (begin x2 ...))))
+
+(define-syntax-rule (syntax-error msg arg ...)
+ (%syntax-error msg arg ...))
+
+(define-syntax-rule (new class arg ...)
+ (%new class arg ...))
+
+(define-syntax define-entry-point
+ (syntax-rules ()
+ ((_ (name . llist) body ...)
+ (define-entry-point name (lambda llist body ...)))
+ ((_ name x)
+ (begin
+ (define name x)
+ (define (%host-set! 'name (callback name)))))))
+
+(define-syntax-rule (define-native name ...)
+ (begin
+ (define-syntax name
+ (native (%host-ref 'name)))
+ ...))
+
+(define-syntax-rule (define-native-method name ...)
+ (begin
+ (define-syntax name
+ (native-method (%host-ref 'name)))
+ ...))
+
+(define-syntax set!
+ (let-syntax ((primitive-set! set!))
+ (syntax-rules ()
+ ((_ (prop x) y)
+ (%property-set! 'prop x y))
+ ((_ var x)
+ (primitive-set! var x)))))
+
+(define-syntax-rule (optional x y)
+ (if (pair? x) (car x) y))
diff --git a/spock-0.2/tests/cells.html b/spock-0.2/tests/cells.html
@@ -0,0 +1,33 @@
+<html>
+<head>
+ <script src="spock-runtime-debug.js"></script>
+ <script src="srfi-25.js"></script>
+ <script type="text/javascript">
+
+var cells = new Array(900);
+var col = true;
+
+function create() {
+for(x = 0; x < 30; ++x) {
+ for(y = 0; y < 30; ++y) {
+ var c = document.createElement("div");
+ cells[ y * 10 + x ] = c;
+ c.style.left = (50 + x * 5) + "px";
+ c.style.top = (50 + y * 5) + "px";
+ c.style.backgroundColor = col ? "red" : "green";
+ c.style.position = "absolute";
+ c.style.width = 5;
+ c.style.height = 5;
+ col = !col;
+ document.body.appendChild(c);
+ }
+}
+}
+
+setTimeout(create, 1000);
+
+</script>
+</head>
+<body style="background-color: #ffffff;">
+</body>
+</html>
diff --git a/spock-0.2/tests/cells.scm b/spock-0.2/tests/cells.scm
@@ -0,0 +1,26 @@
+;;;; cells.scm
+
+
+(define w 30)
+(define h 30)
+
+(define cells (make-array (shape 0 w 0 h)))
+(define col #t)
+
+(define (create)
+ (do ((x 0 (+ x 1)))
+ ((>= x w))
+ (do ((y 0 (+ y 1)))
+ ((>= y h))
+ (let ((div ((native document.createElement) "div")))
+ (array-set! cells x y div)
+ (set! (.style.left div) (string-append (number->string (+ (* x 5) 50)) "px"))
+ (set! (.style.top div) (string-append (number->string (+ (* y 5) 50)) "px"))
+ (set! (.stype.backgroundColor div) (if col "red" "green"))
+ (set! (.stype.position div) "absolute")
+ (set! (.stype.width div) 5)
+ (set! (.stype.height div) 5)
+ (set! col (not col))
+ ((native document.body.appendChild) div)))))
+
+(create)
diff --git a/spock-0.2/tests/drag.html b/spock-0.2/tests/drag.html
@@ -0,0 +1,35 @@
+<!-- drag.html - simple example for SPOCK -->
+
+<html>
+ <head>
+ <script src="spock-runtime-debug.js"></script>
+ <script src="drag.js"></script>
+ <style type="text/css">
+ body {
+ font-family: Arial, Helvetica;
+ font-size: x-large;
+ }
+
+ #info {
+ position: absolute;
+ right-margin: auto;
+ left: 0px;
+ top-margin: auto;
+ bottom: 0px;
+ }
+
+ #box {
+ width: 200px;
+ height: 200px;
+ background-color: red;
+ position: absolute;
+ left: 50%;
+ top: 50%;
+ }
+ </style>
+ </head>
+ <body>
+ <div id="info">xxx</div>
+ <div id="box">Drag me.</div>
+ </body>
+</html>
diff --git a/spock-0.2/tests/drag.scm b/spock-0.2/tests/drag.scm
@@ -0,0 +1,44 @@
+;;;; drag.scm
+
+
+(define (box) (%inline "document.getElementById" "box"))
+(define (info) (%inline "document.getElementById" "info"))
+
+(define down #f)
+
+(define (mouse-position event)
+ (values
+ (- (+ (.clientX event) document.body.scrollLeft) document.body.clientLeft)
+ (- (+ (.clientY event) document.body.scrollTop) document.body.clientTop)))
+
+(define (mouse-move event)
+ (let ((event (if (void? event) window.event event)))
+ (when down
+ (call-with-values (cut mouse-position event)
+ (lambda (x y)
+ (move-element (box) x y)
+ (show-position x y))))))
+
+(define (move-element elt x y)
+ (set! (.style.left elt) x)
+ (set! (.style.top elt) y))
+
+(define (move-element-by elt x y)
+ (call-with-values (cut element-position elt)
+ (lambda (x1 y1)
+ (move-element elt (+ x1 x) (+ y1 y)))))
+
+(define (element-position elt)
+ (values
+ (.offsetLeft elt)
+ (.offsetTop elt)))
+
+(define (show-position x y)
+ (set! (.innerHTML (info))
+ (jstring
+ (string-append
+ (number->string x) "/" (number->string y)))))
+
+(set! document.onmousemove (callback mouse-move))
+(set! document.onmousedown (callback (lambda () (set! down #t))))
+(set! document.onmouseup (callback (lambda () (set! down #f))))
diff --git a/spock-0.2/tests/run.scm b/spock-0.2/tests/run.scm
@@ -0,0 +1,18 @@
+;;;; run.scm - overly simplistic spock test
+
+
+(import scheme (chicken base) spock)
+
+(print "\nGenerating some trivial JS:\n")
+
+(display (<spock-header> debug: #t))
+(display #`(print #^(+ 3 4)))
+
+(print "\nUsing `bind':\n")
+(spock 'bind "test-bind.js"
+ 'code '(begin
+ (print ($ "abc"))
+ (print (Math.sin 42))
+ (print (gurgle (vector "yes" "no") 1))
+ (print yes)
+ (set! one.two "ok")))
diff --git a/spock-0.2/tests/srfi-25.scm b/spock-0.2/tests/srfi-25.scm
@@ -0,0 +1,1269 @@
+;;;; srfi-25.scm - Jussi Piitulainen's array library
+
+
+(define array:array-tag (list 'array))
+
+(define (array:make vec ind shp) (vector array:array-tag vec ind shp))
+(define (array:array? x) (and (vector? x) (eq? (vector-ref x 0) array:array-tag)))
+(define (array:vector a) (vector-ref a 1))
+(define (array:index a) (vector-ref a 2))
+(define (array:shape a) (vector-ref a 3))
+
+
+;;; array
+;;; 1997 - 2001 Jussi Piitulainen
+
+
+;;; --- Intro ---
+
+;;; This interface to arrays is based on Alan Bawden's array.scm of
+;;; 1993 (earlier version in the Internet Repository and another
+;;; version in SLIB). This is a complete rewrite, to be consistent
+;;; with the rest of Scheme and to make arrays independent of lists.
+
+;;; Some modifications are due to discussion in srfi-25 mailing list.
+
+;;; (array? obj)
+;;; (make-array shape [obj]) changed arguments
+;;; (shape bound ...) new
+;;; (array shape obj ...) new
+;;; (array-rank array) changed name back
+;;; (array-start array dimension) new
+;;; (array-end array dimension) new
+;;; (array-ref array k ...)
+;;; (array-ref array index) new variant
+;;; (array-set! array k ... obj) changed argument order
+;;; (array-set! array index obj) new variant
+;;; (share-array array shape proc) changed arguments
+
+;;; All other variables in this file have names in "array:".
+
+;;; Should there be a way to make arrays with initial values mapped
+;;; from indices? Sure. The current "initial object" is lame.
+;;;
+;;; Removed (array-shape array) from here. There is a new version
+;;; in arlib though.
+
+;;; --- Representation type dependencies ---
+
+;;; The mapping from array indices to the index to the underlying vector
+;;; is whatever array:optimize returns. The file "opt" provides three
+;;; representations:
+;;;
+;;; mbda) mapping is a procedure that allows an optional argument
+;;; tter) mapping is two procedures that takes exactly the indices
+;;; ctor) mapping is a vector of a constant term and coefficients
+;;;
+;;; Choose one in "opt" to make the optimizer. Then choose the matching
+;;; implementation of array-ref and array-set!.
+;;;
+;;; These should be made macros to inline them. Or have a good compiler
+;;; and plant the package as a module.
+
+;;; 1. Pick an optimizer.
+;;; 2. Pick matching index representation.
+;;; 3. Pick a record implementation; as-procedure is generic; syntax inlines.
+;;; 3. This file is otherwise portable.
+
+;;; --- Portable R5RS (R4RS and multiple values) ---
+
+;;; (array? obj)
+;;; returns #t if `obj' is an array and #t or #f otherwise.
+
+(define (array? obj)
+ (array:array? obj))
+
+(define-syntax check-array
+ (syntax-rules ()
+ ((_ x loc)
+ (let ((var x))
+ (or (##core#check (array:array? var))
+ (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not an array") var) ) ) ) ) )
+
+;;; (make-array shape)
+;;; (make-array shape obj)
+;;; makes array of `shape' with each cell containing `obj' initially.
+
+(define (make-array shape . rest)
+ (or (##core#check (array:good-shape? shape))
+ (##sys#signal-hook #:type-error 'make-array "bad argument type - not a valid shape" shape))
+ (apply array:make-array shape rest))
+
+(define (array:make-array shape . rest)
+ (let ((size (array:size shape)))
+ (array:make
+ (if (pair? rest)
+ (apply (lambda (o) (make-vector size o)) rest)
+ (make-vector size))
+ (if (= size 0)
+ (array:optimize-empty
+ (vector-ref (array:shape shape) 1))
+ (array:optimize
+ (array:make-index shape)
+ (vector-ref (array:shape shape) 1)))
+ (array:shape->vector shape))))
+
+;;; (shape bound ...)
+;;; makes a shape. Bounds must be an even number of exact, pairwise
+;;; non-decreasing integers. Note that any such array can be a shape.
+
+(define (shape . bounds)
+ (let ((v (list->vector bounds)))
+ (or (##core#check (even? (vector-length v)))
+ (##sys#error 'shape "uneven number of bounds" bounds) )
+ (let ((shp (array:make
+ v
+ (if (pair? bounds)
+ (array:shape-index)
+ (array:empty-shape-index))
+ (vector 0 (quotient (vector-length v) 2)
+ 0 2))))
+ (or (##core#check (array:good-shape? shp))
+ (##sys#signal-hook #:type-error 'shape "bounds are not pairwise non-decreasing exact integers" bounds) )
+ shp)))
+
+;;; (array shape obj ...)
+;;; is analogous to `vector'.
+
+(define (array shape . elts)
+ (or (##core#check (array:good-shape? shape))
+ (##sys#signal-hook #:type-error 'array "bad argument type - not a valid shape" shape) )
+ (let ((size (array:size shape)))
+ (let ((vector (list->vector elts)))
+ (or (##core#check (= (vector-length vector) size))
+ (##sys#error 'array "bad number of elements" shape elts) )
+ (array:make
+ vector
+ (if (= size 0)
+ (array:optimize-empty
+ (vector-ref (array:shape shape) 1))
+ (array:optimize
+ (array:make-index shape)
+ (vector-ref (array:shape shape) 1)))
+ (array:shape->vector shape)))))
+
+;;; (array-rank array)
+;;; returns the number of dimensions of `array'.
+
+(define (array-rank array)
+ (check-array array 'array-rank)
+ (quotient (vector-length (array:shape array)) 2))
+
+;;; (array-start array k)
+;;; returns the lower bound index of array along dimension k. This is
+;;; the least valid index along that dimension if the dimension is not
+;;; empty.
+
+(define (array-start array d)
+ (check-array array 'array-start)
+ (vector-ref (array:shape array) (+ d d)))
+
+;;; (array-end array k)
+;;; returns the upper bound index of array along dimension k. This is
+;;; not a valid index. If the dimension is empty, this is the same as
+;;; the lower bound along it.
+
+(define (array-end array d)
+ (check-array array 'array-end)
+ (vector-ref (array:shape array) (+ d d 1)))
+
+;;; (share-array array shape proc)
+;;; makes an array that shares elements of `array' at shape `shape'.
+;;; The arguments to `proc' are indices of the result. The values of
+;;; `proc' are indices of `array'.
+
+;;; Todo: in the error message, should recognise the mapping and show it.
+
+(define (share-array array subshape f)
+ (check-array array 'share-array)
+ (or (##core#check (array:good-shape? subshape))
+ (##sys#signal-hook #:type-error 'share-array "not a shape" subshape) )
+ (let ((subsize (array:size subshape)))
+ (or (##core#check (array:good-share? subshape subsize f (array:shape array)))
+ (##sys#error 'share-array "subshape does not map into supershape" subshape shape) )
+ (let ((g (array:index array)))
+ (array:make
+ (array:vector array)
+ (if (= subsize 0)
+ (array:optimize-empty
+ (vector-ref (array:shape subshape) 1))
+ (array:optimize
+ (lambda ks
+ (call-with-values
+ (lambda () (apply f ks))
+ (lambda ks (array:vector-index g ks))))
+ (vector-ref (array:shape subshape) 1)))
+ (array:shape->vector subshape)))))
+
+;;; --- Hrmph ---
+
+;;; (array:share/index! ...)
+;;; reuses a user supplied index object when recognising the
+;;; mapping. The mind balks at the very nasty side effect that
+;;; exposes the implementation. So this is not in the spec.
+;;; But letting index objects in at all creates a pressure
+;;; to go the whole hog. Arf.
+
+;;; Use array:optimize-empty for an empty array to get a
+;;; clearly invalid vector index.
+
+;;; Surely it's perverse to use an actor for index here? But
+;;; the possibility is provided for completeness.
+
+(define (array:share/index! array subshape proc index)
+ (array:make
+ (array:vector array)
+ (if (= (array:size subshape) 0)
+ (array:optimize-empty
+ (quotient (vector-length (array:shape array)) 2))
+ ((if (vector? index)
+ array:optimize/vector
+ array:optimize/actor)
+ (lambda (subindex)
+ (let ((superindex (proc subindex)))
+ (if (vector? superindex)
+ (array:index/vector
+ (quotient (vector-length (array:shape array)) 2)
+ (array:index array)
+ superindex)
+ (array:index/array
+ (quotient (vector-length (array:shape array)) 2)
+ (array:index array)
+ (array:vector superindex)
+ (array:index superindex)))))
+ index))
+ (array:shape->vector subshape)))
+
+(define (array:optimize/vector f v)
+ (let ((r (vector-length v)))
+ (do ((k 0 (+ k 1)))
+ ((= k r))
+ (vector-set! v k 0))
+ (let ((n0 (f v))
+ (cs (make-vector (+ r 1)))
+ (apply (array:applier-to-vector (+ r 1))))
+ (vector-set! cs 0 n0)
+ (let wok ((k 0))
+ (if (< k r)
+ (let ((k1 (+ k 1)))
+ (vector-set! v k 1)
+ (let ((nk (- (f v) n0)))
+ (vector-set! v k 0)
+ (vector-set! cs k1 nk)
+ (wok k1)))))
+ (apply (array:maker r) cs))))
+
+(define (array:optimize/actor f a)
+ (let ((r (array-end a 0))
+ (v (array:vector a))
+ (i (array:index a)))
+ (do ((k 0 (+ k 1)))
+ ((= k r))
+ (vector-set! v (array:actor-index i k) 0))
+ (let ((n0 (f a))
+ (cs (make-vector (+ r 1)))
+ (apply (array:applier-to-vector (+ r 1))))
+ (vector-set! cs 0 n0)
+ (let wok ((k 0))
+ (if (< k r)
+ (let ((k1 (+ k 1))
+ (t (array:actor-index i k)))
+ (vector-set! v t 1)
+ (let ((nk (- (f a) n0)))
+ (vector-set! v t 0)
+ (vector-set! cs k1 nk)
+ (wok k1)))))
+ (apply (array:maker r) cs))))
+
+;;; --- Internals ---
+
+(define (array:shape->vector shape)
+ (let ((idx (array:index shape))
+ (shv (array:vector shape))
+ (rnk (vector-ref (array:shape shape) 1)))
+ (let ((vec (make-vector (* rnk 2))))
+ (do ((k 0 (+ k 1)))
+ ((= k rnk)
+ vec)
+ (vector-set! vec (+ k k)
+ (vector-ref shv (array:shape-vector-index idx k 0)))
+ (vector-set! vec (+ k k 1)
+ (vector-ref shv (array:shape-vector-index idx k 1)))))))
+
+;;; (array:size shape)
+;;; returns the number of elements in arrays of shape `shape'.
+
+(define (array:size shape)
+ (let ((idx (array:index shape))
+ (shv (array:vector shape))
+ (rnk (vector-ref (array:shape shape) 1)))
+ (do ((k 0 (+ k 1))
+ (s 1 (* s
+ (- (vector-ref shv (array:shape-vector-index idx k 1))
+ (vector-ref shv (array:shape-vector-index idx k 0))))))
+ ((= k rnk) s))))
+
+;;; (array:make-index shape)
+;;; returns an index function for arrays of shape `shape'. This is a
+;;; runtime composition of several variable arity procedures, to be
+;;; passed to array:optimize for recognition as an affine function of
+;;; as many variables as there are dimensions in arrays of this shape.
+
+(define (array:make-index shape)
+ (let ((idx (array:index shape))
+ (shv (array:vector shape))
+ (rnk (vector-ref (array:shape shape) 1)))
+ (do ((f (lambda () 0)
+ (lambda (k . ks)
+ (+ (* s (- k (vector-ref
+ shv
+ (array:shape-vector-index idx (- j 1) 0))))
+ (apply f ks))))
+ (s 1 (* s (- (vector-ref
+ shv
+ (array:shape-vector-index idx (- j 1) 1))
+ (vector-ref
+ shv
+ (array:shape-vector-index idx (- j 1) 0)))))
+ (j rnk (- j 1)))
+ ((= j 0)
+ f))))
+
+
+;;; --- Error checking ---
+
+;;; (array:good-shape? shape)
+;;; returns true if `shape' is an array of the right shape and its
+;;; elements are exact integers that pairwise bound intervals `[lo..hi)´.
+
+(define (array:good-shape? shape)
+ (and (array:array? shape)
+ (let ((u (array:shape shape))
+ (v (array:vector shape))
+ (x (array:index shape)))
+ (and (= (vector-length u) 4)
+ (= (vector-ref u 0) 0)
+ (= (vector-ref u 2) 0)
+ (= (vector-ref u 3) 2))
+ (let ((p (vector-ref u 1)))
+ (do ((k 0 (+ k 1))
+ (true #t (let ((lo (vector-ref
+ v
+ (array:shape-vector-index x k 0)))
+ (hi (vector-ref
+ v
+ (array:shape-vector-index x k 1))))
+ (and true
+ (integer? lo)
+ (exact? lo)
+ (integer? hi)
+ (exact? hi)
+ (<= lo hi)))))
+ ((= k p) true))))))
+
+;;; (array:good-share? subv subsize mapping superv)
+;;; returns true if the extreme indices in the subshape vector map
+;;; into the bounds in the supershape vector.
+
+;;; If some interval in `subv' is empty, then `subv' is empty and its
+;;; image under `f' is empty and it is trivially alright. One must
+;;; not call `f', though.
+
+(define (array:good-share? subshape subsize f super)
+ (or (zero? subsize)
+ (letrec
+ ((sub (array:vector subshape))
+ (dex (array:index subshape))
+ (ck (lambda (k ks)
+ (if (zero? k)
+ (call-with-values
+ (lambda () (apply f ks))
+ (lambda qs (array:good-indices? qs super)))
+ (and (ck (- k 1)
+ (cons (vector-ref
+ sub
+ (array:shape-vector-index
+ dex
+ (- k 1)
+ 0))
+ ks))
+ (ck (- k 1)
+ (cons (- (vector-ref
+ sub
+ (array:shape-vector-index
+ dex
+ (- k 1)
+ 1))
+ 1)
+ ks)))))))
+ (let ((rnk (vector-ref (array:shape subshape) 1)))
+ (or (array:unchecked-share-depth? rnk)
+ (ck rnk '()))))))
+
+;;; Check good-share on 10 dimensions at most. The trouble is,
+;;; the cost of this check is exponential in the number of dimensions.
+
+(define (array:unchecked-share-depth? rank)
+ (if (> rank 10)
+ (begin
+ (display `(warning: unchecked depth in share:
+ ,rank subdimensions))
+ (newline)
+ #t)
+ #f))
+
+;;; (array:check-indices caller indices shape-vector)
+;;; (array:check-indices.o caller indices shape-vector)
+;;; (array:check-index-vector caller index-vector shape-vector)
+;;; return if the index is in bounds, else signal error.
+;;;
+;;; Shape-vector is the internal representation, with
+;;; b and e for dimension k at 2k and 2k + 1.
+
+(define (array:check-indices who ks shv)
+ (or (array:good-indices? ks shv)
+ (##sys#signal-hook #:bounds-error (array:not-in who ks shv))))
+
+(define (array:check-indices.o who ks shv)
+ (or (array:good-indices.o? ks shv)
+ (##sys#signal-hook #:bounds-error (array:not-in who (reverse (cdr (reverse ks))) shv))))
+
+(define (array:check-index-vector who ks shv)
+ (or (array:good-index-vector? ks shv)
+ (##sys#signal-hook #:bounds-error (array:not-in who (vector->list ks) shv))))
+
+(define (array:check-index-actor who ks shv)
+ (let ((shape (array:shape ks)))
+ (or (and (= (vector-length shape) 2)
+ (= (vector-ref shape 0) 0))
+ (##sys#signal-hook #:type-error "not an actor"))
+ (or (array:good-index-actor?
+ (vector-ref shape 1)
+ (array:vector ks)
+ (array:index ks)
+ shv)
+ (array:not-in who (do ((k (vector-ref shape 1) (- k 1))
+ (m '() (cons (vector-ref
+ (array:vector ks)
+ (array:actor-index
+ (array:index ks)
+ (- k 1)))
+ m)))
+ ((= k 0) m))
+ shv))))
+
+(define (array:good-indices? ks shv)
+ (let ((d2 (vector-length shv)))
+ (do ((kp ks (if (pair? kp)
+ (cdr kp)))
+ (k 0 (+ k 2))
+ (true #t (and true (pair? kp)
+ (array:good-index? (car kp) shv k))))
+ ((= k d2)
+ (and true (null? kp))))))
+
+(define (array:good-indices.o? ks.o shv)
+ (let ((d2 (vector-length shv)))
+ (do ((kp ks.o (if (pair? kp)
+ (cdr kp)))
+ (k 0 (+ k 2))
+ (true #t (and true (pair? kp)
+ (array:good-index? (car kp) shv k))))
+ ((= k d2)
+ (and true (pair? kp) (null? (cdr kp)))))))
+
+(define (array:good-index-vector? ks shv)
+ (let ((r2 (vector-length shv)))
+ (and (= (* 2 (vector-length ks)) r2)
+ (do ((j 0 (+ j 1))
+ (k 0 (+ k 2))
+ (true #t (and true
+ (array:good-index? (vector-ref ks j) shv k))))
+ ((= k r2) true)))))
+
+(define (array:good-index-actor? r v i shv)
+ (and (= (* 2 r) (vector-length shv))
+ (do ((j 0 (+ j 1))
+ (k 0 (+ k 2))
+ (true #t (and true
+ (array:good-index? (vector-ref
+ v
+ (array:actor-index i j))
+ shv
+ k))))
+ ((= j r) true))))
+
+;;; (array:good-index? index shape-vector 2d)
+;;; returns true if index is within bounds for dimension 2d/2.
+
+(define (array:good-index? w shv k)
+ (and (integer? w)
+ (exact? w)
+ (<= (vector-ref shv k) w)
+ (< w (vector-ref shv (+ k 1)))))
+
+(define (array:not-in who ks shv)
+ (##sys#signal-hook #:bounds-error (string-append who ": index not in bounds") ks shv) )
+
+
+(begin
+ (define (array:coefficients f n0 vs vp)
+ (case vp
+ ((()) '())
+ (else
+ (set-car! vp 1)
+ (let ((n (- (apply f vs) n0)))
+ (set-car! vp 0)
+ (cons n (array:coefficients f n0 vs (cdr vp)))))))
+ (define (array:vector-index x ks)
+ (do ((sum 0 (+ sum (* (vector-ref x k) (car ks))))
+ (ks ks (cdr ks))
+ (k 0 (+ k 1)))
+ ((null? ks) (+ sum (vector-ref x k)))))
+ (define (array:shape-index) '#(2 1 0))
+ (define (array:empty-shape-index) '#(0 0 -1))
+ (define (array:shape-vector-index x r k)
+ (+
+ (* (vector-ref x 0) r)
+ (* (vector-ref x 1) k)
+ (vector-ref x 2)))
+ (define (array:actor-index x k)
+ (+ (* (vector-ref x 0) k) (vector-ref x 1)))
+ (define (array:0 n0) (vector n0))
+ (define (array:1 n0 n1) (vector n1 n0))
+ (define (array:2 n0 n1 n2) (vector n1 n2 n0))
+ (define (array:3 n0 n1 n2 n3) (vector n1 n2 n3 n0))
+ (define (array:n n0 n1 n2 n3 n4 . ns)
+ (apply vector n1 n2 n3 n4 (append ns (list n0))))
+ (define (array:maker r)
+ (case r
+ ((0) array:0)
+ ((1) array:1)
+ ((2) array:2)
+ ((3) array:3)
+ (else array:n)))
+ (define array:indexer/vector
+ (let ((em
+ (vector
+ (lambda (x i) (+ (vector-ref x 0)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (vector-ref x 1)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (vector-ref x 2)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (* (vector-ref x 2) (vector-ref i 2))
+ (vector-ref x 3)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (* (vector-ref x 2) (vector-ref i 2))
+ (* (vector-ref x 3) (vector-ref i 3))
+ (vector-ref x 4)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (* (vector-ref x 2) (vector-ref i 2))
+ (* (vector-ref x 3) (vector-ref i 3))
+ (* (vector-ref x 4) (vector-ref i 4))
+ (vector-ref x 5)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (* (vector-ref x 2) (vector-ref i 2))
+ (* (vector-ref x 3) (vector-ref i 3))
+ (* (vector-ref x 4) (vector-ref i 4))
+ (* (vector-ref x 5) (vector-ref i 5))
+ (vector-ref x 6)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (* (vector-ref x 2) (vector-ref i 2))
+ (* (vector-ref x 3) (vector-ref i 3))
+ (* (vector-ref x 4) (vector-ref i 4))
+ (* (vector-ref x 5) (vector-ref i 5))
+ (* (vector-ref x 6) (vector-ref i 6))
+ (vector-ref x 7)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (* (vector-ref x 2) (vector-ref i 2))
+ (* (vector-ref x 3) (vector-ref i 3))
+ (* (vector-ref x 4) (vector-ref i 4))
+ (* (vector-ref x 5) (vector-ref i 5))
+ (* (vector-ref x 6) (vector-ref i 6))
+ (* (vector-ref x 7) (vector-ref i 7))
+ (vector-ref x 8)))
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (* (vector-ref x 2) (vector-ref i 2))
+ (* (vector-ref x 3) (vector-ref i 3))
+ (* (vector-ref x 4) (vector-ref i 4))
+ (* (vector-ref x 5) (vector-ref i 5))
+ (* (vector-ref x 6) (vector-ref i 6))
+ (* (vector-ref x 7) (vector-ref i 7))
+ (* (vector-ref x 8) (vector-ref i 8))
+ (vector-ref x 9)))))
+ (it
+ (lambda (w)
+ (lambda (x i)
+ (+
+ (* (vector-ref x 0) (vector-ref i 0))
+ (* (vector-ref x 1) (vector-ref i 1))
+ (* (vector-ref x 2) (vector-ref i 2))
+ (* (vector-ref x 3) (vector-ref i 3))
+ (* (vector-ref x 4) (vector-ref i 4))
+ (* (vector-ref x 5) (vector-ref i 5))
+ (* (vector-ref x 6) (vector-ref i 6))
+ (* (vector-ref x 7) (vector-ref i 7))
+ (* (vector-ref x 8) (vector-ref i 8))
+ (* (vector-ref x 9) (vector-ref i 9))
+ (do ((xi
+ 0
+ (+
+ (* (vector-ref x u) (vector-ref i u))
+ xi))
+ (u (- w 1) (- u 1)))
+ ((< u 10) xi))
+ (vector-ref x w))))))
+ (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+ (define array:indexer/array
+ (let ((em
+ (vector
+ (lambda (x v i) (+ (vector-ref x 0)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (vector-ref x 1)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (vector-ref x 2)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (*
+ (vector-ref x 2)
+ (vector-ref v (array:actor-index i 2)))
+ (vector-ref x 3)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (*
+ (vector-ref x 2)
+ (vector-ref v (array:actor-index i 2)))
+ (*
+ (vector-ref x 3)
+ (vector-ref v (array:actor-index i 3)))
+ (vector-ref x 4)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (*
+ (vector-ref x 2)
+ (vector-ref v (array:actor-index i 2)))
+ (*
+ (vector-ref x 3)
+ (vector-ref v (array:actor-index i 3)))
+ (*
+ (vector-ref x 4)
+ (vector-ref v (array:actor-index i 4)))
+ (vector-ref x 5)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (*
+ (vector-ref x 2)
+ (vector-ref v (array:actor-index i 2)))
+ (*
+ (vector-ref x 3)
+ (vector-ref v (array:actor-index i 3)))
+ (*
+ (vector-ref x 4)
+ (vector-ref v (array:actor-index i 4)))
+ (*
+ (vector-ref x 5)
+ (vector-ref v (array:actor-index i 5)))
+ (vector-ref x 6)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (*
+ (vector-ref x 2)
+ (vector-ref v (array:actor-index i 2)))
+ (*
+ (vector-ref x 3)
+ (vector-ref v (array:actor-index i 3)))
+ (*
+ (vector-ref x 4)
+ (vector-ref v (array:actor-index i 4)))
+ (*
+ (vector-ref x 5)
+ (vector-ref v (array:actor-index i 5)))
+ (*
+ (vector-ref x 6)
+ (vector-ref v (array:actor-index i 6)))
+ (vector-ref x 7)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (*
+ (vector-ref x 2)
+ (vector-ref v (array:actor-index i 2)))
+ (*
+ (vector-ref x 3)
+ (vector-ref v (array:actor-index i 3)))
+ (*
+ (vector-ref x 4)
+ (vector-ref v (array:actor-index i 4)))
+ (*
+ (vector-ref x 5)
+ (vector-ref v (array:actor-index i 5)))
+ (*
+ (vector-ref x 6)
+ (vector-ref v (array:actor-index i 6)))
+ (*
+ (vector-ref x 7)
+ (vector-ref v (array:actor-index i 7)))
+ (vector-ref x 8)))
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (*
+ (vector-ref x 2)
+ (vector-ref v (array:actor-index i 2)))
+ (*
+ (vector-ref x 3)
+ (vector-ref v (array:actor-index i 3)))
+ (*
+ (vector-ref x 4)
+ (vector-ref v (array:actor-index i 4)))
+ (*
+ (vector-ref x 5)
+ (vector-ref v (array:actor-index i 5)))
+ (*
+ (vector-ref x 6)
+ (vector-ref v (array:actor-index i 6)))
+ (*
+ (vector-ref x 7)
+ (vector-ref v (array:actor-index i 7)))
+ (*
+ (vector-ref x 8)
+ (vector-ref v (array:actor-index i 8)))
+ (vector-ref x 9)))))
+ (it
+ (lambda (w)
+ (lambda (x v i)
+ (+
+ (*
+ (vector-ref x 0)
+ (vector-ref v (array:actor-index i 0)))
+ (*
+ (vector-ref x 1)
+ (vector-ref v (array:actor-index i 1)))
+ (*
+ (vector-ref x 2)
+ (vector-ref v (array:actor-index i 2)))
+ (*
+ (vector-ref x 3)
+ (vector-ref v (array:actor-index i 3)))
+ (*
+ (vector-ref x 4)
+ (vector-ref v (array:actor-index i 4)))
+ (*
+ (vector-ref x 5)
+ (vector-ref v (array:actor-index i 5)))
+ (*
+ (vector-ref x 6)
+ (vector-ref v (array:actor-index i 6)))
+ (*
+ (vector-ref x 7)
+ (vector-ref v (array:actor-index i 7)))
+ (*
+ (vector-ref x 8)
+ (vector-ref v (array:actor-index i 8)))
+ (*
+ (vector-ref x 9)
+ (vector-ref v (array:actor-index i 9)))
+ (do ((xi
+ 0
+ (+
+ (*
+ (vector-ref x u)
+ (vector-ref
+ v
+ (array:actor-index i u)))
+ xi))
+ (u (- w 1) (- u 1)))
+ ((< u 10) xi))
+ (vector-ref x w))))))
+ (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+ (define array:applier-to-vector
+ (let ((em
+ (vector
+ (lambda (p v) (p))
+ (lambda (p v) (p (vector-ref v 0)))
+ (lambda (p v)
+ (p (vector-ref v 0) (vector-ref v 1)))
+ (lambda (p v)
+ (p
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)))
+ (lambda (p v)
+ (p
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)
+ (vector-ref v 3)))
+ (lambda (p v)
+ (p
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)
+ (vector-ref v 3)
+ (vector-ref v 4)))
+ (lambda (p v)
+ (p
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)
+ (vector-ref v 3)
+ (vector-ref v 4)
+ (vector-ref v 5)))
+ (lambda (p v)
+ (p
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)
+ (vector-ref v 3)
+ (vector-ref v 4)
+ (vector-ref v 5)
+ (vector-ref v 6)))
+ (lambda (p v)
+ (p
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)
+ (vector-ref v 3)
+ (vector-ref v 4)
+ (vector-ref v 5)
+ (vector-ref v 6)
+ (vector-ref v 7)))
+ (lambda (p v)
+ (p
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)
+ (vector-ref v 3)
+ (vector-ref v 4)
+ (vector-ref v 5)
+ (vector-ref v 6)
+ (vector-ref v 7)
+ (vector-ref v 8)))))
+ (it
+ (lambda (r)
+ (lambda (p v)
+ (apply
+ p
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)
+ (vector-ref v 3)
+ (vector-ref v 4)
+ (vector-ref v 5)
+ (vector-ref v 6)
+ (vector-ref v 7)
+ (vector-ref v 8)
+ (vector-ref v 9)
+ (do ((k r (- k 1))
+ (r
+ '()
+ (cons (vector-ref v (- k 1)) r)))
+ ((= k 10) r)))))))
+ (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+ (define array:applier-to-actor
+ (let ((em
+ (vector
+ (lambda (p a) (p))
+ (lambda (p a) (p (array-ref a 0)))
+ (lambda (p a)
+ (p (array-ref a 0) (array-ref a 1)))
+ (lambda (p a)
+ (p
+ (array-ref a 0)
+ (array-ref a 1)
+ (array-ref a 2)))
+ (lambda (p a)
+ (p
+ (array-ref a 0)
+ (array-ref a 1)
+ (array-ref a 2)
+ (array-ref a 3)))
+ (lambda (p a)
+ (p
+ (array-ref a 0)
+ (array-ref a 1)
+ (array-ref a 2)
+ (array-ref a 3)
+ (array-ref a 4)))
+ (lambda (p a)
+ (p
+ (array-ref a 0)
+ (array-ref a 1)
+ (array-ref a 2)
+ (array-ref a 3)
+ (array-ref a 4)
+ (array-ref a 5)))
+ (lambda (p a)
+ (p
+ (array-ref a 0)
+ (array-ref a 1)
+ (array-ref a 2)
+ (array-ref a 3)
+ (array-ref a 4)
+ (array-ref a 5)
+ (array-ref a 6)))
+ (lambda (p a)
+ (p
+ (array-ref a 0)
+ (array-ref a 1)
+ (array-ref a 2)
+ (array-ref a 3)
+ (array-ref a 4)
+ (array-ref a 5)
+ (array-ref a 6)
+ (array-ref a 7)))
+ (lambda (p a)
+ (p
+ (array-ref a 0)
+ (array-ref a 1)
+ (array-ref a 2)
+ (array-ref a 3)
+ (array-ref a 4)
+ (array-ref a 5)
+ (array-ref a 6)
+ (array-ref a 7)
+ (array-ref a 8)))))
+ (it
+ (lambda (r)
+ (lambda (p a)
+ (apply
+ a
+ (array-ref a 0)
+ (array-ref a 1)
+ (array-ref a 2)
+ (array-ref a 3)
+ (array-ref a 4)
+ (array-ref a 5)
+ (array-ref a 6)
+ (array-ref a 7)
+ (array-ref a 8)
+ (array-ref a 9)
+ (do ((k r (- k 1))
+ (r '() (cons (array-ref a (- k 1)) r)))
+ ((= k 10) r)))))))
+ (lambda (r)
+ "These are high level, hiding implementation at call site."
+ (if (< r 10) (vector-ref em r) (it r)))))
+ (define array:applier-to-backing-vector
+ (let ((em
+ (vector
+ (lambda (p ai av) (p))
+ (lambda (p ai av)
+ (p (vector-ref av (array:actor-index ai 0))))
+ (lambda (p ai av)
+ (p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))))
+ (lambda (p ai av)
+ (p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))
+ (vector-ref av (array:actor-index ai 2))))
+ (lambda (p ai av)
+ (p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))
+ (vector-ref av (array:actor-index ai 2))
+ (vector-ref av (array:actor-index ai 3))))
+ (lambda (p ai av)
+ (p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))
+ (vector-ref av (array:actor-index ai 2))
+ (vector-ref av (array:actor-index ai 3))
+ (vector-ref av (array:actor-index ai 4))))
+ (lambda (p ai av)
+ (p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))
+ (vector-ref av (array:actor-index ai 2))
+ (vector-ref av (array:actor-index ai 3))
+ (vector-ref av (array:actor-index ai 4))
+ (vector-ref av (array:actor-index ai 5))))
+ (lambda (p ai av)
+ (p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))
+ (vector-ref av (array:actor-index ai 2))
+ (vector-ref av (array:actor-index ai 3))
+ (vector-ref av (array:actor-index ai 4))
+ (vector-ref av (array:actor-index ai 5))
+ (vector-ref av (array:actor-index ai 6))))
+ (lambda (p ai av)
+ (p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))
+ (vector-ref av (array:actor-index ai 2))
+ (vector-ref av (array:actor-index ai 3))
+ (vector-ref av (array:actor-index ai 4))
+ (vector-ref av (array:actor-index ai 5))
+ (vector-ref av (array:actor-index ai 6))
+ (vector-ref av (array:actor-index ai 7))))
+ (lambda (p ai av)
+ (p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))
+ (vector-ref av (array:actor-index ai 2))
+ (vector-ref av (array:actor-index ai 3))
+ (vector-ref av (array:actor-index ai 4))
+ (vector-ref av (array:actor-index ai 5))
+ (vector-ref av (array:actor-index ai 6))
+ (vector-ref av (array:actor-index ai 7))
+ (vector-ref av (array:actor-index ai 8))))))
+ (it
+ (lambda (r)
+ (lambda (p ai av)
+ (apply
+ p
+ (vector-ref av (array:actor-index ai 0))
+ (vector-ref av (array:actor-index ai 1))
+ (vector-ref av (array:actor-index ai 2))
+ (vector-ref av (array:actor-index ai 3))
+ (vector-ref av (array:actor-index ai 4))
+ (vector-ref av (array:actor-index ai 5))
+ (vector-ref av (array:actor-index ai 6))
+ (vector-ref av (array:actor-index ai 7))
+ (vector-ref av (array:actor-index ai 8))
+ (vector-ref av (array:actor-index ai 9))
+ (do ((k r (- k 1))
+ (r
+ '()
+ (cons
+ (vector-ref
+ av
+ (array:actor-index ai (- k 1)))
+ r)))
+ ((= k 10) r)))))))
+ (lambda (r)
+ "These are low level, exposing implementation at call site."
+ (if (< r 10) (vector-ref em r) (it r)))))
+ (define (array:index/vector r x v)
+ ((array:indexer/vector r) x v))
+ (define (array:index/array r x av ai)
+ ((array:indexer/array r) x av ai))
+ (define (array:apply-to-actor r p a)
+ ((array:applier-to-actor r) p a))
+ (define (array:apply-to-vector r p v)
+ ((array:applier-to-vector r) p v))
+ (define (array:optimize f r)
+ (case r
+ ((0) (let ((n0 (f))) (array:0 n0)))
+ ((1) (let ((n0 (f 0))) (array:1 n0 (- (f 1) n0))))
+ ((2)
+ (let ((n0 (f 0 0)))
+ (array:2 n0 (- (f 1 0) n0) (- (f 0 1) n0))))
+ ((3)
+ (let ((n0 (f 0 0 0)))
+ (array:3
+ n0
+ (- (f 1 0 0) n0)
+ (- (f 0 1 0) n0)
+ (- (f 0 0 1) n0))))
+ (else
+ (let ((v
+ (do ((k 0 (+ k 1)) (v '() (cons 0 v)))
+ ((= k r) v))))
+ (let ((n0 (apply f v)))
+ (apply
+ array:n
+ n0
+ (array:coefficients f n0 v v)))))))
+ (define (array:optimize-empty r)
+ (let ((x (make-vector (+ r 1) 0)))
+ (vector-set! x r -1)
+ x)))
+
+
+(define (array-ref a . xs)
+ (or (##core#check (array:array? a))
+ (##sys#signal-hook #:type-error 'array-ref "not an array" a))
+ (let ((shape (array:shape a)))
+ (##core#check
+ (if (null? xs)
+ (array:check-indices "array-ref" xs shape)
+ (let ((x (car xs)))
+ (if (vector? x)
+ (array:check-index-vector "array-ref" x shape)
+ (if (integer? x)
+ (array:check-indices "array-ref" xs shape)
+ (if (array:array? x)
+ (array:check-index-actor "array-ref" x shape)
+ (##sys#signal-hook #:type-error 'array-ref "not an index object" x)))))))
+ (vector-ref
+ (array:vector a)
+ (if (null? xs)
+ (vector-ref (array:index a) 0)
+ (let ((x (car xs)))
+ (if (vector? x)
+ (array:index/vector
+ (quotient (vector-length shape) 2)
+ (array:index a)
+ x)
+ (if (integer? x)
+ (array:vector-index (array:index a) xs)
+ (if (##core#check (array:array? x))
+ (array:index/array
+ (quotient (vector-length shape) 2)
+ (array:index a)
+ (array:vector x)
+ (array:index x))
+ (##sys#signal-hook #:type-error 'array-ref "bad index object" x)))))))))
+
+(define (array-set! a x . xs)
+ (or (##core#check (array:array? a))
+ (##sys#signal-hook #:type-error 'array-set! "not an array" a))
+ (let ((shape (array:shape a)))
+ (##core#check
+ (if (null? xs)
+ (array:check-indices "array-set!" '() shape)
+ (if (vector? x)
+ (array:check-index-vector "array-set!" x shape)
+ (if (integer? x)
+ (array:check-indices.o "array-set!" (cons x xs) shape)
+ (if (array:array? x)
+ (array:check-index-actor "array-set!" x shape)
+ (##sys#signal-hook #:type-error 'array-set! "not an index object" x))))))
+ (if (null? xs)
+ (vector-set! (array:vector a) (vector-ref (array:index a) 0) x)
+ (if (vector? x)
+ (vector-set! (array:vector a)
+ (array:index/vector
+ (quotient (vector-length shape) 2)
+ (array:index a)
+ x)
+ (car xs))
+ (if (integer? x)
+ (let ((v (array:vector a))
+ (i (array:index a))
+ (r (quotient (vector-length shape) 2)))
+ (do ((sum (* (vector-ref i 0) x)
+ (+ sum (* (vector-ref i k) (car ks))))
+ (ks xs (cdr ks))
+ (k 1 (+ k 1)))
+ ((= k r)
+ (vector-set! v (+ sum (vector-ref i k)) (car ks)))))
+ (if (##core#check (array:array? x))
+ (vector-set! (array:vector a)
+ (array:index/array
+ (quotient (vector-length shape) 2)
+ (array:index a)
+ (array:vector x)
+ (array:index x))
+ (car xs))
+ (##sys#signal-hook
+ #:type-error 'array-set!
+ "bad index object: "
+ x)))))))
+
+(define (array:make-locative a x weak?)
+ (or (##core#check (array:array? a))
+ (##sys#signal-hook #:type-error 'array:make-locative "not an array"))
+ (let ((shape (array:shape a)))
+ (##core#check
+ (if (vector? x)
+ (array:check-index-vector "array:make-locative" x shape)
+ (if (integer? x)
+ (array:check-indices.o "array:make-locative" (list x) shape)
+ (if (array:array? x)
+ (array:check-index-actor "array:make-locative" x shape)
+ (##sys#signal-hook #:type-error 'array:make-locative "not an index object" x)))))
+ (if (vector? x)
+ (##core#inline_allocate
+ ("C_a_i_make_locative" 5)
+ 0
+ (array:vector a)
+ (array:index/vector
+ (quotient (vector-length shape) 2)
+ (array:index a)
+ x)
+ weak?)
+ (if (##core#check (array:array? x))
+ (##core#inline_allocate
+ ("C_a_i_make_locative" 5)
+ 0
+ (array:vector a)
+ (array:index/array
+ (quotient (vector-length shape) 2)
+ (array:index a)
+ (array:vector x)
+ (array:index x))
+ weak?)
+ (##sys#signal-hook #:type-error 'array:make-locative "bad index object: " x)))))
diff --git a/spock-0.2/tests/test-bind.js b/spock-0.2/tests/test-bind.js
@@ -0,0 +1,10 @@
+/* test-bind.js */
+
+
+// functions
+function $(string);
+Math.sin(number);
+gurgle([string ...], number ...);
+
+// variables
+var yes, no, one.two = string;
diff --git a/spock-0.2/top.scm b/spock-0.2/top.scm
@@ -0,0 +1,70 @@
+;;; top.scm - driver for command-line executable
+
+
+(define (option? x)
+ (and (> (string-length x) 0)
+ (char=? #\- (string-ref x 0))))
+
+(define (usage code)
+ (let ((out (if (zero? code) (current-output-port) (current-error-port))))
+ (display "usage: spock OPTION | FILENAME ...\n\n" out)
+ (display " -source show source forms\n" out)
+ (display " -expand show forms after macro-expansion\n" out)
+ (display " -canonicalized show forms after canonicalization\n" out)
+ (display " -optimized show forms after optimization\n" out)
+ (display " -cps show forms after CPS-conversion\n" out)
+ (display " -strict enable strict mode\n" out)
+ (display " -optimize enable optimizations\n" out)
+ (display " -block enable block-compilation\n" out)
+ (display " -library-path [DIR] add DIR to library path or show library path\n" out)
+ (display " -namespace VAR put globals into module\n" out)
+ (display " -xref show cross-reference\n" out)
+ (display " -runtime include runtime-system in generated code\n" out)
+ (display " -library compile runtime library\n" out)
+ (display " -seal wrap toplevel definitions into local scope\n" out)
+ (display " -debug enable debug mode\n" out)
+ (display " -verbose show diagnostic messages\n" out)
+ (display " -import FILENAME expand syntax in FILENAME\n" out)
+ (display " -debug-syntax show debug-output during expansion\n" out)
+ (display " -bind FILENAME generate bindings for specifications in FILENAME\n" out)
+ (display " -o FILENAME specify output-file\n" out)
+ (exit code)))
+
+(define (run args)
+ (let ((opts '()))
+ (define (add . xs)
+ (set! opts (append opts xs)))
+ (define (option->symbol o)
+ (string->symbol (substring o 1 (string-length o))))
+ (let loop ((args args))
+ (match args
+ (()
+ (apply spock 'usage (lambda _ (usage 1)) 'fail fail opts))
+ (((or "-h" "-help" "--help") . _)
+ (usage 0))
+ (("-o" out . more)
+ (add 'output-file out)
+ (loop more))
+ (("-library-path")
+ (print (car (spock 'library-path))))
+ (((and o (or "-library-path" "-namespace" "-bind")) arg . more)
+ (add (option->symbol o) arg)
+ (loop more))
+ (((and o (or "-source" "-expand" "-canonicalized" "-cps" "-strict"
+ "-block" "-xref" "-runtime" "-library"
+ "-seal" "-debug" "-debug-syntax" "-import" "-verbose"
+ "-optimize" "-optimized"))
+ . more)
+ (add (option->symbol o))
+ (loop more))
+ (((? option?) . _)
+ (usage 1))
+ ((file . more)
+ (add file)
+ (loop more))))))
+
+(cond-expand
+ (spock
+ (define-entry-point (spock_main . args)
+ (run args)))
+ (else))
diff --git a/spock-0.2/xref.scm b/spock-0.2/xref.scm
@@ -0,0 +1,53 @@
+;;;; xref.scm
+
+
+(define (report-undefined)
+ (let loop ((old undefined) (new '()))
+ (cond ((null? old)
+ (cond ((pair? new)
+ (let ((out (current-error-port)))
+ (display "\nError: access to undefined global variables:\n\n" out)
+ (for-each
+ (lambda (id)
+ (display " " out)
+ (write id out)
+ (display "\n" out))
+ (sort new symbol<?))
+ #t))
+ (else #f)))
+ ((get (car old) 'defined)
+ (loop (cdr old) new))
+ (else (loop (cdr old) (cons (car old) new))))))
+
+(define (xref sections show)
+ (when show
+ (for-each
+ (lambda (defd) (pp `(define ,defd)))
+ (sort defined symbol<?))
+ (for-each
+ (lambda (refd)
+ (when (or (not (symbol? (get refd 'defined))) sections)
+ (pp refd)))
+ (sort referenced symbol<?))
+ (for-each
+ (lambda (asgnd) (pp `(set! ,asgnd)))
+ (sort assigned symbol<?)))
+ (and sections
+ (let loop ((us used-sections) (done '()))
+ (cond ((null? us)
+ (when show
+ (for-each
+ (lambda (s) (pp `(section ,s)))
+ (sort done symbol<?)))
+ done)
+ (else
+ (let* ((s (car us))
+ (done (cons s done)))
+ (let loop2 ((deps (or (get s 'depends) '()))
+ (us (cdr us)))
+ (cond ((null? deps)
+ (loop us done))
+ ((memq (car deps) done)
+ (loop2 (cdr deps) us))
+ (else
+ (loop2 (cdr deps) (cons (car deps) us)))))))))))
