diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 13 | ||||
| -rw-r--r-- | src/interp/daase.lisp | 85 | ||||
| -rw-r--r-- | src/interp/debug.lisp | 2 | ||||
| -rw-r--r-- | src/interp/fname.lisp | 4 | ||||
| -rw-r--r-- | src/interp/foam_l.lisp | 18 | ||||
| -rw-r--r-- | src/interp/hash.lisp | 8 | ||||
| -rw-r--r-- | src/interp/macros.lisp | 12 | ||||
| -rw-r--r-- | src/interp/nlib.lisp | 14 | ||||
| -rw-r--r-- | src/interp/patches.lisp | 13 | ||||
| -rw-r--r-- | src/interp/sfsfun-l.lisp | 6 | ||||
| -rw-r--r-- | src/interp/spad.lisp | 12 | ||||
| -rw-r--r-- | src/interp/util.lisp | 10 | ||||
| -rw-r--r-- | src/interp/vmlisp.lisp | 96 |
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) |