summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Lemmer Webber <cwebber@dustycloud.org>2021-05-10 15:58:15 -0400
committerChristopher Lemmer Webber <cwebber@dustycloud.org>2021-05-10 15:58:15 -0400
commit88f7aa0b3aa48f10a04715c5bc24e2039eae9c6c (patch)
tree801cb0c4bd8c4cf1e0a98bcb50c2f6b557c935d7
parent53e5cf654d5f4d95f407cd814472bcc09a69cd15 (diff)
parent05c57a6a66904861bb760aea13dd3ad3117c5966 (diff)
downloadguile-88f7aa0b3aa48f10a04715c5bc24e2039eae9c6c.tar.gz
Merge branch 'compile-to-js-2017' into compile-to-js-rebase
-rw-r--r--module/Makefile.am48
-rw-r--r--module/language/cps/compile-js.scm201
-rw-r--r--module/language/cps/spec.scm6
-rw-r--r--module/language/javascript.scm274
-rw-r--r--module/language/javascript/simplify.scm58
-rw-r--r--module/language/javascript/spec.scm33
-rw-r--r--module/language/js-il.scm138
-rw-r--r--module/language/js-il/compile-javascript.scm430
-rw-r--r--module/language/js-il/inlining.scm230
-rw-r--r--module/language/js-il/runtime.js1519
-rw-r--r--module/language/js-il/spec.scm31
-rw-r--r--module/scripts/jslink.scm215
12 files changed, 3181 insertions, 2 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 41b77095b..0ad6a8f31 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -29,6 +29,7 @@ $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
+
srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
$(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
@@ -179,6 +180,42 @@ SOURCES = \
language/bytecode.scm \
language/bytecode/spec.scm \
\
+ language/cps.scm \
+ language/cps/closure-conversion.scm \
+ language/cps/compile-bytecode.scm \
+ language/cps/compile-js.scm \
+ language/cps/constructors.scm \
+ language/cps/contification.scm \
+ language/cps/cse.scm \
+ language/cps/dce.scm \
+ language/cps/effects-analysis.scm \
+ language/cps/elide-values.scm \
+ language/cps/handle-interrupts.scm \
+ language/cps/intmap.scm \
+ language/cps/intset.scm \
+ language/cps/licm.scm \
+ language/cps/optimize.scm \
+ language/cps/peel-loops.scm \
+ language/cps/primitives.scm \
+ language/cps/prune-bailouts.scm \
+ language/cps/prune-top-level-scopes.scm \
+ language/cps/reify-primitives.scm \
+ language/cps/renumber.scm \
+ language/cps/rotate-loops.scm \
+ language/cps/self-references.scm \
+ language/cps/simplify.scm \
+ language/cps/slot-allocation.scm \
+ language/cps/spec.scm \
+ language/cps/specialize-primcalls.scm \
+ language/cps/specialize-numbers.scm \
+ language/cps/split-rec.scm \
+ language/cps/type-checks.scm \
+ language/cps/type-fold.scm \
+ language/cps/types.scm \
+ language/cps/utils.scm \
+ language/cps/verify.scm \
+ language/cps/with-cps.scm \
+ \
language/ecmascript/tokenize.scm \
language/ecmascript/parse.scm \
language/ecmascript/impl.scm \
@@ -198,6 +235,16 @@ SOURCES = \
language/elisp/runtime/value-slot.scm \
language/elisp/spec.scm \
\
+ language/javascript.scm \
+ language/javascript/simplify.scm \
+ language/javascript/spec.scm \
+ \
+ language/js-il.scm \
+ language/js-il/inlining.scm \
+ language/js-il/compile-javascript.scm \
+ language/js-il/runtime.js \
+ language/js-il/spec.scm \
+ \
language/scheme/compile-tree-il.scm \
language/scheme/decompile-tree-il.scm \
language/scheme/spec.scm \
@@ -265,6 +312,7 @@ SOURCES = \
scripts/frisk.scm \
scripts/generate-autoload.scm \
scripts/help.scm \
+ scripts/jslink.scm \
scripts/lint.scm \
scripts/list.scm \
scripts/punify.scm \
diff --git a/module/language/cps/compile-js.scm b/module/language/cps/compile-js.scm
new file mode 100644
index 000000000..244a16925
--- /dev/null
+++ b/module/language/cps/compile-js.scm
@@ -0,0 +1,201 @@
+;;; Continuation-passing style (CPS) to JS-IL compiler
+
+;; Copyright (C) 2015, 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language cps compile-js)
+ #:use-module (language cps)
+ #:use-module (language cps intmap)
+ #:use-module (language cps utils)
+ #:use-module ((language js-il)
+ #:renamer (lambda (x) (if (eqv? x 'make-prompt) 'make-prompt* x)))
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (append-map))
+ #:export (compile-js))
+
+(define intmap-select (@@ (language cps compile-bytecode) intmap-select))
+(define lower-cps (@@ (language cps compile-bytecode) lower-cps))
+
+(define (compile-js exp env opts)
+ ;; TODO: I should special case the compilation for the initial fun,
+ ;; as this is the entry point for the program, and shouldn't get a
+ ;; "self" argument, for now, I add "undefined" as the first
+ ;; argument in the call to it.
+ ;; see compile-exp in (language js-il compile-javascript)
+ (define (intmap->program map)
+ (intmap-fold-right (lambda (kfun body accum)
+ (acons (make-kid kfun)
+ (compile-fun (intmap-select map body) kfun)
+ accum))
+ (compute-reachable-functions map 0)
+ '()))
+ (values (make-program (intmap->program (lower-cps exp opts))) env env))
+
+
+(define (compile-fun cps kfun)
+ (define doms (compute-dom-edges (compute-idoms cps kfun)))
+ (match (intmap-ref cps kfun)
+ (($ $kfun src meta self tail clause)
+ (make-function
+ (make-id self)
+ (make-kid tail)
+ (compile-clauses cps doms clause self)))))
+
+
+(define (extract-and-compile-conts cps)
+ (define (step id body accum)
+ (match body
+ ;; The term in a $kargs is always a $continue
+ (($ $kargs names syms ($ $continue k src exp))
+ (acons (make-kid id)
+ (make-continuation (map make-id syms) (compile-exp exp k))
+ accum))
+ (($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
+ (let ((ids (map make-id (append req (list rest)))))
+ (acons (make-kid id)
+ (make-continuation ids (make-continue (make-kid k2) ids))
+ accum)))
+ (($ $kreceive ($ $arity req _ #f _ _) k2)
+ (let ((ids (map make-id req)))
+ (acons (make-kid id)
+ (make-continuation ids (make-continue (make-kid k2) ids))
+ accum)))
+ (else accum)))
+ (intmap-fold step cps '()))
+
+
+(define (compile-clauses cps doms clause self)
+ ;; FIXME: This duplicates all the conts in each clause, and requires
+ ;; the inliner to remove them. A better solution is to change the
+ ;; function type to contain a separate map of conts, but this requires
+ ;; more code changes, and is should constitute a separate commit.
+ (let loop ((clause clause))
+ (match (intmap-ref cps clause)
+ (($ $kclause arity body #f)
+ `((,(make-kid clause)
+ ,(arity->params arity self)
+ ,(compile-clause cps doms arity body self))))
+ (($ $kclause arity body next)
+ `((,(make-kid clause)
+ ,(arity->params arity self)
+ ,(compile-clause cps doms arity body self))
+ . ,(loop next))))))
+
+
+(define (arity->params arity self)
+ (match arity
+ (($ $arity req opts rest ((kws names kw-syms) ...) allow-other-keys?)
+ (make-params (make-id self)
+ (map make-id req)
+ (map make-id opts)
+ (and rest (make-id rest))
+ (map (lambda (kw name kw-sym)
+ (list kw (make-id name) (make-id kw-sym)))
+ kws
+ names
+ kw-syms)
+ allow-other-keys?))))
+
+
+(define (compile-clause cps doms arity body self)
+ (match arity
+ (($ $arity req opt rest ((_ _ kw-syms) ...) _)
+ (let ((ids (map make-id
+ (append req opt kw-syms (if rest (list rest) '())))))
+ (make-continuation
+ (cons (make-id self) ids)
+ (make-local (list (cons (make-kid body) (compile-cont cps doms body)))
+ (make-continue (make-kid body) ids)))))))
+
+(define (compile-cont cps doms cont)
+ (define (redominate label exp)
+ ;; This ensures that functions which are dominated by a $kargs [e.g.
+ ;; because they need its arguments] are moved into its body, and so
+ ;; we get correct scoping.
+ (define (find&compile-dominated label)
+ (append-map (lambda (label)
+ (match (intmap-ref cps label)
+ (($ $ktail) '()) ; ignore tails
+ (($ $kargs)
+ ;; kargs may bind more arguments
+ (list (cons (make-kid label) (compile label))))
+ (else
+ ;; otherwise, even if it dominates other conts,
+ ;; it doesn't need to contain them
+ (cons (cons (make-kid label) (compile label))
+ (find&compile-dominated label)))))
+ (intmap-ref doms label)))
+ (make-local (find&compile-dominated label) exp))
+ (define (compile cont)
+ (match (intmap-ref cps cont)
+ ;; The term in a $kargs is always a $continue
+ (($ $kargs names syms ($ $continue k src exp))
+ (make-continuation (map make-id syms)
+ (redominate cont (compile-exp exp k))))
+ (($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
+ (let ((ids (map make-id (append req (list rest)))))
+ (make-continuation ids (make-continue (make-kid k2) ids))))
+ (($ $kreceive ($ $arity req _ #f _ _) k2)
+ (let ((ids (map make-id req)))
+ (make-continuation ids (make-continue (make-kid k2) ids))))))
+ (compile cont))
+
+(define (compile-exp exp k)
+ (match exp
+ (($ $branch kt exp)
+ (compile-test exp (make-kid kt) (make-kid k)))
+ (($ $primcall 'return (arg))
+ (make-continue (make-kid k) (list (make-id arg))))
+ (($ $call name args)
+ (make-call (make-id name) (make-kid k) (map make-id args)))
+ (($ $callk label proc args)
+ (make-continue (make-kid label)
+ (cons* (make-id proc)
+ (make-kid k)
+ (map make-id args))))
+ (($ $values values)
+ (make-continue (make-kid k) (map make-id values)))
+ (($ $prompt escape? tag handler)
+ (make-seq
+ (list
+ (make-prompt* escape? (make-id tag) (make-kid handler))
+ (make-continue (make-kid k) '()))))
+ (_
+ (make-continue (make-kid k) (list (compile-exp* exp))))))
+
+(define (compile-exp* exp)
+ (match exp
+ (($ $const val)
+ (make-const val))
+ (($ $primcall name args)
+ (make-primcall name (map make-id args)))
+ (($ $closure label nfree)
+ (make-closure (make-kid label) nfree))
+ (($ $values (val))
+ ;; FIXME:
+ ;; may happen if a test branch of a conditional compiles to values
+ ;; placeholder till I learn if multiple values could be returned.
+ (make-id val))))
+
+(define (compile-test exp kt kf)
+ ;; TODO: find out if the expression is always simple enough that I
+ ;; don't need to create a new continuation (which will require extra
+ ;; arguments being passed through)
+ (make-branch (compile-exp* exp)
+ (make-continue kt '())
+ (make-continue kf '())))
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
index 5864203cb..add9bb14c 100644
--- a/module/language/cps/spec.scm
+++ b/module/language/cps/spec.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -25,6 +25,7 @@
#:use-module (language cps intmap)
#:use-module (language cps optimize)
#:use-module (language cps compile-bytecode)
+ #:use-module (language cps compile-js)
#:export (cps))
(define (read-cps port env)
@@ -47,6 +48,7 @@
#:title "CPS Intermediate Language"
#:reader read-cps
#:printer write-cps
- #:compilers `((bytecode . ,compile-bytecode))
+ #:compilers `((bytecode . ,compile-bytecode)
+ (js-il . ,compile-js))
#:for-humans? #f
#:lowerer make-cps-lowerer)
diff --git a/module/language/javascript.scm b/module/language/javascript.scm
new file mode 100644
index 000000000..2e1ca7dcd
--- /dev/null
+++ b/module/language/javascript.scm
@@ -0,0 +1,274 @@
+;;; JavaScript Language
+
+;; Copyright (C) 2015, 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+;; Only has enough of the ecmascript language for compilation from cps
+(define-module (language javascript)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (
+ make-assign assign
+ make-const const
+ make-function function
+ make-return return
+ make-call call
+ make-block block
+ make-new new
+ make-id id
+ make-refine refine
+ make-branch branch
+ make-var var
+ make-binop binop
+ make-ternary ternary
+ make-prefix prefix
+
+ print-statement))
+
+;; Copied from (language cps)
+;; Should put in a srfi 99 module
+(define-syntax define-record-type*
+ (lambda (x)
+ (define (id-append ctx . syms)
+ (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
+ (syntax-case x ()
+ ((_ name field ...)
+ (and (identifier? #'name) (and-map identifier? #'(field ...)))
+ (with-syntax ((cons (id-append #'name #'make- #'name))
+ (pred (id-append #'name #'name #'?))
+ ((getter ...) (map (lambda (f)
+ (id-append f #'name #'- f))
+ #'(field ...))))
+ #'(define-record-type name
+ (cons field ...)
+ pred
+ (field getter)
+ ...))))))
+
+;; TODO: add type predicates to fields so I can only construct valid
+;; objects
+(define-syntax-rule (define-js-type name field ...)
+ (begin
+ (define-record-type* name field ...)
+ (set-record-type-printer! name print-js)))
+
+(define (print-js exp port)
+ (format port "#<js ~S>" (unparse-js exp)))
+
+(define-js-type assign id exp)
+(define-js-type const c)
+(define-js-type function args body)
+(define-js-type return exp)
+(define-js-type call function args)
+(define-js-type block statements)
+(define-js-type new expr)
+(define-js-type id name)
+(define-js-type refine id field)
+(define-js-type branch test then else)
+(define-js-type var id exp)
+(define-js-type binop op arg1 arg2)
+(define-js-type ternary test then else)
+(define-js-type prefix op expr)
+
+(define (unparse-js exp)
+ (match exp
+ (($ assign id exp)
+ `(assign ,id ,(unparse-js exp)))
+ (($ const c)
+ `(const ,c))
+ (($ function args body)
+ `(function ,args ,@(map unparse-js body)))
+ (($ return exp)
+ `(return ,(unparse-js exp)))
+ (($ call function args)
+ `(call ,(unparse-js function) ,@(map unparse-js args)))
+ (($ block statements)
+ `(block ,@(map unparse-js statements)))
+ (($ new expr)
+ `(new ,(unparse-js expr)))
+ (($ id name)
+ `(id ,name))
+ (($ refine id field)
+ `(refine ,(unparse-js id) ,(unparse-js field)))
+ (($ branch test then else)
+ `(if ,(unparse-js test)
+ (block ,@(map unparse-js then))
+ (block ,@(map unparse-js else))))
+ (($ var id exp)
+ `(var ,id ,(unparse-js exp)))
+ (($ binop op arg1 arg2)
+ `(binop ,op ,(unparse-js arg1) ,(unparse-js arg2)))
+ (($ ternary test then else)
+ `(ternary ,(unparse-js test) ,(unparse-js then) ,(unparse-js else)))
+ (($ prefix op expr)
+ `(prefix ,op ,(unparse-js expr)))
+ ))
+
+(define (print-exp exp port)
+ (match exp
+
+ (($ assign id exp)
+ (print-id id port)
+ (format port " = ")
+ (display "(" port)
+ (print-exp exp port)
+ (display ")" port))
+
+ (($ const c)
+ (print-const c port))
+
+ (($ id name)
+ (print-id name port))
+
+ (($ call (and ($ function _ _) fun) args)
+ (format port "(")
+ (print-exp fun port)
+ (format port ")(")
+ (print-separated args print-exp "," port)
+ (format port ")"))
+
+ (($ call fun args)
+ (print-exp fun port)
+ (format port "(")
+ (print-separated args print-exp "," port)
+ (format port ")"))
+
+
+ (($ refine expr field)
+ (print-exp expr port)
+ (format port "[")
+ (print-exp field port)
+ (format port "]"))
+
+ (($ function params body)
+ (format port "function (")
+ (print-separated params print-id "," port)
+ (format port ")")
+ (print-block body port))
+
+ (($ block stmts)
+ (print-block stmts port))
+
+ (($ new expr)
+ (format port "new ")
+ (print-exp expr port))
+
+ (($ binop op arg1 arg2)
+ (display "(" port)
+ (print-exp arg1 port)
+ (display ")" port)
+ (print-binop op port)
+ (display "(" port)
+ (print-exp arg2 port)
+ (display ")" port))
+
+ (($ ternary test then else)
+ (display "(" port)
+ (print-exp test port)
+ (display ") ? (" port)
+ (print-exp then port)
+ (display ") : (" port)
+ (print-exp else port)
+ (display ")" port))
+
+ (($ prefix op exp)
+ (print-prefix op port)
+ (display "(" port)
+ (print-exp exp port)
+ (display ")" port))
+ ))
+
+(define (print-binop op port)
+ (case op
+ ((or) (display "||" port))
+ ((and) (display "&&" port))
+ ((=) (display "==" port))
+ ((begin) (display "," port))
+ ((+ - < <= > >= === instanceof) (format port "~a" op))
+ (else
+ (throw 'unprintable-binop op))))
+
+(define (print-prefix op port)
+ (case op
+ ((not) (display "!" port))
+ ((typeof + -)
+ (format port "~a" op))
+ (else
+ (throw 'unprintable-prefix op))))
+
+(define (print-statement stmt port)
+ (match stmt
+ (($ var id exp)
+ (format port "var ")
+ (print-id id port)
+ (format port " = ")
+ (print-exp exp port)
+ (format port ";"))
+
+ (($ branch test then else)
+ (format port "if (")
+ (print-exp test port)
+ (format port ") {")
+ (print-block then port)
+ (format port "} else {")
+ (print-block else port)
+ (format port "}"))
+
+ (($ return expr)
+ (format port "return ")
+ (print-exp expr port)
+ (format port ";"))
+
+ (expr
+ (print-exp expr port)
+ (format port ";"))))
+
+(define (print-id id port)
+ (display id port))
+
+(define (print-block stmts port)
+ (format port "{")
+ (print-statements stmts port)
+ (format port "}"))
+
+(define (print-statements stmts port)
+ (for-each (lambda (stmt)
+ (print-statement stmt port))
+ stmts))
+
+(define (print-const c port)
+ (cond ((string? c)
+ ;; FIXME:
+ ;; Scheme strings and JS Strings are different, and not just in
+ ;; terms of mutability
+ (write c port))
+ ((number? c)
+ (write c port))
+ (else
+ (throw 'unprintable-const c))))
+
+(define (print-separated args printer separator port)
+ (unless (null? args)
+ (let ((first (car args))
+ (rest (cdr args)))
+ (printer first port)
+ (for-each (lambda (x)
+ (display separator port)
+ (printer x port))
+ rest))))
diff --git a/module/language/javascript/simplify.scm b/module/language/javascript/simplify.scm
new file mode 100644
index 000000000..a26b7fd2e
--- /dev/null
+++ b/module/language/javascript/simplify.scm
@@ -0,0 +1,58 @@
+(define-module (language javascript simplify)
+ #:use-module (language javascript)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold-right))
+ #:export (flatten-blocks))
+
+(define (flatten-blocks exp)
+ (define (flatten exp rest)
+ (match exp
+ (($ block statements)
+ (fold-right flatten rest statements))
+ (else
+ (cons (flatten-exp exp) rest))))
+ (define (flatten-block stmts)
+ (fold-right flatten '() stmts))
+ (define (flatten-exp exp)
+ (match exp
+ (($ assign id exp)
+ (make-assign id (flatten-exp exp)))
+ (($ const c) exp)
+ (($ new exp)
+ (make-new (flatten-exp exp)))
+ (($ return exp)
+ (make-return (flatten-exp exp)))
+ (($ id name) exp)
+ (($ var id exp)
+ (make-var id (flatten-exp exp)))
+ (($ refine id field)
+ (make-refine (flatten-exp id)
+ (flatten-exp field)))
+ (($ binop op arg1 arg2)
+ (make-binop op
+ (flatten-exp arg1)
+ (flatten-exp arg2)))
+ (($ function args body)
+ (make-function args (flatten-block body)))
+ (($ block statements)
+ (maybe-make-block (flatten-block statements)))
+ (($ branch test then else)
+ (make-branch (flatten-exp test)
+ (flatten-block then)
+ (flatten-block else)))
+ (($ call function args)
+ (make-call (flatten-exp function)
+ (map flatten-exp args)))
+
+ (($ ternary test then else)
+ (make-ternary (flatten-exp test)
+ (flatten-exp then)
+ (flatten-exp else)))
+ (($ prefix op exp)
+ (make-prefix op (flatten-exp exp)))
+ ))
+ (define (maybe-make-block exp)
+ (match exp
+ ((exp) exp)
+ (exps (make-block exps))))
+ (maybe-make-block (flatten exp '())))
diff --git a/module/language/javascript/spec.scm b/module/language/javascript/spec.scm
new file mode 100644
index 000000000..b7a4a3dda
--- /dev/null
+++ b/module/language/javascript/spec.scm
@@ -0,0 +1,33 @@
+;;; JavaScript Language
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+;; in future, this should be merged with ecmacript
+
+(define-module (language javascript spec)
+ #:use-module (system base language)
+ #:use-module (language javascript)
+ #:export (javascript))
+
+(define-language javascript
+ #:title "Javascript"
+ #:reader #f
+ #:printer print-statement
+ #:for-humans? #f
+ )
diff --git a/module/language/js-il.scm b/module/language/js-il.scm
new file mode 100644
index 000000000..c0c10655a
--- /dev/null
+++ b/module/language/js-il.scm
@@ -0,0 +1,138 @@
+;;; JavaScript Intermediate Language (JS-IL)
+
+;; Copyright (C) 2015, 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language js-il)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (ice-9 match)
+ #:export (make-program program
+ make-function function
+ make-params params
+ make-continuation continuation
+ make-local local
+ make-continue continue
+ make-const const
+ make-primcall primcall
+ make-call call
+ make-closure closure
+ make-branch branch
+ make-id id
+ make-kid kid
+ make-seq seq
+ make-prompt prompt
+ ))
+
+;; Copied from (language cps)
+;; Should put in a srfi 99 module
+(define-syntax define-record-type*
+ (lambda (x)
+ (define (id-append ctx . syms)
+ (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
+ (syntax-case x ()
+ ((_ name field ...)
+ (and (identifier? #'name) (and-map identifier? #'(field ...)))
+ (with-syntax ((cons (id-append #'name #'make- #'name))
+ (pred (id-append #'name #'name #'?))
+ ((getter ...) (map (lambda (f)
+ (id-append f #'name #'- f))
+ #'(field ...))))
+ #'(define-record-type name
+ (cons field ...)
+ pred
+ (field getter)
+ ...))))))
+
+;; TODO: add type predicates to fields so I can only construct valid
+;; objects
+(define-syntax-rule (define-js-type name field ...)
+ (begin
+ (define-record-type* name field ...)
+ (set-record-type-printer! name print-js)))
+
+(define (print-js exp port)
+ (format port "#<js-il ~S>" (unparse-js exp)))
+
+(define-js-type program body)
+(define-js-type function self tail clauses)
+(define-js-type params self req opt rest kw allow-other-keys?)
+(define-js-type continuation params body)
+(define-js-type local bindings body) ; local scope
+(define-js-type continue cont args)
+(define-js-type const value)
+(define-js-type primcall name args)
+(define-js-type call name k args)
+(define-js-type closure label num-free)
+(define-js-type branch test consequence alternate)
+(define-js-type id name)
+(define-js-type kid name)
+(define-js-type seq body)
+(define-js-type prompt escape? tag handler)
+
+(define (unparse-js exp)
+ (match exp
+ (($ program body)
+ `(program . ,(map (match-lambda
+ ((($ kid k) . fun)
+ (cons k (unparse-js fun))))
+ body)))
+ (($ continuation params body)
+ `(continuation ,(map unparse-js params) ,(unparse-js body)))
+ (($ function ($ id self) ($ kid tail) clauses)
+ `(function ,self
+ ,tail
+ ,@(map (match-lambda
+ ((($ kid id) params kont)
+ (list id
+ (unparse-js params)
+ (unparse-js kont))))
+ clauses)))
+ (($ params ($ id self) req opt rest kws allow-other-keys?)
+ `(params ,self
+ ,(map unparse-js req)
+ ,(map unparse-js opt)
+ ,(and rest (unparse-js rest))
+ ,(map (match-lambda
+ ((kw ($ id name) ($ id sym))
+ (list kw name sym)))
+ kws)
+ ,allow-other-keys?))
+ (($ local bindings body)
+ `(local ,(map (match-lambda
+ ((a . d)
+ (cons (unparse-js a)
+ (unparse-js d))))
+ bindings)
+ ,(unparse-js body)))
+ (($ continue ($ kid k) args)
+ `(continue ,k ,(map unparse-js args)))
+ (($ branch test then else)
+ `(if ,(unparse-js test) ,(unparse-js then) ,(unparse-js else)))
+ (($ const c)
+ `(const ,c))
+ (($ primcall name args)
+ `(primcall ,name ,(map unparse-js args)))
+ (($ call ($ id name) ($ kid k) args)
+ `(call ,name ,k ,(map unparse-js args)))
+ (($ closure ($ kid label) nfree)
+ `(closure ,label ,nfree))
+ (($ id name)
+ `(id . ,name))
+ (($ kid name)
+ `(kid . ,name))))
diff --git a/module/language/js-il/compile-javascript.scm b/module/language/js-il/compile-javascript.scm
new file mode 100644
index 000000000..a6c399451
--- /dev/null
+++ b/module/language/js-il/compile-javascript.scm
@@ -0,0 +1,430 @@
+;;; JavaScript Intermediate Language (JS-IL) to Javascript Compiler
+
+;; Copyright (C) 2015, 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language js-il compile-javascript)
+ #:use-module ((srfi srfi-1) #:select (fold-right))
+ #:use-module (ice-9 match)
+ #:use-module ((language js-il) #:renamer (symbol-prefix-proc 'il:))
+ #:use-module (language javascript)
+ #:use-module (language javascript simplify)
+ #:use-module (language js-il inlining)
+ #:use-module (system foreign)
+ #:use-module (system syntax internal)
+ #:export (compile-javascript))
+
+(define (undefined? obj)
+ (define tc8-iflag 4)
+ (define unbound-val 9)
+ (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
+ (eqv? obj (pointer->scm (make-pointer unbound-bits))))
+
+(define (compile-javascript exp env opts)
+ (match (memq #:js-inline? opts)
+ ((#:js-inline? #f _ ...) #f)
+ (_ (set! exp (inline-single-calls exp))))
+ (set! exp (compile-exp exp))
+ (match (memq #:js-flatten? opts)
+ ((#:js-flatten? #f _ ...) #f)
+ (_ (set! exp (flatten-blocks exp))))
+ (values exp env env))
+
+(define *scheme* (make-id "scheme"))
+(define *utils* (make-refine *scheme* (make-const "utils")))
+
+(define (rename-id i)
+ (match i
+ (($ il:id i)
+ (rename i))
+ (($ il:kid i)
+ (rename-kont i))))
+
+(define (compile-id i)
+ (make-id (rename-id i)))
+
+(define (kont->id name)
+ (make-id (rename-kont name)))
+
+(define (rename-kont name)
+ (format #f "k_~a" name))
+
+(define (name->id name)
+ (make-id (rename name)))
+
+(define (rename id)
+ (cond ((and (integer? id) (>= id 0))
+ (format #f "v_~a" id))
+ ((symbol? id)
+ (js-id (symbol->string id)))
+ ((string? id)
+ (js-id id))
+ (else
+ (throw 'bad-id id))))
+
+(define (js-id name)
+ (call-with-output-string
+ (lambda (port)
+ (display "v_" port)
+ (string-for-each
+ (lambda (c)
+ (if (or (and (char<=? #\a c) (char<=? c #\z))
+ (and (char<=? #\A c) (char<=? c #\Z))
+ (and (char<=? #\0 c) (char<=? c #\9)))
+ (display c port)
+ (case c
+ ((#\-) (display "_h" port))
+ ((#\_) (display "_u" port))
+ ((#\?) (display "_p" port))
+ ((#\!) (display "_x" port))
+ ((#\<) (display "_l" port))
+ ((#\>) (display "_g" port))
+ ((#\=) (display "_e" port))
+ ((#\*) (display "_s" port))
+ ((#\+) (display "_a" port))
+ ((#\\) (display "_b" port))
+ ((#\/) (display "_f" port))
+ ((#\%) (display "_c" port))
+ ((#\$) (display "_d" port))
+ ((#\~) (display "_t" port))
+ ((#\^) (display "_i" port))
+ ((#\&) (display "_j" port))
+ ((#\:) (display "_k" port))
+ ((#\@) (display "_m" port))
+ ;; unused: noqrvxy
+ (else
+ (display "_z" port)
+ (display (char->integer c) port)))))
+ name))))
+
+(define (bind-rest-args rest num-drop)
+ (define (ref i l)
+ (if (null? l)
+ i
+ (ref (make-refine i (make-const (car l)))
+ (cdr l))))
+ (define this (rename-id rest))
+ (make-var this
+ (make-call (ref *scheme* (list "list" "apply"))
+ (list
+ (ref *scheme* (list "list"))
+ (make-call (ref (make-id "Array") (list "prototype" "slice" "call"))
+ (list (make-id "arguments") (make-const num-drop)))))))
+
+(define (bind-opt-args opts num-drop)
+ (map (lambda (opt idx)
+ (make-var (rename-id opt)
+ (let ((arg (make-refine (make-id "arguments")
+ (make-const (+ num-drop idx)))))
+ (make-ternary (make-binop '===
+ (make-prefix 'typeof arg)
+ (make-id "undefined"))
+ (make-refine *scheme* (make-const "UNDEFINED"))
+ arg))))
+ opts
+ (iota (length opts))))
+
+(define (bind-kw-args kws ids num-drop)
+ (define lookup (make-refine *utils* (make-const "keyword_ref")))
+ (map (lambda (kw id)
+ (make-var (rename-id id)
+ (make-call lookup
+ (list (compile-const kw)
+ (make-id "arguments")
+ (compile-const num-drop)
+ (make-refine *scheme* (make-const "UNDEFINED"))))))
+ kws
+ ids))
+
+(define (bind-opt-kw-args opts kws ids num-drop)
+ ;; FIXME: what we really need is a rewrite of all the complex argument
+ ;; handling , not another special case.
+ ;; NB: our generated IDs will not clash since they are not prefixed
+ ;; with k_ or v_
+ (define skip? (make-id "skip"))
+ (define skip-idx (make-id "skip_idx"))
+ (define (bind-opt-args opts num-drop)
+ (map (lambda (opt idx)
+ (make-var (rename-id opt)
+ (let ((arg (make-refine (make-id "arguments")
+ (make-const (+ num-drop idx)))))
+ (make-ternary (make-binop 'or
+ skip?
+ (make-binop '===
+ (make-prefix 'typeof arg)
+ (make-id "undefined")))
+ (make-refine *scheme* (make-const "UNDEFINED"))
+ (make-ternary (make-binop 'instanceof
+ arg
+ (make-refine *scheme* (make-const "Keyword")))
+ (make-binop 'begin
+ (make-assign "skip" (compile-const #t))
+ (make-refine *scheme* (make-const "UNDEFINED")))
+ (make-binop 'begin
+ (make-assign "skip_idx" (make-binop '+ skip-idx (make-const 1)))
+ arg))))))
+ opts
+ (iota (length opts))))
+ (define (bind-kw-args kws ids)
+ (define lookup (make-refine *utils* (make-const "keyword_ref")))
+ (map (lambda (kw id)
+ (make-var (rename-id id)
+ (make-call lookup
+ (list (compile-const kw)
+ (make-id "arguments")
+ skip-idx
+ (make-refine *scheme* (make-const "UNDEFINED"))))))
+ kws
+ ids))
+ (append (list (make-var "skip" (compile-const #f))
+ (make-var "skip_idx" (compile-const num-drop)))
+ (bind-opt-args opts num-drop)
+ (bind-kw-args kws ids)))
+
+
+(define (compile-exp exp)
+ ;; TODO: handle ids for js
+ (match exp
+ (($ il:program ((name . fun) (names . funs) ...))
+ (let ((entry-call
+ (make-return
+ (make-call (compile-id name)
+ (list
+ (make-id "undefined")
+ (make-id "unit_cont"))))))
+ (make-function
+ (list "unit_cont")
+ (append
+ (map (lambda (id f)
+ (make-var (rename-id id)
+ (compile-exp f)))
+ (cons name names)
+ (cons fun funs))
+
+ (list entry-call)))))
+
+ (($ il:continuation params body)
+ (make-function (map rename-id params) (list (compile-exp body))))
+
+ (($ il:function self tail clauses)
+ (make-function (list (rename-id self) (rename-id tail))
+ (append
+ (map (match-lambda
+ ((id _ body)
+ (make-var (rename-id id) (compile-exp body))))
+ clauses)
+ (list (compile-jump-table clauses)))))
+
+ (($ il:local ((ids . bindings) ...) body)
+ (make-block
+ (append (map (lambda (id binding)
+ (make-var (rename-id id) (compile-exp binding)))
+ ids
+ bindings)
+ (list (compile-exp body)))))
+
+ (($ il:continue k exps)
+ (make-return (make-call (compile-id k) (map compile-exp exps))))
+
+ (($ il:branch test then else)
+ (make-branch (make-call (make-refine *scheme* (make-const "is_true"))
+ (list (compile-exp test)))
+ (list (compile-exp then))
+ (list (compile-exp else))))
+
+ (($ il:const c)
+ (compile-const c))
+
+ (($ il:primcall name args)
+ (make-call (make-refine (make-refine *scheme* (make-const "primitives"))
+ (make-const (symbol->string name)))
+ (map compile-id args)))
+
+ (($ il:call name k args)
+ (make-return
+ (make-call (make-refine (compile-id name) (make-const "fun"))
+ (cons* (compile-id name)
+ (compile-id k)
+ (map compile-id args)))))
+
+ (($ il:closure label nfree)
+ (make-new
+ (make-call (make-refine *scheme* (make-const "Closure"))
+ (list (compile-id label) (make-const nfree)))))
+
+ (($ il:prompt escape? tag handler)
+ ;; never a tailcall
+ (make-call (make-refine (make-refine *scheme* (make-const "primitives"))
+ (make-const "prompt"))
+ (list (compile-const escape?) (compile-id tag) (compile-id handler))))
+
+ (($ il:seq body)
+ (make-block (map compile-exp body)))
+
+ (($ il:id name)
+ (name->id name))
+
+ (($ il:kid name)
+ (kont->id name))))
+
+(define (compile-jump-table specs)
+ (define offset 2) ; closure & continuation
+ (define (compile-test params)
+ (match params
+ (($ il:params self req '() #f '() #f)
+ (make-binop '=
+ (make-refine (make-id "arguments")
+ (make-const "length"))
+ (make-const (+ offset (length req)))))
+ (($ il:params self req '() rest '() #f)
+ (make-binop '>=
+ (make-refine (make-id "arguments")
+ (make-const "length"))
+ (make-const (+ offset (length req)))))
+ (($ il:params self req opts #f '() #f)
+ (make-binop 'and
+ (make-binop '<=
+ (make-const (+ offset (length req)))
+ (make-refine (make-id "arguments")
+ (make-const "length")))
+ (make-binop '<=
+ (make-refine (make-id "arguments")
+ (make-const "length"))
+ (make-const (+ offset (length req) (length opts))))))
+ ;; FIXME: need to handle allow-other-keys? and testing for actual keywords
+ (($ il:params self req opts #f kwargs _)
+ (make-binop '<=
+ (make-const (+ offset (length req)))
+ (make-refine (make-id "arguments")
+ (make-const "length"))))
+ ))
+ (define (compile-jump params k)
+ (match params
+ (($ il:params self req '() #f '() #f)
+ (list
+ (make-return
+ (make-call (compile-id k)
+ (cons (compile-id self)
+ (map (lambda (idx)
+ (make-refine (make-id "arguments")
+ (make-const (+ offset idx))))
+ (iota (length req))))))))
+ (($ il:params self req '() rest '() #f)
+ (list
+ (bind-rest-args rest (+ offset (length req)))
+ (make-return
+ (make-call (compile-id k)
+ (append (list (compile-id self))
+ (map (lambda (idx)
+ (make-refine (make-id "arguments")
+ (make-const (+ offset idx))))
+ (iota (length req)))
+ (list (compile-id rest)))))))
+ (($ il:params self req opts #f '() #f)
+ (append
+ (bind-opt-args opts (+ offset (length req)))
+ (list
+ (make-return
+ (make-call (compile-id k)
+ (append (list (compile-id self))
+ (map (lambda (idx)
+ (make-refine (make-id "arguments")
+ (make-const (+ offset idx))))
+ (iota (length req)))
+ (map compile-id opts)))))))
+ (($ il:params self req opts #f ((kws names ids) ...) _)
+ (append
+ (bind-opt-kw-args opts kws names (+ offset (length req)))
+ (list
+ (make-return
+ (make-call (compile-id k)
+ (append (list (compile-id self))
+ (map (lambda (idx)
+ (make-refine (make-id "arguments")
+ (make-const (+ offset idx))))
+ (iota (length req)))
+ (map compile-id opts)
+ (map compile-id names)))))))
+ ))
+ (fold-right (lambda (a d)
+ (match a
+ ((id params _)
+ (make-branch (compile-test params)
+ (compile-jump params id)
+ (list d)))))
+ ;; FIXME: should throw an error
+ (make-return (make-id "undefined"))
+ specs))
+
+(define (compile-const c)
+ (cond ((number? c)
+ (make-const c))
+ ((eqv? c #t)
+ (make-refine *scheme* (make-const "TRUE")))
+ ((eqv? c #f)
+ (make-refine *scheme* (make-const "FALSE")))
+ ((eqv? c '())
+ (make-refine *scheme* (make-const "EMPTY")))
+ ((unspecified? c)
+ (make-refine *scheme* (make-const "UNSPECIFIED")))
+ ((symbol? c)
+ (make-new
+ (make-call
+ (make-refine *scheme* (make-const "Symbol"))
+ (list (make-const (symbol->string c))))))
+ ((list? c)
+ (make-call
+ (make-refine *scheme* (make-const "list"))
+ (map compile-const c)))
+ ((string? c)
+ (make-new
+ (make-call
+ (make-refine *scheme* (make-const "String"))
+ (list (make-const c)))))
+ ((pair? c)
+ (make-new
+ (make-call
+ (make-refine *scheme* (make-const "Pair"))
+ (list (compile-const (car c))
+ (compile-const (cdr c))))))
+ ((vector? c)
+ (make-new
+ (make-call
+ (make-refine *scheme* (make-const "Vector"))
+ (map compile-const (vector->list c)))))
+ ((char? c)
+ (make-new
+ (make-call
+ (make-refine *scheme* (make-const "Char"))
+ (list (make-const (string c))))))
+ ((keyword? c)
+ (make-new
+ (make-call
+ (make-refine *scheme* (make-const "Keyword"))
+ (list (make-const (symbol->string (keyword->symbol c)))))))
+ ((undefined? c)
+ (make-refine *scheme* (make-const "UNDEFINED")))
+ ((syntax? c)
+ (make-call
+ (make-refine *scheme* (make-const "Syntax"))
+ (map compile-const
+ (list (syntax-expression c)
+ (syntax-wrap c)
+ (syntax-module c)))))
+ (else
+ (throw 'uncompilable-const c))))
diff --git a/module/language/js-il/inlining.scm b/module/language/js-il/inlining.scm
new file mode 100644
index 000000000..5b51f580e
--- /dev/null
+++ b/module/language/js-il/inlining.scm
@@ -0,0 +1,230 @@
+;;; JavaScript Intermediate Language (JS-IL) Inliner
+
+;; Copyright (C) 2015, 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+;; FIXME: It is currently wrong to think of inlining as an optimisation
+;; since in the cps-soup world we need inlining to rebuild the scope
+;; tree for variables.
+;; FIXME: since *all* conts are passed to each clause, there can be
+;; "dead" conts thare are included in a clause
+
+(define-module (language js-il inlining)
+ #:use-module ((srfi srfi-1) #:select (partition))
+ #:use-module (ice-9 match)
+ #:use-module (language js-il)
+ #:export (count-calls
+ inline-single-calls
+ ))
+
+(define (count-calls exp)
+ (define counts (make-hash-table))
+ (define (count-inc! key)
+ (hashv-set! counts key (+ 1 (hashv-ref counts key 0))))
+ (define (count-inf! key)
+ (hashv-set! counts key +inf.0))
+ (define (analyse-args arg-list)
+ (for-each (match-lambda
+ (($ kid name)
+ (count-inf! name))
+ (($ id name) #f))
+ arg-list))
+ (define (analyse exp)
+ (match exp
+ (($ program ((ids . funs) ...))
+ (for-each analyse funs))
+
+ (($ function self tail ((($ kid ids) _ bodies) ...))
+ (for-each count-inc! ids) ;; count-inf! ?
+ (for-each analyse bodies))
+
+ (($ continuation params body)
+ (analyse body))
+
+ (($ local bindings body)
+ (for-each (match-lambda
+ ((i . b) (analyse b)))
+ bindings)
+ (analyse body))
+
+ (($ continue ($ kid cont) args)
+ (count-inc! cont)
+ (for-each analyse args))
+
+ (($ primcall name args)
+ (analyse-args args))
+
+ (($ call name ($ kid k) args)
+ (count-inf! k)
+ (analyse-args args))
+
+ (($ closure ($ kid label) num-free)
+ (count-inf! label))
+
+ (($ branch test consequence alternate)
+ (analyse test)
+ (analyse consequence)
+ (analyse alternate))
+
+ (($ kid name)
+ (count-inf! name))
+
+ (($ seq body)
+ (for-each analyse body))
+
+ (($ prompt escape? tag ($ kid handler))
+ (count-inf! handler))
+
+ (else #f)))
+ (analyse exp)
+ counts)
+
+(define no-values-primitives
+ '(
+ cache-current-module!
+ set-cdr!
+ set-car!
+ vector-set!
+ free-set!
+ vector-set!/immediate
+ box-set!
+ struct-set!
+ struct-set!/immediate
+ wind
+ unwind
+ push-fluid
+ pop-fluid
+ handle-interrupts
+ push-dynamic-state
+ pop-dynamic-state
+ fluid-set!
+ ))
+
+(define no-values-primitive?
+ (let ((h (make-hash-table)))
+ (for-each (lambda (prim)
+ (hashv-set! h prim #t))
+ no-values-primitives)
+ (lambda (prim)
+ (hashv-ref h prim))))
+
+
+(define (inline-single-calls exp)
+ (define (handle-function fun)
+ (match fun
+ (($ function self tail ((ids params bodies) ...))
+ (make-function self
+ tail
+ (map (lambda (id param body)
+ (list id param (inline-clause body)))
+ ids
+ params
+ bodies)))))
+ (match exp
+ (($ program ((ids . funs) ...))
+ (make-program (map (lambda (id fun)
+ (cons id (handle-function fun)))
+ ids
+ funs)))))
+
+(define (inline-clause exp)
+
+ (define calls (count-calls exp))
+
+ (define (inlinable? k)
+ (eqv? 1 (hashv-ref calls k)))
+
+ (define (split-inlinable bindings)
+ (partition (match-lambda
+ ((($ kid id) . _) (inlinable? id)))
+ bindings))
+
+ (define (lookup kont substs)
+ (match substs
+ (((($ kid id) . exp) . rest)
+ (if (= id kont)
+ exp
+ (lookup kont rest)))
+ (() kont)
+ (else
+ (throw 'lookup-failed kont))))
+
+ (define (inline exp substs)
+ (match exp
+
+ ;; FIXME: This hacks around the fact that define doesn't return
+ ;; arguments to the continuation. This should be handled when
+ ;; converting to js-il, not here.
+ (($ continue
+ ($ kid (? inlinable? cont))
+ (($ primcall (? no-values-primitive? prim) args)))
+ (match (lookup cont substs)
+ (($ continuation () body)
+ (make-seq
+ (list
+ (make-primcall prim args)
+ (inline body substs))))
+ (else
+ ;; inlinable but not locally bound
+ exp)))
+
+ (($ continue ($ kid (? inlinable? cont)) args)
+ (match (lookup cont substs)
+ (($ continuation kargs body)
+ (if (not (= (length args) (length kargs)))
+ (throw 'args-dont-match cont args kargs)
+ (make-local (map cons kargs args)
+ ;; gah, this doesn't work
+ ;; identifiers need to be separated earlier
+ ;; not just as part of compilation
+ (inline body substs))))
+ (else
+ ;; inlinable but not locally bound
+ ;; FIXME: This handles tail continuations, but only by accident
+ exp)))
+
+ (($ continue cont args)
+ exp)
+
+ (($ continuation params body)
+ (make-continuation params (inline body substs)))
+
+ (($ local bindings body)
+ (call-with-values
+ (lambda ()
+ (split-inlinable bindings))
+ (lambda (new-substs uninlinable-bindings)
+ (define substs* (append new-substs substs))
+ (make-local (map (match-lambda
+ ((id . val)
+ `(,id . ,(inline val substs*))))
+ uninlinable-bindings)
+ (inline body substs*)))))
+
+ (($ seq body)
+ (make-seq (map (lambda (x) (inline x substs))
+ body)))
+
+ (($ branch test consequence alternate)
+ (make-branch test
+ (inline consequence substs)
+ (inline alternate substs)))
+
+ (exp exp)))
+
+ (inline exp '()))
diff --git a/module/language/js-il/runtime.js b/module/language/js-il/runtime.js
new file mode 100644
index 000000000..142e3db86
--- /dev/null
+++ b/module/language/js-il/runtime.js
@@ -0,0 +1,1519 @@
+// JavaScript Runtime
+
+// Copyright (C) 2015, 2017 Free Software Foundation, Inc.
+
+// This library is free software; you can redistribute it and/or
+// modify it under the terms of the GNU Lesser General Public
+// License as published by the Free Software Foundation; either
+// version 3 of the License, or (at your option) any later version.
+//
+// This library is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+// Lesser General Public License for more details.
+//
+// You should have received a copy of the GNU Lesser General Public
+// License along with this library; if not, write to the Free Software
+// Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+// Code:
+
+var scheme = {
+ obarray : {},
+ primitives : {},
+ utils : {},
+ env : {},
+ cache: [],
+ module_cache: {},
+ builtins: [],
+ dynstack : [],
+ // TODO: placeholders
+ FALSE : false,
+ TRUE : true,
+ NIL : false,
+ EMPTY : [],
+ UNSPECIFIED : [],
+ // FIXME: wingo says not to leak undefined to users
+ UNDEFINED: undefined
+};
+
+function not_implemented_yet() {
+ throw "not implemented yet";
+};
+
+function coerce_bool(obj) {
+ return obj ? scheme.TRUE : scheme.FALSE;
+};
+
+// Numbers
+scheme.primitives.add = function (x, y) {
+ return x + y;
+};
+
+scheme.primitives.add1 = function (x) {
+ return x + 1;
+};
+
+scheme.primitives["add/immediate"] = function (x, y) {
+ return x + y;
+};
+
+scheme.primitives.sub = function (x, y) {
+ return x - y;
+};
+
+scheme.primitives.sub1 = function (x) {
+ return x - 1;
+};
+
+scheme.primitives["sub/immediate"] = function (x, y) {
+ return x - y;
+};
+
+scheme.primitives.mul = function (x, y) {
+ return x * y;
+};
+
+scheme.primitives.div = function (x, y) {
+ return x / y;
+};
+
+scheme.primitives["="] = function (x, y) {
+ return coerce_bool(x == y);
+};
+
+scheme.primitives["<"] = function (x, y) {
+ return coerce_bool(x < y);
+};
+
+scheme.primitives["<="] = function (x, y) {
+ return coerce_bool(x <= y);
+};
+
+scheme.primitives[">"] = function (x, y) {
+ return coerce_bool(x > y);
+};
+
+scheme.primitives[">="] = function (x, y) {
+ return coerce_bool(x >= y);
+};
+
+scheme.primitives.quo = not_implemented_yet;
+scheme.primitives.rem = not_implemented_yet;
+scheme.primitives.mod = not_implemented_yet;
+
+// Unboxed Numbers
+scheme.primitives["load-u64"] = function(x) {
+ return x;
+};
+
+scheme.primitives["u64-="] = function(x, y) {
+ return coerce_bool(x === y);
+};
+
+scheme.primitives["u64-=-scm"] = function(x, y) {
+ // i.e. br-if-u64-=-scm
+ return coerce_bool(x === y);
+};
+
+scheme.primitives["u64-<=-scm"] = function(x, y) {
+ return coerce_bool(x <= y);
+};
+
+scheme.primitives["u64-<-scm"] = function(x, y) {
+ return coerce_bool(x < y);
+};
+
+scheme.primitives["u64->-scm"] = function(x, y) {
+ return coerce_bool(x > y);
+};
+
+scheme.primitives["u64->=-scm"] = function(x, y) {
+ return coerce_bool(x >= y);
+};
+
+scheme.primitives["scm->u64"] = function(x) {
+ return x;
+};
+
+scheme.primitives["u64->scm"] = function(x) {
+ return x;
+};
+
+// Boxes
+scheme.Box = function (x) {
+ this.x = x;
+ return this;
+};
+
+scheme.primitives["box"] = function(x) {
+ return new scheme.Box(x);
+};
+
+scheme.primitives["box-ref"] = function (box) {
+ return box.x;
+};
+
+scheme.primitives["box-set!"] = function (box, val) {
+ box.x = val;
+};
+
+// Lists
+scheme.Pair = function (car, cdr) {
+ this.car = car;
+ this.cdr = cdr;
+ return this;
+};
+
+scheme.primitives["pair?"] = function (obj) {
+ return coerce_bool(obj instanceof scheme.Pair);
+};
+
+scheme.primitives.cons = function (car, cdr) {
+ return new scheme.Pair(car,cdr);
+};
+
+scheme.primitives.car = function (obj) {
+ return obj.car;
+};
+
+scheme.primitives.cdr = function (obj) {
+ return obj.cdr;
+};
+
+scheme.primitives["set-car!"] = function (pair, obj) {
+ obj.car = obj;
+};
+
+scheme.primitives["set-cdr!"] = function (pair, obj) {
+ obj.cdr = obj;
+};
+
+scheme.list = function () {
+ var l = scheme.EMPTY;
+ for (var i = arguments.length - 1; i >= 0; i--){
+ l = scheme.primitives.cons(arguments[i],l);
+ };
+ return l;
+};
+
+scheme.primitives["null?"] = function(obj) {
+ return coerce_bool(scheme.EMPTY == obj);
+};
+
+// Symbols
+scheme.Symbol = function(s) {
+ if (scheme.obarray[s]) {
+ return scheme.obarray[s];
+ } else {
+ this.name = s;
+ scheme.obarray[s] = this;
+ return this;
+ };
+};
+
+scheme.primitives["symbol?"] = function (obj) {
+ return coerce_bool(obj instanceof scheme.Symbol);
+};
+
+// Keywords
+scheme.Keyword = function(s) {
+ this.name = s;
+ return this;
+};
+
+scheme.primitives["keyword?"] = function (obj) {
+ return coerce_bool(obj instanceof scheme.Keyword);
+};
+
+scheme.utils.keyword_ref = function(kw, args, start, dflt) {
+ var l = args.length;
+
+ if ((l - start) % 2 == 1) {
+ // FIXME: should error
+ return undefined;
+ }
+ // Need to loop in reverse because last matching keyword wins
+ for (var i = l - 2; i >= start; i -= 2) {
+ if (!(args[i] instanceof scheme.Keyword)) {
+ return undefined;
+ }
+ if (args[i].name === kw.name) {
+ return args[i + 1];
+ }
+ }
+ return dflt;
+};
+
+// Vectors
+scheme.Vector = function () {
+ this.array = Array.prototype.slice.call(arguments);
+ return this;
+};
+
+scheme.primitives["vector-ref"] = function (vec, idx) {
+ return vec.array[idx];
+};
+
+scheme.primitives["vector-set!"] = function (vec, idx, obj) {
+ return vec.array[idx] = obj;
+};
+
+scheme.primitives["vector-length"] = function (vec) {
+ return vec.array.length;
+};
+
+scheme.primitives["vector?"] = function (obj) {
+ return coerce_bool(obj instanceof scheme.Vector);
+};
+
+scheme.primitives["make-vector/immediate"] = function(length, init) {
+ var v = new scheme.Vector();
+
+ var temp = []
+ for (var i=0; i < length; i++) {
+ temp[i] = init;
+ }
+
+ v.array = temp;
+
+ return v;
+};
+
+scheme.primitives["vector-set!/immediate"] = scheme.primitives["vector-set!"];
+scheme.primitives["vector-ref/immediate"] = scheme.primitives["vector-ref"];
+
+// Bytevectors
+
+// Booleans
+
+scheme.primitives["boolean?"] = not_implemented_yet;
+
+// Chars
+scheme.Char = function(c) {
+ this.c = c;
+ return this;
+};
+
+scheme.primitives["char?"] = function (obj) {
+ return coerce_bool(obj instanceof scheme.Char);
+};
+
+// Strings
+scheme.String = function(s) {
+ this.s = s;
+ return this;
+};
+
+scheme.primitives["string?"] = function (obj) {
+ return coerce_bool(obj instanceof scheme.String);
+};
+
+scheme.primitives["string-length"] = function (str) {
+ return str.s.length;
+};
+
+scheme.primitives["string-ref"] = function (str, idx) {
+ return new scheme.Char(str.s[idx]);
+};
+
+// Closures
+scheme.Closure = function(f, size) {
+ this.fun = f;
+ this.freevars = new Array(size);
+ return this;
+};
+
+scheme.primitives["free-set!"] = function (closure, idx, obj) {
+ closure.freevars[idx] = obj;
+};
+
+scheme.primitives["free-ref"] = function (closure, idx) {
+ return closure.freevars[idx];
+};
+
+scheme.primitives["builtin-ref"] = function (idx) {
+ return scheme.builtins[idx];
+};
+
+// Syntax Objects
+scheme.Syntax = function (expr, wrap, module) {
+ this.expr = expr;
+ this.wrap = wrap;
+ this.module = module;
+ return this;
+};
+
+// Hashtables
+scheme.HashTable = function (is_weak) {
+ // HashTable definition needs to come before scm_pre_modules_obarray
+
+ // ignore the is_weak argument, since we can't iterate over js WeakMaps
+ this.table = new Map(); // WeakMap();
+
+ this.lookup = function (obj, dflt) {
+ if (this.table.has(obj)) {
+ return this.table.get(obj);
+ } else {
+ return dflt;
+ }
+ };
+
+ this.get = function(key) {
+ return this.table.get(key);
+ };
+
+ this.set = function (key, obj) {
+ this.table.set(key, obj);
+ return obj;
+ };
+
+ this.delete = function (key) {
+ this.table.delete(key);
+ return scheme.FALSE; // or handle
+ };
+
+ this.clear = function () {
+ this.table.clear();
+ return scheme.UNSPECIFIED;
+ };
+
+ this.keys = function () {
+ return [...this.table.keys()];
+ };
+
+ return this;
+};
+
+// Modules
+scheme.primitives["define!"] = function(sym) {
+ var mod = scm_current_module ();
+ var v = scm_module_ensure_local_variable (mod, sym);
+ return v;
+};
+
+scheme.primitives["cache-current-module!"] = function (module, scope) {
+ scheme.cache[scope] = module;
+};
+
+scheme.primitives["cached-toplevel-box"] = function (scope, sym, is_bound) {
+ var module = scheme.cache[scope]; // FIXME: what if not there?
+
+ if (!scheme.is_true(module)) {
+ module = scm_the_root_module();
+ }
+
+ var v = scm_module_lookup(module, sym);
+
+ if (is_bound) {
+ // not_implemented_yet();
+ }
+
+ return v;
+};
+
+var scm_pre_modules_obarray = new scheme.HashTable();
+var the_root_module;
+
+function scm_the_root_module() {
+ if (module_system_is_booted)
+ return the_root_module.x;
+ else
+ return scheme.FALSE;
+}
+
+scheme.primitives["cached-module-box"] = function (module_name, sym, is_public, is_bound) {
+ var v;
+
+ if (!module_system_is_booted) {
+ if (module_name instanceof scheme.Pair
+ && module_name.car.name === "guile"
+ && module_name.cdr === scheme.EMPTY) {
+ v = scm_lookup (sym);
+ } else {
+ not_implemented_yet();
+ }
+ } else if (sym.name === "equal?") {
+ // FIXME: this hack exists to work around a miscompilation of
+ // equal? which is not being handled as a toplevel reference.
+ // This leads to an infinite loop in the temporary definition of
+ // resolve-module, which is called by cache-module-box.
+ v = scm_pre_modules_obarray.get(sym);
+ } else if (scheme.is_true(is_public)) {
+ v = scm_public_lookup (module_name, sym);
+ } else {
+ v = scm_private_lookup (module_name, sym);
+ }
+
+ if (is_bound) {
+ // not_implemented_yet();
+ }
+
+ return v;
+};
+
+function scm_public_lookup(module_name, name) {
+ var v = scm_public_variable (module_name, name);
+ // if false, error
+ return v;
+}
+
+function scm_public_variable(module_name, name) {
+ var mod = scheme.call(resolve_module_var.x, module_name, k_ensure, scheme.FALSE);
+
+ // if (scm_is_false (mod))
+ // scm_misc_error ("public-lookup", "Module named ~s does not exist",
+ // scm_list_1 (module_name));
+
+ var iface = scm_module_public_interface (mod);
+
+ // if (scm_is_false (iface))
+ // scm_misc_error ("public-lookup", "Module ~s has no public interface",
+ // scm_list_1 (mod));
+
+ return scm_module_variable (iface, name);
+}
+
+var module_public_interface_var;
+
+function scm_module_public_interface (module) {
+ return scheme.call(module_public_interface_var.x, module);
+}
+
+function scm_private_lookup(module_name, sym) {
+ // FIXME: scm_private_variable + miscerror if not bound
+ return scm_private_variable(module_name, sym);
+}
+
+function scm_private_variable (module_name, name) {
+ var mod = scheme.call(resolve_module_var.x, module_name, k_ensure, scheme.FALSE);
+
+ // if (scm_is_false (mod))
+ // scm_misc_error ("private-lookup", "Module named ~s does not exist",
+ // scm_list_1 (module_name));
+
+ return scm_module_variable (mod, name);
+}
+
+scheme.primitives["current-module"] = scm_current_module;
+
+scheme.primitives["resolve"] = function (sym, is_bound) {
+ var v = scm_lookup(sym);
+
+ if (is_bound) {
+ // not_implemented_yet();
+ };
+
+ return v;
+};
+
+function scm_current_module() {
+ if (module_system_is_booted) {
+ return the_module.value;
+ } else {
+ return scheme.FALSE;
+ }
+}
+
+function scm_lookup(sym) {
+ return scm_module_lookup(scm_current_module(), sym);
+};
+
+scheme.call = function (func) {
+ var args = Array.prototype.slice.call(arguments, 1);
+ args.unshift(scheme.initial_cont);
+ args.unshift(func);
+ return func.fun.apply(func, args);
+};
+
+function scm_module_ensure_local_variable(module, sym) {
+ if (module_system_is_booted) {
+ // SCM_VALIDATE_MODULE (1, module);
+ // SCM_VALIDATE_SYMBOL (2, sym);
+ // FIXME: this will need a specific continuation
+ return scheme.call(module_make_local_var_x_var.x, module, sym);
+ } else {
+ var box = scm_pre_modules_obarray.lookup(sym, false);
+ if (box) {
+ return box;
+ } else {
+ var v = new scheme.Box(scheme.UNDEFINED);
+ scm_pre_modules_obarray.set(sym, v);
+ return v;
+ }
+ }
+}
+
+function scm_module_variable(module, sym) {
+ // if booted, validate module
+ // validate symbol
+ if (scheme.is_true(module)) {
+ // 1. Check Module Obarray
+ if (module instanceof scheme.Struct) {
+ var obarray = module.fields[0];
+ var v = obarray.lookup(sym, scheme.UNDEFINED);
+ if (v === scheme.UNDEFINED) { // is_false
+ // 2. Search among the imported variables
+ v = module_imported_variable(module, sym);
+ return v;
+ // can't be imported
+ not_implemented_yet();
+ } else {
+ return v;
+ }
+ }
+ // 2. Search among the imported variables
+ // 3. Query the custom binder
+ // 4. Return False
+ not_implemented_yet();
+ }
+
+ return scm_pre_modules_obarray.lookup(sym, scheme.UNDEFINED);
+}
+
+var scm_module_index_obarray = 0;
+var scm_module_index_uses = 1;
+var scm_module_index_import_obarray = 8;
+function module_imported_variable(module, sym) {
+ // search cached imported bindings
+ var imports = module.fields[scm_module_index_import_obarray];
+ var v = imports.lookup(sym, scheme.UNDEFINED);
+ if (!(scheme.UNDEFINED === (v))) {
+ return v;
+ }
+ // search use list
+ var uses = module.fields[scm_module_index_uses];
+ var found_var = scheme.FALSE;
+ var found_iface = scheme.FALSE;
+ for (; uses instanceof scheme.Pair; uses = uses.cdr) {
+ var iface = uses.car;
+ var v = scm_module_variable(iface, sym);
+ if (scheme.is_true(v)) {
+ if (scheme.is_true(found_var)) {
+ console.log("resolve duplicate binding");
+ not_implemented_yet();
+ } else {
+ found_var = v;
+ found_iface = iface;
+ }
+ }
+ }
+ if (scheme.is_true(found_var)) {
+ imports.set(sym, found_var);
+ return found_var;
+ }
+ return scheme.FALSE;
+}
+
+function scm_module_define(module, sym, val) {
+ var v = scm_module_ensure_local_variable(module, sym);
+ v.x = val;
+ return v;
+}
+
+function scm_module_lookup(module, sym) {
+ var v = scm_module_variable(module, sym);
+ if (scheme.is_true(v)) {
+ return v;
+ }
+ not_implemented_yet(); // FIXME: unbound
+}
+
+
+var module_system_is_booted = false;
+
+var module_make_local_var_x_var =
+ scm_module_define(scm_current_module(),
+ new scheme.Symbol("module-make-local-var!"),
+ scheme.UNDEFINED);
+
+
+// bleh
+scheme.initial_cont = function (x) { return x; };
+scheme.primitives.return = function (x) { return x; };
+scheme.is_true = function (obj) {
+ return !(obj === scheme.FALSE || obj === scheme.NIL);
+};
+
+// Builtins
+var apply = function(self, k, f) {
+ var args = Array.prototype.slice.call(arguments, 3);
+ var tail = args.pop();
+
+ while (scheme.is_true(scheme.primitives["pair?"](tail))) {
+ args.push(tail.car);
+ tail = tail.cdr;
+ };
+
+ return f.fun.apply(f.fun, [f,k].concat(args));
+};
+
+var values = function(self, k) {
+ var args = Array.prototype.slice.call(arguments, 2);
+ return k.apply(k,args);
+};
+
+var abort_to_prompt = function(self, k, prompt) {
+
+ var args = Array.prototype.slice.call(arguments, 3);
+ var idx = find_prompt(prompt);
+ var frame = scheme.dynstack[idx];
+
+ var kont = undefined; // actual value doesn't matter
+
+ if (!scheme.is_true(frame.escape_only)) {
+ var f = function (self, k2) {
+ var args = Array.prototype.slice.call(arguments, 2);
+ return k.apply(k,args);
+ };
+ kont = new scheme.Closure(f, 0);
+ };
+
+ unwind(scheme.dynstack, idx); // FIXME:
+
+ var handler = frame.handler;
+ args.unshift(kont);
+ return handler.apply(handler, args);
+};
+
+var call_with_values = function (self, k, producer, consumer) {
+ var k2 = function () {
+ var args = Array.prototype.slice.call(arguments);
+ return consumer.fun.apply(consumer.fun, [consumer, k].concat(args));
+ };
+ return producer.fun(producer, k2);
+};
+
+var callcc = function (self, k, closure) {
+ var dynstack = scheme.dynstack.slice();
+
+ var f = function (self, k2) {
+ var args = Array.prototype.slice.call(arguments, 2);
+
+ var i = shared_stack_length(dynstack, scheme.dynstack);
+
+ unwind(scheme.dynstack, i);
+ wind(dynstack, i);
+ scheme.dynstack = dynstack;
+
+ return k.apply(k,args);
+ };
+ return closure.fun(closure, k, new scheme.Closure(f, 0));
+};
+scheme.builtins[0] = new scheme.Closure(apply, 0);
+scheme.builtins[1] = new scheme.Closure(values, 0);
+scheme.builtins[2] = new scheme.Closure(abort_to_prompt, 0);
+scheme.builtins[3] = new scheme.Closure(call_with_values, 0);
+scheme.builtins[4] = new scheme.Closure(callcc, 0);
+
+// Structs
+scheme.Struct = function (vtable, nfields) {
+ this.is_vtable = false;
+ this.vtable = vtable;
+ this.fields = [];
+
+ if (this.vtable && this.vtable.hasOwnProperty('children_applicable_vtables')) {
+ this.is_vtable = true;
+ this.children_applicable = true;
+ }
+
+ if (this.vtable && this.vtable.hasOwnProperty('children_applicable')) {
+ this.is_applicable = true;
+ this.fun = function (self, cont) {
+ var scm_applicable_struct_index_procedure = 0;
+ var clos = self.fields[scm_applicable_struct_index_procedure];
+ return clos.fun(clos, cont);
+ };
+ } else {
+ this.fun = function () { throw "not applicable"; };
+ }
+
+ // FIXME: worth doing?
+ for(var i = 0; i < nfields; i++){
+ this.fields[i]=scheme.UNDEFINED;
+ }
+
+ return this;
+};
+
+scheme.primitives["struct?"] = function (obj) {
+ return coerce_bool(obj instanceof scheme.Struct);
+};
+
+scheme.primitives["allocate-struct/immediate"] = function (vtable, nfields) {
+ return new scheme.Struct(vtable, nfields);
+};
+
+scheme.primitives["struct-vtable"] = function(struct) {
+ return struct.vtable;
+};
+
+scheme.primitives["struct-set!"] = function (struct, idx, obj) {
+ struct.fields[idx] = obj;
+ return;
+};
+
+scheme.primitives["struct-ref"] = function (struct, idx) {
+ return struct.fields[idx];
+};
+
+scheme.primitives["struct-set!/immediate"] = scheme.primitives["struct-set!"];
+scheme.primitives["struct-ref/immediate"] = scheme.primitives["struct-ref"];
+
+// Equality
+scheme.primitives["eq?"] = function(x, y) {
+ return coerce_bool(x === y);
+};
+
+scheme.primitives["eqv?"] = function(x, y) {
+ return coerce_bool(x === y);
+};
+
+// Fluids
+scheme.Fluid = function (x) {
+ this.value = x;
+ return this;
+};
+
+var the_module = new scheme.Fluid(scheme.FALSE);
+
+scheme.primitives["pop-fluid"] = function () {
+ var frame = scheme.dynstack.shift();
+ if (frame instanceof scheme.frame.Fluid) {
+ frame.fluid.value = frame.old_value;
+ return;
+ } else {
+ throw "not a frame";
+ };
+};
+
+scheme.primitives["push-fluid"] = function (fluid, new_value) {
+ var old_value = fluid.value;
+ fluid.value = new_value;
+ var frame = new scheme.frame.Fluid(fluid, old_value);
+ scheme.dynstack.unshift(frame);
+ return;
+};
+
+scheme.primitives["fluid-ref"] = function (fluid) {
+ // TODO: check fluid type
+ return fluid.value;
+};
+
+// Variables
+scheme.primitives["variable?"] = function (obj) {
+ // FIXME: should variables be distinct from boxes?
+ return coerce_bool(obj instanceof scheme.Box);
+};
+
+// Dynamic Wind
+scheme.primitives["wind"] = function(enter, leave) {
+ var frame = new scheme.frame.DynWind(enter, leave);
+ scheme.dynstack.unshift(frame);
+};
+
+scheme.primitives["unwind"] = function () {
+ var frame = scheme.dynstack.shift();
+ if (!(frame instanceof scheme.frame.DynWind) &&
+ !(frame instanceof scheme.frame.Prompt)) {
+ throw "not a dynamic wind frame";
+ };
+};
+
+// Misc
+scheme.primitives["prompt"] = function(escape_only, tag, handler){
+ var frame = new scheme.frame.Prompt(tag, escape_only, handler);
+ scheme.dynstack.unshift(frame);
+};
+
+var shared_stack_length = function (dynstack1, dynstack2) {
+ // Assumes that if it matches at i then it matches for all x<i,
+ // which will be fine given that we don't reuse frames
+ var size1 = dynstack1.length;
+ var size2 = dynstack2.length;
+ var last = Math.min(size1, size2);
+
+ var i = last-1;
+ for (; i >= 0; i--) {
+ if (dynstack1[i] === dynstack2[i]) {
+ break;
+ }
+ };
+
+ return i + 1;
+};
+
+var wind = function (dynstack, idx) {
+ for (var i = idx; i < dynstack.length; i++) {
+ var frame = dynstack[i];
+ if (frame instanceof scheme.frame.DynWind) {
+ // TODO: how to handle continuations and errors in this?
+ frame.wind.fun(frame.wind, scheme.initial_cont);
+ } else {
+ throw "unsupported frame type -- wind";
+ }
+ }
+};
+
+var unwind = function (dynstack, idx) {
+ for (var i = dynstack.length - 1; i >= idx; i--) {
+ var frame = dynstack[i];
+ if (frame instanceof scheme.frame.DynWind) {
+ // TODO: how to handle continuations and errors in this?
+ frame.unwind.fun(frame.unwind, scheme.initial_cont);
+ } else {
+ throw "unsupported frame type -- unwind";
+ }
+ }
+};
+
+var find_prompt = function(prompt) {
+ var eq = scheme.primitives["eq?"];
+ function test(x){
+ return scheme.is_true(eq(x,prompt)) || scheme.is_true(eq(x,scheme.TRUE));
+ };
+ for (idx in scheme.dynstack) {
+ var frame = scheme.dynstack[idx];
+ if (frame instanceof scheme.frame.Prompt && test(frame.tag)) {
+ return idx;
+ };
+ };
+ // FIXME: should error
+ return undefined;
+};
+
+scheme.primitives["handle-interrupts"] = function () {
+ // TODO: implement
+ return;
+};
+
+// Dynstack frames
+scheme.frame = {};
+
+scheme.frame.Prompt = function(tag, escape_only, handler){
+ this.tag = tag;
+ this.escape_only = escape_only;
+ this.handler = handler;
+};
+
+scheme.frame.Fluid = function(fluid, old_value) {
+ this.fluid = fluid;
+ this.old_value = old_value;
+};
+
+scheme.frame.DynWind = function(wind, unwind) {
+ this.wind = wind;
+ this.unwind = unwind;
+};
+
+function def_guile0 (name, fn) {
+ var clos = new scheme.Closure(fn, 0);
+ def_guile_val(name, clos);
+};
+
+function def_guile_val (name, val) {
+ var sym = new scheme.Symbol(name); // put in obarray
+ var box = new scheme.Box(val);
+ scm_pre_modules_obarray.set(sym,box);
+};
+
+function scm_list (self, cont) {
+ var l = scheme.EMPTY;
+ for (var i = arguments.length - 1; i >= 2; i--){
+ l = scheme.primitives.cons(arguments[i],l);
+ };
+ return cont(l);
+};
+def_guile0("list", scm_list);
+
+// Numbers
+function scm_add(self, cont) {
+
+ var total = 0;
+ for (var i = arguments.length - 1; i >= 2; i--){
+ total += arguments[i];
+ };
+ return cont(total);
+
+};
+def_guile0("+", scm_add);
+
+function scm_mul(self, cont) {
+
+ var total = 1;
+ for (var i = arguments.length - 1; i >= 2; i--){
+ total *= arguments[i];
+ };
+ return cont(total);
+
+};
+def_guile0("*", scm_mul);
+
+def_guile0("integer?", function(self, cont, obj) {
+ // return coerce_bool(Number.isInteger(obj)); // ES6
+ return cont(coerce_bool(typeof(obj) === 'number'));
+});
+
+// Lists
+def_guile0("make-list", function (self, cont, n, obj) {
+ var list = scheme.EMPTY;
+
+ for (var i = 0; i <= n; i++) {
+ list = new scheme.Pair(obj, list);
+ }
+
+ return cont(list);
+});
+
+def_guile0("cons", function (self, cont, car, cdr) {
+ return cont(scheme.primitives.cons(car, cdr));
+});
+
+def_guile0("length", function (self, cont, list) {
+ var len = 0;
+
+ while (!scheme.is_true(scheme.primitives["null?"](list))) {
+ if (scheme.is_true(scheme.primitives["pair?"](list))) {
+ list = list.cdr;
+ len += 1;
+ } else {
+ console.log("length bad");
+ not_implemented_yet();
+ }
+ }
+
+ return cont(len);
+});
+
+def_guile0("list?", function (self, cont, list) {
+
+ while (!scheme.is_true(scheme.primitives["null?"](list))) {
+ if (scheme.is_true(scheme.primitives["pair?"](list))) {
+ list = list.cdr;
+ } else {
+ return cont(scheme.FALSE);
+ }
+ }
+
+ return cont(scheme.TRUE);
+});
+
+def_guile0("reverse", function (self, cont, lst) {
+ var l = scheme.EMPTY;
+ while (lst != scheme.EMPTY) {
+ l = scheme.primitives.cons(lst.car, l);
+ lst = lst.cdr;
+ }
+ return cont(l);
+});
+
+def_guile0("append", function (self, cont, l1, l2) {
+ if (arguments.length != 4) {
+ console.log("FIXAPPEND", arguments.length);
+ throw "fail";
+ }
+
+
+ if (l1 === scheme.EMPTY) {
+ return cont(l2);
+ }
+
+ var l = new scheme.Pair(l1.car, l2);
+
+ var lp = l;
+ while (scheme.is_true(scheme.primitives["pair?"](l1.cdr))) {
+
+ var lo = new scheme.Pair(l1.cdr.car, l2);
+ lp.cdr = l2;
+
+ lp = lp.cdr;
+ l1 = l1.cdr;
+ }
+
+ return cont(l);
+});
+
+function scm_equal(x,y) {
+ if (x instanceof scheme.Pair) {
+ if (y instanceof scheme.Pair) {
+ return (scm_equal(x.car,y.car) && scm_equal(x.cdr,y.cdr));
+ } else {
+ return false;
+ }
+ } else if (y instanceof scheme.Pair) {
+ return false;
+ } else {
+ return (x === y);
+ }
+}
+
+def_guile0("equal?", function (self, cont, x, y) {
+ return cont(coerce_bool(scm_equal(x,y)));
+});
+
+def_guile0("memq", function (self, cont, elt, list) {
+ // FIXME: validate list
+ for (; list != scheme.EMPTY && list != scheme.NIL; list = list.cdr) {
+ if (elt === list.car) { // FIXME: eqv
+ return cont(list);
+ }
+ }
+ return cont(scheme.FALSE);
+});
+
+def_guile0("member", function (self, cont, elt, list) {
+ // FIXME: validate list
+ for (; list != scheme.EMPTY && list != scheme.NIL; list = list.cdr) {
+ if (scm_equal(elt, list.car)) {
+ return cont(list);
+ }
+ }
+ return cont(scheme.FALSE);
+});
+
+def_guile0("delete!", function (self, cont, elt, list) {
+ // FIXME: validate list
+ if (list instanceof scheme.Pair) {
+ // initially skip car;
+ for (var prev = list, walk = list.cdr;
+ walk instanceof scheme.Pair;
+ walk = walk.cdr) {
+
+ if (scm_equal(walk.car, elt)) {
+ prev.cdr = walk.cdr;
+ } else {
+ prev = prev.cdr;
+ }
+ }
+ // fixup car in return value, but can't delete
+ if (scm_equal(list.car, elt)) {
+ return cont(list.cdr);
+ }
+ }
+
+ return cont(list);
+});
+
+// Macros
+scheme.Macro = function (name, type, binding) {
+ // TODO: prim field?
+ this.name = name;
+ this.type = type;
+ this.binding = binding;
+ return this;
+};
+
+def_guile0("make-syntax-transformer", function (self, cont, name, type, binding) {
+ return cont(new scheme.Macro(name, type, binding));
+});
+
+function scm_is_syntax (self, cont, obj) {
+ return cont(coerce_bool(obj instanceof scheme.Syntax));
+};
+def_guile0("syntax?", scm_is_syntax);
+
+def_guile0("make-syntax", function (self, cont, expr, wrap, module) {
+ return cont(new scheme.Syntax(expr, wrap, module));
+});
+
+def_guile0("syntax-expression", function (self, cont, obj) {
+ return cont(obj.expr);
+});
+
+def_guile0("syntax-wrap", function (self, cont, obj) {
+ return cont(obj.wrap);
+});
+
+def_guile0("syntax-module", function (self, cont, obj) {
+ return cont(obj.module);
+});
+
+// Symbols
+def_guile0("symbol->string", function (self, cont, sym) {
+ return cont(new scheme.String(sym.name));
+});
+
+var gensym_counter = 0;
+function scm_gensym (self, cont, prefix) {
+ var name = prefix ? prefix.s : "gen ";
+ name += gensym_counter;
+ gensym_counter += 1;
+
+ return cont(new scheme.Symbol(name));
+};
+def_guile0("gensym", scm_gensym);
+
+// Chars
+def_guile0("char=?", function (self, cont, char1, char2) {
+ return cont(char1.c === char2.c);
+});
+
+// Strings
+def_guile0("string=?", function (self, cont, s1, s2) {
+ return cont(coerce_bool(s1.s === s2.s));
+});
+
+def_guile0("string-append", function (self, cont, s1, s2) {
+ var s = "";
+
+ for (var i = 2; i < arguments.length; i++) {
+ s += arguments[i].s;
+ }
+
+ //console.log("sap", s1, s2, arguments.length);
+ return cont(new scheme.String(s));
+});
+
+def_guile0("string-join", function (self, cont, strings) {
+ var s = "";
+
+ while (!scheme.is_true(scheme.primitives["null?"](strings))) {
+ if (scheme.is_true(scheme.primitives["pair?"](strings))) {
+ s += strings.car.s;
+ strings = strings.cdr;
+ } else {
+ console.log("string-join bad");
+ not_implemented_yet();
+ }
+ }
+
+ return cont(new scheme.String(s));
+});
+
+// Fluids
+def_guile0("make-fluid", function (self, cont, val) {
+ if (val === undefined) {
+ val = scheme.FALSE;
+ }
+ return cont(new scheme.Fluid(val));
+});
+
+// Structs
+var vtable_base_layout = new scheme.String("pruhsruhpwphuhuh");
+def_guile_val("standard-vtable-fields", vtable_base_layout);
+
+var scm_vtable_index_layout = 0;
+var scm_vtable_index_flags = 1;
+var scm_vtable_index_self = 2;
+var scm_vtable_index_instance_finalize = 3;
+var scm_vtable_index_instance_printer = 4;
+var scm_vtable_index_name = 5;
+var scm_vtable_index_size = 6;
+var scm_vtable_index_reserved_7 = 7;
+var scm_vtable_offset_user = 8;
+
+function scm_struct_init(struct, layout, args) {
+ // FIXME: assumes there are no tail arrays
+ var nfields = layout.length / 2; // assumes even
+ var arg = 0;
+
+ for (var i = 0; i < nfields; i++) {
+ if (layout[2*i+1] == 'o' || layout[2*i+1] == 'h') {
+ continue;
+ }
+ switch (layout[2*i]) {
+ case 'p' :
+ struct.fields[i] = (arg < args.length) ? args[arg] : scheme.FALSE;
+ arg += 1;
+ break;
+ case 'u' :
+ struct.fields[i] = (arg < args.length) ? args[arg] : 0;
+ arg += 1;
+ break;
+ case 's' :
+ struct.fields[i] = struct;
+ }
+ }
+};
+
+// Set up <standard-vtable>
+var scm_standard_vtable = new scheme.Struct(undefined, 0);
+scm_standard_vtable.vtable = scm_standard_vtable;
+scm_standard_vtable.is_vtable = true; // ?
+scm_struct_init(scm_standard_vtable,
+ vtable_base_layout.s,
+ [new scheme.Symbol(vtable_base_layout.s)]);
+// scm_set_struct_vtable_name_x (scm_standard_vtable_vtable, name);
+
+def_guile_val("<standard-vtable>", scm_standard_vtable);
+def_guile_val("vtable-index-layout", scm_vtable_index_layout);
+def_guile_val("vtable-index-printer", scm_vtable_index_instance_printer);
+def_guile_val("vtable-offset-user", scm_vtable_offset_user);
+
+
+function scm_make_struct (vtable, args) {
+ var layout = vtable.fields[scm_vtable_index_layout].name;
+ var s = new scheme.Struct(vtable, layout.length / 2);
+ scm_struct_init(s, layout, args);
+ return s;
+}
+
+def_guile0("make-struct/no-tail", function (self, cont, vtable) {
+ var args = Array.prototype.slice.call(arguments, 3);
+ return cont(scm_make_struct(vtable, args));
+});
+
+def_guile0("make-vtable", function(self, cont, fields, printer) {
+ var layout = new scheme.Symbol(fields.s); // make-struct-layout
+ var str = scm_make_struct(scm_standard_vtable, [layout, printer]);
+ str.is_vtable = true;
+ return cont(str);
+});
+
+def_guile0("make-struct-layout", function (self, cont, str) {
+ var layout = new scheme.Symbol(str.s);
+ return cont(layout);
+});
+
+def_guile0("struct-vtable?", function (self, cont, obj) {
+ // We don't inherit flags, so =struct-vtable?= may give the wrong
+ // answer where SCM_VTABLE_FLAG_VTABLE would have been set
+ var bool = coerce_bool(obj instanceof scheme.Struct && obj.is_vtable);
+ return cont(bool);
+});
+
+var applicable_vtable = scm_make_struct(scm_standard_vtable, [new scheme.Symbol(vtable_base_layout.s)]);
+applicable_vtable.children_applicable_vtables = true;
+
+def_guile_val("<applicable-struct-vtable>", applicable_vtable);
+
+def_guile_val("record-type-vtable", scm_standard_vtable); // FIXME:
+
+def_guile0("set-struct-vtable-name!", function (self, cont, val, args) {
+ // FIXME:
+ return cont(scheme.FALSE);
+});
+
+def_guile0("make-struct", function (self, cont, vtable, tailsize) {
+ if (tailsize === 0) {
+ // make-struct/no-tail
+ var args = Array.prototype.slice.call(arguments, 4);
+ return cont(scm_make_struct(vtable, args));
+ } else {
+ console.log("make-struct with tail", arguments);
+ not_implemented_yet();
+ }
+});
+
+// Procedures
+def_guile0("procedure?", function (self, cont, obj) {
+ return cont(coerce_bool(obj instanceof scheme.Closure));
+});
+
+def_guile0("set-procedure-property!", function (self, cont, procedure, property, obj) {
+ return cont(scheme.FALSE);
+});
+
+def_guile0("make-procedure-with-setter", function (self, cont, procedure, setter) {
+ return cont(scheme.FALSE);
+});
+
+// Hashtables
+def_guile0("make-hash-table", function (self, cont, size) {
+ return cont(new scheme.HashTable());
+});
+
+def_guile0("make-weak-key-hash-table", function (self, cont, size) {
+ return cont(new scheme.HashTable(true));
+});
+
+def_guile0("make-weak-value-hash-table", function (self, cont, size) {
+ // FIXME:
+ return cont(new scheme.HashTable(true));
+});
+
+def_guile0("hash-clear!", function (self, cont, hashtable) {
+ return cont(hashtable.clear());
+});
+
+def_guile0("hashq-remove!", function (self, cont, htable, key) {
+ return cont(htable.delete(key));
+});
+
+def_guile0("hashq-ref", function(self, cont, obarray, sym, dflt) {
+ return cont(obarray.lookup(sym, dflt ? dflt : scheme.FALSE));
+});
+
+def_guile0("hashq-set!", function (self, cont, hashtable, key, obj) {
+ return cont(hashtable.set(key,obj));
+});
+
+def_guile0("hash-for-each", function (self, cont, proc, htable) {
+ var keys = htable.keys(); // don't know if I can use js iterators
+
+ var loop = function (i) {
+ if (i === keys.length) {
+ return cont(scheme.UNSPECIFIED);
+ } else {
+ var newk = function() {
+ return loop(i+1);
+ };
+ return proc.fun(proc, newk, keys[i], htable.get(keys[i]));
+ }
+ };
+
+ return loop(0);
+});
+
+def_guile0("hash-map->list", function (self, cont, proc, htable) {
+ var keys = htable.keys(); // don't know if I can use js iterators
+
+ var loop = function (i, retval, k) {
+ if (i === keys.length) {
+ return k(retval);
+ } else {
+ var newk = function(result) {
+ return loop(i+1, scheme.primitives.cons(result, retval), k);
+ };
+ return proc.fun(proc, newk, keys[i], htable.get(keys[i]));
+ }
+ };
+
+ return loop(0, scheme.EMPTY, cont);
+});
+
+// Modules
+def_guile0("make-variable", function (self, cont, val) {
+ return cont(new scheme.Box(val));
+});
+def_guile0("make-undefined-variable", function (self, cont, val) {
+ return cont(new scheme.Box(scheme.UNDEFINED));
+});
+
+def_guile0("variable-bound?", function (self, cont, box) {
+ return cont(coerce_bool(!(box.x === scheme.UNDEFINED)));
+});
+
+def_guile0("define!", function (self, cont, symbol, value) {
+ // FIXME: validate symbol
+ return cont(scm_module_define(scm_current_module(), symbol, value));
+});
+
+var boot_modules = {};
+
+function scm_primitive_load_path (self, cont, path) {
+ if (path.s in boot_modules) {
+ return boot_modules[path.s](cont);
+ } else {
+ console.log("primitive load path", arguments);
+ not_implemented_yet();
+ }
+};
+def_guile0("primitive-load-path", scm_primitive_load_path);
+
+boot_modules["ice-9/deprecated"] = function () {};
+boot_modules["ice-9/ports"] = function () {};
+boot_modules["ice-9/posix"] = function () {};
+boot_modules["ice-9/threads"] = function () {};
+boot_modules["srfi/srfi-4"] = function () {};
+
+def_guile0("module-local-variable", function (self, cont, module, symbol) {
+ // module system is booted, then validate module
+ // validate symbol
+ if (!scheme.is_true(module)) {
+ // hashq ref
+ return cont(scm_pre_modules_obarray.lookup(symbol, scheme.UNDEFINED));
+ }
+ // 1. check module_obarray
+ var obarray = module.fields[0]; // SCM_MODULE_OBARRAY
+ var b = obarray.lookup(symbol, scheme.UNDEFINED);
+ if (b != scheme.UNDEFINED) { // is_true
+ return cont(b);
+ }
+
+ // FIXME: check binders
+ return cont(scheme.FALSE);
+});
+
+def_guile0("module-variable", function (self, cont, module, symbol) {
+ return cont(scm_module_variable(module, symbol));
+});
+
+def_guile0("%get-pre-modules-obarray", function (self, cont) {
+ return cont(scm_pre_modules_obarray);
+});
+
+def_guile0("set-current-module", function (self, cont, module) {
+
+ if (!module_system_is_booted) {
+ scm_post_boot_init_modules ();
+ }
+ // SCM_VALIDATE_MODULE (SCM_ARG1, module);
+
+ var old = scm_current_module ();
+ the_module.value = module;
+ return cont(old);
+});
+
+var k_ensure;
+var resolve_module_var;
+
+function scm_post_boot_init_modules() {
+ module_system_is_booted = true;
+ the_root_module = scm_lookup (new scheme.Symbol("the-root-module"));
+ k_ensure = new scheme.Keyword("ensure");
+ resolve_module_var = scm_lookup (new scheme.Symbol("resolve-module"));
+ module_public_interface_var = scm_lookup (new scheme.Symbol("module-public-interface"));
+}
+
+// Stubs
+function stub(name) {
+ function scm_fn (self, cont) {
+ console.log(name, arguments);
+ not_implemented_yet();
+ };
+ def_guile0(name, scm_fn);
+};
+
+stub("syntax-session-id");
+stub("macroexpand");
+stub("%exception-handler");
+stub("print-exception");
+def_guile_val("*features*", scheme.EMPTY);
+stub("%load-hook");
+stub("current-reader");
+
+def_guile0("read-hash-extend", function (self, cont, char, fun) {
+ return cont(scheme.FALSE);
+});
+
+scheme.Hook = function (arity) {
+ this.arity = arity;
+ this.procs = [];
+};
+
+def_guile0("make-hook", function (self, cont, nargs) {
+ var arity = (nargs === undefined) ? 0 : nargs;
+ return cont(new scheme.Hook(arity));
+});
+
+def_guile0("run-hook", function (self, cont, hook) {
+ var procs = hook.procs;
+ var args = Array.prototype.slice.call(arguments, 3);
+ // FIXME: validate hook
+ // FIXME: check num args = arity or error
+
+ var loop = function (i) {
+ if (i === procs.length) {
+ return cont(scheme.UNSPECIFIED);
+ } else {
+ var newk = function() {
+ return loop(i+1);
+ };
+
+ var proc = procs[i];
+ return proc.fun.apply(proc.fun, [proc, newk].concat(args));
+ }
+ };
+ return loop(0);
+});
+
+function scm_simple_format (self, cont) {
+ not_implemented_yet();
+};
+def_guile0("simple-format", scm_simple_format);
+
+def_guile0("scm-error", function (self, cont, key, subr, message, args, data) {
+ not_implemented_yet();
+});
+
diff --git a/module/language/js-il/spec.scm b/module/language/js-il/spec.scm
new file mode 100644
index 000000000..2e933abe4
--- /dev/null
+++ b/module/language/js-il/spec.scm
@@ -0,0 +1,31 @@
+;;; JavaScript Intermediate Language (JS-IL)
+
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language js-il spec)
+ #:use-module (system base language)
+ #:use-module (language js-il compile-javascript)
+ #:export (js-il))
+
+(define-language js-il
+ #:title "Javascript Intermediate Language"
+ #:reader #f
+ #:compilers `((javascript . ,compile-javascript))
+ #:printer #f
+ #:for-humans? #f)
diff --git a/module/scripts/jslink.scm b/module/scripts/jslink.scm
new file mode 100644
index 000000000..06d4dec17
--- /dev/null
+++ b/module/scripts/jslink.scm
@@ -0,0 +1,215 @@
+;;; jslink --- Link Together JS Modules
+
+;; Copyright 2017 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ian Price <ianprice90@gmail.com>
+
+;;; Commentary:
+
+;; Usage: jslink [ARGS]
+;;
+;; A command-line tool for linking together compiled JS modules.
+
+;;; Code:
+
+(define-module (scripts jslink)
+ #:use-module (system base compile)
+ #:use-module (system base language)
+ #:use-module (language javascript)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 format)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:export (jslink))
+
+(define %summary "Link a JS module.")
+
+(define* (copy-port from #:optional (to (current-output-port)) #:key (buffer-size 1024))
+ (define bv (make-bytevector buffer-size))
+ (let loop ()
+ (let ((num-read (get-bytevector-n! from bv 0 buffer-size)))
+ (unless (eof-object? num-read)
+ (put-bytevector to bv 0 num-read)
+ (loop)))))
+
+(define boot-dependencies
+ '(("ice-9/posix" . #f)
+ ("ice-9/ports" . (ice-9 ports))
+ ("ice-9/threads" . (ice-9 threads))
+ ("srfi/srfi-4" . (srfi srfi-4))
+
+ ("ice-9/deprecated" . #t)
+ ("ice-9/boot-9" . #t)
+ ;; FIXME: needs to be at end, or I get strange errors
+ ("ice-9/psyntax-pp" . #t)
+ ))
+
+(define (fail . messages)
+ (format (current-error-port) "error: ~{~a~}~%" messages)
+ (exit 1))
+
+(define %options
+ (list (option '(#\h "help") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'help? #t result)))
+
+ (option '("version") #f #f
+ (lambda (opt name arg result)
+ (show-version)
+ (exit 0)))
+
+ (option '(#\o "output") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'output-file)
+ (fail "`-o' option cannot be specified more than once")
+ (alist-cons 'output-file arg result))))
+
+ (option '(#\d "depends") #t #f
+ (lambda (opt name arg result)
+ (define (read-from-string s)
+ (call-with-input-string s read))
+ (let ((depends (assoc-ref result 'depends)))
+ (alist-cons 'depends (cons (read-from-string arg) depends)
+ result))))
+
+ (option '("no-boot") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'no-boot? #t result)))
+ ))
+
+(define (parse-args args)
+ "Parse argument list @var{args} and return an alist with all the relevant
+options."
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (format (current-error-port) "~A: unrecognized option" name)
+ (exit 1))
+ (lambda (file result)
+ (let ((input-files (assoc-ref result 'input-files)))
+ (alist-cons 'input-files (cons file input-files)
+ result)))
+
+ ;; default option values
+ '((input-files)
+ (depends)
+ (no-boot? . #f)
+ )))
+
+(define (show-version)
+ (format #t "compile (GNU Guile) ~A~%" (version))
+ (format #t "Copyright (C) 2017 Free Software Foundation, Inc.
+License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.~%"))
+
+(define (show-help)
+ (format #t "Usage: jslink [OPTION] FILE
+Link Javascript FILE with all its dependencies
+
+ -h, --help print this help message
+ -v, --version show version information
+ -o, --output=OFILE write output to OFILE
+ -d, --depends=DEP add dependency on DEP
+ --no-boot link without boot-9 & its dependencies
+
+Report bugs to <~A>.~%"
+ %guile-bug-report-address))
+
+(define* (link-file file #:key (extra-dependencies '()) output-file no-boot?)
+ (let ((dependencies (if no-boot?
+ extra-dependencies
+ ;; FIXME: extra-dependencies need to come before psyntax
+ (append extra-dependencies boot-dependencies)))
+ (output-file (or output-file "main.js")) ;; FIXME: changeable
+ )
+ (with-output-to-file output-file
+ (lambda ()
+ (format #t "(function () {\n")
+ (link-runtime)
+ (format #t "/* ---------- end of runtime ---------- */\n")
+ (for-each (lambda (x)
+ (let ((path (car x))
+ (file (cdr x)))
+ (link-dependency path file))
+ (format #t "/* ---------- */\n"))
+ dependencies)
+ (format #t "/* ---------- end of dependencies ---------- */\n")
+ (link-main file no-boot?)
+ (format #t "})();")
+ output-file))))
+
+(define *runtime-file* (%search-load-path "language/js-il/runtime.js"))
+
+(define (link-runtime)
+ (call-with-input-file *runtime-file* copy-port))
+
+(define (link-dependency path file)
+ (define (compile-dependency file)
+ (call-with-input-file file
+ (lambda (in)
+ ((language-printer (lookup-language 'javascript))
+ (read-and-compile in
+ #:from 'scheme
+ #:to 'javascript
+ #:env (default-environment (lookup-language 'scheme)))
+ (current-output-port)))))
+ (format #t "boot_modules[~s] =\n" path)
+ (cond ((string? file)
+ (compile-dependency file))
+ ((list? file)
+ (print-statement (compile `(define-module ,file)
+ #:from 'scheme #:to 'javascript)
+ (current-output-port))
+ (newline))
+ (file (compile-dependency (%search-load-path path)))
+ (else
+ (format #t "function (cont) { return cont(scheme.UNDEFINED); };")))
+ (newline))
+
+(define (link-main file no-boot?)
+ ;; FIXME: continuation should be changeable with a switch
+ (call-with-input-file file
+ (lambda (in)
+ (format #t "var main =\n")
+ (copy-port in)
+ (newline)
+ (if no-boot?
+ (format #t "main(scheme.initial_cont);\n")
+ (format #t "boot_modules[\"ice-9/boot-9\"](function() {return main((function (x) {console.log(x); return x; }));});"))))) ; scheme.initial_cont
+
+(define (jslink . args)
+ (let* ((options (parse-args args))
+ (help? (assoc-ref options 'help?))
+ (dependencies (assoc-ref options 'depends))
+ (input-files (assoc-ref options 'input-files))
+ (output-file (assoc-ref options 'output-file))
+ (no-boot? (assoc-ref options 'no-boot?)))
+
+ (if (or help? (null? input-files))
+ (begin (show-help) (exit 0)))
+
+ (unless (null? (cdr input-files))
+ (fail "can only link one file at a time"))
+ (format #t "wrote `~A'\n"
+ (link-file (car input-files)
+ #:extra-dependencies dependencies
+ #:output-file output-file
+ #:no-boot? no-boot?))))
+
+(define main jslink)