...
 
Commits (51)
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2009, 2010, 2011, 2012, 2013,
## 2014, 2015 Free Software Foundation, Inc.
## 2014, 2015, 2017 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
......@@ -193,6 +193,7 @@ SOURCES = \
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 \
......@@ -257,6 +258,7 @@ SOURCES = \
scripts/frisk.scm \
scripts/generate-autoload.scm \
scripts/help.scm \
scripts/jslink.scm \
scripts/lint.scm \
scripts/list.scm \
scripts/punify.scm \
......
;;; 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 optimize (@@ (language cps compile-bytecode) optimize))
(define convert-closures (@@ (language cps compile-bytecode) convert-closures))
(define reify-primitives (@@ (language cps compile-bytecode) reify-primitives))
(define renumber (@@ (language cps compile-bytecode) renumber))
(define intmap-select (@@ (language cps compile-bytecode) intmap-select))
(define lower-cps (@@ (language cps compile-bytecode) lower-cps))
(define (compile-js exp env opts)
;; See comment in `optimize' about the use of set!.
(set! exp (optimize exp opts))
(set! exp (convert-closures exp))
;; first-order optimization should go here
(set! exp (reify-primitives exp))
(set! exp (renumber exp))
(match exp
(($ $program (($ $cont ks funs) ...))
;; 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)
(values (make-program
(map (lambda (k fun)
(cons (make-kid k) (compile-fun fun)))
ks
funs))
env
env))))
(define (compile-fun fun)
(match fun
(($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause)
;; 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 clause self)))))
(define (compile-clauses clause self)
(match clause
(($ $cont k ($ $kclause arity body #f))
`((,(make-kid k)
,(arity->params arity self)
,(compile-clause arity body self))))
(($ $cont k ($ $kclause arity body next))
`((,(make-kid k)
,(arity->params arity self)
,(compile-clause arity body self))
. ,(compile-clauses next self)))))
(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
......@@ -66,40 +111,49 @@
kw-syms)
allow-other-keys?))))
(define (compile-clause arity body self)
(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)
(match body
(($ $cont k cont)
(make-local `((,(make-kid k) . ,(compile-cont cont)))
(make-continue (make-kid k) ids)))))))))
(define (compile-term term)
(match term
(($ $letk (($ $cont ks conts) ...) body)
(make-local (map (lambda (k cont)
(cons (make-kid k)
(compile-cont cont)))
ks
conts)
(compile-term body)))
(($ $continue k src exp)
(compile-exp exp k))))
(define (compile-cont cont)
(match cont
(($ $kargs names syms body)
(make-continuation (map make-id syms) (compile-term body)))
(($ $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))))))
(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
......
;;; 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
......
;;; 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
......@@ -50,6 +71,7 @@
(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)
......@@ -66,6 +88,8 @@
(define (unparse-js exp)
(match exp
(($ assign id exp)
`(assign ,id ,(unparse-js exp)))
(($ const c)
`(const ,c))
(($ function args body)
......@@ -99,6 +123,13 @@
(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))
......@@ -168,7 +199,8 @@
((or) (display "||" port))
((and) (display "&&" port))
((=) (display "==" port))
((+ - < <= > >= ===) (format port "~a" op))
((begin) (display "," port))
((+ - < <= > >= === instanceof) (format port "~a" op))
(else
(throw 'unprintable-binop op))))
......
......@@ -15,6 +15,8 @@
(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)))
......
;;; 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)
......
;;; 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)
......
;;; 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)
......@@ -6,6 +26,7 @@
#: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)
......@@ -15,9 +36,13 @@
(eqv? obj (pointer->scm (make-pointer unbound-bits))))
(define (compile-javascript exp env opts)
(set! exp (inline-single-calls exp))
(match (memq #:js-inline? opts)
((#:js-inline? #f _ ...) #f)
(_ (set! exp (inline-single-calls exp))))
(set! exp (compile-exp exp))
(set! exp (flatten-blocks exp))
(match (memq #:js-flatten? opts)
((#:js-flatten? #f _ ...) #f)
(_ (set! exp (flatten-blocks exp))))
(values exp env env))
(define *scheme* (make-id "scheme"))
......@@ -126,6 +151,51 @@
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
......@@ -136,18 +206,17 @@
(make-call (compile-id name)
(list
(make-id "undefined")
(make-refine *scheme* (make-const "initial_cont")))))))
(make-call (make-function
'()
(append
(map (lambda (id f)
(make-var (rename-id id)
(compile-exp f)))
(cons name names)
(cons fun funs))
(list entry-call)))
'())))
(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))))
......@@ -280,8 +349,7 @@
(map compile-id opts)))))))
(($ il:params self req opts #f ((kws names ids) ...) _)
(append
(bind-opt-args opts (+ offset (length req)))
(bind-kw-args kws names (+ offset (length req)))
(bind-opt-kw-args opts kws names (+ offset (length req)))
(list
(make-return
(make-call (compile-id k)
......@@ -351,5 +419,12 @@
(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))))
;;; 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)
......@@ -69,7 +95,7 @@
counts)
(define no-values-primitives
'(define!
'(
cache-current-module!
set-cdr!
set-car!
......@@ -83,6 +109,10 @@
unwind
push-fluid
pop-fluid
handle-interrupts
push-dynamic-state
pop-dynamic-state
fluid-set!
))
(define no-values-primitive?
......@@ -93,7 +123,26 @@
(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))
......@@ -178,20 +227,4 @@
(exp 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 body '())))
ids
params
bodies)))))
(match exp
(($ program ((ids . funs) ...))
(make-program (map (lambda (id fun)
(cons id (handle-function fun)))
ids
funs)))))
(inline exp '()))
;;; 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)
......
;;; 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)