diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/i-syscmd.boot | 2 | ||||
| -rw-r--r-- | src/interp/vmlisp.lisp | 113 |
2 files changed, 49 insertions, 66 deletions
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot index e17d6f65..b2d70fd2 100644 --- a/src/interp/i-syscmd.boot +++ b/src/interp/i-syscmd.boot @@ -2380,7 +2380,7 @@ savesystem l == )if not %hasFeature KEYWORD::ECL AxiomCore::saveCore SYMBOL_-NAME first l )else - fatalError '"don't know how to same image" + fatalError '"don't know how to save image" )endif --% )show diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp index e7bedb34..811b7069 100644 --- a/src/interp/vmlisp.lisp +++ b/src/interp/vmlisp.lisp @@ -469,15 +469,9 @@ (defmacro sintp (n) `(typep ,n 'fixnum)) -(defmacro sintp (n) - `(fixp ,n)) - (defmacro smintp (n) `(typep ,n 'fixnum)) -(defmacro smintp (n) - `(fixp ,n)) - (defmacro stringlength (x) `(length (the string ,x))) @@ -498,8 +492,6 @@ (defmacro zero? (x) `(and (typep ,x 'fixnum) (zerop (the fixnum ,x)))) -(defmacro zero? (x) `(zerop ,x)) - ;; defuns (define-function 'tempus-fugit #'get-internal-run-time) @@ -1693,66 +1685,57 @@ (defun |read-line| (st &optional (eofval *read-place-holder*)) (read-line st nil eofval)) -#+Lucid -(defun gcmsg (x) - (prog1 (not system::*gc-silence*) (setq system::*gc-silence* (not x)))) -#+(OR IBCL KCL) -(defun gcmsg (x) - (prog1 system:*gbc-message* (setq system:*gbc-message* x))) -#+:cmulisp (defun gcmsg (x) - (prog1 ext:*gc-verbose* (setq ext:*gc-verbose* x))) -#+ (or :allegro :sbcl :clisp :ecl) -(defun gcmsg (x)) - -#+Lucid -(defun reclaim () (system:gc)) -#+:cmulisp -(defun reclaim () (ext:gc)) -#+(OR IBCL KCL) -(defun reclaim () (gbc t)) -#+:allegro -(defun reclaim () (excl::gc t)) + #+Lucid + (prog1 (not system::*gc-silence*) + (setq system::*gc-silence* (not x))) + #+(OR IBCL KCL) + (prog1 system:*gbc-message* + (setq system:*gbc-message* x)) + #+:cmulisp + (prog1 ext:*gc-verbose* + (setq ext:*gc-verbose* x)) + ) + +(defun reclaim () + #+Lucid (system:gc) + #+:cmulisp (ext:gc) + #+(OR IBCL KCL) (gbc t) + #+:allegro (excl::gc t) + ) -#+Lucid -(defun BPINAME (func) - (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) -(defun BPINAME (func) - (if (functionp func) - (cond ((symbolp func) func) - ((and (consp func) (eq (car func) 'LAMBDA-BLOCK)) - (cadr func)) - ((compiled-function-p func) - (system:compiled-function-name func)) - ('t func)))) -#+:cmulisp -(defun BPINAME (func) - (when (functionp func) - (cond - ((symbolp func) func) - ((and (consp func) (eq (car func) 'lambda)) (second (third func))) - ((compiled-function-p func) - (system::%primitive header-ref func system::%function-name-slot)) - ('else func)))) -#+:allegro (defun bpiname (func) - func) - -#+(or :SBCL :clisp :ecl) -(defun BPINAME (x) - (if (symbolp x) - x - (multiple-value-bind (l c n) - (function-lambda-expression x) - (declare (ignore l c)) - n))) + #+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)) + (cadr func)) + ((compiled-function-p func) + (system:compiled-function-name func)) + ('t func))) + #+:cmulisp (when (functionp func) + (cond + ((symbolp func) func) + ((and (consp func) + (eq (car func) 'lambda)) + (second (third func))) + ((compiled-function-p func) + (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) + (function-lambda-expression func) + (declare (ignore l c)) + n))) (defun RE-ENABLE-INT (number-of-handler) number-of-handler) |