Commit b2dd8e9e authored by jjgarcia's avatar jjgarcia

Documentation strings are stored in hash tables, not in property lists.

These hash tables can be dumped to help files which are understood by ECLS.
Most documentation strings have been moved back to the lisp source files
from which "SYS:help.doc" is built.
parent 8df91fc4
......@@ -803,6 +803,9 @@ ECLS 0.5
- libclos.a should be installed together with libecls.a and liblsp.a
- PROBE-FILE would not translate logical pathnames before checking for
file existence.
* System design and portability:
- Remove function_entry_table.
......@@ -837,6 +840,12 @@ ECLS 0.5
- Reader macro '#,' has been dropped. LOAD-TIME-VALUE added to both
the interpreter and the compiler.
- New, undocumented implementation of documentation strings which
uses hash tables instead of property lists. The gloal variable
si::*keep-documentation* determines whether documentation strings
are stored in memory. It is possible to dump documentation strings
to a help file.
TODO:
=====
......
......@@ -89,6 +89,7 @@ install: BUILD-STAMP
test -d $(PREFIX)$(libdir)/h/private || (mkdir $(PREFIX)$(libdir)/h/private; chmod 755 $(PREFIX)$(libdir)/h/private); \
for i in $(srcdir)/gc/include/private/?*.h; do $(INSTALL_DATA) $$i $(PREFIX)$(libdir)/h/private/`basename $$i`; done; \
fi
$(INSTALL_DATA) help.doc $(PREFIX)$(libdir)
cd c; $(MAKE) PREFIX="$(PREFIX)" install
cd doc; $(MAKE) PREFIX="$(PREFIX)" install
......@@ -107,7 +108,8 @@ clean: clean_lisp
$(RM) config.version config.log config.cache
$(RM) *.c *.o *.a *.h *.data
clean_lisp:
for i in lsp cmp clos clx tk; do rm -f lib$$i.a $$i/?*.o $$i/?*.c $$i/?*.data $$i/?*.h; done
for i in lsp cmp clos clx tk; do $(RM) lib$$i.a $$i/?*.o $$i/?*.c $$i/?*.data $$i/?*.h; done
$(RM) help.doc
distclean: clean
realclean: distclean
test1:
......
......@@ -23,6 +23,9 @@
;;;
(load "cmp/load.lsp")
(load "@srcdir@/doc/help.lsp")
(si::dump-documentation "help.doc")
;;;
;;; * By redefining "SYS:" ECLS will be able to
;;; find headers and libraries in the build directory.
......@@ -34,6 +37,11 @@
;;;
(setq compiler::*cc-flags* (concatenate 'string compiler::*cc-flags* " -I@srcdir@/h -I@srcdir@/gmp "))
;;;
;;; * Remove documentation from compiled files
;;;
(setq si::*keep-documentation* nil)
;;;
;;; * Beppe's defsystem utility
;;;
......
......@@ -42,6 +42,8 @@ cl_object @'si::*source-pathname*';
/* Try to load shared object file */
block = alloc_object(t_codeblock);
block->cblock.data = NULL;
block->cblock.data_size = 0;
block->cblock.name = filename;
block->cblock.handle = dlopen(filename->string.self, RTLD_NOW|RTLD_GLOBAL);
if (block->cblock.handle == NULL)
......
......@@ -2294,6 +2294,9 @@ read_VV(cl_object block, void *entry)
(*entry_point)(block);
len = block->cblock.data_size;
if (len == 0)
return;
#ifdef GBC_BOEHM
VV = block->cblock.data = alloc(len * sizeof(cl_object));
#else
......
......@@ -50,6 +50,18 @@
:commands (adjoin break-commands *tpl-commands*)))))
(defun sys::universal-error-handler (continue-string datum args)
"Args: (error-name continuable-p function-name
continue-format-string error-format-string
&rest args)
ECL specific.
Starts the error handler of ECL.
When an error is detected, ECL calls this function with the specified
arguments. To change the error handler of ECL, redefine this function.
ERROR-NAME is the name of the error. CONTINUABLE-P is T for a continuable
error and NIL for a fatal error. FUNCTION-NAME is the name of the function
that caused the error. CONTINUE-FORMAT-STRING and ERROR-FORMAT-STRING are the
format strings of the error message. ARGS are the arguments to the format
strings."
(declare (inline apply) ;; So as not to get bogus frames in debugger
(ignore error-name))
(let ((condition (coerce-to-condition datum args 'simple-error 'error)))
......@@ -473,6 +485,10 @@
(define-condition warning (condition) ())
(defun warn (datum &rest arguments)
"Args: (format-string &rest args)
Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message. Enters
a break level if the value of *BREAK-ON-WARNINGS* is non-NIL. Otherwise,
returns with NIL."
(let ((condition
(coerce-to-condition datum arguments 'SIMPLE-WARNING 'WARN)))
(check-type condition warning "a warning condition")
......
......@@ -205,10 +205,22 @@
(defvar *error-p* nil)
(defconstant *cmperr-tag* (cons nil nil))
(defvar *compile-print* t)
(defvar *compile-verbose* t)
(defvar *suppress-compiler-warnings* nil)
(defvar *suppress-compiler-notes* nil)
(defvar *compile-print* t
"This variable controls whether the compiler displays messages about
each form it processes. The default value is NIL.")
(defvar *compile-verbose* t
"This variable controls whether the compiler should display messages about its
progress. The default value is T.")
(defvar *suppress-compiler-warnings* nil
"This variable controls whether the compiler should issue warnings.
The default value is NIL.")
(defvar *suppress-compiler-notes* nil
"This variable controls whether the compiler displays compilation notices.
The default value is NIL.")
(defvar *compiler-break-enable* nil)
(defvar *compiler-in-use* nil)
......
......@@ -22,7 +22,14 @@
;;; The constant string *include-string* is the content of file "ecl.h".
;;; Here we use just a placeholder: it will be replaced with sed.
(defvar *cc* "cc"))
(defvar *cc* "cc"
"This variable controls how the C compiler is invoked by ECL.
The default value is \"cc -I. -I/usr/local/include/\".
The second -I option names the directory where the file ECL.h has been installed.
One can set the variable appropriately adding for instance flags which the
C compiler may need to exploit special hardware features (e.g. a floating point
coprocessor).")
(defvar *cc-flags* "-g -I.")
(defvar *cc-optimize* "-O") ; C compiler otimization flag
(defvar *cc-format* "~A ~A ~:[~*~;~A~] -I~A/h -w -c ~A -o ~A"))
......@@ -52,17 +59,20 @@
string result))
result))
(defun library-pathname (name &optional (directory "./"))
(make-pathname :name (concatenate 'string "lib" name) :type "a" :defaults directory))
(defun library-pathname (name shared &optional(directory "./"))
(if shared
(make-pathname :name name :type "so" :defaults directory)
(make-pathname :name (concatenate 'string "lib" name)
:type "a" :defaults directory)))
(defun compile-file-pathname (name &key output-file)
(merge-pathnames (or output-file name) #+dlopen #P".so" #-dlopen #P".o"))
(defun make-library (lib objects &key (output-dir "./"))
(defun make-library (lib objects &key (output-dir "./") (shared nil))
(let* ((lib (string-upcase lib))
(init-name (mapcar #'(lambda (x) (string-upcase (pathname-name x)))
objects))
(liba (library-pathname (string-downcase lib) output-dir))
(liba (library-pathname (string-downcase lib) shared output-dir))
(libc (make-pathname :name lib :type "c" :defaults output-dir))
(libo (make-pathname :name lib :type "o" :defaults output-dir)))
(with-open-file (libc-file libc :direction :output)
......@@ -77,24 +87,30 @@ init_~A(cl_object)
"
lib init-name init-name)
(compiler-cc libc libo)
#-dlopen
(safe-system (format nil "ar cr ~A ~A ~{~A ~}"
(namestring liba) (namestring libo) objects))
(namestring liba) (namestring libo) objects))
#+dlopen
(if shared
(apply #'shared-cc (namestring liba) (namestring libo) objects)
(safe-system (format nil "ar cr ~A ~A ~{~A ~}"
(namestring liba) (namestring libo) objects)))
(delete-file (namestring libc))
(delete-file (namestring libo)))
liba))
(defun linker-cc (o-pathname options &optional (shared nil))
(defun linker-cc (o-pathname &rest options)
(safe-system
(format nil
*ld-format*
*cc*
(if shared "-shared" "")
""
(namestring o-pathname)
(namestring (translate-logical-pathname "SYS:"))
options *ld-flags*)))
#+dlopen
(defun shared-cc (o-pathname options &optional (shared nil))
(defun shared-cc (o-pathname &rest options)
(safe-system
(format nil
*ld-shared-format*
......@@ -133,7 +149,7 @@ main(int argc, char **argv)
(error "compiler::build-ecls wrong argument ~A" item))))
(format c-file "~A;~%}~%" epilogue-code))
(compiler-cc c-name o-name)
(linker-cc name (cons (namestring o-name) ld-flags))
(apply #'linker-cc name (namestring o-name) ld-flags)
(delete-file c-name)
))
......@@ -241,7 +257,7 @@ Cannot compile ~a."
(format t "~&;;; Calling the C compiler... "))
(compiler-cc c-pathname o-pathname)
#+dlopen
(unless system-p (shared-cc so-pathname (list o-pathname) t))
(unless system-p (shared-cc so-pathname o-pathname))
(cond #+dlopen
((and (not system-p) (probe-file so-pathname))
(when load (load so-pathname))
......@@ -362,7 +378,7 @@ Cannot compile ~a."
(when *compile-verbose*
(format t "~&;;; Calling the C compiler... "))
(compiler-cc c-pathname o-pathname)
(shared-cc so-pathname (list o-pathname) t)
(shared-cc so-pathname o-pathname)
(delete-file c-pathname)
(delete-file h-pathname)
(delete-file o-pathname)
......@@ -497,7 +513,7 @@ Cannot compile ~a."
#+dlopen
(defun load-o-file (file verbose print)
(let ((tmp (merge-pathnames ".so" file)))
(shared-cc tmp (list file))
(shared-cc tmp file)
(when (probe-file tmp)
(load tmp :verbose nil :print nil)
;(delete-file tmp)
......
......@@ -237,10 +237,11 @@
(setq lambda-expr (c1lambda-expr (cdr args) fname))
(unless (eql setjmps *setjmps*)
(setf (info-volatile (second lambda-expr)) t))
(when (fourth lambda-expr)
(setq doc (add-object (fourth lambda-expr))))
(when (and (setq doc (fourth lambda-expr))
(setq doc (si::expand-set-documentation fname 'function doc)))
(t1expr `(progn ,@doc)))
(add-load-time-values)
(setq output (new-defun fname cfun lambda-expr doc *special-binding*))
(setq output (new-defun fname cfun lambda-expr *special-binding*))
(when
(and
(get fname 'PROCLAIMED-FUNCTION)
......@@ -275,7 +276,7 @@
output))
;;; Mechanism for sharing code:
(defun new-defun (fname cfun lambda-expr doc special-binding)
(defun new-defun (fname cfun lambda-expr special-binding)
(let ((previous (dolist (form *global-funs*)
(when (and (eq 'DEFUN (car form))
(equal special-binding (fifth form))
......@@ -284,9 +285,8 @@
(if previous
(progn
(cmpnote "Sharing code for function ~A" fname)
(list 'DEFUN fname previous nil doc special-binding
*funarg-vars*))
(let ((fun-desc (list fname cfun lambda-expr doc special-binding
(list 'DEFUN fname previous nil special-binding *funarg-vars*))
(let ((fun-desc (list fname cfun lambda-expr special-binding
*funarg-vars*)))
(push fun-desc *global-funs*)
(cons 'DEFUN fun-desc)))))
......@@ -329,7 +329,7 @@
"register "
""))
(defun t2defun (fname cfun lambda-expr doc sp funarg-vars
(defun t2defun (fname cfun lambda-expr sp funarg-vars
&aux (vv (add-symbol fname))
(nkey (length (fifth (third lambda-expr)))))
(declare (ignore sp funarg-vars))
......@@ -337,16 +337,11 @@
(if (numberp cfun)
(wt-nl "MF(" vv ",L" cfun ",Cblock);")
(wt-nl "MF(" vv "," cfun ",Cblock);"))
(when (< *space* 3)
(when doc
(wt-nl "(void)putprop(" vv "," doc ","
(add-symbol 'si::function-documentation) ");")
(wt-nl)))
(when (get fname 'PROCLAIMED-FUNCTION)
(wt-if-proclaimed fname cfun vv lambda-expr))
)
(defun t3defun (fname cfun lambda-expr doc sp funarg-vars
(defun t3defun (fname cfun lambda-expr sp funarg-vars
&aux inline-info lambda-list requireds
(*current-form* (list 'DEFUN fname))
(*volatile* (when lambda-expr
......@@ -355,8 +350,6 @@
(*next-unboxed* 0) (*unboxed* nil)
(*lex* *lex*) (*max-lex* *max-lex*)
(*env* *env*) (*max-env* 0) (*level* *level*))
(declare (ignore doc))
(setq *funarg-vars* funarg-vars)
(when lambda-expr ; Not sharing code.
(setq lambda-list (third lambda-expr)
......@@ -577,27 +570,24 @@
(setq *non-package-operation* t)
(let (macro-lambda (cfun (next-cfun)) (doc nil) (ppn nil))
(setq macro-lambda (c1dm (car args) (second args) (cddr args)))
(when (car macro-lambda) (setq doc (add-object (car macro-lambda))))
(when (second macro-lambda) (setq ppn (add-object (second macro-lambda))))
(when (and (setq doc (car macro-lambda))
(setq doc (si::expand-set-documentation (car args) 'function doc)))
(t1expr `(progn ,@doc)))
(add-load-time-values)
(list 'DEFMACRO (car args) cfun (cddr macro-lambda) doc ppn
(list 'DEFMACRO (car args) cfun (cddr macro-lambda) ppn
*special-binding*)))
(defun t2defmacro (fname cfun macro-lambda doc ppn sp
&aux (vv (add-symbol fname)))
(defun t2defmacro (fname cfun macro-lambda ppn sp &aux (vv (add-symbol fname)))
(declare (ignore macro-lambda sp))
(when (< *space* 3)
(when doc
(wt-nl "(void)putprop(" vv "," doc ","
(add-symbol 'si::function-documentation) ");")
(wt-nl))
(when ppn
(wt-nl "(void)putprop(" vv "," ppn ",siSpretty_print_format);")
(wt-nl)))
(wt-h "static cl_object L" cfun "();")
(wt-nl "MM(" vv ",L" cfun ",Cblock);"))
(defun t3defmacro (fname cfun macro-lambda doc ppn sp
(defun t3defmacro (fname cfun macro-lambda ppn sp
&aux (*lcl* 0) (*temp* 0) (*max-temp* 0)
(*lex* *lex*) (*max-lex* *max-lex*)
(*next-unboxed* 0) *unboxed*
......@@ -607,7 +597,6 @@
(*exit* 'RETURN) (*unwind-exit* '(RETURN))
(*destination* 'RETURN)
(*reservation-cmacro* (next-cmacro)))
(declare (ignore doc ppn))
(wt-comment "macro definition for " fname)
(wt-nl1 "static cl_object L" cfun "(int narg, cl_object V1, cl_object V2)")
(wt-nl1 "{")
......@@ -662,24 +651,22 @@
(if (endp (cdr args))
(list 'DECLARE (add-symbol name))
(progn
(unless (endp (cddr args)) (setq doc (add-object (third args))))
(when (and (setq doc (third args))
(setq doc (si::expand-set-documentation name 'variable doc)))
(t1expr `(progn ,@doc)))
(setq form (c1expr (second args)))
(add-load-time-values)
(list 'DEFVAR (make-var :name name :kind 'SPECIAL
:loc (add-symbol name)) form doc))))
:loc (add-symbol name)) form))))
(defun t2defvar (var form doc &aux (vv (var-loc var)))
(defun t2defvar (var form &aux (vv (var-loc var)))
(wt-nl vv "->symbol.stype=(short)stp_special;")
(let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
(*destination* (list 'VAR var)))
(wt-nl "if(" vv "->symbol.dbind == OBJNULL){")
(c2expr form)
(wt "}")
(wt-label *exit*))
(when (and doc (< *space* 3))
(wt-nl "(void)putprop(" vv "," doc "," (add-symbol 'si::variable-documentation) ");")
(wt-nl))
)
(wt-label *exit*)))
(defun t1decl-body (decls body)
(if (null decls)
......
......@@ -6,6 +6,7 @@
;;;
;;; * Compile, load and link Common-Lisp base library
;;;
(setq si::*keep-documentation* nil)
(in-package "COMMON-LISP-USER")
(load "lsp/defsys.lsp")
(proclaim '(optimize (safety 2) (space 3)))
......@@ -22,7 +23,7 @@
(progn
(load "cmp/defsys.lsp")
(proclaim '(optimize (safety 2) (space 3)))
(sbt::operate-on-system cmp :library)
(sbt::operate-on-system cmp #-dlopen :library #+dlopen :shared-library)
;(sbt::operate-on-system cmp :load)
)
......@@ -37,6 +38,6 @@
;(sbt::operate-on-system clos :load)
)
(compiler::build-ecls "ecls" :components '(#+WANTS-CMP cmp))
(compiler::build-ecls "ecls" :components '(#+(and (not dlopen) WANTS-CMP) cmp))
(quit)
......@@ -24,7 +24,7 @@ FILTER = sed 's,@VERSION@,$(VERSION),g'
ECL = ../ecls
all: help.doc ecls.info eclsdev.info $(HTML)
all: ecls.info eclsdev.info $(HTML)
ecls.dvi: $(srcdir)/user.txi $(srcdir)/macros.txi clisp.sty ecl.sty
tex $(srcdir)/user.txi
......@@ -37,16 +37,12 @@ eclsdev.ps: eclsdev.dvi $(srcdir)/macros.txi
dvips -o $@ eclsdev.dvi
install: all
$(INSTALL_DATA) help.doc $(PREFIX)$(libdir)
$(INSTALL_DATA) ecls.info $(PREFIX)$(infodir)
$(INSTALL_DATA) eclsdev.info $(PREFIX)$(infodir)
uninstall:
rm -r $(infodir)/ecls.info $(infodir)/eclsdev.info
help.doc: help.lsp
$(ECL) < $(srcdir)/help.lsp > /dev/null
ecls.info: $(srcdir)/user.txi $(srcdir)/macros.txi
makeinfo -I $(srcdir) --no-split $(srcdir)/user.txi
eclsdev.info: $(srcdir)/devel.txi $(srcdir)/macros.txi
......@@ -80,4 +76,4 @@ ecls.html: $(srcdir)/user.txi $(srcdir)/macros.txi
eclsdev.html: $(srcdir)/devel.txi $(srcdir)/macros.txi
makeinfo -I $(srcdir) --html $(srcdir)/devel.txi
clean:
rm -f ecls.* help.doc *.html
rm -f ecls.* *.html
No preview for this file type
......@@ -28,6 +28,27 @@
(initial-contents nil initial-contents-supplied-p)
adjustable fill-pointer
displaced-to (displaced-index-offset 0))
"Args: (dimensions &key (element-type t) initial-element (initial-contents nil)
(adjustable nil) (fill-pointer nil) (displaced-to nil)
(displaced-index-offset 0) (static nil))
Creates an array of the specified DIMENSIONS. DIMENSIONS is a list of
non-negative integers each representing the length of the corresponding
dimension. It may be an integer for vectors, i.e., one-dimensional arrays.
ELEMENT-TYPE specifies the type of array elements. INITIAL-ELEMENT specifies
the initial value for all elements. Its default value depends on ELEMENT-
TYPE. INITIAL-CONTENTS specifies each element in terms of sequences.
ADJUSTABLE specifies whether or not the array is adjustable (see ADJUST-
ARRAY). FILL-POINTER is meaningful only for vectors. It specifies whether
the vector has fill-pointer or not, and if it has, the initial value of the
fill-pointer. Possible values are NIL (no fill-pointer), T (the length of the
vector), or an integer. See VECTOR-PUSH and VECTOR-POP. DISPLACED-TO, if
non-NIL, must be an array and specifies that the new array is displaced to the
given array. DISPLACED-INDEX-OFFSET is meaningful only when DISPLACED-TO is
non-NIL and specifies that the reference to the I-th element of the new array
in raw-major indexing is actually the reference to the (I + DISPLACED-INDEX-
OFFSET)th element of the given array.If the STATIC argument is supplied
with a non-nil value, then the body of the array is allocated as a
contiguous block."
(setq element-type (type-for-array element-type))
(if (or (integerp dimensions)
......@@ -103,12 +124,17 @@
(defun vector (&rest objects)
"Args: (&rest objects)
Creates and returns a simple-vector, with the N-th OBJECT being the N-th
element."
(make-array (list (length objects))
:element-type t
:initial-contents objects))
(defun array-dimensions (array)
"Args: (array)
Returns a list whose N-th element is the length of the N-th dimension of ARRAY."
(do ((i (array-rank array))
(d nil))
((= i 0) d)
......@@ -117,6 +143,9 @@
(defun array-in-bounds-p (array &rest indices &aux (r (array-rank array)))
"Args: (array &rest indexes)
Returns T if INDEXes are valid indexes of ARRAY; NIL otherwise. The number of
INDEXes must be equal to the rank of ARRAY."
(when (/= r (length indices))
(error "The rank of the array is ~R,~%~
~7@Tbut ~R ~:*~[indices are~;index is~:;indices are~] ~
......@@ -131,6 +160,10 @@
(defun array-row-major-index (array &rest indices)
"Args: (array &rest indexes)
Returns the non-negative integer that represents the location of the element
of ARRAY specified by INDEXes, assuming all elements of ARRAY are aligned in
row-major order."
(do ((i 0 (1+ i))
(j 0 (+ (* j (array-dimension array i)) (car s)))
(s indices (cdr s)))
......@@ -138,58 +171,111 @@
(defun bit (bit-array &rest indices)
"Args: (bit-array &rest indexes)
Returns the bit of BIT-ARRAY specified by INDEXes."
(apply #'aref bit-array indices))
(defun sbit (bit-array &rest indices)
"Args: (simple-bit-array &rest subscripts)
Returns the specified bit in SIMPLE-BIT-ARRAY."
(apply #'aref bit-array indices))
(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise AND of BIT-ARRAY1 and BIT-ARRAY2. Puts the results
into a new bit-array if RESULT is NIL, into BIT-ARRAY1 if RESULT is T, or into
RESULT if RESULT is a bit-array."
(bit-array-op boole-and bit-array1 bit-array2 result-bit-array))
(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise INCLUSIVE OR of BIT-ARRAY1 and BIT-ARRAY2. Puts the
results into a new bit-array if RESULT is NIL, into BIT-ARRAY1 if RESULT is T,
or into RESULT if RESULT is a bit-array."
(bit-array-op boole-ior bit-array1 bit-array2 result-bit-array))
(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise EXCLUSIVE OR of BIT-ARRAY1 and BIT-ARRAY2. Puts the
results into a new bit-array if RESULT is NIL, into BIT-ARRAY1 if RESULT is T,
or into RESULT if RESULT is a bit-array."
(bit-array-op boole-xor bit-array1 bit-array2 result-bit-array))
(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise EQUIVALENCE of BIT-ARRAY1 and BIT-ARRAY2. Puts the
results into a new bit-array if RESULT is NIL, into BIT-ARRAY1 if RESULT is T,
or into RESULT if RESULT is a bit-array."
(bit-array-op boole-eqv bit-array1 bit-array2 result-bit-array))
(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise NOT of {the element-wise AND of BIT-ARRAY1 and BIT-
ARRAY2}. Puts the results into a new bit-array if RESULT is NIL, into BIT-
ARRAY1 if RESULT is T, or into RESULT if RESULT is a bit-array."
(bit-array-op boole-nand bit-array1 bit-array2 result-bit-array))
(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise NOT of {the element-wise INCLUSIVE OR of BIT-ARRAY1
and BIT-ARRAY2}. Puts the results into a new bit-array if RESULT is NIL, into
BIT-ARRAY1 if RESULT is T, or into RESULT if RESULT is a bit-array."
(bit-array-op boole-nor bit-array1 bit-array2 result-bit-array))
(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise AND of {the element-wise NOT of BIT-ARRAY1} and BIT-
ARRAY2. Puts the results into a new bit-array if RESULT is NIL, into BIT-
ARRAY1 if RESULT is T, or into RESULT if RESULT is a bit-array."
(bit-array-op boole-andc1 bit-array1 bit-array2 result-bit-array))
(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise AND of BIT-ARRAY1 and {the element-wise NOT of BIT-
ARRAY2}. Puts the results into a new bit-array if RESULT is NIL, into BIT-
ARRAY1 if RESULT is T, or into RESULT if RESULT is a bit-array."
(bit-array-op boole-andc2 bit-array1 bit-array2 result-bit-array))
(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise INCLUSIVE OR of {the element-wise NOT of BIT-ARRAY1}
and BIT-ARRAY2. Puts the results into a new bit-array if RESULT is NIL, into
BIT-ARRAY1 if RESULT is T, or into RESULT if RESULT is a bit-array."
(bit-array-op boole-orc1 bit-array1 bit-array2 result-bit-array))
(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
"Args: (bit-array1 bit-array2 &optional (result nil))
Returns the element-wise INCLUSIVE OR of BIT-ARRAY1 and {the element-wise NOT
of BIT-ARRAY2}. Puts the results into a new bit-array if RESULT is NIL, into
BIT-ARRAY1 if RESULT is T, or into RESULT if RESULT is a bit-array."
(bit-array-op boole-orc2 bit-array1 bit-array2 result-bit-array))
(defun bit-not (bit-array &optional result-bit-array)
"Args: (bit-array &optional (result nil))
Returns the element-wise NOT of BIT-ARRAY. Puts the results into a new bit-
array if RESULT is NIL, into BIT-ARRAY if RESULT is T, or into RESULT if
RESULT is a bit-array."
(bit-array-op boole-c1 bit-array bit-array result-bit-array))
(defun vector-push (new-element vector)
"Args: (item vector)
Replaces ITEM for the element of VECTOR that is pointed to by the fill-pointer
of VECTOR and then increments the fill-pointer by one. Returns NIL if the new
value of the fill-pointer becomes too large. Otherwise, returns the new fill-
pointer as the value."
(let ((fp (fill-pointer vector)))
(declare (fixnum fp))
(cond ((< fp (the fixnum (array-dimension vector 0)))
......@@ -200,6 +286,11 @@
(defun vector-push-extend (new-element vector &optional extension)
"Args: (item vector &optional (n (length vector)))
Replaces ITEM for the element of VECTOR that is pointed to by the fill-pointer
of VECTOR and then increments the fill-pointer by one. If the new value of
the fill-pointer becomes too large, extends VECTOR for N more elements.
Returns the new value of the fill-pointer."
(let ((fp (fill-pointer vector)))
(declare (fixnum fp))
(cond ((< fp (the fixnum (array-dimension vector 0)))
......@@ -221,6 +312,10 @@
(defun vector-pop (vector)
"Args: (vector)
Decrements the fill-pointer of VECTOR by one and returns the element pointed
to by the new fill-pointer. Signals an error if the old value of the fill-
pointer is 0 already."
(let ((fp (fill-pointer vector)))
(declare (fixnum fp))
(when (= fp 0)
......@@ -237,6 +332,12 @@
fill-pointer
displaced-to
displaced-index-offset)
"Args: (array dimensions
&key (element-type (array-element-type array))
initial-element (initial-contents nil) (fill-pointer nil)
(displaced-to nil) (displaced-index-offset 0))
Adjusts the dimensions of ARRAY to the given DIMENSIONS. ARRAY must be an
adjustable array."
(declare (ignore element-type
initial-element
initial-contents
......
......@@ -13,6 +13,12 @@
(c-declaim (si::c-export-fname ecase-error ccase-error typecase-error-string))
(defmacro check-type (place typespec &optional (string nil s))
"Args: (check-type place typespec [string-form])
Signals a continuable error, if the value of PLACE is not of the specified
type. Before continuing, receives a new value of PLACE from the user and
checks the type again. Repeats this process until the value of PLACE becomes
of the specified type. STRING-FORM, if given, is evaluated only once and the
value is used to indicate the expected type in the error message."
`(do ((*print-level* 4)
(*print-length* 4))
((typep ,place ',typespec) nil)
......@@ -24,6 +30,11 @@
(defmacro assert (test-form &optional places string &rest args)
"Args: (assert form [({place}*) [string {arg}*]])
Evaluates FORM and signals a continuable error if the value is NIL. Before
continuing, receives new values of PLACEs from user. Repeats this process
until FORM returns a non-NIL value. Returns NIL. STRING is the format string
for the error message and ARGs are arguments to the format string."
`(do ((*print-level* 4)
(*print-length* 4))
(,test-form nil)
......@@ -66,6 +77,11 @@
clauses))
(defmacro ecase (keyform &rest clauses)
"Syntax: (ecase keyform {({key | ({key}*)} {form}*)}*)
Evaluates KEYFORM and tries to find the KEY that is EQL to the value of
KEYFORM. If found, then evaluates FORMs that follow the KEY (or the key list
that contains the KEY) and returns all values of the last FORM. If not,
signals an error."
(let* ((key (if (atom keyform) keyform '#:key))
(let (if (atom keyform) nil (list (list key keyform)))))
`(let ,let
......@@ -86,6 +102,13 @@
value))
(defmacro ccase (keyform &rest clauses)
"Syntax: (ccase place {({key | ({key}*)} {form}*)}*)
Searches a KEY that is EQL to the value of PLACE. If found, then evaluates
FORMs in order that follow the KEY (or the key list that contains the KEY) and
returns all values of the last FORM. If no such KEY is found, signals a
continuable error. Before continuing, receives a new value of PLACE from
user and searches a KEY again. Repeats this process until the value of PLACE
becomes EQL to one of the KEYs."
(let* ((key (if (atom keyform) keyform '#:key))
(let (if (atom keyform) nil (list (list key keyform))))
(repeat '#:repeat))
......@@ -96,6 +119,11 @@
(go ,repeat)))))))
(defmacro typecase (keyform &rest clauses)
"Syntax: (typecase keyform {(type {form}*)}*)
Evaluates KEYFORM and searches a TYPE to which the value of KEYFORM belongs.
If found, then evaluates FORMs that follow the TYPE and returns all values of
the last FORM. If not, simply returns NIL. The symbols T and OTHERWISE may
be used as a TYPE to specify the default case."
(do ((l (reverse clauses) (cdr l))
(form nil) (key (gensym)))
((endp l) `(let ((,key ,keyform)) ,form))
......@@ -108,6 +136,10 @@
)
(defmacro etypecase (keyform &rest clauses &aux (key (gensym)))
"Syntax: (etypecase keyform {(type {form}*)}*)
Evaluates KEYFORM and searches a TYPE to which the value of KEYFORM belongs.
If found, then evaluates FORMs that follow the TYPE and returns all values of
the last FORM. If not, signals an error."
(do ((l (reverse clauses) (cdr l)) ; Beppe
(form `(error (typecase-error-string
',keyform ,key
......@@ -120,6 +152,12 @@
)
(defmacro ctypecase (keyplace &rest clauses &aux (key (gensym)))
"Syntax: (ctypecase place {(type {form}*)}*)
Searches a TYPE to which the value of PLACE belongs. If found, then evaluates
FORMs that follow the TYPE and returns all values of the last FORM. If no
such TYPE is found, signals a continuable error. Before continuing, receives
a new value of PLACE from the user and searches an appropriate TYPE again.
Repeats this process until the value of PLACE becomes of one of the TYPEs."
`(loop (let ((,key ,keyplace))
,@(mapcar #'(lambda (l)
`(when (typep ,key ',(car l))
......
......@@ -37,33 +37,68 @@
;;; Go into LISP.
(in-package "LISP")
(defun lisp-implementation-type () "ECLS")
(defun lisp-implementation-type ()
"Args: ()
Returns the string \"ECLS\"."
"ECLS")
;;; Compiler functions.
(unless (fboundp 'compile)
(defun proclaim (d)
"Args: (decl-spec)
Gives a global declaration. See DECLARE for possible DECL-SPECs."
(when (eq (car d) 'SPECIAL) (mapc #'sys::*make-special (cdr d))))
(defun proclamation (d)
(and (eq (car d) 'SPECIAL)
(dolist (var (cdr d) t)
(unless (sys::specialp var) (return nil)))))
(defun compile-file (&rest args)
(load "SYS:compiler")
"Args: (input-pathname
&key output-file (load nil)
(o-file t) (c-file nil) (h-file nil) (data-file nil))
Compiles the file specified by INPUT-PATHNAME and generates a fasl file
specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME,
then \".lsp\" is used as the default file type for the source file. LOAD
specifies whether to load the generated fasl file after compilation. The