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 "#" (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 "#" (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= 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 +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("", 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_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 + +;;; 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 . +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)