Index: gnu/commonlisp/lang/ChangeLog =================================================================== --- gnu/commonlisp/lang/ChangeLog (revision 7791) +++ gnu/commonlisp/lang/ChangeLog (working copy) @@ -1,5 +1,10 @@ 2014-02-08 Charles Turner + * CommonLisp.java: Added member, apply, complement and eql. + + +2014-02-08 Charles Turner + * CommonLisp.java: Added the various c*r procedures, acons, listp, numberp, zerop, consp and atom. Index: gnu/commonlisp/lang/CommonLisp.java =================================================================== --- gnu/commonlisp/lang/CommonLisp.java (revision 7791) +++ gnu/commonlisp/lang/CommonLisp.java (working copy) @@ -67,6 +67,7 @@ public static final Not not; public static final IsEq isEq; + public static final IsEqv isEqv; /** Package location symbols. */ public static final Symbol internalKeyword = Keyword.make("INTERNAL"); @@ -90,7 +91,9 @@ NumberCompare.TRUE_IF_LSS); numLEq = NumberCompare.make(instance, "<=", NumberCompare.TRUE_IF_LSS|NumberCompare.TRUE_IF_EQU); - isEq = new gnu.kawa.functions.IsEq(instance, "eq?"); + isEq = new IsEq(instance, "eq?"); + isEqv = new IsEqv(instance, "eqv?", isEq); + Environment saveEnv = Environment.setSaveCurrent(clispEnvironment); try { @@ -165,6 +168,8 @@ defProcStFld("<=", "gnu.commonlisp.lang.CommonLisp", "numLEq"); defProcStFld(">=", "gnu.commonlisp.lang.CommonLisp", "numGEq"); defProcStFld("not", "gnu.commonlisp.lang.CommonLisp"); + defProcStFld("eq?", "gnu.commonlisp.lang.CommonLisp", "isEq"); + defProcStFld("eqv?", "gnu.commonlisp.lang.CommonLisp", "isEqv"); defProcStFld("functionp", "gnu.commonlisp.lisp.PrimOps"); defProcStFld("car", "gnu.commonlisp.lisp.primitives"); defProcStFld("first", "gnu.commonlisp.lisp.primitives"); @@ -210,6 +215,10 @@ defProcStFldAs("zerop", "kawa.lib.numbers", "zero?"); defProcStFldAs("consp", "kawa.lib.lists", "pair?"); defProcStFld("atom", "gnu.commonlisp.lisp.primitives"); + defProcStFld("eql", "gnu.commonlisp.lisp.primitives"); + defProcStFld("member", "gnu.commonlisp.lisp.primitives"); + defProcStFld("complement", "gnu.commonlisp.lisp.primitives"); + defProcStFld("apply", "gnu.commonlisp.lisp.primitives"); } public static CommonLisp getInstance() Index: gnu/commonlisp/lisp/ChangeLog =================================================================== --- gnu/commonlisp/lisp/ChangeLog (revision 7791) +++ gnu/commonlisp/lisp/ChangeLog (working copy) @@ -1,5 +1,10 @@ 2014-02-08 Charles Turner + * PrimsOps.scm (setcar, setcdr): Remove non-CL symbols. + * primitives.lisp (eql, complement, member, apply): New procedures. + +2014-02-08 Charles Turner + * primitives.lisp (acons, listp, numberp, atom): Added new functions. 2014-02-07 Charles Turner Index: gnu/commonlisp/lisp/PrimOps.scm =================================================================== --- gnu/commonlisp/lisp/PrimOps.scm (revision 7791) +++ gnu/commonlisp/lisp/PrimOps.scm (working copy) @@ -2,12 +2,6 @@ ;;; They should be re-written in Common Lisp, but there are still some ;;; limitations in the Common Lisp support making that difficult. -(define (setcar (p ) x) - (set-car! p x)) - -(define (setcdr (p ) x) - (set-cdr! p x)) - ;; ANSI: This should be inclosed in "an implicit block whose name is ;; the function block name of the function-name or name, as ;; appropriate." But we don't have support for CL blocks yet. Index: gnu/commonlisp/lisp/primitives.lisp =================================================================== --- gnu/commonlisp/lisp/primitives.lisp (revision 7791) +++ gnu/commonlisp/lisp/primitives.lisp (working copy) @@ -43,3 +43,52 @@ (defun atom (obj) (not (consp obj))) + +(defun eql (x y) + (eqv? x y)) + +(defun complement (pred) + (lambda (&rest arguments) + (not (apply pred arguments)))) + +(defun member-with-test (x lst test key) + (declare (list lst)) + (cond ((null lst) nil) + ((funcall test x (funcall key (car lst))) lst) + (t (member-with-test x (cdr lst) test key)))) + +(defun member-with-key (x lst key) + (declare (list lst)) + (cond ((null lst) nil) + ((eql x (funcall key (car lst))) lst) + (t (member-with-key x (cdr lst) key)))) + +(defun member-plain (x lst) + (declare (list lst)) + (cond ((null lst) nil) + ((eql x (car lst)) lst) + (t (member-plain x (cdr lst))))) + +(defun member (x lst &key key + (test nil test-supplied) + (test-not nil test-not-supplied)) + (declare (list lst)) + (cond (test-supplied + (member-with-test x lst test key)) + (test-not-supplied + (member-with-test x lst (complement test-not) key)) + (key + (member-with-key x lst key)) + (t + (member-plain x lst)))) + +(defun apply (func &rest args) + (invoke (the |function| + (if (symbolp func) + (symbol-function func) + func)) + '|applyN| + (invoke-static |gnu.kawa.functions.Apply| + '|getArguments| + args + 0 #'apply))) Index: gnu/commonlisp/testsuite/ChangeLog =================================================================== --- gnu/commonlisp/testsuite/ChangeLog (revision 7791) +++ gnu/commonlisp/testsuite/ChangeLog (working copy) @@ -1,5 +1,9 @@ 2014-02-08 Charles Turner + * lang-test.lisp: New tests for member, apply, complement and eql. + +2014-02-08 Charles Turner + * lang-test.lisp: New test for acons, listp, numberp, zerop, consp, and atom. Index: gnu/commonlisp/testsuite/lang-test.lisp =================================================================== --- gnu/commonlisp/testsuite/lang-test.lisp (revision 7791) +++ gnu/commonlisp/testsuite/lang-test.lisp (working copy) @@ -1,4 +1,4 @@ -(test-init "Common Lisp tests" 59) +(test-init "Common Lisp tests" 80) (setq y 100) (defun foo1 (x) @@ -109,3 +109,35 @@ (test t 'atomp-3 (atom nil)) (test t 'atomp-4 (atom '())) (test t 'atomp-5 (atom 3)) + +(test nil 'eql-1 (eql 'a 'b)) +(test t 'eql-2 (eql 'a 'a)) +(test t 'eql-3 (eql 3 3)) +(test nil 'eql-4 (eql 3 3.0)) +(test t 'eql-5 (eql 3.0 3.0)) +(test nil 'eql-6 (eql (cons 'a 'b) (cons 'a 'c))) +(test nil 'eql-7 (eql (cons 'a 'b) (cons 'a 'b))) +(test t 'eql-8 (eql #\A #\A)) +(test nil 'eql-9 (eql "Foo" "FOO")) +(test t 'eql-10 (progn (setq x (cons 'a 'b)) (eql x x))) +(test t 'eql-11 (progn (setq x '(a . b)) (eql x x))) + +; BUG! Using Scheme booleans (via zerop). +;(test t 'complement-1 (funcall (complement #'zerop) 1)) +(test nil 'complement-2 (funcall (complement #'member) 'a '(a b c))) +(test t 'complement-3 (funcall (complement #'member) 'd '(a b c))) + +(test '(2 3) 'member-1 (member 2 '(1 2 3))) +(test '((3 . 4)) 'member-2 + (member 2 '((1 . 2) (3 . 4)) + :test-not #'= + :key #'cdr)) +(test nil 'member-3 (member 'e '(a b c d))) + +(setq f '+) +(test 3 'apply-1 (apply f '(1 2))) +(setq f #'-) +(test -1 'apply-2 (apply f '(1 2))) +(test 7 'apply-3 (apply #'max 3 5 '(2 7 3))) +(test '((+ 2 3) . 4) 'apply-4 (apply 'cons '((+ 2 3) 4))) +(test 0 'apply-5 (apply #'+ '())) Index: gnu/kawa/functions/Apply.java =================================================================== --- gnu/kawa/functions/Apply.java (revision 7791) +++ gnu/kawa/functions/Apply.java (working copy) @@ -14,6 +14,11 @@ super(name); this.applyToArgs = applyToArgs; } + + public static Object[] getArguments(LList args, int skip, + Procedure proc) { + return getArguments(args.toArray(), skip, proc); + } public static Object[] getArguments(Object[] args, int skip, Procedure proc) { Index: gnu/kawa/functions/ChangeLog =================================================================== --- gnu/kawa/functions/ChangeLog (revision 7791) +++ gnu/kawa/functions/ChangeLog (working copy) @@ -1,3 +1,8 @@ +2014-02-08 Charles Turner + + * Apply.java (getArguments): New overload to allow getArguments to + be called from Lisp code. + 2014-02-07 Per Bothner * RunProcess.java (getInputStreamFrom, copyStream): Make public -