aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2010-02-07 14:27:03 +0000
committerdos-reis <gdr@axiomatics.org>2010-02-07 14:27:03 +0000
commit49820464da35e02649ec0d4107ac3ea4491e1620 (patch)
treee38cf02a8f8cf1d08002a7965788cae8858a1446 /src
parent511d7f753a42d2ec117e2c52fcaf3f3e7615f676 (diff)
downloadopen-axiom-49820464da35e02649ec0d4107ac3ea4491e1620.tar.gz
* interp/daase.lisp: Remove conditionals on :CCL.
* interp/fname.lisp: Likewise. * interp/foam_l.lisp: Likewise. * interp/macros.lisp: Likewise. * interp/nlib.lisp: Likewise. * interp/patches.lisp: Likewise. * interp/sfsfun-l.lisp: Likewise. * interp/spad.lisp: Likewise. * interp/util.lisp: Likewise. * interp/vmlisp.lisp: Likewise.
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog13
-rw-r--r--src/interp/daase.lisp85
-rw-r--r--src/interp/debug.lisp2
-rw-r--r--src/interp/fname.lisp4
-rw-r--r--src/interp/foam_l.lisp18
-rw-r--r--src/interp/hash.lisp8
-rw-r--r--src/interp/macros.lisp12
-rw-r--r--src/interp/nlib.lisp14
-rw-r--r--src/interp/patches.lisp13
-rw-r--r--src/interp/sfsfun-l.lisp6
-rw-r--r--src/interp/spad.lisp12
-rw-r--r--src/interp/util.lisp10
-rw-r--r--src/interp/vmlisp.lisp96
13 files changed, 44 insertions, 249 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 4e34a158..65af692f 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,16 @@
+2010-02-07 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * interp/daase.lisp: Remove conditionals on :CCL.
+ * interp/fname.lisp: Likewise.
+ * interp/foam_l.lisp: Likewise.
+ * interp/macros.lisp: Likewise.
+ * interp/nlib.lisp: Likewise.
+ * interp/patches.lisp: Likewise.
+ * interp/sfsfun-l.lisp: Likewise.
+ * interp/spad.lisp: Likewise.
+ * interp/util.lisp: Likewise.
+ * interp/vmlisp.lisp: Likewise.
+
2010-01-03 Aleksej Saushev <asau@inbox.ru>
* hyper/addfile.c (strpostfix): Simplify.
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp
index e4193d52..10c02fd7 100644
--- a/src/interp/daase.lisp
+++ b/src/interp/daase.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2009, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -1074,11 +1074,6 @@
(cdr (assoc index alist :test #'string=))))
(let (cname kind key alist (systemdir? nil)
oldmaps asharp-name dbstruct abbrev)
-#+:CCL
- ;; Open the library
- (let (lib)
- (if (filep (setq lib (make-pathname :name object :type "lib")) )
- (setq input-libraries (cons (open-library (truename lib)) input-libraries))))
(set-file-getter object) ; sets the autoload property for G-object
(dolist (domain asy)
(setq key (first domain))
@@ -1234,21 +1229,12 @@
(remprop key 'loaded)
(if (null noexpose)
(|setExposeAddConstr| (cons key nil)))
- #-:CCL
(setf (symbol-function key) ; sets the autoload property for cname
#'(lambda (&rest args)
(unless (get key 'loaded)
(|startTimingProcess| '|load|)
(|loadLibNoUpdate| key key object)) ; used to be cname key
(apply key args)))
- #+:CCL
- (let (lib)
- (if (filep
- (setq lib (make-pathname :name object :type "lib")) )
- (setq input-libraries
- (cons (open-library (truename lib))
- input-libraries)))
- (|unloadOneConstructor| (get abbrev 'abbreviationfor) abbrev) )
(|sayKeyedMsg| 'S2IU0001 (list key object))))))
; making new databases consists of:
@@ -1705,29 +1691,6 @@
(cond ((not type?) obj)
(t (|makeOldAxiomDispatchDomain| obj))))
-;; CCL doesn't have closures, so we use an intermediate function in
-;; asharpMkAutoLoadFunctor.
-#+:CCL
-(defun mkFunctorStub (func cosig cname)
- (setf (symbol-function cname)
- (if (vectorp (car func))
- `(lambda () ',func) ;; constant domain
- `(lambda (&rest args2)
- (apply ',(|ClosFun| func)
- (nconc
- (mapcar #'wrapDomArgs args2 ',(cdr cosig))
- (list ',(|ClosEnv| func))))))))
-
-#+:CCL
-(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig)
- (setf (symbol-function cname)
- `(lambda (&rest args)
- (mkFunctorStub
- (getconstructor (eval (file-getter-name ',file)) ',asharp-name)
- ',cosig ',cname)
- (apply ',cname args))))
-
-#-:CCL
(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig)
(setf (symbol-function cname)
#'(lambda (&rest args)
@@ -1742,35 +1705,6 @@
(list (|ClosEnv| func)))))))
(apply cname args)))))
-;; CCL doesn't have closures, so we use an intermediate function in
-;; asharpMkAutoLoadCategory.
-#+:CCL
-(defun mkCategoryStub (func cosig packname)
- (setf (symbol-function packname)
- (if (vectorp (car func))
- `(lambda (self) ;; constant category
- (|CCall| (elt ',(car func) 5) ',(cdr func) (wrapDomArgs self t)))
- `(lambda (self &rest args)
- (let ((precat
- (apply (|ClosFun| ',func)
- (nconc
- (mapcar #'wrapDomArgs args ',(cdr cosig))
- (list (|ClosEnv| ',func))))))
- (|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t)))))
-))
-
-#+:CCL
-(defun asharpMkAutoLoadCategory (file cname asharp-name cosig)
- (asharpMkAutoLoadFunctor file cname asharp-name cosig)
- (let ((packname (INTERN (STRCONC cname "&"))))
- (setf (symbol-function packname)
- `(lambda (self &rest args)
- (mkCategoryStub
- (getconstructor (eval (file-getter-name ',file)) ',asharp-name)
- ',cosig ',packname)
- (apply ',packname self args)))))
-
-#-:CCL
(defun asharpMkAutoLoadCategory (file cname asharp-name cosig)
(asharpMkAutoLoadFunctor file cname asharp-name cosig)
(let ((packname (INTERN (STRCONC cname '"&"))))
@@ -1790,17 +1724,6 @@
(|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t))))))
(apply packname self args))))))
-#+:CCL
-(defun asharpMkAutoLoadFunction (file asharpname)
- (setf (symbol-value asharpname)
- (cons
- `(lambda (&rest l)
- (let ((args (butlast l))
- (func (getconstructor (eval (file-getter-name ',file)) ',asharpname)))
- (apply (car func) (append args (list (cdr func))))))
- ())))
-
-#-:CCL
(defun asharpMkAutoLoadFunction (file asharpname)
(setf (symbol-value asharpname)
(cons
@@ -1826,10 +1749,7 @@
(defun init-file-getter (env)
(let ((getter-name (car env))
(filename (cdr env)))
-#-:CCL
(load filename)
-#+:CCL
- (load-module filename)
(|CCall| (eval getter-name))))
(defun set-lib-file-getter (filename cname)
@@ -1841,10 +1761,7 @@
(let* ((getter-name (car env))
(cname (cdr env))
(filename (|getConstructorModuleFromDB| cname)))
-#-:CCL
(load filename)
-#+:CCL
- (load-module (pathname-name filename))
(|CCall| (eval getter-name))))
;; following 2 functions are called by file-exports and file-imports macros
diff --git a/src/interp/debug.lisp b/src/interp/debug.lisp
index a6cdc383..9e61867c 100644
--- a/src/interp/debug.lisp
+++ b/src/interp/debug.lisp
@@ -1136,8 +1136,6 @@ EXAMINE (SETQ RECNO (NOTE |$InputStream|))
(defun lisp-break-from-axiom (&rest ignore)
(boot::|handleLispBreakLoop| boot::|$BreakMode|))
-#+:CCL (setq lisp:*break-loop* 'boot::lisp-break-from-axiom)
-#-:CCL
(defun interrupt (&rest ignore))
diff --git a/src/interp/fname.lisp b/src/interp/fname.lisp
index a3c622d5..32dd202d 100644
--- a/src/interp/fname.lisp
+++ b/src/interp/fname.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2008, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -84,8 +84,6 @@
(if (probe-file (namestring f)) 't nil))
(defun |fnameReadable?| (f)
-#+:CCL (file-readablep f)
-#-:CCL
(let ((s (open f :direction :input :if-does-not-exist nil)))
(cond (s (close s) 't) ('t nil)) )
)
diff --git a/src/interp/foam_l.lisp b/src/interp/foam_l.lisp
index 8863d2d6..55390f44 100644
--- a/src/interp/foam_l.lisp
+++ b/src/interp/foam_l.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2008, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -520,11 +520,6 @@
(cddr ,x) nil))
(defmacro |SetEnvInfo| (x val) `(rplacd (cdr ,x) ,val))
-#+:CCL
-(defmacro |FoamEnvEnsure| (e)
- `(let ((einf (|EnvInfo| ,e)))
- (if einf (|CCall| einf) nil)))
-#-:CCL
(defmacro |FoamEnvEnsure| (e)
`(if (|EnvInfo| ,e) (|CCall| (|EnvInfo| ,e)) nil))
@@ -666,7 +661,6 @@
(defmacro block-return (obj val)
`(return-from ,obj ,val))
-#-:CCL
(defmacro typed-let (letvars &rest forms)
`(let ,(mapcar #'(lambda (var)
(list (car var) (type2init (cadr var))))
@@ -676,12 +670,6 @@
letvars))
,@forms))
-#+:CCL
-(defmacro typed-let (letvars &rest forms)
- `(let ,(mapcar #'(lambda (var) (car var))
- letvars )
- ,@forms))
-
(defmacro cases (&rest junk)
`(case ,@junk))
@@ -709,7 +697,6 @@
:element-type ',type
:initial-element ,(type2init type))))
-#-:CCL
(defun type2init (x)
(cond
((eq x '|Char|) '|CharInit|)
@@ -731,9 +718,6 @@
((eq x '|Nil|) nil)
(t nil)))
-#+:CCL
-(defun type2init (x) nil)
-
;; opsys interface
(defvar |G-mainArgc| 0)
(defvar |G-mainArgv| (vector))
diff --git a/src/interp/hash.lisp b/src/interp/hash.lisp
index b9f3463e..affd3f6e 100644
--- a/src/interp/hash.lisp
+++ b/src/interp/hash.lisp
@@ -78,14 +78,6 @@
(2 'EQUAL)
(t "error unknown hash table class")))
-#+:CCL
-(defun HASHTABLE-CLASS (table)
- (case (hashtable-flavour table)
- (0 'EQ)
- (1 'EQL)
- (2 'EQUAL)
- (t (format nil "error unknown hash table class ~a" (hashtable-flavour table)))))
-
(define-function 'HCOUNT #'hash-table-count)
;17.4 Searching and Updating
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index 809c5c1e..8c73a892 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2008, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -150,10 +150,6 @@
((eql n (qvmaxindex vec)) vec)
(t (subseq vec 0 (+ n 1))))))
-;; In CCL ASH assumes a 2's complement machine. We use ASH in Integer and
-;; assume we have a sign and magnitude setup.
-#+:CCL (defmacro ash (u v) `(lisp::ash1 ,u ,v))
-
; 14 SEQUENCES
; 14.1 Simple Sequence Functions
@@ -526,11 +522,11 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
#+IBCL
(defmacro |elapsedGcTime| () '(system:gbc-time-report))
+
#+AKCL
(defmacro |elapsedGcTime| () '(system:gbc-time))
-#+:CCL
-(defmacro |elapsedGcTime| () '(lisp:gctime))
-#-(OR :CCL IBCL AKCL)
+
+#-(OR IBCL AKCL)
(defmacro |elapsedGcTime| () '0)
(defmacro |do| (&rest args) (CONS 'PROGN args))
diff --git a/src/interp/nlib.lisp b/src/interp/nlib.lisp
index 434970e6..a81d840b 100644
--- a/src/interp/nlib.lisp
+++ b/src/interp/nlib.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2009, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -120,14 +120,6 @@
(princ pos stream)
(finish-output stream)))
-;;#+:ccl
-;;(defun putindextable (indextable dirname)
-;; (with-open-file
-;; (stream (concat dirname "/" |$IndexFilename|)
-;; :direction :io :if-does-not-exist :create)
-;; (file-position stream :end)
-;; (write-indextable indextable stream)))
-;;#-:ccl
(defun putindextable (indextable dirname)
(with-open-file
(stream (concat dirname "/" |$IndexFilename|)
@@ -351,12 +343,12 @@
(copy-file name1 name2))))
-#+(OR :AKCL (AND :CCL :UNIX))
+#+ :AKCL
(defun copy-lib-directory (name1 name2)
(|checkMkdir| name2)
(system (concat "sh -c 'cp " name1 "/* " name2 "'")))
-#+(OR :AKCL (AND :CCL :UNIX))
+#+ :AKCL
(defun copy-file (namestring1 namestring2)
(system (concat "cp " namestring1 " " namestring2)))
diff --git a/src/interp/patches.lisp b/src/interp/patches.lisp
index e6d206ba..958fcda4 100644
--- a/src/interp/patches.lisp
+++ b/src/interp/patches.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2008, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -97,14 +97,9 @@
(type (pathname-type input-file)))
(cond
((string= type "boot")
-#-:CCL
(boot input-file
(setq lfile (make-pathname :type "lisp"
:defaults input-file)))
-#+:CCL
- (boot input-file
- (setq lfile (make-pathname :name (pathname-name input-file)
- :type "lisp")))
(load lfile))
((string= type "lisp") (load input-file))
((string= type "bbin") (load input-file))
@@ -222,22 +217,16 @@
(name )) ;; this is used for printing
#+(and :gcl (not (or :dos :win32)))
(defun |xdrOpen| (str dir) (make-xdr-stream :handle (system:xdr-open str) :name str))
-#+:CCL
-(defun |xdrOpen| (str dir) (xdr-open str dir) )
#+(and :gcl (or :dos :win32))
(defun |xdrOpen| (str dir) (format t "xdrOpen called"))
#+(and :akcl (not (or :dos :win32)))
(defun |xdrRead| (xstr r) (system:xdr-read (xdr-stream-handle xstr) r) )
-#+:CCL
-(defun |xdrRead| (xstr r) (xdr-read xstr r) )
#+(and :gcl (or :dos :win32))
(defun |xdrRead| (str) (format t "xdrRead called"))
#+(and :akcl (not (or :dos :win32)))
(defun |xdrWrite| (xstr d) (system:xdr-write (xdr-stream-handle xstr) d) )
-#+:CCL
-(defun |xdrWrite| (xstr d) (xdr-write xstr d) )
#+(and :gcl (or :dos :win32))
(defun |xdrWrite| (str) (format t "xdrWrite called"))
diff --git a/src/interp/sfsfun-l.lisp b/src/interp/sfsfun-l.lisp
index 810cbe21..4014543b 100644
--- a/src/interp/sfsfun-l.lisp
+++ b/src/interp/sfsfun-l.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2008, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -40,9 +40,6 @@
;; SMW Feb 91
;;
-;; #-:CCL
-;; (defun |float| (x) (|float| x))
-
;; Conversion between spad and lisp complex representations
(defun s-to-c (c) (complex (car c) (cdr c)))
(defun c-to-s (c) (cons (realpart c) (imagpart c)))
@@ -56,7 +53,6 @@
(defun rlngamma (x) (|lnrgamma| x) )
(defun clngamma (z) (c-to-s (|lncgamma| (s-to-c z)) ))
-;; #-:CCL
(defun rgamma (x) (|rgamma| x))
(defun cgamma (z) (c-to-s (|cgamma| (s-to-c z)) ))
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index aefc8608..7761a1ef 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2008, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -442,28 +442,18 @@
;; function to create byte and half-word vectors in new runtime system 8/90
-#-:CCL
(defun |makeByteWordVec| (initialvalue)
(let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue)))))
(make-array (length initialvalue)
:element-type (list 'mod (1+ n))
:initial-contents initialvalue)))
-#+:CCL
-(defun |makeByteWordVec| (initialvalue)
- (list-to-vector initialvalue))
-
-#-:CCL
(defun |makeByteWordVec2| (maxelement initialvalue)
(let ((n (cond ((null initialvalue) 7) ('t maxelement))))
(make-array (length initialvalue)
:element-type (list 'mod (1+ n))
:initial-contents initialvalue)))
-#+:CCL
-(defun |makeByteWordVec2| (maxelement initialvalue)
- (list-to-vector initialvalue))
-
(defun |knownEqualPred| (dom)
(let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom)))
(if fun (get (bpiname (car fun)) '|SPADreplace|)
diff --git a/src/interp/util.lisp b/src/interp/util.lisp
index 6abfbbd3..1da23cf4 100644
--- a/src/interp/util.lisp
+++ b/src/interp/util.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2009, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -208,19 +208,13 @@
(defun compile-boot-file (file)
"compile and load a boot file"
(boot (concat file ".boot") (concat file ".lisp"))
-#-:ccl
(compile-file (concat file ".lisp"))
-#-:ccl
(load (concat file "." |$faslType|))
-#+:CCL
- (load (concat file ".lisp"))
)
;; Translate a single boot file to common lisp
(defun translate (file) ;; translates a single boot file
-#+:CCL
- (setq *package* (find-package "BOOT"))
#+:AKCL
(in-package "BOOT")
(let (*print-level* *print-length* (fn (pathname-name file))
@@ -297,8 +291,6 @@
(defun |setBootAutloadProperties| (fun-list file-list)
#+:AKCL
(mapc #'(lambda (fun) (|setBootAutoLoadProperty| fun file-list)) fun-list)
-#+:CCL
- (mapc #'(lambda (fun) (lisp::set-autoload fun file-list)) fun-list)
)
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index 72d79e12..e7bedb34 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2008, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -70,7 +70,6 @@
(defmacro absval (x)
`(abs ,x))
-#-:CCL
(defmacro add1 (x)
`(1+ ,x))
@@ -81,18 +80,12 @@
(defmacro applx (&rest args)
`(apply ,@args))
-#-(or LispM Lucid :CCL)
+#-(or LispM Lucid)
(defmacro assq (a b)
`(assoc ,a ,b :test #'eq))
-#+:CCL
-(defmacro assq (a b) `(atsoc ,a ,b))
-
-#-:CCL
(defmacro bintp (n)
`(typep ,n 'bignum))
-#+:CCL
-(defun bintp (n) (and (integerp n) (not (fixp n))))
(defmacro closedfn (form)
`(function ,form))
@@ -106,7 +99,6 @@
(defmacro dcq (&rest args)
(cons 'setqp args))
-#-:CCL
(defmacro difference (&rest args)
`(- ,@args))
@@ -125,7 +117,6 @@
(and (consp x) (eq (car x) 'quote)
(symbolp (cadr x))))))
-#-:CCL
(defmacro eqcar (x y)
(let ((test
(cond
@@ -156,11 +147,9 @@
(defmacro fetchchar (x i)
`(char ,x ,i))
-#-:CCL ;; fixp in ccl tests for fixnum
(defmacro fixp (x)
`(integerp ,x))
-#-:CCL
(defmacro greaterp (&rest args)
`(> ,@args))
@@ -211,7 +200,6 @@
(defmacro lastpair (l)
`(last ,l))
-#-:CCL
(defmacro lessp (&rest args)
`(< ,@args))
@@ -226,11 +214,10 @@
(defmacro maxindex (x)
`(the fixnum (1- (the fixnum (length ,x)))))
-#-(or LispM Lucid :CCL)
+#-(or LispM Lucid)
(defmacro memq (a b)
`(member ,a ,b :test #'eq))
-#-:CCL
(defmacro minus (x)
`(- ,x))
@@ -243,11 +230,8 @@
(defmacro ne (a b) `(not (equal ,a ,b)))
-;;; This may need adjustment in CCL where NEQ means (NOT (EQUAL ..)))
-#-:CCL
(defmacro neq (a b) `(not (eq ,a ,b)))
-#-:CCL
(defmacro nreverse0 (x)
(if (atom x)
`(if (atom ,x) ,x (nreverse ,x))
@@ -267,7 +251,6 @@
(defmacro pairp (x)
`(consp ,x))
-#-:CCL
(defmacro plus (&rest args)
`(+ ,@ args))
@@ -275,23 +258,21 @@
; `(assoc ,a ,b :test #'eq))
(defmacro qassq (a b) `(assq ,a ,b))
-#-:CCL
(defmacro qcar (x)
`(car (the cons ,x)))
-#-:CCL
+
(defmacro qcdr (x)
`(cdr (the cons ,x)))
-#-:CCL
(defmacro qcaar (x)
`(car (the cons (car (the cons ,x)))))
-#-:CCL
+
(defmacro qcadr (x)
`(car (the cons (cdr (the cons ,x)))))
-#-:CCL
+
(defmacro qcdar (x)
`(cdr (the cons (car (the cons ,x)))))
-#-:CCL
+
(defmacro qcddr (x)
`(cdr (the cons (cdr (the cons ,x)))))
@@ -447,11 +428,6 @@
(defmacro qvsize (x)
`(the fixnum (length (the simple-vector ,x))))
-; #-:CCL
-; (defmacro refvecp (v)
-; `(typep ,v '(vector t)))
-; #+:CCL
-; (defun refvecp (v) (and (vectorp v) (not (stringp v))))
(defmacro refvecp (v) `(simple-vector-p ,v))
(defmacro resetq (a b)
@@ -475,7 +451,6 @@
(setq ,id ,item)
(lam\,fileactq ',id (list 'setq ',id (list 'quote ,id)))))
-#-:CCL
(defmacro setelt (vec ind val)
`(setf (elt ,vec ,ind) ,val))
@@ -491,17 +466,15 @@
(defmacro sfp (x)
`(special-form-p ,x))
-#-:CCL
(defmacro sintp (n)
`(typep ,n 'fixnum))
-#+:CCL
+
(defmacro sintp (n)
`(fixp ,n))
-#-:CCL
(defmacro smintp (n)
`(typep ,n 'fixnum))
-#+:CCL
+
(defmacro smintp (n)
`(fixp ,n))
@@ -514,24 +487,17 @@
(defmacro throw-protect (exp1 exp2)
`(unwind-protect ,exp1 ,exp2))
-#-:CCL
(defmacro times (&rest args)
`(* ,@args))
(defmacro vec-setelt (vec ind val)
`(setf (svref ,vec ,ind) ,val))
-; #-:CCL
-; (defmacro vecp (v)
-; `(typep ,v '(vector t)))
-; #+:CCL
-; (defun vecp (v) (and (vectorp v) (not (stringp v))))
(defmacro vecp (v) `(simple-vector-p ,v))
-#-:CCL
(defmacro zero? (x)
`(and (typep ,x 'fixnum) (zerop (the fixnum ,x))))
-#+:CCL
+
(defmacro zero? (x) `(zerop ,x))
;; defuns
@@ -541,12 +507,9 @@
(defun $TOTAL-ELAPSED-TIME ()
(list (get-internal-run-time) (get-internal-real-time)))
-#-(OR IBCL KCL :CMULISP :CCL)
+#-(OR IBCL KCL :CMULISP)
(defun $TOTAL-GC-TIME () (list 0 0))
-#+:CCL
-(defun $TOTAL-GC-TIME () (list (gctime) (gctime)))
-
#+IBCL
(defun $TOTAL-GC-TIME (&aux (gcruntime (system:gbc-time-report)))
(list gcruntime gcruntime))
@@ -635,8 +598,6 @@
(cond ((atom (car fnlist)) (list (COMPILE1 fnlist)))
(t (MAPCAR #'(lambda (x) (COMPILE1 x)) fnlist))))
-#+:CCL (proclaim '(special *vars* *decl*)) ;; declare not handled right
-
(defun |compileLispDefinition| (name def)
(when *COMP370-APPLY*
(funcall *COMP370-APPLY* name def)))
@@ -709,7 +670,6 @@
; 9.5 Identifiers
-#-:CCL
(defun gensymp (x) (and (symbolp x) (null (symbol-package x))))
(defun digitp (x)
@@ -722,9 +682,8 @@
(digit-char-p (char (symbol-name x) 0))
(digit-char-p x)))
-#-:CCL
(defun LN (x) (LOG x))
-#-:CCL
+
(defun LOG2 (x) (LOG x 2.0))
(defun |log| (x) (LOG x 10.0))
@@ -743,7 +702,7 @@
(eq (system:fp-output-stream stream)
(system:fp-output-stream *terminal-io*))))
-#-(OR Lucid KCL :CCL)
+#-(OR Lucid KCL)
(defun IS-CONSOLE (stream)
(cond ((not (streamp stream))
nil)
@@ -796,10 +755,8 @@
;; property lists in vmlisp are alists
(defun PROPLIST (x)
(if (symbolp x)
-#-:CCL
+
(plist2alist (symbol-plist x))
-#+:CCL
- (plist2alist (plist x))
nil))
(defun plist2alist (x)
@@ -830,13 +787,11 @@
(define-function 'vm/ #'quotient)
-#-:CCL
(defun REMAINDER (x y)
(if (and (integerp x) (integerp y))
(rem x y)
(- x (* y (QUOTIENT x y)))))
-#-:CCL
(defun DIVIDE (x y)
(if (and (integerp x) (integerp y))
(multiple-value-list (truncate x y))
@@ -898,8 +853,6 @@
; 14.3 Searching
-#+:CCL (DEFMACRO |assoc| (X Y) `(ASSOC** ,X ,Y))
-#-:CCL
(DEFUN |assoc| (X Y)
"Return the pair associated with key X in association list Y."
; ignores non-nil list terminators
@@ -972,9 +925,7 @@
;; is compiled and the latter is byte-coded!
(defun size (l)
(cond ((vectorp l) (length l))
-#+:CCL ((stringp l) (length l)) ;; Until ACN fixes his lisp -> C translator.
-#-:CCL ((consp l) (list-length l))
-#+:CCL ((consp l) (length l))
+ ((consp l) (list-length l))
(t 0)))
(define-function 'MOVEVEC #'replace)
@@ -1540,9 +1491,7 @@
(defun EMBEDDED () (mapcar #'car *embedded-functions*))
(defun EMBED (CURRENT-BINDING NEW-DEFINITION)
- (PROG
-#+:CCL (OP BV BODY OLD-DEF *COMP)
-#-:CCL (OP BV BODY OLD-DEF)
+ (PROG (OP BV BODY OLD-DEF)
(COND
( (NOT (IDENTP CURRENT-BINDING))
(SETQ CURRENT-BINDING
@@ -1566,17 +1515,13 @@
( 'T
`((LAMBDA (,CURRENT-BINDING) ,NEW-DEFINITION) ',OLD-DEF)))
) )
-#+:CCL (IF (CONSP NEW-DEFINITION) (SETQ NEW-DEFINITION (CDR NEW-DEFINITION)))
(push (LIST CURRENT-BINDING NEW-DEFINITION OLD-DEF) *embedded-functions*)
(RETURN CURRENT-BINDING) ) )
(defun UNEMBED (CURRENT-BINDING)
- (PROG
-#+:CCL (TMP E-LIST CUR-DEF *COMP)
-#-:CCL (TMP E-LIST CUR-DEF)
+ (PROG (TMP E-LIST CUR-DEF)
(SETQ E-LIST *embedded-functions*)
(SETQ CUR-DEF (symbol-function CURRENT-BINDING))
-#+:CCL (IF (CONSP CUR-DEF) (SETQ CUR-DEF (CDR CUR-DEF)))
(COND
( (NOT (consp E-LIST))
NIL )
@@ -1768,8 +1713,6 @@
(defun reclaim () (gbc t))
#+:allegro
(defun reclaim () (excl::gc t))
-#+:CCL
-(defun reclaim () (gc))
#+Lucid
(defun BPINAME (func)
@@ -1801,11 +1744,6 @@
#+:allegro
(defun bpiname (func)
func)
-#+:CCL
-(defun bpiname (x)
- (if (symbolp x)
- (intern (symbol-name (symbol-function x)) "BOOT")
- nil))
#+(or :SBCL :clisp :ecl)
(defun BPINAME (x)