mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 15:40:55 -08:00
118 lines
4 KiB
Common Lisp
118 lines
4 KiB
Common Lisp
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
|
;;;; Copyright (c) 1990, Giuseppe Attardi.
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
;;;; Exporting external symbols of LISP package
|
|
|
|
(si::select-package "CL")
|
|
|
|
(export '(
|
|
COMMON
|
|
KYOTO
|
|
KCL
|
|
ECL
|
|
ECL
|
|
common-lisp
|
|
common-lisp-user
|
|
cl
|
|
cl-user
|
|
))
|
|
|
|
(si::select-package "SI")
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
;;;
|
|
(*make-special '*dump-defun-definitions*)
|
|
(setq *dump-defun-definitions* nil)
|
|
(*make-special '*dump-defmacro-definitions*)
|
|
(setq *dump-defmacro-definitions* *dump-defun-definitions*)
|
|
|
|
(si::fset 'defun
|
|
(si::bc-disassemble
|
|
#'(lambda-block defun (def env)
|
|
(let* ((name (second def))
|
|
(function `#'(lambda-block ,@(cdr def))))
|
|
(when *dump-defun-definitions*
|
|
(print function)
|
|
(setq function `(si::bc-disassemble ,function)))
|
|
`(si::fset ',name ,function))))
|
|
t)
|
|
|
|
(si::fset 'in-package
|
|
#'(lambda-block in-package (def env)
|
|
`(si::select-package ,(string (second def))))
|
|
t)
|
|
|
|
(defun eval-feature (x)
|
|
(cond ((symbolp x)
|
|
(member x *features*
|
|
:test #'(lambda (a b)
|
|
(or (eql a b)
|
|
(and (symbolp a) (symbolp b)
|
|
(string-equal (symbol-name a)
|
|
(symbol-name b)))))))
|
|
((atom x) (error "~ is not allowed as a feature" x))
|
|
((eq (car x) 'AND)
|
|
(dolist (x (cdr x) t) (unless (eval-feature x) (return nil))))
|
|
((eq (car x) 'OR)
|
|
(dolist (x (cdr x) nil) (when (eval-feature x) (return t))))
|
|
((eq (car x) 'NOT)
|
|
(not (eval-feature (second x))))
|
|
(t (error "~S is not a feature expression." x))))
|
|
|
|
;;; Revised by G. Attardi
|
|
(defun check-no-infix (stream subchar arg)
|
|
(when arg
|
|
(error "Reading from ~S: no number should appear between # and ~A"
|
|
stream subchar)))
|
|
|
|
(defun sharp-+-reader (stream subchar arg)
|
|
(check-no-infix stream subchar arg)
|
|
(let ((feature (read stream t nil t)))
|
|
(if (and (not *read-suppress*) (eval-feature feature))
|
|
(read stream t nil t)
|
|
(let ((*read-suppress* t)) (read stream t nil t) (values)))))
|
|
|
|
(set-dispatch-macro-character #\# #\+ 'sharp-+-reader)
|
|
(set-dispatch-macro-character #\# #\+ 'sharp-+-reader
|
|
(sys::standard-readtable))
|
|
|
|
(defun sharp---reader (stream subchar arg)
|
|
(check-no-infix stream subchar arg)
|
|
(let ((feature (read stream t nil t)))
|
|
(if (or *read-suppress* (eval-feature feature))
|
|
(let ((*read-suppress* t)) (read stream t nil t) (values))
|
|
(read stream t nil t))))
|
|
|
|
(set-dispatch-macro-character #\# #\- 'sharp---reader)
|
|
(set-dispatch-macro-character #\# #\- 'sharp---reader
|
|
(sys::standard-readtable))
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
|
|
(in-package "CL")
|
|
|
|
;
|
|
; Conditions system
|
|
;
|
|
(export '(*break-on-signals* *debugger-hook* signal
|
|
handler-case handler-bind ignore-errors define-condition make-condition
|
|
with-simple-restart restart-case restart-bind restart-name
|
|
restart-name find-restart compute-restarts invoke-restart
|
|
invoke-restart-interactively abort continue muffle-warning
|
|
store-value use-value invoke-debugger restart condition
|
|
warning serious-condition simple-condition simple-warning simple-error
|
|
simple-condition-format-string simple-condition-format-arguments
|
|
storage-condition stack-overflow storage-exhausted type-error
|
|
type-error-datum type-error-expected-type simple-type-error
|
|
program-error control-error stream-error stream-error-stream
|
|
end-of-file file-error file-error-pathname cell-error
|
|
unbound-variable undefined-function arithmetic-error
|
|
arithmetic-error-operation arithmetic-error-operands
|
|
package-error package-error-package
|
|
division-by-zero floating-point-overflow floating-point-underflow))
|