David Vazquez <davazp at gmail.com>
Raimon Grau <rgrau at gmail.com>
Alfredo Beaumont <alfredo.beaumont at gmail.com>
+Owen Rodley
+Andrea Griffini <agriff at tin.it>
("print" :target)
("read" :both)
("compiler" :both)
+ ("list" :target)
("toplevel" :target)))
(defun source-pathname
,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
',name))
-(defmacro named-lambda (name args &rest body)
- (let ((x (gensym "FN")))
- `(let ((,x (lambda ,args ,@body)))
- (oset ,x "fname" ,name)
- ,x)))
-
(defmacro defun (name args &rest body)
`(progn
-
- (fset ',name
- (named-lambda ,(symbol-name name) ,args
- ,@(if (and (stringp (car body)) (not (null (cdr body))))
- `(,(car body) (block ,name ,@(cdr body)))
- `((block ,name ,@body)))))
+ (fset ',name #'(named-lambda ,name ,args ,@body))
',name))
(defun null (x)
(incf pos))
pos))
-(defun assoc (x alist)
+(defun assoc (x alist &key (test #'eql))
(while alist
- (if (eql x (caar alist))
+ (if (funcall test x (caar alist))
(return)
(setq alist (cdr alist))))
(car alist))
((symbolp x) (symbol-name x))
(t (char-to-string x))))
+(defun equal (x y)
+ (cond
+ ((eql x y) t)
+ ((consp x)
+ (and (consp y)
+ (equal (car x) (car y))
+ (equal (cdr x) (cdr y))))
+ ((arrayp x)
+ (and (arrayp y)
+ (let ((n (length x)))
+ (when (= (length y) n)
+ (dotimes (i n)
+ (unless (equal (aref x i) (aref y i))
+ (return-from equal nil)))
+ t))))
+ (t nil)))
+
(defun string= (s1 s2)
(equal s1 s2))
(ll-optional-arguments-canonical lambda-list))))
(remove nil (mapcar #'third args))))
-(defun lambda-docstring-wrapper (docstring &rest strs)
- (if docstring
+(defun lambda-name/docstring-wrapper (name docstring &rest strs)
+ (if (or name docstring)
(js!selfcall
"var func = " (join strs) ";" *newline*
- "func.docstring = '" docstring "';" *newline*
+ (when name
+ (code "func.fname = '" (escape-string name) "';" *newline*))
+ (when docstring
+ (code "func.docstring = '" (escape-string docstring) "';" *newline*))
"return func;" *newline*)
(apply #'code strs)))
"throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
"}" *newline*)))))
-(defun compile-lambda (ll body)
- (let ((required-arguments (ll-required-arguments ll))
- (optional-arguments (ll-optional-arguments ll))
- (keyword-arguments (ll-keyword-arguments ll))
- (rest-argument (ll-rest-argument ll))
- documentation)
- ;; Get the documentation string for the lambda function
- (when (and (stringp (car body))
+(defun parse-lambda-list (ll)
+ (values (ll-required-arguments ll)
+ (ll-optional-arguments ll)
+ (ll-keyword-arguments ll)
+ (ll-rest-argument ll)))
+
+;;; Process BODY for declarations and/or docstrings. Return as
+;;; multiple values the BODY without docstrings or declarations, the
+;;; list of declaration forms and the docstring.
+(defun parse-body (body &key declarations docstring)
+ (let ((value-declarations)
+ (value-docstring))
+ ;; Parse declarations
+ (when declarations
+ (do* ((rest body (cdr rest))
+ (form (car rest) (car rest)))
+ ((or (atom form) (not (eq (car form) 'declare)))
+ (setf body rest))
+ (push form value-declarations)))
+ ;; Parse docstring
+ (when (and docstring
+ (stringp (car body))
(not (null (cdr body))))
- (setq documentation (car body))
+ (setq value-docstring (car body))
(setq body (cdr body)))
- (let ((n-required-arguments (length required-arguments))
- (n-optional-arguments (length optional-arguments))
- (*environment* (extend-local-env
- (append (ensure-list rest-argument)
- required-arguments
- optional-arguments
- keyword-arguments
- (ll-svars ll)))))
- (lambda-docstring-wrapper
- documentation
- "(function ("
- (join (cons "values"
- (mapcar #'translate-variable
- (append required-arguments optional-arguments)))
- ",")
- "){" *newline*
- (indent
- ;; Check number of arguments
- (lambda-check-argument-count n-required-arguments
- n-optional-arguments
- (or rest-argument keyword-arguments))
- (compile-lambda-optional ll)
- (compile-lambda-rest ll)
- (compile-lambda-parse-keywords ll)
- (let ((*multiple-value-p* t))
- (ls-compile-block body t)))
- "})"))))
+ (values body value-declarations value-docstring)))
+
+;;; Compile a lambda function with lambda list LL and body BODY. If
+;;; NAME is given, it should be a constant string and it will become
+;;; the name of the function. If BLOCK is non-NIL, a named block is
+;;; created around the body. NOTE: No block (even anonymous) is
+;;; created if BLOCk is NIL.
+(defun compile-lambda (ll body &key name block)
+ (multiple-value-bind (required-arguments
+ optional-arguments
+ keyword-arguments
+ rest-argument)
+ (parse-lambda-list ll)
+ (multiple-value-bind (body decls documentation)
+ (parse-body body :declarations t :docstring t)
+ (declare (ignore decls))
+ (let ((n-required-arguments (length required-arguments))
+ (n-optional-arguments (length optional-arguments))
+ (*environment* (extend-local-env
+ (append (ensure-list rest-argument)
+ required-arguments
+ optional-arguments
+ keyword-arguments
+ (ll-svars ll)))))
+ (lambda-name/docstring-wrapper name documentation
+ "(function ("
+ (join (cons "values"
+ (mapcar #'translate-variable
+ (append required-arguments optional-arguments)))
+ ",")
+ "){" *newline*
+ (indent
+ ;; Check number of arguments
+ (lambda-check-argument-count n-required-arguments
+ n-optional-arguments
+ (or rest-argument keyword-arguments))
+ (compile-lambda-optional ll)
+ (compile-lambda-rest ll)
+ (compile-lambda-parse-keywords ll)
+ (let ((*multiple-value-p* t))
+ (if block
+ (ls-compile-block `((block ,block ,@body)) t)
+ (ls-compile-block body t))))
+ "})")))))
(defun setq-pair (var val)
(cond
((and (listp x) (eq (car x) 'lambda))
(compile-lambda (cadr x) (cddr x)))
+ ((and (listp x) (eq (car x) 'named-lambda))
+ ;; TODO: destructuring-bind now! Do error checking manually is
+ ;; very annoying.
+ (let ((name (cadr x))
+ (ll (caddr x))
+ (body (cdddr x)))
+ (compile-lambda ll body
+ :name (symbol-name name)
+ :block name)))
((symbolp x)
(let ((b (lookup-in-lexenv x *environment* 'function)))
(if b
(code "(" x ").toString()"))
(define-builtin eq (x y) (js!bool (code "(" x " === " y ")")))
-(define-builtin equal (x y) (js!bool (code "(" x " == " y ")")))
(define-builtin char-to-string (x)
(type-check (("x" "number" x))
--- /dev/null
+;;; list.lisp ---
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Various list functions
+
+
+;;; The rest of the C[AD]*R functions; only a few were defined in boot.lisp
+(defun cadar (x) (car (cdar x)))
+(defun caaar (x) (car (caar x)))
+(defun caadr (x) (car (cadr x)))
+(defun cdaar (x) (cdr (caar x)))
+(defun cdadr (x) (cdr (cadr x)))
+(defun cddar (x) (cdr (cdar x)))
+(defun caaaar (x) (car (caaar x)))
+(defun caaadr (x) (car (caadr x)))
+(defun caadar (x) (car (cadar x)))
+(defun caaddr (x) (car (caddr x)))
+(defun cadaar (x) (car (cdaar x)))
+(defun cadadr (x) (car (cdadr x)))
+(defun caddar (x) (car (cddar x)))
+(defun cdaaar (x) (cdr (caaar x)))
+(defun cdaadr (x) (cdr (caadr x)))
+(defun cdadar (x) (cdr (cadar x)))
+(defun cdaddr (x) (cdr (caddr x)))
+(defun cddaar (x) (cdr (cdaar x)))
+(defun cddadr (x) (cdr (cdadr x)))
+(defun cdddar (x) (cdr (cddar x)))
+(defun cddddr (x) (cdr (cdddr x)))
+
+
+(defun copy-tree (tree)
+ (if (consp tree)
+ (cons (copy-tree (car tree))
+ (copy-tree (cdr tree)))
+ tree))
+
+(defun subst (new old tree &key (key #'identity) (test #'eql))
+ (cond
+ ((funcall test (funcall key tree) (funcall key old))
+ new)
+ ((consp tree)
+ (cons (subst new old (car tree) :key key :test test)
+ (subst new old (cdr tree) :key key :test test)))
+ (t tree)))
+
+(defmacro pop (place)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion place)
+ (let ((head (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,head ,getter)
+ (,(car newval) (cdr ,head))
+ ,@(cdr newval))
+ ,setter
+ (car ,head)))))
(intern name package)
(find-symbol name package))))
+(defun read-integer (string)
+ (let ((sign 1)
+ (number nil)
+ (size (length string)))
+ (dotimes (i size)
+ (let ((elt (char string i)))
+ (cond
+ ((digit-char-p elt)
+ (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
+ ((zerop i)
+ (case elt
+ (#\+ nil)
+ (#\- (setq sign -1))
+ (otherwise (return-from read-integer))))
+ ((and (= i (1- size)) (char= elt #\.)) nil)
+ (t (return-from read-integer)))))
+ (and number (* sign number))))
+
(defun read-float (string)
(block nil
(let ((sign 1)
(incf index))))
(unless (= index size) (return))
;; Everything went ok, we have a float
- (/ (* sign (expt 10 (* exponent-sign exponent)) number) divisor))))
+ ;; XXX: Use FLOAT when implemented.
+ (/ (* sign (expt 10.0d0 (* exponent-sign exponent)) number) divisor))))
(defun !parse-integer (string junk-allow)
(read-sharp stream))
(t
(let ((string (read-until stream #'terminalp)))
- (or (values (!parse-integer string nil))
+ (or (read-integer string)
(read-float string)
(read-symbol string)))))))
(values-list /))
(export '(&body &key &optional &rest * ** *** *gensym-counter* *package* + ++
- +++ - / // /// 1+ 1- < <= = = > >= and append apply aref
- arrayp assoc atom block boundp butlast caar cadddr caddr
+ +++ - / // /// 1+ 1- < <= = = > >= and append apply aref arrayp
+ assoc atom block boundp butlast cadar caaar caadr cdaar cdadr
+ cddar caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar
+ cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 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 defconstant define-setf-expander
+ copy-list copy-tree decf declaim declare defconstant define-setf-expander
define-symbol-macro defmacro defparameter defun defvar
digit-char digit-char-p disassemble do do* documentation
dolist dotimes ecase eq eql equal error eval every export expt
make-symbol mapcar member minusp mod multiple-value-bind
multiple-value-call multiple-value-list multiple-value-prog1
nconc nil not nreconc nth nthcdr null numberp or
- package-name package-use-list packagep parse-integer plusp
+ package-name package-use-list packagep parse-integer plusp pop
prin1-to-string print proclaim prog1 prog2 progn psetq push
quote read-from-string remove remove-if remove-if-not return
return-from revappend reverse rplaca rplacd second set setf
- setq some string string-upcase string= stringp subseq
+ setq some string string-upcase string= stringp subseq subst
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
--- /dev/null
+(test (equal '(1 2) '(1 2)))
+(test (equal 1 1))
+(test (equal "abc" "abc"))
+(test (not (equal "abc" "def")))
+(test (not (equal "Abc" "abc")))
+(test (equal #(1 2 3) #(1 2 3)))
+(test (equal '(1 2 #(3 4 ("a b c" T)))
+ '(1 2 #(3 4 ("a b c" T)))))
+(test (not (equal '(1 2 #(3 4 ("a b c" T)))
+ '(1 2 #(3 4 ("a b x" T))))))
--- /dev/null
+;; Tests for list functions
+
+;; TODO: EQUAL doesn't compare lists correctly at the moment.
+;; Once it does the lists can be compared directly in many of these tests
+
+; COPY-TREE
+(test (let* ((foo '((1 2) (3 4)))
+ (bar (copy-tree foo)))
+ ;; (SETF (CAR (CAR FOO)) 0) doesn't work in the test for some reason,
+ ;; despite working fine in the REPL
+ (rplaca (car foo) 0)
+ (not (= (car (car foo))
+ (car (car bar))))))
+
+; SUBST
+; Can't really test this until EQUAL works properly on lists
+
+; POP
+(test (let* ((foo '(1 2 3))
+ (bar (pop foo)))
+ (and (= bar 1)
+ (= (car foo) 2))))
projects / jscl.git / commitdiff