Skip to content

Instantly share code, notes, and snippets.

@alandipert
Created February 12, 2020 18:19
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save alandipert/bf7167580f385d7eb8f6dd0fb38698cf to your computer and use it in GitHub Desktop.
;; in JACL package; use JACL from COMMON-LISP and switch to COMMON-LISP
(%let ((cl-pkg (\. (%js "Package") (|get| (\. '#:common-lisp |name|)))))
(\. cl-pkg (|usePackage| cl:*package*))
(%setq cl:*package* cl-pkg))
(\. *package* (|exportSymbol| (\. 'defmacro |name|)))
(%js "(~{}.setMacro().fvalue = ~{})"
'defmacro
(%lambda (env form name params &rest body)
;; TODO Use %PROGN instead of %LET
`(jacl:%progn
(jacl:%js "(~{}.setMacro().fvalue = ~{})"
',name
;; TODO Macro lambda list parsing. Also, consider
;; incorportating a symbol's package into the name of its
;; generated local.
(jacl:%lambda (jacl::&environment jacl::&whole ,@params)
,@body))
',name)))
(\. *package* (|exportSymbol| (\. 'defun |name|)))
(defmacro defun (name params &rest body)
`(jacl:%progn
(jacl:%js "(~{}.fvalue = ~{})"
',name
(jacl:%lambda ,params ,@body))
',name))
(defun %export (symbol &optional (package *package*))
(\. package (|exportSymbol| (\. symbol |name|))))
(%export 'let)
(defmacro let (bindings &rest body)
`(jacl:%let ,bindings ,@body))
(%export 'if)
(defmacro if (test true-form &optional else-form)
`(jacl:%if ,test ,true-form ,else-form))
(%export 'progn)
(defmacro progn (&rest forms)
`(jacl:%progn ,@forms))
(%export 'when)
(defmacro when (test &rest forms)
`(if ,test (progn ,@forms)))
(%export 'defvar)
(defmacro defvar (symbol &optional (value nil value?))
`(progn
(jacl:%js "~{}.isSpecial = true" ',symbol)
(when (jacl:%js "(((~{}.value === UNDEFINED) && ~{}) ? true : null)" ',symbol ,value?)
(jacl:%js "(~{}.value = ~{})" ',symbol ',value))
',symbol))
(%export 'eq)
(defun eq (x y)
(jacl:%js "~{} === ~{} ? true : null" x y))
(%export 'null)
(defun null (x) (eq x nil))
(%export 'not)
(defun not (x) (eq x nil))
(%export 'cons)
(defun cons (car cdr)
(jacl:%new (jacl:%js "Cons") car cdr))
(%export 'car)
(defun car (x)
(when (not (null x))
(jacl:\. x |car|)))
(%export 'cdr)
(defun cdr (x)
(when (not (null x))
(jacl:\. x |cdr|)))
(%export 'caar)
(defun caar (x)
(car (car x)))
(%export 'cadar)
(defun cadar (x)
(car (cdr (car x))))
(%export 'cond)
(defmacro cond (&rest clauses)
(when clauses
`(if ,(caar clauses)
,(cadar clauses)
(cond ,@(cdr clauses)))))
(%export 'numberp)
(defun numberp (x)
(jacl:%js "typeof ~{} === 'number' ? true : null" x))
(%export 'integerp)
(defun integerp (x)
(jacl:%js "(typeof ~{} === 'number') && (Math.floor(~{}) === ~{}) ? true : null" x x x))
(%export 'stringp)
(defun stringp (x)
(jacl:%js "~{} instanceof LispString ? true : null" x))
(%export 'symbolp)
(defun symbolp (x)
(jacl:%js "~{} instanceof LispSymbol ? true : null" x))
(%export 'consp)
(defun consp (x)
(jacl:%js "~{} instanceof Cons ? true : null" x))
(%export 'tagbody)
(defmacro tagbody (&rest body)
`(jacl:%tagbody ,@body))
(%export 'go)
(defmacro go (tag)
`(jacl:%go ,tag))
(%export '*gensym-counter*)
(defvar *gensym-counter* 0)
(defmacro %type-error (expected-type)
`(jacl:%throw
(jacl:%new (jacl:%js "TypeError")
(jacl:%js "'Not a ' + ~{}.toString()" ,expected-type))))
(%export 'set)
(defun set (symbol value)
(when (not (symbolp symbol))
(%type-error "symbol"))
(jacl:%js "(~{}.value = ~{})" symbol value))
(%export '1+)
(defun 1+ (x)
(when (not (numberp x))
(%type-error "number"))
(jacl:%js "~{}+1" x))
(%export 'gensym)
(defun gensym (&optional (x nil x?))
(cond ((stringp x)
(jacl:%new (jacl:%js "LispSymbol")
(jacl:%js "~{}+~{}.toString()" x *gensym-counter*)))
((numberp x)
(jacl:%new (jacl:%js "LispSymbol")
(jacl:%js "'G'+~{}.toString()" x)))
((not x?)
(let ((sym (jacl:%new (jacl:%js "LispSymbol")
(jacl:%js "'G'+~{}.toString()" *gensym-counter*))))
(set '*gensym-counter* (1+ *gensym-counter*))
sym))
(t (%type-error "string or integer"))))
(%export 'or)
(defmacro or (&rest forms)
(when forms
(let ((x (gensym)))
`(let ((,x ,(car forms)))
(if ,x ,x (or ,@(cdr forms)))))))
(%export 'and)
(defmacro and (&rest forms)
(if forms
(let ((x (gensym)))
`(let ((,x ,(car forms)))
(when ,x (and ,@(cdr forms)))))
t))
(%export 'listp)
(defun listp (x)
(or (null x) (consp x)))
(%export 'lambda)
(defmacro lambda (params &rest body)
`(jacl:%lambda ,params ,@body))
(defun %designated-string (x)
(cond ((stringp x) x)
((symbolp x)
(jacl:\. (jacl:%js "LispString") (|fromString| (jacl:\. x |name|))))
(t (%type-error "string or symbol"))))
(defun %designated-symbols (x)
(cond ((symbolp x) (list x))
((listp x) x)
(t (%type-error "symbol or list of symbols"))))
(%export 'let*)
(defmacro let* (bindings &rest body)
(if bindings
`(let (,(car bindings))
(let* ,(cdr bindings)
,@body))
`(progn ,@body)))
(%export 'function)
(defmacro function (x)
`(jacl:%js "~{}.func()" x))
(%export 'functionp)
(defun functionp (x)
(jacl:%js "~{} instanceof Function ? true : null" x))
(%export 'funcall)
(defun funcall (f &rest args)
(when (not (functionp f))
(%type-error "function"))
(jacl:%js "~{}.call(null, List.toArray(~{}))" f args))
;; TODO
(%export 'export)
(defun export (symbols &optional (package *package*))
(let ((syms (designated-symbols symbols)))
(tagbody
start
(when syms
(%export (car syms) package)
(jacl:%setq syms (cdr syms))
(go start)))))
;; Use COMMON-LISP from COMMON-LISP-USER and switch to
;; COMMON-LISP-USER
(%let ((cl-user-pkg (\. (%js "Package") (|get| (\. '#:common-lisp-user |name|)))))
(\. cl-user-pkg (|usePackage| cl:*package*))
(%setq cl:*package* cl-user-pkg))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment