Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
255 lines (245 sloc) 9.65 KB
(define-module ralph/compiler/javascript
import: (ralph/regexp
ralph/compiler/utilities
(escodegen rename: (generate compile-tree)))
export: (compile-js))
(define *reserved*
["break" "case" "catch" "continue" "default" "delete" "do" "else"
"finally" "for" "function" "if" "in" "instanceof" "new" "return"
"switch" "this" "throw" "try" "typeof" "var" "void" "while"
"with" "abstract" "boolean" "byte" "char" "class" "const"
"debugger" "double" "enum" "export" "extends" "final" "float"
"goto" "implements" "import" "int" "interface" "long" "native"
"package" "private" "protected" "public" "short" "static" "super"
"synchronized" "throws" "transient" "volatile" "null" "true" "false"
"arguments" "object" "number" "string" "array" "let" "yield"])
(define *symbol-escapes*
(make-object
"-" "_"
"_" "__"
"&" "A"
"$" "B"
":" "C"
"." "D"
"=" "E"
"^" "F"
">" "G"
"#" "H"
"@" "I"
"~" "J"
;; K: keyword
"<" "L"
"%" "M"
"!" "N"
;; O
"+" "P"
"?" "Q"
;; R: reserved
"/" "S"
"*" "T"
;; U, V, W, X, Y
;; Z: any other
))
(define-function escape-name (name)
(if (member? name *reserved*)
(concatenate "R" name)
(bind ((chars
(map (method (char)
(cond
((has? *symbol-escapes* char)
(get *symbol-escapes* char))
((match "\\w" char)
char)
(else:
(concatenate
"Z" (as-string (char-code char))))))
(as-array name))))
(join chars ""))))
(define-function compile-js (exp env)
(compile-tree (as-statement
(compile exp env))
(%object "verbatim" "x-verbatim")))
(define-function as-statement (exp)
(if (or (position (get exp "type")
"Statement")
(position (get exp "type")
"Declaration"))
exp
(%object "type" "ExpressionStatement"
"expression" exp)))
(define-function make-block (statements)
(%object "type" "BlockStatement"
"body" statements))
(define-function compile (exp env)
(select exp instance?
((<array>)
(if (empty? exp)
(signal (make <error> message: "empty expression"))
(compile-exp exp env)))
((<hash-symbol>)
(%object "type" "Identifier"
"name" (concatenate
"$" (as-uppercase (symbol-name exp)))))
((<keyword>)
(%object "type" "CallExpression"
"callee" (%object "type" "Identifier"
"name" "$K")
"arguments" [(compile (symbol-name exp) env)]))
((<symbol>)
(select (symbol-name exp) ==
(("%this-method")
(compile (get env "current-method") env))
(("%all-arguments")
(%object "type" "Identifier"
"name" "arguments"))
(else:
(%object "type" "Identifier"
"name" (escape-name
(if (== (get exp "module")
(get env "module" "name"))
(symbol-name exp)
(description exp)))))))
((<number>)
(if (< exp 0)
(%object "type" "UnaryExpression"
"operator" "-"
"prefix" #t
"argument" (%object "type" "Literal"
"value" (abs exp)))
(%object "type" "Literal"
"value" exp)))
(else:
(%object "type" "Literal"
"value" (or exp #f)))))
(define-function compile-exp (exp env)
(bind ((name (symbol-name (first exp))))
(select name ==
(("%quote")
(destructuring-bind (name module-name)
(destructure-symbol (second exp))
(compile
`(%native-call "$S" ,name
,@(if module-name
[module-name]
[]))
env)))
(("%method")
(destructuring-bind (_ name parameters form) exp
(bind ((previous-method (get env "current-method")))
(%object "type" "FunctionExpression"
"id" (compile name env)
"params" (map (rcurry compile env)
parameters)
"body" (begin
(set! (get env "current-method")
name)
(bind ((form* (compile (if (op? "%begin" form)
form
`(%begin ,form))
env)))
(set! (get env "current-method")
previous-method)
form*))))))
(("%set")
(destructuring-bind (_ identifier value) exp
(%object "type" "AssignmentExpression"
"operator" "="
"left" (compile identifier env)
"right" (compile value env))))
(("%if")
(destructuring-bind (_ test consequent alternate) exp
(%object "type" "IfStatement"
"test" (compile test env)
"consequent" (as-statement
(compile consequent env))
"alternate" (when alternate
(as-statement
(compile alternate env))))))
(("%begin")
(make-block (map (method (exp)
(as-statement
(compile exp env)))
(rest exp))))
(("%while")
(destructuring-bind (_ test form) exp
(%object "type" "WhileStatement"
"test" (compile test env)
"body" (as-statement
(compile form env)))))
(("%try")
(destructuring-bind (_ protected-form identifier handling-form) exp
(%object "type" "TryStatement"
"block" (make-block [(as-statement
(compile protected-form env))])
"handler" (%object "type" "CatchClause"
"param" (compile identifier env)
"body" (make-block
[(as-statement
(compile handling-form env))])))))
(("%var")
(destructuring-bind (_ identifier value) exp
;; NOTE: always initialize, might reset state
(%object "type" "VariableDeclaration"
"kind" "var"
"declarations" [(%object "type" "VariableDeclarator"
"id" (compile identifier env)
"init" (compile (or value #f) env))])))
(("%native-call")
(destructuring-bind (_ operator #rest arguments) exp
(%object "type" "CallExpression"
"callee" (%object "type" "Identifier"
"name" operator)
"arguments" (map (rcurry compile env)
arguments))))
(("%infix")
(destructuring-bind (_ operator #rest arguments) exp
(reduce1 (method (result exp)
(%object "type" "BinaryExpression"
"operator" operator
"left" result
"right" exp))
(map (rcurry compile env)
arguments))))
(("%native")
(%object "type" "Expression"
"x-verbatim"
(reduce1 concatenate
(map (method (e)
(select e instance?
((<symbol> <array>)
;; returns statement, strip semicolon
(but-last
(compile-js e env)))
(else:
(as-string e))))
(rest exp)))))
(("%object")
(%object "type" "ObjectExpression"
"properties" (map (method (property/value)
(destructuring-bind (property value)
property/value
(%object "type" "Property"
"key" (compile property env)
"value" (compile value env)
"kind" "init")))
(partition 2 (rest exp)))))
(("%array")
(destructuring-bind (_ #rest elements) exp
(%object "type" "ArrayExpression"
"elements" (map (rcurry compile env)
elements))))
(("%get-property")
(destructuring-bind (_ object #rest properties) exp
(reduce (method (object property)
(%object "type" "MemberExpression"
"object" object
"property" (compile property env)
"computed" #t))
(compile object env)
properties)))
(else:
(destructuring-bind (function #rest arguments) exp
(%object "type" "CallExpression"
"callee" (compile function env)
"arguments" (map (rcurry compile env)
arguments)))))))