346 lines
12 KiB
Racket
346 lines
12 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/string
|
|
(for-syntax racket/base))
|
|
|
|
(provide js)
|
|
|
|
;; A deliberately small Racket/Scheme-to-JavaScript string maker.
|
|
;;
|
|
;; Design notes:
|
|
;; - This is still a macro based string generator, not a full compiler.
|
|
;; - `let` and `let*` are kept distinct: ordinary `let` evaluates all RHS
|
|
;; expressions before introducing the bound names; `let*` binds sequentially.
|
|
;; - named `let` is compiled as a JavaScript `while (true)` loop. A tail call
|
|
;; to the named-let identifier is rewritten to parallel assignments plus
|
|
;; `continue`. Other tail statements fall through with `break` so the loop
|
|
;; cannot accidentally become infinite.
|
|
|
|
;; -------------------------------------------------------------------------
|
|
;; Runtime helpers used by the generated macro expansion.
|
|
;; -------------------------------------------------------------------------
|
|
|
|
(define (symbol->js-name s)
|
|
(define str (symbol->string s))
|
|
(define cleaned (regexp-replace* #px"[^A-Za-z0-9_.$]" str "_"))
|
|
(cond [(regexp-match? #px"^[A-Za-z_$]" cleaned) cleaned]
|
|
[else (string-append "_" cleaned)]))
|
|
|
|
(define (js-escape-string s)
|
|
(apply string-append
|
|
(for/list ([ch (in-string s)])
|
|
(case ch
|
|
[(#\\) "\\\\"]
|
|
[(#\") "\\\""]
|
|
[(#\newline) "\\n"]
|
|
[(#\return) "\\r"]
|
|
[(#\tab) "\\t"]
|
|
[else (string ch)]))))
|
|
|
|
(define (js-string s)
|
|
(string-append "\"" (js-escape-string (format "~a" s)) "\""))
|
|
|
|
(define (js-number n)
|
|
(cond [(and (real? n) (not (integer? n))) (number->string (exact->inexact n))]
|
|
[else (format "~a" n)]))
|
|
|
|
(define (js-datum v)
|
|
(cond [(string? v) (js-string v)]
|
|
[(symbol? v) (js-string (symbol->string v))]
|
|
[(number? v) (js-number v)]
|
|
[(boolean? v) (if v "true" "false")]
|
|
[(null? v) "[]"]
|
|
[(list? v) (string-append "[" (string-join (map js-datum v) ", ") "]")]
|
|
[else (error 'js-datum "unsupported datum: ~e" v)]))
|
|
|
|
(define (js-stmt s)
|
|
(define t (string-trim s))
|
|
(cond [(equal? t "") ""]
|
|
[(or (string-suffix? t ";")
|
|
(string-suffix? t "}")
|
|
(string-suffix? t ")")) ; IIFE or function call expression may still need ;
|
|
(if (string-suffix? t ")") (string-append s ";\n") (string-append s "\n"))]
|
|
[else (string-append s ";\n")]))
|
|
|
|
(define (js-block body)
|
|
(string-append "{\n" body "}\n"))
|
|
|
|
;; -------------------------------------------------------------------------
|
|
;; Small string-making macros.
|
|
;; -------------------------------------------------------------------------
|
|
|
|
(define-syntax js-primitive
|
|
(syntax-rules ()
|
|
[(_ a) (js-datum 'a)]))
|
|
|
|
(define-syntax js-id
|
|
(syntax-rules ()
|
|
[(_ a) (symbol->js-name 'a)]))
|
|
|
|
(define-syntax js-ids
|
|
(syntax-rules ()
|
|
[(_ a ...) (string-join (list (js-id a) ...) ", ")]))
|
|
|
|
(define-syntax js-join
|
|
(syntax-rules ()
|
|
[(_ sep (a ...)) (string-join (list (js1 a) ...) sep)]))
|
|
|
|
(define-syntax js-infix
|
|
(syntax-rules ()
|
|
[(_ sep (a ...)) (string-join (list (js1 a) ...) sep)]))
|
|
|
|
(define-syntax js-call
|
|
(syntax-rules ()
|
|
[(_ f) (string-append (js-id f) "()")]
|
|
[(_ f a ...) (string-append (js-id f) "(" (js-join ", " (a ...)) ")")]))
|
|
|
|
(define-syntax js-array
|
|
(syntax-rules ()
|
|
[(_) "[]"]
|
|
[(_ a ...) (string-append "[" (js-join ", " (a ...)) "]")]))
|
|
|
|
(define-syntax js-cons
|
|
(syntax-rules ()
|
|
[(_ a b) (string-append "[" (js1 a) "].concat(" (js1 b) ")")]))
|
|
|
|
(define-syntax js-dot*
|
|
(syntax-rules ()
|
|
[(_ obj field) (string-append (js1 obj) "." (js-id field))]
|
|
[(_ obj field rest ...) (js-dot* (js-dot* obj field) rest ...)]))
|
|
|
|
(define-syntax js-send
|
|
(syntax-rules ()
|
|
[(_ obj method) (string-append (js1 obj) "." (js-id method) "()")]
|
|
[(_ obj method arg ...) (string-append (js1 obj) "." (js-id method) "(" (js-join ", " (arg ...)) ")")]))
|
|
|
|
(define-syntax js-new
|
|
(syntax-rules ()
|
|
[(_ class) (string-append "new " (js-id class) "()")]
|
|
[(_ class arg ...) (string-append "new " (js-id class) "(" (js-join ", " (arg ...)) ")")]))
|
|
|
|
(define-syntax js-set!
|
|
(syntax-rules ()
|
|
[(_ target expr) (string-append (js1 target) " = " (js1 expr) ";")]))
|
|
|
|
(define-syntax js-return
|
|
(syntax-rules ()
|
|
[(_ expr) (string-append "return " (js1 expr) ";")]))
|
|
|
|
(define-syntax js-begin
|
|
(syntax-rules ()
|
|
[(_ body ...) (js-block (js body ...))]))
|
|
|
|
(define-syntax js-if
|
|
(syntax-rules ()
|
|
[(_ c then else)
|
|
(string-append "if (" (js1 c) ") {\n"
|
|
(js-stmt (js1 then))
|
|
"} else {\n"
|
|
(js-stmt (js1 else))
|
|
"}")]))
|
|
|
|
(define-syntax js-define-function
|
|
(syntax-rules ()
|
|
[(_ f (arg ...) body ...)
|
|
(string-append "function " (js-id f) "(" (js-ids arg ...) ") {\n"
|
|
(js body ...)
|
|
"}")]))
|
|
|
|
(define-syntax js-define-value
|
|
(syntax-rules ()
|
|
[(_ name expr) (string-append "let " (js-id name) " = " (js1 expr) ";")]))
|
|
|
|
(define-syntax js-lambda
|
|
(syntax-rules ()
|
|
[(_ (arg ...) body ...)
|
|
(string-append "function (" (js-ids arg ...) ") {\n"
|
|
(js body ...)
|
|
"}")]))
|
|
|
|
(define-syntax js-let*
|
|
(syntax-rules ()
|
|
[(_ ([id init] ...) body ...)
|
|
(string-append "{\n"
|
|
(string-append "let " (js-id id) " = " (js1 init) ";\n") ...
|
|
(js body ...)
|
|
"}")]))
|
|
|
|
(define-syntax (js-let stx)
|
|
(syntax-case stx ()
|
|
[(_ ([id init] ...) body ...)
|
|
(with-syntax ([(tmp ...) (generate-temporaries #'(id ...))])
|
|
#'(string-append "{\n"
|
|
;; First evaluate all RHS expressions into temporary names.
|
|
;; This preserves ordinary Racket/Scheme `let` scoping:
|
|
;; newly bound names are not visible to other RHS expressions.
|
|
;; The real bindings are introduced in an inner block so
|
|
;; JavaScript `let` TDZ rules do not shadow RHS references.
|
|
(string-append "const " (js-id tmp) " = " (js1 init) ";\n") ...
|
|
"{\n"
|
|
(string-append "let " (js-id id) " = " (js-id tmp) ";\n") ...
|
|
(js body ...)
|
|
"}\n"
|
|
"}"))]))
|
|
|
|
;; -------------------------------------------------------------------------
|
|
;; named-let loop support.
|
|
;; -------------------------------------------------------------------------
|
|
|
|
(define-for-syntax (same-length? a b)
|
|
(= (length (syntax->list a)) (length (syntax->list b))))
|
|
|
|
(define-syntax (js-loop-continue stx)
|
|
(syntax-case stx ()
|
|
[(_ (var ...) (arg ...))
|
|
(unless (same-length? #'(var ...) #'(arg ...))
|
|
(raise-syntax-error 'js-loop-continue "named let tail call has the wrong arity" stx))
|
|
(with-syntax ([(tmp ...) (generate-temporaries #'(var ...))])
|
|
#'(string-append
|
|
;; Evaluate new values before assigning loop variables, so the update
|
|
;; is parallel, not sequential.
|
|
(string-append "const " (js-id tmp) " = " (js1 arg) ";\n") ...
|
|
(string-append (js-id var) " = " (js-id tmp) ";\n") ...
|
|
"continue;\n"))]))
|
|
|
|
(define-syntax (js-loop-tail stx)
|
|
(syntax-case stx ()
|
|
;; More than one expression in tail position: emit the leading statement,
|
|
;; then continue tail conversion on the rest.
|
|
[(_ loop-name (var ...) first second rest ...)
|
|
#'(string-append (js-stmt (js1 first))
|
|
(js-loop-tail loop-name (var ...) second rest ...))]
|
|
|
|
;; One expression in tail position.
|
|
[(_ loop-name (var ...) expr)
|
|
(syntax-case #'expr (if begin return)
|
|
[(if c then else)
|
|
#'(string-append "if (" (js1 c) ") {\n"
|
|
(js-loop-tail loop-name (var ...) then)
|
|
"} else {\n"
|
|
(js-loop-tail loop-name (var ...) else)
|
|
"}\n")]
|
|
[(begin body ...)
|
|
#'(js-loop-tail loop-name (var ...) body ...)]
|
|
[(return value)
|
|
#'(string-append "return " (js1 value) ";\n")]
|
|
[(call arg ...)
|
|
(and (identifier? #'call) (free-identifier=? #'call #'loop-name))
|
|
#'(js-loop-continue (var ...) (arg ...))]
|
|
[_
|
|
;; Statement-oriented fallback: execute the tail expression once and
|
|
;; leave the loop. In normal use, a named-let body ends in either a
|
|
;; loop tail call or an explicit return/breaking condition.
|
|
#'(string-append (js-stmt (js1 expr)) "break;\n")])]))
|
|
|
|
(define-syntax (js-named-let stx)
|
|
(syntax-case stx ()
|
|
[(_ loop-name ([id init] ...) body ...)
|
|
(with-syntax ([(tmp ...) (generate-temporaries #'(id ...))])
|
|
#'(string-append "{\n"
|
|
;; Initial expressions are evaluated before the loop
|
|
;; variables are introduced, like named `let` in Racket.
|
|
;; The loop variables live in an inner block for the same
|
|
;; reason as ordinary `let`: avoid JavaScript TDZ shadowing.
|
|
(string-append "const " (js-id tmp) " = " (js1 init) ";\n") ...
|
|
"{\n"
|
|
(string-append "let " (js-id id) " = " (js-id tmp) ";\n") ...
|
|
"while (true) {\n"
|
|
(js-loop-tail loop-name (id ...) body ...)
|
|
"}\n"
|
|
"}\n"
|
|
"}"))]))
|
|
|
|
;; -------------------------------------------------------------------------
|
|
;; Main dispatcher. This is intentionally normalized by syntactic form first,
|
|
;; instead of by arity first.
|
|
;; -------------------------------------------------------------------------
|
|
|
|
(define-syntax (js1 stx)
|
|
(syntax-case stx (define lambda λ if set! let let* begin return quote eval)
|
|
[(_ (define (f arg ...) body ...)) #'(js-define-function f (arg ...) body ...)]
|
|
[(_ (define name expr)) #'(js-define-value name expr)]
|
|
[(_ (lambda (arg ...) body ...)) #'(js-lambda (arg ...) body ...)]
|
|
[(_ (λ (arg ...) body ...)) #'(js-lambda (arg ...) body ...)]
|
|
[(_ (if c then else)) #'(js-if c then else)]
|
|
[(_ (set! target expr)) #'(js-set! target expr)]
|
|
[(_ (let loop-name ([id init] ...) body ...))
|
|
(identifier? #'loop-name)
|
|
#'(js-named-let loop-name ([id init] ...) body ...)]
|
|
[(_ (let ([id init] ...) body ...)) #'(js-let ([id init] ...) body ...)]
|
|
[(_ (let* ([id init] ...) body ...)) #'(js-let* ([id init] ...) body ...)]
|
|
[(_ (begin body ...)) #'(js-begin body ...)]
|
|
[(_ (return expr)) #'(js-return expr)]
|
|
[(_ (quote datum)) #'(js-datum 'datum)]
|
|
[(_ (eval expr)) #'(js-datum expr)]
|
|
|
|
;; Generic operator/function-call dispatch.
|
|
[(_ (op arg ...))
|
|
(let ([d (syntax-e #'op)])
|
|
(cond [(eq? d '+) #'(js-infix " + " (arg ...))]
|
|
[(eq? d '-) #'(js-infix " - " (arg ...))]
|
|
[(eq? d '*) #'(js-infix " * " (arg ...))]
|
|
[(eq? d '/) #'(js-infix " / " (arg ...))]
|
|
[(eq? d 'and) #'(js-infix " && " (arg ...))]
|
|
[(eq? d 'or) #'(js-infix " || " (arg ...))]
|
|
[(eq? d '>) #'(js-infix " > " (arg ...))]
|
|
[(eq? d '<) #'(js-infix " < " (arg ...))]
|
|
[(eq? d '>=) #'(js-infix " >= " (arg ...))]
|
|
[(eq? d '<=) #'(js-infix " <= " (arg ...))]
|
|
[(eq? d '==) #'(js-infix " == " (arg ...))]
|
|
[(eq? d '===) #'(js-infix " === " (arg ...))]
|
|
[(eq? d '!=) #'(js-infix " != " (arg ...))]
|
|
[(eq? d '!==) #'(js-infix " !== " (arg ...))]
|
|
[(eq? d 'not) #'(string-append "!(" (js1 arg ...) ")")]
|
|
[(eq? d 'send) #'(js-send arg ...)]
|
|
[(eq? d 'list) #'(js-array arg ...)]
|
|
[(eq? d 'cons) #'(js-cons arg ...)]
|
|
[(or (eq? d 'js-dot) (eq? d 'dot)) #'(js-dot* arg ...)]
|
|
[(eq? d 'new) #'(js-new arg ...)]
|
|
[(identifier? #'op) #'(js-call op arg ...)]
|
|
[else (raise-syntax-error 'js1 "unsupported compound expression" stx #'op)]))]
|
|
|
|
[(_ a)
|
|
(cond [(identifier? #'a) #'(symbol->js-name 'a)]
|
|
[else #'(js-datum 'a)])]))
|
|
|
|
(define-syntax js
|
|
(syntax-rules ()
|
|
[(_ statement ...)
|
|
(string-append (js-stmt (js1 statement)) ...)]))
|
|
|
|
|
|
|
|
;; -------------------------------------------------------------------------
|
|
;; Examples
|
|
;; -------------------------------------------------------------------------
|
|
|
|
#|
|
|
(js
|
|
(define (sum-to n)
|
|
(let loop ([i 0] [acc 0])
|
|
(if (> i n)
|
|
(return acc)
|
|
(loop (+ i 1) (+ acc i))))))
|
|
|
|
=>
|
|
function sum_to(n) {
|
|
{
|
|
const temp... = 0;
|
|
const temp... = 0;
|
|
let i = temp...;
|
|
let acc = temp...;
|
|
while (true) {
|
|
if (i > n) {
|
|
return acc;
|
|
} else {
|
|
const temp... = i + 1;
|
|
const temp... = acc + i;
|
|
i = temp...;
|
|
acc = temp...;
|
|
continue;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|#
|