;;;; Copyright (c) 2020-2021 Alan Dipert <alan@dipert.org>
;;;; Part of the JACL project: https://tailrecursion.com/JACL/
;;;;
;;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;;; of this software and associated documentation files (the "Software"), to deal
;;;; in the Software without restriction, including without limitation the rights
;;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;;; copies of the Software, and to permit persons to whom the Software is
;;;; furnished to do so, subject to the following conditions:
;;;;
;;;; The above copyright notice and this permission notice shall be included in all
;;;; copies or substantial portions of the Software.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
;; in JACL package; use JACL from COMMON-LISP and switch to COMMON-LISP
(%setq jacl-pkg cl:*package*)
(%let ((cl-pkg (\. (%js "Package") (|get| (\. '#:common-lisp |name|)))))
(\. cl-pkg (|usePackage| jacl-pkg))
(%setq cl:*package* cl-pkg))
(%js "(~{}.fvalue = ~{})"
'%internal-name
(%lambda %internal-name nil (prefix-string name)
(\. (%js "Package")
(|get| (\. "JACL" (|toString|)))
(|intern|
(%js
"('INTERNAL-' + ~{}.toString() + '-' + (~{} === null ? 'NIL' : ~{}.name))"
prefix-string
name
name)))))
(\. *package* (|exportSymbol| (\. 'block |name|)))
(%js "(~{}.setMacro().fvalue = ~{})"
'block
(%lambda nil t
(block-name
&body forms
&aux
(vname# (%internal-name "BLOCK-VALUE" block-name))
(labelname# (%internal-name "BLOCK-LABEL" block-name)))
`(%let ((,vname# nil))
(%tagbody (%setq ,vname# (%progn ,@forms))
,labelname#)
,vname#)))
(%js "(~{}.fvalue = ~{})"
'%has-declare?
(%lambda nil nil
(body)
(%js "(~{} instanceof Cons && ~{}.car instanceof Cons && ~{}.car.car === Package.get('COMMON-LISP').intern('DECLARE')) ? true : null" body body body)))
(\. *package* (|exportSymbol| (\. 'defmacro |name|)))
(%js "(~{}.setMacro().fvalue = ~{})"
'defmacro
(%lambda nil t
(name
params
&body body
&aux
(vname# (%internal-name "BLOCK-VALUE" nil))
(labelname# (%internal-name "BLOCK-LABEL" nil)))
`(%progn
(%js "(~{}.setMacro().fvalue = ~{})"
',name
(%lambda nil t
,params
,@(%if (%has-declare? body) `(,(%js "~{}.car" body)))
(block ,name ,@(%if (%has-declare? body)
(%js "~{}.cdr" body)
body))))
',name)))
(\. *package* (|exportSymbol| (\. 'defun |name|)))
(defmacro defun (name params &rest body)
`(%progn
(%js "(~{}.fvalue = ~{})"
',name
(%lambda ,name nil
,params
,@(%if (%has-declare? body) `(,(%js "~{}.car" body)))
(block ,name ,@(%if (%has-declare? body)
(%js "~{}.cdr" body)
body))))
',name))
(defun %export (symbol &optional (package *package*))
(\. package (|exportSymbol| (\. symbol |name|))))
(defun %log (x)
(\. (%js "console") (|log| (%js "prstr(~{})" x))))
(%export 'return-from)
(defmacro return-from (block-name expr
&aux
(vname# (%internal-name "BLOCK-VALUE" block-name))
(labelname# (%internal-name "BLOCK-LABEL" block-name)))
`(%progn (%setq ,vname# ,expr)
(%go ,labelname#)))
(%export 'return)
(defmacro return (expr)
`(return-from nil ,expr))
(defun %debug (&rest objs)
(declare (rest-array))
(%js "console.debug.apply(null, ~{})" objs))
(%export 'let)
(defmacro let (bindings &rest body)
`(%let ,bindings ,@body))
(%export 'if)
(defmacro if (test true-form &optional else-form)
`(%if ,test ,true-form ,else-form))
(%export 'progn)
(defmacro progn (&rest forms)
`(%progn ,@forms))
(%export 'prog1)
(defmacro prog1 (first-form &rest forms)
(let ((ret (gensym)))
`(let ((,ret ,first-form))
,@forms
,ret)))
(%export 'prog2)
(defmacro prog2 (first-form second-form &rest forms)
(let ((ret (gensym)))
`(progn
,first-form
(let ((,ret ,second-form))
,@forms
,ret))))
(%export 'when)
(defmacro when (test &rest forms)
`(if ,test (progn ,@forms)))
(%export 'defvar)
(defmacro defvar (symbol &optional (value nil value?))
;; Arguably this sohuld work, but we should do it with
;; DECLARE/DECLAIM
;; (%js "~{}.isSpecial = true" symbol)
`(progn
(%js "~{}.isSpecial = true" ',symbol)
(when (%js "(((~{}.value === UNDEFINED) && ~{}) ? true : null)" ',symbol ,value?)
(%js "(~{}.value = ~{})" ',symbol ,value))
',symbol))
(%export 'eq)
(defun eq (x y)
(%js "~{} === ~{} ? true : null" x y))
;; TODO Real EQL
(%export 'eql)
(defun eql (x y)
(eq x y))
(%export 'null)
(defun null (x) (eq x nil))
(%export 'not)
(defun not (x) (eq x nil))
(%export 'cons)
(defun cons (car cdr)
(%new (%js "Cons") car cdr))
(%export 'car)
(defun car (x)
(when (not (null x))
(\. x |car|)))
(%export 'cdr)
(defun cdr (x)
(when (not (null x))
(\. x |cdr|)))
(%export 'rplacd)
(defun rplacd (cons obj)
;; TODO type check
(%js "~{}.cdr=~{}" cons obj)
cons)
(%export 'cadr)
(defun cadr (x)
(car (cdr x)))
(%export 'cddr)
(defun cddr (x)
(cdr (cdr x)))
(%export 'caar)
(defun caar (x)
(car (car x)))
(%export 'cadar)
(defun cadar (x)
(car (cdr (car x))))
(%export 'caddr)
(defun caddr (x)
(car (cdr (cdr x))))
(%export 'cond)
(defmacro cond (&rest clauses)
(when clauses
`(if ,(caar clauses)
,(cadar clauses)
(cond ,@(cdr clauses)))))
(%export 'numberp)
(defun numberp (x)
(%js "typeof ~{} === 'number' ? true : null" x))
(%export 'stringp)
(defun stringp (x)
(%js "~{} instanceof LispString ? true : null" x))
(%export 'symbolp)
(defun symbolp (x)
(%js "(~{} === null || ~{} instanceof LispSymbol) ? true : null" x x))
(%export 'consp)
(defun consp (x)
(%js "~{} instanceof Cons ? true : null" x))
(%export 'tagbody)
(defmacro tagbody (&rest body)
`(%tagbody ,@body))
(%export 'go)
(defmacro go (tag)
`(%go ,tag))
(%export '*gensym-counter*)
(defvar *gensym-counter* 0)
(defmacro %type-error (expected-type)
`(%throw
(%new (%js "TypeError")
(%js "'Not a ' + ~{}.toString()" ,expected-type))))
(%export 'set)
(defun set (symbol value)
(when (not (symbolp symbol))
(%type-error "symbol"))
(%js "(~{}.value = ~{})" symbol value))
(%export '1+)
(defun 1+ (x)
(when (not (numberp x)) (%type-error "number"))
(%js "~{}+1" x))
(%export '1-)
(defun 1- (x)
(when (not (numberp x)) (%type-error "number"))
(%js "~{}-1" x))
(defun %aref (arr i)
(%js "~{}[~{}]" arr i))
(%export '+)
(defun + (&rest nums)
(declare (rest-array))
(%js "
var nums = ~{}, sum = 0;
for(var i = 0; i < nums.length; i++) {
var num = nums[i];
if (typeof num !== 'number') {
throw new TypeError('Not a number: ' + num);
}
sum += num
}
return sum" nums)
;; Never returned. Here to force the preceding expression to be
;; analyzed as "statement" context.
nil)
(%export '-)
(defun - (minuend &rest subtrahends)
(declare (rest-array))
(when (not (numberp minuend)) (%type-error "number"))
(%js "
var minuend = ~{}, subtrahends = ~{};
if (subtrahends.length) {
for (var i = 0; i < subtrahends.length; i++) {
var num = subtrahends[i];
if (typeof num !== 'number') {
throw new TypeError('Not a number: ' + num);
}
minuend -= num;
}
return minuend;
} else {
return -minuend;
}
" minuend subtrahends)
;; Never returned. Here to force the preceding expression to be
;; analyzed as "statement" context.
nil)
(%export 'gensym)
(defun gensym (&optional (x nil x?))
(if x?
(if (stringp x)
(%progn
(%setq *gensym-counter* (1+ *gensym-counter*))
(%js "(new LispSymbol(~{}.toString()+~{}))" x *gensym-counter*))
(if (numberp x)
(%js "(new LispSymbol('G'+~{}))" x)
(%type-error "string or integer")))
(%progn
(%setq *gensym-counter* (1+ *gensym-counter*))
(%js "(new LispSymbol('G'+~{}))" *gensym-counter*))))
(%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 'let*)
(defmacro let* (bindings &rest body)
(if bindings
`(let (,(car bindings))
(let* ,(cdr bindings) ,@body))
`(progn ,@body)))
(%export 'listp)
(defun listp (x)
(or (null x) (consp x)))
(%export 'lambda)
(defmacro lambda (params &rest body)
`(%lambda nil nil ,params ,@body))
(%export 'list)
(defun list (&rest objects)
`(,@objects))
(%export 'functionp)
(defun functionp (x)
(%js "~{} instanceof Function ? true : null" x))
(%export 'symbol-function)
(defun symbol-function (symbol)
(if (not (symbolp symbol))
(%type-error "symbol")
(\. symbol (|func|))))
(%export 'function)
(defmacro function (x)
(cond ((symbolp x) `(symbol-function ',x))
((%js "isLambdaForm(~{})?true:null" x) x)
(t (%type-error "function"))))
(defun %unspread (args)
(when args
(if (and (listp (car args))
(null (cdr args)))
(car args)
(cons (car args) (%unspread (cdr args))))))
(%export 'funcall)
(defun funcall (function &rest args)
(declare (rest-array args))
(\. function (|apply| function args)))
(%export 'apply)
(defun apply (function &rest args)
(declare (rest-array args))
(\. function (|apply| function (%js "unspread(~{})" args))))
(defun %map-pairs (fun pairs)
(let ((head nil)
(tail nil))
(tagbody
start
(when (not pairs) (go end))
(when (not head)
(%setq head (list (funcall fun (car pairs) (cadr pairs))))
(%setq tail head)
(go next))
(let ((new-tail (list (funcall fun (car pairs) (cadr pairs)))))
(rplacd tail new-tail)
(%setq tail new-tail))
next
(%setq pairs (cddr pairs))
(go start)
end)
head))
(%export 'setq)
(defmacro setq (&rest pairs)
`(cl:progn
,@(%map-pairs (lambda (x y) `(%setq ,x ,y)) pairs)))
(%export 'zerop)
(defun zerop (x)
(when (not (numberp x)) (%type-error "number"))
(eql x 0))
(defun %> (x y)
(when (not (numberp x)) (%type-error "number"))
(when (not (numberp y)) (%type-error "number"))
(%js "~{}>~{}?true:null" x y))
(defun %< (x y)
(when (not (numberp x)) (%type-error "number"))
(when (not (numberp y)) (%type-error "number"))
(%js "~{}<~{}?true:null" x y))
(%export '>)
(defun > (number &rest more-numbers)
(when (not (numberp number))
(%type-error "number"))
(let ((ret t))
(tagbody
start
(when (not more-numbers) (go end))
(when (not (%> number (car more-numbers)))
(setq ret nil)
(go end))
(setq number (car more-numbers)
more-numbers (cdr more-numbers))
(when (not (numberp number))
(%type-error "number"))
(go start)
end)
ret))
(%export '<)
(defun < (num &rest nums)
(declare (rest-array))
(let ((len (%dot nums |length|))
(ret t)
(i 0))
(tagbody
start
(when (not (numberp num))
(%type-error "number"))
(when (eql i len)
(go end))
(let ((x (%aref nums i)))
(when (not (%< num x))
(setq ret nil)
(go end))
(setq num x
i (1+ i)))
(go start)
end)
ret))
(%export 'symbol-name)
(defun symbol-name (symbol)
(when (not (symbolp symbol))
(%type-error "symbol"))
(if (null symbol)
"NIL"
(\. symbol |name|)))
(defun %mapcar (function list)
(when list
(cons (funcall function (car list))
(%mapcar function (cdr list)))))
(defun %mapcan (function list)
(when list
(append (funcall function (car list))
(%mapcan function (cdr list)))))
(defun %do (op-bind op-set step-forms more)
(let* ((end-test-and-result-forms (car more))
(end-test-form (car end-test-and-result-forms))
(result-forms (cdr end-test-and-result-forms))
(body (cdr more))
(begin# (gensym "begin"))
(bindings (%mapcar (lambda (step-form)
(list (car step-form) (cadr step-form)))
step-forms))
(assignments `(,op-set ,@(%mapcan (lambda (step-form)
(when (caddr step-form)
(list (car step-form) (caddr step-form))))
step-forms))))
`(block nil
(,op-bind ,bindings
(tagbody
,begin#
(if ,end-test-form
(return (progn ,@result-forms)))
,@body
,assignments
(go ,begin#))))))
(%export 'do*)
(defmacro do* (step-forms &rest more)
(%do 'let* 'setq step-forms more))
(defun %collector ()
(let ((tail nil)
(head nil))
(lambda (&optional (item nil argument?))
(cond
((not argument?) head)
((null tail) (setq tail (cons item nil)
head tail))
(t (let ((new-tail (cons item nil)))
(rplacd tail new-tail)
(setq tail new-tail)))))))
(%export 'psetq)
(defmacro psetq (&rest pairs)
(let ((triples (do* ((collect (%collector))
(head pairs (cddr head)))
((not head) (funcall collect))
(funcall collect (list
(gensym "psetq-var")
(car head)
(cadr head))))))
`(let ,(%mapcar (lambda (triple)
(list (car triple)))
triples)
(setq ,@(%mapcan (lambda (triple)
(list (car triple) (caddr triple)))
triples)
,@(%mapcan (lambda (triple)
(list (cadr triple) (car triple)))
triples)))))
(%export 'do)
(defmacro do (step-forms &rest more)
(%do 'let 'psetq step-forms more))
(%export 'dolist)
(defmacro dolist (binding &rest body)
(let ((list# (gensym "list")))
`(do* ((,list# ,(cadr binding) (cdr ,list#))
(,(car binding) (car ,list#) (car ,list#)))
((not ,list#) ,(caddr binding))
,@body)))
(%export 'dotimes)
(defmacro dotimes (binding &rest body)
`(do ((,(car binding) 0 (1+ ,(car binding))))
((eql ,(car binding) ,(cadr binding))
,(caddr binding))
,@body))
(%export 'some)
(defun some (predicate &rest sequences)
(let* ((sequences (%js "[...~{}]"
(%mapcar (lambda (sequence)
(%js "[...~{}]" sequence))
sequences)))
(shortest (%js "Math.min(...~{}.map(x => x.length))" sequences)))
(do* ((i 0 (1+ i)))
((eql i (1+ shortest)))
(let ((args (%js "~{}.map(x => x[~{}])" sequences i)))
(when (%js "~{}(...~{}) === null ? null : true" predicate args)
(return-from some t))))))
(%export 'mapcar)
(defun mapcar (function &rest lists)
(do* ((collect (%collector)))
((%js "[...~{}].some(x => x === null) ? true : null" lists)
(funcall collect))
(funcall collect (apply function (%mapcar #'car lists)))
(setq lists (%mapcar #'cdr lists))))
;; designators
(defun %designated-string (x)
(cond ((stringp x) x)
((symbolp x)
(\. (%js "LispString") (|fromString| (\. x |name|))))
(t (%type-error "string or symbol"))))
(defun %designated-symbols (x &aux (err "symbol or list of symbols"))
(cond ((symbolp x) (list x))
((listp x) (dolist (obj x x)
(when (not (symbolp obj))
(%type-error err))))
(t (%type-error err))))
(%export 'use-package)
(defun use-package (packages-to-use &optional (package *package*))
;; TODO %designated-packages and accept list of package designators
(let* ((pkg (\. (%js "Package")
(|get| (\. (%designated-string packages-to-use)
(|toString|))))))
(\. package (|usePackage| pkg))))
(%export 'in-package)
(defmacro in-package (name)
(let ((name-string (%designated-string name)))
`(setq *package* (\. (%js "Package") (|get| (\. ,name-string (|toString|)))))))
(%export 'make-package)
(defun make-package (package-name &key nicknames use)
;; TODO error if package exists
(let* ((package-name-js (\. (%designated-string package-name) (|toString|)))
(new-package (%js "Package.makePackage(~{}, ...Cons.toArray(~{}))"
package-name-js
(mapcar (lambda (x)
(\. (%designated-string x) (|toString|)))
nicknames))))
(dolist (u use new-package)
(use-package u new-package))))
(%export 'export)
(defun export (symbols &optional (package *package*))
;; TODO error when symbols not accessible
(dolist (sym (%designated-symbols symbols) t)
(%export sym package)))
(in-package #:jacl)
(use-package '#:common-lisp)
(cl::%export 'fetch-load)
(defun fetch-load (src &aux (src (\. src (|toString|))))
(%js "fetchLoad(~{})" src))
(in-package #:common-lisp)
(%export 'macroexpand-1)
(defun macroexpand-1 (form &optional env)
(if (%js "isMacroForm(~{})?true:null" form)
(apply (symbol-function (car form)) env form (cdr form))
form))
;;(%export 'export)
;;(defun export (symbols &optional (package *package*))
;; (let ((syms (designated-symbols symbols)))
;; (tagbody
;; start
;; (when syms
;; (%export (car syms) package)
;; (%setq syms (cdr syms))
;; (go start)))))
;; Use COMMON-LISP from COMMON-LISP-USER and switch to
;; COMMON-LISP-USER
(in-package #:common-lisp-user)
(cl:use-package '#:common-lisp)
;; Local Variables:
;; eval: (put '%let 'lisp-indent-function 1)
;; End: