From 0e38e0fddb31adfa138e782accc1eadb83139dd8 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 12 Apr 2011 16:06:12 +0000 Subject: cleanup from lisp --- src/interp/debug.lisp | 2 -- src/interp/hash.lisp | 6 +----- src/interp/metalex.lisp | 20 +++++++------------- src/interp/spad.lisp | 10 +--------- src/interp/vmlisp.lisp | 33 ++------------------------------- 5 files changed, 11 insertions(+), 60 deletions(-) (limited to 'src/interp') diff --git a/src/interp/debug.lisp b/src/interp/debug.lisp index 2c951e31..1f1b9c5c 100644 --- a/src/interp/debug.lisp +++ b/src/interp/debug.lisp @@ -290,8 +290,6 @@ (compile (EVAL DEF)))) ( DEF (FUNCALL OP (LIST DEF)) ) ) - #+Lucid(system::compiler-options :messages nil :warnings nil) - #+Lucid(TERPRI) (COND ( TRACEFLAG (/TRACE-2 /FN NIL) ) ) diff --git a/src/interp/hash.lisp b/src/interp/hash.lisp index affd3f6e..98ac338a 100644 --- a/src/interp/hash.lisp +++ b/src/interp/hash.lisp @@ -44,8 +44,7 @@ ((EQ ID) #'eq) (CVEC #'equal) (EQL #'eql) - #+Lucid ((UEQUAL EQUALP) #'EQUALP) - #-Lucid ((UEQUAL EQUAL) #'equal) + ((UEQUAL EQUAL) #'equal) (otherwise (error "bad arg to make-hashtable"))))) (make-hash-table :test test))) @@ -60,9 +59,6 @@ #'(lambda (key val) (declare (ignore val)) (push key keys)) table) keys)) -#+Lucid -(define-function 'HASHTABLE-CLASS #'system::hash-table-test) - #+AKCL (clines "int mem_value(x ,i)object x;int i; { return ((short *)x)[i];}") #+AKCL diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp index e6cc1485..bc80c1d6 100644 --- a/src/interp/metalex.lisp +++ b/src/interp/metalex.lisp @@ -407,10 +407,10 @@ NonBlank is true if the token is not preceded by a blank." (*print-pretty* t)) (if store (progn (format t "~%Reduction stack contains:~%") - (mapcar #'(lambda (x) (if (eq (type-of x) 'token) - #+Symbolics (zl:describe-defstruct x) - #-Symbolics (describe x) - (print x))) + (mapcar #'(lambda (x) + (if (eq (type-of x) 'token) + (describe x) + (print x))) (stack-store reduce-stack))) (format t "~%There is nothing on the reduction stack.~%")))) @@ -524,19 +524,13 @@ empty (if File-Closed (return nil)) (format t "~%The number of valid tokens is ~S.~%" Valid-Tokens)) (if (> Valid-Tokens 0) (progn (format t "The current token is~%") - #+Symbolics (zl:describe-defstruct current-token) - #-Symbolics (describe current-token) - )) + (describe current-token))) (if (> Valid-Tokens 1) (progn (format t "The next token is~%") - #+Symbolics (zl:describe-defstruct next-token) - #-Symbolics (describe next-token) - )) + (describe next-token))) (if (token-type prior-token) (progn (format t "The prior token was~%") - #+Symbolics (zl:describe-defstruct prior-token) - #-Symbolics (describe prior-token) - ))) + (describe prior-token)))) (defmacro token-stack-clear () `(progn (setq valid-tokens 0) diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp index 2c2a01ee..853fcbc8 100644 --- a/src/interp/spad.lisp +++ b/src/interp/spad.lisp @@ -241,14 +241,8 @@ (defun |sort| (seq spadfn) (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) -#-Lucid (defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) -#+Lucid -(defun DIVIDE2 (X Y) - (if (zerop y) (truncate 1 Y) - (multiple-value-call #'cons (TRUNCATE X Y)))) - (define-function '|not| #'NOT) (defun |random| () (random (expt 2 26))) @@ -425,9 +419,7 @@ (defun |hashable| (dom) (memq (|knownEqualPred| dom) - #-Lucid '(EQ EQL EQUAL) - #+Lucid '(EQ EQL EQUAL EQUALP) - )) + '(EQ EQL EQUAL))) ;; simpler interpface to RDEFIOSTREAM (defun RDEFINSTREAM (&rest fn) diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp index af7021cd..6d10bd30 100644 --- a/src/interp/vmlisp.lisp +++ b/src/interp/vmlisp.lisp @@ -77,7 +77,6 @@ (defmacro applx (&rest args) `(apply ,@args)) -#-(or LispM Lucid) (defmacro assq (a b) `(assoc ,a ,b :test #'eq)) @@ -205,7 +204,6 @@ (defmacro maxindex (x) `(the fixnum (1- (the fixnum (length ,x))))) -#-(or LispM Lucid) (defmacro memq (a b) `(member ,a ,b :test #'eq)) @@ -550,8 +548,7 @@ (setq args (remove-fluids (cadr lamda))) (cond ((and (eq ltype 'lambda) (simple-arglist args)) (setq nargs args)) (t (setq nargs (gensym)) - #+LispM (setq body `((dsetq ,args (copy-list ,nargs)) ,@body)) - #-LispM (setq body `((dsetq ,args ,nargs) ,@body)) + (setq body `((dsetq ,args ,nargs) ,@body)) (cond ((eq ltype 'lambda) (setq nargs `(&rest ,nargs &aux ,@*vars*))) ((eq ltype 'mlambda) (setq nargs `(&whole ,nargs &rest ,(gensym) &aux ,@*vars*))) @@ -620,20 +617,13 @@ ; 9.13 Streams -#+Lucid -(defun IS-CONSOLE (stream) - (and (streamp stream) - (or (not (consp (pathname-directory stream))) - (equal (qcar (pathname-directory stream)) "dev") - (null (pathname-name stream) )))) - #+KCL (defun IS-CONSOLE (stream) (and (streamp stream) (output-stream-p stream) (eq (system:fp-output-stream stream) (system:fp-output-stream *terminal-io*)))) -#-(OR Lucid KCL) +#-KCL (defun IS-CONSOLE (stream) (cond ((not (streamp stream)) nil) @@ -1548,14 +1538,6 @@ (LIST "in the expression:" MESSAGE)) ()) -#+Lucid -(defun numberofargs (x) - (setq x (system::arglist x)) - (let ((nx (- (length x) (length (memq '&aux x))))) - (if (memq '&rest x) (setq nx (- (1- nx)))) - (if (memq '&optional x) (setq nx (- (1- (abs nx))))) - nx)) - ; 98.0 Stuff Not In The VMLisp Manual That We Like ; A version of GET that works with lists @@ -1603,9 +1585,6 @@ (read-line st nil eofval)) (defun gcmsg (x) - #+Lucid - (prog1 (not system::*gc-silence*) - (setq system::*gc-silence* (not x))) #+(OR IBCL KCL) (prog1 system:*gbc-message* (setq system:*gbc-message* x)) @@ -1615,13 +1594,6 @@ ) (defun bpiname (func) - #+Lucid (if (functionp func) - (if (symbolp func) func - (let ((name (svref func 0))) - (if (and (consp name) (eq (car name) 'SYSTEM::NAMED-LAMBDA)) - (cadr name) - name)))) - #+(OR IBCL KCL) (if (functionp func) (cond ((symbolp func) func) ((and (consp func) (eq (car func) 'LAMBDA-BLOCK)) @@ -1639,7 +1611,6 @@ (system::%primitive header-ref func system::%function-name-slot)) ('else func))) - #+:allegro func #+(or :SBCL :clisp :ecl :clozure) (if (symbolp func) func (multiple-value-bind (l c n) -- cgit v1.2.3