Created
February 12, 2020 18:19
Star
You must be signed in to star a gist
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; 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