summaryrefslogtreecommitdiff
path: root/module/language/javascript.scm
diff options
context:
space:
mode:
authorChristopher Lemmer Webber <cwebber@dustycloud.org>2021-05-10 15:58:15 -0400
committerChristopher Lemmer Webber <cwebber@dustycloud.org>2021-05-10 15:58:15 -0400
commit88f7aa0b3aa48f10a04715c5bc24e2039eae9c6c (patch)
tree801cb0c4bd8c4cf1e0a98bcb50c2f6b557c935d7 /module/language/javascript.scm
parent53e5cf654d5f4d95f407cd814472bcc09a69cd15 (diff)
parent05c57a6a66904861bb760aea13dd3ad3117c5966 (diff)
downloadguile-88f7aa0b3aa48f10a04715c5bc24e2039eae9c6c.tar.gz
Merge branch 'compile-to-js-2017' into compile-to-js-rebase
Diffstat (limited to 'module/language/javascript.scm')
-rw-r--r--module/language/javascript.scm274
1 files changed, 274 insertions, 0 deletions
diff --git a/module/language/javascript.scm b/module/language/javascript.scm
new file mode 100644
index 000000000..2e1ca7dcd
--- /dev/null
+++ b/module/language/javascript.scm
@@ -0,0 +1,274 @@
+;;; JavaScript Language
+
+;; Copyright (C) 2015, 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+;; Only has enough of the ecmascript language for compilation from cps
+(define-module (language javascript)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (
+ make-assign assign
+ make-const const
+ make-function function
+ make-return return
+ make-call call
+ make-block block
+ make-new new
+ make-id id
+ make-refine refine
+ make-branch branch
+ make-var var
+ make-binop binop
+ make-ternary ternary
+ make-prefix prefix
+
+ print-statement))
+
+;; Copied from (language cps)
+;; Should put in a srfi 99 module
+(define-syntax define-record-type*
+ (lambda (x)
+ (define (id-append ctx . syms)
+ (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
+ (syntax-case x ()
+ ((_ name field ...)
+ (and (identifier? #'name) (and-map identifier? #'(field ...)))
+ (with-syntax ((cons (id-append #'name #'make- #'name))
+ (pred (id-append #'name #'name #'?))
+ ((getter ...) (map (lambda (f)
+ (id-append f #'name #'- f))
+ #'(field ...))))
+ #'(define-record-type name
+ (cons field ...)
+ pred
+ (field getter)
+ ...))))))
+
+;; TODO: add type predicates to fields so I can only construct valid
+;; objects
+(define-syntax-rule (define-js-type name field ...)
+ (begin
+ (define-record-type* name field ...)
+ (set-record-type-printer! name print-js)))
+
+(define (print-js exp port)
+ (format port "#<js ~S>" (unparse-js exp)))
+
+(define-js-type assign id exp)
+(define-js-type const c)
+(define-js-type function args body)
+(define-js-type return exp)
+(define-js-type call function args)
+(define-js-type block statements)
+(define-js-type new expr)
+(define-js-type id name)
+(define-js-type refine id field)
+(define-js-type branch test then else)
+(define-js-type var id exp)
+(define-js-type binop op arg1 arg2)
+(define-js-type ternary test then else)
+(define-js-type prefix op expr)
+
+(define (unparse-js exp)
+ (match exp
+ (($ assign id exp)
+ `(assign ,id ,(unparse-js exp)))
+ (($ const c)
+ `(const ,c))
+ (($ function args body)
+ `(function ,args ,@(map unparse-js body)))
+ (($ return exp)
+ `(return ,(unparse-js exp)))
+ (($ call function args)
+ `(call ,(unparse-js function) ,@(map unparse-js args)))
+ (($ block statements)
+ `(block ,@(map unparse-js statements)))
+ (($ new expr)
+ `(new ,(unparse-js expr)))
+ (($ id name)
+ `(id ,name))
+ (($ refine id field)
+ `(refine ,(unparse-js id) ,(unparse-js field)))
+ (($ branch test then else)
+ `(if ,(unparse-js test)
+ (block ,@(map unparse-js then))
+ (block ,@(map unparse-js else))))
+ (($ var id exp)
+ `(var ,id ,(unparse-js exp)))
+ (($ binop op arg1 arg2)
+ `(binop ,op ,(unparse-js arg1) ,(unparse-js arg2)))
+ (($ ternary test then else)
+ `(ternary ,(unparse-js test) ,(unparse-js then) ,(unparse-js else)))
+ (($ prefix op expr)
+ `(prefix ,op ,(unparse-js expr)))
+ ))
+
+(define (print-exp exp port)
+ (match exp
+
+ (($ assign id exp)
+ (print-id id port)
+ (format port " = ")
+ (display "(" port)
+ (print-exp exp port)
+ (display ")" port))
+
+ (($ const c)
+ (print-const c port))
+
+ (($ id name)
+ (print-id name port))
+
+ (($ call (and ($ function _ _) fun) args)
+ (format port "(")
+ (print-exp fun port)
+ (format port ")(")
+ (print-separated args print-exp "," port)
+ (format port ")"))
+
+ (($ call fun args)
+ (print-exp fun port)
+ (format port "(")
+ (print-separated args print-exp "," port)
+ (format port ")"))
+
+
+ (($ refine expr field)
+ (print-exp expr port)
+ (format port "[")
+ (print-exp field port)
+ (format port "]"))
+
+ (($ function params body)
+ (format port "function (")
+ (print-separated params print-id "," port)
+ (format port ")")
+ (print-block body port))
+
+ (($ block stmts)
+ (print-block stmts port))
+
+ (($ new expr)
+ (format port "new ")
+ (print-exp expr port))
+
+ (($ binop op arg1 arg2)
+ (display "(" port)
+ (print-exp arg1 port)
+ (display ")" port)
+ (print-binop op port)
+ (display "(" port)
+ (print-exp arg2 port)
+ (display ")" port))
+
+ (($ ternary test then else)
+ (display "(" port)
+ (print-exp test port)
+ (display ") ? (" port)
+ (print-exp then port)
+ (display ") : (" port)
+ (print-exp else port)
+ (display ")" port))
+
+ (($ prefix op exp)
+ (print-prefix op port)
+ (display "(" port)
+ (print-exp exp port)
+ (display ")" port))
+ ))
+
+(define (print-binop op port)
+ (case op
+ ((or) (display "||" port))
+ ((and) (display "&&" port))
+ ((=) (display "==" port))
+ ((begin) (display "," port))
+ ((+ - < <= > >= === instanceof) (format port "~a" op))
+ (else
+ (throw 'unprintable-binop op))))
+
+(define (print-prefix op port)
+ (case op
+ ((not) (display "!" port))
+ ((typeof + -)
+ (format port "~a" op))
+ (else
+ (throw 'unprintable-prefix op))))
+
+(define (print-statement stmt port)
+ (match stmt
+ (($ var id exp)
+ (format port "var ")
+ (print-id id port)
+ (format port " = ")
+ (print-exp exp port)
+ (format port ";"))
+
+ (($ branch test then else)
+ (format port "if (")
+ (print-exp test port)
+ (format port ") {")
+ (print-block then port)
+ (format port "} else {")
+ (print-block else port)
+ (format port "}"))
+
+ (($ return expr)
+ (format port "return ")
+ (print-exp expr port)
+ (format port ";"))
+
+ (expr
+ (print-exp expr port)
+ (format port ";"))))
+
+(define (print-id id port)
+ (display id port))
+
+(define (print-block stmts port)
+ (format port "{")
+ (print-statements stmts port)
+ (format port "}"))
+
+(define (print-statements stmts port)
+ (for-each (lambda (stmt)
+ (print-statement stmt port))
+ stmts))
+
+(define (print-const c port)
+ (cond ((string? c)
+ ;; FIXME:
+ ;; Scheme strings and JS Strings are different, and not just in
+ ;; terms of mutability
+ (write c port))
+ ((number? c)
+ (write c port))
+ (else
+ (throw 'unprintable-const c))))
+
+(define (print-separated args printer separator port)
+ (unless (null? args)
+ (let ((first (car args))
+ (rest (cdr args)))
+ (printer first port)
+ (for-each (lambda (x)
+ (display separator port)
+ (printer x port))
+ rest))))