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 -