;; Basic functions
(defun = (x y) (= x y))
- (defun + (x y) (+ x y))
- (defun - (x y) (- x y))
(defun * (x y) (* x y))
(defun / (x y) (/ x y))
(defun 1+ (x) (+ x 1))
;;; constructions.
#+ecmalisp
(progn
+ (defun + (&rest args)
+ (let ((r 0))
+ (dolist (x args r)
+ (incf r x))))
+
+ (defun - (x &rest others)
+ (if (null others)
+ (- x)
+ (let ((r x))
+ (dolist (y others r)
+ (decf r y)))))
+
(defun append-two (list1 list2)
(if (null list1)
list2
decls)
(concat "return " (progn ,@body) ";" *newline*)))
+;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
+;;; a variable which holds a list of forms. It will compile them and
+;;; store the result in some Javascript variables. BODY is evaluated
+;;; with ARGS bound to the list of these variables to generate the
+;;; code which performs the transformation on these variables.
+
+(defun variable-arity-call (args function)
+ (unless (consp args)
+ (error "ARGS must be a non-empty list"))
+ (let ((counter 0)
+ (variables '())
+ (prelude ""))
+ (dolist (x args)
+ (let ((v (concat "x" (integer-to-string (incf counter)))))
+ (push v variables)
+ (concatf prelude
+ (concat "var " v " = " (ls-compile x) ";" *newline*
+ "if (typeof " v " !== 'number') throw 'Not a number!';"
+ *newline*))))
+ (js!selfcall prelude (funcall function (reverse variables)))))
+
+
+(defmacro variable-arity (args &body body)
+ (unless (symbolp args)
+ (error "Bad usage of VARIABLE-ARITY, yo must pass a symbol"))
+ `(variable-arity-call ,args
+ (lambda (,args)
+ (concat "return " ,@body ";" *newline*))))
+
+
(defun num-op-num (x op y)
(type-check (("x" "number" x) ("y" "number" y))
(concat "x" op "y")))
-(define-builtin + (x y) (num-op-num x "+" y))
-(define-builtin - (x y) (num-op-num x "-" y))
+(define-raw-builtin + (&rest numbers)
+ (if (null numbers)
+ "0"
+ (variable-arity numbers
+ (join numbers "+"))))
+
+(define-raw-builtin - (x &rest others)
+ (let ((args (cons x others)))
+ (variable-arity args
+ (if (null others)
+ (concat "-" (car args))
+ (join args "-")))))
+
+
(define-builtin * (x y) (num-op-num x "*" y))
(define-builtin / (x y) (num-op-num x "/" y))
(ls-compile-toplevel x))))
(js-eval code)))
- (export '(* *gensym-counter* *package* + - / 1+ 1- < <= = = > >= and append
- apply 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 defvar digit-char-p disassemble
- documentation dolist dotimes ecase eq eql equal error eval
- every export fdefinition find-package find-symbol first
- fourth fset funcall function functionp gensym go identity
- if in-package incf integerp integerp intern keywordp
- lambda last length let let* list-all-packages list listp
- make-package make-symbol mapcar member minusp mod nil not
- nth nthcdr null numberp or package-name package-use-list
- packagep plusp prin1-to-string print proclaim prog1 prog2
- pron push quote remove remove-if remove-if-not return
- return-from revappend reverse 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 variable warn when write-line write-string
- zerop))
+ (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= =
+= > >= and append apply 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 defvar digit-char-p disassemble documentation
+dolist dotimes ecase eq eql equal error eval every export fdefinition
+find-package find-symbol first fourth fset funcall function functionp
+gensym go identity if in-package incf integerp integerp intern
+keywordp lambda last length let let* list-all-packages list listp
+make-package make-symbol mapcar member minusp mod nil not nth nthcdr
+null numberp or package-name package-use-list packagep plusp
+prin1-to-string print proclaim prog1 prog2 pron push quote remove
+remove-if remove-if-not return return-from revappend reverse 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 variable
+warn when write-line write-string zerop))
(setq *package* *user-package*)