(defun second (x) (cadr x))
(defun third (x) (caddr x))
(defun fourth (x) (cadddr x))
+ (defun rest (x) (cdr x))
(defun list (&rest args) args)
(defun atom (x)
(concat-two s1 s2))
(defun mapcar (func list)
- (if (null list)
- '()
- (cons (funcall func (car list))
- (mapcar func (cdr list)))))
+ (let* ((head (cons 'sentinel nil))
+ (tail head))
+ (while (not (null list))
+ (let ((new (cons (funcall func (car list)) nil)))
+ (rplacd tail new)
+ (setq tail new
+ list (cdr list))))
+ (cdr head)))
(defun identity (x) x)
+ (defun constantly (x)
+ (lambda (&rest args)
+ x))
+
(defun copy-list (x)
(mapcar #'identity x))
(- x #\0)
nil))
+ (defun digit-char (weight)
+ (and (<= 0 weight 9)
+ (char "0123456789" weight)))
+
(defun subseq (seq a &optional b)
(cond
((stringp seq)
do (write-string " ")
do (write-line line)))))
-
(defun integer-to-string (x)
(cond
((zerop x)
(while (not (zerop x))
(push (mod x 10) digits)
(setq x (truncate x 10)))
- (join (mapcar (lambda (d) (string (char "0123456789" d)))
- digits))))))
+ (mapconcat (lambda (x) (string (digit-char x)))
+ digits)))))
;;; Wrap X with a Javascript code to convert the result from
((and (listp x) (eq (car x) 'lambda))
(compile-lambda (cadr x) (cddr x)))
((symbolp x)
- (ls-compile `(symbol-function ',x)))))
+ (let ((b (lookup-in-lexenv x *environment* 'function)))
+ (if b
+ (binding-value b)
+ (ls-compile `(symbol-function ',x)))))))
+
+
+(defun make-function-binding (fname)
+ (make-binding fname 'function (gvarname fname)))
+
+(defun compile-function-definition (list)
+ (compile-lambda (car list) (cdr list)))
+
+(defun translate-function (name)
+ (let ((b (lookup-in-lexenv name *environment* 'function)))
+ (binding-value b)))
+
+(define-compilation flet (definitions &rest body)
+ (let* ((fnames (mapcar #'car definitions))
+ (fbody (mapcar #'cdr definitions))
+ (cfuncs (mapcar #'compile-function-definition fbody))
+ (*environment*
+ (extend-lexenv (mapcar #'make-function-binding fnames)
+ *environment*
+ 'function)))
+ (concat "(function("
+ (join (mapcar #'translate-function fnames) ",")
+ "){" *newline*
+ (let ((body (ls-compile-block body t)))
+ (indent body))
+ "})(" (join cfuncs ",") ")")))
+
+(define-compilation labels (definitions &rest body)
+ (let* ((fnames (mapcar #'car definitions))
+ (*environment*
+ (extend-lexenv (mapcar #'make-function-binding fnames)
+ *environment*
+ 'function)))
+ (js!selfcall
+ (mapconcat (lambda (func)
+ (concat "var " (translate-function (car func))
+ " = " (compile-lambda (cadr func) (cddr func))
+ ";" *newline*))
+ definitions)
+ (ls-compile-block body t))))
+
+
(defvar *compiling-file* nil)
(define-compilation eval-when-compile (&rest body)
form)))
(defun compile-funcall (function args)
- (let ((values-funcs (if *multiple-value-p* "values" "pv")))
- (if (and (symbolp function)
- #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
- #+common-lisp t)
- (concat (ls-compile `',function) ".fvalue("
- (join (cons values-funcs (mapcar #'ls-compile args))
- ", ")
- ")")
- (concat (ls-compile `#',function) "("
- (join (cons values-funcs (mapcar #'ls-compile args))
- ", ")
- ")"))))
+ (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
+ (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
+ (cond
+ ((translate-function function)
+ (concat (translate-function function) arglist))
+ ((and (symbolp function)
+ #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
+ #+common-lisp t)
+ (concat (ls-compile `',function) ".fvalue" arglist))
+ (t
+ (concat (ls-compile `#',function) arglist)))))
(defun ls-compile-block (sexps &optional return-last-p)
(if return-last-p
(defun eval (x)
(js-eval (ls-compile-toplevel x t)))
- (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= =
- = > >= and append apply aref arrayp aset assoc atom block boundp
- boundp butlast caar cadddr caddr cadr car car case catch cdar cdddr
- cddr cdr cdr char char-code char= code-char cond cons consp copy-list
- decf declaim defparameter defun defmacro defvar digit-char-p
- disassemble do do* documentation dolist dotimes ecase eq eql equal
- error eval every export fdefinition find-package find-symbol first
- fourth fset funcall function functionp gensym get-universal-time go
- identity if in-package incf integerp integerp intern keywordp lambda
- last length let let* list-all-packages list listp make-array
- make-package make-symbol mapcar member minusp mod multiple-value-bind
- multiple-value-call multiple-value-list multiple-value-prog1 nil not
- nth nthcdr null numberp or package-name package-use-list packagep
- parse-integer plusp prin1-to-string print proclaim prog1 prog2 progn
- psetq push quote remove remove-if remove-if-not return return-from
- revappend reverse rplaca rplacd second set setq some string-upcase
- string string= stringp subseq symbol-function symbol-name symbol-package
- symbol-plist symbol-value symbolp t tagbody third throw truncate
- unless unwind-protect values values-list variable warn when write-line
- write-string zerop))
+ (export '(&rest &optional &body * *gensym-counter* *package* + - /
+ 1+ 1- < <= = = > >= and append apply aref arrayp aset
+ assoc atom block boundp boundp butlast caar cadddr caddr
+ cadr car car case catch cdar cdddr cddr cdr cdr char
+ char-code char= code-char cond cons consp constantly
+ copy-list decf declaim defparameter defun defmacro defvar
+ digit-char digit-char-p disassemble do do* documentation
+ dolist dotimes ecase eq eql equal error eval every export
+ fdefinition find-package find-symbol first flet fourth
+ fset funcall function functionp gensym get-universal-time
+ go identity if in-package incf integerp integerp intern
+ keywordp labels lambda last length let let*
+ list-all-packages list listp make-array make-package
+ make-symbol mapcar member minusp mod multiple-value-bind
+ multiple-value-call multiple-value-list
+ multiple-value-prog1 nil not nth nthcdr null numberp or
+ package-name package-use-list packagep parse-integer plusp
+ prin1-to-string print proclaim prog1 prog2 progn psetq
+ push quote remove remove-if remove-if-not return
+ return-from revappend reverse rplaca rplacd second set
+ setq some string-upcase string string= stringp subseq
+ symbol-function symbol-name symbol-package symbol-plist
+ symbol-value symbolp t tagbody third throw truncate unless
+ unwind-protect values values-list variable warn when
+ write-line write-string zerop))
(setq *package* *user-package*)
projects / jscl.git / blobdiff