diff --git a/.github/workflows/dfsg-deban-eus10.patch b/.github/workflows/dfsg-deban-eus10.patch
new file mode 100644
index 000000000..373b4fa08
--- /dev/null
+++ b/.github/workflows/dfsg-deban-eus10.patch
@@ -0,0 +1,46 @@
+diff --git a/debian/patches/fix-for-blhc.patch b/debian/patches/fix-for-blhc.patch
+index 2d34fab..eec84b2 100644
+--- a/debian/patches/fix-for-blhc.patch
++++ b/debian/patches/fix-for-blhc.patch
+@@ -23,12 +23,12 @@ index abf7b7b..01bc54f 100644
+ (defparameter *defun-list* nil)
+ (defparameter *verbose* nil)
+ (defparameter *optimize* 2)
+-@@ -1261,7 +1261,7 @@
+- (setq file (merge-pathnames ".l" file))
+- (if (null (probe-file file))
+- (error "file ~A not found~%" file)))
+-- (warn "compiling file: ~A~%" (namestring file))
+-+ ;; (warn "compiling file: ~A~%" (namestring file))
+- (setq ins (open file))
+- (setq *defun-list* nil)
+- (when *multipass-optimize*
++@@ -1855,7 +1855,7 @@
++ (setq file (merge-pathnames ".l" file))
++ (if (null (probe-file file))
++ (error io-error "file ~A not found~%" file)))
++- (warn "compiling file: ~A~%" (namestring file))
+++ ;; (warn "compiling file: ~A~%" (namestring file))
++ (setq ins (open file))
++ (setq *defun-list* nil)
++ (when *multipass-optimize*
+diff --git a/debian/patches/fix-for-hardening.patch b/debian/patches/fix-for-hardening.patch
+index f32285e..ad7e358 100644
+--- a/debian/patches/fix-for-hardening.patch
++++ b/debian/patches/fix-for-hardening.patch
+@@ -22,6 +22,7 @@ index 247bfa3..4b8e968 100644
+
+ -CFLAGS= $(WFLAGS) -fPIC -D$(MACHINE) -DLinux -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ +CFLAGS:= $(CFLAGS) $(CPPFLAGS) $(WFLAGS) -fPIC -D$(MACHINE) -DLinux -D_REENTRANT -DVERSION=\"$(VERSION)\" \
++ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
+ -DLIB6 $(ALIGN_FUNCTIONS) \
+ $(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
+ -DGCC $(GCC3) \
+@@ -78,6 +79,7 @@ index ec1665b..1de89b1 100644
+
+ -CFLAGS=$(WFLAGS) -D$(MACHINE) -DLinux -DARM -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ +CFLAGS:= $(CFLAGS) $(CPPFLAGS) $(WFLAGS) -D$(MACHINE) -DLinux -DARM -D_REENTRANT -DVERSION=\"$(VERSION)\" \
++ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
+ -DLIB6 $(ALIGN_FUNCTIONS) $(ADD_CFLAGS) \
+ $(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
+ -DGCC $(GCC3) \
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 000000000..4241c6ad9
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,39 @@
+Linux64
+Darwin
+Linux
+IRIX
+Alpha
+Cygwin
+LinuxARM
+LinuxSH4
+SunOS4
+SunOS5
+IRIX6
+
+include
+
+lisp/Makefile
+lisp/c/makedate.c
+
+lisp/comp/*.c
+lisp/comp/*.h
+lisp/geo/*.c
+lisp/geo/*.h
+lisp/image/*.c
+lisp/image/*.h
+lisp/l/*.c
+lisp/l/*.h
+lisp/opengl/src/*.c
+lisp/opengl/src/*.h
+lisp/xwindow/*.c
+lisp/xwindow/*h
+
+*.aux
+*.idx
+*.ilg
+*.ind
+*.log
+*.out
+*.toc
+*.hlp
+*.dvi
\ No newline at end of file
diff --git a/.travis.sh b/.travis.sh
index 1fb4ea247..b9e264ef8 100755
--- a/.travis.sh
+++ b/.travis.sh
@@ -81,6 +81,7 @@ if [[ "$QEMU" != "" && "$DOCKER_IMAGE" != "arm64v8/ubuntu:"* ]]; then
travis_time_start download.euslisp-debian
export GIT_SSL_NO_VERIFY=1
git clone http://salsa.debian.org/science-team/euslisp /tmp/euslisp-dfsg
+ patch -d /tmp/euslisp-dfsg -f -p1 < .github/workflows/dfsg-deban-eus10.patch
for file in $(cat /tmp/euslisp-dfsg/debian/patches/series); do
# skip patches already applied by https://github.com/euslisp/EusLisp/pull/482
[[ $file =~ use-rtld-global-loadelf.patch|fix-arm-ldflags.patch|fix-library-not-linked-against-libc.patch|fix-manpage-has-bad-whatis-entry-on-man-pages.patch ]] && continue;
diff --git a/README.md b/README.md
index 1d31d267d..500c7a1b5 100644
--- a/README.md
+++ b/README.md
@@ -27,17 +27,17 @@ $ git clone https://github.com/euslisp/EusLisp euslisp
$ cd euslisp
$ export ARCHDIR=Linux64
$ export EUSDIR=`pwd`
-$ export PATH=$PATH:$EUSDIR/$ARCHDIR/bin
-$ export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$EUSDIR/$ARCHDIR/lib
+$ export PATH=$EUSDIR/$ARCHDIR/bin:$PATH
+$ export LD_LIBRARY_PATH=$EUSDIR/$ARCHDIR/lib:$LD_LIBRARY_PATH
$ cd lisp
$ ln -sf Makefile.Linux64 Makefile
$ make eus0 eus1 eus2 eusg eusx eusgl eus
```
-For cygwin sytem, set ARCHDIR=Cygwin and ln -sf Makefile.Cygwin Makefile
+For cygwin system, set ARCHDIR=Cygwin and ln -sf Makefile.Cygwin Makefile
For 32bit Linux system, set ARCHDIR=Linux and ln -sf Makefile.Linux.thread Makefile
-### Documnets
+### Documents
See online [manual](http://euslisp.github.io/EusLisp/manual.html). (Japanese translation [manual](http://euslisp.github.io/EusLisp/jmanual.html))
diff --git a/contrib/utyo/select.l b/contrib/utyo/select.l
index 8e55a147a..ca0c0faf0 100644
--- a/contrib/utyo/select.l
+++ b/contrib/utyo/select.l
@@ -312,7 +312,6 @@
(defun reploop (prompt) ;read-eval-print loop
(let* ((result)
(ttyp (unix:isatty *terminal-io*))
- (*error-handler* 'euserror)
(eof (gensym))
(command) (input)
(arg) (arglist) (local-bindings) (special-bindings))
diff --git a/doc/help.eus/makehelp.l b/doc/help.eus/makehelp.l
index cc2ef7385..9fa3a7b37 100644
--- a/doc/help.eus/makehelp.l
+++ b/doc/help.eus/makehelp.l
@@ -30,6 +30,7 @@
"sequences"
"io"
"evaluation"
+ "types"
"sysfunc"
"matrix"
"geometry"
@@ -37,6 +38,8 @@
"voronoi"
"graphics"
"xwindow"
+ "xtoolkit"
+ "mthread"
"image"
"manipulator"))
(defvar *eus-jtex-list* (list "jintro"
@@ -56,6 +59,8 @@
"jvoronoi"
"jgraphics"
"jxwindow"
+ "jxtoolkit"
+ "jmthread"
"jimage"
"jmanipulator"))
diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp
index 3c0be3805..48b34238b 100644
--- a/doc/jlatex/euslisp.hlp
+++ b/doc/jlatex/euslisp.hlp
@@ -1,5 +1,5 @@
; This file is help command list for euslisp
-"/home/affonso/euslisp/src/euslisp/Euslisp/doc/jlatex" ; Directory of TeX manual
+"/home/affonso/euslisp_new_ws/src/euslisp/Euslisp/doc/jlatex" ; Directory of TeX manual
;
"and" 6 "jcontrols" 334 3
"or" 6 "jcontrols" 541 3
@@ -15,33 +15,46 @@
"let*" 6 "jcontrols" 3720 3
"flet" 6 "jcontrols" 4073 3
"labels" 6 "jcontrols" 4189 3
-"block" 6 "jcontrols" 4598 3
-"return-from" 6 "jcontrols" 4799 3
-"return" 3 "jcontrols" 5179 3
-"catch" 6 "jcontrols" 5483 3
-"throw" 6 "jcontrols" 5760 3
-"unwind-protect" 6 "jcontrols" 5916 3
-"while" 6 "jcontrols" 6625 3
-"tagbody" 6 "jcontrols" 7339 3
-"go" 6 "jcontrols" 7511 3
-"prog" 3 "jcontrols" 7773 3
-"do" 3 "jcontrols" 7972 3
-"do*" 3 "jcontrols" 8600 3
-"dotimes" 3 "jcontrols" 8863 3
-"dolist" 3 "jcontrols" 9126 3
-"until" 3 "jcontrols" 9641 3
-"loop" 3 "jcontrols" 9760 3
-"eq" 2 "jcontrols" 10134 3
-"eql" 2 "jcontrols" 10399 3
-"equal" 2 "jcontrols" 10539 3
-"superequal" 2 "jcontrols" 10912 3
-"null" 2 "jcontrols" 11061 3
-"not" 2 "jcontrols" 11176 3
-"atom" 2 "jcontrols" 11249 3
-"every" 2 "jcontrols" 11567 3
-"some" 2 "jcontrols" 11812 3
-"functionp" 2 "jcontrols" 12088 3
-"compiled-function-p" 2 "jcontrols" 12577 3
+"macrolet" 6 "jcontrols" 4537 3
+"block" 6 "jcontrols" 4707 3
+"return-from" 6 "jcontrols" 4908 3
+"return" 3 "jcontrols" 5288 3
+"catch" 6 "jcontrols" 5592 3
+"throw" 6 "jcontrols" 5869 3
+"unwind-protect" 6 "jcontrols" 6025 3
+"while" 6 "jcontrols" 6734 3
+"tagbody" 6 "jcontrols" 7448 3
+"go" 6 "jcontrols" 7620 3
+"prog" 3 "jcontrols" 7882 3
+"do" 3 "jcontrols" 8081 3
+"do*" 3 "jcontrols" 8709 3
+"dotimes" 3 "jcontrols" 8972 3
+"dolist" 3 "jcontrols" 9235 3
+"until" 3 "jcontrols" 9750 3
+"loop" 3 "jcontrols" 9869 3
+"eq" 2 "jcontrols" 10243 3
+"eql" 2 "jcontrols" 10508 3
+"equal" 2 "jcontrols" 10648 3
+"superequal" 2 "jcontrols" 11021 3
+"null" 2 "jcontrols" 11170 3
+"not" 2 "jcontrols" 11285 3
+"atom" 2 "jcontrols" 11358 3
+"every" 2 "jcontrols" 11676 3
+"some" 2 "jcontrols" 11921 3
+"functionp" 2 "jcontrols" 12197 3
+"compiled-function-p" 2 "jcontrols" 12686 3
+"condition" 0 "jcontrols" 14881 4
+":init" 1 "jcontrols" 14974 3
+"lisp::*condition-handler*" 5 "jcontrols" 15304 2
+"lisp::*current-condition*" 5 "jcontrols" 15422 2
+"defcondition" 3 "jcontrols" 15517 3
+"install-handler" 2 "jcontrols" 15755 3
+"remove-handler" 2 "jcontrols" 16132 3
+"handler-bind" 2 "jcontrols" 16433 3
+"handler-case" 3 "jcontrols" 16798 3
+"signals" 2 "jcontrols" 17193 3
+"invoke-next-handler" 2 "jcontrols" 17617 3
+"lisp::atomic" 3 "jcontrols" 17913 3
"defclass" 3 "jobjects" 4063 3
"defmethod" 6 "jobjects" 4582 3
"defclassmethod" 3 "jobjects" 4812 2
@@ -184,47 +197,48 @@
"boundp" 2 "jsymbols" 3711 3
"fboundp" 2 "jsymbols" 4054 3
"makunbound" 2 "jsymbols" 4181 3
-"get" 2 "jsymbols" 4388 3
-"putprop" 2 "jsymbols" 4585 3
-"remprop" 2 "jsymbols" 4719 3
-"setq" 6 "jsymbols" 4828 3
-"set" 2 "jsymbols" 5185 3
-"defun" 6 "jsymbols" 5385 3
-"defmacro" 6 "jsymbols" 5686 3
-"defvar" 3 "jsymbols" 5869 3
-"defparameter" 3 "jsymbols" 6133 3
-"defconstant" 3 "jsymbols" 6357 3
-"keywordp" 2 "jsymbols" 6885 3
-"constantp" 2 "jsymbols" 7013 3
-"documentation" 2 "jsymbols" 7143 3
-"gensym" 2 "jsymbols" 7262 3
-"gentemp" 2 "jsymbols" 7829 3
-"*lisp-package*" 4 "jsymbols" 11225 2
-"*user-package*" 4 "jsymbols" 11278 2
-"*unix-package*" 4 "jsymbols" 11339 2
-"*system-package*" 4 "jsymbols" 11394 2
-"*keyword-package*" 4 "jsymbols" 11458 2
-"find-symbol" 2 "jsymbols" 11518 3
-"make-symbol" 2 "jsymbols" 11774 3
-"intern" 2 "jsymbols" 11891 3
-"list-all-packages" 2 "jsymbols" 12245 3
-"find-package" 2 "jsymbols" 12347 3
-"make-package" 2 "jsymbols" 12462 3
-"in-package" 2 "jsymbols" 12735 3
-"package-name" 2 "jsymbols" 12874 3
-"package-nicknames" 2 "jsymbols" 12975 3
-"rename-package" 2 "jsymbols" 13054 3
-"package-use-list" 2 "jsymbols" 13331 3
-"packagep" 2 "jsymbols" 13423 3
-"use-package" 2 "jsymbols" 13510 3
-"unuse-package" 2 "jsymbols" 13773 3
-"shadow" 2 "jsymbols" 13886 3
-"export" 2 "jsymbols" 14030 3
-"unexport" 2 "jsymbols" 15257 3
-"import" 2 "jsymbols" 15407 3
-"do-symbols" 3 "jsymbols" 15819 3
-"do-external-symbols" 3 "jsymbols" 16047 3
-"do-all-symbols" 3 "jsymbols" 16246 3
+"fmakunbound" 2 "jsymbols" 4396 3
+"get" 2 "jsymbols" 4625 3
+"putprop" 2 "jsymbols" 4822 3
+"remprop" 2 "jsymbols" 4956 3
+"setq" 6 "jsymbols" 5065 3
+"set" 2 "jsymbols" 5422 3
+"defun" 6 "jsymbols" 5622 3
+"defmacro" 6 "jsymbols" 5923 3
+"defvar" 3 "jsymbols" 6110 3
+"defparameter" 3 "jsymbols" 6374 3
+"defconstant" 3 "jsymbols" 6598 3
+"keywordp" 2 "jsymbols" 7126 3
+"constantp" 2 "jsymbols" 7254 3
+"documentation" 2 "jsymbols" 7384 3
+"gensym" 2 "jsymbols" 7503 3
+"gentemp" 2 "jsymbols" 8070 3
+"*lisp-package*" 4 "jsymbols" 11466 2
+"*user-package*" 4 "jsymbols" 11519 2
+"*unix-package*" 4 "jsymbols" 11580 2
+"*system-package*" 4 "jsymbols" 11635 2
+"*keyword-package*" 4 "jsymbols" 11699 2
+"find-symbol" 2 "jsymbols" 11759 3
+"make-symbol" 2 "jsymbols" 12015 3
+"intern" 2 "jsymbols" 12132 3
+"list-all-packages" 2 "jsymbols" 12486 3
+"find-package" 2 "jsymbols" 12588 3
+"make-package" 2 "jsymbols" 12703 3
+"in-package" 2 "jsymbols" 12976 3
+"package-name" 2 "jsymbols" 13115 3
+"package-nicknames" 2 "jsymbols" 13216 3
+"rename-package" 2 "jsymbols" 13295 3
+"package-use-list" 2 "jsymbols" 13572 3
+"packagep" 2 "jsymbols" 13664 3
+"use-package" 2 "jsymbols" 13751 3
+"unuse-package" 2 "jsymbols" 14014 3
+"shadow" 2 "jsymbols" 14127 3
+"export" 2 "jsymbols" 14271 3
+"unexport" 2 "jsymbols" 15498 3
+"import" 2 "jsymbols" 15648 3
+"do-symbols" 3 "jsymbols" 16060 3
+"do-external-symbols" 3 "jsymbols" 16288 3
+"do-all-symbols" 3 "jsymbols" 16487 3
"elt" 2 "jsequences" 584 3
"length" 2 "jsequences" 968 3
"subseq" 2 "jsequences" 1609 3
@@ -277,111 +291,149 @@
"cdaar" 2 "jsequences" 11555 3
"cdddr" 2 "jsequences" 11625 3
"cddar" 2 "jsequences" 11695 3
-"first" 2 "jsequences" 11765 3
-"nth" 2 "jsequences" 12212 3
-"nthcdr" 2 "jsequences" 12395 3
-"last" 2 "jsequences" 12505 3
-"butlast" 2 "jsequences" 12599 3
-"cons" 2 "jsequences" 12722 3
-"list" 2 "jsequences" 12839 3
-"list*" 2 "jsequences" 12908 3
-"list-length" 2 "jsequences" 13162 3
-"make-list" 2 "jsequences" 13270 3
-"rplaca" 2 "jsequences" 13400 3
-"rplacd" 2 "jsequences" 13577 3
-"memq" 2 "jsequences" 13752 3
-"member" 2 "jsequences" 13865 3
-"assq" 2 "jsequences" 14353 2
-"assoc" 2 "jsequences" 14383 3
-"rassoc" 2 "jsequences" 14693 3
-"pairlis" 2 "jsequences" 14809 3
-"acons" 2 "jsequences" 15061 3
-"append" 2 "jsequences" 15207 3
-"nconc" 2 "jsequences" 15409 3
-"subst" 2 "jsequences" 15581 3
-"flatten" 2 "jsequences" 15691 3
-"push" 3 "jsequences" 15986 3
-"pop" 3 "jsequences" 16101 3
-"pushnew" 3 "jsequences" 16253 3
-"adjoin" 2 "jsequences" 16511 3
-"union" 2 "jsequences" 16642 3
-"subsetp" 2 "jsequences" 16764 3
-"intersection" 2 "jsequences" 17025 3
-"set-difference" 2 "jsequences" 17179 3
-"set-exclusive-or" 2 "jsequences" 17383 3
-"list-insert" 2 "jsequences" 17557 3
-"copy-tree" 2 "jsequences" 17869 3
-"mapc" 2 "jsequences" 18145 3
-"mapcar" 2 "jsequences" 18404 3
-"mapcan" 2 "jsequences" 18704 3
-"array-rank-limit" 4 "jsequences" 20887 2
-"array-dimension-limit" 4 "jsequences" 20962 2
-"vectorp" 2 "jsequences" 21169 3
-"vector" 2 "jsequences" 21408 3
-"make-array" 2 "jsequences" 21524 3
-"svref" 2 "jsequences" 21870 3
-"aref" 2 "jsequences" 22029 3
-"vector-push" 2 "jsequences" 22503 3
-"vector-push-extend" 2 "jsequences" 22893 3
-"arrayp" 2 "jsequences" 23101 3
-"array-total-size" 2 "jsequences" 23232 3
-"fill-pointer" 2 "jsequences" 23311 3
-"array-rank" 2 "jsequences" 23437 3
-"array-dimensions" 2 "jsequences" 23511 3
-"array-dimension" 2 "jsequences" 23608 3
-"bit" 2 "jsequences" 23755 3
-"bit-and" 2 "jsequences" 23945 2
-"bit-ior" 2 "jsequences" 23995 2
-"bit-xor" 2 "jsequences" 24045 2
-"bit-eqv" 2 "jsequences" 24095 2
-"bit-nand" 2 "jsequences" 24146 2
-"bit-nor" 2 "jsequences" 24196 2
-"bit-not" 2 "jsequences" 24247 3
-"digit-char-p" 2 "jsequences" 24799 3
-"alpha-char-p" 2 "jsequences" 24912 3
-"upper-case-p" 2 "jsequences" 25083 3
-"lower-case-p" 2 "jsequences" 25199 3
-"alphanumericp" 2 "jsequences" 25316 3
-"char-upcase" 2 "jsequences" 25535 3
-"char-downcase" 2 "jsequences" 25606 3
-"char" 2 "jsequences" 25668 3
-"schar" 2 "jsequences" 25756 3
-"stringp" 2 "jsequences" 25959 3
-"string-upcase" 2 "jsequences" 26089 3
-"string-downcase" 2 "jsequences" 26222 3
-"nstring-upcase" 2 "jsequences" 26354 3
-"nstring-downcase" 2 "jsequences" 26463 3
-"string=" 2 "jsequences" 26579 3
-"string-equal" 2 "jsequences" 26770 3
-"string" 2 "jsequences" 26956 3
-"string<" 2 "jsequences" 27594 2
-"string<=" 2 "jsequences" 27627 2
-"string>" 2 "jsequences" 27659 2
-"string>=" 2 "jsequences" 27692 2
-"string-left-trim" 2 "jsequences" 27731 2
-"string-right-trim" 2 "jsequences" 27770 3
-"string-trim" 2 "jsequences" 28082 3
-"substringp" 2 "jsequences" 28271 3
-"make-foreign-string" 2 "jsequences" 30560 3
-"sxhash" 2 "jsequences" 32595 3
-"make-hash-table" 2 "jsequences" 33258 3
-"gethash" 2 "jsequences" 33361 3
-"remhash" 2 "jsequences" 33774 3
-"maphash" 2 "jsequences" 33892 3
-"hash-table-p" 2 "jsequences" 33998 3
-"hash-table" 0 "jsequences" 34106 4
-":hash-function" 1 "jsequences" 34714 3
-"queue" 0 "jsequences" 35365 4
-":init" 1 "jsequences" 35434 3
-":enqueue" 1 "jsequences" 35488 3
-":dequeue" 1 "jsequences" 35576 3
-":empty?" 1 "jsequences" 35834 3
-":length" 1 "jsequences" 35903 3
-":trim" 1 "jsequences" 35960 3
-":search" 1 "jsequences" 36074 3
-":delete" 1 "jsequences" 36213 3
-":first" 1 "jsequences" 36376 3
-":last" 1 "jsequences" 36484 3
+"caaddr" 2 "jsequences" 11766 3
+"caaadr" 2 "jsequences" 11842 3
+"caadar" 2 "jsequences" 11918 3
+"caaaar" 2 "jsequences" 11994 3
+"cadadr" 2 "jsequences" 12070 3
+"cadaar" 2 "jsequences" 12146 3
+"cadddr" 2 "jsequences" 12222 3
+"caddar" 2 "jsequences" 12298 3
+"cdaddr" 2 "jsequences" 12374 3
+"cdaadr" 2 "jsequences" 12450 3
+"cdadar" 2 "jsequences" 12526 3
+"cdaaar" 2 "jsequences" 12602 3
+"cddadr" 2 "jsequences" 12678 3
+"cddaar" 2 "jsequences" 12754 3
+"cddddr" 2 "jsequences" 12830 3
+"cdddar" 2 "jsequences" 12906 3
+"first" 2 "jsequences" 12981 3
+"second" 2 "jsequences" 13055 3
+"third" 2 "jsequences" 13129 3
+"fourth" 2 "jsequences" 13204 3
+"fifth" 2 "jsequences" 13278 3
+"sixth" 2 "jsequences" 13352 3
+"seventh" 2 "jsequences" 13428 3
+"eighth" 2 "jsequences" 13503 3
+"ninth" 2 "jsequences" 13577 3
+"tenth" 2 "jsequences" 13651 3
+"nth" 2 "jsequences" 13724 3
+"nthcdr" 2 "jsequences" 13907 3
+"last" 2 "jsequences" 14017 3
+"butlast" 2 "jsequences" 14141 3
+"cons" 2 "jsequences" 14264 3
+"list" 2 "jsequences" 14381 3
+"list*" 2 "jsequences" 14471 3
+"values" 2 "jsequences" 14720 3
+"list-length" 2 "jsequences" 14783 3
+"make-list" 2 "jsequences" 14891 3
+"rplaca" 2 "jsequences" 15021 3
+"rplacd" 2 "jsequences" 15198 3
+"memq" 2 "jsequences" 15373 3
+"member" 2 "jsequences" 15486 3
+"assq" 2 "jsequences" 15974 2
+"assoc" 2 "jsequences" 16004 3
+"assoc-if" 2 "jsequences" 16203 3
+"assoc-if-not" 2 "jsequences" 16377 3
+"rassoc" 2 "jsequences" 16554 3
+"rassoc-if" 2 "jsequences" 16707 3
+"rassoc-if-not" 2 "jsequences" 16839 3
+"pairlis" 2 "jsequences" 16974 3
+"acons" 2 "jsequences" 17226 3
+"append" 2 "jsequences" 17372 3
+"nconc" 2 "jsequences" 17574 3
+"subst" 2 "jsequences" 17746 3
+"flatten" 2 "jsequences" 17856 3
+"push" 3 "jsequences" 18151 3
+"pop" 3 "jsequences" 18266 3
+"pushnew" 3 "jsequences" 18418 3
+"adjoin" 2 "jsequences" 18676 3
+"union" 2 "jsequences" 18807 3
+"subsetp" 2 "jsequences" 18929 3
+"intersection" 2 "jsequences" 19190 3
+"set-difference" 2 "jsequences" 19344 3
+"set-exclusive-or" 2 "jsequences" 19548 3
+"list-insert" 2 "jsequences" 19722 3
+"list-delete" 2 "jsequences" 20036 3
+"copy-tree" 2 "jsequences" 20298 3
+"mapc" 2 "jsequences" 20574 3
+"mapcar" 2 "jsequences" 20833 3
+"mapcan" 2 "jsequences" 21133 3
+"array-rank-limit" 4 "jsequences" 23316 2
+"array-dimension-limit" 4 "jsequences" 23391 2
+"vectorp" 2 "jsequences" 23598 3
+"vector" 2 "jsequences" 23837 3
+"make-array" 2 "jsequences" 23953 3
+"svref" 2 "jsequences" 24299 3
+"aref" 2 "jsequences" 24458 3
+"vector-push" 2 "jsequences" 24932 3
+"vector-push-extend" 2 "jsequences" 25322 3
+"arrayp" 2 "jsequences" 25530 3
+"array-total-size" 2 "jsequences" 25661 3
+"fill-pointer" 2 "jsequences" 25740 3
+"array-rank" 2 "jsequences" 25866 3
+"array-dimensions" 2 "jsequences" 25940 3
+"array-dimension" 2 "jsequences" 26037 3
+"bit" 2 "jsequences" 26184 3
+"bit-and" 2 "jsequences" 26374 2
+"bit-ior" 2 "jsequences" 26424 2
+"bit-xor" 2 "jsequences" 26474 2
+"bit-eqv" 2 "jsequences" 26524 2
+"bit-nand" 2 "jsequences" 26575 2
+"bit-nor" 2 "jsequences" 26625 2
+"bit-not" 2 "jsequences" 26676 3
+"digit-char-p" 2 "jsequences" 27228 3
+"alpha-char-p" 2 "jsequences" 27341 3
+"upper-case-p" 2 "jsequences" 27512 3
+"lower-case-p" 2 "jsequences" 27628 3
+"alphanumericp" 2 "jsequences" 27745 3
+"char-upcase" 2 "jsequences" 27964 3
+"char-downcase" 2 "jsequences" 28035 3
+"char=" 2 "jsequences" 28098 3
+"char/=" 2 "jsequences" 28168 3
+"char>" 2 "jsequences" 28240 3
+"char<" 2 "jsequences" 28313 3
+"char>=" 2 "jsequences" 28387 3
+"char<=" 2 "jsequences" 28462 3
+"char" 2 "jsequences" 28533 3
+"schar" 2 "jsequences" 28621 3
+"setchar" 2 "jsequences" 28824 3
+"stringp" 2 "jsequences" 28928 3
+"string-upcase" 2 "jsequences" 29058 3
+"string-downcase" 2 "jsequences" 29191 3
+"nstring-upcase" 2 "jsequences" 29323 3
+"nstring-downcase" 2 "jsequences" 29432 3
+"string=" 2 "jsequences" 29548 3
+"string-equal" 2 "jsequences" 29739 3
+"string" 2 "jsequences" 29925 3
+"string<" 2 "jsequences" 30563 2
+"string<=" 2 "jsequences" 30674 2
+"string>" 2 "jsequences" 30808 2
+"string>=" 2 "jsequences" 30919 2
+"string-left-trim" 2 "jsequences" 31060 2
+"string-right-trim" 2 "jsequences" 31369 3
+"string-trim" 2 "jsequences" 31672 3
+"substringp" 2 "jsequences" 31861 3
+"make-foreign-string" 2 "jsequences" 34150 3
+"sxhash" 2 "jsequences" 36185 3
+"make-hash-table" 2 "jsequences" 36848 3
+"gethash" 2 "jsequences" 36951 3
+"remhash" 2 "jsequences" 37364 3
+"maphash" 2 "jsequences" 37482 3
+"hash-table-p" 2 "jsequences" 37588 3
+"hash-table" 0 "jsequences" 37696 4
+":hash-function" 1 "jsequences" 38355 3
+"queue" 0 "jsequences" 39006 4
+":init" 1 "jsequences" 39075 3
+":enqueue" 1 "jsequences" 39129 3
+":dequeue" 1 "jsequences" 39217 3
+":empty?" 1 "jsequences" 39475 3
+":length" 1 "jsequences" 39544 3
+":trim" 1 "jsequences" 39601 3
+":search" 1 "jsequences" 39715 3
+":delete" 1 "jsequences" 39854 3
+":first" 1 "jsequences" 40017 3
+":last" 1 "jsequences" 40125 3
"streamp" 2 "jio" 591 3
"input-stream-p" 2 "jio" 741 3
"output-stream-p" 2 "jio" 859 3
@@ -457,216 +509,240 @@
"object-file-p" 2 "jio" 36490 3
"directory" 2 "jio" 36680 3
"dir" 2 "jio" 36786 3
-"identity" 2 "jevaluation" 1928 3
-"eval" 2 "jevaluation" 2435 3
-"apply" 2 "jevaluation" 2706 3
-"funcall" 2 "jevaluation" 3348 3
-"quote" 6 "jevaluation" 3543 3
-"function" 6 "jevaluation" 3608 3
-"evalhook" 2 "jevaluation" 3743 3
-"eval-dynamic" 2 "jevaluation" 3891 3
-"macroexpand" 2 "jevaluation" 3989 3
-"eval-when" 6 "jevaluation" 4251 3
-"the" 6 "jevaluation" 5475 3
-"declare" 6 "jevaluation" 5674 3
-"proclaim" 2 "jevaluation" 6951 3
-"warn" 2 "jevaluation" 7259 3
-"error" 2 "jevaluation" 7420 3
-"lisp::install-error-handler" 2 "jevaluation" 8487 3
-"*prompt-string*" 5 "jevaluation" 12488 2
-"*program-name*" 5 "jevaluation" 12571 2
-"eustop" 2 "jevaluation" 12715 3
-"eussig" 2 "jevaluation" 12786 3
-"sigint-handler" 2 "jevaluation" 13010 3
-"euserror" 2 "jevaluation" 13176 3
-"reset" 2 "jevaluation" 13344 3
-"exit" 2 "jevaluation" 13453 3
-"*top-selector*" 5 "jevaluation" 13627 2
-"h" 2 "jevaluation" 13753 3
-"!" 2 "jevaluation" 13881 3
-"new-history" 2 "jevaluation" 14862 3
-"compile-file" 2 "jevaluation" 22385 3
-"compile" 2 "jevaluation" 23183 3
-"compile-file-if-src-newer" 2 "jevaluation" 23539 3
-"compiler:*optimize*" 5 "jevaluation" 23840 2
-"compiler:*verbose*" 5 "jevaluation" 23927 2
-"compiler:*safety*" 5 "jevaluation" 24111 2
-"load" 2 "jevaluation" 24261 3
-"load-files" 2 "jevaluation" 28182 3
-"*modules*" 5 "jevaluation" 28297 2
-"provide" 2 "jevaluation" 28401 3
-"require" 2 "jevaluation" 28818 3
-"system:binload" 2 "jevaluation" 30060 3
-"system::txtload" 2 "jevaluation" 30283 2
-"describe" 2 "jevaluation" 30386 3
-"describe-list" 2 "jevaluation" 30533 3
-"inspect" 3 "jevaluation" 30673 3
-"more" 2 "jevaluation" 31010 3
-"break" 2 "jevaluation" 31383 3
-"help" 2 "jevaluation" 31680 3
-"apropos" 2 "jevaluation" 31971 3
-"apropos-list" 2 "jevaluation" 32382 3
-"constants" 2 "jevaluation" 32527 3
-"variables" 2 "jevaluation" 32702 3
-"functions" 2 "jevaluation" 32895 3
-"btrace" 2 "jevaluation" 33082 3
-"step-hook" 2 "jevaluation" 33188 2
-"step" 2 "jevaluation" 33215 3
-"trace" 2 "jevaluation" 33354 3
-"untrace" 2 "jevaluation" 33543 3
-"timing" 3 "jevaluation" 33614 3
-"time" 3 "jevaluation" 33759 3
-"sys:list-all-catchers" 2 "jevaluation" 33874 3
-"sys:list-all-instances" 2 "jevaluation" 33955 3
-"sys:list-all-bindings" 2 "jevaluation" 34344 3
-"sys:list-all-special-bindings" 2 "jevaluation" 34494 3
-"dump-object" 2 "jevaluation" 35295 2
-"dump-structure" 2 "jevaluation" 35343 3
-"dump-loadable-structure" 2 "jevaluation" 35498 3
-"sys:save" 2 "jevaluation" 36560 3
-"lisp-implementation-type" 2 "jevaluation" 39964 3
-"lisp-implementation-version" 2 "jevaluation" 40036 3
+"identity" 2 "jevaluation" 118 3
+"eval" 2 "jevaluation" 625 3
+"apply" 2 "jevaluation" 896 3
+"funcall" 2 "jevaluation" 1538 3
+"quote" 6 "jevaluation" 1733 3
+"function" 6 "jevaluation" 1798 3
+"evalhook" 2 "jevaluation" 1933 3
+"eval-dynamic" 2 "jevaluation" 2081 3
+"macroexpand" 2 "jevaluation" 2222 3
+"eval-when" 6 "jevaluation" 2484 3
+"the" 6 "jevaluation" 3708 3
+"declare" 6 "jevaluation" 3907 3
+"proclaim" 2 "jevaluation" 5184 3
+"warn" 2 "jevaluation" 5492 3
+"error" 2 "jevaluation" 5653 3
+"error" 0 "jevaluation" 6656 4
+"argument-error" 0 "jevaluation" 6755 4
+"program-error" 0 "jevaluation" 6792 4
+"name-error" 0 "jevaluation" 6826 4
+"type-error" 0 "jevaluation" 6860 4
+"value-error" 0 "jevaluation" 6895 4
+"index-error" 0 "jevaluation" 6930 4
+"io-error" 0 "jevaluation" 6962 4
+"assertion-error" 0 "jevaluation" 7001 4
+"lisp::print-error-message" 2 "jevaluation" 7050 3
+"interruption" 0 "jevaluation" 7177 4
+"unix::signal-received" 0 "jevaluation" 7227 4
+"unix::sigint-received" 0 "jevaluation" 7276 4
+"unix::sigcont-received" 0 "jevaluation" 7338 4
+"unix:install-signal-handler" 3 "jevaluation" 7406 3
+"eussig" 2 "jevaluation" 7824 3
+"*signal-handlers*" 5 "jevaluation" 8069 2
+"*error-handler*" 5 "jevaluation" 8178 2
+"*prompt-string*" 5 "jevaluation" 12318 2
+"*program-name*" 5 "jevaluation" 12401 2
+"eustop" 2 "jevaluation" 12545 3
+"sigint-handler" 2 "jevaluation" 12624 3
+"euserror" 2 "jevaluation" 12795 3
+"reset" 2 "jevaluation" 12960 3
+"exit" 2 "jevaluation" 13092 3
+"*top-selector*" 5 "jevaluation" 13266 2
+"h" 2 "jevaluation" 13392 3
+"!" 2 "jevaluation" 13520 3
+"new-history" 2 "jevaluation" 14501 3
+"compile-file" 2 "jevaluation" 24018 3
+"compile" 2 "jevaluation" 24816 3
+"compile-method" 2 "jevaluation" 25169 3
+"compile-file-if-src-newer" 2 "jevaluation" 25624 3
+"compiler:*optimize*" 5 "jevaluation" 25925 2
+"compiler:*safety*" 5 "jevaluation" 26011 2
+"compiler:*verbose*" 5 "jevaluation" 26080 2
+"compiler:*type-check-declare*" 5 "jevaluation" 26276 2
+"compiler::compiler-implementation-version" 2 "jevaluation" 26476 3
+"load" 2 "jevaluation" 26693 3
+"load-files" 2 "jevaluation" 30614 3
+"*modules*" 5 "jevaluation" 30729 2
+"provide" 2 "jevaluation" 30833 3
+"require" 2 "jevaluation" 31250 3
+"system:binload" 2 "jevaluation" 32492 3
+"system::txtload" 2 "jevaluation" 32715 2
+"describe" 2 "jevaluation" 32818 3
+"describe-list" 2 "jevaluation" 32965 3
+"inspect" 3 "jevaluation" 33105 3
+"more" 2 "jevaluation" 33442 3
+"break" 2 "jevaluation" 33815 3
+"help" 2 "jevaluation" 34112 3
+"apropos" 2 "jevaluation" 34403 3
+"apropos-list" 2 "jevaluation" 34814 3
+"constants" 2 "jevaluation" 34959 3
+"variables" 2 "jevaluation" 35134 3
+"functions" 2 "jevaluation" 35327 3
+"btrace" 2 "jevaluation" 35514 3
+"step-hook" 2 "jevaluation" 35620 2
+"step" 2 "jevaluation" 35647 3
+"trace" 2 "jevaluation" 35786 3
+"untrace" 2 "jevaluation" 35975 3
+"timing" 3 "jevaluation" 36046 3
+"time" 3 "jevaluation" 36191 3
+"lisp::print-callstack" 2 "jevaluation" 36306 3
+"sys:list-callstack" 2 "jevaluation" 36547 3
+"sys:list-all-catchers" 2 "jevaluation" 36754 3
+"sys:list-all-blocks" 2 "jevaluation" 36832 3
+"sys:list-all-tags" 2 "jevaluation" 36908 3
+"sys:list-all-instances" 2 "jevaluation" 36991 3
+"sys:list-all-bindings" 2 "jevaluation" 37380 3
+"sys:list-all-special-bindings" 2 "jevaluation" 37727 3
+"sys:list-all-function-bindings" 2 "jevaluation" 37886 3
+"dump-object" 2 "jevaluation" 38892 2
+"dump-structure" 2 "jevaluation" 38940 3
+"dump-loadable-structure" 2 "jevaluation" 39095 3
+"sys:save" 2 "jevaluation" 40157 3
+"lisp-implementation-type" 2 "jevaluation" 43561 3
+"lisp-implementation-version" 2 "jevaluation" 43633 3
"sys:gc" 2 "jsysfunc" 6326 3
-"sys:*gc-hook*" 5 "jsysfunc" 6522 2
-"sys:gctime" 2 "jsysfunc" 6638 3
-"sys:alloc" 2 "jsysfunc" 6943 3
-"sys:newstack" 2 "jsysfunc" 7099 3
-"sys:*gc-merge*" 5 "jsysfunc" 7231 2
-"sys:*gc-margin*" 5 "jsysfunc" 7810 2
-"sys:reclaim" 2 "jsysfunc" 8209 3
-"sys:reclaim-tree" 2 "jsysfunc" 8440 3
-"sys::bktrace" 2 "jsysfunc" 8575 3
-"sys:memory-report" 2 "jsysfunc" 8704 3
-"sys:room" 2 "jsysfunc" 8857 3
-"sys:address" 2 "jsysfunc" 8965 3
-"sys:peek" 2 "jsysfunc" 9151 3
-"sys:poke" 2 "jsysfunc" 10343 3
-"sys:list-all-chunks" 2 "jsysfunc" 10844 3
-"sys:object-size" 2 "jsysfunc" 10991 3
-"unix:ptimes" 2 "jsysfunc" 12500 3
-"unix:runtime" 2 "jsysfunc" 12793 3
-"unix:localtime" 2 "jsysfunc" 12926 3
-"unix:asctime" 2 "jsysfunc" 13391 3
-"unix:getpid" 2 "jsysfunc" 13683 3
-"unix:getppid" 2 "jsysfunc" 13779 3
-"unix:getpgrp" 2 "jsysfunc" 13853 3
-"unix:setpgrp" 2 "jsysfunc" 13930 3
-"unix:getuid" 2 "jsysfunc" 14015 3
-"unix:geteuid" 2 "jsysfunc" 14092 3
-"unix:getgid" 2 "jsysfunc" 14183 3
-"unix:getegid" 2 "jsysfunc" 14272 3
-"unix:setuid" 2 "jsysfunc" 14375 3
-"unix:setgid" 2 "jsysfunc" 14479 3
-"unix:fork" 2 "jsysfunc" 14594 3
-"unix:vfork" 2 "jsysfunc" 14917 3
-"unix:exec" 2 "jsysfunc" 15077 3
-"unix:wait" 2 "jsysfunc" 15163 3
-"unix::exit" 2 "jsysfunc" 15260 3
-"sys:*exit-hook*" 5 "jsysfunc" 15403 2
-"unix:getpriority" 2 "jsysfunc" 15507 3
-"unix:setpriority" 2 "jsysfunc" 15720 3
-"unix:getrusage" 2 "jsysfunc" 16454 3
-"unix:system" 2 "jsysfunc" 17606 3
-"unix:getenv" 2 "jsysfunc" 17787 3
-"unix:putenv" 2 "jsysfunc" 17869 3
-"unix:sleep" 2 "jsysfunc" 18067 3
-"unix:usleep" 2 "jsysfunc" 18167 3
-"unix:uread" 2 "jsysfunc" 18503 3
-"unix:write" 2 "jsysfunc" 19170 3
-"unix:fcntl" 2 "jsysfunc" 19394 2
-"unix:ioctl" 2 "jsysfunc" 19441 2
-"unix:ioctl_" 2 "jsysfunc" 19488 2
-"unix:ioctl_r" 2 "jsysfunc" 19539 2
-"unix:ioctl_w" 2 "jsysfunc" 19613 2
-"unix:ioctl_wr" 2 "jsysfunc" 19688 2
-"unix:uclose" 2 "jsysfunc" 19761 3
-"unix:dup" 2 "jsysfunc" 19851 3
-"unix:pipe" 2 "jsysfunc" 19966 3
-"unix:lseek" 2 "jsysfunc" 20075 3
-"unix:link" 2 "jsysfunc" 20241 3
-"unix:unlink" 2 "jsysfunc" 20306 3
-"unix:mknod" 2 "jsysfunc" 20491 3
-"unix:mkdir" 2 "jsysfunc" 20669 3
-"unix:access" 2 "jsysfunc" 20861 3
-"unix:stat" 2 "jsysfunc" 20955 3
-"unix:chdir" 2 "jsysfunc" 21510 3
-"unix:getwd" 2 "jsysfunc" 21600 3
-"unix:chmod" 2 "jsysfunc" 21667 3
-"unix:chown" 2 "jsysfunc" 21771 3
-"unix:isatty" 2 "jsysfunc" 21867 3
-"unix:msgget" 2 "jsysfunc" 22047 3
-"unix:msgsnd" 2 "jsysfunc" 22179 2
-"unix:msgrcv" 2 "jsysfunc" 22239 2
-"unix:socket" 2 "jsysfunc" 22294 3
-"unix:bind" 2 "jsysfunc" 22587 3
-"unix:connect" 2 "jsysfunc" 22810 3
-"unix:listen" 2 "jsysfunc" 22929 3
-"unix:accept" 2 "jsysfunc" 23123 3
-"unix:recvfrom" 2 "jsysfunc" 23293 3
-"unix:sendto" 2 "jsysfunc" 23863 3
-"unix:getservbyname" 2 "jsysfunc" 24370 3
-"unix:gethostbyname" 2 "jsysfunc" 24544 3
-"unix:syserrlist" 2 "jsysfunc" 24692 3
-"unix:signal" 2 "jsysfunc" 24887 3
-"unix:kill" 2 "jsysfunc" 25518 3
-"unix:pause" 2 "jsysfunc" 25628 3
-"unix:alarm" 2 "jsysfunc" 25740 3
-"unix:ualarm" 2 "jsysfunc" 25941 3
-"unix:getitimer" 2 "jsysfunc" 26169 3
-"unix:setitimer" 2 "jsysfunc" 26413 3
-"unix:select" 2 "jsysfunc" 26826 3
-"unix:select-read-fd" 2 "jsysfunc" 27950 3
-"unix:thr-self" 2 "jsysfunc" 28663 3
-"unix:thr-getprio" 2 "jsysfunc" 28761 3
-"unix:thr-setprio" 2 "jsysfunc" 28868 3
-"unix:thr-getconcurrency" 2 "jsysfunc" 29368 3
-"unix:thr-setconcurrency" 2 "jsysfunc" 29499 3
-"unix:thr-create" 2 "jsysfunc" 30264 3
-"unix:malloc" 2 "jsysfunc" 30734 3
-"unix:free" 2 "jsysfunc" 30829 3
-"unix:valloc" 2 "jsysfunc" 30938 2
-"unix:mmap" 2 "jsysfunc" 30968 2
-"unix:munmap" 2 "jsysfunc" 31038 2
-"unix:vadvise" 2 "jsysfunc" 31078 2
-"unix:tiocgetp" 2 "jsysfunc" 32060 3
-"unix:tiocsetp" 2 "jsysfunc" 32144 3
-"unix:tiocsetn" 2 "jsysfunc" 32222 2
-"unix:tiocgetd" 2 "jsysfunc" 32275 2
-"unix:tiocflush" 2 "jsysfunc" 32330 3
-"unix:tiocgpgrp" 2 "jsysfunc" 32407 3
-"unix:tiocspgrp" 2 "jsysfunc" 32494 3
-"unix:tiocoutq" 2 "jsysfunc" 32585 2
-"unix:fionread" 2 "jsysfunc" 32626 2
-"unix:tiocsetc" 2 "jsysfunc" 32667 2
-"unix:tioclbis" 2 "jsysfunc" 32704 2
-"unix:tioclbic" 2 "jsysfunc" 32741 2
-"unix:tioclset" 2 "jsysfunc" 32778 2
-"unix:tioclget" 2 "jsysfunc" 32815 2
-"unix:tcseta" 2 "jsysfunc" 32851 3
-"unix:tcsets" 2 "jsysfunc" 32950 3
-"unix:tcsetsw" 2 "jsysfunc" 33041 3
-"unix:tcsetsf" 2 "jsysfunc" 33195 3
-"unix:tiocsetc" 2 "jsysfunc" 33411 2
-"unix:tcsetaf" 2 "jsysfunc" 33450 2
-"unix:tcsetaw" 2 "jsysfunc" 33489 2
-"unix:tcgeta" 2 "jsysfunc" 33527 2
-"unix:tcgets" 2 "jsysfunc" 33565 2
-"unix:tcgetattr" 2 "jsysfunc" 33606 2
-"unix:tcsetattr" 2 "jsysfunc" 33647 2
-"dbm-open" 2 "jsysfunc" 34307 3
-"dbm-store" 2 "jsysfunc" 35418 3
-"dbm-fetch" 2 "jsysfunc" 35732 3
-"cd" 2 "jsysfunc" 37511 3
-"ez" 2 "jsysfunc" 37613 3
-"piped-fork" 2 "jsysfunc" 37749 3
-"rusage" 2 "jsysfunc" 37900 3
-"load-foreign" 3 "jsysfunc" 45704 3
-"defforeign" 3 "jsysfunc" 48935 3
-"defun-c-callable" 3 "jsysfunc" 51236 3
-"pod-address" 2 "jsysfunc" 52511 3
-"array-entity" 3 "jsysfunc" 52838 3
-"float2double" 2 "jsysfunc" 53142 3
-"double2float" 2 "jsysfunc" 53380 3
+"sys:gctime" 2 "jsysfunc" 6520 3
+"sys:alloc" 2 "jsysfunc" 6837 3
+"sys:newstack" 2 "jsysfunc" 6993 3
+"sys:*gc-debug*" 5 "jsysfunc" 7125 2
+"sys:*gc-merge*" 5 "jsysfunc" 7259 2
+"sys:*gc-margin*" 5 "jsysfunc" 7838 2
+"sys:reclaim" 2 "jsysfunc" 8237 3
+"sys:reclaim-tree" 2 "jsysfunc" 8468 3
+"sys::bktrace" 2 "jsysfunc" 8603 3
+"sys:memory-report" 2 "jsysfunc" 8732 3
+"sys:room" 2 "jsysfunc" 8885 3
+"sys:address" 2 "jsysfunc" 8993 3
+"sys:peek" 2 "jsysfunc" 9179 3
+"sys:poke" 2 "jsysfunc" 10371 3
+"sys:list-all-chunks" 2 "jsysfunc" 10872 3
+"sys:object-size" 2 "jsysfunc" 11019 3
+"unix:ptimes" 2 "jsysfunc" 12528 3
+"unix:runtime" 2 "jsysfunc" 12821 3
+"unix:localtime" 2 "jsysfunc" 12954 3
+"unix:asctime" 2 "jsysfunc" 13419 3
+"unix:getpid" 2 "jsysfunc" 13711 3
+"unix:getppid" 2 "jsysfunc" 13807 3
+"unix:getpgrp" 2 "jsysfunc" 13881 3
+"unix:setpgrp" 2 "jsysfunc" 13958 3
+"unix:getuid" 2 "jsysfunc" 14043 3
+"unix:geteuid" 2 "jsysfunc" 14120 3
+"unix:getgid" 2 "jsysfunc" 14211 3
+"unix:getegid" 2 "jsysfunc" 14300 3
+"unix:setuid" 2 "jsysfunc" 14403 3
+"unix:setgid" 2 "jsysfunc" 14507 3
+"unix:fork" 2 "jsysfunc" 14622 3
+"unix:vfork" 2 "jsysfunc" 14945 3
+"unix:exec" 2 "jsysfunc" 15105 3
+"unix:wait" 2 "jsysfunc" 15191 3
+"unix::exit" 2 "jsysfunc" 15288 3
+"sys:*exit-hook*" 5 "jsysfunc" 15431 2
+"unix:getpriority" 2 "jsysfunc" 15535 3
+"unix:setpriority" 2 "jsysfunc" 15748 3
+"unix:getrusage" 2 "jsysfunc" 16482 3
+"unix:system" 2 "jsysfunc" 17634 3
+"unix:getenv" 2 "jsysfunc" 17815 3
+"unix:putenv" 2 "jsysfunc" 17897 3
+"unix:sleep" 2 "jsysfunc" 18095 3
+"unix:usleep" 2 "jsysfunc" 18195 3
+"unix:uread" 2 "jsysfunc" 18531 3
+"unix:write" 2 "jsysfunc" 19198 3
+"unix:fcntl" 2 "jsysfunc" 19422 2
+"unix:ioctl" 2 "jsysfunc" 19469 2
+"unix:ioctl_" 2 "jsysfunc" 19516 2
+"unix:ioctl_r" 2 "jsysfunc" 19567 2
+"unix:ioctl_w" 2 "jsysfunc" 19641 2
+"unix:ioctl_wr" 2 "jsysfunc" 19716 2
+"unix:uclose" 2 "jsysfunc" 19789 3
+"unix:dup" 2 "jsysfunc" 19879 3
+"unix:pipe" 2 "jsysfunc" 19994 3
+"unix:lseek" 2 "jsysfunc" 20103 3
+"unix:link" 2 "jsysfunc" 20269 3
+"unix:unlink" 2 "jsysfunc" 20334 3
+"unix:mknod" 2 "jsysfunc" 20519 3
+"unix:mkdir" 2 "jsysfunc" 20697 3
+"unix:access" 2 "jsysfunc" 20889 3
+"unix:stat" 2 "jsysfunc" 20983 3
+"unix:chdir" 2 "jsysfunc" 21538 3
+"unix:getwd" 2 "jsysfunc" 21628 3
+"unix:chmod" 2 "jsysfunc" 21695 3
+"unix:chown" 2 "jsysfunc" 21799 3
+"unix:isatty" 2 "jsysfunc" 21895 3
+"unix:msgget" 2 "jsysfunc" 22075 3
+"unix:msgsnd" 2 "jsysfunc" 22207 2
+"unix:msgrcv" 2 "jsysfunc" 22267 2
+"unix:socket" 2 "jsysfunc" 22322 3
+"unix:bind" 2 "jsysfunc" 22615 3
+"unix:connect" 2 "jsysfunc" 22838 3
+"unix:listen" 2 "jsysfunc" 22957 3
+"unix:accept" 2 "jsysfunc" 23151 3
+"unix:recvfrom" 2 "jsysfunc" 23321 3
+"unix:sendto" 2 "jsysfunc" 23891 3
+"unix:getservbyname" 2 "jsysfunc" 24398 3
+"unix:gethostbyname" 2 "jsysfunc" 24572 3
+"unix:syserrlist" 2 "jsysfunc" 24720 3
+"unix:signal" 2 "jsysfunc" 24915 3
+"unix:kill" 2 "jsysfunc" 25667 3
+"unix:pause" 2 "jsysfunc" 25777 3
+"unix:alarm" 2 "jsysfunc" 25889 3
+"unix:ualarm" 2 "jsysfunc" 26220 3
+"unix:getitimer" 2 "jsysfunc" 26508 3
+"unix:setitimer" 2 "jsysfunc" 26752 3
+"unix:select" 2 "jsysfunc" 27165 3
+"unix:select-read-fd" 2 "jsysfunc" 28289 3
+"unix:thr-self" 2 "jsysfunc" 29002 3
+"unix:thr-getprio" 2 "jsysfunc" 29100 3
+"unix:thr-setprio" 2 "jsysfunc" 29207 3
+"unix:thr-getconcurrency" 2 "jsysfunc" 29707 3
+"unix:thr-setconcurrency" 2 "jsysfunc" 29838 3
+"unix:thr-create" 2 "jsysfunc" 30603 3
+"unix:malloc" 2 "jsysfunc" 31073 3
+"unix:free" 2 "jsysfunc" 31168 3
+"unix:valloc" 2 "jsysfunc" 31277 2
+"unix:mmap" 2 "jsysfunc" 31307 2
+"unix:munmap" 2 "jsysfunc" 31377 2
+"unix:vadvise" 2 "jsysfunc" 31417 2
+"unix:tiocgetp" 2 "jsysfunc" 32399 3
+"unix:tiocsetp" 2 "jsysfunc" 32483 3
+"unix:tiocsetn" 2 "jsysfunc" 32561 2
+"unix:tiocgetd" 2 "jsysfunc" 32614 2
+"unix:tiocflush" 2 "jsysfunc" 32669 3
+"unix:tiocgpgrp" 2 "jsysfunc" 32746 3
+"unix:tiocspgrp" 2 "jsysfunc" 32833 3
+"unix:tiocoutq" 2 "jsysfunc" 32924 2
+"unix:fionread" 2 "jsysfunc" 32965 2
+"unix:tiocsetc" 2 "jsysfunc" 33006 2
+"unix:tioclbis" 2 "jsysfunc" 33043 2
+"unix:tioclbic" 2 "jsysfunc" 33080 2
+"unix:tioclset" 2 "jsysfunc" 33117 2
+"unix:tioclget" 2 "jsysfunc" 33154 2
+"unix:tcseta" 2 "jsysfunc" 33190 3
+"unix:tcsets" 2 "jsysfunc" 33289 3
+"unix:tcsetsw" 2 "jsysfunc" 33380 3
+"unix:tcsetsf" 2 "jsysfunc" 33534 3
+"unix:tiocsetc" 2 "jsysfunc" 33750 2
+"unix:tcsetaf" 2 "jsysfunc" 33789 2
+"unix:tcsetaw" 2 "jsysfunc" 33828 2
+"unix:tcgeta" 2 "jsysfunc" 33866 2
+"unix:tcgets" 2 "jsysfunc" 33904 2
+"unix:tcgetattr" 2 "jsysfunc" 33945 2
+"unix:tcsetattr" 2 "jsysfunc" 33986 2
+"dbm-open" 2 "jsysfunc" 34646 3
+"dbm-store" 2 "jsysfunc" 35757 3
+"dbm-fetch" 2 "jsysfunc" 36071 3
+"cd" 2 "jsysfunc" 37850 3
+"ez" 2 "jsysfunc" 37952 3
+"piped-fork" 2 "jsysfunc" 38088 3
+"rusage" 2 "jsysfunc" 38239 3
+"load-foreign" 3 "jsysfunc" 46043 3
+"defforeign" 3 "jsysfunc" 49274 3
+"defun-c-callable" 3 "jsysfunc" 51575 3
+"pod-address" 2 "jsysfunc" 52850 3
+"array-entity" 3 "jsysfunc" 53177 3
+"float2double" 2 "jsysfunc" 53481 3
+"double2float" 2 "jsysfunc" 53719 3
"connect-vxw" 2 "jvxw" 3159 3
"vxw" 2 "jvxw" 3910 3
"defvxw" 3 "jvxw" 5715 3
@@ -1202,6 +1278,141 @@
":rgb" 1 "jxwindow" 37928 3
":init" 1 "jxwindow" 38004 3
"find-visual" 2 "jxwindow" 38092 3
+"event" 5 "jxtoolkit" 4967 2
+"next-event" 2 "jxtoolkit" 5070 3
+"event-type" 2 "jxtoolkit" 5252 3
+"event-window" 2 "jxtoolkit" 6295 3
+"event-x" 2 "jxtoolkit" 6387 3
+"event-y" 2 "jxtoolkit" 6591 3
+"event-width" 2 "jxtoolkit" 6799 3
+"event-height" 2 "jxtoolkit" 6946 3
+"event-state" 2 "jxtoolkit" 7093 3
+"display-events" 2 "jxtoolkit" 7473 3
+"window-main-loop" 3 "jxtoolkit" 7671 3
+"window-main-thread" 2 "jxtoolkit" 8221 3
+"panel" 0 "jxtoolkit" 8665 4
+":create" 1 "jxtoolkit" 9214 3
+":items" 1 "jxtoolkit" 9753 3
+":locate-item" 1 "jxtoolkit" 9839 3
+":create-item" 1 "jxtoolkit" 10734 3
+":delete-items" 1 "jxtoolkit" 11388 3
+":create-menubar" 1 "jxtoolkit" 11486 3
+":quit" 1 "jxtoolkit" 11992 3
+":keypress" 1 "jxtoolkit" 12129 3
+":keyrelease" 1 "jxtoolkit" 12180 3
+":buttonpress" 1 "jxtoolkit" 12232 3
+":buttonrelease" 1 "jxtoolkit" 12286 3
+":motionnotify" 1 "jxtoolkit" 12339 3
+":enternotify" 1 "jxtoolkit" 12391 3
+":leavenotify" 1 "jxtoolkit" 12443 3
+"menu-panel" 0 "jxtoolkit" 12604 4
+":create" 1 "jxtoolkit" 13711 3
+":add-item" 1 "jxtoolkit" 14040 3
+"menubar-panel" 0 "jxtoolkit" 14680 4
+"panel-item" 0 "jxtoolkit" 18825 4
+":notify" 1 "jxtoolkit" 19158 3
+":create" 1 "jxtoolkit" 20317 3
+"button-item" 0 "jxtoolkit" 20675 4
+":draw-label" 1 "jxtoolkit" 21037 3
+":create" 1 "jxtoolkit" 21181 3
+":buttonpress" 1 "jxtoolkit" 21891 3
+":buttonrelease" 1 "jxtoolkit" 21996 3
+"menu-button-item" 0 "jxtoolkit" 22087 4
+":create" 1 "jxtoolkit" 22681 3
+":buttonpress" 1 "jxtoolkit" 22930 3
+":buttonrelease" 1 "jxtoolkit" 23082 3
+"bitmap-button-item" 0 "jxtoolkit" 23231 4
+":create" 1 "jxtoolkit" 23662 3
+":draw-label" 1 "jxtoolkit" 23947 3
+":create-bitmap-from-file" 1 "jxtoolkit" 24088 3
+"choice-item" 0 "jxtoolkit" 24247 4
+":create" 1 "jxtoolkit" 24656 3
+":value" 1 "jxtoolkit" 25189 3
+":draw-active-button" 1 "jxtoolkit" 25620 3
+":buttonpress" 1 "jxtoolkit" 25755 3
+":buttonrelease" 1 "jxtoolkit" 26025 3
+"slider-item" 0 "jxtoolkit" 26289 4
+":create" 1 "jxtoolkit" 26940 3
+":value" 1 "jxtoolkit" 27516 3
+"joystick-item" 0 "jxtoolkit" 27921 4
+":create" 1 "jxtoolkit" 28426 3
+":value" 1 "jxtoolkit" 29193 3
+"text-item" 0 "jxtoolkit" 31008 4
+":create" 1 "jxtoolkit" 32039 3
+":getstring" 1 "jxtoolkit" 32390 3
+"canvas" 0 "jxtoolkit" 32791 4
+"textwindow" 0 "jxtoolkit" 34085 4
+":init" 1 "jxtoolkit" 35039 3
+":create" 1 "jxtoolkit" 35142 3
+":cursor" 1 "jxtoolkit" 35634 3
+":clear" 1 "jxtoolkit" 36160 3
+":clear-eol" 1 "jxtoolkit" 36229 3
+":clear-lines" 1 "jxtoolkit" 36434 3
+":clear-eos" 1 "jxtoolkit" 36547 3
+":win-row-max" 1 "jxtoolkit" 36708 3
+":win-col-max" 1 "jxtoolkit" 36794 3
+":xy" 1 "jxtoolkit" 36871 3
+":goto" 1 "jxtoolkit" 37019 3
+":goback" 1 "jxtoolkit" 37147 3
+":advance" 1 "jxtoolkit" 37228 3
+":scroll" 1 "jxtoolkit" 37317 3
+":horizontal-scroll" 1 "jxtoolkit" 37444 3
+":newline" 1 "jxtoolkit" 37555 3
+":putch" 1 "jxtoolkit" 37632 3
+":putstring" 1 "jxtoolkit" 37865 3
+":event-row" 1 "jxtoolkit" 38014 3
+":event-col" 1 "jxtoolkit" 38048 3
+":keypress" 1 "jxtoolkit" 38440 3
+"textwindowstream" 0 "jxtoolkit" 38736 4
+":flush" 1 "jxtoolkit" 39106 3
+"make-text-window-stream" 2 "jxtoolkit" 39361 3
+"buffertextwindow" 0 "jxtoolkit" 39487 4
+":line" 1 "jxtoolkit" 40148 3
+":nlines" 1 "jxtoolkit" 40234 3
+":all-lines" 1 "jxtoolkit" 40298 3
+":refresh-line" 1 "jxtoolkit" 40389 3
+":refresh" 1 "jxtoolkit" 40525 3
+":insert-string" 1 "jxtoolkit" 40641 3
+":insert" 1 "jxtoolkit" 40725 3
+":delete" 1 "jxtoolkit" 40799 3
+"expand-tab" 2 "jxtoolkit" 40966 3
+"scrolltextwindow" 0 "jxtoolkit" 41221 4
+":create" 1 "jxtoolkit" 41845 3
+":locate" 1 "jxtoolkit" 42370 3
+":display-selection" 1 "jxtoolkit" 42503 3
+":selection" 1 "jxtoolkit" 42669 3
+":read-file" 1 "jxtoolkit" 42744 3
+":display-string" 1 "jxtoolkit" 42969 3
+":scroll" 1 "jxtoolkit" 43221 3
+":horizontal-scroll" 1 "jxtoolkit" 43303 3
+":buttonrelease" 1 "jxtoolkit" 43583 3
+":resize" 1 "jxtoolkit" 43844 3
+"sys:make-thread" 2 "jmthread" 16176 3
+"sys:*threads*" 5 "jmthread" 16911 2
+"sys::free-threads" 2 "jmthread" 17036 3
+"sys:thread" 2 "jmthread" 17424 3
+"sys:thread-no-wait" 2 "jmthread" 18266 3
+"sys:wait-thread" 2 "jmthread" 18506 3
+"sys:plist" 3 "jmthread" 18951 3
+"sys:make-mutex-lock" 2 "jmthread" 19780 3
+"sys:mutex-lock" 2 "jmthread" 19927 3
+"sys:mutex-unlock" 2 "jmthread" 20157 3
+"sys:mutex" 3 "jmthread" 20315 3
+"sys:make-cond" 2 "jmthread" 21116 3
+"sys:cond-wait" 2 "jmthread" 21335 3
+"sys:cond-signal" 2 "jmthread" 21610 3
+"sys:make-semaphore" 2 "jmthread" 21720 3
+"sys:sema-post" 2 "jmthread" 21858 3
+"sys:sema-wait" 2 "jmthread" 21922 3
+"sys:barrier-synch" 0 "jmthread" 22003 4
+":init" 1 "jmthread" 23023 3
+":add" 1 "jmthread" 23172 3
+":remove" 1 "jmthread" 23275 3
+":wait" 1 "jmthread" 23376 3
+"sys:synch-memory-port" 0 "jmthread" 23518 4
+":read" 1 "jmthread" 23835 3
+":write" 1 "jmthread" 24025 3
+":init" 1 "jmthread" 24336 3
"make-equilevel-lut" 2 "jimage" 654 3
"look-up" 2 "jimage" 984 3
"look-up2" 2 "jimage" 1395 3
diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex
index 4472a3a97..6ea8d81a6 100644
--- a/doc/jlatex/jcontrols.tex
+++ b/doc/jlatex/jcontrols.tex
@@ -94,6 +94,8 @@ \subsection{ローカル関数}
{\bf flet}で定義されたローカル関数は、その他の関数を参照または再帰できないが、
{\bf labels}は相互の参照を許可する。}
+\specialdesc{macrolet}{ (\{name lambda-list . body)\}*) \{form\}*}{
+ローカルマクロを定義する。}
\end{refdesc}
\subsection{ブロックとExit}
@@ -272,4 +274,109 @@ \subsection{述語}
\end{refdesc}
+\subsection{コンディション}
+
+コンディションシステムを用いることによって情報をプログラムの上層に伝達し、正しい対応を促すことができる。
+コンディションは{\em signals}関数によってレイズされ、予め登録されたハンドラーによって処理される。
+グローバルなハンドラーは{\em install-handler}によって登録され、そしてローカルなハンドラーは{\em handler-bind} (resumption semantics)、あるいは{\em handler-case} (termination semantics)によって登録される。
+
+\begin{verbatim}
+(defcondition foo)
+(install-handler foo #'(lambda (c) 2))
+
+(list 1 (signals foo) 3)
+--> (1 2 3)
+
+(handler-bind ((foo #'(lambda (c) 20)))
+ (list 1 (signals foo) 3))
+--> (1 20 3)
+
+(handler-case (list 1 (signals foo) 3)
+ (foo () 200))
+--> 200
+\end{verbatim}
+
+コンディションがレイズされた時、そのコンディションにマッチする一番新しいハンドラーが実行される。
+ただし、callback中に{\em invoke-next-handler}を呼び出すことで以前のハンドラーを実行することもできる。
+
+\begin{verbatim}
+(defcondition foo)
+(install-handler foo #'(lambda (c) (print "FOO")))
+(install-handler foo
+ #'(lambda (c)
+ (print "Start")
+ (invoke-next-handler c)
+ (print "Done")))
+
+(signals foo)
+"Start"
+"FOO"
+"Done"
+\end{verbatim}
+
+コンディションのハンドリングを延期したい時、{\em lisp::atomic}を使うこともできる。
+
+\begin{verbatim}
+(defcondition foo)
+(install-handler foo #'(lambda (c) (print "FOO")))
+(defun bar (n)
+ (if (= n 3) (signals foo))
+ (print n))
+
+(lisp::atomic (dotimes (i 5) (bar i))
+ (foo () (print "In a second...")))
+0
+1
+2
+"In a second..."
+3
+4
+"FOO"
+\end{verbatim}
+
+\begin{refdesc}
+
+\classdesc{condition}{object}{message}{
+コンディションの最も基本的なクラス。}
+\methoddesc{:init}{\&rest init-args \&key message \&allow-other-keys}{
+インスタンスのスロットを{\em init-args}に沿って初期化する。子クラスに導入されたスロットに対しても初期化を行えるため、子クラスの:initから呼ばれるように設計されている。}
+
+\vardesc{lisp::*condition-handler*}{
+コンディションとそれに対応するhandlerのalistを保持する。}
+
+\vardesc{lisp::*current-condition*}{
+現在処理されているコンディションを保持する。}
+
+\macrodesc{defcondition}{name \&key slots (super 'condition)}{
+新しいコンディションを定義する。{\em slots}に含まれる各スロットに対するsetter/getterと{\em :init}メソッドも一緒に定義される。}
+
+\funcdesc{install-handler}{label handler}{
+Callback関数{\em handler}を定義し、{\em label}を親クラスとするコンディションがsignalizeされたらその関数を実行する。
+{\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。}
+
+\funcdesc{remove-handler}{label \&optional handler}{
+\textit{install-handler}によってコンディション{\em label}で登録された最後のhandlerを登録解除する。
+{\em handler}が与えられた場合、最後に登録された({\em label . handler})のペアを登録解除する。}
+
+\funcdesc{handler-bind}{(\&rest (label handler)) \&rest forms}{
+コンディション{\rm label}とハンドラー{\em handler}をロカルにbindし、{\em forms}を実行する。
+{\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。}
+
+\macrodesc{handler-case}{form \&rest (label arg-list \&rest body)}{
+{\em form}実行中に{\em label}を親クラスとするコンディションがsignalizeされれば、実行を停止し代わりに{\em body}を評価し、その値を返す。
+{\em arg-list}はコンディションインスタンスを保持する一個(あるいはゼロ個)のパラメータを持つリストである。}
+
+\funcdesc{signals}{obj \&rest init-args}{
+{\em obj}によって示されるコンディションをsignalizeする。最初にマッチングされたhandlerの返り値を返す。マッチングされずにどのhandlerも呼ばれない場合はnilを返す。
+{\em obj}はコンディションインスタンスか、 {\em init-args}によって初期化されるコンディションクラスである。}
+
+\funcdesc{invoke-next-handler}{obj}{
+ コンディションハンドラーの中から呼ばれた場合、コンディションインタンス{\em obj}と次にマッチングされたhandlerの返り値を返す。マッチングされずにどのhandlerも呼ばれない場合はnilを返す。}
+
+\macrodesc{lisp::atomic}{form \&rest (label arg-list \&rest body)}{
+{\em label}のコンディションに中断されることなく{\em body}を実行する。
+{\em form}実行中に{\em label}を親クラスとするコンディションがsignalizeされれば、{\em body}をその場で実行し、そして{\em form}の評価が終わったときにはそのコンディションをもう一度レイズする。}
+
+\end{refdesc}
+
\newpage
diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex
index 7cfd22043..5d4e35e90 100644
--- a/doc/jlatex/jevaluation.tex
+++ b/doc/jlatex/jevaluation.tex
@@ -3,41 +3,11 @@ \section{評価}
\subsection{評価関数}
-エラーやシグナル(signal)に関する振る舞いを示すために、
-あらかじめそれぞれ特別の変数{\bf *error-handler*}と{\bf *signal-handler*}
-に適当な関数を設定する。
-修正あるいは続行できるエラーはない。
-エラーを解析後、現在の実行を{\bf reset}または上位レベルへの適当な{\bf throw}
-によって停止しなければならない。
-Euslispの最上位レベルで{\tt 0}と名付けられたcatch frameを作成しているので、
-{\bf reset}は、{\tt (throw 0 NIL)}と同等である。
-
-エラーハンドラーは、{\em code msg1 form \&optional (msg2)}
-という3つあるいは4つの引き数を持つ関数として定義しなければならない。
-{\em code}はエラーコードで、システムで定義されたエラーを示す。
-例えば、14が'引き数が合わない'、13が'関数が定義されていない'となる。
-これらの定義は、"c/eus.h"の中に定義されている。
-{\em msg1}と{\em msg2}は、ユーザーに示されるメッセージである。
-{\em form}は、エラーによって生じたs表現である。
-
-シグナルハンドラーは、{\em sig}と{\em code}の2つの引き数を受ける関数として
-定義されなければならない。
-{\em sig}は、1から30までのシグナル番号である。
-{\em code}は、シグナル番号の中に定義された補助番号である。
-
-最上位レベルでの\verb+^+D({\em end-of-file})は、Euslispの活動を停止させる。
-これは、Euslispをフィルターとしてプログラムされているとき
-役に立つ。
-
-{\bf eval-dynamic}は、letやlambda変数として使用されるsymbolに結び付く
-動的な変数を捜す関数である。
-デバッグするときに役に立つ。
-
\begin{refdesc}
\funcdesc{identity}{obj}{
{\em obj}自身を返す。
-{\bf idnetity}と{\bf quote}との違いに注意すること。
+{\bf identity}と{\bf quote}との違いに注意すること。
{\bf identity}が関数であるのに対して{\bf quote}は、特殊書式(special form)
である。
したがって、{\tt (identity 'abc)}は{\tt abc}と評価されるが、
@@ -77,7 +47,8 @@ \subsection{評価関数}
{\em hookfun}を{\bf *evalhook*}に結び付けた後、{\em form}を一度評価する。}
\funcdesc{eval-dynamic}{variable}{
-スタックにある{\em variable}(symbol)の値を捜す。}
+スタックにある{\em variable}(symbol)の値を捜す。
+デバッグするときに役に立つ。}
\funcdesc{macroexpand}{form}{
もし、{\em form}がマクロcallであるなら、それを展開する。
@@ -135,26 +106,56 @@ \subsection{評価関数}
{\em format-string}と{\em args}で与えられる警告メッセージを
{\bf *error-output*}に出力する。}
-\funcdesc{error}{format-string \&rest args}{
-{\bf *error-handler*}に結び付く現在のエラーハンドラー関数を呼び出す。
-デフォルトのエラーハンドラー'euserror'を{\bf *error-output*}に最初に出力し
-{\em format-string}と{\em args}を{\bf format}を用いて出力する。
-その後、新しい最上位レベルのセッション(session)に入る。
-プロンプトには、エラーセッションの深さを示す。
-{\bf throw}にその番号を与えることにより、低いエラーレベルのセッションへ戻ることができる。}
+\funcdesc{error}{message-or-class \&rest format-args}{
+{\em message-or-class}をメッセージに持つエラーコンディションをsignalizeする。
+{\em message-or-class}がクラスだった場合、それによってしめされるエラーコンディションをsignalizeする。そのとき、二番目のargumentはメッセージを指定しなければならない。}
\end{refdesc}
-マルチスレッドEuslispにおいて、特殊変数はスレッド間で共有され、
-同じ{\bf *error-handler*}が異なったスレッドから参照される。
-この不自由を避けるために、マルチスレッドEuslispは{\bf install-error-handler}
-関数を備えている。その関数は、それぞれのスレッドに対して
-異なったエラーハンドラーをインストールする。
+\newpage
+
+\subsection{エラーとUnixシグナルをハンドリングする}
+
+コンディションハンドラーを用いることでエラーや中断シグナル(sigint)をハンドリングすることができる。
+EusLispでは以下のコンディションクラスが定義され、Unixシグナルに関するクラスを新しく導入したい場合にはマクロ{\bf unix:install-signal-handler}を使うと良い。デフォルトではエラーは{\bf euserror}に、中断シグナルは{\bf lisp::interruption-handler}によってハンドリングされる。
\begin{refdesc}
-\funcdesc{lisp::install-error-handler}{handler}{
-{\em handler}を現在のスレッドのエラーハンドラーとしてインストールする。}
+\classdesc{error}{condition}{callstack form}{
+エラーの最も基本的なクラス。}
+\classdesc{argument-error}{error}{}{}
+\classdesc{program-error}{error}{}{}
+\classdesc{name-error}{error}{}{}
+\classdesc{type-error}{error}{}{}
+\classdesc{value-error}{error}{}{}
+\classdesc{index-error}{error}{}{}
+\classdesc{io-error}{error}{}{}
+\classdesc{assertion-error}{error}{}{}
+
+\funcdesc{lisp::print-error-message}{err \&optional (os *error-output*)}{
+{\em err}のmessageをoutput stream {\em os}に出力する。}
+
+\classdesc{interruption}{condition}{}{}
+
+\classdesc{unix::signal-received}{condition}{}{}
+\classdesc{unix::sigint-received}{unix::signal-received}{}{}
+\classdesc{unix::sigcont-received}{unix::signal-received}{}{}
+
+\macrodesc{unix:install-signal-handler}{sig obj \&rest init-args}{
+コンディション{\em obj}を定義し、Unixシグナル{\em sig}を受信する度にそれをsignalizeする。
+定義されるコンディションは{\em unix::signal-received}の子クラスであり、signalizeされるインスタンスは{\em init-args}によって初期化される。}
+
+互換性のため、以下の処理方法も定義されている。
+
+\funcdesc{eussig}{sig code}{
+SIGPIPEのデフォルトシグナルハンドラー。
+{\bf *signal-handlers*}に格納されているハンドラーを実行した後、シグナル番号を出力し新たなREPLレベルに入る。}
+
+\vardesc{*signal-handlers*}{
+{\bf eussig}に用いられるハンドラー関数を格納するベクトル.}
+
+\vardesc{*error-handler*}{
+NILでない時、エラーをハンドリングする関数を指定する。その関数は４つの引数を受け取る:エラー番号、メッセージ、評価されていたexpression、そしてオプショナルな追加メッセージ。}
\end{refdesc}
@@ -248,21 +249,15 @@ \subsection{最上位レベルの対話}
\funcdesc{eustop}{\&rest argv}{
デフォルトの最上位ループ}
-\funcdesc{eussig}{sig code}{
-SIGPIPEのデフォルトシグナルハンドラー。
-{\bf eussig}は、SIGPIPEが到着したり他の最上位レベルループに入るとき
-シグナル番号を出力する。}
-
-\funcdesc{sigint-handler}{sig code}{
+\funcdesc{sigint-handler}{c}{
SIGINT(control-C)のデフォルトシグナルハンドラー。
-このシグナルで新しい最上位セッションへ入る。}
+デフォルトで{\it interruption}コンディションをsignalizeする。}
-\funcdesc{euserror}{code message \&rest arg}{
-デフォルトのエラーハンドラーで、
-{\em message}を出力し、新しいエラーセッションへ入る。}
+\funcdesc{euserror}{err}{
+デフォルトのエラーハンドラーで、{\em err}のcallstackとmessageを出力し、新しいエラーセッションへ入る。}
-\funcdesc{reset}{}{
-エラーループから脱出して、最後の{\bf eustop}セッションへ戻る。}
+\funcdesc{reset}{\&optional (n 0)}{
+エラーループから脱出して、{\em n}番目の{\bf eustop}セッションへ戻る。}
\funcdesc{exit}{\&optional termination-code}{
Euslispプロセスを終了し、プロセスの状態コードとして{\em termination-code}
@@ -405,6 +400,40 @@ \subsection{コンパイル}\label{compiler}
コンパイルされたコードを解析するためには中間Cプログラムを見るかあるいは
{\bf adb}を使用する。
+\subsubsection{クロージャコンパイル}
+
+クロージャが生成されるとき、コンパイラはスタック・メモリに存在する現在のローカル・バインディングをヒープ・メモリに移動させなければならない。これによって、クロージャが元のスコープの外からでも安定して実行できるようになる。
+
+しかし、ローカル・バインディングをすべてヒープに保存するのは最適ではない。そのため、コンパイラはルックアヘッドを用いて必要最小限の参照のみをヒープに移動している。
+
+例えば、次のようなコードをみてみよう。
+\begin{verbatim}
+(let ((a 1) (b 2) (c 3))
+ (setq fn1 #'(lambda () (1+ a))))
+\end{verbatim}
+
+コンパイルされたコードは次のとおりとなる。クロージャで使用される唯一のローカル変数である{\em a}の値を保持するため、サイズ 1 のベクトルをallocationしている。二番目に生成されるベクトルは参照ベクトルをまとめるもので、複数のクロージャが同じバインドを共有するときに重要となる。二番目のベクトルのサイズは、allocation時のスタックのサイズに等しい。これは、クロージャの内部と外部で同じインデックスを維持するための便宜上のものであり、最適化の余地もまだある。
+
+\begin{verbatim}
+ local[0]= makeint((eusinteger_t)1L);
+ local[1]= makeint((eusinteger_t)2L);
+ local[2]= makeint((eusinteger_t)3L);
+ ctx->vsp=local+3;
+ ctx->vsp=local+3;
+ local[3]= makevector(C_VECTOR,1); /*parlet*/
+ local[3]->c.vec.v[0]= local[0];
+ ctx->vsp=local+4;
+ local[4]= makevector(C_VECTOR,4); /*lambda-closure*/
+ local[4]->c.vec.v[3] = local[3];
+ w = local[4];
+ ctx->vsp=local+4;
+ local[4]= makeclosure(codevec,quotevec,testCLO1,NIL,w);
+ storeglobal(fqv[0],local[4]);
+ w = local[4];
+ local[0]= NIL;
+ ctx->vsp=local; return(local[0]);
+\end{verbatim}
+
\begin{refdesc}
\functiondescription{euscomp}{\&rest filename}{UNIXコマンド}{
@@ -424,12 +453,19 @@ \subsection{コンパイル}\label{compiler}
モジュールが作成中にEuslispのコアにハードリンクされていないかぎり、
{\em :pic}は、Tに設定すべきである。}
-\funcdesc{compile}{funcname}{
+\funcdesc{compile}{\&rest funcnames}{
関数をコンパイルする。{\bf compile}は、最初に関数定義をテンポラリファイルに
出力する。そのファイルは、{\bf compile-file}によってコンパイルされ、
それから{\bf load}によってロードされる。
テンポラリファイルは削除される。}
+\funcdesc{compile-method}{obj \&rest meths}{
+オプジェクトインスタンスやクラス{\em obj}のメソッド{\em meths}をコンパイルする。
+{\bf compile-method}は、最初にメソッド定義をテンポラリファイルに
+出力する。そのファイルは、{\bf compile-file}によってコンパイルされ、
+それから{\bf load}によってロードされる。
+テンポラリファイルは削除される。}
+
\funcdesc{compile-file-if-src-newer}{srcfile \&key compiler-options}{
{\em srcfile}が対応するオブジェクトファイルよりも新しい（最近変更された）
ならば、コンパイルする。そのオブジェクトファイルは、".o"拡張子を
@@ -438,13 +474,18 @@ \subsection{コンパイル}\label{compiler}
\vardesc{compiler:*optimize*}{
コンパイラの最適化レベルを制御する。}
+\vardesc{compiler:*safety*}{
+安全性レベルを制御する。}
+
\vardesc{compiler:*verbose*}{
non-NILが設定されたとき、コンパイルされている関数名やメソッド名そして
コンパイルに要した時間を表示する。}
-\vardesc{compiler:*safety*}{
-安全性レベルを制御する。}
+\vardesc{compiler:*type-check-declare*}{
+non-NILが設定されたとき、コンパイルされたコードではdeclareされた変数のタイプを積極的にチェックする。}
+\funcdesc{compiler::compiler-implementation-version}{}{
+コンパイラのバーションを表すストリングを返す。``EusLisp compiler version 1.54''}
\end{refdesc}
\newpage
@@ -637,9 +678,23 @@ \subsection{デバッグ補助}
\macrodesc{time}{function}{
{\em function}によって経過した時間を測定し始める。}
+\funcdesc{lisp::print-callstack}{\&optional (stack (sys:list-callstack)) max (os *error-output*)}{
+Callstackの最高{\em max}個をoutput stream{\em os}に出力する。
+{\em max}が{\it nil}なら、callstackのすべてを出力する。}
+
+\funcdesc{sys:list-callstack}{\&optional max}{
+現在のcallstackの最高{\em max}個のリストを返す。
+{\em max}が与えられない場合には現在のcallstackのすべてを出力する。}
+
\funcdesc{sys:list-all-catchers}{}{
すべての{\bf catch}タグを返す。}
+\funcdesc{sys:list-all-blocks}{}{
+すべての{\bf block}タグを返す。}
+
+\funcdesc{sys:list-all-tags}{}{
+すべての{\bf tagbody}タグを返す。}
+
\funcdesc{sys:list-all-instances}{aclass \&optional scan-sub}{
すべてのヒープの中から{\em aclass}で指定されるインスタンスをすべて
探し、集める。
@@ -647,12 +702,17 @@ \subsection{デバッグ補助}
リストする。そうでなければ、{\em aclass}のインスタンスあるいはサブクラス
が集められる。}
-\funcdesc{sys:list-all-bindings}{}{
-バインドされるスタックを探し、
-アクセス可能な値すべてをリストで返す。}
+\funcdesc{sys:list-all-bindings}{\&optional bindframe}{
+{\em bindframe}でバインドされているすべてのローカル変数の名前と値のリストを返す。
+{\em bindframe}が与えられない場合には現在のcallstackでバインドされているすべてのローカル変数の名前と値のリストを返す。}
\funcdesc{sys:list-all-special-bindings}{}{
-スタックを捜し、値をすべてリストアップする。}
+callstackでバインドされているすべてのスペシャル変数の名前と値のリストを返す。}
+
+\funcdesc{sys:list-all-function-bindings}{\&optional fletframe}{
+{\em fletframe}でバインドされているすべてのローカル関数のリストを返す。
+{\em fletframe}が与えられない場合には現在のcallstackでバインドされているすべてのローカル関数のリストを返す。}
+
\end{refdesc}
diff --git a/doc/jlatex/jgenerals.tex b/doc/jlatex/jgenerals.tex
index 6208c1e3c..3191102e7 100644
--- a/doc/jlatex/jgenerals.tex
+++ b/doc/jlatex/jgenerals.tex
@@ -529,22 +529,22 @@ \subsection{特殊書式}
\begin{center}
{\large
\begin{tabular}{|l l l|} \hline
-and & flet & quote \\
-block & function & return-from\\
-catch & go & setq \\
-cond & if & tagbody \\
-declare & labels & the \\
-defmacro & let & throw \\
-defmethod & let* & unwind-protect \\
-defun & progn & while \\
-eval-when & or & \\
+and & flet & progn \\
+block & function & quote\\
+catch & go & return-from\\
+cond & if & setq\\
+declare & labels & tagbody\\
+defmacro & let & the\\
+defmethod & let* & throw\\
+defun & macrolet & unwind-protect\\
+eval-when & or & while\\
\hline
\end{tabular} }
\end{center}
\end{table}
全ての特殊書式は、表\ref{SpecialForms}にリストされている。
-{\bf macrolet, compiler-let,}や{\bf progv}は、該当しない。
+{\bf symbol-macrolet, compiler-let,}や{\bf progv}は、該当しない。
特殊書式は、文脈の評価および制御フローの管理のための
基本的な言語構造である。
インタプリタとコンパイラは、これらの構造をそれぞれ正しく処理する
@@ -596,7 +596,18 @@ \subsection{関数}
{\bf \&optional, \&rest, \&key }や{\bf \&aux} はそれぞれ、lambda-list
のなかに特殊な意味を持っていて、これらのsymbolは、変数名として使用
することはできない。
-\&optionalや\&keyパラメータのsupplied-p変数は、サポートされていない。
+\&optionalや\&keyパラメータのsupplied-p変数は、version 10よりサポートされている。
+
+\begin{verbatim}
+(defun foo (&optional (a nil a-p))
+ (list a a-p))
+(foo 1)
+--> (1 t)
+(foo nil)
+--> (nil t)
+(foo)
+--> (nil nil)
+\end{verbatim}
lambda書式は、普通のリストデータと区別できないため、
{\bf function}特殊書式を用いて、インタプリタやコンパイラに関数として
@@ -638,26 +649,32 @@ \subsection{関数}
(vector-sum #(1 2 3 4)) --> 10
\end{verbatim}
-EusLispのclosureは、不定な大きさを持つことができない。
-すなわち、closureはその外側の大きさで可能な大きさまで持つことができる。
-これはclosureが'generators'のプログラミングのために使用されないことを意味する。
-次のプログラムは何もしない。
+\subsection{クロージャ}
+
+クロージャは生成時のlexicalスコープを継承する関数である。
+オブジェクトと同じくローカルな変数や関数のバインドを保持、アクセスすることができる。
+ただし、EusLispのオブジェクト指向とは異なり、クロージャのメンバーは外部からアクセスできない
+(privateメンバーとして機能する)。
\begin{verbatim}
-(proclaim '(special gen))
(let ((index 0))
(setq gen #'(lambda () (setq index (1+ index)))))
(funcall gen)
+--> 1
+(funcall gen)
+--> 2
\end{verbatim}
-しかしながら、その同じ目的がオブジェクト指向プログラミングで実現できる。
-なぜなら、オブジェクトはそれ自身の固定変数を持つことができるためである。
+同じ目的のオブジェクト指向プログラミングを以下で示す。
\begin{verbatim}
-(defclass generator object (index))
+(defclass generator :super object :slots (index))
(defmethod generator
(:next () (setq index (1+ index)))
(:init (&optional (start 0)) (setq index start) self))
(defvar gen (instance generator :init 0))
(send gen :next)
+--> 1
+(send gen :next)
+--> 2
\end{verbatim}
\newpage
diff --git a/doc/jlatex/jintro.tex b/doc/jlatex/jintro.tex
index d7e03bc5a..82fcf4a71 100644
--- a/doc/jlatex/jintro.tex
+++ b/doc/jlatex/jintro.tex
@@ -142,17 +142,10 @@ \subsection{Common Lispとの互換性}
\item 多値変数:
multiple-value-call, multiple-value-prog1, etc.
\item いくつかのデータ型:
- bignum, character, deftype
+ bignum, character, deftype, complex number and ratio (最後の二つは部分的に実装)
\item いくつかの特殊書式:
- progv, compiler-let,macrolet
-\end{enumerate}
-
-次の特徴は、まだ完全でない。：
-\begin{enumerate}
-\setcounter{enumi}{3}
-\item closure -- 動的範囲のみ有効である。
-%\item package -- no shadowing-list
-\item declare,proclaim -- inlineとignoreは認識されない。
+ progv, compiler-let, symbol-macrolet
+\item inline, ignore, declare, and proclaim (最後の二つは部分的に実装)
\end{enumerate}
\subsection{開発履歴}
diff --git a/doc/jlatex/jmthread.tex b/doc/jlatex/jmthread.tex
index 70f23e1c3..a3e34481f 100644
--- a/doc/jlatex/jmthread.tex
+++ b/doc/jlatex/jmthread.tex
@@ -268,7 +268,7 @@ \subsection{スレッド生成}
\begin{refdesc}
-\funcdesc{sys:make-thread}{num \&optional (lsize 32*1024) (csize lsize)}{
+\funcdesc{sys:make-thread}{\&optional (num 1) (lsize 32*1024) (csize lsize)}{
{\em lsize}ワードのlispスタックと{\em csize}ワードのC-スタックを持つ
スレッドを{\em num}個だけ生成し、システムのスレッドプールに
置く。
diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex
index 6780e5ffb..ee6502641 100644
--- a/doc/jlatex/jsequences.tex
+++ b/doc/jlatex/jsequences.tex
@@ -256,14 +256,83 @@ \subsection{リスト}
\funcdesc{cddar}{list}{
{\tt (cddar list) = (cdr (cdr (car list)))}}
+\funcdesc{caaddr}{list}{
+{\tt (caddr list) = (car (car (cdr (cdr list)))}}
+
+\funcdesc{caaadr}{list}{
+{\tt (caadr list) = (car (car (car (cdr list)))}}
+
+\funcdesc{caadar}{list}{
+{\tt (cadar list) = (car (car (cdr (car list)))}}
+
+\funcdesc{caaaar}{list}{
+{\tt (caaar list) = (car (car (car (car list)))}}
+
+\funcdesc{cadadr}{list}{
+{\tt (cdadr list) = (car (cdr (car (cdr list)))}}
+
+\funcdesc{cadaar}{list}{
+{\tt (cdaar list) = (car (cdr (car (car list)))}}
+
+\funcdesc{cadddr}{list}{
+{\tt (cdddr list) = (car (cdr (cdr (cdr list)))}}
+
+\funcdesc{caddar}{list}{
+{\tt (cddar list) = (car (cdr (cdr (car list)))}}
+
+\funcdesc{cdaddr}{list}{
+{\tt (caddr list) = (cdr (car (cdr (cdr list)))}}
+
+\funcdesc{cdaadr}{list}{
+{\tt (caadr list) = (cdr (car (car (cdr list)))}}
+
+\funcdesc{cdadar}{list}{
+{\tt (cadar list) = (cdr (car (cdr (car list)))}}
+
+\funcdesc{cdaaar}{list}{
+{\tt (caaar list) = (cdr (car (car (car list)))}}
+
+\funcdesc{cddadr}{list}{
+{\tt (cdadr list) = (cdr (cdr (car (cdr list)))}}
+
+\funcdesc{cddaar}{list}{
+{\tt (cdaar list) = (cdr (cdr (car (car list)))}}
+
+\funcdesc{cddddr}{list}{
+{\tt (cdddr list) = (cdr (cdr (cdr (cdr list)))}}
+
+\funcdesc{cdddar}{list}{
+{\tt (cddar list) = (cdr (cdr (cdr (car list)))}}
+
\funcdesc{first}{list}{
-{\em list}の最初の要素を取り出す。
-{\bf second, third, fourth, fifth, sixth, seventh, eighth}もまた定義されている。{\tt (first list) = (car list)}}
+{\em list}の最初の要素を取り出す。}
+
+\funcdesc{second}{list}{
+{\em list}の2番目の要素を取り出す。}
+
+\funcdesc{third}{list}{
+{\em list}の3番目の要素を取り出す。}
+
+\funcdesc{fourth}{list}{
+{\em list}の4番目の要素を取り出す。}
+
+\funcdesc{fifth}{list}{
+{\em list}の5番目の要素を取り出す。}
+
+\funcdesc{sixth}{list}{
+{\em list}の6番目の要素を取り出す。}
-%\funcdesc{second}{list}{{\tt (second list) = (cadr list)}}
-%\funcdesc{third}{list}{{\tt (third list) = (caddr list)}}
-%\funcdesc{fourth}{list}{{\tt (fourth list) = (car (cdddr list))}}
-%\funcdesc{fifth}{list}{{\tt (fifth list) = (cadr (cdddr list))}}
+\funcdesc{seventh}{list}{
+{\em list}の7番目の要素を取り出す。}
+
+\funcdesc{eighth}{list}{
+{\em list}の8番目の要素を取り出す。}
+
+\funcdesc{ninth}{list}{
+{\em list}の9番目の要素を取り出す。}
+
+\funcdesc{tenth}{list}{
+{\em list}の10番目の要素を取り出す。}
\funcdesc{nth}{count list}{
{\em list}内の{\em count}番目の要素を返す。
@@ -272,8 +341,8 @@ \subsection{リスト}
\funcdesc{nthcdr}{count list}{
{\em list}に{\bf cdr}を{\em count}回適用した後のリストを返す。}
-\funcdesc{last}{list}{
-{\em list}の最後の要素でなく、最後のconsを返す。}
+\funcdesc{last}{list \&optional (n 1)}{
+{\em list}の最後の要素でなく、最後の{\em n}個のconsを返す。}
\funcdesc{butlast}{list \&optional (n 1)}{
{\em list}の最後から{\em n}個の要素を削除したリストを返す。}
@@ -282,13 +351,16 @@ \subsection{リスト}
{\tt car}が{\em car}で{\tt cdr}が{\em cdr}であるような新しいconsを作る。}
\funcdesc{list}{\&rest elements}{
-makes a list of {\em elements}.}
+{\em element}を要素とするリストを返す。}
\funcdesc{list*}{\&rest elements}{
{\em element}を要素とするリストを作る。しかし、最後の要素は{\bf cons}されるため、
atomであってはならない。
例えば、{\tt (list* 1 2 3 '(4 5)) = (1 2 3 4 5)}である。}
+\funcdesc{values}{\&rest elements}{
+{\em list}のalias.}
+
\funcdesc{list-length}{list}{
{\em list}の長さを返す。{\em list}は、環状リストでも良い。}
@@ -319,13 +391,25 @@ \subsection{リスト}
\funcdesc{assoc}{item alist \&key key (test \#'eq) test-not}{
{\em alist}の要素の{\bf car}が{\em :test}の条件にあった最初のものを返す。
-合わなければ、NILを返す。
-{\em :test}のデフォルトは{\tt \#'eq}である。
-{\tt (assoc '2 '((1 d t y)(2 g h t)(3 e x g))=(2 g h t)}}
+合わなければ、NILを返す。}
+
+\funcdesc{assoc-if}{pred alist \&key key}{
+{\em alist}の要素の{\bf car}が{\em pred}の条件にあった最初のものを返す。
+なければ、NILを返す。}
-\funcdesc{rassoc}{item alist}{
+\funcdesc{assoc-if-not}{pred alist \&key key}{
+{\em alist}の要素の{\bf car}が{\em pred}の条件に{\bf あわない}最初のものを返す。
+なければ、NILを返す。}
+
+\funcdesc{rassoc}{item alist \&key key (test \#'equal) test-not}{
{\bf cdr}が{\em item}に等しい{\em alist}のなかの最初の組を返す。}
+\funcdesc{rassoc-if}{pred alist \&key key}{
+{\bf cdr}が{\em pred}にあった{\em alist}のなかの最初の組を返す。}
+
+\funcdesc{rassoc-if-not}{pred alist \&key key}{
+{\bf cdr}が{\em pred}に{\bf あわない}{\em alist}のなかの最初の組を返す。}
+
\funcdesc{pairlis}{l1 l2 \&optional alist}{
{\em l1}と{\em l2}の中の一致する要素を対にしたリストを作る。
もし{\em alist}が与えられたとき、
@@ -392,6 +476,12 @@ \subsection{リスト}
{\bf nconc}される。
{\tt (list-insert 'x 2 '(a b c d)) = (a b x c d)}}
+\funcdesc{list-delete}{lst n}{
+{\em lst}の{\em n}番目の要素を削除する
+（元のリストを変化させる）。
+もし{\em n}が{\em lst}の長さより大きいなら、{\em lst}は変更されない。
+{\tt (list-delete 'x 2 '(a b c d)) = (a b d)}}
+
\funcdesc{copy-tree}{tree}{
入れこリストである{\em tree}のコピーを返す。
しかし、環状参照はできない。環状リストは、
@@ -575,6 +665,24 @@ \subsection{文字と文字列}
\funcdesc{char-downcase}{ch}{
{\em ch}を小文字に変換する。}
+\funcdesc{char=}{ch1 ch2 \&rest more-characters}{
+{\em =}のalias.}
+
+\funcdesc{char/=}{ch1 ch2 \&rest more-characters}{
+{\em /=}のalias.}
+
+\funcdesc{char$>$}{ch1 ch2 \&rest more-characters}{
+{\em $>$}のalias.}
+
+\funcdesc{char$<$}{ch1 ch2 \&rest more-characters}{
+{\em $<$}のalias.}
+
+\funcdesc{char$>=$}{ch1 ch2 \&rest more-characters}{
+{\em $>=$}のalias.}
+
+\funcdesc{char$<=$}{ch1 ch2 \&rest more-characters}{
+{\em $<=$}のalias.}
+
\funcdesc{char}{string index}{
{\em string}の{\em index}番目の文字を返す。}
@@ -583,6 +691,9 @@ \subsection{文字と文字列}
{\em string}の型が明確に解っていて、型チェックを要しないときのみ、{\bf schar}
を使うこと。}
+\funcdesc{setchar}{string index ch}{
+{\em string}の{\em index}番目の文字を{\em ch}にする。}
+
\funcdesc{stringp}{object}{
{\em object}がバイト(256より小さい正の整数)のベクトルなら、Tを返す。}
@@ -617,18 +728,26 @@ \subsection{文字と文字列}
もっと複雑なオブジェクトから文字列表現を得るためには、
最初の引数をNILにした{\bf format}関数を用いること。}
-\fundesc{string$<$}{str1 str2}
+\fundesc{string$<$}{str1 str2}{
+strcmpによる{\em str1}の値が{\em str2}より低い時、Tを返す。}
-\fundesc{string$<=$}{str1 str2}
+\fundesc{string$<=$}{str1 str2}{
+strcmpによる{\em str1}の値が{\em str2}より低い、もしくは等しい時、Tを返す。}
-\fundesc{string$>$}{str1 str2}
+\fundesc{string$>$}{str1 str2}{
+strcmpによる{\em str1}の値が{\em str2}より高い時、Tを返す。}
-\fundesc{string$>=$}{str1 str2}
+\fundesc{string$>=$}{str1 str2}{
+strcmpによる{\em str1}の値が{\em str2}より高い、もしくは等しい時、Tを返す。}
-\fundesc{string-left-trim}{bag str}
+\fundesc{string-left-trim}{bag str}{
+{\em str}は、左から探索され、もし{\em bag}リスト内の文字を含んでいるなら、
+その要素を削除する。
+一旦{\em bag}に含まれない文字が見つかると、その後の探索は中止され、
+{\em str}の残りが返される。}
\funcdesc{string-right-trim}{bag str}{
-{\em str}は、左（右）から探索され、もし{\em bag}リスト内の文字を含んでいるなら、
+{\em str}は、右から探索され、もし{\em bag}リスト内の文字を含んでいるなら、
その要素を削除する。
一旦{\em bag}に含まれない文字が見つかると、その後の探索は中止され、
{\em str}の残りが返される。}
@@ -730,7 +849,7 @@ \subsection{ハッシュテーブル}
その他どんなオブジェクトでも、{\bf sxhash}はそれぞれのスロットのハッシュ値を
再帰的呼出しで計算し、それらの合計を返す。}
-\funcdesc{make-hash-table}{\&key (size 30) (test \#'eq) (rehash-size 2.0)}{
+\funcdesc{make-hash-table}{\&key (size 10) (test \#'eq) (rehash-size 1.7)}{
hash-tableを作り、返す。}
@@ -750,12 +869,12 @@ \subsection{ハッシュテーブル}
\funcdesc{hash-table-p}{x}{
もし{\em x}がhash-tableクラスのインスタンスなら、Tを返す。}
-\classdesc{hash-table}{object}{(key value count \\
+\classdesc{hash-table}{object}{(key value count fill-count \\
\> hash-function test-function \\
\> rehash-size empty deleted)}{
hash-tableを定義する。
{\em key}と{\em value}は大きさが等しい一次元ベクトルである。
-{\em count}は、{\em key}や{\em value}が埋まっている数である。
+{\em count}と{\em fill-count}は、{\em key}や{\em value}の埋まり具合を管理するために使われる。
{\em hash-function}のデフォルトは{\bf sxhash}である。
{\em test-function}のデフォルトは{\bf eq}である。
{\em empty}と{\em deleted}は、{\em key}ベクトルのなかで空または削除された
diff --git a/doc/jlatex/jsymbols.tex b/doc/jlatex/jsymbols.tex
index 1ccb041fc..a624ed77f 100644
--- a/doc/jlatex/jsymbols.tex
+++ b/doc/jlatex/jsymbols.tex
@@ -78,6 +78,10 @@ \subsection{symbol}
{\em symbol}は、（特殊値を持たないように）強制的にunboundされる。
ローカル変数は、いつも値が割り当てられ、{\bf makunbound}できない。}
+\funcdesc{fmakunbound}{symbol}{
+{\em symbol}に示される関数は、（特殊値を持たないように）強制的にunboundされる。
+ローカル関数は、いつも値が割り当てられ、{\bf fmakunbound}できない。}
+
\funcdesc{get}{sym attribute}{
{\em sym}のplistの中で{\em attribute}に関連する値を取り出す。
{\tt (cdr (assoc {\em attribute} (symbol-plist {\em sym})))}と等価である。}
@@ -105,7 +109,7 @@ \subsection{symbol}
\specialdesc{defmacro}{symbol lambda-list \&rest body}{
グローバルマクロを定義する。
-EusLispは、ローカルスコープマクロ定義の機能を持っていない。}
+ローカルマクロを定義するためには、{\bf macrolet}を使用すること。}
\macrodesc{defvar}{var \&optional (init nil) doc}{
もし{\em var}が特殊値を持っていれば、{\bf defvar} は何もしない。
diff --git a/doc/jlatex/jsysfunc.tex b/doc/jlatex/jsysfunc.tex
index 668e90af6..7815e3a0f 100644
--- a/doc/jlatex/jsysfunc.tex
+++ b/doc/jlatex/jsysfunc.tex
@@ -97,13 +97,11 @@ \subsection{メモリ管理}
ガーベージコレクションを実行する。割り当てられている中で空いているワード数および全体のワード数
のリストを返す。}
-\vardesc{sys:*gc-hook*}{
-ガーベージコレクションを実行する時に呼ばれる関数を定義する。}
-
\funcdesc{sys:gctime}{}{
3つの整数のリストを返す。1つは、ＧＣを呼び出した回数。
-2つは、セルをマーキングするために使用した時間（1ユニットに1/60秒）。
-3つが、矯正（マーキングを外し、マージする）のために使用した時間。}
+2つは、セルをマーキングするために使用した時間。
+3つが、矯正（マーキングを外し、マージする）のために使用した時間。
+時間はtick回数で与えられる。}
\funcdesc{sys:alloc}{size}{
ヒープに少なくとも{\em size}ワードのメモリを配置し、
@@ -112,6 +110,9 @@ \subsection{メモリ管理}
\funcdesc{sys:newstack}{size}{
現在のスタックを廃棄し、{\em size}ワードの新しいスタックを配置する。}
+\vardesc{sys:*gc-debug*}{
+ガーベージコレクションを実行する度にデバッグメッセージをプリントする。}
+
\vardesc{sys:*gc-merge*}{
メモリ管理用のパラメータ。
{\bf *gc-merge*}は、GCによりマージされずに残すヒープメモリの比率を示す。
@@ -508,8 +509,9 @@ \subsubsection{シグナル}
\begin{refdesc}
-\funcdesc{unix:signal}{signal func \&optional option}{
-{\em signal}に対してシグナルハンドラー{\em func}をインストールする。
+\funcdesc{unix:signal}{signal \&optional func option}{
+{\em func}が与えていればそれを{\em signal}に対するシグナルハンドラーとしてインストールする。
+そうでなければ{\em signal}に対するシグナルハンドラーを返す。
BSD4.2システムにおいて、システムコール処理の間に捕まえたシグナルは、
システムコールのリトライに起因する。
これは、もしその処理がシステムコールの呼び出しを発行するならば、
@@ -525,10 +527,12 @@ \subsubsection{シグナル}
\funcdesc{unix:alarm}{time}{
{\em time}秒後にアラーム時計シグナル(SIGALRM 14)を送る。
-{\em time}=0で{\bf unix:alarm}を呼び出すと、アラーム時計をリセットする。}
+{\em time}=0で{\bf unix:alarm}を呼び出すと、アラーム時計をリセットする。
+既にスケジューリングされているalarmがある時はその実行までの秒数を、ない場合には0を返す。}
-\funcdesc{unix:ualarm}{time}{
+\funcdesc{unix:ualarm}{time interval}{
{\em time}がマイクロ秒単位であることを除いて{\bf unix:alarm}と同じである。
+{\em time}は1000000を超えてはならない。
{\bf ualarm}は、Solaris2あるいはSystem5系のシステムに実現されていない。}
\funcdesc{unix:getitimer}{timer}{
diff --git a/doc/latex/controls.tex b/doc/latex/controls.tex
index 498569663..a31d416ae 100644
--- a/doc/latex/controls.tex
+++ b/doc/latex/controls.tex
@@ -96,6 +96,8 @@ \subsection{Local Functions}
the local functions defined by {\em flet} cannot reference
each other or recursively, whereas {\em labels} allows such mutual references.}
+\specialdesc{macrolet}{ (\{(name lambda-list . body)\}*) \{form\}*}{
+defines local macros.}
\end{refdesc}
\subsection{Blocks and Exits}
@@ -136,6 +138,7 @@ \subsection{Blocks and Exits}
\end{refdesc}
+
\subsection{Iteration}
\begin{refdesc}
@@ -269,4 +272,112 @@ \subsection{Predicates}
\end{refdesc}
+
+\subsection{Conditions}
+
+Conditions can be used to report exceptions to higher levels in the program and ask for handling before continuing.
+Conditions are signalized using the {\em signals} function, and are handled through callbacks registered either globaly with {\em install-handler} or locally with {\em handler-bind} (resumption semantics) or {\em handler-case} (termination semantics).
+
+\begin{verbatim}
+(defcondition foo)
+(install-handler foo #'(lambda (c) 2))
+
+(list 1 (signals foo) 3)
+--> (1 2 3)
+
+(handler-bind ((foo #'(lambda (c) 20)))
+ (list 1 (signals foo) 3))
+--> (1 20 3)
+
+(handler-case (list 1 (signals foo) 3)
+ (foo () 200))
+--> 200
+\end{verbatim}
+
+When a signal is raised, the most recently registered handler is always prioritized.
+However, it is also possible to interact with previous handlers by calling
+{\em invoke-next-handler} at any point of the callback execution.
+
+\begin{verbatim}
+(defcondition foo)
+(install-handler foo #'(lambda (c) (print "FOO")))
+(install-handler foo
+ #'(lambda (c)
+ (print "Start")
+ (invoke-next-handler c)
+ (print "Done")))
+
+(signals foo)
+"Start"
+"FOO"
+"Done"
+\end{verbatim}
+
+The function {\em lisp::atomic} also allows to locally postpone
+a handler evaluation, possibly with some additional callback.
+
+\begin{verbatim}
+(defcondition foo)
+(install-handler foo #'(lambda (c) (print "FOO")))
+(defun bar (n)
+ (if (= n 3) (signals foo))
+ (print n))
+
+(lisp::atomic (dotimes (i 5) (bar i))
+ (foo () (print "In a second...")))
+0
+1
+2
+"In a second..."
+3
+4
+"FOO"
+\end{verbatim}
+
+
+\begin{refdesc}
+
+\classdesc{condition}{object}{message}{
+ The most basic class for signaling conditions.}
+\methoddesc{:init}{\&rest init-args \&key message \&allow-other-keys}{
+ Loops through {\em init-args} setting instance slots to its respective key argument.
+ It can also handle slots added in child classes, and is designed to be called from child classes initialization.}
+
+\vardesc{lisp::*condition-handler*}{
+ Holds the alist of conditions and handlers.}
+
+\vardesc{lisp::*current-condition*}{
+ Holds the condition being currently handled.}
+
+\macrodesc{defcondition}{name \&key slots (super 'condition)}{
+ Defines new conditions. Defines a new class with setter/getter methods for each slot in {\em slots} and a proper {\em :init} method.}
+
+\funcdesc{install-handler}{label handler}{
+ Introduces a callback function {\em handler} to be called when a condition derived from {\em label} is signalized.
+ {\em label} is a condition class and {\em handler} is a funcallable object which takes one parameter (the condition instance signalized).}
+
+\funcdesc{remove-handler}{label \&optional handler}{
+ Removes the last handler that has been registered with \textit{install-handler} relative to the condition {\em label}.
+ If {\em handler} is given, removes the last registered pair of ({\em label . handler}) instead.}
+
+\funcdesc{handler-bind}{(\&rest (label handler)) \&rest forms}{
+ Locally binds condition handlers and executes {\em forms}.
+ {\em label} is a condition class and {\em handler} is a funcallable object which takes one parameter (the condition instance signalized).}
+
+\macrodesc{handler-case}{form \&rest (label arg-list \&rest body)}{
+ If any condition matching {\em label} is signalized during execution of {\em form}, the execution is aborted and {\em body} is evaluated instead. {\em arg-list} is a one or zero length parameter list to hold the condition instance.}
+
+\funcdesc{signals}{obj \&rest init-args}{
+ Signalizes conditions. Returns the result of the first matching handler or {\it nil} if unhandled.
+ {\em obj} is a condition instance or a condition class to be initialized by {\em init-args}.}
+
+\funcdesc{invoke-next-handler}{obj}{
+ Can be used from within a condition handler to call the next handler matching the {\it obj} condition. {\it obj} must be an initialized condition instance. Returns the result of the matching handler or {\it nil} if unhandled.}
+
+\macrodesc{lisp::atomic}{form \&rest (label arg-list \&rest body)}{
+ Executes {\em form} without being interrupted by conditions matching {\em label}.
+ If a condition matching {\em label} is signalized during the execution of {\em form}, the callback defined in {\em body} is executed in-place and the condition is re-signalized after the evaluation finishes.}
+
+\end{refdesc}
+
\newpage
diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp
index 44148cfbf..4c9a635bb 100644
--- a/doc/latex/euslisp.hlp
+++ b/doc/latex/euslisp.hlp
@@ -1,5 +1,5 @@
; This file is help command list for euslisp
-"/home/affonso/euslisp/src/euslisp/Euslisp/doc/latex" ; Directory of TeX manual
+"/home/affonso/euslisp_new_ws/src/euslisp/Euslisp/doc/latex" ; Directory of TeX manual
;
"and" 6 "controls" 308 3
"or" 6 "controls" 473 3
@@ -15,33 +15,46 @@
"let*" 6 "controls" 3186 3
"flet" 6 "controls" 3492 3
"labels" 6 "controls" 3596 3
-"block" 6 "controls" 3963 3
-"return-from" 6 "controls" 4130 3
-"return" 3 "controls" 4384 3
-"catch" 6 "controls" 4629 3
-"throw" 6 "controls" 4864 3
-"unwind-protect" 6 "controls" 4998 3
-"while" 6 "controls" 5549 3
-"tagbody" 6 "controls" 6152 3
-"go" 6 "controls" 6282 3
-"prog" 3 "controls" 6497 3
-"do" 3 "controls" 6680 3
-"do*" 3 "controls" 7195 3
-"dotimes" 3 "controls" 7446 3
-"dolist" 3 "controls" 7674 3
-"until" 3 "controls" 8071 3
-"loop" 3 "controls" 8160 3
-"eq" 2 "controls" 8492 3
-"eql" 2 "controls" 8719 3
-"equal" 2 "controls" 8856 3
-"superequal" 2 "controls" 9117 3
-"null" 2 "controls" 9226 3
-"not" 2 "controls" 9314 3
-"atom" 2 "controls" 9378 3
-"every" 2 "controls" 9604 3
-"some" 2 "controls" 9768 3
-"functionp" 2 "controls" 9963 3
-"compiled-function-p" 2 "controls" 10370 3
+"macrolet" 6 "controls" 3905 3
+"block" 6 "controls" 4055 3
+"return-from" 6 "controls" 4222 3
+"return" 3 "controls" 4476 3
+"catch" 6 "controls" 4721 3
+"throw" 6 "controls" 4956 3
+"unwind-protect" 6 "controls" 5090 3
+"while" 6 "controls" 5642 3
+"tagbody" 6 "controls" 6245 3
+"go" 6 "controls" 6375 3
+"prog" 3 "controls" 6590 3
+"do" 3 "controls" 6773 3
+"do*" 3 "controls" 7288 3
+"dotimes" 3 "controls" 7539 3
+"dolist" 3 "controls" 7767 3
+"until" 3 "controls" 8164 3
+"loop" 3 "controls" 8253 3
+"eq" 2 "controls" 8585 3
+"eql" 2 "controls" 8812 3
+"equal" 2 "controls" 8949 3
+"superequal" 2 "controls" 9210 3
+"null" 2 "controls" 9319 3
+"not" 2 "controls" 9407 3
+"atom" 2 "controls" 9471 3
+"every" 2 "controls" 9697 3
+"some" 2 "controls" 9861 3
+"functionp" 2 "controls" 10056 3
+"compiled-function-p" 2 "controls" 10463 3
+"condition" 0 "controls" 12273 4
+":init" 1 "controls" 12360 3
+"lisp::*condition-handler*" 5 "controls" 12652 2
+"lisp::*current-condition*" 5 "controls" 12737 2
+"defcondition" 3 "controls" 12812 3
+"install-handler" 2 "controls" 13014 3
+"remove-handler" 2 "controls" 13315 3
+"handler-bind" 2 "controls" 13587 3
+"handler-case" 3 "controls" 13855 3
+"signals" 2 "controls" 14153 3
+"invoke-next-handler" 2 "controls" 14405 3
+"lisp::atomic" 3 "controls" 14666 3
"defclass" 3 "objects" 3223 3
"defmethod" 6 "objects" 3684 3
"defclassmethod" 3 "objects" 3859 2
@@ -184,47 +197,48 @@
"boundp" 2 "symbols" 3325 3
"fboundp" 2 "symbols" 3555 3
"makunbound" 2 "symbols" 3653 3
-"get" 2 "symbols" 3842 3
-"putprop" 2 "symbols" 4016 3
-"remprop" 2 "symbols" 4134 3
-"setq" 6 "symbols" 4227 3
-"set" 2 "symbols" 4544 3
-"defun" 6 "symbols" 4690 3
-"defmacro" 6 "symbols" 4911 3
-"defvar" 3 "symbols" 5058 3
-"defparameter" 3 "symbols" 5277 3
-"defconstant" 3 "symbols" 5455 3
-"keywordp" 2 "symbols" 5869 3
-"constantp" 2 "symbols" 5964 3
-"documentation" 2 "symbols" 6067 3
-"gensym" 2 "symbols" 6154 3
-"gentemp" 2 "symbols" 6603 3
-"*lisp-package*" 4 "symbols" 9167 2
-"*user-package*" 4 "symbols" 9211 2
-"*unix-package*" 4 "symbols" 9255 2
-"*system-package*" 4 "symbols" 9301 2
-"*keyword-package*" 4 "symbols" 9350 2
-"find-symbol" 2 "symbols" 9393 3
-"make-symbol" 2 "symbols" 9595 3
-"intern" 2 "symbols" 9689 3
-"list-all-packages" 2 "symbols" 9990 3
-"find-package" 2 "symbols" 10063 3
-"make-package" 2 "symbols" 10171 3
-"in-package" 2 "symbols" 10376 3
-"package-name" 2 "symbols" 10512 3
-"package-nicknames" 2 "symbols" 10599 3
-"rename-package" 2 "symbols" 10675 3
-"package-use-list" 2 "symbols" 10909 3
-"packagep" 2 "symbols" 10995 3
-"use-package" 2 "symbols" 11055 3
-"unuse-package" 2 "symbols" 11251 3
-"shadow" 2 "symbols" 11355 3
-"export" 2 "symbols" 11476 3
-"unexport" 2 "symbols" 12371 3
-"import" 2 "symbols" 12510 3
-"do-symbols" 3 "symbols" 12848 3
-"do-external-symbols" 3 "symbols" 13030 3
-"do-all-symbols" 3 "symbols" 13191 3
+"fmakunbound" 2 "symbols" 3850 3
+"get" 2 "symbols" 4049 3
+"putprop" 2 "symbols" 4223 3
+"remprop" 2 "symbols" 4341 3
+"setq" 6 "symbols" 4434 3
+"set" 2 "symbols" 4751 3
+"defun" 6 "symbols" 4897 3
+"defmacro" 6 "symbols" 5118 3
+"defvar" 3 "symbols" 5242 3
+"defparameter" 3 "symbols" 5461 3
+"defconstant" 3 "symbols" 5639 3
+"keywordp" 2 "symbols" 6053 3
+"constantp" 2 "symbols" 6148 3
+"documentation" 2 "symbols" 6251 3
+"gensym" 2 "symbols" 6338 3
+"gentemp" 2 "symbols" 6787 3
+"*lisp-package*" 4 "symbols" 9351 2
+"*user-package*" 4 "symbols" 9395 2
+"*unix-package*" 4 "symbols" 9439 2
+"*system-package*" 4 "symbols" 9485 2
+"*keyword-package*" 4 "symbols" 9534 2
+"find-symbol" 2 "symbols" 9577 3
+"make-symbol" 2 "symbols" 9779 3
+"intern" 2 "symbols" 9873 3
+"list-all-packages" 2 "symbols" 10174 3
+"find-package" 2 "symbols" 10247 3
+"make-package" 2 "symbols" 10355 3
+"in-package" 2 "symbols" 10560 3
+"package-name" 2 "symbols" 10696 3
+"package-nicknames" 2 "symbols" 10783 3
+"rename-package" 2 "symbols" 10859 3
+"package-use-list" 2 "symbols" 11093 3
+"packagep" 2 "symbols" 11179 3
+"use-package" 2 "symbols" 11239 3
+"unuse-package" 2 "symbols" 11435 3
+"shadow" 2 "symbols" 11539 3
+"export" 2 "symbols" 11660 3
+"unexport" 2 "symbols" 12555 3
+"import" 2 "symbols" 12694 3
+"do-symbols" 3 "symbols" 13032 3
+"do-external-symbols" 3 "symbols" 13214 3
+"do-all-symbols" 3 "symbols" 13375 3
"elt" 2 "sequences" 521 3
"length" 2 "sequences" 854 3
"subseq" 2 "sequences" 1335 3
@@ -277,111 +291,149 @@
"cdaar" 2 "sequences" 9975 3
"cdddr" 2 "sequences" 10045 3
"cddar" 2 "sequences" 10115 3
-"first" 2 "sequences" 10185 3
-"nth" 2 "sequences" 10330 3
-"nthcdr" 2 "sequences" 10507 3
-"last" 2 "sequences" 10589 3
-"butlast" 2 "sequences" 10666 3
-"cons" 2 "sequences" 10773 3
-"list" 2 "sequences" 10863 3
-"list*" 2 "sequences" 10932 3
-"list-length" 2 "sequences" 11101 3
-"make-list" 2 "sequences" 11197 3
-"rplaca" 2 "sequences" 11326 3
-"rplacd" 2 "sequences" 11440 3
-"memq" 2 "sequences" 11552 3
-"member" 2 "sequences" 11645 3
-"assq" 2 "sequences" 11968 2
-"assoc" 2 "sequences" 11998 3
-"rassoc" 2 "sequences" 12276 3
-"pairlis" 2 "sequences" 12382 3
-"acons" 2 "sequences" 12611 3
-"append" 2 "sequences" 12734 3
-"nconc" 2 "sequences" 12872 3
-"subst" 2 "sequences" 12989 3
-"flatten" 2 "sequences" 13083 3
-"push" 3 "sequences" 13352 3
-"pop" 3 "sequences" 13437 3
-"pushnew" 3 "sequences" 13571 3
-"adjoin" 2 "sequences" 13806 3
-"union" 2 "sequences" 13914 3
-"subsetp" 2 "sequences" 14027 3
-"intersection" 2 "sequences" 14226 3
-"set-difference" 2 "sequences" 14381 3
-"set-exclusive-or" 2 "sequences" 14561 3
-"list-insert" 2 "sequences" 14730 3
-"copy-tree" 2 "sequences" 14997 3
-"mapc" 2 "sequences" 15236 3
-"mapcar" 2 "sequences" 15463 3
-"mapcan" 2 "sequences" 15729 3
-"array-rank-limit" 4 "sequences" 17384 2
-"array-dimension-limit" 4 "sequences" 17461 2
-"vectorp" 2 "sequences" 17591 3
-"vector" 2 "sequences" 17787 3
-"make-array" 2 "sequences" 17889 3
-"svref" 2 "sequences" 18207 3
-"aref" 2 "sequences" 18329 3
-"vector-push" 2 "sequences" 18616 3
-"vector-push-extend" 2 "sequences" 18913 3
-"arrayp" 2 "sequences" 19085 3
-"array-total-size" 2 "sequences" 19171 3
-"fill-pointer" 2 "sequences" 19258 3
-"array-rank" 2 "sequences" 19390 3
-"array-dimensions" 2 "sequences" 19461 3
-"array-dimension" 2 "sequences" 19534 3
-"bit" 2 "sequences" 19657 3
-"bit-and" 2 "sequences" 19810 2
-"bit-ior" 2 "sequences" 19860 2
-"bit-xor" 2 "sequences" 19910 2
-"bit-eqv" 2 "sequences" 19960 2
-"bit-nand" 2 "sequences" 20011 2
-"bit-nor" 2 "sequences" 20061 2
-"bit-not" 2 "sequences" 20112 3
-"digit-char-p" 2 "sequences" 20603 3
-"alpha-char-p" 2 "sequences" 20692 3
-"upper-case-p" 2 "sequences" 20824 3
-"lower-case-p" 2 "sequences" 20913 3
-"alphanumericp" 2 "sequences" 21004 3
-"char-upcase" 2 "sequences" 21177 3
-"char-downcase" 2 "sequences" 21248 3
-"char" 2 "sequences" 21310 3
-"schar" 2 "sequences" 21393 3
-"stringp" 2 "sequences" 21569 3
-"string-upcase" 2 "sequences" 21678 3
-"string-downcase" 2 "sequences" 21795 3
-"nstring-upcase" 2 "sequences" 21911 3
-"nstring-downcase" 2 "sequences" 22002 3
-"string=" 2 "sequences" 22100 3
-"string-equal" 2 "sequences" 22241 3
-"string" 2 "sequences" 22390 3
-"string<" 2 "sequences" 22890 2
-"string<=" 2 "sequences" 22923 2
-"string>" 2 "sequences" 22955 2
-"string>=" 2 "sequences" 22988 2
-"string-left-trim" 2 "sequences" 23027 2
-"string-right-trim" 2 "sequences" 23066 3
-"string-trim" 2 "sequences" 23344 3
-"substringp" 2 "sequences" 23541 3
-"make-foreign-string" 2 "sequences" 24576 3
-"sxhash" 2 "sequences" 26186 3
-"make-hash-table" 2 "sequences" 26710 3
-"gethash" 2 "sequences" 26818 3
-"remhash" 2 "sequences" 27169 3
-"maphash" 2 "sequences" 27261 3
-"hash-table-p" 2 "sequences" 27358 3
-"hash-table" 0 "sequences" 27436 4
-":hash-function" 1 "sequences" 27924 3
-"queue" 0 "sequences" 28563 4
-":init" 1 "sequences" 28632 3
-":enqueue" 1 "sequences" 28702 3
-":dequeue" 1 "sequences" 28782 3
-":empty?" 1 "sequences" 28996 3
-":length" 1 "sequences" 29055 3
-":trim" 1 "sequences" 29112 3
-":search" 1 "sequences" 29196 3
-":delete" 1 "sequences" 29353 3
-":first" 1 "sequences" 29470 3
-":last" 1 "sequences" 29548 3
+"caaddr" 2 "sequences" 10186 3
+"caaadr" 2 "sequences" 10262 3
+"caadar" 2 "sequences" 10338 3
+"caaaar" 2 "sequences" 10414 3
+"cadadr" 2 "sequences" 10490 3
+"cadaar" 2 "sequences" 10566 3
+"cadddr" 2 "sequences" 10642 3
+"caddar" 2 "sequences" 10718 3
+"cdaddr" 2 "sequences" 10794 3
+"cdaadr" 2 "sequences" 10870 3
+"cdadar" 2 "sequences" 10946 3
+"cdaaar" 2 "sequences" 11022 3
+"cddadr" 2 "sequences" 11098 3
+"cddaar" 2 "sequences" 11174 3
+"cddddr" 2 "sequences" 11250 3
+"cdddar" 2 "sequences" 11326 3
+"first" 2 "sequences" 11401 3
+"second" 2 "sequences" 11471 3
+"third" 2 "sequences" 11541 3
+"fourth" 2 "sequences" 11611 3
+"fifth" 2 "sequences" 11681 3
+"sixth" 2 "sequences" 11750 3
+"seventh" 2 "sequences" 11821 3
+"eighth" 2 "sequences" 11893 3
+"ninth" 2 "sequences" 11963 3
+"tenth" 2 "sequences" 12032 3
+"nth" 2 "sequences" 12099 3
+"nthcdr" 2 "sequences" 12276 3
+"last" 2 "sequences" 12358 3
+"butlast" 2 "sequences" 12462 3
+"cons" 2 "sequences" 12569 3
+"list" 2 "sequences" 12659 3
+"list*" 2 "sequences" 12728 3
+"values" 2 "sequences" 12892 3
+"list-length" 2 "sequences" 12957 3
+"make-list" 2 "sequences" 13053 3
+"rplaca" 2 "sequences" 13182 3
+"rplacd" 2 "sequences" 13296 3
+"memq" 2 "sequences" 13408 3
+"member" 2 "sequences" 13501 3
+"assq" 2 "sequences" 13824 2
+"assoc" 2 "sequences" 13854 3
+"assoc-if" 2 "sequences" 14134 3
+"assoc-if-not" 2 "sequences" 14296 3
+"rassoc" 2 "sequences" 14461 3
+"rassoc-if" 2 "sequences" 14604 3
+"rassoc-if-not" 2 "sequences" 14724 3
+"pairlis" 2 "sequences" 14847 3
+"acons" 2 "sequences" 15076 3
+"append" 2 "sequences" 15199 3
+"nconc" 2 "sequences" 15337 3
+"subst" 2 "sequences" 15454 3
+"flatten" 2 "sequences" 15548 3
+"push" 3 "sequences" 15817 3
+"pop" 3 "sequences" 15902 3
+"pushnew" 3 "sequences" 16036 3
+"adjoin" 2 "sequences" 16271 3
+"union" 2 "sequences" 16379 3
+"subsetp" 2 "sequences" 16492 3
+"intersection" 2 "sequences" 16691 3
+"set-difference" 2 "sequences" 16846 3
+"set-exclusive-or" 2 "sequences" 17026 3
+"list-insert" 2 "sequences" 17195 3
+"list-delete" 2 "sequences" 17464 3
+"copy-tree" 2 "sequences" 17696 3
+"mapc" 2 "sequences" 17935 3
+"mapcar" 2 "sequences" 18162 3
+"mapcan" 2 "sequences" 18428 3
+"array-rank-limit" 4 "sequences" 20083 2
+"array-dimension-limit" 4 "sequences" 20160 2
+"vectorp" 2 "sequences" 20290 3
+"vector" 2 "sequences" 20486 3
+"make-array" 2 "sequences" 20588 3
+"svref" 2 "sequences" 20906 3
+"aref" 2 "sequences" 21028 3
+"vector-push" 2 "sequences" 21315 3
+"vector-push-extend" 2 "sequences" 21612 3
+"arrayp" 2 "sequences" 21784 3
+"array-total-size" 2 "sequences" 21870 3
+"fill-pointer" 2 "sequences" 21957 3
+"array-rank" 2 "sequences" 22089 3
+"array-dimensions" 2 "sequences" 22160 3
+"array-dimension" 2 "sequences" 22233 3
+"bit" 2 "sequences" 22356 3
+"bit-and" 2 "sequences" 22509 2
+"bit-ior" 2 "sequences" 22559 2
+"bit-xor" 2 "sequences" 22609 2
+"bit-eqv" 2 "sequences" 22659 2
+"bit-nand" 2 "sequences" 22710 2
+"bit-nor" 2 "sequences" 22760 2
+"bit-not" 2 "sequences" 22811 3
+"digit-char-p" 2 "sequences" 23302 3
+"alpha-char-p" 2 "sequences" 23391 3
+"upper-case-p" 2 "sequences" 23523 3
+"lower-case-p" 2 "sequences" 23612 3
+"alphanumericp" 2 "sequences" 23703 3
+"char-upcase" 2 "sequences" 23876 3
+"char-downcase" 2 "sequences" 23947 3
+"char=" 2 "sequences" 24010 3
+"char/=" 2 "sequences" 24082 3
+"char>" 2 "sequences" 24156 3
+"char<" 2 "sequences" 24231 3
+"char>=" 2 "sequences" 24307 3
+"char<=" 2 "sequences" 24384 3
+"char" 2 "sequences" 24457 3
+"schar" 2 "sequences" 24540 3
+"setchar" 2 "sequences" 24716 3
+"stringp" 2 "sequences" 24812 3
+"string-upcase" 2 "sequences" 24921 3
+"string-downcase" 2 "sequences" 25038 3
+"nstring-upcase" 2 "sequences" 25154 3
+"nstring-downcase" 2 "sequences" 25245 3
+"string=" 2 "sequences" 25343 3
+"string-equal" 2 "sequences" 25484 3
+"string" 2 "sequences" 25633 3
+"string<" 2 "sequences" 26134 3
+"string<=" 2 "sequences" 26231 3
+"string>" 2 "sequences" 26339 3
+"string>=" 2 "sequences" 26439 3
+"string-left-trim" 2 "sequences" 26556 2
+"string-right-trim" 2 "sequences" 26830 3
+"string-trim" 2 "sequences" 27099 3
+"substringp" 2 "sequences" 27297 3
+"make-foreign-string" 2 "sequences" 28332 3
+"sxhash" 2 "sequences" 29942 3
+"make-hash-table" 2 "sequences" 30466 3
+"gethash" 2 "sequences" 30574 3
+"remhash" 2 "sequences" 30925 3
+"maphash" 2 "sequences" 31017 3
+"hash-table-p" 2 "sequences" 31114 3
+"hash-table" 0 "sequences" 31192 4
+":hash-function" 1 "sequences" 31703 3
+"queue" 0 "sequences" 32342 4
+":init" 1 "sequences" 32411 3
+":enqueue" 1 "sequences" 32481 3
+":dequeue" 1 "sequences" 32561 3
+":empty?" 1 "sequences" 32775 3
+":length" 1 "sequences" 32834 3
+":trim" 1 "sequences" 32891 3
+":search" 1 "sequences" 32975 3
+":delete" 1 "sequences" 33132 3
+":first" 1 "sequences" 33249 3
+":last" 1 "sequences" 33327 3
"streamp" 2 "io" 483 3
"input-stream-p" 2 "io" 606 3
"output-stream-p" 2 "io" 698 3
@@ -462,217 +514,241 @@
"object-file-p" 2 "io" 32088 3
"directory" 2 "io" 32217 3
"dir" 2 "io" 32307 3
-"identity" 2 "evaluation" 1531 3
-"eval" 2 "evaluation" 1948 3
-"apply" 2 "evaluation" 2179 3
-"funcall" 2 "evaluation" 2705 3
-"quote" 6 "evaluation" 2871 3
-"function" 6 "evaluation" 2933 3
-"evalhook" 2 "evaluation" 3053 3
-"eval-dynamic" 2 "evaluation" 3186 3
-"macroexpand" 2 "evaluation" 3279 3
-"eval-when" 6 "evaluation" 3456 3
-"the" 6 "evaluation" 4375 3
-"declare" 6 "evaluation" 4516 3
-"proclaim" 2 "evaluation" 5560 3
-"warn" 2 "evaluation" 5822 3
-"error" 2 "evaluation" 5955 3
-"lisp::install-error-handler" 2 "evaluation" 6702 3
-"*prompt-string*" 5 "evaluation" 11860 2
-"*program-name*" 5 "evaluation" 11924 2
-"eustop" 2 "evaluation" 12036 3
-"eussig" 2 "evaluation" 12100 3
-"sigint-handler" 2 "evaluation" 12266 3
-"euserror" 2 "evaluation" 12388 3
-"reset" 2 "evaluation" 12518 3
-"exit" 2 "evaluation" 12603 3
-"*top-selector*" 5 "evaluation" 12768 2
-"h" 2 "evaluation" 12895 3
-"!" 2 "evaluation" 13007 3
-"new-history" 2 "evaluation" 13865 3
-"compile-file" 2 "evaluation" 19537 3
-"compile" 2 "evaluation" 20218 3
-"compile-file-if-src-newer" 2 "evaluation" 20469 3
-"compiler:*optimize*" 5 "evaluation" 20690 2
-"compiler:*verbose*" 5 "evaluation" 20751 2
-"compiler:*safety*" 5 "evaluation" 20911 2
-"load" 2 "evaluation" 21039 3
-"load-files" 2 "evaluation" 24466 3
-"*modules*" 5 "evaluation" 24568 2
-"provide" 2 "evaluation" 24657 3
-"require" 2 "evaluation" 24984 3
-"system:binload" 2 "evaluation" 25951 3
-"system::txtload" 2 "evaluation" 26143 2
-"describe" 2 "evaluation" 26240 3
-"describe-list" 2 "evaluation" 26373 3
-"inspect" 3 "evaluation" 26484 3
-"more" 2 "evaluation" 26729 3
-"break" 2 "evaluation" 27009 3
-"help" 2 "evaluation" 27213 3
-"apropos" 2 "evaluation" 27824 3
-"apropos-list" 2 "evaluation" 28193 3
-"constants" 2 "evaluation" 28323 3
-"variables" 2 "evaluation" 28472 3
-"functions" 2 "evaluation" 28626 3
-"btrace" 2 "evaluation" 28779 3
-"step-hook" 2 "evaluation" 28868 2
-"step" 2 "evaluation" 28895 3
-"trace" 2 "evaluation" 29019 3
-"untrace" 2 "evaluation" 29166 3
-"timing" 3 "evaluation" 29221 3
-"time" 3 "evaluation" 29352 3
-"sys:list-all-catchers" 2 "evaluation" 29452 3
-"sys:list-all-instances" 2 "evaluation" 29531 3
-"sys:list-all-bindings" 2 "evaluation" 29828 3
-"sys:list-all-special-bindings" 2 "evaluation" 29949 3
-"dump-object" 2 "evaluation" 30555 2
-"dump-structure" 2 "evaluation" 30603 3
-"dump-loadable-structure" 2 "evaluation" 30734 3
-"sys:save" 2 "evaluation" 31606 3
-"lisp-implementation-type" 2 "evaluation" 34316 3
-"lisp-implementation-version" 2 "evaluation" 34385 3
-"sys:gc" 2 "sysfunc" 4816 3
-"sys:*gc-hook*" 5 "sysfunc" 4947 2
-"sys:gctime" 2 "sysfunc" 5035 3
-"sys:alloc" 2 "sysfunc" 5238 3
-"sys:newstack" 2 "sysfunc" 5380 3
-"sys:*gc-merge*" 5 "sysfunc" 5493 2
-"sys:*gc-margin*" 5 "sysfunc" 5941 2
-"sys:reclaim" 2 "sysfunc" 6243 3
-"sys:reclaim-tree" 2 "sysfunc" 6400 3
-"sys::bktrace" 2 "sysfunc" 6506 3
-"sys:memory-report" 2 "sysfunc" 6615 3
-"sys:room" 2 "sysfunc" 6740 3
-"sys:address" 2 "sysfunc" 6839 3
-"sys:peek" 2 "sysfunc" 7008 3
-"sys:poke" 2 "sysfunc" 8001 3
-"sys:list-all-chunks" 2 "sysfunc" 8376 3
-"sys:object-size" 2 "sysfunc" 8486 3
-"unix:ptimes" 2 "sysfunc" 9597 3
-"unix:runtime" 2 "sysfunc" 9862 3
-"unix:localtime" 2 "sysfunc" 9969 3
-"unix:asctime" 2 "sysfunc" 10526 3
-"unix:getpid" 2 "sysfunc" 10799 3
-"unix:getppid" 2 "sysfunc" 10884 3
-"unix:getpgrp" 2 "sysfunc" 10959 3
-"unix:setpgrp" 2 "sysfunc" 11018 3
-"unix:getuid" 2 "sysfunc" 11075 3
-"unix:geteuid" 2 "sysfunc" 11134 3
-"unix:getgid" 2 "sysfunc" 11209 3
-"unix:getegid" 2 "sysfunc" 11276 3
-"unix:setuid" 2 "sysfunc" 11352 3
-"unix:setgid" 2 "sysfunc" 11427 3
-"unix:fork" 2 "sysfunc" 11506 3
-"unix:vfork" 2 "sysfunc" 11765 3
-"unix:exec" 2 "sysfunc" 11903 3
-"unix:wait" 2 "sysfunc" 11982 3
-"unix::exit" 2 "sysfunc" 12058 3
-"sys:*exit-hook*" 5 "sysfunc" 12194 2
-"unix:getpriority" 2 "sysfunc" 12294 3
-"unix:setpriority" 2 "sysfunc" 12466 3
-"unix:getrusage" 2 "sysfunc" 13065 3
-"unix:system" 2 "sysfunc" 14159 3
-"unix:getenv" 2 "sysfunc" 14295 3
-"unix:putenv" 2 "sysfunc" 14389 3
-"unix:sleep" 2 "sysfunc" 14556 3
-"unix:usleep" 2 "sysfunc" 14647 3
-"unix:uread" 2 "sysfunc" 14910 3
-"unix:write" 2 "sysfunc" 15367 3
-"unix:fcntl" 2 "sysfunc" 15548 2
-"unix:ioctl" 2 "sysfunc" 15595 2
-"unix:ioctl_" 2 "sysfunc" 15642 2
-"unix:ioctl_r" 2 "sysfunc" 15693 2
-"unix:ioctl_w" 2 "sysfunc" 15767 2
-"unix:ioctl_wr" 2 "sysfunc" 15842 2
-"unix:uclose" 2 "sysfunc" 15915 3
-"unix:dup" 2 "sysfunc" 15996 3
-"unix:pipe" 2 "sysfunc" 16077 3
-"unix:lseek" 2 "sysfunc" 16160 3
-"unix:link" 2 "sysfunc" 16307 3
-"unix:unlink" 2 "sysfunc" 16365 3
-"unix:mknod" 2 "sysfunc" 16503 3
-"unix:mkdir" 2 "sysfunc" 16621 3
-"unix:access" 2 "sysfunc" 16744 3
-"unix:stat" 2 "sysfunc" 16819 3
-"unix:chdir" 2 "sysfunc" 17378 3
-"unix:getwd" 2 "sysfunc" 17462 3
-"unix:chmod" 2 "sysfunc" 17521 3
-"unix:chown" 2 "sysfunc" 17609 3
-"unix:isatty" 2 "sysfunc" 17691 3
-"unix:msgget" 2 "sysfunc" 17831 3
-"unix:msgsnd" 2 "sysfunc" 17936 2
-"unix:msgrcv" 2 "sysfunc" 17996 2
-"unix:socket" 2 "sysfunc" 18051 3
-"unix:bind" 2 "sysfunc" 18316 3
-"unix:connect" 2 "sysfunc" 18474 3
-"unix:listen" 2 "sysfunc" 18578 3
-"unix:accept" 2 "sysfunc" 18777 3
-"unix:recvfrom" 2 "sysfunc" 18942 3
-"unix:sendto" 2 "sysfunc" 19337 3
-"unix:getservbyname" 2 "sysfunc" 19703 3
-"unix:gethostbyname" 2 "sysfunc" 19862 3
-"unix:syserrlist" 2 "sysfunc" 20005 3
-"unix:signal" 2 "sysfunc" 20178 3
-"unix:kill" 2 "sysfunc" 20589 3
-"unix:pause" 2 "sysfunc" 20674 3
-"unix:alarm" 2 "sysfunc" 20760 3
-"unix:ualarm" 2 "sysfunc" 20926 3
-"unix:getitimer" 2 "sysfunc" 21113 3
-"unix:setitimer" 2 "sysfunc" 21654 3
-"unix:select" 2 "sysfunc" 22000 3
-"unix:select-read-fd" 2 "sysfunc" 22842 3
-"unix:thr-self" 2 "sysfunc" 23376 3
-"unix:thr-getprio" 2 "sysfunc" 23467 3
-"unix:thr-setprio" 2 "sysfunc" 23570 3
-"unix:thr-getconcurrency" 2 "sysfunc" 23965 3
-"unix:thr-setconcurrency" 2 "sysfunc" 24111 3
-"unix:thr-create" 2 "sysfunc" 24700 3
-"unix:malloc" 2 "sysfunc" 25069 3
-"unix:free" 2 "sysfunc" 25149 3
-"unix:valloc" 2 "sysfunc" 25243 2
-"unix:mmap" 2 "sysfunc" 25273 2
-"unix:munmap" 2 "sysfunc" 25343 2
-"unix:vadvise" 2 "sysfunc" 25383 2
-"unix:tiocgetp" 2 "sysfunc" 26102 3
-"unix:tiocsetp" 2 "sysfunc" 26175 3
-"unix:tiocsetn" 2 "sysfunc" 26236 2
-"unix:tiocgetd" 2 "sysfunc" 26289 2
-"unix:tiocflush" 2 "sysfunc" 26344 3
-"unix:tiocgpgrp" 2 "sysfunc" 26404 3
-"unix:tiocspgrp" 2 "sysfunc" 26472 3
-"unix:tiocoutq" 2 "sysfunc" 26538 2
-"unix:fionread" 2 "sysfunc" 26579 2
-"unix:tiocsetc" 2 "sysfunc" 26620 2
-"unix:tioclbis" 2 "sysfunc" 26657 2
-"unix:tioclbic" 2 "sysfunc" 26694 2
-"unix:tioclset" 2 "sysfunc" 26731 2
-"unix:tioclget" 2 "sysfunc" 26768 2
-"unix:tcseta" 2 "sysfunc" 26804 3
-"unix:tcsets" 2 "sysfunc" 26883 3
-"unix:tcsetsw" 2 "sysfunc" 26951 3
-"unix:tcsetsf" 2 "sysfunc" 27080 3
-"unix:tiocsetc" 2 "sysfunc" 27259 2
-"unix:tcsetaf" 2 "sysfunc" 27298 2
-"unix:tcsetaw" 2 "sysfunc" 27337 2
-"unix:tcgeta" 2 "sysfunc" 27375 2
-"unix:tcgets" 2 "sysfunc" 27413 2
-"unix:tcgetattr" 2 "sysfunc" 27454 2
-"unix:tcsetattr" 2 "sysfunc" 27495 2
-"dbm-open" 2 "sysfunc" 28000 3
-"dbm-store" 2 "sysfunc" 28790 3
-"dbm-fetch" 2 "sysfunc" 29005 3
-"cd" 2 "sysfunc" 30445 3
-"ez" 2 "sysfunc" 30540 3
-"piped-fork" 2 "sysfunc" 30657 3
-"xfork" 2 "sysfunc" 31081 3
-"rusage" 2 "sysfunc" 31752 3
-"load-foreign" 3 "sysfunc" 38565 3
-"defforeign" 3 "sysfunc" 41123 3
-"defun-c-callable" 3 "sysfunc" 43642 3
-"pod-address" 2 "sysfunc" 44657 3
-"array-entity" 3 "sysfunc" 44922 3
-"float2double" 2 "sysfunc" 45205 3
-"double2float" 2 "sysfunc" 45424 3
+"identity" 2 "evaluation" 124 3
+"eval" 2 "evaluation" 541 3
+"apply" 2 "evaluation" 772 3
+"funcall" 2 "evaluation" 1298 3
+"quote" 6 "evaluation" 1464 3
+"function" 6 "evaluation" 1526 3
+"evalhook" 2 "evaluation" 1646 3
+"eval-dynamic" 2 "evaluation" 1779 3
+"macroexpand" 2 "evaluation" 1911 3
+"eval-when" 6 "evaluation" 2088 3
+"the" 6 "evaluation" 3007 3
+"declare" 6 "evaluation" 3148 3
+"proclaim" 2 "evaluation" 4192 3
+"warn" 2 "evaluation" 4454 3
+"error" 2 "evaluation" 4587 3
+"error" 0 "evaluation" 5340 4
+"argument-error" 0 "evaluation" 5441 4
+"program-error" 0 "evaluation" 5478 4
+"name-error" 0 "evaluation" 5512 4
+"type-error" 0 "evaluation" 5546 4
+"value-error" 0 "evaluation" 5581 4
+"index-error" 0 "evaluation" 5616 4
+"io-error" 0 "evaluation" 5648 4
+"assertion-error" 0 "evaluation" 5687 4
+"lisp::print-error-message" 2 "evaluation" 5736 3
+"interruption" 0 "evaluation" 5871 4
+"unix::signal-received" 0 "evaluation" 5921 4
+"unix::sigint-received" 0 "evaluation" 5970 4
+"unix::sigcont-received" 0 "evaluation" 6032 4
+"unix:install-signal-handler" 3 "evaluation" 6100 3
+"eussig" 2 "evaluation" 6464 3
+"*signal-handlers*" 5 "evaluation" 6693 2
+"*error-handler*" 5 "evaluation" 6773 2
+"*prompt-string*" 5 "evaluation" 12192 2
+"*program-name*" 5 "evaluation" 12256 2
+"eustop" 2 "evaluation" 12368 3
+"sigint-handler" 2 "evaluation" 12440 3
+"euserror" 2 "evaluation" 12616 3
+"reset" 2 "evaluation" 12740 3
+"exit" 2 "evaluation" 12859 3
+"*top-selector*" 5 "evaluation" 13024 2
+"h" 2 "evaluation" 13151 3
+"!" 2 "evaluation" 13263 3
+"new-history" 2 "evaluation" 14121 3
+"compile-file" 2 "evaluation" 21642 3
+"compile" 2 "evaluation" 22323 3
+"compile-method" 2 "evaluation" 22572 3
+"compile-file-if-src-newer" 2 "evaluation" 22891 3
+"compiler:*optimize*" 5 "evaluation" 23112 2
+"compiler:*safety*" 5 "evaluation" 23172 2
+"compiler:*verbose*" 5 "evaluation" 23227 2
+"compiler:*type-check-declare*" 5 "evaluation" 23399 2
+"compiler::compiler-implementation-version" 2 "evaluation" 23542 3
+"load" 2 "evaluation" 23731 3
+"load-files" 2 "evaluation" 27158 3
+"*modules*" 5 "evaluation" 27260 2
+"provide" 2 "evaluation" 27349 3
+"require" 2 "evaluation" 27676 3
+"system:binload" 2 "evaluation" 28643 3
+"system::txtload" 2 "evaluation" 28835 2
+"describe" 2 "evaluation" 28932 3
+"describe-list" 2 "evaluation" 29065 3
+"inspect" 3 "evaluation" 29176 3
+"more" 2 "evaluation" 29421 3
+"break" 2 "evaluation" 29701 3
+"help" 2 "evaluation" 29905 3
+"apropos" 2 "evaluation" 30516 3
+"apropos-list" 2 "evaluation" 30885 3
+"constants" 2 "evaluation" 31015 3
+"variables" 2 "evaluation" 31164 3
+"functions" 2 "evaluation" 31318 3
+"btrace" 2 "evaluation" 31471 3
+"step-hook" 2 "evaluation" 31560 2
+"step" 2 "evaluation" 31587 3
+"trace" 2 "evaluation" 31711 3
+"untrace" 2 "evaluation" 31858 3
+"timing" 3 "evaluation" 31913 3
+"time" 3 "evaluation" 32044 3
+"lisp::print-callstack" 2 "evaluation" 32144 3
+"sys:list-callstack" 2 "evaluation" 32398 3
+"sys:list-all-catchers" 2 "evaluation" 32592 3
+"sys:list-all-blocks" 2 "evaluation" 32668 3
+"sys:list-all-tags" 2 "evaluation" 32742 3
+"sys:list-all-instances" 2 "evaluation" 32823 3
+"sys:list-all-bindings" 2 "evaluation" 33120 3
+"sys:list-all-special-bindings" 2 "evaluation" 33338 3
+"sys:list-all-function-bindings" 2 "evaluation" 33455 3
+"dump-object" 2 "evaluation" 34191 2
+"dump-structure" 2 "evaluation" 34239 3
+"dump-loadable-structure" 2 "evaluation" 34370 3
+"sys:save" 2 "evaluation" 35242 3
+"lisp-implementation-type" 2 "evaluation" 37952 3
+"lisp-implementation-version" 2 "evaluation" 38021 3
+"sys:gc" 2 "sysfunc" 4597 3
+"sys:gctime" 2 "sysfunc" 4726 3
+"sys:alloc" 2 "sysfunc" 4943 3
+"sys:newstack" 2 "sysfunc" 5085 3
+"sys:*gc-debug*" 5 "sysfunc" 5198 2
+"sys:*gc-merge*" 5 "sysfunc" 5276 2
+"sys:*gc-margin*" 5 "sysfunc" 5724 2
+"sys:reclaim" 2 "sysfunc" 6026 3
+"sys:reclaim-tree" 2 "sysfunc" 6183 3
+"sys::bktrace" 2 "sysfunc" 6289 3
+"sys:memory-report" 2 "sysfunc" 6398 3
+"sys:room" 2 "sysfunc" 6523 3
+"sys:address" 2 "sysfunc" 6622 3
+"sys:peek" 2 "sysfunc" 6791 3
+"sys:poke" 2 "sysfunc" 7784 3
+"sys:list-all-chunks" 2 "sysfunc" 8159 3
+"sys:object-size" 2 "sysfunc" 8269 3
+"unix:ptimes" 2 "sysfunc" 9380 3
+"unix:runtime" 2 "sysfunc" 9645 3
+"unix:localtime" 2 "sysfunc" 9752 3
+"unix:asctime" 2 "sysfunc" 10309 3
+"unix:getpid" 2 "sysfunc" 10582 3
+"unix:getppid" 2 "sysfunc" 10667 3
+"unix:getpgrp" 2 "sysfunc" 10742 3
+"unix:setpgrp" 2 "sysfunc" 10801 3
+"unix:getuid" 2 "sysfunc" 10858 3
+"unix:geteuid" 2 "sysfunc" 10917 3
+"unix:getgid" 2 "sysfunc" 10992 3
+"unix:getegid" 2 "sysfunc" 11059 3
+"unix:setuid" 2 "sysfunc" 11135 3
+"unix:setgid" 2 "sysfunc" 11210 3
+"unix:fork" 2 "sysfunc" 11289 3
+"unix:vfork" 2 "sysfunc" 11548 3
+"unix:exec" 2 "sysfunc" 11686 3
+"unix:wait" 2 "sysfunc" 11765 3
+"unix::exit" 2 "sysfunc" 11841 3
+"sys:*exit-hook*" 5 "sysfunc" 11977 2
+"unix:getpriority" 2 "sysfunc" 12077 3
+"unix:setpriority" 2 "sysfunc" 12249 3
+"unix:getrusage" 2 "sysfunc" 12848 3
+"unix:system" 2 "sysfunc" 13942 3
+"unix:getenv" 2 "sysfunc" 14078 3
+"unix:putenv" 2 "sysfunc" 14172 3
+"unix:sleep" 2 "sysfunc" 14339 3
+"unix:usleep" 2 "sysfunc" 14430 3
+"unix:uread" 2 "sysfunc" 14693 3
+"unix:write" 2 "sysfunc" 15150 3
+"unix:fcntl" 2 "sysfunc" 15331 2
+"unix:ioctl" 2 "sysfunc" 15378 2
+"unix:ioctl_" 2 "sysfunc" 15425 2
+"unix:ioctl_r" 2 "sysfunc" 15476 2
+"unix:ioctl_w" 2 "sysfunc" 15550 2
+"unix:ioctl_wr" 2 "sysfunc" 15625 2
+"unix:uclose" 2 "sysfunc" 15698 3
+"unix:dup" 2 "sysfunc" 15779 3
+"unix:pipe" 2 "sysfunc" 15860 3
+"unix:lseek" 2 "sysfunc" 15943 3
+"unix:link" 2 "sysfunc" 16090 3
+"unix:unlink" 2 "sysfunc" 16148 3
+"unix:mknod" 2 "sysfunc" 16286 3
+"unix:mkdir" 2 "sysfunc" 16404 3
+"unix:access" 2 "sysfunc" 16527 3
+"unix:stat" 2 "sysfunc" 16602 3
+"unix:chdir" 2 "sysfunc" 17161 3
+"unix:getwd" 2 "sysfunc" 17245 3
+"unix:chmod" 2 "sysfunc" 17304 3
+"unix:chown" 2 "sysfunc" 17392 3
+"unix:isatty" 2 "sysfunc" 17474 3
+"unix:msgget" 2 "sysfunc" 17614 3
+"unix:msgsnd" 2 "sysfunc" 17719 2
+"unix:msgrcv" 2 "sysfunc" 17779 2
+"unix:socket" 2 "sysfunc" 17834 3
+"unix:bind" 2 "sysfunc" 18099 3
+"unix:connect" 2 "sysfunc" 18257 3
+"unix:listen" 2 "sysfunc" 18361 3
+"unix:accept" 2 "sysfunc" 18560 3
+"unix:recvfrom" 2 "sysfunc" 18725 3
+"unix:sendto" 2 "sysfunc" 19120 3
+"unix:getservbyname" 2 "sysfunc" 19486 3
+"unix:gethostbyname" 2 "sysfunc" 19645 3
+"unix:syserrlist" 2 "sysfunc" 19788 3
+"unix:signal" 2 "sysfunc" 19966 3
+"unix:kill" 2 "sysfunc" 20461 3
+"unix:pause" 2 "sysfunc" 20546 3
+"unix:alarm" 2 "sysfunc" 20632 3
+"unix:ualarm" 2 "sysfunc" 20928 3
+"unix:getitimer" 2 "sysfunc" 21167 3
+"unix:setitimer" 2 "sysfunc" 21708 3
+"unix:select" 2 "sysfunc" 22054 3
+"unix:select-read-fd" 2 "sysfunc" 22896 3
+"unix:thr-self" 2 "sysfunc" 23430 3
+"unix:thr-getprio" 2 "sysfunc" 23521 3
+"unix:thr-setprio" 2 "sysfunc" 23624 3
+"unix:thr-getconcurrency" 2 "sysfunc" 24019 3
+"unix:thr-setconcurrency" 2 "sysfunc" 24165 3
+"unix:thr-create" 2 "sysfunc" 24754 3
+"unix:malloc" 2 "sysfunc" 25123 3
+"unix:free" 2 "sysfunc" 25203 3
+"unix:valloc" 2 "sysfunc" 25297 2
+"unix:mmap" 2 "sysfunc" 25327 2
+"unix:munmap" 2 "sysfunc" 25397 2
+"unix:vadvise" 2 "sysfunc" 25437 2
+"unix:tiocgetp" 2 "sysfunc" 26156 3
+"unix:tiocsetp" 2 "sysfunc" 26229 3
+"unix:tiocsetn" 2 "sysfunc" 26290 2
+"unix:tiocgetd" 2 "sysfunc" 26343 2
+"unix:tiocflush" 2 "sysfunc" 26398 3
+"unix:tiocgpgrp" 2 "sysfunc" 26458 3
+"unix:tiocspgrp" 2 "sysfunc" 26526 3
+"unix:tiocoutq" 2 "sysfunc" 26592 2
+"unix:fionread" 2 "sysfunc" 26633 2
+"unix:tiocsetc" 2 "sysfunc" 26674 2
+"unix:tioclbis" 2 "sysfunc" 26711 2
+"unix:tioclbic" 2 "sysfunc" 26748 2
+"unix:tioclset" 2 "sysfunc" 26785 2
+"unix:tioclget" 2 "sysfunc" 26822 2
+"unix:tcseta" 2 "sysfunc" 26858 3
+"unix:tcsets" 2 "sysfunc" 26937 3
+"unix:tcsetsw" 2 "sysfunc" 27005 3
+"unix:tcsetsf" 2 "sysfunc" 27134 3
+"unix:tiocsetc" 2 "sysfunc" 27313 2
+"unix:tcsetaf" 2 "sysfunc" 27352 2
+"unix:tcsetaw" 2 "sysfunc" 27391 2
+"unix:tcgeta" 2 "sysfunc" 27429 2
+"unix:tcgets" 2 "sysfunc" 27467 2
+"unix:tcgetattr" 2 "sysfunc" 27508 2
+"unix:tcsetattr" 2 "sysfunc" 27549 2
+"dbm-open" 2 "sysfunc" 28054 3
+"dbm-store" 2 "sysfunc" 28844 3
+"dbm-fetch" 2 "sysfunc" 29059 3
+"cd" 2 "sysfunc" 30499 3
+"ez" 2 "sysfunc" 30594 3
+"piped-fork" 2 "sysfunc" 30711 3
+"xfork" 2 "sysfunc" 31135 3
+"rusage" 2 "sysfunc" 31806 3
+"load-foreign" 3 "sysfunc" 38619 3
+"defforeign" 3 "sysfunc" 41177 3
+"defun-c-callable" 3 "sysfunc" 43696 3
+"pod-address" 2 "sysfunc" 44711 3
+"array-entity" 3 "sysfunc" 44976 3
+"float2double" 2 "sysfunc" 45259 3
+"double2float" 2 "sysfunc" 45478 3
"float-vector" 2 "matrix" 389 3
"float-vector-p" 2 "matrix" 660 3
"v+" 2 "matrix" 724 3
@@ -1204,6 +1280,142 @@
":rgb" 1 "xwindow" 31889 3
":init" 1 "xwindow" 31976 3
"find-visual" 2 "xwindow" 32050 3
+"event" 5 "xtoolkit" 4114 2
+"next-event" 2 "xtoolkit" 4208 3
+"event-type" 2 "xtoolkit" 4366 3
+"event-window" 2 "xtoolkit" 5364 3
+"event-x" 2 "xtoolkit" 5451 3
+"event-y" 2 "xtoolkit" 5615 3
+"event-width" 2 "xtoolkit" 5781 3
+"event-height" 2 "xtoolkit" 5945 3
+"event-state" 2 "xtoolkit" 6108 3
+"display-events" 2 "xtoolkit" 6408 3
+"window-main-loop" 3 "xtoolkit" 6555 3
+"window-main-thread" 2 "xtoolkit" 6999 3
+"panel" 0 "xtoolkit" 7363 4
+":create" 1 "xtoolkit" 7790 3
+":items" 1 "xtoolkit" 8233 3
+":locate-item" 1 "xtoolkit" 8306 3
+":create-item" 1 "xtoolkit" 9054 3
+":delete-items" 1 "xtoolkit" 9608 3
+":create-menubar" 1 "xtoolkit" 9678 3
+":quit" 1 "xtoolkit" 10062 3
+":keypress" 1 "xtoolkit" 10162 3
+":keyrelease" 1 "xtoolkit" 10210 3
+":buttonpress" 1 "xtoolkit" 10259 3
+":buttonrelease" 1 "xtoolkit" 10310 3
+":motionnotify" 1 "xtoolkit" 10360 3
+":enternotify" 1 "xtoolkit" 10409 3
+":leavenotify" 1 "xtoolkit" 10458 3
+"menu-panel" 0 "xtoolkit" 10605 4
+":create" 1 "xtoolkit" 11904 3
+":create-item" 1 "xtoolkit" 12199 3
+"menubar-panel" 0 "xtoolkit" 12769 4
+"panel-item" 0 "xtoolkit" 16496 4
+":notify" 1 "xtoolkit" 16747 3
+":create" 1 "xtoolkit" 17671 3
+"button-item" 0 "xtoolkit" 17949 4
+":draw-label" 1 "xtoolkit" 18222 3
+":create" 1 "xtoolkit" 18345 3
+":buttonpress" 1 "xtoolkit" 18939 3
+":buttonrelease" 1 "xtoolkit" 19033 3
+"menu-button-item" 0 "xtoolkit" 19123 4
+":create" 1 "xtoolkit" 19617 3
+":buttonpress" 1 "xtoolkit" 19840 3
+":buttonrelease" 1 "xtoolkit" 19979 3
+"bitmap-button-item" 0 "xtoolkit" 20129 4
+":draw-label" 1 "xtoolkit" 20522 3
+":create" 1 "xtoolkit" 20647 3
+":draw-label" 1 "xtoolkit" 20892 3
+":create-bitmap-from-file" 1 "xtoolkit" 21023 3
+"choice-item" 0 "xtoolkit" 21165 4
+":create" 1 "xtoolkit" 21505 3
+":value" 1 "xtoolkit" 21956 3
+":draw-active-button" 1 "xtoolkit" 22291 3
+":buttonpress" 1 "xtoolkit" 22406 3
+":buttonrelease" 1 "xtoolkit" 22617 3
+"slider-item" 0 "xtoolkit" 22835 4
+":create" 1 "xtoolkit" 23424 3
+":value" 1 "xtoolkit" 23976 3
+"joystick-item" 0 "xtoolkit" 24313 4
+":create" 1 "xtoolkit" 24784 3
+":value" 1 "xtoolkit" 25480 3
+"text-item" 0 "xtoolkit" 27206 4
+":create" 1 "xtoolkit" 28032 3
+":getstring" 1 "xtoolkit" 28348 3
+"canvas" 0 "xtoolkit" 28732 4
+"textwindow" 0 "xtoolkit" 29982 4
+":init" 1 "xtoolkit" 30844 3
+":create" 1 "xtoolkit" 30920 3
+":cursor" 1 "xtoolkit" 31366 3
+":clear" 1 "xtoolkit" 31759 3
+":clear-eol" 1 "xtoolkit" 31808 3
+":clear-lines" 1 "xtoolkit" 32004 3
+":clear-eos" 1 "xtoolkit" 32105 3
+":win-row-max" 1 "xtoolkit" 32269 3
+":win-col-max" 1 "xtoolkit" 32364 3
+":xy" 1 "xtoolkit" 32452 3
+":goto" 1 "xtoolkit" 32595 3
+":goback" 1 "xtoolkit" 32706 3
+":advance" 1 "xtoolkit" 32787 3
+":scroll" 1 "xtoolkit" 32877 3
+":horizontal-scroll" 1 "xtoolkit" 32977 3
+":newline" 1 "xtoolkit" 33070 3
+":putch" 1 "xtoolkit" 33143 3
+":putstring" 1 "xtoolkit" 33368 3
+":event-row" 1 "xtoolkit" 33515 3
+":event-col" 1 "xtoolkit" 33549 3
+":keypress" 1 "xtoolkit" 33942 3
+"textwindowstream" 0 "xtoolkit" 34226 4
+":flush" 1 "xtoolkit" 34516 3
+"make-text-window-stream" 2 "xtoolkit" 34717 3
+"buffertextwindow" 0 "xtoolkit" 34811 4
+":line" 1 "xtoolkit" 35364 3
+":nlines" 1 "xtoolkit" 35448 3
+":all-lines" 1 "xtoolkit" 35517 3
+":refresh-line" 1 "xtoolkit" 35600 3
+":refresh" 1 "xtoolkit" 35718 3
+":insert-string" 1 "xtoolkit" 35832 3
+":insert" 1 "xtoolkit" 35909 3
+":delete" 1 "xtoolkit" 35974 3
+"expand-tab" 2 "xtoolkit" 36132 3
+"scrolltextwindow" 0 "xtoolkit" 36319 4
+":create" 1 "xtoolkit" 36814 3
+":locate" 1 "xtoolkit" 37297 3
+":display-selection" 1 "xtoolkit" 37419 3
+":selection" 1 "xtoolkit" 37569 3
+":read-file" 1 "xtoolkit" 37634 3
+":display-string" 1 "xtoolkit" 37832 3
+":scroll" 1 "xtoolkit" 38068 3
+":horizontal-scroll" 1 "xtoolkit" 38140 3
+":buttonrelease" 1 "xtoolkit" 38413 3
+":resize" 1 "xtoolkit" 38612 3
+"sys:make-thread" 2 "mthread" 12293 3
+"sys:*threads*" 5 "mthread" 12881 2
+"sys::free-threads" 2 "mthread" 12980 3
+"sys:thread" 2 "mthread" 13257 3
+"sys:thread-no-wait" 2 "mthread" 14009 3
+"sys:wait-thread" 2 "mthread" 14213 3
+"sys:plist" 3 "mthread" 14577 3
+"sys:make-mutex-lock" 2 "mthread" 15283 3
+"sys:mutex-lock" 2 "mthread" 15415 3
+"sys:mutex-unlock" 2 "mthread" 15595 3
+"sys:mutex" 3 "mthread" 15715 3
+"sys:make-cond" 2 "mthread" 16345 3
+"sys:cond-wait" 2 "mthread" 16508 3
+"sys:cond-signal" 2 "mthread" 16723 3
+"sys:make-semaphore" 2 "mthread" 16811 3
+"sys:sema-post" 2 "mthread" 16928 3
+"sys:sema-wait" 2 "mthread" 16980 3
+"sys:barrier-synch" 0 "mthread" 17066 4
+":init" 1 "mthread" 17903 3
+":add" 1 "mthread" 18020 3
+":remove" 1 "mthread" 18102 3
+":wait" 1 "mthread" 18185 3
+"sys:synch-memory-port" 0 "mthread" 18294 4
+":read" 1 "mthread" 18547 3
+":write" 1 "mthread" 18670 3
+":init" 1 "mthread" 18896 3
"make-equilevel-lut" 2 "image" 509 3
"look-up" 2 "image" 782 3
"look-up2" 2 "image" 1079 3
diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex
index f4e08d7b5..1c6efc548 100644
--- a/doc/latex/evaluation.tex
+++ b/doc/latex/evaluation.tex
@@ -3,35 +3,6 @@ \section{Evaluation}
\subsection{Evaluators}
-In order to specify the behaviors upon an error and an interrupt(signal),
-set an appropriate function to each of the special variables
-{\bf *error-handler*} and {\bf *signal-handler*} in advance.
-There is no correctable or continue-able error.
-After analyzing errors you must abort the current execution by
-{\bf reset} or appropriate {\bf throw} to upper level catchers.
-{\bf reset} is equivalent to {\tt (throw 0 NIL)}, since EusLisp's top-level
-creates catch frame named {\tt 0}.
-
-Error handlers should be programmed as functions with three or four
-arguments: {\em code msg1 form \&optional (msg2)}.
-{\em Code} is the error code which identifies system defined errors,
-such as 14 for 'mismatch argument' or 13 for 'undefined function'.
-These mappings are described in "c/eus.h".
-{\em msg1} and {\em msg1} are messages displayed to the user.
-{\em form} is the S-expression which caused the error.
-
-Signal handlers should be programmed as functions receiving
-two arguments: {\em sig} and {\em code}.
-{\em Sig} is the signal number ranging from 1 to 31, and {\em code}
-is the minor signal code defined in signal-number dependent manners.
-
-\verb+^+D ({\em end-of-file}) at the top-level terminates eus session.
-This is useful when eus is programmed as a filter.
-
-{\bf Eval-dynamic} is the function to find the dynamic value bound
-to a symbol used as a let or lambda variable.
-This is useful for debugging.
-
\begin{refdesc}
\funcdesc{identity}{obj}{
@@ -75,7 +46,8 @@ \subsection{Evaluators}
evaluates {\em form} once after binding {\em hookfunc} to {\bf *evalhook*}.}
\funcdesc{eval-dynamic}{variable}{
-finds the value of {\em variable} (symbol) on the stack.}
+finds the dynamic value bound to {\em variable} (symbol) on the stack.
+Is useful for debugging.}
\funcdesc{macroexpand}{form}{
expands {\em form} if it is a macro call.
@@ -135,27 +107,57 @@ \subsection{Evaluators}
prints warning-message given as {\em format-string} and {\em args} to
*error-output*.}
-\funcdesc{error}{format-string \&rest args}{
-calls the current error-handler function bound to {\bf *error-handler*}.
-The default error-handler 'euserror' first
-prints arguments to {\bf *error-output*} using {\bf format},
-then enters a new top level session.
-The prompt shows you the depth of your error session.
-{\bf Throw}ing to the number, you can go back to the lower level error
-session.}
+\funcdesc{error}{message-or-class \&rest format-args}{
+Signals an error condition with message {\em message-or-class}.
+Other error conditions can be signalizing by designating an error class to {\em message-or-class}, in which case the second argument is required to designate the message.}
\end{refdesc}
-In the multithread EusLisp, special variables are shared among threads
-and the same {\bf *error-handler*} is referenced by different threads.
-To avoid this inconvenience, multithread EusLisp provides
-the {\bf install-error-handler} function which installs different
-error handler for each thread.
+\newpage
+
+\subsection{Handling Errors and Unix Signals}
+
+Condition handlers can be used to specify the behaviors upon an error or an interruption signal (sigint). In EusLisp the following condition classes are defined, and the macro {\bf unix:install-signal-handler} helps introducing new conditions to unix signals. By default errors are handled by {\bf euserror} and interruption signals by {\bf lisp::interruption-handler}.
\begin{refdesc}
-\funcdesc{lisp::install-error-handler}{handler}{
-installs the {\em handler} as the error handler of the current thread.}
+\classdesc{error}{condition}{callstack form}{
+ The most basic class for signaling errors.}
+\classdesc{argument-error}{error}{}{}
+\classdesc{program-error}{error}{}{}
+\classdesc{name-error}{error}{}{}
+\classdesc{type-error}{error}{}{}
+\classdesc{value-error}{error}{}{}
+\classdesc{index-error}{error}{}{}
+\classdesc{io-error}{error}{}{}
+\classdesc{assertion-error}{error}{}{}
+
+\funcdesc{lisp::print-error-message}{err \&optional (os *error-output*)}{
+Formats the message of {\em err} object to the output stream {\em os}.}
+
+\classdesc{interruption}{condition}{}{}
+
+\classdesc{unix::signal-received}{condition}{}{}
+\classdesc{unix::sigint-received}{unix::signal-received}{}{}
+\classdesc{unix::sigcont-received}{unix::signal-received}{}{}
+
+\macrodesc{unix:install-signal-handler}{sig obj \&rest init-args}{
+Defines the condition {\em obj} and signalizes it every time the unix signal {\em sig} is received.
+The condition class is defined as a child of {\em unix::signal-received} and the instances signalized are initialized with {\em init-args}.}
+
+The following handling methods are also defined for backward compatibility.
+
+\funcdesc{eussig}{sig code}{
+Is the default signal hander for SIGPIPE.
+After evaluating the corresponding handler function stored in {\bf *signal-handlers*}, prints the signal number and enters another toplevel loop.}
+
+\vardesc{*signal-handlers*}{
+Vector with all the handlers used by {\bf eussig}.}
+
+\vardesc{*error-handler*}{
+If non-nil, specifies a handling function to be called when an error occurs.
+The handling function takes four arguments: the error code (number), the error message, the error form (evaluated expression), and an optional message with additional information.}
+
\end{refdesc}
\newpage
@@ -242,7 +244,7 @@ \subsection{Top-level Interaction}
% and you can edit the line interactively with control keys,
% as in emacs. (can no more (?))
-\verb+^+D (EOF) terminates EusLisp normally.
+\verb+^+D (EOF) terminates the current reploop, going back to previous replevels or terminating the program itself on toplevel.
To return abnormal termination code to upper level (usually a csh),
use {\bf exit} with an appropriate condition code.
@@ -288,21 +290,15 @@ \subsection{Top-level Interaction}
\funcdesc{eustop}{\&rest argv}{
is the default toplevel loop.}
-\funcdesc{eussig}{sig code}{
-is the default signal hander for SIGPIPE.
-{\bf eussig} prints signal number upon its arrival and enters
-another toplevel loop.}
-
-\funcdesc{sigint-handler}{sig code}{
+\funcdesc{sigint-handler}{c}{
is the default signal handler for SIGINT (control-C).
-It enters a new top level session.}
+It signalizes an {\it interruption} condition, which by default enters a new top level session.}
-\funcdesc{euserror}{code message \&rest arg}{
-the default error handler that
-prints {\em message} and enters a new error session.}
+\funcdesc{euserror}{err}{
+the default error handler that prints {\em err} callstack, message and enters a new error session.}
-\funcdesc{reset}{}{
-quits error loop and goes back to the outermost eustop session.}
+\funcdesc{reset}{\&optional (n 0)}{
+quits error loop and goes back to the {\em n}\textsuperscript{th} eustop session.}
\funcdesc{exit}{\&optional termination-code}{
terminates EusLisp process and returns {\em termination-code} (0..255)
@@ -352,12 +348,12 @@ \subsection{Compilation}\label{compiler}
Sometimes proper type declarations are needed to inform
the compiler applicability of optimization.
-{\bf Compile-function} compiles functions one by one.
+{\bf Compile} compiles functions one by one.
{\bf Compile-file} compiles an entire source file.
-During the execution of {\bf Compile-file}, each form in a file
+During the execution of {\bf compile-file}, each form in a file
is read and evaluated.
This may change the current EusLisp environment.
-For examples, {\bf defparameter}
+For example, {\bf defparameter}
may set a new value to a symbol and {\bf defun} may substitute the existing
compiled function with its non-compiled version.
To avoid these unexpected effects, use the {\bf eval-when} special form
@@ -445,6 +441,40 @@ \subsection{Compilation}\label{compiler}
In order to analyze compiled code, see the intermediate C program
or use {\tt adb}.
+\subsubsection{Closure Compilation}
+
+When a closure is created, the compiler must move the current local bindings present in stack memory to heap memory. This allows for the stable execution of closures even from outside their original scope: the bindings remain valid while being referenced by the closure object, and are collected by the garbage collector when the reference ends.
+
+However, it is not optimal to move all of the local bindings to the heap. In order to deal with that, the compiler adopts a look-ahead technique to only keep the minimal required references in the heap.
+
+For example, when considering the following code:
+\begin{verbatim}
+(let ((a 1) (b 2) (c 3))
+ (setq fn1 #'(lambda () (1+ a))))
+\end{verbatim}
+
+The generated code is as follows. Note how a vector of size 1 is allocated to hold the value of variable {\em a}, the only binding used in the closure. The second generated vector is used by the compiler to bundle and administer all of the other binding vectors, in a way that is shareable among different closure objects. The size of this second vector is set to the current size of the stack at the allocation time. This is done for practical reasons in order to keep the same reference index both inside and outside the closure, still having room for optimization.
+
+\begin{verbatim}
+ local[0]= makeint((eusinteger_t)1L);
+ local[1]= makeint((eusinteger_t)2L);
+ local[2]= makeint((eusinteger_t)3L);
+ ctx->vsp=local+3;
+ ctx->vsp=local+3;
+ local[3]= makevector(C_VECTOR,1); /*parlet*/
+ local[3]->c.vec.v[0]= local[0];
+ ctx->vsp=local+4;
+ local[4]= makevector(C_VECTOR,4); /*lambda-closure*/
+ local[4]->c.vec.v[3] = local[3];
+ w = local[4];
+ ctx->vsp=local+4;
+ local[4]= makeclosure(codevec,quotevec,testCLO1,NIL,w);
+ storeglobal(fqv[0],local[4]);
+ w = local[4];
+ local[0]= NIL;
+ ctx->vsp=local; return(local[0]);
+\end{verbatim}
+
\begin{refdesc}
\functiondescription{euscomp}{\&rest filename}{unix-command}{
@@ -464,9 +494,15 @@ \subsection{Compilation}\label{compiler}
{\em :Pic} should be set T, unless the module is hard-linked in the
EusLisp core during the make stage.}
-\funcdesc{compile}{funcname}{
+\funcdesc{compile}{\&rest funcnames}{
compiles a function.
-{\bf Compile} first prints the function definition into a temporary file.
+{\bf Compile} first prints the function definitions into a temporary file.
+The file is compiled by {\bf compile-file} and then is loaded by {\bf load}.
+Temporary files are deleted.}
+
+\funcdesc{compile-method}{obj \&rest meths}{
+compiles the methods {\em meths} of the class or object instance {\em obj}.
+{\bf Compile-method} first prints the method definition into a temporary file.
The file is compiled by {\bf compile-file} and then is loaded by {\bf load}.
Temporary files are deleted.}
@@ -478,13 +514,18 @@ \subsection{Compilation}\label{compiler}
\vardesc{compiler:*optimize*}{
controls optimization level.}
+\vardesc{compiler:*safety*}{
+controls safety level.}
+
\vardesc{compiler:*verbose*}{
When set to non-nil, the name of a function or a method being compiled,
and the time required for the compilation are displayed.}
-\vardesc{compiler:*safety*}{
-controls safety level.}
+\vardesc{compiler:*type-check-declare*}{
+When set to non-nil, will add type checks for declared variables on the compiled code.}
+\funcdesc{compiler::compiler-implementation-version}{}{
+Returns a string detailing the compiler version. ``EusLisp compiler version 1.54''}
\end{refdesc}
\newpage
@@ -695,19 +736,40 @@ \subsection{Debugging Aid}
\macrodesc{time}{function}{
begins measurement of time elapsed by {\em function}.}
+\funcdesc{lisp::print-callstack}{\&optional (stack (sys:list-callstack)) max (os *error-output*)}{
+formats the upmost {\em max} elements of the callstack {\em stack} into the output stream {\em os}.
+If {\em max} is {\it nil} formats all elements instead.}
+
+\funcdesc{sys:list-callstack}{\&optional max}{
+returns a list of the upmost {\em max} elements of the current callstack.
+If {\em max} is not provided return a list of all elements instead.}
+
\funcdesc{sys:list-all-catchers}{}{
returns a list of all {\bf catch} tags.}
+\funcdesc{sys:list-all-blocks}{}{
+returns a list of all {\bf block} tags.}
+
+\funcdesc{sys:list-all-tags}{}{
+returns a list of all {\bf tagbody} tags.}
+
\funcdesc{sys:list-all-instances}{aclass \&optional scan-sub}{
scans in the overall heap, and collects all the instances of the specified class.
If {\em scan-sub} is NIL, then instances of exactly the {\em aclass} are
listed, otherwise, instances of {\em aclass} or its subclasses are collected.}
-\funcdesc{sys:list-all-bindings}{}{
-scans bind stack, and returns a list of all the accessible value bindings.}
+\funcdesc{sys:list-all-bindings}{\&optional bindframe}{
+returns a list of all value bindings in {\em bindframe}.
+If {\em bindframe} is not provided, returns a list of all value bindings
+in the current stack.}
\funcdesc{sys:list-all-special-bindings}{}{
-scans the stack and list up all value bindings.}
+return a list of all the special value bindings in the current stack.}
+
+\funcdesc{sys:list-all-function-bindings}{\&optional fletframe}{
+returns a list of all function bindings in {\em fletframe}.
+If {\em fletframe} is not provided, returns a list of all function bindings
+in the current stack.}
\end{refdesc}
diff --git a/doc/latex/generals.tex b/doc/latex/generals.tex
index 279cf77a1..0338662df 100644
--- a/doc/latex/generals.tex
+++ b/doc/latex/generals.tex
@@ -542,15 +542,15 @@ \subsection{Special Forms}
\begin{center}
{\large
\begin{tabular}{|l l l|} \hline
-and & flet & quote \\
-block & function & return-from\\
-catch & go & setq \\
-cond & if & tagbody \\
-declare & labels & the \\
-defmacro & let & throw \\
-defmethod & let* & unwind-protect \\
-defun & progn & while \\
-eval-when & or & \\
+and & flet & progn \\
+block & function & quote\\
+catch & go & return-from\\
+cond & if & setq\\
+declare & labels & tagbody\\
+defmacro & let & the\\
+defmethod & let* & throw\\
+defun & macrolet & unwind-protect\\
+eval-when & or & while\\
\hline
\end{tabular} }
\end{center}
@@ -558,7 +558,7 @@ \subsection{Special Forms}
\end{table}
All the special forms are listed in Table \ref{SpecialForms}.
-{\bf macrolet, compiler-let,} and {\bf progv} have not been implemented.
+{\bf symbol-macrolet, compiler-let,} and {\bf progv} have not been implemented.
Special forms are essential language constructs for the management of
evaluation contexts and control flows.
The interpreter and compiler have special knowledge to
@@ -611,7 +611,19 @@ \subsection{Functions}
Each of {\bf \&optional, \&rest, \&key } and {\bf \&aux} has special
meaning in lambda-lists, and these symbols cannot be used as variable
names.
-Supplied-p variables for \&optional or \&key parameters are not supported.
+Supplied-p variables for \&optional or \&key parameters are also supported starting
+from version 10.
+
+\begin{verbatim}
+(defun foo (&optional (a nil a-p))
+ (list a a-p))
+(foo 1)
+--> (1 t)
+(foo nil)
+--> (nil t)
+(foo)
+--> (nil nil)
+\end{verbatim}
Since a lambda form is indistinguishable from normal list data,
{\bf function} special form must be used to inform the interpreter and
@@ -652,26 +664,32 @@ \subsection{Functions}
(vector-sum #(1 2 3 4)) --> 10
\end{verbatim}
-EusLisp's closure cannot have indefinite extent:
-i.e. a closure can only survive as long as its outer extent is in effect.
-This means that a closure cannot be used for programming of ``generators".
-The following program does not work.
+\subsection{Closures}
+
+Closures are functions which inherit the lexical scope in which they were created.
+In many ways they behave similarly to classes, with local variable and function bindings.
+However, differently from EusLisp classes, all bindings in a closure can only be accessed
+internally (i.e. are ``private'').
\begin{verbatim}
-(proclaim '(special gen))
(let ((index 0))
(setq gen #'(lambda () (setq index (1+ index)))))
(funcall gen)
+--> 1
+(funcall gen)
+--> 2
\end{verbatim}
-However, the same purpose is accomplished by object oriented programming,
-because an object can hold its own static variables:
+A similar example using classes is shown below.
\begin{verbatim}
-(defclass generator object (index))
+(defclass generator :super object :slots (index))
(defmethod generator
(:next () (setq index (1+ index)))
(:init (&optional (start 0)) (setq index start) self))
(defvar gen (instance generator :init 0))
(send gen :next)
+--> 1
+(send gen :next)
+--> 2
\end{verbatim}
\newpage
diff --git a/doc/latex/intro.tex b/doc/latex/intro.tex
index 4a1e63a36..afe2747b6 100644
--- a/doc/latex/intro.tex
+++ b/doc/latex/intro.tex
@@ -90,7 +90,7 @@ \section{Introduction}
memory efficiency without sacrificing runtime or garbage-collection
performance.
-This reference manual describes EusLisp version 7.27 in two parts,
+This reference manual describes EusLisp in two parts,
{\em EusLisp Basics and EusLisp Extensions}.
The first part describes Common Lisp features and object-oriented
programming. Since a number of literatures are available on both topics,
@@ -218,18 +218,12 @@ \subsection{Compatibility with Common Lisp}
multiple-value-call,multiple-value-prog1, etc., are present only
in a limited way;
\item some of data types:
- bignum, character, deftype, complex number and ratio (the last
+ bignum, character, deftype, complex number, and ratio (the last
two are present only in a limited way);
\item some of special forms:
- progv, compiler-let,macrolet
-\end{enumerate}
-
-Following features are incomplete:
-\begin{enumerate}
-\setcounter{enumi}{3}
-\item closure -- only valid for dynamic extent
-%\item package -- no shadowing-list
-\item declare,proclaim -- inline and ignore are unrecognized
+ progv, compiler-let, symbol-macrolet
+\item inline, ignore, declare, and proclaim (the last
+ two are present only in a limited way);
\end{enumerate}
\subsection{Revision History}
diff --git a/doc/latex/mthread.tex b/doc/latex/mthread.tex
index ad85972b3..23d0c963c 100644
--- a/doc/latex/mthread.tex
+++ b/doc/latex/mthread.tex
@@ -282,7 +282,7 @@ \subsection{Thread creation}
\begin{refdesc}
-\funcdesc{sys:make-thread}{num \&optional (lsize 32*1024) (csize lsize)}{
+\funcdesc{sys:make-thread}{\&optional (num 1) (lsize 32*1024) (csize lsize)}{
creates {\em num} threads with {\em lsize} words of Lisp stack
and {\em csize} words of C stack, and put them in the system's
thread pool.
diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex
index ab94ba857..2fc552686 100644
--- a/doc/latex/sequences.tex
+++ b/doc/latex/sequences.tex
@@ -261,10 +261,83 @@ \subsection{Lists}
\funcdesc{cddar}{list}{
{\tt (cddar list) = (cdr (cdr (car list)))}}
+\funcdesc{caaddr}{list}{
+{\tt (caddr list) = (car (car (cdr (cdr list)))}}
+
+\funcdesc{caaadr}{list}{
+{\tt (caadr list) = (car (car (car (cdr list)))}}
+
+\funcdesc{caadar}{list}{
+{\tt (cadar list) = (car (car (cdr (car list)))}}
+
+\funcdesc{caaaar}{list}{
+{\tt (caaar list) = (car (car (car (car list)))}}
+
+\funcdesc{cadadr}{list}{
+{\tt (cdadr list) = (car (cdr (car (cdr list)))}}
+
+\funcdesc{cadaar}{list}{
+{\tt (cdaar list) = (car (cdr (car (car list)))}}
+
+\funcdesc{cadddr}{list}{
+{\tt (cdddr list) = (car (cdr (cdr (cdr list)))}}
+
+\funcdesc{caddar}{list}{
+{\tt (cddar list) = (car (cdr (cdr (car list)))}}
+
+\funcdesc{cdaddr}{list}{
+{\tt (caddr list) = (cdr (car (cdr (cdr list)))}}
+
+\funcdesc{cdaadr}{list}{
+{\tt (caadr list) = (cdr (car (car (cdr list)))}}
+
+\funcdesc{cdadar}{list}{
+{\tt (cadar list) = (cdr (car (cdr (car list)))}}
+
+\funcdesc{cdaaar}{list}{
+{\tt (caaar list) = (cdr (car (car (car list)))}}
+
+\funcdesc{cddadr}{list}{
+{\tt (cdadr list) = (cdr (cdr (car (cdr list)))}}
+
+\funcdesc{cddaar}{list}{
+{\tt (cdaar list) = (cdr (cdr (car (car list)))}}
+
+\funcdesc{cddddr}{list}{
+{\tt (cdddr list) = (cdr (cdr (cdr (cdr list)))}}
+
+\funcdesc{cdddar}{list}{
+{\tt (cddar list) = (cdr (cdr (cdr (car list)))}}
+
\funcdesc{first}{list}{
-retrieves the first element in {\em list}.
-\bfx{second, third, fourth, fifth, sixth, seventh, eighth} are als
-available.}
+retrieves the first element in {\em list}.}
+
+\funcdesc{second}{list}{
+retrieves the second element in {\em list}.}
+
+\funcdesc{third}{list}{
+retrieves the third element in {\em list}.}
+
+\funcdesc{fourth}{list}{
+retrieves the fourth element in {\em list}.}
+
+\funcdesc{fifth}{list}{
+retrieves the fifth element in {\em list}.}
+
+\funcdesc{sixth}{list}{
+retrieves the sixth element in {\em list}.}
+
+\funcdesc{seventh}{list}{
+retrieves the seventh element in {\em list}.}
+
+\funcdesc{eighth}{list}{
+retrieves the eighth element in {\em list}.}
+
+\funcdesc{ninth}{list}{
+retrieves the ninth element in {\em list}.}
+
+\funcdesc{tenth}{list}{
+retrieves the tenth element in {\em list}.}
\funcdesc{nth}{count list}{
returns the {\em count}-th element in {\em list}.
@@ -274,8 +347,8 @@ \subsection{Lists}
\funcdesc{nthcdr}{count list}{
applies {\bf cdr} {\em count} times to {\em list}.}
-\funcdesc{last}{list}{
-the last cons is returned, not the last element.}
+\funcdesc{last}{list \&optional (n 1)}{
+the last {\em n} conses is returned, not the last element.}
\funcdesc{butlast}{list \&optional (n 1)}{
returns a list which does not contain the last {\em n} elements.}
@@ -290,6 +363,9 @@ \subsection{Lists}
makes a list of {\em elements}, but the last element is consed in cdr:
for example, {\tt (list* 1 2 3 '(4 5)) = (1 2 3 4 5)}.}
+\funcdesc{values}{\&rest elements}{
+alias for {\em list}.}
+
\funcdesc{list-length}{list}{
returns the length of the {\em list}. {\em List} can be circular.}
@@ -320,9 +396,23 @@ \subsection{Lists}
first pair in the {\em alist} such that the {\em car} of the pair satisfies
the {\em test}, or NIL if there is no such pair in the {\em alist}.}
-\funcdesc{rassoc}{item alist}{
+\funcdesc{assoc-if}{pred alist \&key key}{
+returns the first pair in {\em alist} whose {\em car} satisfies
+the {\em pred}, or NIL if there is no such pair.}
+
+\funcdesc{assoc-if-not}{pred alist \&key key}{
+returns the first pair in {\em alist} whose {\em car} DOES NOT satisfies
+the {\em pred}, or NIL if there is no such pair.}
+
+\funcdesc{rassoc}{item alist \&key key (test \#'equal) test-not}{
returns the first pair in {\em alist} whose cdr is equal to {\em item}.}
+\funcdesc{rassoc-if}{pred alist \&key key}{
+returns the first pair in {\em alist} whose cdr satisfies {\em pred}.}
+
+\funcdesc{rassoc-if-not}{pred alist \&key key}{
+returns the first pair in {\em alist} whose cdr DOES NOT satisfies {\em pred}.}
+
\funcdesc{pairlis}{l1 l2 \&optional alist}{
makes a list of pairs consing corresponding elements in {\em l1} and {\em l2}.
If {\em alist} is given, it is concatenated at the tail of the pair list
@@ -389,6 +479,11 @@ \subsection{Lists}
nconc'ed at the tail.
For example, {\tt (list-insert 'x 2 '(a b c d)) = (a b x c d)}}
+\funcdesc{list-delete}{lst n}{
+deletes the item at the {\em n}'th position in {\em lst} destructively.
+If {\em n} is bigger than the length of {\em lst}, no items are deleted.
+For example, {\tt (list-delete '(a b c d) 2) = (a b d)}}
+
\funcdesc{copy-tree}{tree}{
returns the copy of {\em tree} which may be a nested list
but cannot have circular reference. Circular lists can be copied by
@@ -573,6 +668,24 @@ \subsection{Characters and Strings}
\funcdesc{char-downcase}{ch}{
convert the case of {\em ch} to lower.}
+\funcdesc{char=}{ch1 ch2 \&rest more-characters}{
+alias for {\em =}.}
+
+\funcdesc{char/=}{ch1 ch2 \&rest more-characters}{
+alias for {\em /=}.}
+
+\funcdesc{char$>$}{ch1 ch2 \&rest more-characters}{
+alias for {\em $>$}.}
+
+\funcdesc{char$<$}{ch1 ch2 \&rest more-characters}{
+alias for {\em $<$}.}
+
+\funcdesc{char$>=$}{ch1 ch2 \&rest more-characters}{
+alias for {\em $>=$}.}
+
+\funcdesc{char$<=$}{ch1 ch2 \&rest more-characters}{
+alias for {\em $<=$}.}
+
\funcdesc{char}{string index}{
returns {\em index}th character in {\em string}.}
@@ -580,6 +693,9 @@ \subsection{Characters and Strings}
extracts a character from {\em string}. Use {\bf schar} only if the
type of {\em string} is definitely known and no type check is required.}
+\funcdesc{setchar}{string index ch}{
+set {\em index}th character in {\em string} to {\em ch}.}
+
\funcdesc{stringp}{object}{
returns T if {\em object} is a vector of bytes (integers less than 256).}
@@ -613,18 +729,28 @@ \subsection{Characters and Strings}
In order to get string representation for more complex objects,
use {\bf format} with NIL in the first argument.}
-\fundesc{string$<$}{str1 str2}
+\funcdesc{string$<$}{str1 str2}{
+T if {\em str1} is less than {\em str2} according to strcmp.}
-\fundesc{string$<=$}{str1 str2}
+\funcdesc{string$<=$}{str1 str2}{
+T if {\em str1} is less than or equal to {\em str2} according to strcmp.}
-\fundesc{string$>$}{str1 str2}
+\funcdesc{string$>$}{str1 str2}{
+T if {\em str1} is greater than {\em str2} according to strcmp.}
-\fundesc{string$>=$}{str1 str2}
+\funcdesc{string$>=$}{str1 str2}{
+T if {\em str1} is greater than or equal to {\em str2} according to strcmp.}
-\fundesc{string-left-trim}{bag str}
+\fundesc{string-left-trim}{bag str}{
+{\em str} is scanned from the left,
+and its elements are removed if
+it is included in the {\em bag} list.
+Once a character other than the ones in the {\em bag} is found,
+further scan is aborted and the rest of {\em str}
+is returned.}
\funcdesc{string-right-trim}{bag str}{
-{\em str} is scanned from the left(or right),
+{\em str} is scanned from the right,
and its elements are removed if
it is included in the {\em bag} list.
Once a character other than the ones in the {\em bag} is found,
@@ -632,9 +758,9 @@ \subsection{Characters and Strings}
is returned.}
\funcdesc{string-trim}{bag str}{
-{\em Bag} is a sequence of character codes.
+{\em bag} is a sequence of character codes.
A new copy of {\em str} which does not contain characters specified in {\em bag}
-in its both end is made and returned.}
+in its both ends is made and returned.}
\funcdesc{substringp}{sub string}{
T if string {\em sub} is contained in {\em string} as a substring.
@@ -714,7 +840,7 @@ \subsection{Hash Tables}
For any other objects, {\bf sxhash} is recursively called to calculate
the hash value of each slot, and the sum of them is returned.}
-\funcdesc{make-hash-table}{\&key (size 30) (test \#'eq) (rehash-size 2.0)}{
+\funcdesc{make-hash-table}{\&key (size 10) (test \#'eq) (rehash-size 1.7)}{
creates a hash table and returns it.}
@@ -734,12 +860,12 @@ \subsection{Hash Tables}
\funcdesc{hash-table-p}{x}{
T if {\em x} is an instance of class hash-table.}
-\classdesc{hash-table}{object}{(key value count \\
+\classdesc{hash-table}{object}{(key value count fill-count \\
\> hash-function test-function \\
\> rehash-size empty deleted)}{
defines hash table.
{\em Key} and {\em value} are simple-vectors of the same {\em size}.
-{\em Count} is the number of filled slots in {\em key} and {\em value}.
+{\em Count} and {\em fill-count} are used to administer the number of filled slots.
{\em Hash-function} is defaulted to {\bf sxhash} and
{\em test-function} to {\bf eq}.
{\em Empty} and {\em deleted} are uninterned symbols to indicate
diff --git a/doc/latex/symbols.tex b/doc/latex/symbols.tex
index 30304107d..f42966257 100644
--- a/doc/latex/symbols.tex
+++ b/doc/latex/symbols.tex
@@ -87,6 +87,11 @@ \subsection{Symbols}
Note that lexical (local) variables always have values assigned and
cannot be {\em makunbound}ed.}
+\funcdesc{fmakunbound}{symbol}{
+{\em symbol} function is forced to be unbound (to have no special value).
+Note that lexical (local) functions always have values assigned and
+cannot be {\em fmakunbound}ed.}
+
\funcdesc{get}{sym attribute}{
retrieves {\em sym}'s value associated with {\em attribute} in its plist.
{\tt = (cdr (assoc {\em attribute} (symbol-plist {\em sym})))}}
@@ -114,7 +119,7 @@ \subsection{Symbols}
\specialdesc{defmacro}{symbol lambda-list \&rest body}{
defines a global macro.
-EusLisp does not have facilities for defining locally scoped macros.}
+Use {\em macrolet} for defining local macros.}
\macrodesc{defvar}{var \&optional (init nil) doc}{
If {\em var} symbol has any special value, {\bf defvar} does nothing.
diff --git a/doc/latex/sysfunc.tex b/doc/latex/sysfunc.tex
index d2aaf239e..e9fa42b54 100644
--- a/doc/latex/sysfunc.tex
+++ b/doc/latex/sysfunc.tex
@@ -47,9 +47,6 @@ \subsection{Memory Management}
{\bf SYS:GC} invokes garbage collector explicitly, returning a list of two integers,
numbers of free words and total words (not bytes) allocated in the heap.
-{\bf SYS:*GC-HOOK*} is a variable to hold a function that is called upon the
-completion of a GC. The hook function should receive two arguments
-representing the sizes of the free heap and the total heap.
If "fatal error: stack overflow" is reported during execution,
and you are convinced that the error is not caused by a infinite loop
@@ -99,13 +96,10 @@ \subsection{Memory Management}
starts garbage collection, and returns a list of the numbers
of free words and total words allocated.}
-\vardesc{sys:*gc-hook*}{
-Defines a function that is called upon the completion of a GC.}
-
\funcdesc{sys:gctime}{}{
returns a list of three integers: the count of gc invoked,
-the time elapsed for marking cells (in 1/60 sec. unit),
-and the time elapsed for reclamation (unmarking and merging).}
+the time elapsed for marking cells, and the time elapsed for reclamation (unmarking and merging).
+The time is given in tick counts.}
\funcdesc{sys:alloc}{size}{
allocates at least {\em size} words of memory in the heap,
@@ -115,6 +109,9 @@ \subsection{Memory Management}
relinquishes the current stack,
and allocates a new stack of {\em size} words.}
+\vardesc{sys:*gc-debug*}{
+Print debug messages every time the GC is called.}
+
\vardesc{sys:*gc-merge*}{
is a memory management parameter.
{\bf *gc-merge*} is the ratio the ratio of heap memory which is
@@ -518,12 +515,13 @@ \subsubsection{File Systems and I/O}
\end{refdesc}
-\subsubsection{Signals}
+\subsubsection{Unix Signals}
\begin{refdesc}
-\funcdesc{unix:signal}{signal func \&optional option}{
-installs the signal handler {\em func} for {\em signal}.
+\funcdesc{unix:signal}{signal \&optional func option}{
+if {\em func} is given install it as the signal handler for {\em signal}.
+Otherwise returns the installed handler function for {\em signal}.
In BSD4.2 systems, signals caught during system call processing
cause the system call to be retried.
This means that if the process is issuing a read system call,
@@ -540,10 +538,13 @@ \subsubsection{Signals}
\funcdesc{unix:alarm}{time}{
sends an alarm clock signal (SIGALRM 14) after {\em time} seconds.
-Calling {\bf unix:alarm} with {\em time}=0 resets the alarm clock.}
+Calling {\bf unix:alarm} with {\em time}=0 resets the alarm clock.
+Returns the number of seconds remaining until any previously scheduled alarm,
+or zero if there was no previously scheduled alarm.}
-\funcdesc{unix:ualarm}{time}{
+\funcdesc{unix:ualarm}{time interval}{
same as {\bf unix:alarm} except that the unit of {\em time} is micro seconds.
+{\em time} cannot be greater than 1000000.
{\bf ualarm} is not available on Solaris2 or on other Sys5 based systems.}
\funcdesc{unix:getitimer}{timer}{
@@ -559,7 +560,7 @@ \subsubsection{Signals}
\funcdesc{unix:setitimer}{timer value interval}{
sets {\em value} and {\em interval} in {\em timer}.
-{\em timer} is eiterh 0 ({\tt ITIMER\_REAL}), 1 ({\tt ITIMER\_VIRTUAL}),
+{\em timer} is either 0 ({\tt ITIMER\_REAL}), 1 ({\tt ITIMER\_VIRTUAL}),
or 2({\tt ITIMER\_PROF}).
{\tt ITIMER\_REAL} delivers SIGALRM when {\em value} expires.
{\tt ITIMER\_VIRTUAL} delivers SIGVTALRM, and
diff --git a/lib/eus.init.l b/lib/eus.init.l
index 3e575c48a..5267aa786 100644
--- a/lib/eus.init.l
+++ b/lib/eus.init.l
@@ -15,7 +15,7 @@
"constants"
"stream" "string" "loader" "pprint" "process"
"hashtab" "array" "mathtran" "eusdebug" "eusforeign" "extnum"
- "par"
+ "conditions" "par"
;; TOPLEVEL
"tty" "history" "toplevel"
;; C O M P I L E R
diff --git a/lib/llib/documentation.l b/lib/llib/documentation.l
index a673d02c4..94d768e8c 100644
--- a/lib/llib/documentation.l
+++ b/lib/llib/documentation.l
@@ -206,11 +206,11 @@
(defvar *output-format* :html)))
(unless (fboundp 'defclass-org)
- (setf (symbol-function 'defclass-org) (symbol-function 'defclass)))
+ (alias 'defclass-org 'defclass))
(unless (fboundp 'defmethod-org)
- (setf (symbol-function 'defmethod-org) (symbol-function 'defmethod)))
+ (alias 'defmethod-org 'defmethod))
(unless (fboundp 'defun-org)
- (setf (symbol-function 'defun-org) (symbol-function 'defun)))
+ (alias 'defun-org 'defun))
(defmacro require (&rest args) (format *error-output* ";; skip require ~A ..." args))
(defmacro defclass (cls &rest args &key element-type super slots documentation (doc documentation) &allow-other-keys)
`(progn
diff --git a/lib/llib/logger.l b/lib/llib/logger.l
new file mode 100644
index 000000000..ecbd78c41
--- /dev/null
+++ b/lib/llib/logger.l
@@ -0,0 +1,81 @@
+(unless (find-package "LOG")
+ (make-package "LOG"))
+(in-package "LOG")
+
+(export '(set-logger-level log-debug log-info log-warn log-error log-fatal))
+
+;; Condition instance for logger messages
+(defcondition logger-message :slots (lvl args))
+
+;; Logger level related
+(defconstant logger-table
+ '((:debug . 1) (:info . 2) (:warn . 3) (:error . 4) (:fatal . 5)))
+
+(defun get-level (lvl)
+ (cond
+ ((cdr (assoc lvl logger-table)))
+ (t (error value-error "no such level ~A" lvl))))
+
+(defun get-level-name (lvl)
+ (cond
+ ((car (rassoc lvl logger-table)))
+ (t (error value-error "no such level ~A" lvl))))
+
+(defvar *logger-level* (get-level :info))
+
+(defun set-logger-level (lvl)
+ (setq *logger-level* (get-level lvl)))
+
+
+;; Utility
+(defmacro level-belongs (lvl &rest options)
+ `(or ,@(mapcar #'(lambda (val) `(= ,lvl (get-level ,val))) options)))
+
+(defmacro with-slots (slots instance &rest body)
+ (let ((inst-val (gensym)))
+ `(let* ((,inst-val ,instance) ;; evaluate instance only once
+ ,@(mapcar #'(lambda (s)
+ (if (consp s)
+ `(,(car s) (send ,inst-val :get-val ',(cadr s)))
+ `(,s (send ,inst-val :get-val ',s))))
+ slots))
+ ,@body)))
+
+(defun format-log-message (log)
+ (with-slots (message lvl args) log
+ (format nil "[~A] ~A"
+ (symbol-pname (get-level-name lvl))
+ (apply #'format nil message args))))
+
+
+;; Loggers signalers
+(defun log-debug (msg &rest format-args)
+ (signals logger-message :message msg :lvl (get-level :debug) :args format-args))
+(defun log-info (msg &rest format-args)
+ (signals logger-message :message msg :lvl (get-level :info) :args format-args))
+(defun log-warn (msg &rest format-args)
+ (signals logger-message :message msg :lvl (get-level :warn) :args format-args))
+(defun log-error (msg &rest format-args)
+ (signals logger-message :message msg :lvl (get-level :error) :args format-args))
+(defun log-fatal (msg &rest format-args)
+ (signals logger-message :message msg :lvl (get-level :fatal) :args format-args))
+
+
+;; Printing callback
+(defun logger-callback (log)
+ (when (>= (send log :get-val 'lvl) *logger-level*)
+ (let ((lvl (send log :get-val 'lvl))
+ (msg (format-log-message log)))
+ (cond
+ ((level-belongs lvl :debug :info)
+ (princ msg *standard-output*)
+ (terpri *standard-output*))
+ ((level-belongs lvl :warn)
+ (warning-message 3 msg)
+ (terpri *error-output*))
+ ((level-belongs lvl :error :fatal)
+ (warning-message 1 msg)
+ (terpri *error-output*))))))
+
+(unless (assoc logger-message lisp::*condition-handler*)
+ (install-handler logger-message #'logger-callback))
diff --git a/lib/llib/unittest.l b/lib/llib/unittest.l
index e862755df..6a126f72c 100644
--- a/lib/llib/unittest.l
+++ b/lib/llib/unittest.l
@@ -41,29 +41,6 @@
)
str2))
-(defun unittest-error (code msg1 form &optional (msg2))
- (format *error-output* "~C[1;3~Cm~A unittest-error: ~A"
- #x1b (+ 1 48) *program-name* msg1)
- (if msg2 (format *error-output* " ~A" msg2))
- (if form (format *error-output* " in ~s" form))
- (format *error-output* ", exitting...~C[0m~%" #x1b)
- (when (*unit-test* . result) ;; force put error code into all-test
- (push 'all-test (unit-test-result-tests (car (last (*unit-test* . result)))))
- (push (list form msg1 code) (unit-test-result-failures (car (last (*unit-test* . result))))))
- (when code
- (format *error-output* "~C[3~Cm[ERROR] test ~A failed" #x1b 49 form)
- (format *error-output* " ... (~A ~A)" msg1 code)
- (format *error-output* ".~C[0m~%" #x1b))
- (send *unit-test* :print-result :if-exists :overwrite)
- (if lisp::*exit-on-fatal-error* (exit 1)))
-
-(defun unittest-sigint-handler (sig code)
- (format *error-output* "unittest-sigint-handler ~A~%" sig)
- (when (*unit-test* . result) ;; force put error code into all-test
- (push 'all-test (unit-test-result-tests (car (last (*unit-test* . result)))))
- (push (list "" (format nil "signal-handler ~A" sig) code) (unit-test-result-failures (car (last (*unit-test* . result))))))
- (send *unit-test* :print-result :if-exists :overwrite)
- (if lisp::*exit-on-fatal-error* (exit 1)))
(defclass unit-test-result
:super propertied-object
@@ -91,29 +68,37 @@
(strm)
(format strm " ~%" name "run" time name)
(dolist (ret failures)
- (let ((test (elt ret 0))
- (msg (elt ret 1))
- (trace (elt ret 2)))
- (when trace
- (format strm " ~%" (escape-xml-string msg))
- (format strm "Test:~A~%" (escape-xml-string (prin1-to-string test)))
- (format strm "Trace:~A~%" (escape-xml-string (prin1-to-string trace)))
- (format strm "Message:~A~%" (escape-xml-string (prin1-to-string msg)))
- (format strm " ~%"))))
+ (let ((type (send (class ret) :name))
+ test msg)
+ (cond
+ ((derivedp ret error)
+ (setq test (prin1-to-string (send ret :form)))
+ (setq msg (send ret :message)))
+ ((derivedp ret unix::signal-received)
+ (setq test "")
+ (setq msg (format nil "signal-handler ~A" (send ret :sig)))))
+ (format strm " ~%"
+ (escape-xml-string msg)
+ (escape-xml-string (prin1-to-string type)))
+ (format strm "Test:~A~%" (escape-xml-string test))
+ ;; (format strm "Trace:~A~%" (escape-xml-string (prin1-to-string trace)))
+ (format strm "Message:~A~%" (escape-xml-string (prin1-to-string msg)))
+ (format strm " ~%")))
(format strm " ~%")
)
)
(defclass unit-test-container
:super propertied-object
- :slots (result functions log-fname output-mode))
+ :slots (result functions log-fname output-mode exit-on-error))
(defmethod unit-test-container
(:init
- (&key ((:log-fname fname)))
+ (&key ((:log-fname fname)) ((:exit-on-error eoe) t))
(setq result nil)
(setq functions nil)
(setq log-fname fname)
+ (setq exit-on-error eoe)
(when log-fname
(warning-message 3 "output to ~A~%" log-fname)
(setq output-mode :xml))
@@ -126,12 +111,35 @@
(test)
(if result (push test (unit-test-result-tests (car result)))))
(:increment-failure
- (test msg trace)
- (if result (push (list test msg trace) (unit-test-result-failures (car result))))
- (when trace
- (format *error-output* "~C[3~Cm[ERROR] test ~A failed" #x1b 49 test)
- (format *error-output* " ... (~A ~A)" msg trace)
- (format *error-output* ".~C[0m~%" #x1b)))
+ (failure)
+ (if result (push failure (unit-test-result-failures (car result))))
+ (cond
+ ((derivedp failure error)
+ (if result
+ (format *error-output* "~C[3~Cm[ERROR] test ~A failed at ~S" #x1b 49
+ (unit-test-result-name (car result))
+ (send failure :form))
+ (format *error-output* "~C[3~Cm[ERROR] test failed at ~S" #x1b 49
+ (send failure :form)))
+ (format *error-output* " ... (~A)" (send failure :message))
+ (format *error-output* ".~C[0m~%" #x1b))
+ ((derivedp failure unix::signal-received)
+ (if result
+ (format *error-output* "~C[3~Cm[ERROR] test ~A interrupted with signal ~A" #x1b 49
+ (if result (unit-test-result-name (car result)) "")
+ (send failure :sig))
+ (format *error-output* "~C[3~Cm[ERROR] test interrupted with signal ~A" #x1b 49
+ (send failure :sig)))
+ (format *error-output* " ... (~A)" (send (class failure) :name))
+ (format *error-output* ".~C[0m~%" #x1b))))
+ (:abort
+ ()
+ (warning-message 1 "exitting...~%")
+ (send *unit-test* :print-result :if-exists :overwrite)
+ (exit 1))
+ (:maybe-abort
+ ()
+ (when exit-on-error (send self :abort)))
(:set-time-to-current-result
(time) ;; msec
(if result (setf (unit-test-result-time (car result)) (round time))))
@@ -140,7 +148,7 @@
(push (instance unit-test-result :init func-sym) result))
(:clear-result ()
(setq result nil)
- (send self :init-result 'all-test)
+ ;(send self :init-result 'all-test)
;(send self :increment-test 'all-test)
)
;;
@@ -158,6 +166,7 @@
(let ((all-tests (apply #'+ (send-all result :num-tests)))
(all-successes (apply #'+ (send-all result :num-successes)))
(all-failures (apply #'+ (send-all result :num-failures))))
+ (terpri strm)
(format strm "ALL RESULTS:~%")
(format strm " TEST-NUM: ~A~%" all-tests)
(format strm " PASSED: ~A~%" all-successes)
@@ -181,10 +190,26 @@
(defmacro deftest (name &rest body)
`(progn
- ;; its not cool...
(defun ,name ()
(warning-message 2 "start testing [~A]~%" ',name)
- ,@body)
+ (handler-case
+ (progn ,@body)
+ (assertion-error (err)
+ (send *unit-test* :increment-failure err))
+ (error (err)
+ (when (send err :callstack)
+ (lisp::print-callstack (send err :callstack) lisp::*max-callstack-depth*))
+ (lisp::print-error-message err)
+
+ (send *unit-test* :increment-failure err)
+ (send *unit-test* :maybe-abort))
+ (unix::sigint-received (c)
+ (send *unit-test* :increment-failure c)
+ (send *unit-test* :abort))
+ (unix::sighup-received (c)
+ (send *unit-test* :increment-failure c)
+ (send *unit-test* :abort))))
+
(send *unit-test* :add-function ',name)
',name))
@@ -211,40 +236,23 @@
(exit 1)))
t)
-(defun init-unit-test (&key log-fname trace)
+(defun init-unit-test (&key log-fname trace (exit-on-error t))
(let* ((p "--gtest_output=xml:")
(s (find-if #'(lambda (tmpx) (substringp p tmpx)) lisp::*eustop-argument*))
(xml-fname (if s (string-left-trim p s))))
(if xml-fname (setq log-fname xml-fname))
+ (unix:install-signal-handler unix::sighup unix::sighup-received)
- (setq lisp::*exit-on-fatal-error* t)
- (lisp::install-error-handler 'unittest-error)
- (unix:signal unix::sigint 'unittest-sigint-handler)
- (unix:signal unix::sighup 'unittest-sigint-handler)
-
- (setq *unit-test* (instance unit-test-container :init :log-fname log-fname))
+ (setq *unit-test* (instance unit-test-container :init
+ :log-fname log-fname
+ :exit-on-error exit-on-error))
(when trace
- (setf (symbol-function 'defun-org) (symbol-function 'defun))
+ (alias 'defun-org 'defun)
(defmacro defun (name args &rest body)
`(prog1
(defun-org ,name ,args ,@body)
(trace ,name))))
-
- (defmacro assert (pred &optional (message "") &rest args)
- `(let (failure (ret ,pred))
- ;; lisp::step could not work with macros..
- ;; (if (and (listp ',pred) (functionp (car ',pred)))
- ;; (setq ret (lisp::step ,pred))
- ;; (setq ret ,pred))
- ;;
- (if (not ret)
- ;; escape <> for xml
- (send *unit-test* :increment-failure ',pred (format nil ,message ,@args)
- (escape-xml-string (subseq (send *error-output* :buffer) 0 (or (position 0 (send *error-output* :buffer)) (length (send *error-output* :buffer)))))))
- ))
-
-
t))
(provide :unittest)
diff --git a/lisp/Makefile.Alpha b/lisp/Makefile.Alpha
index b887f7574..76824e74a 100644
--- a/lisp/Makefile.Alpha
+++ b/lisp/Makefile.Alpha
@@ -21,6 +21,7 @@ MFLAGS=-r
#CFLAGS=-D$(MACHINE) -Dbsd4_2
# For SunOS4.1, add "-DSunOS4_1" in the following CFLAGS definition.
CFLAGS=$(COPTS) -D$(MACHINE) -Dsystem5 -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-I/usr/include/X11 -I$(EUSDIR)/include $(DEBUGFLAGS) $(THREAD)
# add -DSolaris2 -D_REENTRANT
#CFLAGS=-D$(MACHINE) -DSolaris2 -D_REENTRANT -DVERSION=\"$(VERSION)\" \
@@ -137,6 +138,7 @@ $(LDIR)/array.l:
$(LDIR)/hashtab.l:
$(LDIR)/eusforeign.l:
$(LDIR)/extnum.l:
+$(LDIR)/conditions.l:
$(LDIR)/mathtran.l:
$(LDIR)/toplevel.l:
$(LDIR)/tty.l:
diff --git a/lisp/Makefile.Cygwin b/lisp/Makefile.Cygwin
index 26d81c6b9..441b4d8dc 100644
--- a/lisp/Makefile.Cygwin
+++ b/lisp/Makefile.Cygwin
@@ -40,6 +40,7 @@ DEBUG= -g
# In order to include thread library, libc.so.6 is preferrable.
CFLAGS=-D$(MACHINE) -DCygwin -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DGCC -DKERNEL -falign-functions=8 \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-I/usr/include -I/usr/X11R6/include -I$(EUSDIR)/lisp/c
diff --git a/lisp/Makefile.Cygwin32 b/lisp/Makefile.Cygwin32
index 37d09992d..3a6483bf1 100644
--- a/lisp/Makefile.Cygwin32
+++ b/lisp/Makefile.Cygwin32
@@ -39,6 +39,7 @@ DEBUG= -g
# In order to include thread library, libc.so.6 is preferrable.
CFLAGS=-D$(MACHINE) -DCygwin -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DGCC -DKERNEL -falign-functions=4 \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-I/usr/include -I/usr/X11R6/include -I$(EUSDIR)/lisp/c
diff --git a/lisp/Makefile.Cygwin64 b/lisp/Makefile.Cygwin64
index e841b89ff..a5d1db539 100644
--- a/lisp/Makefile.Cygwin64
+++ b/lisp/Makefile.Cygwin64
@@ -39,6 +39,7 @@ DEBUG= -g
# In order to include thread library, libc.so.6 is preferrable.
CFLAGS=-D$(MACHINE) -DCygwin -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DGCC -DKERNEL -falign-functions=8 \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-I/usr/include -I/usr/X11R6/include -I$(EUSDIR)/lisp/c
diff --git a/lisp/Makefile.Darwin b/lisp/Makefile.Darwin
index df7814f41..4358d358e 100644
--- a/lisp/Makefile.Darwin
+++ b/lisp/Makefile.Darwin
@@ -54,6 +54,7 @@ DEBUG= -g
# In order to include thread library, libc.so.6 is preferrable.
CFLAGS=-D$(MACHINE) -Wno-return-type -DLinux -D_REENTRANT -DVERSION=\"$(VERSION)\" -DDarwin \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DLIB6 $(ALIGN_FUNCTIONS) \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-DGCC $(GCC3) \
diff --git a/lisp/Makefile.IRIX b/lisp/Makefile.IRIX
index b154839fa..2b1bf0178 100644
--- a/lisp/Makefile.IRIX
+++ b/lisp/Makefile.IRIX
@@ -20,6 +20,7 @@ include Makefile.generic1
#CFLAGS=-D$(MACHINE) -DSunOS4_1 -DGCC \
# -I/usr/share/include/X11 -I$(EUSDIR)/$(CDIR)
CFLAGS=-signed -G 0 -D$(MACHINE) -DIRIX $(IRIX6_2) -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-I/usr/include -I/usr/include/X11 -I$(EUSDIR)/include
# For older version IRIX than 6.2, comment out the following difinition.
IRIX6_2=-DIRIX6_2
diff --git a/lisp/Makefile.IRIX5 b/lisp/Makefile.IRIX5
index 9d335ce05..836ffff7f 100644
--- a/lisp/Makefile.IRIX5
+++ b/lisp/Makefile.IRIX5
@@ -51,7 +51,7 @@ XWINDOWDIR=xwindow
#CFLAGS=-D$(MACHINE) -DSunOS4_1 -DGCC \
# -I/usr/share/include/X11 -I$(EUSDIR)/$(CDIR)
CFLAGS=-signed -G 0 -D$(MACHINE) -DGCC -DIRIX -DVERSION=\"$(VERSION)\" \
- \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-I/usr/include -I/usr/include/X11 -I$(EUSDIR)/$(CDIR)
# Use gcc for C-compiling on SunOS4. Sun's cc is ok on Solaris.
# ucb cc cannot compile since it doesnot recognize prototype declarations.
diff --git a/lisp/Makefile.IRIX6 b/lisp/Makefile.IRIX6
index a29bc818a..724e334e8 100644
--- a/lisp/Makefile.IRIX6
+++ b/lisp/Makefile.IRIX6
@@ -20,6 +20,7 @@ include Makefile.generic1
# -I/usr/share/include/X11 -I$(EUSDIR)/$(CDIR)
CFLAGS=-signed -G 0 -woff 1009,1116,1233 \
-D$(MACHINE) -DIRIX6 $(IRIX6_2) -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-I/usr/include -I/usr/include/X11 -I$(EUSDIR)/include
# For older version IRIX than 6.2, comment out the following difinition.
IRIX6_2=-DIRIX6_2
diff --git a/lisp/Makefile.Linux b/lisp/Makefile.Linux
index 5c564816f..da411a5d5 100644
--- a/lisp/Makefile.Linux
+++ b/lisp/Makefile.Linux
@@ -67,6 +67,7 @@ DEBUG= # -g
# If you use old linux that does not know mallopt, add -OLD_LINUX option.
CFLAGS:= $(CFLAGS) $(CPPFLAGS) $(WFLAGS) -D$(MACHINE) -DLinux -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DLIB6 $(ALIGN_FUNCTIONS) -fsigned-char -fno-stack-protector \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-DGCC $(GCC3) \
diff --git a/lisp/Makefile.Linux.ppc b/lisp/Makefile.Linux.ppc
index 12f92eeff..b7717ed85 100644
--- a/lisp/Makefile.Linux.ppc
+++ b/lisp/Makefile.Linux.ppc
@@ -31,6 +31,7 @@ include Makefile.generic1
MACHINE=i486
DEBUG= -g
CFLAGS=-D$(MACHINE) -DLinux -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DLinux_ppc \
$(DEBUG) $(CPU_OPTIMIZE) -DGCC \
-I/usr/include -I/usr/X11R6/include -I$(EUSDIR)/include
diff --git a/lisp/Makefile.Linux.thread b/lisp/Makefile.Linux.thread
index 913b67b65..5d183ce09 100644
--- a/lisp/Makefile.Linux.thread
+++ b/lisp/Makefile.Linux.thread
@@ -55,6 +55,7 @@ DEBUG= # -g
# In order to include thread library, libc.so.6 is preferrable.
CFLAGS=$(WFLAGS) -D$(MACHINE) -DLinux -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DLIB6 $(ALIGN_FUNCTIONS) -fno-stack-protector \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-DGCC $(GCC3) \
diff --git a/lisp/Makefile.Linux64 b/lisp/Makefile.Linux64
index e12ed0820..0137ec492 100644
--- a/lisp/Makefile.Linux64
+++ b/lisp/Makefile.Linux64
@@ -47,6 +47,7 @@ DEBUG= -g
WFLAGS= #-Wall -Wno-unused -Wno-switch -Wno-return-type
CFLAGS= $(WFLAGS) -fPIC -D$(MACHINE) -DLinux -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DLIB6 $(ALIGN_FUNCTIONS) \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-DGCC $(GCC3) \
diff --git a/lisp/Makefile.LinuxARM b/lisp/Makefile.LinuxARM
index 4b2683d1b..345dc7d64 100644
--- a/lisp/Makefile.LinuxARM
+++ b/lisp/Makefile.LinuxARM
@@ -68,6 +68,7 @@ DEBUG= -g
# In order to include thread library, libc.so.6 is preferrable.
CFLAGS=$(WFLAGS) -D$(MACHINE) -DLinux -DARM -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DLIB6 $(ALIGN_FUNCTIONS) $(ADD_CFLAGS) \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-DGCC $(GCC3) \
diff --git a/lisp/Makefile.LinuxSH4.2 b/lisp/Makefile.LinuxSH4.2
index b93acb586..9ab19599e 100644
--- a/lisp/Makefile.LinuxSH4.2
+++ b/lisp/Makefile.LinuxSH4.2
@@ -59,6 +59,7 @@ OFLAGS=-O2
# If you use old linux that does not know mallopt, add -OLD_LINUX option.
CFLAGS=-D$(MACHINE) -DLinux -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DLIB6 $(ALIGN_FUNCTIONS) \
$(DEBUG) $(CPU_OPTIMIZE) $(THREAD) -D$(XVERSION) \
-DGCC $(GCC3) -I$(EUSDIR)/include -DSH4
diff --git a/lisp/Makefile.SunOS4 b/lisp/Makefile.SunOS4
index 9b64b4e39..ede8186e0 100644
--- a/lisp/Makefile.SunOS4
+++ b/lisp/Makefile.SunOS4
@@ -19,6 +19,7 @@ THREAD= -DTHREADED
#CFLAGS=-D$(MACHINE) -Dbsd4_2
# For SunOS4.1, add "-DSunOS4_1" in the following CFLAGS definition.
CFLAGS=-D$(MACHINE) -DSunOS4_1 -DGCC -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-I/usr/share/include/X11 -I$(EUSDIR)/include $(THREAD)
# Use gcc for C-compiling on SunOS4. Sun's cc is ok on Solaris.
# /usr/ucb/cc cannot compile because of its incapability of recognizing
diff --git a/lisp/Makefile.SunOS4.sub b/lisp/Makefile.SunOS4.sub
index 075b1157e..54c50ff25 100644
--- a/lisp/Makefile.SunOS4.sub
+++ b/lisp/Makefile.SunOS4.sub
@@ -56,6 +56,7 @@ LOBJECTS= $(OBJDIR)/readmacro.o\
$(OBJDIR)/string.o $(OBJDIR)/array.o \
$(OBJDIR)/hashtab.o \
$(OBJDIR)/eusforeign.o $(OBJDIR)/extnum.o \
+ $(OBJDIR)/conditions.o \
$(OBJDIR)/mathtran.o \
$(OBJDIR)/toplevel.o \
$(OBJDIR)/tty.o $(OBJDIR)/history.o \
@@ -372,6 +373,7 @@ eustag :
$(EUSDIR)/$(LDIR)/hashtab.l \
$(EUSDIR)/$(LDIR)/eusforeign.l \
$(EUSDIR)/$(LDIR)/extnum.l \
+ $(EUSDIR)/$(LDIR)/conditions.l \
$(EUSDIR)/$(LDIR)/mathtran.l \
$(EUSDIR)/$(GEODIR)/geopack.l \
$(EUSDIR)/$(GEODIR)/geobody.l \
@@ -440,6 +442,7 @@ $(OBJDIR)/array.o: $(LDIR)/array.l
$(OBJDIR)/hashtab.o: $(LDIR)/hashtab.l
$(OBJDIR)/eusforeign.o: $(LDIR)/eusforeign.l
$(OBJDIR)/extnum.o: $(LDIR)/extnum.l
+$(OBJDIR)/conditions.o: $(LDIR)/conditions.l
$(OBJDIR)/mathtran.o: $(LDIR)/mathtran.l
$(OBJDIR)/toplevel.o: $(LDIR)/toplevel.l
$(OBJDIR)/tty.o: $(LDIR)/tty.l
diff --git a/lisp/Makefile.SunOS5 b/lisp/Makefile.SunOS5
index c2be3c902..a00153008 100644
--- a/lisp/Makefile.SunOS5
+++ b/lisp/Makefile.SunOS5
@@ -22,6 +22,7 @@ THREAD= -DTHREADED
#CFLAGS=-D$(MACHINE) -DSunOS4_1 -DGCC \
# -I/usr/share/include/X11 -I$(EUSDIR)/include
CFLAGS=-D$(MACHINE) -DSolaris2 -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-xcg92 -xstrconst \
-I/usr/include/X11 -I$(EUSDIR)/include $(THREAD)
PIC=-k pic
diff --git a/lisp/Makefile.SunOS5.X11R6.1 b/lisp/Makefile.SunOS5.X11R6.1
index 9045d0114..a62377968 100644
--- a/lisp/Makefile.SunOS5.X11R6.1
+++ b/lisp/Makefile.SunOS5.X11R6.1
@@ -23,6 +23,7 @@ XVERSION=X_V11R6_1
#CFLAGS=-D$(MACHINE) -DSunOS4_1 -DGCC \
# -I/usr/share/include/X11 -I$(EUSDIR)/include
CFLAGS=-D$(MACHINE) -DSolaris2 -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-xcg92 -xstrconst -D$(XVERSION) \
-I/usr/include -I/usr/include/X11 -I$(EUSDIR)/include $(THREAD)
# Use gcc for C-compiling on SunOS4. Sun's cc is ok on Solaris.
diff --git a/lisp/Makefile.SunOS5.i386 b/lisp/Makefile.SunOS5.i386
index a88ab20d1..be646f360 100644
--- a/lisp/Makefile.SunOS5.i386
+++ b/lisp/Makefile.SunOS5.i386
@@ -24,6 +24,7 @@ THREAD= -DTHREADED
# -I/usr/share/include/X11 -I$(EUSDIR)/include
#CFLAGS=-ansi -I/usr/include
CFLAGS= -D$(MACHINE) -DSolaris2 -D_REENTRANT -DVERSION=\"$(VERSION)\" \
+ -DCOMPILERVERSION=\"$(COMPILERVERSION)\" \
-DGCC \
-I/usr/include/X11 -I$(EUSDIR)/include $(THREAD)
# Use gcc for C-compiling on SunOS4. Sun's cc is ok on Solaris.
diff --git a/lisp/Makefile.generic1 b/lisp/Makefile.generic1
index 2df52b9df..ed2381be5 100644
--- a/lisp/Makefile.generic1
+++ b/lisp/Makefile.generic1
@@ -28,6 +28,7 @@ TOOLDIR=tool
XWINDOWDIR=xwindow
GLDIR=opengl/src
GLINCLUDE=-I/usr/local/Mesa/include/
-VERSION=9.29
+VERSION=10.0
+COMPILERVERSION=2.0
XVERSION=X_V11R6
diff --git a/lisp/Makefile.generic2 b/lisp/Makefile.generic2
index 0b5410059..a72fdc26d 100644
--- a/lisp/Makefile.generic2
+++ b/lisp/Makefile.generic2
@@ -55,6 +55,7 @@ LOBJECTS= $(OBJDIR)/readmacro.o\
$(OBJDIR)/string.o $(OBJDIR)/array.o \
$(OBJDIR)/hashtab.o \
$(OBJDIR)/eusforeign.o $(OBJDIR)/extnum.o \
+ $(OBJDIR)/conditions.o \
$(OBJDIR)/mathtran.o \
$(OBJDIR)/toplevel.o \
$(OBJDIR)/tty.o $(OBJDIR)/history.o \
@@ -386,6 +387,7 @@ eustag :
$(EUSDIR)/$(LDIR)/hashtab.l \
$(EUSDIR)/$(LDIR)/eusforeign.l \
$(EUSDIR)/$(LDIR)/extnum.l \
+ $(EUSDIR)/$(LDIR)/conditions.l \
$(EUSDIR)/$(LDIR)/mathtran.l \
$(EUSDIR)/$(GEODIR)/geopack.l \
$(EUSDIR)/$(GEODIR)/geobody.l \
@@ -456,6 +458,7 @@ $(OBJDIR)/array.o: $(LDIR)/array.l
$(OBJDIR)/hashtab.o: $(LDIR)/hashtab.l
$(OBJDIR)/eusforeign.o: $(LDIR)/eusforeign.l
$(OBJDIR)/extnum.o: $(LDIR)/extnum.l
+$(OBJDIR)/conditions.o: $(LDIR)/conditions.l
$(OBJDIR)/mathtran.o: $(LDIR)/mathtran.l
$(OBJDIR)/toplevel.o: $(LDIR)/toplevel.l
$(OBJDIR)/tty.o: $(LDIR)/tty.l
diff --git a/lisp/c/arith.c b/lisp/c/arith.c
index 751aeeb4f..e5a7acb96 100644
--- a/lisp/c/arith.c
+++ b/lisp/c/arith.c
@@ -162,7 +162,7 @@ register pointer argv[];
fright=fleft; }
return(T);
RATGT:
- error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
+ error(E_TYPE_ERROR,(pointer)"comparison of ratios is not implemented");
}
pointer LESSP(ctx,n,argv)
@@ -226,7 +226,7 @@ register pointer argv[];
fright=fleft; }
return(T);
RATLT:
- error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
+ error(E_TYPE_ERROR,(pointer)"comparison of ratios is not implemented");
}
pointer GREQP(ctx,n,argv)
@@ -290,7 +290,7 @@ register pointer argv[];
fright=fleft; }
return(T);
RATGE:
- error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
+ error(E_TYPE_ERROR,(pointer)"comparison of ratios is not implemented");
}
pointer LSEQP(ctx,n,argv) /*less-or-equalp*/
@@ -354,7 +354,7 @@ pointer argv[];
fright=fleft; }
return(T);
RATLE:
- error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
+ error(E_TYPE_ERROR,(pointer)"comparison of ratios is not implemented");
}
pointer MOD(ctx,n,argv)
@@ -388,7 +388,7 @@ pointer argv[];
return(makeflt(x-1.0)); }
else if (isbignum(a)) {
a=copy_big(a); sub_int_big(1,a); return(normalize_bignum(a));}
- else error(E_NOINT);
+ else error(E_NONUMBER);
}
@@ -408,7 +408,7 @@ pointer argv[];
return(makeflt(x+1.0)); }
else if (isbignum(a)) {
a=copy_big(a); add_int_big(1,a); return(a);}
- else error(E_NOINT);
+ else error(E_NONUMBER);
}
/* extended numbers */
@@ -511,11 +511,11 @@ pointer r;
q=r->c.ratio.denominator;
if (isint(p)) num=intval(p);
else if (isbignum(p)) num=big_to_float(p);
- else error(E_USER,(pointer)"illegal ratio numerator");
+ else error(E_TYPE_ERROR,(pointer)"integer or bignum exptected for ratio numerator");
if (isint(q)) den=intval(q);
else if (isbignum(q)) den=big_to_float(q);
- else error(E_USER,(pointer)"illegal ratio denominator");
+ else error(E_TYPE_ERROR,(pointer)"integer or bignum exptected for ratio denominator");
return(num/den);}
@@ -683,7 +683,7 @@ register pointer argv[];
b=normalize_bignum(b);
if (isint(b)) { vpop(); is=intval(b); goto IMINUS;}
}
- else if (isratio(a)) error(E_USER,(pointer)"BIG-RATIO not supported");
+ else if (isratio(a)) error(E_TYPE_ERROR,(pointer)"BIG-RATIO not supported");
else error(E_NONUMBER);}
return(b);}
@@ -703,6 +703,8 @@ register pointer argv[];
for (i=0; ilastalloc= vpop();
@@ -816,9 +818,7 @@ pointer argv[];
else if (pisbignum(a)) { rs=copy_big(a); goto bquo;}
else error(E_NONUMBER);
- if (n==1) {
- fs=fltval(a);
- return(makeflt(1.0/fs));}
+ if (n==1) return(makeflt(1.0/is));
while (i>(WORD_SIZE-width);
val &= mask;
@@ -1402,7 +1404,7 @@ register pointer argv[];
if (state==NIL) { goto MAKERANDSTATENIL; }
else if (state==T) {
if (time(&tm)==-1){
- error(E_USER,(pointer)"failed to fetch time"); }
+ error(E_PROGRAM_ERROR,(pointer)"failed to fetch time"); }
srand((unsigned int)tm);
randvec->c.ivec.iv[0] = rand();
randvec->c.ivec.iv[1] = rand();
diff --git a/lisp/c/arith.old.c b/lisp/c/arith.old.c
deleted file mode 100644
index e331043e5..000000000
--- a/lisp/c/arith.old.c
+++ /dev/null
@@ -1,1446 +0,0 @@
-/****************************************************************/
-/* arith.c EULISP arithmetic functions
-/* Copyright(c)1988 Toshihiro MATSUI, Electrotechnical Laboratory
-/* 1986-May
-.* 1988-Feb boxing and unboxing recoded by macros
-/****************************************************************/
-
-static char *rcsid="@(#)$Id$";
-
-#include "eus.h"
-#include
-#if alpha
-#include
-#endif
-
-extern pointer RANDSTATE;
-extern int gcd();
-extern pointer makeratio();
-
-extern pointer copy_big(), big_plus(), big_minus();
-extern sub_int_big(), add_int_big();
-extern pointer add_big_big(), big_times();
-extern pointer makebig(), makebig1(), makebig2(), extend_big(pointer,int);
-extern pointer normalize_bignum();
-extern eusfloat_t big_to_float(pointer);
-extern pointer eusfloat_to_big(float);
-extern eusinteger_t big_sign(pointer);
-
-/****************************************************************/
-/* number predicates
-/****************************************************************/
-pointer NUMEQUAL(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register eusfloat_t fx,fy;
- register pointer a,x;
- numunion nu;
-
- if (n<=1) error(E_MISMATCHARG);
- x=argv[--n];
- if (isint(x)) {
- while (--n>=0) {
- a=argv[n];
- if (isflt(a)) { fx=intval(x); fy=fltval(a); goto flteqnum;}
- else if (isint(a)) { if (x!=a) return(NIL);}
- else if (pisratio(a)) { x=makeratio(intval(x),1); goto reqnum;}
- else error(E_NONUMBER);}
- return(T);}
- else if (isratio(x)) {
- while (--n>=0) {
- a=argv[n];
- if (isflt(a)) { fx=ratio2flt(x); fy=fltval(a); goto flteqnum;}
- else if (isint(a)) a=makeratio(intval(a),1);
- else if (!pisratio(a)) error(E_NONUMBER);
-reqnum:
- if ((a->c.ratio.numerator != x->c.ratio.numerator) ||
- (a->c.ratio.denominator != x->c.ratio.denominator))
- return(NIL);}
- return(T);}
- else if (isflt(x)) {
- fx=fltval(x);
- while (--n>=0) {
- fy=ckfltval(argv[n]);
-flteqnum:
- if (fx!=fy) return(NIL);}
- return(T); }
- else if (pisbignum(x))
- { eusinteger_t *xv, *av;
- int size,i;
- xv=bigvec(x); size=bigsize(x);
- while (--n >=0) {
- a=argv[n];
- if (!isbignum(a)) return(NIL);
- if (size != bigsize(a)) return(NIL);
- av=bigvec(a);
- for (i=0; i=0) {
- left=argv[n];
- if (isint(left)) {
- if ((eusinteger_t)left <= (eusinteger_t)right) return(NIL); }
- else if (isflt(left)) { fright=intval(right); goto fltgt2;}
- else if (isbignum(left)) {
- if (big_sign(left)<0) return(NIL);
- right=left; goto BIGGT; }
- if (!isint(left)) error(E_NONUMBER);
- right=left;}
- return(T);
-
-BIGGT:
- sign=big_sign(right);
- while (--n>=0) {
- left=argv[n];
- if (isint(left)) {
- ival= intval(left);
- if (sign>=0) return(NIL);
- right=left;
- goto INTGT; }
- else if (isflt(left)) {
- fright=big_to_float(right);
- if (fltval(left)<=fright) return(NIL);
- goto FLTGT1;}
- else if (pisbignum(left)) {
- comparison=big_compare(left, right);
- if (comparison<=0) return(NIL);
- right=left;
- sign=big_sign(right);}
- else if (isratio(left)) goto RATGT; }
-FLTGT:
- fright=fltval(right);
-FLTGT1:
- while (--n>=0) {
- fltgt2: fleft=ckfltval(argv[n]);
- if (fleft<=fright) return(NIL);
- fright=fleft; }
- return(T);
-RATGT:
- error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
- }
-
-pointer LESSP(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register pointer left,right;
- register eusfloat_t fleft,fright;
- eusinteger_t ival;
- eusinteger_t sign;
- int comparison;
- numunion nu;
-
- if (n<=1) error(E_MISMATCHARG);
- right=argv[--n];
-
- if (isint(right)) goto INTLT;
- else if (isflt(right)) goto FLTLT;
- else if (pisratio(right)) goto RATLT;
- else if (pisbignum(right)) goto BIGLT;
- else error(E_NONUMBER);
-
-INTLT:
- while (--n>=0) {
- left=argv[n];
- if (isint(left)) {
- if ((eusinteger_t)left >= (eusinteger_t)right) return(NIL); }
- else if (isflt(left)) { fright=intval(right); goto FLTLT2;}
- else if (isbignum(left)) {
- if (big_sign(left)>0) return(NIL);
- right=left; goto BIGLT; }
- if (!isint(left)) error(E_NONUMBER);
- right=left;}
- return(T);
-
-BIGLT:
- sign=big_sign(right);
- while (--n>=0) {
- left=argv[n];
- if (isint(left)) {
- ival= intval(left);
- if (sign<0) return(NIL);
- right=left;
- goto INTLT; }
- else if (isflt(left)) {
- fright=big_to_float(right);
- if (fltval(left)>=fright) return(NIL);
- goto FLTLT1;}
- else if (pisbignum(left)) {
- comparison=big_compare(left, right);
- if (comparison>=0) return(NIL);
- right=left;
- sign=big_sign(right);}
- else if (isratio(left)) goto RATLT; }
-FLTLT:
- fright=fltval(right);
-FLTLT1:
- while (--n>=0) {
- FLTLT2: fleft=ckfltval(argv[n]);
- if (fleft>=fright) return(NIL);
- fright=fleft; }
- return(T);
-RATLT:
- error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
- }
-
-pointer GREQP(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register pointer left,right;
- register eusfloat_t fleft,fright;
- eusinteger_t ival;
- eusinteger_t sign;
- int comparison;
- numunion nu;
-
- if (n<=1) error(E_MISMATCHARG);
- right=argv[--n];
-
- if (isint(right)) goto INTGE;
- else if (isflt(right)) goto FLTGE;
- else if (pisratio(right)) goto RATGE;
- else if (pisbignum(right)) goto BIGGE;
- else error(E_NONUMBER);
-
-INTGE:
- while (--n>=0) {
- left=argv[n];
- if (isint(left)) {
- if ((eusinteger_t)left < (eusinteger_t)right) return(NIL); }
- else if (isflt(left)) { fright=intval(right); goto FLTGE2;}
- else if (isbignum(left)) {
- if (sign=big_sign(left)<0) return(NIL);
- right=left; goto BIGGE; }
- if (!isint(left)) error(E_NONUMBER);
- right=left;}
- return(T);
-
-BIGGE:
- sign=big_sign(right);
- while (--n>=0) {
- left=argv[n];
- if (isint(left)) {
- ival= intval(left);
- if (sign>0) return(NIL);
- right=left;
- goto INTGE; }
- else if (isflt(left)) {
- fright=big_to_float(right);
- if (fltval(left)=0) {
- FLTGE2: fleft=ckfltval(argv[n]);
- if (fleft=0) {
- left=argv[n];
- if (isint(left)) {
- if ((eusinteger_t)left > (eusinteger_t)right) return(NIL); }
- else if (isflt(left)) { fright=intval(right); goto FLTLE2;}
- else if (isbignum(left)) {
- if (sign=big_sign(left)>0) return(NIL);
- right=left; goto BIGLE; }
- if (!isint(left)) error(E_NONUMBER);
- right=left;}
- return(T);
-
-BIGLE:
- sign=big_sign(right);
- while (--n>=0) {
- left=argv[n];
- if (isint(left)) {
- ival= intval(left);
- if (sign<0) return(NIL);
- right=left;
- goto INTLE; }
- else if (isflt(left)) {
- fright=big_to_float(right);
- if (fltval(left) > fright) return(NIL);
- goto FLTLE1;}
- else if (pisbignum(left)) {
- comparison=big_compare(left, right);
- if (comparison > 0) return(NIL);
- right=left;
- sign=big_sign(right);}
- else if (isratio(left)) goto RATLE; }
-FLTLE:
- fright=fltval(right);
-FLTLE1:
- while (--n>=0) {
- FLTLE2: fleft=ckfltval(argv[n]);
- if (fleft > fright) return(NIL);
- fright=fleft; }
- return(T);
-RATLE:
- error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
- }
-
-pointer MOD(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register eusinteger_t x,y;
- ckarg(2);
- x=ckintval(argv[0]); y=ckintval(argv[1]);
- return(makeint(x % y));}
-
-pointer SUB1(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register pointer a=argv[0];
- eusfloat_t x;
- numunion nu;
-
- ckarg(1);
- if (a==makeint(MINNEGFIXNUM)) { return(makebig1(MINNEGFIXNUM-1));}
- if (isint(a)) return((pointer)((eusinteger_t)a-4));
- else if (isflt(a)) {
- x=fltval(a);
- return(makeflt(x-1.0)); }
- else if (isbignum(a)) {
- a=copy_big(a); sub_int_big(1,a); return(normalize_bignum(a));}
- else error(E_NOINT);
- }
-
-
-pointer ADD1(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register pointer a=argv[0];
- float x;
- numunion nu;
-
- ckarg(1);
- if (a==makeint(MAXPOSFIXNUM)) { return(makebig1(MAXPOSFIXNUM+1));}
- if (isint(a)) return((pointer)((eusinteger_t)a+4));
- else if (isflt(a)) {
- x=fltval(a);
- return(makeflt(x+1.0)); }
- else if (isbignum(a)) {
- a=copy_big(a); add_int_big(1,a); return(a);}
- else error(E_NOINT);
- }
-
-/* extended numbers */
-
-pointer ratio_plus(x,y)
-pointer x,y;
-{
- register eusinteger_t x_num, x_den, y_num, y_den, z_num, z_den, d1,d2,t;
-
- x_num = intval(x->c.ratio.numerator);
- x_den = intval(x->c.ratio.denominator);
- y_num = intval(y->c.ratio.numerator);
- y_den = intval(y->c.ratio.denominator);
-
- d1=gcd(x_den,y_den);
- if(d1 == 1){
- z_num = x_num * y_den + x_den * y_num;
- z_den = x_den * y_den;
- return(makeratio(z_num,z_den));}
- else{
- t = x_num * (y_den / d1) + y_num * (x_den / d1);
- d2=gcd(t,d1);
-
- z_num = t / d2;
- z_den = (x_den / d1) * (y_den / d2);
- return(makeratio(z_num,z_den));}
-}
-
-pointer ratio_minus(x,y)
-pointer x,y;
-{
- register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2,t;
-
- x_num = intval(x->c.ratio.numerator);
- x_den = intval(x->c.ratio.denominator);
- y_num = intval(y->c.ratio.numerator);
- y_den = intval(y->c.ratio.denominator);
- d1 = gcd(x_den,y_den);
- if(d1 == 1){
- z_num = x_num * y_den - x_den * y_num;
- z_den = x_den * y_den;
- return(makeratio(z_num,z_den));}
- else{
- t = x_num * (y_den / d1) - y_num * (x_den / d1);
- d2=gcd(t,d1);
- z_num = t / d2;
- z_den = (x_den / d1) * (y_den / d2);
- return(makeratio(z_num,z_den));}
-}
-
-pointer ratio_times(x,y)
-pointer x,y;
-{
- register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2;
-
- x_num = intval(x->c.ratio.numerator);
- x_den = intval(x->c.ratio.denominator);
- y_num = intval(y->c.ratio.numerator);
- y_den = intval(y->c.ratio.denominator);
- d1=gcd(x_num,y_den);
- d2=gcd(x_den,y_num);
-
- z_num = (x_num / d1) * (y_num / d2);
- z_den = (x_den / d2) * (y_den / d1);
-
- return(makeratio(z_num,z_den));
-}
-
-pointer ratio_divide(x,y)
-pointer x,y;
-{
- register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2;
- register int sign;
-
- x_num = intval(x->c.ratio.numerator);
- x_den = intval(x->c.ratio.denominator);
- y_num = intval(y->c.ratio.numerator);
- y_den = intval(y->c.ratio.denominator);
-
- d1=gcd(x_num,y_num);
- d2=gcd(x_den,y_den);
-
- if(y_num >= 0) sign=1; else sign=-1;
-
- z_num = (x_num / d1) * (y_den / d2) * sign;
- z_den = abs((x_den / d2) * (y_num / d1));
-
- return(makeratio(z_num,z_den));
-}
-
-pointer int2ratio(i)
-eusinteger_t i;
-{ return(makeratio(i,1));}
-
-eusfloat_t ratio2flt(r)
-pointer r;
-{ pointer p,q;
- eusfloat_t num, den;
- p=r->c.ratio.numerator;
- q=r->c.ratio.denominator;
- if (isint(p)) num=intval(p);
- else if (isbignum(p)) num=big_to_float(p);
- else error(E_USER,(pointer)"illegal ratio numerator");
-
- if (isint(q)) den=intval(q);
- else if (isbignum(q)) den=big_to_float(q);
- else error(E_USER,(pointer)"illegal ratio denominator");
-
- return(num/den);}
-
-pointer return_ratio(r)
-pointer r;
-{ if (intval(r->c.ratio.numerator)==0) return(makeint(0));
- else if (intval(r->c.ratio.denominator)==1) return(r->c.ratio.numerator);
- else return(r);}
-
-
-pointer PLUS(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ eusfloat_t fs;
- register eusinteger_t is=0,j;
- register int i=0;
- register pointer a, r, rs;
- pointer b;
- numunion nu;
-
- while (i> 1) ^ is)&((eusinteger_t)1<= 0) add_int_big(is, b);
- else sub_int_big(is, b);
- vpush(b);
- while (i0) add_int_big(j,b);
- else if (j<0) sub_int_big(-j,b);
- b=normalize_bignum(b);}
- else if (isbignum(a)) {
- b=big_plus(a,b);
- vpop();
- vpush(b);
- b=normalize_bignum(b);
- }
- i++; }
- vpop();
- return(b);
- }
-
-pointer MINUS(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ float fs;
- register eusinteger_t is,ia;
- register int i;
- register pointer a=argv[0], rs, b, z;
- numunion nu;
-
- if (n<1) error(E_MISMATCHARG);
- else if (n==1) { /*negate*/
- if (a==makeint(MINNEGFIXNUM)) return(makebig1(-MINNEGFIXNUM));
- if (isint(a)) return(makeint(-intval(a)));
- else if (isflt(a)) {
- fs= -fltval(a);
- return(makeflt(fs));}
- else if (isratio(a)) { /* buggy when numerator == MINNEGFIXNUM */
- return(makeratio(-intval(a->c.ratio.numerator),
- intval(a->c.ratio.denominator)));}
-
- else if (isbignum(a)) { return(big_minus(a));}
- else error(E_NONUMBER); }
-
- /* n>1 */
-
- i=1;
-
- if (isint(a)) { is=intval(a); goto IMINUS;}
- else if (isflt(a)) { fs=fltval(a); goto FMINUS;}
- else if (pisratio(a)) { rs=a; goto RMINUS;}
- else if (isbignum(a)) { b=copy_big(a); goto BIGMINUS;}
- else error(E_NONUMBER);
-
-IMINUS:
- while (i> 1) ^ is)&((eusinteger_t)1<0) add_int_big(is, z);
- else if (is<0) sub_int_big(-is, z);
- z=normalize_bignum(z);
- if (isint(z)) { vpop(); is= intval(z);}
- else { b=z; goto BIGMINUS1;} }
- else error(E_NONUMBER); }
- return(makeint(is));
-
-RMINUS:
- while (i0) sub_int_big(intval(a), b);
- else if (ia<0) add_int_big(-ia, b);
- b=normalize_bignum(b);
- if (isint(b)) { vpop(); goto IMINUS;}
- }
- else if (isflt(a)) {
- is= big_to_float(b); vpop(); goto FMINUS;}
- else if (isbignum(a)) {
- z= big_minus(a);
- vpush(z);
- b=big_plus(b,z);
- ctx->vsp[-2]=b; /*replace b on the stack*/
- vpop();
- b=normalize_bignum(b);
- if (isint(b)) { vpop(); is=intval(b); goto IMINUS;}
- }
- else if (isratio(a)) error(E_USER,(pointer)"BIG-RATIO not supported");
- else error(E_NONUMBER);}
- return(b);}
-
-pointer TIMES(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register eusfloat_t fs;
- register eusinteger_t is,s;
- register int i;
- register eusinteger_t sign=1;
- register pointer a, rs, b;
- eusinteger_t hi, lo;
- numunion nu;
-
-/* fprintf(stderr, "TIMES ");
- for (i=0; ibignum */
- b=makebig2(hi, lo & MASK);
- vpush(b);
- if (sign<0) complement_big(b);
- goto BIGTIMES;}
- else is= lo*sign;}
- else if (isflt(a)) { fs=is; goto FTIMES1;}
- else if (pisbignum(a)) { /* fixnum times bignum */
- b=copy_big(a);
- vpush(b);
- goto BIGTIMES1;}
- else if (pisratio(a)) {
- rs=makeratio(is,1);
- vpush(rs);
- goto RTIMES1;}
- else error(E_NONUMBER);}
- return(makeint(is));
-
-RTIMES:
- while (ivsp[-1]=rs;
- }
- ctx->lastalloc=rs;
- vpop();
- return(return_ratio(rs));
-
-BIGTIMES:
- while (ivsp[-2]=b;
- vpop();
- b=normalize_bignum(b);
- if (isint(b)) { is=intval(b); vpop(); goto ITIMES;}
- }
- else if (pisratio(a)) {
- error(E_USER,(pointer)"sorry, big * ratio is not yet implemented.");}
- else error(E_NONUMBER);
- }
- ctx->lastalloc= vpop();
- return(b);
-
-FTIMES:
- while (i int*/
-register context *ctx;
-int n;
-pointer argv[];
-{ pointer x;
- eusinteger_t i;
- ckarg(1);
- x=argv[0];
- if (!isflt(x)) error(E_NONUMBER);
- i=intval(x);
- return(makeint(i));}
-
-pointer MAX(ctx,n,argv)
-register context *ctx;
-register int n;
-pointer argv[];
-{ eusfloat_t fs,fm;
- register i=1;
- register eusinteger_t is;
- register pointer a=argv[0];
- numunion nu;
- if (n<1) error(E_MISMATCHARG);
- if (n==1) return(a);
- if (isint(a)) is=(eusinteger_t)a;
- else { fs=fltval(a); goto fmax;}
- while (i(eusinteger_t)a) is=(eusinteger_t)a;}
- else error(E_NONUMBER);
- i++;}
- return((pointer)is);
-fmin:
- while (ifm) fs=fm;
- i++;}
- return(makeflt(fs));}
-
-/****************************************************************/
-/* bit wise logical operations
-/****************************************************************/
-pointer LOGAND(context *ctx, int n, pointer argv[])
-{ int i=1,j,k,rsize,psize;
- eusinteger_t *rbv, *bbv, *pbv;
- pointer b,p,r=argv[0];
-
- if (isbignum(r)) {
- r=copy_big(r); rsize=bigsize(r); rbv=bigvec(r);
- p=argv[i++];
- goto bigand;}
-
- k=intval(r);
- while (i=0) for (j=1; j=psize) {
- for (j=0; jc.bgnm.bv->c.ivec.iv[j];
- if (rsize>psize) {
- if (big_sign(p)>0) for (j=psize; jc.bgnm.bv->c.ivec.iv[j];
- }
- else
- for (j=0; jc.bgnm.bv->c.ivec.iv[j];
- }
- else error(E_NOINT);}
- return(normalize_bignum(r));}
-
-pointer LOGIOR(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register eusinteger_t result=0;
- register int i=0;
- pointer p;
- while (i0) {
- if (!isint(argv[--n])) error(E_NOINT);
- result ^= intval(argv[n]); }
- return(makeint(~result));}
-
-pointer LOGNAND(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register eusinteger_t result= ~0;
- register int i=0;
- while (i>index) & 1) return(T); else return(NIL);}
-
-pointer ASH(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register eusinteger_t count,val;
- register int firstone;
- register eusinteger_t sign;
- pointer a,b;
- ckarg(2);
- count=ckintval(argv[1]);
- if (isint(argv[0])) {
- val=intval(argv[0]);
- if (count<=0) return(makeint(val>>(-count)));
- if (val<=0) { return(makeint(val<=0)?1:(-1);
- val=val<0) return(makeint(val));
- else return(makeint(~val)); }
- /*extend to big*/
- a=makebig1(val);}
- else if (isbignum(argv[0])) { a=argv[0]; sign=big_sign(a);}
- else error(E_NOINT);
-
- /*shift b by count bits*/
- { int size=bigsize(a);
- int i, j, k;
- eusinteger_t x, *av, *bv;
- pointer b=makebig(size+(count+(WORD_SIZE-1))/(WORD_SIZE-1));
- vpush(b);
- av=bigvec(a); bv=bigvec(b);
- if (count>=0) {
- j= count/(WORD_SIZE-1); k=count % (WORD_SIZE-1);
- for (i=0; i>((WORD_SIZE-1)-k)); } }
- else { /* count <0 ; shift right */
- count = -count;
- j=count/(WORD_SIZE-1); k=count % (WORD_SIZE-1);
- for (i=0; i>k) | ((av[j+i+1]<<((WORD_SIZE-1)-k)) & MASK); }
- bv[size-j-1]=av[size-1]>>k;
- }
- b=normalize_bignum(b);
- vpop();
- return(b); }
- }
-
-pointer LDB(ctx,n,argv) /*(LDB 'val 'pos 'width)*/
-register context *ctx;
-register int n; /*no byte specifier in euslisp*/
-register pointer argv[];
-{ register eusinteger_t pos,width=8;
-#if (WORD_SIZE == 64)
- register unsigned long val;
-#else
- register unsigned int val;
-#endif
- ckarg2(2,3);
- val=ckintval(argv[0]); pos=ckintval(argv[1]);
- if (n==3) width=ckintval(argv[2]);
- val=(val<<(WORD_SIZE-pos-width))>>(WORD_SIZE-width);
- return(makeint(val));}
-
-pointer DPB(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register eusinteger_t pos,width=8;
-#if (WORD_SIZE == 64)
- register unsigned long val,target,mask=~0;
-#else
- register unsigned int val,target,mask=~0;
-#endif
- ckarg(4);
- val=ckintval(argv[0]);
- target=ckintval(argv[1]);
- pos=ckintval(argv[2]);
- width=ckintval(argv[3]);
- mask=mask<<(WORD_SIZE-(pos+width));
- mask=mask>>(WORD_SIZE-width);
- val &= mask;
- mask <<= pos;
- target=(target & ~mask) | (val<c.ivec.iv);
-#else
- randval=erand48(state->c.ivec.iv);
-#endif
-#endif
- if (isint(a)) {
- imax=intval(a);
- irandval=randval*imax;
- return(makeint(irandval));}
- else if (isflt(a)) {
- fmax=fltval(a);
- frandval=randval*fmax;
- return(makeflt(frandval));}
- else error(E_NONUMBER);
- }
-
-
-arith(ctx,mod)
-register context *ctx;
-pointer mod;
-{
- defun(ctx,"=",mod,NUMEQUAL,NULL);
- defun(ctx,">",mod,GREATERP,NULL);
- defun(ctx,"<",mod,LESSP,NULL);
- defun(ctx,">=",mod,GREQP,NULL);
- defun(ctx,"<=",mod,LSEQP,NULL);
- defun(ctx,"MOD",mod,MOD,NULL);
- defun(ctx,"1-",mod,SUB1,NULL);
- defun(ctx,"1+",mod,ADD1,NULL);
- defun(ctx,"+",mod,PLUS,NULL);
- defun(ctx,"-",mod,MINUS,NULL);
- defun(ctx,"*",mod,TIMES,NULL);
- defun(ctx,"/",mod,QUOTIENT,NULL);
- defun(ctx,"SIN",mod,SIN,NULL);
- defun(ctx,"COS",mod,COS,NULL);
- defun(ctx,"TAN",mod,TAN,NULL);
- defun(ctx,"ATAN",mod,ATAN,NULL);
- defun(ctx,"TANH",mod,TANH,NULL);
- defun(ctx,"ATANH",mod,ATANH,NULL);
- defun(ctx,"SINH",mod,SINH,NULL);
- defun(ctx,"ASINH",mod,ASINH,NULL);
- defun(ctx,"COSH",mod,COSH,NULL);
- defun(ctx,"ACOSH",mod,ACOSH,NULL);
- defun(ctx,"SQRT",mod,SQRT,NULL);
- defun(ctx,"LOG",mod,LOG,NULL);
- defun(ctx,"EXP",mod,EXP,NULL);
- defun(ctx,"ABS",mod,ABS,NULL);
- defun(ctx,"ROUND",mod,ROUND,NULL);
- defun(ctx,"FLOOR",mod,FLOOR,NULL);
- defun(ctx,"CEILING",mod,CEILING,NULL);
- defun(ctx,"TRUNCATE",mod,TRUNCATE,NULL);
- defun(ctx,"FLOAT",mod,FLOAT,NULL);
- defun(ctx,"DECODE-FLOAT",mod,DECFLOAT,NULL);
- defun(ctx,"MAX",mod,MAX,NULL);
- defun(ctx,"MIN",mod,MIN,NULL);
- defun(ctx,"LOGAND",mod,LOGAND,NULL);
- defun(ctx,"LOGIOR",mod,LOGIOR,NULL);
- defun(ctx,"LOGXOR",mod,LOGXOR,NULL);
- defun(ctx,"LOGEQV",mod,LOGEQV,NULL);
- defun(ctx,"LOGNAND",mod,LOGNAND,NULL);
- defun(ctx,"LOGNOR",mod,LOGNOR,NULL);
- defun(ctx,"LOGNOT",mod,LOGNOT,NULL);
- defun(ctx,"LOGTEST",mod,LOGTEST,NULL);
- defun(ctx,"LOGBITP",mod,LOGBITP,NULL);
- defun(ctx,"ASH",mod,ASH,NULL);
- defun(ctx,"LDB",mod,LDB,NULL);
- defun(ctx,"DPB",mod,DPB,NULL);
- defun(ctx,"RANDOM",mod,RANDOM,NULL);
- defun(ctx,"FREXP",mod,FREXP,NULL);
-}
diff --git a/lisp/c/big.c b/lisp/c/big.c
index 1774f2993..542f97b18 100644
--- a/lisp/c/big.c
+++ b/lisp/c/big.c
@@ -630,7 +630,7 @@ eusinteger_t c;
pointer x;
{ int i, size;
eusinteger_t *xv, r;
- if (c == 0) error(E_USER,(pointer)"divide by zero in bignum div");
+ if (c == 0) error(E_VALUE_ERROR,(pointer)"divide by zero in bignum div");
size=bigsize(x); xv=bigvec(x);
/* divide from MSB */
r = xv[size-1] % c;
@@ -718,7 +718,7 @@ pointer x, y;
if (j==ysize-1) {
while (hi>0) {
k++;
- if (k>=xsize+ysize) error(E_USER,(pointer)"bignum mult overflow");
+ if (k>=xsize+ysize) error(E_PROGRAM_ERROR,(pointer)"bignum mult overflow");
zv[k] += hi;
if (zv[k] & MSB) { zv[k] &= MASK; hi=1; }
else hi=0;}
diff --git a/lisp/c/calleus.c b/lisp/c/calleus.c
index a8d6b6e9f..fd3e8e6c3 100644
--- a/lisp/c/calleus.c
+++ b/lisp/c/calleus.c
@@ -103,7 +103,7 @@ register eusinteger_t cargv[]; /*arguments vector passed from C function*/
printf("calleus : fsym.resulttype = %lX (%lX,%lX)\n",
fs->resulttype, (long *)fs, &(fs->resulttype));
#endif
- if (!isforeignpod(fsym)) error(E_USER,(pointer)"not a foreign pod");
+ if (!isforeignpod(fsym)) error(E_TYPE_ERROR,(pointer)"not a foreign pod");
param=fs->paramtypes;
resulttype=fs->resulttype;
while (islist(param)) {
@@ -126,7 +126,7 @@ register eusinteger_t cargv[]; /*arguments vector passed from C function*/
f = nu.f32val;
vpush(makeflt(f));
} else if (islist(p)) {
- if (ccar(p)!=K_STRING) error(E_USER,(pointer)":string key expected");
+ if (ccar(p)!=K_STRING) error(E_TYPE_ERROR,(pointer)":string key expected");
p=ccdr(p);
if (p==NIL) {
if(icount < 6) c = iargv[icount++]; else c = vargv[vcount++];
@@ -140,7 +140,7 @@ register eusinteger_t cargv[]; /*arguments vector passed from C function*/
if(icount < 6) c = iargv[icount++]; else c = vargv[vcount++];
c -= 2*sizeof(pointer);
vpush((pointer)c);
- } else error(E_USER,(pointer)"unknown param type spec");
+ } else error(E_TYPE_ERROR,(pointer)"unknown param type spec");
argc++;
}
#if 0
@@ -184,7 +184,7 @@ register int a2, a3, a4, a5, a6, a7, a8;
ctx=euscontexts[thr_self()];
argv=ctx->vsp;
fs=(struct foreignpod *)fsym;
- if (!isforeignpod(fsym)) error(E_USER,(pointer)"not a foreign pod");
+ if (!isforeignpod(fsym)) error(E_TYPE_ERROR,(pointer)"not a foreign pod");
param=fs->paramtypes;
resulttype=fs->resulttype;
while (islist(param)) {
@@ -194,7 +194,7 @@ register int a2, a3, a4, a5, a6, a7, a8;
dp=(double *)&cargv[i]; f= *dp;
vpush(makeflt(f)); i+=2;}
else if (islist(p)) {
- if (ccar(p)!=K_STRING) error(E_USER,(pointer)":string key expected");
+ if (ccar(p)!=K_STRING) error(E_TYPE_ERROR,(pointer)":string key expected");
p=ccdr(p);
if (p==NIL) {
vpush(makestring((char *)cargv[i],strlen((char *)cargv[i]))); i++;}
@@ -209,7 +209,7 @@ register int a2, a3, a4, a5, a6, a7, a8;
c=cargv[i++]-2*sizeof(pointer);
#endif
vpush((pointer)c);}
- else error(E_USER,(pointer)"unknown param type spec");
+ else error(E_TYPE_ERROR,(pointer)"unknown param type spec");
argc++;}
result=ufuncall(ctx,fsym,fsym,(pointer)argv,NULL,argc);
ctx->vsp = argv;
diff --git a/lisp/c/charstring.old.c b/lisp/c/charstring.old.c
deleted file mode 100644
index 56e869990..000000000
--- a/lisp/c/charstring.old.c
+++ /dev/null
@@ -1,202 +0,0 @@
-/****************************************************************
-/* CHARACTER and STRING functions
-/* 1987-Dec-17
-/* Copyright(c) Toshihiro MATSUI, ETL, 1988.
-/****************************************************************/
-static char *rcsid="@(#)$Id: charstring.old.c,v 1.1.1.1 2003/11/20 07:46:26 eus Exp $";
-#include
-#include "eus.h"
-
-extern byte *get_string();
-
-pointer CHAR(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register pointer a=argv[0];
- ckarg(2);
- n=ckintval(argv[1]);
- if (!isstring(a)) error(E_NOSTRING);
- if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
-/* This code should be eliminated, because the compiler cannot know if
- this object is a normal string or a foreign string, thus no optimization.
- if (elmtypeof(a)==ELM_FOREIGN)
- return(makeint((a->c.foreign.chars)[n]));
- else */
- return(makeint(a->c.str.chars[n]));}
-
-pointer SETCHAR(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ register pointer a=argv[0];
- register int newval=ckintval(argv[2]);
- ckarg(3);
- n=ckintval(argv[1]);
- if (!isstring(a)) error(E_NOSTRING);
- if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
-/* if (elmtypeof(a)==ELM_FOREIGN)
- ((byte *)(a->c.ivec.iv[0]))[n]=newval;
- else */
- a->c.str.chars[n]=newval;
- return(argv[2]);}
-
-pointer UPCASEP(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ ckarg(1); n=ckintval(argv[0]);
- return((isupper(n))?T:NIL);}
-
-pointer LOWCASEP(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ ckarg(1); n=ckintval(argv[0]);
- return((islower(n))?T:NIL);}
-
-pointer ALPHAP(ctx,n,argv)
-register context *ctx;
-register int n;
-pointer argv[];
-{ ckarg(1); n=ckintval(argv[0]);
- return((isalpha(n))?T:NIL);}
-
-pointer DIGITP(ctx,n,argv)
-register context *ctx;
-register int n;
-pointer argv[];
-{ ckarg(1); n=ckintval(argv[0]);
- return((isdigit(n))?T:NIL);}
-
-pointer ALNUMP(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer argv[];
-{ ckarg(1); n=ckintval(argv[0]);
- return((isalnum(n))?T:NIL);}
-
-pointer CHUPCASE(ctx,n,argv)
-register context *ctx;
-register int n;
-pointer argv[];
-{ ckarg(1); n=ckintval(argv[0]);
- return((islower(n))?(makeint(toupper(n))):argv[0]);}
-
-pointer CHDOWNCASE(ctx,n,argv)
-register context *ctx;
-register int n;
-pointer argv[];
-{ ckarg(1); n=ckintval(argv[0]);
- return((isupper(n))?(makeint(tolower(n))):argv[0]);}
-
-pointer STRINGEQ(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ register byte *str1, *str2;
- int start1,end1,start2,end2;
- register int len;
- pointer s1=Getstring(argv[0]), s2=Getstring(argv[1]);
- ckarg(6);
- start1=ckintval(argv[2]); end1=ckintval(argv[3]);
- end1=min(end1,vecsize(s1));
- start2=ckintval(argv[4]); end2=ckintval(argv[5]);
- end2=min(end2,vecsize(s2));
- len=end1-start1;
- if (len!=end2-start2) return(NIL);
- str1= &s1->c.str.chars[start1]; str2= &s2->c.str.chars[start2];
- while (len-->0) if (*str1++ != *str2++) return(NIL);
- return(T);}
-
-pointer STRINGEQUAL(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ register byte *str1, *str2;
- int start1,end1,start2,end2,ch1,ch2;
- pointer s1=Getstring(argv[0]),s2=Getstring(argv[1]);
- register int len;
- ckarg(6);
- start1=ckintval(argv[2]); end1=ckintval(argv[3]); end1=min(end1,vecsize(s1));
- start2=ckintval(argv[4]); end2=ckintval(argv[5]); end2=min(end2,vecsize(s2));
- len=end1-start1;
- if (len!=end2-start2) return(NIL);
- str1= &s1->c.str.chars[start1]; str2= &s2->c.str.chars[start2];
- while (len-->0) {
- ch1= *str1++; ch2= *str2++;
- if (islower(ch1)) ch1=toupper(ch1);
- if (islower(ch2)) ch2=toupper(ch2);
- if (ch1!=ch2) return(NIL);}
- return(T);}
-
-/****************************************************************/
-/* S T R I N G compare
-/****************************************************************/
-
-pointer STR_LT(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(2);
- if (strcmp(get_string(argv[0]),get_string(argv[1]))<0) return(T);
- else return(NIL);}
-
-pointer STR_LE(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(2);
- if (strcmp(get_string(argv[0]),get_string(argv[1]))<=0) return(T);
- else return(NIL);}
-
-pointer STR_EQ(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(2);
- if (strcmp(get_string(argv[0]),get_string(argv[1]))==0) return(T);
- else return(NIL);}
-
-pointer STR_GT(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(2);
- if (strcmp(get_string(argv[0]),get_string(argv[1]))>0) return(T);
- else return(NIL);}
-
-pointer STR_GE(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(2);
- if (strcmp(get_string(argv[0]),get_string(argv[1]))>=0) return(T);
- else return(NIL);}
-
-/* initializers */
-
-charstring(ctx,mod)
-register context *ctx;
-register pointer mod;
-{
- defun(ctx,"CHAR",mod,CHAR,NULL);
- defun(ctx,"SCHAR",mod,CHAR,NULL);
- defun(ctx,"SETCHAR",mod,SETCHAR,NULL);
- defun(ctx,"ALPHA-CHAR-P",mod,ALPHAP,NULL);
- defun(ctx,"UPPER-CASE-P",mod,UPCASEP,NULL);
- defun(ctx,"LOWER-CASE-P",mod,LOWCASEP,NULL);
- defun(ctx,"DIGIT-CHAR-P",mod,DIGITP,NULL);
- defun(ctx,"ALPHANUMERICP",mod,ALNUMP,NULL);
- defun(ctx,"CHAR-UPCASE",mod,CHUPCASE,NULL);
- defun(ctx,"CHAR-DOWNCASE",mod,CHDOWNCASE,NULL);
- defun(ctx,"STRINGEQ",mod,STRINGEQ,NULL);
- defun(ctx,"STRINGEQUAL",mod,STRINGEQUAL,NULL);
- defun(ctx,"STRING<",mod,STR_LT,NULL);
- defun(ctx,"STRING<=",mod,STR_LE,NULL);
- defun(ctx,"STRING=",mod,STR_EQ,NULL);
- defun(ctx,"STRING>",mod,STR_GT,NULL);
- defun(ctx,"STRING>=",mod,STR_GE,NULL);
-
- }
-
diff --git a/lisp/c/collector.c b/lisp/c/collector.c
index 91c8f36fa..107f71133 100644
--- a/lisp/c/collector.c
+++ b/lisp/c/collector.c
@@ -186,14 +186,6 @@ static int mark_a_little(int m_unit)
markon(bp); /* mark it first to avoid endless marking */
if(pisclosure(p)){
- /*
- if (p->c.clo.env1>minmemory && p->c.clo.env1c.clo.env1);
- if (p->c.clo.env2>minmemory && p->c.clo.env2c.clo.env2);
- */
goto markloop; /* avoid marking contents of closure */
}
if(bp->h.elmtype == ELM_FIXED){ /* contents are all pointers */
@@ -533,6 +525,7 @@ static void scan_global_roots()
{
int i;
pointerpush(sysobj);
+ pointerpush(eussigobj);
pointerpush(pkglist);
/* minimize scanning time for class table */
pointerpush(rgc_classtable);
diff --git a/lisp/c/compsub.c b/lisp/c/compsub.c
index aa24a727d..db4679916 100644
--- a/lisp/c/compsub.c
+++ b/lisp/c/compsub.c
@@ -11,6 +11,40 @@ static char *rcsid="@(#)$Id$";
#include "eus.h"
+
+int checkversion(compver, loadver)
+const char* compver;
+const char* loadver;
+{
+ unsigned compmajor=0, compminor=0;
+ unsigned loadmajor=0, loadminor=0;
+ sscanf(compver, "%u.%u", &compmajor, &compminor);
+ sscanf(loadver, "%u.%u", &loadmajor, &loadminor);
+ // check if the major version is equal
+ return (compmajor == loadmajor);
+}
+
+void checkcompversion(compver)
+const char* compver;
+{
+ if (compver==NULL) {
+ error(E_PROGRAM_ERROR,
+ (pointer)"COMPTIMEVERSION not defined. Did you compile with an older EusLisp version?");
+ }
+
+#if defined(COMPILERVERSION)
+ char* loadver = COMPILERVERSION;
+ if (!checkversion(compver, loadver)) {
+ fprintf(stderr, ";; compile time version: %s\n", compver);
+ fprintf(stderr, ";; load time version: %s\n", loadver);
+ error(E_PROGRAM_ERROR, (pointer)"compiler version mismatch");
+ }
+#else
+ error(E_PROGRAM_ERROR,
+ (pointer)"COMPILERVERSION not defined. Is this an older EusLisp version?");
+#endif
+}
+
int maerror()
{ error(E_MISMATCHARG);}
@@ -81,5 +115,6 @@ register context *ctx;
ctx->vsp = (pointer *)cfp;
ctx->callfp = cfp->cf;
ctx->bindfp = cfp->bf;
+ ctx->fletfp = cfp->ff;
ctx->catchfp= cfp->nextcatch;}
diff --git a/lisp/c/eus.c b/lisp/c/eus.c
index 6dc23e193..5a940692f 100644
--- a/lisp/c/eus.c
+++ b/lisp/c/eus.c
@@ -52,6 +52,7 @@ extern pointer *gcstack, *gcsp, *gcsplimit;
/* to protect from being garbage-collected */
pointer sysobj;
+pointer eussigobj;
/* context */
context *mainctx;
@@ -81,6 +82,8 @@ cixpair fcodecp;
/*cixpair modulecp; */
cixpair ldmodulecp;
cixpair closurecp;
+cixpair bindframecp;
+cixpair fletframecp;
cixpair labrefcp;
cixpair threadcp;
cixpair arraycp;
@@ -95,6 +98,12 @@ cixpair extnumcp;
cixpair ratiocp;
cixpair complexcp;
cixpair bignumcp;
+/* conditions */
+cixpair conditioncp;
+cixpair errorcp;
+/* errors */
+cixpair argumenterrorcp, programerrorcp, nameerrorcp;
+cixpair typeerrorcp, valueerrorcp, indexerrorcp, ioerrorcp;
struct built_in_cid builtinclass[64];
@@ -106,7 +115,7 @@ context *euscontexts[MAXTHREAD];
/*symbol management*/
-pointer pkglist,lisppkg,keywordpkg,userpkg,syspkg,unixpkg,xpkg;
+pointer pkglist,lisppkg,keywordpkg,userpkg,compilerpkg,syspkg,unixpkg,xpkg;
pointer NIL,PACKAGE,T,QUOTE;
pointer FUNCTION;
pointer QDECLARE,QSPECIAL;
@@ -118,12 +127,12 @@ pointer SELF;
pointer CLASS;
pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT;
pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER;
-pointer TOPLEVEL,QEVALHOOK,ERRHANDLER,FATALERROR;
-pointer QGCHOOK, QEXITHOOK;
-pointer QUNBOUND,QDEBUG;
+pointer TOPLEVEL,QEVALHOOK,QEXITHOOK,ERRHANDLER,FATALERROR;
+pointer SIGNALS;
+pointer QUNBOUND,QDEBUG,QGCHOOK,QGCDEBUG;
pointer QTHREADS; /* system:*threads* */
pointer QPARAGC;
-pointer QVERSION;
+pointer QVERSION,QCOMPILERVERSION;
pointer QEQ,QEQUAL,QNOT, QAND, QOR;
/* keywords */
@@ -141,11 +150,12 @@ int nextcix;
/*class cells*/
pointer C_CONS, C_OBJECT, C_SYMBOL, C_PACKAGE;
pointer C_STREAM, C_FILESTREAM, C_IOSTREAM, C_CODE, C_FCODE, C_LDMOD;
-pointer C_VECTOR, C_METACLASS, C_CLOSURE, C_LABREF;
+pointer C_VECTOR, C_METACLASS, C_CLOSURE, C_BINDFRAME, C_FLETFRAME, C_LABREF;
pointer C_THREAD;
pointer C_VCLASS, C_FLTVECTOR, C_INTVECTOR, C_STRING, C_BITVECTOR;
pointer C_FOREIGNCODE,C_ARRAY,C_READTABLE;
pointer C_EXTNUM, C_RATIO, C_BIGNUM, C_COMPLEX;
+pointer C_CONDITION, C_ERROR;
/*class names*/
pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL,
@@ -155,6 +165,10 @@ pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE;
pointer FOREIGNCODE,ARRAY,BITVECTOR;
pointer EXTNUM, RATIO, COMPLEX, BIGNUM;
+/*error classes*/
+pointer C_ARGUMENTERROR, C_PROGRAMERROR, C_NAMEERROR;
+pointer C_TYPEERROR, C_VALUEERROR, C_INDEXERROR, C_IOERROR;
+
/*toplevel & evaluation control*/
int intsig,intcode;
int ehbypass;
@@ -171,7 +185,7 @@ pointer OPTIONAL,REST,KEY,AUX,MACRO,LAMBDA,LAMCLOSURE,COMCLOSURE;
pointer PRCIRCLE,PROBJECT,PRSTRUCTURE,PRCASE,PRLENGTH,PRLEVEL;
pointer RANDSTATE,FEATURES,READBASE,PRINTBASE,QREADTABLE,QTERMIO;
pointer GCMERGE,GCMARGIN, QLDENT;
-pointer K_PRIN1;
+pointer K_PRIN1, K_ISATTY, K_NAME;
pointer K_FUNCTION_DOCUMENTATION, K_VARIABLE_DOCUMENTATION,
K_CLASS_DOCUMENTATION, K_METHOD_DOCUMENTATION, K_CLASS;
pointer QLOADED_MODULES;
@@ -189,6 +203,7 @@ jmp_buf topjbuf;
*/
char *errmsg[100]={
+/* FATAL ERROR */
"", /*0*/
"stack overflow", /*1 errcode=1..10 are fatal errors*/
"allocation", /*2*/
@@ -199,78 +214,83 @@ char *errmsg[100]={
"", /*7*/
"", /*8*/
"", /*9*/
+/* ARGUMENT ERROR */
"", /*10 end of fatal error*/
- "attempt to set to constant", /*11 E_SETCONST */
- "unbound variable", /*12 E_UNBOUND */
- "undefined function", /*13 E_UNDEF */
- "mismatch argument", /*14 E_MISMATCHARG */
- "illegal function", /*15 E_ILLFUNC */
- "illegal character", /*16 E_ILLCH */
- "illegal delimiter", /*17 E_READ */
- "write?", /*18 E_WRITE*/
- "too long string", /*19 E_LONGSTRING */
- "symbol expected",
- "list expected",
- "illegal lambda form",
- "illegal lambda parameter syntax",
+ "",
+ "mismatch argument",
+ "illegal parameter syntax",
+ "keyword expected for arguments",
+ "no such keyword",
+ "multiple variable declaration",
+/* PROGRAM ERROR */
+ "",
+ "string is too long",
+ "class table overflow",
+ "declaration is not allowed here",
"no catcher found",
"no such block",
+/* NAME ERROR */
+ "",
+ "unbound variable",
+ "undefined function",
+ "no such package",
+ "cannot find method",
+ "cannot find slot",
+ "no such external symbol",
+ "cannot be used for a variable",
+ "package already exists",
+ "symbol conflict",
+/* TYPE ERROR */
+ "",
+ "attempt to set to constant",
+ "symbol expected",
+ "list expected",
+ "function expected",
"stream expected",
- "illegal stream direction keyword",
- "integer expected",
"string expected",
- "error in open file",
- "EOF hit",
+ "integer expected",
"number expected",
- "class table overflow",
"class expected",
- "vector expected",
- "array size must be positive",
- "duplicated object variable name",
- "cannot make instance",
- "array index out of range", /* E_ARRAYINDEX */
- "cannot find method",
- "circular list",
- "unknown sharp macro",
- "list expected for an element of an alist",
- "macro expected",
- "no such package",
- "package name",
- "invalid lisp object form",
- "no such object variable",
+ "object expected",
"sequence expected",
- "illegal start/end index",
- "no super class",
- "invalid format string",
+ "array expected",
+ "vector expected",
"float vector expected",
- "char code out of range",
- "vector dimension mismatch",
- "object expected",
+ "integer vector expected",
+ "bit vector expected",
+ "bind-frame expected",
+ "flet-frame expected",
"type mismatch",
- "declaration is not allowed here",
- "illegal declaration form",
- "cannot be used for a variable",
+
+/* VALUE ERROR */
+ "",
"illegal rotation axis",
- "multiple variable declaration",
- "illegal #n= or #n= label",
- "illegal #f( expression",
- "illegal #v or #j expression",
- "invalid socket address",
- "array expected",
+ "char code out of range",
+ "searching a circular list",
+/* INDEX ERROR */
+ "",
"array dimension mismatch",
- "keyword expected for arguments",
- "no such keyword",
- "integer vector expected",
- "sequence index out of range",
- "not a bit vector",
- "no such external symbol",
- "symbol conflict",
+ "array index out of range",
+ "vector dimension mismatch",
+ "vector index out of range",
+ "sequence index out of range",
+/* IO ERROR */
+ "",
+ "illegal stream direction",
+ "error in open file",
+ "EOF hit",
+ "illegal character",
+ "delimiter expected",
+ "invalid format string",
+ "illegal #n= or #n# label",
+/* USER ERROR */
"",
+/* REPL ERROR */
+ "",
+/* END ERROR */
"E_END",
};
-static pointer brkloop();
-
void unwind(ctx,p)
register context *ctx;
register pointer *p;
@@ -283,14 +303,17 @@ register pointer *p;
ufuncall(ctx,cleanup,cleanup,NULL,NULL,0);}
/*an error may occur if catch, throw or return-from or access to
special variables are taken in clean up forms*/
- /*unwind specially bound variables*/
+ // unwind context before euslongjmp
+ // bind-frames are unwinded by the binder itself (e.g. PARLET) or at the eussetjmp catcher
+ // flet-frames are unwinded at the end of ufuncall evaluation or at the eussetjmp catcher
+ /*unwind specially bound variables*/
unbindspecial(ctx,(struct specialbindframe *)p);
/*unwind block frames*/
while (ctx->blkfp>(struct blockframe *)p) ctx->blkfp=ctx->blkfp->dynklink;
/*unwind catch frames*/
while (ctx->catchfp>(struct catchframe *)p) ctx->catchfp=ctx->catchfp->nextcatch;
- /*unwind flet frames*/
- while (ctx->fletfp>(struct fletframe *)p) ctx->fletfp=ctx->fletfp->dynlink;
+ /*unwind call frames*/
+ while (ctx->callfp>(struct callframe *)p) ctx->callfp=ctx->callfp->vlink;
}
#ifdef USE_STDARG
@@ -303,11 +326,10 @@ va_dcl
va_list args;
pointer errhandler;
register char *errstr;
- register int argc;
register context *ctx;
register struct callframe *vf;
- pointer msg;
- int i, n;
+ pointer msg,form,callstack;
+ pointer errobj;
#ifdef USE_STDARG
va_start(args,ec);
@@ -320,18 +342,8 @@ va_dcl
ctx=euscontexts[thr_self()];
- /* print call stack */
- n=intval(Spevalof(MAXCALLSTACKDEPTH));
- if (n > 0) {
- fprintf( stderr, "Call Stack (max depth: %d):\n", n );
- vf=(struct callframe *)(ctx->callfp);
- for (i = 0; vf->vlink != NULL && i < n; ++i, vf = vf->vlink) {
- fprintf( stderr, " %d: at ", i );
- prinx(ctx, vf->form, ERROUT);
- flushstream(ERROUT);
- fprintf( stderr, "\n" ); }
- if (vf->vlink != NULL) {
- fprintf (stderr, " And more...\n"); }}
+ // variable arguments are not guarded from gc!!
+ // push them as required
/* error(errstr) must be error(E_USER,errstr) */
if ((int)ec < E_END) errstr=errmsg[(int)ec];
@@ -348,59 +360,114 @@ va_dcl
fprintf(stderr, "exiting\n"); exit(ec);}
else throw(ctx,makeint(0),NIL);}
- /* get extra message */
+ /* get message */
+ pointer dest;
+ char *msgstr;
switch((unsigned int)ec) {
case E_UNBOUND: case E_UNDEF: case E_NOCLASS: case E_PKGNAME:
- case E_NOOBJ: case E_NOOBJVAR: case E_NOPACKAGE: case E_NOMETHOD:
+ case E_NOSLOT: case E_NOPACKAGE: case E_NOMETHOD:
case E_NOKEYPARAM: case E_READLABEL: case E_ILLCH: case E_NOCATCHER:
- case E_NOVARIABLE: case E_EXTSYMBOL: case E_SYMBOLCONFLICT:
- case E_USER:
- msg = va_arg(args,pointer); break;
- }
-
- /* call user's error handler function */
- errhandler=ctx->errhandler;
- if (errhandler==NIL || errhandler==NULL) errhandler=Spevalof(ERRHANDLER);
- Spevalof(QEVALHOOK)=NIL; /* reset eval hook */
- if (errhandler!=NIL) {
+ case E_EXTSYMBOL: case E_SYMBOLCONFLICT:
+ vpush(va_arg(args,pointer));
+ dest=(pointer)mkstream(ctx,K_OUT,makebuffer(64));
+ prinx(ctx,vpop(),dest);
+ msgstr=(char*)malloc(2+ strlen(errstr) + intval(dest->c.stream.count));
+ strcpy(msgstr,errstr);
+ strcat(msgstr,(char*)" ");
+ strcat(msgstr,makestring((char *)dest->c.stream.buffer->c.str.chars,
+ intval(dest->c.stream.count))->c.str.chars);
+ msg=makestring(msgstr,strlen(msgstr));
+ free(msgstr);
+ break;
+ case E_REPL:
+ errobj = (pointer)va_arg(args,pointer);
+ msg = (pointer)va_arg(args,pointer);
+ vpush(errobj);
+ break;
+ case E_ARGUMENT_ERROR: case E_PROGRAM_ERROR: case E_NAME_ERROR: case E_TYPE_ERROR:
+ case E_VALUE_ERROR: case E_INDEX_ERROR: case E_IO_ERROR: case E_USER:
+ errstr = (char*)va_arg(args,pointer);
+ default:
+ msg=makestring(errstr,strlen(errstr));}
+
+ vpush(msg);
+ va_end(args);
+
+ /* try calling legacy handler when set */
+ if (Spevalof(ERRHANDLER)!=NIL) {
+ int argc;
+ errhandler=Spevalof(ERRHANDLER);
+ Spevalof(QEVALHOOK)=NIL; /* reset eval hook */
vpush(makeint((unsigned int)ec));
- vpush(makestring(errstr,strlen(errstr)));
+ vpush(msg);
if (ctx->callfp) vpush(ctx->callfp->form); else vpush(NIL);
switch((unsigned int)ec) {
case E_UNBOUND: case E_UNDEF: case E_NOCLASS: case E_PKGNAME:
- case E_NOOBJ: case E_NOOBJVAR: case E_NOPACKAGE: case E_NOMETHOD:
+ case E_NOSLOT: case E_NOPACKAGE: case E_NOMETHOD:
case E_NOKEYPARAM: case E_READLABEL: case E_ILLCH: case E_NOCATCHER:
- case E_NOVARIABLE: case E_EXTSYMBOL: case E_SYMBOLCONFLICT:
- vpush(msg); argc=4; break;
- case E_USER:
- vpush(makestring((char*)msg,strlen((char*)msg))); argc=4; break;
+ case E_EXTSYMBOL: case E_SYMBOLCONFLICT: case E_USER:
+ vpush(NIL); argc=4; break;
default: argc=3; break;}
ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-argc),ctx->bindfp,argc);
ctx->vsp-=argc;
- }
+ return NIL;}
- /*default error handler*/
- flushstream(ERROUT);
- fprintf(stderr,"%s: ERROR th=%d %s ",progname,thr_self(),errstr);
- switch((int)ec) {
- case E_UNBOUND: case E_UNDEF: case E_NOCLASS: case E_PKGNAME:
- case E_NOOBJ: case E_NOOBJVAR: case E_NOPACKAGE: case E_NOMETHOD:
- case E_NOKEYPARAM: case E_READLABEL: case E_ILLCH: case E_NOCATCHER:
- case E_NOVARIABLE: case E_EXTSYMBOL: case E_SYMBOLCONFLICT:
- prinx(ctx,msg,ERROUT); flushstream(ERROUT); break;
- }
- if( ec == E_USER ) {
- fprintf( stderr,"%s",(char*)msg ); flushstream(ERROUT); }
- else if (ispointer(msg)) {prinx(ctx,msg,ERROUT); flushstream(ERROUT); }
- if (ctx->callfp) {
- fprintf(stderr," in ");
- prinx(ctx,ctx->callfp->form,ERROUT);
- flushstream(ERROUT);}
- /*enter break loop*/
- brkloop(ctx,"E: ");
- throw(ctx,makeint(0),T); /*throw to toplevel*/
+ /* call user's error handler function */
+ errhandler=getfunc_closure_noexcept(ctx, SIGNALS);
+
+ /* get call stack */
+ callstack=list_callstack(ctx,-1);
+
+ /* get form */
+ if (ctx->callfp) form=ctx->callfp->form; else form=NIL;
+
+ switch((unsigned int)ec) {
+ // ARGUMENT ERROR
+ case E_ARGUMENT_ERROR: case E_MISMATCHARG: case E_PARAMETER:
+ case E_KEYPARAM: case E_NOKEYPARAM: case E_MULTIDECL:
+ errobj=makeobject(C_ARGUMENTERROR); break;
+ // PROGRAM ERROR
+ case E_PROGRAM_ERROR: case E_LONGSTRING: case E_CLASSOVER:
+ case E_DECLARE: case E_NOCATCHER: case E_NOBLOCK:
+ errobj=makeobject(C_PROGRAMERROR); break;
+ // NAME ERROR
+ case E_NAME_ERROR: case E_UNBOUND: case E_UNDEF: case E_NOPACKAGE:
+ case E_NOMETHOD: case E_NOSLOT: case E_EXTSYMBOL: case E_ILLVARIABLE:
+ case E_PKGNAME: case E_SYMBOLCONFLICT:
+ errobj=makeobject(C_NAMEERROR); break;
+ // TYPE ERROR
+ case E_TYPE_ERROR: case E_SETCONST: case E_NOSYMBOL: case E_NOLIST:
+ case E_NOFUNCTION: case E_STREAM: case E_NOSTRING: case E_NOINT:
+ case E_NONUMBER: case E_NOCLASS: case E_NOOBJECT: case E_NOSEQ:
+ case E_NOARRAY: case E_NOVECTOR: case E_FLOATVECTOR: case E_NOINTVECTOR:
+ case E_BITVECTOR: case E_NOBINDFRAME: case E_NOFLETFRAME: case E_TYPEMISMATCH:
+ errobj=makeobject(C_TYPEERROR); break;
+ // VALUE ERROR
+ case E_VALUE_ERROR: case E_ROTAXIS: case E_CHARRANGE: case E_CIRCULAR:
+ errobj=makeobject(C_VALUEERROR); break;
+ // INDEX ERROR
+ case E_INDEX_ERROR: case E_ARRAYDIMENSION: case E_ARRAYINDEX:
+ case E_VECSIZE: case E_VECINDEX: case E_SEQINDEX:
+ errobj=makeobject(C_INDEXERROR); break;
+ // IO ERROR
+ case E_IO_ERROR: case E_IODIRECTION: case E_OPENFILE: case E_EOF:
+ case E_ILLCH: case E_NODELIMITER: case E_FORMATSTRING: case E_READLABEL:
+ errobj=makeobject(C_IOERROR); break;
+ // USER ERROR
+ case E_USER:
+ errobj=makeobject(C_ERROR); break;
}
+ pointer_update(errobj->c.obj.iv[0],msg);
+ pointer_update(errobj->c.obj.iv[1],callstack);
+ pointer_update(errobj->c.obj.iv[2],form);
+
+ Spevalof(QEVALHOOK)=NIL; /* reset eval hook */
+ if (errhandler!=NIL && errhandler!=UNBOUND) {
+ vpush(errobj);
+ ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-1),ctx->bindfp,1);}
+}
+
#ifdef USE_STDARG
pointer basicclass(char *name, ...)
#else
@@ -416,6 +483,10 @@ va_dcl
int n,i,svcount;
context *ctx=mainctx;
+ // C_VECTOR is only guarded from gc after it is
+ // assigned to speval(VECTOR) in initclasses()
+ vpush(C_VECTOR);
+
#ifdef USE_STDARG
va_start(ap, name);
#else
@@ -426,6 +497,7 @@ va_dcl
#endif
super=va_arg(ap,pointer);
cixp=va_arg(ap,cixpair *); n=va_arg(ap,int);
+ vpush(super);
/*class name symbols are defined in lisp package*/
classsym=intern(ctx,(char *)name,strlen(name),lisppkg);
@@ -455,7 +527,7 @@ va_dcl
nextbclass++;
cixp->cix=intval(class->c.cls.cix);
cixp->sub=classtab[cixp->cix].subcix;
- ctx->vsp-=3;
+ ctx->vsp-=5;
va_end(ap);
return(classsym);}
@@ -564,6 +636,7 @@ static void initpackage()
NIL->c.sym.speval=NIL;
NIL->c.sym.plist=NIL;
sysobj=NIL;
+ eussigobj=NIL;
pkglist->c.cons.cdr=NIL;
lisppkg->c.pkg.use=NIL;
lisppkg->c.pkg.names->c.cons.cdr=NIL;
@@ -575,6 +648,7 @@ static void initpackage()
/*default packages*/
keywordpkg=makepkg(ctx,makestring("KEYWORD",7),NIL,NIL);
userpkg= makepkg(ctx,makestring("USER",4),NIL,rawcons(ctx,lisppkg,NIL));
+ compilerpkg= makepkg(ctx,makestring("COMPILER",8),NIL,rawcons(ctx,lisppkg,NIL));
syspkg= makepkg(ctx,makestring("SYSTEM",6),NIL,rawcons(ctx,lisppkg,NIL));
unixpkg= makepkg(ctx,makestring("UNIX",4),NIL,rawcons(ctx,lisppkg,NIL));
xpkg= makepkg(ctx,makestring("X",1),NIL,rawcons(ctx,lisppkg,NIL));
@@ -638,6 +712,8 @@ static void initsymbols()
K_FOREIGN_STRING=defkeyword(ctx,"FOREIGN-STRING");
K_ALLOWOTHERKEYS=defkeyword(ctx,"ALLOW-OTHER-KEYS");
K_PRIN1=defkeyword(ctx,"PRIN1");
+ K_ISATTY=defkeyword(ctx,"ISATTY");
+ K_NAME=defkeyword(ctx,"NAME");
K_CLASS=defkeyword(ctx,"CLASS");
K_FUNCTION_DOCUMENTATION=defkeyword(ctx,"FUNCTION-DOCUMENTATION");
K_CLASS_DOCUMENTATION=defkeyword(ctx,"CLASS-DOCUMENTATION");
@@ -679,9 +755,11 @@ static void initsymbols()
QLDENT=defvar(ctx,"*LOAD-ENTRIES*", NIL, syspkg);
QTHREADS=defvar(ctx, "*THREADS*", NIL, syspkg);
QPARAGC=defvar(ctx, "*PARALLEL-GC*", NIL, syspkg);
+ QGCDEBUG=defvar(ctx,"*GC-DEBUG*",NIL,syspkg);
QGCHOOK=defvar(ctx,"*GC-HOOK*",NIL,syspkg);
QEXITHOOK=defvar(ctx,"*EXIT-HOOK*",NIL,syspkg);
FATALERROR=defvar(ctx,"*EXIT-ON-FATAL-ERROR*",NIL,lisppkg);
+ SIGNALS=intern(ctx,"SIGNALS",7,lisppkg);
/*init character macro table*/
for (i=0; i<256; i++) charmacro[i]=sharpmacro[i]=NIL;
@@ -743,43 +821,31 @@ static void initclasses()
C_ARRAY=speval(ARRAY);
/*12 */
THREAD=basicclass("THREAD", C_PROPOBJ, &threadcp,
- 10, "ID", "REQUESTER", "REQUEST-SEM", "DONE-SEM",
+ 11, "ID", "REQUESTER", "REQUEST-SEM", "RUN-SEM", "DONE-SEM",
"FUNC", "ARGS", "RESULT", "CONTEXT",
"IDLE", "WAIT");
C_THREAD=speval(THREAD);
/*13*/
- CODE=basicclass("COMPILED-CODE",C_OBJECT,&codecp,4,"CODEVECTOR","QUOTEVECTOR",
+#if ARM // ARM uses entry2
+ CODE=basicclass("COMPILED-CODE",C_PROPOBJ,&codecp,5,"CODEVECTOR","QUOTEVECTOR",
+ "TYPE","ENTRY","ENTRY2");
+#else
+ CODE=basicclass("COMPILED-CODE",C_PROPOBJ,&codecp,4,"CODEVECTOR","QUOTEVECTOR",
"TYPE","ENTRY");
+#endif
C_CODE=speval(CODE);
/*14*/
- FCODE=basicclass("FOREIGN-CODE",C_CODE,&fcodecp,3,"ENTRY2","PARAMTYPES","RESULTTYPE"); /* kanehiro's patch 2000.12.13 */
- C_FCODE=speval(FCODE);
-/*15*/
-#if (WORD_SIZE == 64)
- CLOSURE=basicclass("CLOSURE",C_CODE,&closurecp,
-#if ARM // ARM uses entry2 in struct closure in eus.h
- 4,"ENTRY2",
-#else
- 3,
-#endif
- "ENV0","ENV1","ENV2");
-#else
- CLOSURE=basicclass("CLOSURE",C_CODE,&closurecp,
-#if ARM // ARM uses entry2 in struct closure in eus.h
- 3,"ENTRY2",
+#if ARM // foreign code always has entry2 (kanehiro's patch 2000.12.13)
+ FCODE=basicclass("FOREIGN-CODE",C_CODE,&fcodecp,2,"PARAMTYPES","RESULTTYPE");
#else
- 2,
-#endif
- "ENV1","ENV2");
+ FCODE=basicclass("FOREIGN-CODE",C_CODE,&fcodecp,3,"ENTRY2","PARAMTYPES","RESULTTYPE");
#endif
+ C_FCODE=speval(FCODE);
+/*15*/
+ CLOSURE=basicclass("CLOSURE",C_CODE,&closurecp,2,"ENV0","ENV1");
C_CLOSURE=speval(CLOSURE);
/* 16 ---new for Solaris */
- LDMODULE=basicclass("LOAD-MODULE",C_CODE, &ldmodulecp,
-#if ARM // ARM uses entry2 in struct ldmodule in eus.h
- 4,"ENTRY2",
-#else
- 3,
-#endif
+ LDMODULE=basicclass("LOAD-MODULE",C_CODE, &ldmodulecp,3,
"SYMBOL-TABLE","OBJECT-FILE", "HANDLE");
C_LDMOD=speval(LDMODULE);
/*17*/
@@ -807,6 +873,7 @@ static void initclasses()
builtinclass[nextbclass].cls=C_STRING;
builtinclass[nextbclass++].cp= &stringcp;
+/* derived classes */
BITVECTOR=defvector(ctx,"BIT-VECTOR",C_VECTOR,ELM_BIT, 0); /* alpha */
C_BITVECTOR=speval(BITVECTOR);
builtinclass[nextbclass].cls=C_BITVECTOR;
@@ -822,10 +889,30 @@ static void initclasses()
BIGNUM=basicclass("BIGNUM", C_EXTNUM, &bignumcp, 2, "SIZE", "BV");
C_BIGNUM=speval(BIGNUM);
+/* bind frames */
+ C_BINDFRAME=speval(basicclass("BIND-FRAME",C_OBJECT,&bindframecp,3,
+ "SYMBOL","VALUE","NEXT"));
+ C_FLETFRAME=speval(basicclass("FLET-FRAME",C_OBJECT,&fletframecp,3,
+ "NAME","FCLOSURE","NEXT"));
+
+/* conditions */
+ C_CONDITION=speval(basicclass("CONDITION",C_OBJECT,&conditioncp,1,"MESSAGE"));
+ C_ERROR=speval(basicclass("ERROR",C_CONDITION,&errorcp,2,"CALLSTACK","FORM"));
+ C_ARGUMENTERROR=speval(basicclass("ARGUMENT-ERROR",C_ERROR,&argumenterrorcp,0));
+ C_PROGRAMERROR=speval(basicclass("PROGRAM-ERROR",C_ERROR,&programerrorcp,0));
+ C_NAMEERROR=speval(basicclass("NAME-ERROR",C_ERROR,&nameerrorcp,0));
+ C_TYPEERROR=speval(basicclass("TYPE-ERROR",C_ERROR,&typeerrorcp,0));
+ C_VALUEERROR=speval(basicclass("VALUE-ERROR",C_ERROR,&valueerrorcp,0));
+ C_INDEXERROR=speval(basicclass("INDEX-ERROR",C_ERROR,&indexerrorcp,0));
+ C_IOERROR=speval(basicclass("IO-ERROR",C_ERROR,&ioerrorcp,0));
+
+ /*populate sysobj*/
for (i=0;iintsig);}
}
-static pointer brkloop(ctx, prompt)
-context *ctx;
-char *prompt;
-{ jmp_buf brkjmp;
- pointer val;
- int i;
- mkcatchframe(ctx,T,&brkjmp);
- Spevalof(QSTDOUT)=STDOUT;
- Spevalof(QSTDIN)=STDIN;
- Spevalof(QERROUT)=ERROUT;
- if ((val=(pointer)eussetjmp(brkjmp))==0) val=reploop(ctx,prompt);
- else if ((eusinteger_t)val==1) val=makeint(0); /*longjmp cannot return 0*/
- ctx->callfp=ctx->catchfp->cf;
- ctx->bindfp=ctx->catchfp->bf;
- ctx->vsp=(pointer *)ctx->catchfp;
- ctx->catchfp=(struct catchframe *)*(ctx->vsp);
- return(val);}
-
void sigbreak()
{ pointer sighandler,*vspsave;
context *ctx=euscontexts[thr_self()];
@@ -1075,7 +1146,6 @@ void sigbreak()
ctx->vsp=vspsave; }
else {
fprintf(stderr,"signal=%d to thread %d, \n",is, thr_self());
- /* brkloop(ctx,"B: "); */
return; }}
@@ -1403,5 +1473,3 @@ eusinteger_t intval(pointer p) {
else return (((eusinteger_t)i)>>2);
}
#endif
-
-eusinteger_t hide_ptr (pointer p) { return (eusinteger_t)p; }
diff --git a/lisp/c/eus.h b/lisp/c/eus.h
index 97852175b..b934ae293 100644
--- a/lisp/c/eus.h
+++ b/lisp/c/eus.h
@@ -228,6 +228,7 @@ struct package {
};
struct code {
+ pointer plist;
pointer codevec;
pointer quotevec;
pointer subrtype; /*function,macro,special*/
@@ -238,15 +239,17 @@ struct code {
};
struct fcode { /*foreign function code*/
+ pointer plist;
pointer codevec;
pointer quotevec;
pointer subrtype;
pointer entry;
- pointer entry2; /* kanehiro's patch 2000.12.13 */
+ pointer entry2; /* foreign code always has entry2 (kanehiro's patch 2000.12.13) */
pointer paramtypes;
pointer resulttype;};
struct ldmodule { /*foreign language object module*/
+ pointer plist;
pointer codevec;
pointer quotevec;
pointer subrtype; /*function,macro,special*/
@@ -259,6 +262,7 @@ struct ldmodule { /*foreign language object module*/
pointer handle;}; /* dl's handle */
struct closure {
+ pointer plist;
pointer codevec;
pointer quotevec;
pointer subrtype; /*function,macro,special*/
@@ -267,8 +271,7 @@ struct closure {
pointer entry2; /* some archtecture did not set code on 4 byte alignment */
#endif
pointer env0; /*upper closure link*/
- pointer *env1; /*argument pointer: argv*/
- pointer *env2;}; /*local variable frame: local*/
+ pointer env1;}; /*local frame (argframe, bindframe, fletframe)*/
struct stream {
pointer plist;
@@ -294,7 +297,7 @@ struct labref { /*used for reading labeled forms: #n#,#n=*/
pointer label;
pointer value;
pointer unsolved;
- pointer next; };
+ pointer next;};
struct vector {
pointer size;
@@ -364,6 +367,16 @@ struct threadport {
pointer idle;
pointer wait;};
+struct bindframe {
+ pointer sym;
+ pointer val;
+ pointer next;};
+
+struct fletframe {
+ pointer name;
+ pointer fclosure;
+ pointer next;};
+
/* extended numbers */
struct ratio {
pointer numerator;
@@ -419,6 +432,8 @@ typedef
struct vecclass vcls;
struct readtable rdtab;
struct threadport thrp;
+ struct bindframe bfp;
+ struct fletframe ffp;
struct ratio ratio;
struct complex cmplx;
struct bignum bgnm;
@@ -476,11 +491,6 @@ struct callframe {
pointer form;
};
-struct bindframe { /*to achieve lexical binding in the interpreter*/
- struct bindframe *dynblink, *lexblink; /*links to upper level*/
- pointer sym; /*symbol*/
- pointer val;}; /*bound value*/
-
struct specialbindframe { /*special value binding frame*/
struct specialbindframe *sblink;
pointer sym; /*pointer to the symbol word(dynval or dynfunc)*/
@@ -495,9 +505,9 @@ struct blockframe {
struct catchframe {
struct catchframe *nextcatch;
pointer label;
- struct bindframe *bf; /*bind frame save*/
+ pointer bf; /*bind frame save*/
struct callframe *cf; /*call frame save*/
- struct fletframe *ff;
+ pointer ff; /*fletframe*/
jmp_buf *jbp;
};
@@ -506,13 +516,6 @@ struct protectframe {
pointer cleaner; /*cleanup form closure*/
};
-struct fletframe {
- pointer name;
- pointer fclosure;
- struct fletframe *scope;
- struct fletframe *lexlink;
- struct fletframe *dynlink;};
-
#define MAXMETHCACHE 256 /*must be power to 2*/
struct methdef {
@@ -528,13 +531,12 @@ typedef struct {
#endif
struct callframe *callfp;
struct catchframe *catchfp;
- struct bindframe *bindfp;
+ pointer bindfp;
struct specialbindframe *sbindfp;
struct blockframe *blkfp;
struct protectframe *protfp;
- struct fletframe *fletfp, *newfletfp;
+ pointer fletfp;
pointer lastalloc;
- pointer errhandler;
pointer threadobj;
struct methdef *methcache;
struct buddyfree *thr_buddy;
@@ -601,6 +603,7 @@ extern long alloccount[MAXBUDDY];
/* System internal objects are connected to sysobj list
/* to protect from garbage-collection */
extern pointer sysobj;
+extern pointer eussigobj;
extern pointer lastalloc;
/* thread euscontexts */
@@ -627,6 +630,8 @@ extern cixpair fcodecp;
/*cixpair modulecp; */
extern cixpair ldmodulecp;
extern cixpair closurecp;
+extern cixpair bindframecp;
+extern cixpair fletframecp;
extern cixpair labrefcp;
extern cixpair threadcp;
extern cixpair arraycp;
@@ -659,9 +664,8 @@ extern pointer SELF;
extern pointer CLASS;
extern pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT;
extern pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER;
-extern pointer TOPLEVEL,QEVALHOOK,ERRHANDLER;
-extern pointer QGCHOOK, QEXITHOOK;
-extern pointer QUNBOUND,QDEBUG;
+extern pointer TOPLEVEL,QEVALHOOK,QEXITHOOK;
+extern pointer QUNBOUND,QDEBUG,QGCHOOK,QGCDEBUG;
extern pointer QTHREADS;
extern pointer QEQ,QEQUAL,QNOT;
extern pointer QAND, QOR, QNOT;
@@ -689,6 +693,7 @@ extern pointer C_THREAD;
extern pointer C_VCLASS, C_FLTVECTOR, C_INTVECTOR, C_STRING, C_BITVECTOR;
extern pointer C_FOREIGNCODE,C_ARRAY,C_READTABLE;
extern pointer C_EXTNUM, C_RATIO, C_COMPLEX, C_BIGNUM;
+extern pointer C_CONDITION, C_ERROR;
/*class names*/
extern pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL,
@@ -713,14 +718,12 @@ extern int export_all;
/****************************************************************/
#ifdef RGC
-#define carof(p,err) (islist(p)?(p)->c.cons.car:(pointer)error(E_DUMMY5,(pointer)(err)))
-#define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:(pointer)error(E_DUMMY5,(pointer)(err)))
#define alloc rgc_alloc
#else
-#define carof(p,err) (islist(p)?(p)->c.cons.car:(pointer)error(E_DUMMY3,(pointer)(err)))
-#define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:(pointer)error(E_DUMMY3,(pointer)(err)))
#define alloc gc_alloc
#endif
+#define carof(p,err) (islist(p)?(p)->c.cons.car:(pointer)error((enum errorcode)(err)))
+#define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:(pointer)error((enum errorcode)(err)))
#define ccar(p) ((p)->c.cons.car)
#define ccdr(p) ((p)->c.cons.cdr)
#define cixof(p) ((p)->cix)
@@ -827,8 +830,8 @@ extern eusinteger_t intval(pointer p);
#endif
/*predicates to test object type*/
-#define pislist(p) (p->cix<=conscp.sub)
-#define piscons(p) (p->cix<=conscp.sub)
+#define pislist(p) (conscp.cix<=(p)->cix && (p)->cix<=conscp.sub)
+#define piscons(p) (conscp.cix<=(p)->cix && (p)->cix<=conscp.sub)
#define pispropobj(p) (propobjcp.cix<=(p)->cix && (p)->cix<=propobjcp.sub)
#define ispropobj(p) (ispointer(p) && pispropobj(p))
#define pissymbol(p) (symbolcp.cix<=(p)->cix && (p)->cix<=symbolcp.sub)
@@ -858,6 +861,7 @@ extern eusinteger_t intval(pointer p);
#define isfltvector(p) (ispointer(p) && (elmtypeof(p)==ELM_FLOAT))
#define isptrvector(p) (ispointer(p) && (elmtypeof(p)==ELM_POINTER))
#define isintvector(p) (ispointer(p) && (elmtypeof(p)==ELM_INT))
+#define isbitvector(p) (ispointer(p) && (elmtypeof(p)==ELM_BIT))
#define pisclass(p) (metaclasscp.cix<=(p)->cix && (p)->cix<=metaclasscp.sub)
#define isclass(p) (ispointer(p) && pisclass(p))
#define pisvecclass(p) (vecclasscp.cix<=(p)->cix && (p)->cix<=vecclasscp.sub)
@@ -866,6 +870,12 @@ extern eusinteger_t intval(pointer p);
#define ispackage(p) (ispointer(p) && pispackage(p))
#define pisclosure(p) (closurecp.cix<=(p)->cix && (p)->cix<=closurecp.sub)
#define isclosure(p) (ispointer(p) && pisclosure(p))
+#define pisbindframe(p) (bindframecp.cix<=(p)->cix && (p)->cix<=bindframecp.sub)
+#define isbindframe(p) (ispointer(p) && pisbindframe(p))
+#define pisfletframe(p) (fletframecp.cix<=(p)->cix && (p)->cix<=fletframecp.sub)
+#define isfletframe(p) (ispointer(p) && pisfletframe(p))
+#define pisthread(p) (threadcp.cix<=(p)->cix && (p)->cix<=threadcp.sub)
+#define isthread(p) (ispointer(p) && pisthread(p))
#define pislabref(p) (labrefcp.cix<=(p)->cix && (p)->cix<=labrefcp.sub)
#define islabref(p) (ispointer(p) && pislabref(p))
/* extended numbers */
@@ -936,75 +946,87 @@ enum errorcode {
E_DUMMY10,
#define E_FATAL 10
/* followings are not fatal errors */
- E_SETCONST, /*11 attempt to set to constant*/
+
+/* ARGUMENT ERROR */
+ E_ARGUMENT_ERROR,
+ E_MISMATCHARG,
+ E_PARAMETER,
+ E_KEYPARAM,
+ E_NOKEYPARAM,
+ E_MULTIDECL,
+
+/* PROGRAM ERROR */
+ E_PROGRAM_ERROR,
+ E_LONGSTRING,
+ E_CLASSOVER,
+ E_DECLARE,
+ E_NOCATCHER,
+ E_NOBLOCK,
+
+/* NAME ERROR */
+ E_NAME_ERROR,
E_UNBOUND,
E_UNDEF,
- E_MISMATCHARG,
- E_ILLFUNC,
- E_ILLCH,
- E_READ,
- E_WRITE,
- E_LONGSTRING, /*19: string too long*/
- E_NOSYMBOL, /*20: symbol expected*/
- E_NOLIST, /*list expected*/
- E_LAMBDA, /*illegal lambda form*/
- E_PARAMETER, /*illegal lambda parameter syntax*/
- E_NOCATCHER, /*no catch block */
- E_NOBLOCK, /*no block to return*/
- E_STREAM, /*stream expected*/
- E_IODIRECTION, /*io stream direction keyword*/
- E_NOINT, /*integer value expected*/
- E_NOSTRING, /*string expected*/
- E_OPENFILE, /*30: error in open*/
- E_EOF, /*EOF encountered*/
- E_NONUMBER, /*number expected*/
- E_CLASSOVER, /*class table overflow*/
- E_NOCLASS, /*class expected*/
- E_NOVECTOR, /*vector expected*/
- E_VECSIZE, /*error of vector size*/
- E_DUPOBJVAR, /*duplicated object variable name*/
- E_INSTANTIATE, /*38: cannot make an instance*/
- E_ARRAYINDEX,
- E_NOMETHOD, /*40*/
+ E_NOPACKAGE,
+ E_NOMETHOD,
+ E_NOSLOT,
+ E_EXTSYMBOL,
+ E_ILLVARIABLE,
+ E_PKGNAME,
+ E_SYMBOLCONFLICT,
+
+/* TYPE ERROR */
+ E_TYPE_ERROR,
+ E_SETCONST,
+ E_NOSYMBOL,
+ E_NOLIST,
+ E_NOFUNCTION,
+ E_STREAM,
+ E_NOSTRING,
+ E_NOINT,
+ E_NONUMBER,
+ E_NOCLASS,
+ E_NOOBJECT,
+ E_NOSEQ,
+ E_NOARRAY,
+ E_NOVECTOR,
+ E_FLOATVECTOR,
+ E_NOINTVECTOR,
+ E_BITVECTOR,
+ E_NOBINDFRAME,
+ E_NOFLETFRAME,
+ E_TYPEMISMATCH,
+
+/* VALUE ERROR */
+ E_VALUE_ERROR,
+ E_ROTAXIS,
+ E_CHARRANGE,
E_CIRCULAR,
- E_SHARPMACRO, /*unknown sharp macro*/
- E_ALIST, /*list expected for an element of an alist*/
- E_NOMACRO, /*macro expected*/
- E_NOPACKAGE, /*no such package */
- E_PKGNAME, /*the package already exists*/
- E_NOOBJ, /*invalid form*/
- E_NOOBJVAR, /*48: not an object variable*/
- E_NOSEQ, /*sequence(list,string,vector) expected*/
- E_STARTEND, /*illegal subsequence index*/
- E_NOSUPER, /*no superclass*/
- E_FORMATSTRING, /*invalid format string character*/
- E_FLOATVECTOR, /*float vector expected*/
- E_CHARRANGE, /*0..255*/
- E_VECINDEX, /*vector index mismatch*/
- E_NOOBJECT, /*other than numbers expected*/
- E_TYPEMISMATCH, /*the: type mismatch*/
- E_DECLARE, /*illegal declaration*/
- E_DECLFORM, /*invalid declaration form*/
- E_NOVARIABLE, /*constant is used in let or lambda*/
- E_ROTAXIS, /*illegal rotation axis spec*/
- E_MULTIDECL,
- E_READLABEL, /*illegal #n= or #n# label*/
- E_READFVECTOR, /*error of #f( expression*/
- E_READOBJECT, /*error in #V or #J format*/
- E_SOCKET, /*error of socket address*/
- E_NOARRAY, /*array expected*/
- E_ARRAYDIMENSION, /*array dimension mismatch*/
- E_KEYPARAM, /*keyword parameter expected*/
- E_NOKEYPARAM, /*no such keyword*/
- E_NOINTVECTOR, /*integer vector expected*/
- E_SEQINDEX, /*sequence index out of range*/
- E_BITVECTOR, /*not a bit vector*/
- E_EXTSYMBOL, /*no such external symbol*/
- E_SYMBOLCONFLICT, /*symbol conflict in a package*/
-
-/* the following error is added by APT */
+
+/* INDEX ERROR */
+ E_INDEX_ERROR,
+ E_ARRAYDIMENSION,
+ E_ARRAYINDEX,
+ E_VECSIZE,
+ E_VECINDEX,
+ E_SEQINDEX,
+
+/* IO ERROR */
+ E_IO_ERROR,
+ E_IODIRECTION,
+ E_OPENFILE,
+ E_EOF,
+ E_ILLCH,
+ E_NODELIMITER,
+ E_FORMATSTRING,
+ E_READLABEL,
+
+/* custom error */
E_USER,
+/* error from the lisp REPL */
+ E_REPL,
+
/* E_END must locate at the end of the error list */
E_END
};
@@ -1021,24 +1043,24 @@ extern "C" {
extern pointer eval(context *, pointer);
extern pointer eval2(context *, pointer, pointer);
extern pointer ufuncall(context *, pointer, pointer, pointer,
- struct bindframe *, int);
+ pointer /*bindframe*/, int);
extern pointer funlambda(context *, pointer, pointer, pointer, pointer *,
- struct bindframe *, int);
+ pointer /*bindframe*/, int);
extern pointer funcode(context *, pointer, pointer, int);
extern pointer progn(context *, pointer);
extern pointer csend(context *, ...);
extern pointer getval(context *, pointer);
extern pointer setval(context *, pointer, pointer);
extern pointer getfunc(context *, pointer);
-extern struct bindframe *declare(context *, pointer, struct bindframe *);
-extern struct bindframe *vbind(context *, pointer, pointer,
- struct bindframe *, struct bindframe*);
-extern struct bindframe *fastbind(context *, pointer, pointer,
- struct bindframe *);
+extern pointer declare(context *, pointer, pointer /*bindframe*/);
+extern pointer vbind(context *, pointer, pointer,
+ pointer /*bindframe*/, pointer /*bindframe*/);
+extern pointer fastbind(context *, pointer, pointer,
+ pointer /*bindframe*/);
extern void bindspecial(context *, pointer, pointer);
extern void unbindspecial(context *, struct specialbindframe *);
-extern struct bindframe *bindkeyparams(context *, pointer, pointer *,
- int, struct bindframe *, struct bindframe *);
+extern pointer bindkeyparams(context *, pointer, pointer *,
+ int, pointer /*bindframe*/, pointer /*bindframe*/);
extern pointer Getstring();
extern pointer findpkg();
@@ -1050,7 +1072,7 @@ extern pointer makebuffer(int);
extern pointer makevector(pointer, int);
extern pointer makeclass(context *, pointer, pointer, pointer,pointer, pointer,
int, pointer);
-extern pointer makecode(pointer, pointer(*)(), pointer);
+extern pointer makecode(context *, pointer, pointer(*)(), pointer, pointer);
extern pointer makematrix(context *, int, int);
extern pointer makeobject(pointer);
extern pointer rawcons(context *, pointer, pointer);
@@ -1100,7 +1122,7 @@ extern pointer reader(context *, pointer, pointer);
extern pointer prinx(context *, pointer, pointer);
/*for compiled code*/
-extern pointer makeclosure(pointer,pointer,pointer(*)(),pointer, pointer*, pointer*);
+extern pointer makeclosure(pointer,pointer,pointer(*)(),pointer, pointer);
extern pointer fcall();
extern pointer xcar(pointer), xcdr(pointer), xcadr(pointer);
extern pointer *ovafptr(pointer,pointer);
@@ -1124,5 +1146,4 @@ extern sema_t free_thread_sem;
}
#endif
-extern eusinteger_t hide_ptr (pointer p);
diff --git a/lisp/c/eus.h.bsd b/lisp/c/eus.h.bsd
deleted file mode 100644
index 7ebe6cca1..000000000
--- a/lisp/c/eus.h.bsd
+++ /dev/null
@@ -1,785 +0,0 @@
-/****************************************************************/
-/* eus.h Etl, Umezono, Sakura-mura Lisp
-/*
-/* Copyright(c)1988, Toshihiro Matsui, Electrotechnical Laboratory,
-/* all rights reserved, all wrongs left.
-/* created on: 1986-May
-/* needed to be included by all euslisp kernel (.c) files and
-/* user functions compiled by euscomp.
-/****************************************************************/
-
-#if vxworks
-#include
-#include
-#define errno errnoGet()
-#define _setjmp(buf) setjmp(buf)
-#define _longjmp(buf,val) longjmp(buf,val)
-#else
-#include
-#define min(x,y) ((x
-#endif
-
-#include
-
-#define ERR (-1)
-#define STOPPER makepointer(0) /*impossible pointer object*/
-#define UNBOUND makepointer(0)
-
-/* dynamic value type */
-#define V_CONSTANT makeint(0)
-#define V_VARIABLE makeint(1)
-#define V_SPECIAL makeint(2)
-
-/* function types*/
-#define SUBR_FUNCTION makeint(0)
-#define SUBR_MACRO makeint(1)
-#define SUBR_SPECIAL makeint(2)
-#define SUBR_ENTRY makeint(3)
-
-/* stack frame types (lots more)*/
-#define BLOCKFRAME makeint(0)
-#define TAGBODYFRAME makeint(1)
-
-/*vector element types*/
-#define ELM_FIXED 0
-#define ELM_BIT 1
-#define ELM_CHAR 2
-#define ELM_BYTE 3
-#define ELM_INT 4
-#define ELM_FLOAT 5
-#define ELM_FOREIGN 6
-#define ELM_POINTER 7
-
-/****************************************************************/
-/* configuration constants */
-/****************************************************************/
-
-#define DEFAULTCHUNKINDEX 16 /*fib2(12)=754*/
-#define MAXBUDDY 30 /*fib(30) is big enough*/
-#define MAXSTACK 16384 /*can be expanded by sys:newstack*/
-#define SYMBOLHASH 60 /*initial obvector size in package*/
-#define MAXCLASS 256 /* by M.Inaba from 64 */
-#define KEYWORDPARAMETERLIMIT 32 /*determined by bits in a long word*/
-#define ARRAYRANKLIMIT 7 /*minimal requirement for CommonLisp*/
-#define MAXTHREAD 64 /*maximum number of threads*/
-
-/* type definitions:
- bix is buddy index,
- and cix is class index, which is sometimes refered as cid */
-
-typedef unsigned char byte;
-typedef unsigned short word; /*seldom used*/
-typedef struct cell *pointer;
-
-struct cellheader {
- unsigned mark:1; /* GC mark*/
- unsigned b:1; /* buddy: indicates the side in which its buddy should be found */
- unsigned m:1; /* memory: records b or m of parent cell when it's split*/
- unsigned smark:1; /* shared mark*/
- unsigned pmark:1; /* print mark*/
- unsigned elmtype:3;
- byte bix; /*5 bits are enough*/
- short cix;}; /*8 bits may be enough*/
-
-/****************************************************************/
-/* struct definition for lisp object cell
-/****************************************************************/
-struct cons {
- pointer car, /*cons is made of a car and a cdr*/
- cdr;}; /*what a familiar structure!*/
-
-struct propertied_object {
- pointer plist;};
-
-struct symbol {
- pointer plist, /*inherited from prop_obj*/
- speval,
- vtype, /*const,var,special*/
- spefunc,
- pname,
- homepkg;};
-
-struct string { /*resembles with vector*/
- pointer length; /*boxed*/
- byte chars[1];}; /*long word aligned*/
-
-struct package {
- pointer plist;
- pointer names; /*package name at car, nicknames in cdr*/
- pointer use; /*spreaded use-package list*/
- pointer symvector; /*hashed obvector*/
- pointer symcount; /*number of interned symbols in this package*/
- pointer intsymvector;
- pointer intsymcount;
- pointer shadows;
- pointer used_by;
- };
-
-struct code {
- pointer codevec;
- pointer quotevec;
- pointer subrtype; /*function,macro,special*/
- pointer entry; /*offset from beginning of codevector*/
- };
-
-struct fcode { /*foreign function code*/
- pointer codevec;
- pointer quotevec;
- pointer subrtype;
- pointer entry;
- pointer paramtypes;
- pointer resulttype;};
-
-struct ldmodule { /*foreign language object module*/
- pointer codevec;
- pointer quotevec;
- pointer subrtype; /*function,macro,special*/
- pointer entry;
- pointer symtab;
- pointer objname;
- pointer handle;}; /* dl's handle */
-
-struct closure {
- pointer codevec;
- pointer quotevec;
- pointer subrtype; /*function,macro,special*/
- pointer entry; /*offset from beginning of codevector*/
- pointer *env1; /*argument pointer: argv*/
- pointer *env2;}; /*local variable frame: local*/
-
-struct stream {
- pointer plist;
- pointer direction;
- pointer buffer;
- pointer count;
- pointer tail;};
-
-struct filestream {
- pointer plist;
- pointer direction;
- pointer buffer;
- pointer count;
- pointer tail;
- pointer fd;
- pointer fname;};
-
-struct iostream {
- pointer plist;
- pointer in,out;};
-
-struct labref { /*used for reading labeled forms: #n#,#n=*/
- pointer label;
- pointer value;
- pointer unsolved;
- pointer next; };
-
-struct vector {
- pointer size;
- pointer v[1];};
-
-struct intvector {
- pointer length;
- long iv[1];};
-
-struct floatvector {
- pointer length;
- float fv[1];};
-
-struct arrayheader {
- pointer plist;
- pointer entity,
- rank,
- fillpointer,
- offset,
- dim[ARRAYRANKLIMIT];};
-
-/* structs for object oriented programming */
-struct object {
- pointer iv[2];}; /*instance variables*/
-
-struct class {
- pointer plist;
- pointer name; /*class name symbol*/
- pointer super; /*super class*/
- pointer cix;
- pointer vars; /*var names including inherited ones*/
- pointer types;
- pointer forwards;
- pointer methods; /*method list*/
- };
-
-struct vecclass { /*vector class*/
- pointer plist;
- pointer name;
- pointer super;
- pointer cix;
- pointer vars;
- pointer types;
- pointer forwards;
- pointer methods;
- pointer elmtype;
- pointer size;};
-
-struct readtable {
- pointer plist;
- pointer syntax;
- pointer macro;
- pointer dispatch;};
-
-struct threadport {
- pointer plist;
- pointer id;
- pointer requester;
- pointer reqsem;
- pointer donesem;
- pointer func;
- pointer args;
- pointer result;
- pointer contex;
- pointer idle;};
-
-/****************************************************************/
-typedef
- struct cell {
-#if vax || sun4 || news || mips
- unsigned mark:1;
- unsigned b:1;
- unsigned m:1;
- unsigned smark:1;
- unsigned pmark:1;
- unsigned elmtype:3;
- byte bix;
-#endif
- short cix;
- union cellunion {
- struct cons cons;
- struct symbol sym;
- struct string str;
- struct package pkg;
- struct stream stream;
- struct filestream fstream;
- struct iostream iostream;
- struct code code;
- struct fcode fcode;
- struct ldmodule ldmod;
- struct closure clo;
- struct labref lab;
- struct arrayheader ary;
- struct vector vec;
- struct floatvector fvec;
- struct intvector ivec;
- struct object obj;
- struct class cls;
- struct vecclass vcls;
- struct readtable rdtab;
- struct threadport thrp;
- } c;
- } cell;
-
-typedef
- union numunion {
- float fval;
- int ival;
- struct { short low,high;} sval;
- struct { signed sival:30; unsigned tag:2;} tval;
- } numunion;
-
-/* buddy cell */
-struct bcell {
- struct cellheader h;
- union {
- struct bcell *nextbcell;
- struct cell *c[2];} b;} bcell;
-
-typedef struct bcell *bpointer;
-
-struct chunk {
- struct chunk *nextchunk;
- int chunkbix;
- struct bcell rootcell;};
-
-typedef struct {
- short cix;
- short sub;} cixpair;
-
-enum ch_type {
- ch_illegal,
- ch_white,
- ch_comment,
- ch_macro,
- ch_constituent,
- ch_sglescape,
- ch_multiescape,
- ch_termmacro,
- ch_nontermacro};
-
-enum ch_attr {
- alphabetic,package_marker,illegal,alphadigit};
-
-
-/****************************************************************/
-/* stack frames and context
-/****************************************************************/
-struct callframe {
- struct callframe *vlink;
- pointer form;
- };
-
-struct bindframe { /*to achieve lexical binding in the interpreter*/
- struct bindframe *dynblink, *lexblink; /*links to upper level*/
- pointer sym; /*symbol*/
- pointer val;}; /*bound value*/
-
-struct specialbindframe { /*special value binding frame*/
- struct specialbindframe *sblink;
- pointer sym; /*pointer to the symbol word(dynval or dynfunc)*/
- pointer oldval;};
-
-struct blockframe {
- pointer kind;
- struct blockframe *dynklink,*lexklink;
- pointer name;
- jmp_buf *jbp;};
-
-struct catchframe {
- struct catchframe *nextcatch;
- pointer label;
- struct bindframe *bf; /*bind frame save*/
- struct callframe *cf; /*call frame save*/
- struct fletframe *ff;
- jmp_buf *jbp;
- };
-
-struct protectframe {
- struct protectframe *protlink;
- pointer cleaner; /*cleanup form closure*/
- };
-
-struct fletframe {
- pointer name;
- pointer fclosure;
- struct fletframe *scope;
- struct fletframe *lexlink;
- struct fletframe *dynlink;};
-
-typedef struct {
- pointer *stack, *vsp,*stacklimit;
- struct callframe *callfp;
- struct catchframe *catchfp;
- struct bindframe *bindfp;
- struct specialbindframe *sbindfp;
- struct blockframe *blkfp;
- struct protectframe *protfp;
- struct fletframe *fletfp, *newfletfp;
- pointer lastalloc;}
- context;
-
-/****************************************************************
-/* memory and class management structures
-/****************************************************************/
-struct buddybase {
- int size;
- bpointer bp;} buddy[MAXBUDDY+1];
-
-struct class_desc { /* per- class descripter */
- short cix;
- short subcix;
- pointer def; };
-
-struct built_in_cid {
- pointer cls;
- cixpair *cp; };
-
-
-/****************************************************************/
-/* global variables for eus
-/* date: 1986-Apr
-/* 1987-Apr
-/****************************************************************/
-/* process id and program name*/
-extern int mypid;
-extern char *progname;
-
-/* heap management */
-/* every free cell is linked to the buddybase structure*/
-extern struct buddybase buddy[MAXBUDDY+1];
-extern struct chunk *chunklist;
-extern char *maxmemory;
-extern long freeheap, totalheap; /*size of heap left and allocated*/
-
-/* memory management timers for performance evaluation */
-extern long gccount,marktime,sweeptime;
-extern long alloccount[MAXBUDDY];
-
-/* System internal objects are connected to sysobj list
-/* to protect from garbage-collection */
-extern pointer sysobj;
-extern pointer lastalloc;
-
-/* thread contexts */
-context *contexts[MAXTHREAD];
-
-/****************************************************************/
-/* system defined (built-in) class index
-/* modified to accept dynamic type extension (1987-Jan)
-/****************************************************************/
-
-extern cixpair objectcp;
-extern cixpair conscp;
-extern cixpair propobjcp;
-extern cixpair symbolcp;
-extern cixpair packagecp;
-extern cixpair streamcp;
-extern cixpair filestreamcp;
-extern cixpair iostreamcp;
-extern cixpair metaclasscp;
-extern cixpair vecclasscp;
-extern cixpair codecp;
-extern cixpair fcodecp;
-/*cixpair modulecp; */
-extern cixpair ldmodulecp;
-extern cixpair closurecp;
-extern cixpair labrefcp;
-extern cixpair threadcp;
-extern cixpair arraycp;
-extern cixpair readtablecp;
-extern cixpair vectorcp;
-extern cixpair fltvectorcp;
-extern cixpair intvectorcp;
-extern cixpair stringcp;
-extern cixpair bitvectorcp;
-
-extern struct built_in_cid builtinclass[64];
-extern int nextbclass;
-
-
-/*symbol management*/
-extern pointer pkglist,lisppkg,keywordpkg,userpkg,syspkg,unixpkg,xpkg;
-extern pointer NIL,PACKAGE,T,QUOTE;
-extern pointer FUNCTION;
-extern pointer QDECLARE,QSPECIAL;
-extern pointer SELF,CLASS;
-extern pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT;
-extern pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER;
-extern pointer TOPLEVEL,QEVALHOOK,ERRHANDLER;
-extern pointer QUNBOUND,QDEBUG;
-extern pointer QTHREADS;
-
-/*memory management parameters*/
-extern pointer GCMERGE,GCMARGIN;
-
-/* keywords */
-extern pointer K_IN,K_OUT,K_IO; /*direction keyword*/
-extern pointer K_FLUSH,K_FILL,K_FILE,K_STRING;
-extern pointer K_NOMETHOD,K_BIT,K_BYTE,K_CHAR,K_SHORT,K_LONG,K_INTEGER;
-extern pointer K_FLOAT,K_DOUBLE,K_FOREIGN;
-extern pointer K_DOWNCASE,K_UPCASE;
-
-/*class management*/
-extern struct class_desc classtab[MAXCLASS];
-extern int nextcix;
-
-/*class cells*/
-extern pointer C_CONS, C_OBJECT, C_SYMBOL, C_PACKAGE;
-extern pointer C_STREAM, C_FILESTREAM, C_IOSTREAM, C_CODE, C_FCODE;
-extern pointer C_LDMOD;
-extern pointer C_VECTOR, C_METACLASS, C_CLOSURE, C_LABREF;
-extern pointer C_THREAD;
-extern pointer C_VCLASS, C_FLTVECTOR, C_INTVECTOR, C_STRING, C_BITVECTOR;
-extern pointer C_FOREIGNCODE,C_ARRAY,C_READTABLE;
-
-/*class names*/
-extern pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL,
- CODE, FCODE,LDMODULE, PKGCLASS,METACLASS,CLOSURE,LABREF;
-extern pointer THREAD;
-extern pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE;
-extern pointer FOREIGNCODE,ARRAY,BITVECTOR;
-
-/*toplevel & evaluation control*/
-extern int intsig,intcode;
-extern int ehbypass;
-
-/*reader variables*/
-extern pointer charmacro[256];
-extern pointer sharpmacro[256];
-extern int export_all;
-
-/****************************************************************/
-/* macro definition for euslisp
-/****************************************************************/
-
-#define carof(p,err) (islist(p)?(p)->c.cons.car:error(err))
-#define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:error(err))
-#define ccar(p) ((p)->c.cons.car)
-#define ccdr(p) ((p)->c.cons.cdr)
-#define cixof(p) ((p)->cix)
-#define classof(p) (classtab[(p)->cix].def)
-#define subcixof(p) (classtab[(p)->cix].subcix)
-#define spevalof(p) ((p)->c.sym.speval)
-#define superof(p) ((p)->c.cls.super)
-
-#if sun3 || apollo || system5 || sanyo || vxworks || NEXT
-#define makepointer(bp) ((pointer)((int)(bp) | 2))
-#define isint(p) (!((int)(p) & 3))
-#define isflt(p) (((int)(p) & 3)==1)
-#define isnum(p) (((int)(p) & 2)==0)
-#define ispointer(p) ((int)(p) & 2)
-#define makeint(v) ((pointer)(((int)v)<<2))
-#define bpointerof(p) ((bpointer)((int)(p)-2))
-#endif
-
-#if vax || sun4 || news || mips
-#define makepointer(bp) ((pointer)(bp))
-#define isint(p) (((int)(p) & 3)==2)
-#define isflt(p) (((int)(p) & 3)==1)
-#define isnum(p) (((int)(p) & 3))
-#define ispointer(p) (!((int)(p) & 3))
-#define makeint(v) ((pointer)((((int)v)<<2)+2))
-#define bpointerof(p) ((bpointer)(p))
-#endif
-
-#define intval(p) (((int)(p))>>2)
-#define ckintval(p) (isint(p)?intval(p):(int)error(E_NOINT))
-#define elmtypeof(p) (bpointerof(p)->h.elmtype)
-#define bixof(p) (bpointerof(p)->h.bix)
-
-#if sun3 || sun4 || system5 || apollo || news || sanyo || vxworks || mips || NEXT
-#define fltval(p) (nu.ival=(int)p & 0xfffffffc, nu.fval)
-/*#define makeflt(f) (nu.fval=(f), (pointer)((nu.ival & (~2)) | 1)) */
-#define makeflt(f) (nu.fval=(f),nu.tval.tag=1,(pointer)(nu.ival))
-#define ckfltval(p) (isflt(p)?fltval(p):(isint(p)?intval(p):(int)error(E_NONUMBER)))
-#endif
-
-/*predicates to test object type*/
-#define pislist(p) (p->cix<=conscp.sub)
-#define piscons(p) (p->cix<=conscp.sub)
-#define pispropobj(p) (propobjcp.cix<=(p)->cix && (p)->cix<=propobjcp.sub)
-#define ispropobj(p) (ispointer(p) && pispropobj(p))
-#define pissymbol(p) (symbolcp.cix<=(p)->cix && (p)->cix<=symbolcp.sub)
-#define issymbol(p) (ispointer(p) && pissymbol(p))
-#define pisstring(p) (stringcp.cix<=(p)->cix && (p)->cix<=stringcp.sub)
-#define isstring(p) (ispointer(p) && pisstring(p))
-#define islist(p) (ispointer(p) && pislist(p))
-#define iscons(p) (ispointer(p) && piscons(p))
-#define piscode(p) (codecp.cix<=(p)->cix && (p)->cix<=codecp.sub)
-#define iscode(p) (ispointer(p) && piscode(p))
-#define pisfcode(p) (fcodecp.cix<=(p)->cix && (p)->cix<=fcodecp.sub)
-#define isfcode(p) (ispointer(p) && pisfcode(p))
-#define pisldmod(p) (ldmodulecp.cix<=(p)->cix && (p)->cix<=ldmodulecp.sub)
-#define isldmod(p) (ispointer(p) && pisldmod(p))
-#define pisstream(p) (streamcp.cix<=(p)->cix && (p)->cix<=streamcp.sub)
-#define isstream(p) (ispointer(p) && pisstream(p))
-#define pisfilestream(p) (filestreamcp.cix<=(p)->cix && (p)->cix<=filestreamcp.sub)
-#define isfilestream(p) (ispointer(p) && pisfilestream(p))
-#define pisiostream(p) (iostreamcp.cix<=(p)->cix && (p)->cix<=iostreamcp.sub)
-#define isiostream(p) (ispointer(p) && pisiostream(p))
-#define pisreadtable(p) (readtablecp.cix<=((p)->cix) && ((p)->cix)<=readtablecp.sub)
-#define isreadtable(p) (ispointer(p) && pisreadtable(p))
-#define pisarray(p) (arraycp.cix<=((p)->cix) && ((p)->cix)<=arraycp.sub)
-#define isarray(p) (ispointer(p) && pisarray(p))
-#define pisvector(p) (elmtypeof(p))
-#define isvector(p) (ispointer(p) && pisvector(p))
-#define isfltvector(p) (ispointer(p) && (elmtypeof(p)==ELM_FLOAT))
-#define isptrvector(p) (ispointer(p) && (elmtypeof(p)==ELM_POINTER))
-#define isintvector(p) (ispointer(p) && (elmtypeof(p)==ELM_INT))
-#define pisclass(p) (metaclasscp.cix<=(p)->cix && (p)->cix<=metaclasscp.sub)
-#define isclass(p) (ispointer(p) && pisclass(p))
-#define pisvecclass(p) (vecclasscp.cix<=(p)->cix && (p)->cix<=vecclasscp.sub)
-#define isvecclass(p) (ispointer(p) && pisvecclass(p))
-#define pispackage(p) (packagecp.cix<=(p)->cix && (p)->cix<=packagecp.sub)
-#define ispackage(p) (ispointer(p) && pispackage(p))
-#define pisclosure(p) (closurecp.cix<=(p)->cix && (p)->cix<=closurecp.sub)
-#define isclosure(p) (ispointer(p) && pisclosure(p))
-#define pislabref(p) (labrefcp.cix<=(p)->cix && (p)->cix<=labrefcp.sub)
-#define islabref(p) (ispointer(p) && pislabref(p))
-
-#define strlength(p) (intval((p)->c.str.length))
-#define vecsize(p) (intval((p)->c.vec.size))
-#define objsize(p) (vecsize(classof(p)->c.cls.vars))
-
-#define vpush(v) (*ctx->vsp++=((pointer)v))
-#define ckpush(v) (ctx->vspstacklimit?vpush(v):error(E_STACKOVER))
-#define vpop() (*(--(ctx->vsp)))
-
-#define ckarg(req) if (n!=(req)) error(E_MISMATCHARG)
-#define ckarg2(req1,req2) if ((n<(req1))||((req2)vsp>ctx->stacklimit) error(E_STACKOVER)
-#define debug (spevalof(QDEBUG)!=NIL)
-
-/****************************************************************/
-/* error code definition
-/* 1986-Jun-17
-/****************************************************************/
-
-enum errorcode {
- E_NORMAL, /*0*/
- E_STACKOVER, /*stack overflow*/
- E_ALLOCATION,
- E_DUMMY3,
- E_DUMMY4,
- E_DUMMY5,
- E_DUMMY6,
- E_DUMMY7,
- E_DUMMY8,
- E_DUMMY9,
- E_DUMMY10,
- E_SETCONST, /*11 attempt to set to constant*/
- E_UNBOUND,
- E_UNDEF,
- E_MISMATCHARG,
- E_ILLFUNC,
- E_ILLCH,
- E_READ,
- E_WRITE,
- E_LONGSTRING, /*19: string too long*/
- E_NOSYMBOL, /*20: symbol expected*/
- E_NOLIST, /*list expected*/
- E_LAMBDA, /*illegal lambda form*/
- E_PARAMETER, /*illegal lambda parameter syntax*/
- E_NOCATCHER, /*no catch block */
- E_NOBLOCK, /*no block to return*/
- E_STREAM, /*stream expected*/
- E_IODIRECTION, /*io stream direction keyword*/
- E_NOINT, /*integer value expected*/
- E_NOSTRING, /*string expected*/
- E_OPENFILE, /*30: error in open*/
- E_EOF, /*EOF encountered*/
- E_NONUMBER, /*number expected*/
- E_CLASSOVER, /*class table overflow*/
- E_NOCLASS, /*class expected*/
- E_NOVECTOR, /*vector expected*/
- E_VECSIZE, /*error of vector size*/
- E_DUPOBJVAR, /*duplicated object variable name*/
- E_INSTANTIATE, /*38: cannot make an instance*/
- E_ARRAYINDEX,
- E_NOMETHOD, /*40*/
- E_CIRCULAR,
- E_SHARPMACRO, /*unknown sharp macro*/
- E_ALIST, /*list expected for an element of an alist*/
- E_NOMACRO, /*macro expected*/
- E_NOPACKAGE, /*no such package */
- E_PKGNAME, /*the package already exists*/
- E_NOOBJ, /*invalid form*/
- E_NOOBJVAR, /*48: not an object variable*/
- E_NOSEQ, /*sequence(list,string,vector) expected*/
- E_STARTEND, /*illegal subsequence index*/
- E_NOSUPER, /*no superclass*/
- E_FORMATSTRING, /*invalid format string character*/
- E_FLOATVECTOR, /*float vector expected*/
- E_CHARRANGE, /*0..255*/
- E_VECINDEX, /*vector index mismatch*/
- E_NOOBJECT, /*other than numbers expected*/
- E_TYPEMISMATCH, /*the: type mismatch*/
- E_DECLARE, /*illegal declaration*/
- E_DECLFORM, /*invalid declaration form*/
- E_NOVARIABLE, /*constant is used in let or lambda*/
- E_ROTAXIS, /*illegal rotation axis spec*/
- E_MULTIDECL,
- E_READLABEL, /*illegal #n= or #n# label*/
- E_READFVECTOR, /*error of #f( expression*/
- E_READOBJECT, /*error in #V or #J format*/
- E_SOCKET, /*error of socket address*/
- E_NOARRAY, /*array expected*/
- E_ARRAYDIMENSION, /*array dimension mismatch*/
- E_KEYPARAM, /*keyword parameter*/
- E_NOKEYPARAM, /*no such keyword*/
- E_NOINTVECTOR, /*integer vector expected*/
- E_SEQINDEX, /*sequence index out of range*/
- E_BITVECTOR, /*not a bit vector*/
- E_EXTSYMBOL, /*no such external symbol*/
- E_SYMBOLCONFLICT, /*symbol conflict in a package*/
- };
-
-/* function prototypes */
-
-/*system*/
-extern pointer error(),alloc(),halloc();
-
-/*eval*/
-extern pointer eval(context *, pointer);
-extern pointer eval2(context *, pointer, pointer);
-extern pointer ufuncall(context *, pointer, pointer, pointer,
- struct bindframe *, int);
-extern pointer progn(context *, pointer);
-extern pointer csend();
-extern pointer getval(context *, pointer);
-extern pointer setval(context *, pointer, pointer);
-extern pointer getfunc(context *, pointer);
-extern struct bindframe *declare(context *, pointer, struct bindframe *);
-extern struct bindframe *vbind(context *, pointer, pointer,
- struct bindframe *, struct bindframe*);
-extern struct bindframe *fastbind(context *, pointer, pointer,
- struct bindframe *);
-extern void bindspecial(context *, pointer, pointer);
-extern void unbindspecial(context *, struct specialbindframe *);
-extern struct bindframe *bindkeyparams(context *, pointer, pointer *,
- int, struct bindframe *, struct bindframe *);
-
-extern pointer Getstring();
-extern pointer findpkg();
-extern pointer memq();
-
-/*allocater*/
-extern pointer makebuffer(int);
-extern pointer makevector(pointer, int);
-extern pointer makeclass(context *, pointer, pointer, pointer,pointer, pointer,
- int, pointer);
-extern pointer makecode(pointer, pointer(*)(), pointer);
-extern pointer makematrix(context *, int, int);
-extern pointer makeobject(pointer);
-extern pointer rawcons(context *, pointer, pointer);
-extern pointer cons(context *, pointer, pointer);
-extern pointer makestring(char *, int);
-extern pointer makesymbol(context *, char *, int, pointer);
-extern pointer intern(context *, char *, int, pointer);
-extern pointer makepkg(context *, pointer, pointer, pointer);
-extern pointer mkstream(context *, pointer, pointer);
-extern pointer mkfilestream(context *, pointer,pointer,int,pointer);
-extern pointer mkiostream(context *, pointer,pointer);
-extern pointer makemodule(context *, int);
-extern pointer defun(context *, char *, pointer, pointer(*)());
-extern pointer defmacro(context *, char *, pointer, pointer(*)());
-extern pointer defspecial(context *, char *, pointer, pointer(*)());
-extern pointer defunpkg(context *, char *, pointer, pointer(*)(),pointer);
-extern void addcmethod(context *, pointer, pointer (*)(),
- pointer, pointer, pointer);
-extern pointer defkeyword(context *, char *);
-extern pointer defvar(context *, char *, pointer, pointer);
-extern pointer defconst(context *, char *, pointer, pointer);
-extern pointer stacknlist(context *, int);
-
-/*boxing,unboxing*/
-#if vax
-extern float fltval(),ckfltval();
-extern pointer makeflt();
-#endif
-
-/*io*/
-extern pointer reader(context *, pointer, pointer);
-extern pointer prinx(context *, pointer, pointer);
-
-/*for compiled code*/
-extern pointer makeclosure(pointer,pointer,int,pointer*, pointer*);
-extern pointer fcall();
-extern pointer minilist();
-extern pointer xcar(pointer), xcdr(pointer), xcadr(pointer);
-extern pointer *ovafptr(pointer,pointer);
-
-#if Solaris2
-/* mutex locks*/
-extern mutex_t mark_lock;
-extern char *mark_locking;
-extern int mark_lock_thread;
-extern mutex_t p_mark_lock;
-#endif
-
-
diff --git a/lisp/c/eus.old.h b/lisp/c/eus.old.h
deleted file mode 100644
index 74b5f55ea..000000000
--- a/lisp/c/eus.old.h
+++ /dev/null
@@ -1,795 +0,0 @@
-/****************************************************************/
-/* eus.h Etl, Umezono, Sakura-mura Lisp
-/*
-/* Copyright(c)1988, Toshihiro Matsui, Electrotechnical Laboratory,
-/* all rights reserved, all wrongs left.
-/* created on: 1986-May
-/* needed to be included by all euslisp kernel (.c) files and
-/* user functions compiled by euscomp.
-/****************************************************************/
-
-#if vxworks
-#include
-#include
-#define errno errnoGet()
-#define _setjmp(buf) setjmp(buf)
-#define _longjmp(buf,val) longjmp(buf,val)
-#else
-#include
-#define min(x,y) ((x
-#endif
-
-#include
-
-#define ERR (-1)
-#define STOPPER makepointer(0) /*impossible pointer object*/
-#define UNBOUND makepointer(0)
-
-/* dynamic value type */
-#define V_CONSTANT makeint(0)
-#define V_VARIABLE makeint(1)
-#define V_SPECIAL makeint(2)
-
-/* function types*/
-#define SUBR_FUNCTION makeint(0)
-#define SUBR_MACRO makeint(1)
-#define SUBR_SPECIAL makeint(2)
-#define SUBR_ENTRY makeint(3)
-
-/* stack frame types (lots more)*/
-#define BLOCKFRAME makeint(0)
-#define TAGBODYFRAME makeint(1)
-
-/*vector element types*/
-#define ELM_FIXED 0
-#define ELM_BIT 1
-#define ELM_CHAR 2
-#define ELM_BYTE 3
-#define ELM_INT 4
-#define ELM_FLOAT 5
-#define ELM_FOREIGN 6
-#define ELM_POINTER 7
-
-/****************************************************************/
-/* configuration constants */
-/****************************************************************/
-
-#define DEFAULTCHUNKINDEX 16 /*fib2(12)=754*/
-#define MAXBUDDY 30 /*fib(30) is big enough*/
-#define MAXSTACK 16384 /*can be expanded by sys:newstack*/
-#define SYMBOLHASH 60 /*initial obvector size in package*/
-#define MAXCLASS 256 /* by M.Inaba from 64 */
-#define KEYWORDPARAMETERLIMIT 32 /*determined by bits in a long word*/
-#define ARRAYRANKLIMIT 7 /*minimal requirement for CommonLisp*/
-#define MAXTHREAD 64 /*maximum number of threads*/
-
-/* type definitions:
- bix is buddy index,
- and cix is class index, which is sometimes refered as cid */
-
-typedef unsigned char byte;
-typedef unsigned short word; /*seldom used*/
-typedef struct cell *pointer;
-
-struct cellheader {
- unsigned mark:1; /* GC mark*/
- unsigned b:1; /* buddy: indicates the side in which its buddy should be found */
- unsigned m:1; /* memory: records b or m of parent cell when it's split*/
- unsigned smark:1; /* shared mark*/
- unsigned pmark:1; /* print mark*/
- unsigned elmtype:3;
- byte bix; /*5 bits are enough*/
- short cix;}; /*8 bits may be enough*/
-
-/****************************************************************/
-/* struct definition for lisp object cell
-/****************************************************************/
-struct cons {
- pointer car, /*cons is made of a car and a cdr*/
- cdr;}; /*what a familiar structure!*/
-
-struct propertied_object {
- pointer plist;};
-
-struct symbol {
- pointer plist, /*inherited from prop_obj*/
- speval,
- vtype, /*const,var,special*/
- spefunc,
- pname,
- homepkg;};
-
-struct string { /*resembles with vector*/
- pointer length; /*boxed*/
- byte chars[1];}; /*long word aligned*/
-
-struct package {
- pointer plist;
- pointer names; /*package name at car, nicknames in cdr*/
- pointer use; /*spreaded use-package list*/
- pointer symvector; /*hashed obvector*/
- pointer symcount; /*number of interned symbols in this package*/
- pointer intsymvector;
- pointer intsymcount;
- pointer shadows;
- pointer used_by;
- };
-
-struct code {
- pointer codevec;
- pointer quotevec;
- pointer subrtype; /*function,macro,special*/
- pointer entry; /*offset from beginning of codevector*/
- };
-
-struct fcode { /*foreign function code*/
- pointer codevec;
- pointer quotevec;
- pointer subrtype;
- pointer entry;
- pointer paramtypes;
- pointer resulttype;};
-
-struct ldmodule { /*foreign language object module*/
- pointer codevec;
- pointer quotevec;
- pointer subrtype; /*function,macro,special*/
- pointer entry;
- pointer symtab;
- pointer objname;
- pointer handle;}; /* dl's handle */
-
-struct closure {
- pointer codevec;
- pointer quotevec;
- pointer subrtype; /*function,macro,special*/
- pointer entry; /*offset from beginning of codevector*/
- pointer *env1; /*argument pointer: argv*/
- pointer *env2;}; /*local variable frame: local*/
-
-struct stream {
- pointer plist;
- pointer direction;
- pointer buffer;
- pointer count;
- pointer tail;};
-
-struct filestream {
- pointer plist;
- pointer direction;
- pointer buffer;
- pointer count;
- pointer tail;
- pointer fd;
- pointer fname;};
-
-struct iostream {
- pointer plist;
- pointer in,out;};
-
-struct labref { /*used for reading labeled forms: #n#,#n=*/
- pointer label;
- pointer value;
- pointer unsolved;
- pointer next; };
-
-struct vector {
- pointer size;
- pointer v[1];};
-
-struct intvector {
- pointer length;
- long iv[1];};
-
-struct floatvector {
- pointer length;
- float fv[1];};
-
-struct arrayheader {
- pointer plist;
- pointer entity,
- rank,
- fillpointer,
- offset,
- dim[ARRAYRANKLIMIT];};
-
-/* structs for object oriented programming */
-struct object {
- pointer iv[2];}; /*instance variables*/
-
-struct class {
- pointer plist;
- pointer name; /*class name symbol*/
- pointer super; /*super class*/
- pointer cix;
- pointer vars; /*var names including inherited ones*/
- pointer types;
- pointer forwards;
- pointer methods; /*method list*/
- };
-
-struct vecclass { /*vector class*/
- pointer plist;
- pointer name;
- pointer super;
- pointer cix;
- pointer vars;
- pointer types;
- pointer forwards;
- pointer methods;
- pointer elmtype;
- pointer size;};
-
-struct readtable {
- pointer plist;
- pointer syntax;
- pointer macro;
- pointer dispatch;};
-
-struct threadport {
- pointer plist;
- pointer id;
- pointer requester;
- pointer reqsem;
- pointer donesem;
- pointer func;
- pointer args;
- pointer result;
- pointer contex;
- pointer idle;
- pointer wait;};
-
-/****************************************************************/
-typedef
- struct cell {
-#if vax || sun4 || news || mips
- unsigned mark:1;
- unsigned b:1;
- unsigned m:1;
- unsigned smark:1;
- unsigned pmark:1;
- unsigned elmtype:3;
- byte bix;
-#endif
- short cix;
- union cellunion {
- struct cons cons;
- struct symbol sym;
- struct string str;
- struct package pkg;
- struct stream stream;
- struct filestream fstream;
- struct iostream iostream;
- struct code code;
- struct fcode fcode;
- struct ldmodule ldmod;
- struct closure clo;
- struct labref lab;
- struct arrayheader ary;
- struct vector vec;
- struct floatvector fvec;
- struct intvector ivec;
- struct object obj;
- struct class cls;
- struct vecclass vcls;
- struct readtable rdtab;
- struct threadport thrp;
- } c;
- } cell;
-
-typedef
- union numunion {
- float fval;
- int ival;
- struct {short low,high;} sval;
- } numunion;
-
-/* buddy cell */
-struct bcell {
- struct cellheader h;
- union {
- struct bcell *nextbcell;
- struct cell *c[2];} b;} bcell;
-
-typedef struct bcell *bpointer;
-
-struct chunk {
- struct chunk *nextchunk;
- int chunkbix;
- struct bcell rootcell;};
-
-typedef struct {
- short cix;
- short sub;} cixpair;
-
-enum ch_type {
- ch_illegal,
- ch_white,
- ch_comment,
- ch_macro,
- ch_constituent,
- ch_sglescape,
- ch_multiescape,
- ch_termmacro,
- ch_nontermacro};
-
-enum ch_attr {
- alphabetic,package_marker,illegal,alphadigit};
-
-
-/****************************************************************/
-/* stack frames and context
-/****************************************************************/
-struct callframe {
- struct callframe *vlink;
- pointer form;
- };
-
-struct bindframe { /*to achieve lexical binding in the interpreter*/
- struct bindframe *dynblink, *lexblink; /*links to upper level*/
- pointer sym; /*symbol*/
- pointer val;}; /*bound value*/
-
-struct specialbindframe { /*special value binding frame*/
- struct specialbindframe *sblink;
- pointer sym; /*pointer to the symbol word(dynval or dynfunc)*/
- pointer oldval;};
-
-struct blockframe {
- pointer kind;
- struct blockframe *dynklink,*lexklink;
- pointer name;
- jmp_buf *jbp;};
-
-struct catchframe {
- struct catchframe *nextcatch;
- pointer label;
- struct bindframe *bf; /*bind frame save*/
- struct callframe *cf; /*call frame save*/
- struct fletframe *ff;
- jmp_buf *jbp;
- };
-
-struct protectframe {
- struct protectframe *protlink;
- pointer cleaner; /*cleanup form closure*/
- };
-
-struct fletframe {
- pointer name;
- pointer fclosure;
- struct fletframe *scope;
- struct fletframe *lexlink;
- struct fletframe *dynlink;};
-
-#define MAXMETHCACHE 256 /*must be power to 2*/
-
-struct methdef {
- pointer selector,class,ownerclass,method;
- } methcache[MAXMETHCACHE];
-
-typedef struct {
- pointer *stack, *vsp,*stacklimit;
- struct callframe *callfp;
- struct catchframe *catchfp;
- struct bindframe *bindfp;
- struct specialbindframe *sbindfp;
- struct blockframe *blkfp;
- struct protectframe *protfp;
- struct fletframe *fletfp, *newfletfp;
- pointer lastalloc;
- pointer errhandler;
- struct methdef *methcache;
- }
- context;
-
-/****************************************************************
-/* memory and class management structures
-/****************************************************************/
-struct buddybase {
- int size;
- bpointer bp;} buddy[MAXBUDDY+1];
-
-struct class_desc { /* per- class descripter */
- short cix;
- short subcix;
- pointer def; };
-
-struct built_in_cid {
- pointer cls;
- cixpair *cp; };
-
-
-/****************************************************************/
-/* global variables for eus
-/* date: 1986-Apr
-/* 1987-Apr
-/****************************************************************/
-/* process id and program name*/
-extern int mypid;
-extern char *progname;
-
-/* heap management */
-/* every free cell is linked to the buddybase structure*/
-extern struct buddybase buddy[MAXBUDDY+1];
-extern struct chunk *chunklist;
-extern char *maxmemory;
-extern long freeheap, totalheap; /*size of heap left and allocated*/
-
-/* memory management timers for performance evaluation */
-extern long gccount,marktime,sweeptime;
-extern long alloccount[MAXBUDDY];
-
-/* System internal objects are connected to sysobj list
-/* to protect from garbage-collection */
-extern pointer sysobj;
-extern pointer lastalloc;
-
-/* thread euscontexts */
-context *euscontexts[MAXTHREAD];
-
-/****************************************************************/
-/* system defined (built-in) class index
-/* modified to accept dynamic type extension (1987-Jan)
-/****************************************************************/
-
-extern cixpair objectcp;
-extern cixpair conscp;
-extern cixpair propobjcp;
-extern cixpair symbolcp;
-extern cixpair packagecp;
-extern cixpair streamcp;
-extern cixpair filestreamcp;
-extern cixpair iostreamcp;
-extern cixpair metaclasscp;
-extern cixpair vecclasscp;
-extern cixpair codecp;
-extern cixpair fcodecp;
-/*cixpair modulecp; */
-extern cixpair ldmodulecp;
-extern cixpair closurecp;
-extern cixpair labrefcp;
-extern cixpair threadcp;
-extern cixpair arraycp;
-extern cixpair readtablecp;
-extern cixpair vectorcp;
-extern cixpair fltvectorcp;
-extern cixpair intvectorcp;
-extern cixpair stringcp;
-extern cixpair bitvectorcp;
-
-extern struct built_in_cid builtinclass[64];
-extern int nextbclass;
-
-
-/*symbol management*/
-extern pointer pkglist,lisppkg,keywordpkg,userpkg,syspkg,unixpkg,xpkg;
-extern pointer NIL,PACKAGE,T,QUOTE;
-extern pointer FUNCTION;
-extern pointer QDECLARE,QSPECIAL;
-extern pointer SELF,CLASS;
-extern pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT;
-extern pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER;
-extern pointer TOPLEVEL,QEVALHOOK,ERRHANDLER;
-extern pointer QUNBOUND,QDEBUG;
-extern pointer QTHREADS;
-
-/*memory management parameters*/
-extern pointer GCMERGE,GCMARGIN;
-
-/* keywords */
-extern pointer K_IN,K_OUT,K_IO; /*direction keyword*/
-extern pointer K_FLUSH,K_FILL,K_FILE,K_STRING;
-extern pointer K_NOMETHOD,K_BIT,K_BYTE,K_CHAR,K_SHORT,K_LONG,K_INTEGER;
-extern pointer K_FLOAT,K_DOUBLE,K_FOREIGN;
-extern pointer K_DOWNCASE,K_UPCASE;
-
-/*class management*/
-extern struct class_desc classtab[MAXCLASS];
-extern int nextcix;
-
-/*class cells*/
-extern pointer C_CONS, C_OBJECT, C_SYMBOL, C_PACKAGE;
-extern pointer C_STREAM, C_FILESTREAM, C_IOSTREAM, C_CODE, C_FCODE;
-extern pointer C_LDMOD;
-extern pointer C_VECTOR, C_METACLASS, C_CLOSURE, C_LABREF;
-extern pointer C_THREAD;
-extern pointer C_VCLASS, C_FLTVECTOR, C_INTVECTOR, C_STRING, C_BITVECTOR;
-extern pointer C_FOREIGNCODE,C_ARRAY,C_READTABLE;
-
-/*class names*/
-extern pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL,
- CODE, FCODE,LDMODULE, PKGCLASS,METACLASS,CLOSURE,LABREF;
-extern pointer THREAD;
-extern pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE;
-extern pointer FOREIGNCODE,ARRAY,BITVECTOR;
-
-/*toplevel & evaluation control*/
-extern int intsig,intcode;
-extern int ehbypass;
-
-/*reader variables*/
-extern pointer charmacro[256];
-extern pointer sharpmacro[256];
-extern int export_all;
-
-/****************************************************************/
-/* macro definition for euslisp
-/****************************************************************/
-
-#define carof(p,err) (islist(p)?(p)->c.cons.car:error(err))
-#define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:error(err))
-#define ccar(p) ((p)->c.cons.car)
-#define ccdr(p) ((p)->c.cons.cdr)
-#define cixof(p) ((p)->cix)
-#define classof(p) (classtab[(p)->cix].def)
-#define subcixof(p) (classtab[(p)->cix].subcix)
-#define spevalof(p) ((p)->c.sym.speval)
-#define superof(p) ((p)->c.cls.super)
-
-#if sun3 || apollo || system5 || sanyo || vxworks || NEXT
-#define makepointer(bp) ((pointer)((int)(bp) | 2))
-#define isint(p) (!((int)(p) & 3))
-#define isflt(p) (((int)(p) & 3)==1)
-#define isnum(p) (((int)(p) & 2)==0)
-#define ispointer(p) ((int)(p) & 2)
-#define makeint(v) ((pointer)(((int)v)<<2))
-#define bpointerof(p) ((bpointer)((int)(p)-2))
-#endif
-
-#if vax || sun4 || news || mips
-#define makepointer(bp) ((pointer)(bp))
-#define isint(p) (((int)(p) & 3)==2)
-#define isflt(p) (((int)(p) & 3)==1)
-#define isnum(p) (((int)(p) & 3))
-#define ispointer(p) (!((int)(p) & 3))
-#define makeint(v) ((pointer)((((int)v)<<2)+2))
-#define bpointerof(p) ((bpointer)(p))
-#endif
-
-#define intval(p) (((int)(p))>>2)
-#define ckintval(p) (isint(p)?intval(p):(int)error(E_NOINT))
-#define elmtypeof(p) (bpointerof(p)->h.elmtype)
-#define bixof(p) (bpointerof(p)->h.bix)
-
-#if sun3 || sun4 || system5 || apollo || news || sanyo || vxworks || mips || NEXT
-#define fltval(p) (nu.ival=(int)p & 0xfffffffc, nu.fval)
-#define makeflt(f) (nu.fval=(f), (pointer)((nu.ival & 0xfffffffc) | 1))
-#define ckfltval(p) (isflt(p)?fltval(p):(isint(p)?intval(p):(int)error(E_NONUMBER)))
-#endif
-
-/*predicates to test object type*/
-#define pislist(p) (p->cix<=conscp.sub)
-#define piscons(p) (p->cix<=conscp.sub)
-#define pispropobj(p) (propobjcp.cix<=(p)->cix && (p)->cix<=propobjcp.sub)
-#define ispropobj(p) (ispointer(p) && pispropobj(p))
-#define pissymbol(p) (symbolcp.cix<=(p)->cix && (p)->cix<=symbolcp.sub)
-#define issymbol(p) (ispointer(p) && pissymbol(p))
-#define pisstring(p) (stringcp.cix<=(p)->cix && (p)->cix<=stringcp.sub)
-#define isstring(p) (ispointer(p) && pisstring(p))
-#define islist(p) (ispointer(p) && pislist(p))
-#define iscons(p) (ispointer(p) && piscons(p))
-#define piscode(p) (codecp.cix<=(p)->cix && (p)->cix<=codecp.sub)
-#define iscode(p) (ispointer(p) && piscode(p))
-#define pisfcode(p) (fcodecp.cix<=(p)->cix && (p)->cix<=fcodecp.sub)
-#define isfcode(p) (ispointer(p) && pisfcode(p))
-#define pisldmod(p) (ldmodulecp.cix<=(p)->cix && (p)->cix<=ldmodulecp.sub)
-#define isldmod(p) (ispointer(p) && pisldmod(p))
-#define pisstream(p) (streamcp.cix<=(p)->cix && (p)->cix<=streamcp.sub)
-#define isstream(p) (ispointer(p) && pisstream(p))
-#define pisfilestream(p) (filestreamcp.cix<=(p)->cix && (p)->cix<=filestreamcp.sub)
-#define isfilestream(p) (ispointer(p) && pisfilestream(p))
-#define pisiostream(p) (iostreamcp.cix<=(p)->cix && (p)->cix<=iostreamcp.sub)
-#define isiostream(p) (ispointer(p) && pisiostream(p))
-#define pisreadtable(p) (readtablecp.cix<=((p)->cix) && ((p)->cix)<=readtablecp.sub)
-#define isreadtable(p) (ispointer(p) && pisreadtable(p))
-#define pisarray(p) (arraycp.cix<=((p)->cix) && ((p)->cix)<=arraycp.sub)
-#define isarray(p) (ispointer(p) && pisarray(p))
-#define pisvector(p) (elmtypeof(p))
-#define isvector(p) (ispointer(p) && pisvector(p))
-#define isfltvector(p) (ispointer(p) && (elmtypeof(p)==ELM_FLOAT))
-#define isptrvector(p) (ispointer(p) && (elmtypeof(p)==ELM_POINTER))
-#define isintvector(p) (ispointer(p) && (elmtypeof(p)==ELM_INT))
-#define pisclass(p) (metaclasscp.cix<=(p)->cix && (p)->cix<=metaclasscp.sub)
-#define isclass(p) (ispointer(p) && pisclass(p))
-#define pisvecclass(p) (vecclasscp.cix<=(p)->cix && (p)->cix<=vecclasscp.sub)
-#define isvecclass(p) (ispointer(p) && pisvecclass(p))
-#define pispackage(p) (packagecp.cix<=(p)->cix && (p)->cix<=packagecp.sub)
-#define ispackage(p) (ispointer(p) && pispackage(p))
-#define pisclosure(p) (closurecp.cix<=(p)->cix && (p)->cix<=closurecp.sub)
-#define isclosure(p) (ispointer(p) && pisclosure(p))
-#define pislabref(p) (labrefcp.cix<=(p)->cix && (p)->cix<=labrefcp.sub)
-#define islabref(p) (ispointer(p) && pislabref(p))
-
-#define strlength(p) (intval((p)->c.str.length))
-#define vecsize(p) (intval((p)->c.vec.size))
-#define objsize(p) (vecsize(classof(p)->c.cls.vars))
-
-#define vpush(v) (*ctx->vsp++=((pointer)v))
-#define ckpush(v) (ctx->vspstacklimit?vpush(v):error(E_STACKOVER))
-#define vpop() (*(--(ctx->vsp)))
-
-#define ckarg(req) if (n!=(req)) error(E_MISMATCHARG)
-#define ckarg2(req1,req2) if ((n<(req1))||((req2)vsp>ctx->stacklimit) error(E_STACKOVER)
-#define debug (spevalof(QDEBUG)!=NIL)
-
-/****************************************************************/
-/* error code definition
-/* 1986-Jun-17
-/****************************************************************/
-
-enum errorcode {
- E_NORMAL, /*0*/
- E_STACKOVER, /*stack overflow*/
- E_ALLOCATION,
- E_DUMMY3,
- E_DUMMY4,
- E_DUMMY5,
- E_DUMMY6,
- E_DUMMY7,
- E_DUMMY8,
- E_DUMMY9,
- E_DUMMY10,
- E_SETCONST, /*11 attempt to set to constant*/
- E_UNBOUND,
- E_UNDEF,
- E_MISMATCHARG,
- E_ILLFUNC,
- E_ILLCH,
- E_READ,
- E_WRITE,
- E_LONGSTRING, /*19: string too long*/
- E_NOSYMBOL, /*20: symbol expected*/
- E_NOLIST, /*list expected*/
- E_LAMBDA, /*illegal lambda form*/
- E_PARAMETER, /*illegal lambda parameter syntax*/
- E_NOCATCHER, /*no catch block */
- E_NOBLOCK, /*no block to return*/
- E_STREAM, /*stream expected*/
- E_IODIRECTION, /*io stream direction keyword*/
- E_NOINT, /*integer value expected*/
- E_NOSTRING, /*string expected*/
- E_OPENFILE, /*30: error in open*/
- E_EOF, /*EOF encountered*/
- E_NONUMBER, /*number expected*/
- E_CLASSOVER, /*class table overflow*/
- E_NOCLASS, /*class expected*/
- E_NOVECTOR, /*vector expected*/
- E_VECSIZE, /*error of vector size*/
- E_DUPOBJVAR, /*duplicated object variable name*/
- E_INSTANTIATE, /*38: cannot make an instance*/
- E_ARRAYINDEX,
- E_NOMETHOD, /*40*/
- E_CIRCULAR,
- E_SHARPMACRO, /*unknown sharp macro*/
- E_ALIST, /*list expected for an element of an alist*/
- E_NOMACRO, /*macro expected*/
- E_NOPACKAGE, /*no such package */
- E_PKGNAME, /*the package already exists*/
- E_NOOBJ, /*invalid form*/
- E_NOOBJVAR, /*48: not an object variable*/
- E_NOSEQ, /*sequence(list,string,vector) expected*/
- E_STARTEND, /*illegal subsequence index*/
- E_NOSUPER, /*no superclass*/
- E_FORMATSTRING, /*invalid format string character*/
- E_FLOATVECTOR, /*float vector expected*/
- E_CHARRANGE, /*0..255*/
- E_VECINDEX, /*vector index mismatch*/
- E_NOOBJECT, /*other than numbers expected*/
- E_TYPEMISMATCH, /*the: type mismatch*/
- E_DECLARE, /*illegal declaration*/
- E_DECLFORM, /*invalid declaration form*/
- E_NOVARIABLE, /*constant is used in let or lambda*/
- E_ROTAXIS, /*illegal rotation axis spec*/
- E_MULTIDECL,
- E_READLABEL, /*illegal #n= or #n# label*/
- E_READFVECTOR, /*error of #f( expression*/
- E_READOBJECT, /*error in #V or #J format*/
- E_SOCKET, /*error of socket address*/
- E_NOARRAY, /*array expected*/
- E_ARRAYDIMENSION, /*array dimension mismatch*/
- E_KEYPARAM, /*keyword parameter*/
- E_NOKEYPARAM, /*no such keyword*/
- E_NOINTVECTOR, /*integer vector expected*/
- E_SEQINDEX, /*sequence index out of range*/
- E_BITVECTOR, /*not a bit vector*/
- E_EXTSYMBOL, /*no such external symbol*/
- E_SYMBOLCONFLICT, /*symbol conflict in a package*/
- };
-
-/* function prototypes */
-
-/*system*/
-extern pointer error(),alloc(),halloc();
-
-/*eval*/
-extern pointer eval(context *, pointer);
-extern pointer eval2(context *, pointer, pointer);
-extern pointer ufuncall(context *, pointer, pointer, pointer,
- struct bindframe *, int);
-extern pointer progn(context *, pointer);
-extern pointer csend();
-extern pointer getval(context *, pointer);
-extern pointer setval(context *, pointer, pointer);
-extern pointer getfunc(context *, pointer);
-extern struct bindframe *declare(context *, pointer, struct bindframe *);
-extern struct bindframe *vbind(context *, pointer, pointer,
- struct bindframe *, struct bindframe*);
-extern struct bindframe *fastbind(context *, pointer, pointer,
- struct bindframe *);
-extern void bindspecial(context *, pointer, pointer);
-extern void unbindspecial(context *, struct specialbindframe *);
-extern struct bindframe *bindkeyparams(context *, pointer, pointer *,
- int, struct bindframe *, struct bindframe *);
-
-extern pointer Getstring();
-extern pointer findpkg();
-extern pointer memq();
-
-/*allocater*/
-extern pointer makebuffer(int);
-extern pointer makevector(pointer, int);
-extern pointer makeclass(context *, pointer, pointer, pointer,pointer, pointer,
- int, pointer);
-extern pointer makecode(pointer, pointer(*)(), pointer);
-extern pointer makematrix(context *, int, int);
-extern pointer makeobject(pointer);
-extern pointer rawcons(context *, pointer, pointer);
-extern pointer cons(context *, pointer, pointer);
-extern pointer makestring(char *, int);
-extern pointer makesymbol(context *, char *, int, pointer);
-extern pointer intern(context *, char *, int, pointer);
-extern pointer makepkg(context *, pointer, pointer, pointer);
-extern pointer mkstream(context *, pointer, pointer);
-extern pointer mkfilestream(context *, pointer,pointer,int,pointer);
-extern pointer mkiostream(context *, pointer,pointer);
-extern pointer makemodule(context *, int);
-extern pointer defun(context *, char *, pointer, pointer(*)());
-extern pointer defmacro(context *, char *, pointer, pointer(*)());
-extern pointer defspecial(context *, char *, pointer, pointer(*)());
-extern pointer defunpkg(context *, char *, pointer, pointer(*)(),pointer);
-extern void addcmethod(context *, pointer, pointer (*)(),
- pointer, pointer, pointer);
-extern pointer defkeyword(context *, char *);
-extern pointer defvar(context *, char *, pointer, pointer);
-extern pointer defconst(context *, char *, pointer, pointer);
-extern pointer stacknlist(context *, int);
-#if Solaris2
-extern makethreadport(context *);
-#endif
-
-/*boxing,unboxing*/
-#if vax
-extern float fltval(),ckfltval();
-extern pointer makeflt();
-#endif
-
-/*io*/
-extern pointer reader(context *, pointer, pointer);
-extern pointer prinx(context *, pointer, pointer);
-
-/*for compiled code*/
-extern pointer makeclosure(pointer,pointer,int,pointer*, pointer*);
-extern pointer fcall();
-extern pointer minilist();
-extern pointer xcar(pointer), xcdr(pointer), xcadr(pointer);
-extern pointer *ovafptr(pointer,pointer);
-
-/* mutex locks*/
-
-extern mutex_t mark_lock;
-extern char *mark_locking;
-extern int mark_lock_thread;
-extern mutex_t p_mark_lock;
-
-
diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h
index 5de3c9afe..55b975ff7 100644
--- a/lisp/c/eus_proto.h
+++ b/lisp/c/eus_proto.h
@@ -3,6 +3,7 @@ extern "C" {
#endif
/* arith.c */
extern pointer NUMEQUAL(context */*ctx*/, int /*n*/, pointer /*argv*/*);
+extern pointer NUMNEQUAL(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer GREATERP(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer LESSP(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer GREQP(context */*ctx*/, int /*n*/, pointer /*argv*/*);
@@ -116,6 +117,7 @@ extern pointer STR_GT(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer STR_GE(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern void charstring(context */*ctx*/, pointer /*mod*/);
/* compsub.c */
+extern void checkcompversion(const char* /*compver*/);
extern int maerror(void);
extern pointer loadglobal(pointer /*s*/);
extern pointer storeglobal(pointer /*s*/, pointer /*v*/);
@@ -171,21 +173,21 @@ extern pointer *getobjv(pointer /*sym*/, pointer /*varvec*/, pointer /*obj*/);
extern pointer getval(context */*ctx*/, pointer /*sym*/);
extern pointer setval(context */*ctx*/, pointer /*sym*/, pointer /*val*/);
extern pointer getfunc(context */*ctx*/, pointer /*f*/);
-extern pointer get_sym_func(pointer /*s*/);
-extern void setfunc(pointer /*sym*/, pointer /*func*/);
+extern pointer getfunc_closure(context */*ctx*/, pointer /*f*/);
+extern pointer getfunc_closure_noexcept(context */*ctx*/, pointer /*f*/);
extern pointer *ovafptr(pointer /*o*/, pointer /*v*/);
extern void bindspecial(context */*ctx*/, pointer /*sym*/, pointer /*newval*/);
extern void unbindx(context */*ctx*/, int /*count*/);
extern void unbindspecial(context */*ctx*/, struct specialbindframe */*limit*/);
-extern struct bindframe *fastbind(context */*ctx*/, pointer /*var*/, pointer /*val*/, struct bindframe */*lex*/);
-extern struct bindframe *vbind(context */*ctx*/, pointer /*var*/, pointer /*val*/, struct bindframe */*lex*/, struct bindframe */*declscope*/);
-extern struct bindframe *declare(context */*ctx*/, pointer /*decllist*/, struct bindframe */*env*/);
+extern pointer fastbind(context */*ctx*/, pointer /*var*/, pointer /*val*/, pointer /*lex*/);
+extern pointer vbind(context */*ctx*/, pointer /*var*/, pointer /*val*/, pointer /*lex*/, pointer /*declscope*/);
+extern pointer declare(context */*ctx*/, pointer /*decllist*/, pointer /*env*/);
extern int parsekeyparams(pointer /*keyvec*/, pointer */*actuals*/, int /*noarg*/, pointer */*results*/, int /*allowotherkeys*/);
-extern struct bindframe *bindkeyparams(context */*ctx*/, pointer /*formal*/, pointer */*argp*/, int /*noarg*/, struct bindframe */*env*/, struct bindframe */*bf*/);
-extern pointer funlambda(context */*ctx*/, pointer /*fn*/, pointer /*formal*/, pointer /*body*/, pointer */*argp*/, struct bindframe */*env*/, int /*noarg*/);
+extern pointer bindkeyparams(context */*ctx*/, pointer /*formal*/, pointer */*argp*/, int /*noarg*/, pointer /*env*/, pointer /*bf*/);
+extern pointer funlambda(context */*ctx*/, pointer /*fn*/, pointer /*formal*/, pointer /*body*/, pointer */*argp*/, pointer /*env*/, int /*noarg*/);
extern pointer call_foreign(eusinteger_t (*/*ifunc*/)(), pointer /*code*/, int /*n*/, pointer /*args*/*);
extern pointer funcode(context */*ctx*/, pointer /*func*/, pointer /*args*/, int /*noarg*/);
-extern pointer ufuncall(context */*ctx*/, pointer /*form*/, pointer /*fn*/, pointer /*args*/, struct bindframe */*env*/, int /*noarg*/);
+extern pointer ufuncall(context */*ctx*/, pointer /*form*/, pointer /*fn*/, pointer /*args*/, pointer /*env*/, int /*noarg*/);
extern pointer eval(context */*ctx*/, pointer /*form*/);
extern pointer eval2(context */*ctx*/, pointer /*form*/, pointer /*env*/);
extern pointer progn(context */*ctx*/, pointer /*forms*/);
@@ -257,7 +259,6 @@ extern pointer GETDISPMACRO(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer RESETREADTABLE(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern pointer XFORMAT(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer SIGERROR(context */*ctx*/, int /*n*/, pointer */*argv*/);
-extern pointer INSTALL_ERRHANDLER(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern void lispio(context */*ctx*/, pointer /*mod*/);
/* lists.c */
extern pointer CAR(context */*ctx*/, int /*n*/, pointer */*argv*/);
@@ -285,11 +286,9 @@ extern pointer NSUBST(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer memq(pointer /*item*/, pointer /*list*/);
extern pointer MEMQ(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer MEMBER(context */*ctx*/, int /*n*/, pointer /*argv*/*);
-extern pointer SUPERMEMBER(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer assq(pointer /*item*/, pointer /*alist*/);
extern pointer ASSQ(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer ASSOC(context */*ctx*/, int /*n*/, pointer /*argv*/*);
-extern pointer SUPERASSOC(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer BUTLAST(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer NBUTLAST(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern void lists(context */*ctx*/, pointer /*mod*/);
@@ -326,7 +325,7 @@ extern pointer makepkg(context */*ctx*/, pointer /*namestr*/, pointer /*nicks*/,
extern pointer mkstream(context */*ctx*/, pointer /*dir*/, pointer /*string*/);
extern pointer mkfilestream(context */*ctx*/, pointer /*dir*/, pointer /*string*/, int /*fno*/, pointer /*fname*/);
extern pointer mkiostream(context */*ctx*/, pointer /*in*/, pointer /*out*/);
-extern pointer makecode(pointer /*mod*/, pointer (*/*f*/)(), pointer /*ftype*/);
+ extern pointer makecode(context */*ctx*/,pointer /*mod*/, pointer (*/*f*/)(), pointer /*ftype*/, pointer /*name*/);
extern void bumpcix(int /*m*/, int /*n*/);
extern void recixobj(int /*newcix*/);
extern void resetcix(pointer /*class*/, cixpair */*p*/);
@@ -338,9 +337,10 @@ extern pointer makefvector(int /*s*/);
extern pointer defvector(context */*ctx*/, char */*name*/, pointer /*super*/, int /*elm*/, int /*size*/);
extern pointer makematrix(context */*ctx*/, int /*row*/, int /*column*/);
extern pointer makemodule(context */*ctx*/, int /*size*/);
-extern pointer makeclosure(pointer /*code*/, pointer /*quote*/, pointer (*/*f*/)(), pointer /*e0*/, pointer */*e1*/, pointer */*e2*/);
+extern pointer makeclosure(pointer /*code*/, pointer /*quote*/, pointer (*/*f*/)(), pointer /*e0*/, pointer /*e1*/);
extern pointer makereadtable(context */*ctx*/);
-extern pointer makelabref(pointer /*n*/, pointer /*v*/, pointer /*nxt*/);
+extern pointer makelabref(context */*ctx*/, pointer /*n*/, pointer /*v*/, pointer /*nxt*/);
+extern pointer makebindframe(context */*ctx*/, pointer /*sym*/, pointer /*val*/, pointer /*nxt*/);
extern pointer makeratio(int /*num*/, int /*denom*/);
extern pointer makebig(int /*n*/);
extern pointer makebig1(long /*x*/);
@@ -357,7 +357,8 @@ extern pointer defkeyword(context */*ctx*/, char */*name*/);
extern pointer compfun(context */*ctx*/, pointer /*sym*/, pointer /*mod*/, pointer (*/*entry*/)(), pointer /*doc*/);
extern pointer compmacro(context */*ctx*/, pointer /*sym*/, pointer /*mod*/, pointer (*/*entry*/)(), pointer /*doc*/);
extern struct blockframe *makeblock(context */*ctx*/, pointer /*kind*/, pointer /*name*/, jmp_buf */*jbuf*/, struct blockframe */*link*/);
-extern struct fletframe *makeflet(context */*ctx*/, pointer /*nm*/, pointer /*def*/, struct fletframe */*scp*/, struct fletframe */*link*/);
+extern pointer makeflet(context */*ctx*/, pointer /*nm*/, pointer /*def*/, pointer /*scp*/, pointer /*nxt*/);
+extern pointer makemacrolet(context */*ctx*/, pointer /*nm*/, pointer /*def*/, pointer /*nxt*/);
extern void mkcatchframe(context */*ctx*/, pointer /*lab*/, jmp_buf */*jbuf*/);extern void allocate_stack(context */*ctx*/, int /*n*/);
extern context *makelispcontext(int /*bs_size*/);
extern void deletecontext(int /*id*/, context */*ctx*/);
@@ -560,6 +561,7 @@ extern pointer SEQLET(context */*ctx*/, pointer /*args*/);
extern pointer CATCH(context */*ctx*/, pointer /*arg*/);
extern void throw(context */*ctx*/, pointer /*tag*/, pointer /*result*/);
extern pointer THROW(context */*ctx*/, pointer /*arg*/);
+extern pointer MACROLET(context */*ctx*/, pointer /*arg*/);
extern pointer FLET(context */*ctx*/, pointer /*arg*/);
extern pointer LABELS(context */*ctx*/, pointer /*arg*/);
extern pointer RESET(context */*ctx*/, int /*n*/, pointer */*argv*/);
@@ -586,6 +588,7 @@ extern pointer SYMBNDVALUE(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer SETFUNC(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern pointer SYMFUNC(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern pointer MAKUNBOUND(context */*ctx*/, int /*n*/, pointer */*argv*/);
+extern pointer FMAKUNBOUND(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern void set_special(context */*ctx*/, pointer /*var*/, pointer /*val*/);
extern pointer SETSPECIAL(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern pointer DEFUN(context */*ctx*/, pointer /*arg*/);
@@ -594,6 +597,7 @@ extern pointer FINDSYMBOL(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer INTERN(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer gensym(context */*ctx*/);
extern pointer GENSYM(context */*ctx*/, int /*n*/, pointer /*argv*/*);
+extern pointer getprop(context */*ctx*/, pointer /*sym*/, pointer /*attr*/, pointer /*retval*/);
extern pointer GETPROP(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer EXPORT(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer putprop(context */*ctx*/, pointer /*sym*/, pointer /*val*/, pointer /*attr*/);
@@ -624,8 +628,11 @@ extern pointer LISTALLREFERENCES(context */*ctx*/, int /*n*/, pointer /*argv*/*)
extern pointer ADDRESS(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer PEEK(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer POKE(context */*ctx*/, int /*n*/, pointer /*argv*/*);
+extern pointer list_callstack(context */*ctx*/, int /*max*/);
+extern pointer LISTCALLSTACK(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern pointer LISTALLCATCHERS(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern pointer LISTBINDINGS(context */*ctx*/, int /*n*/, pointer */*argv*/);
+extern pointer LISTFUNCTIONBINDINGS(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern pointer LISTSPECIALBINDINGS(context */*ctx*/, int /*n*/, pointer */*argv*/);
extern pointer LISTALLCLASSES(context */*ctx*/, int /*n*/, pointer /*argv*/*);
extern pointer EXPORTALL(context */*ctx*/, int /*n*/, pointer /*argv*/*);
diff --git a/lisp/c/eval.c b/lisp/c/eval.c
index 400625124..1691dee15 100644
--- a/lisp/c/eval.c
+++ b/lisp/c/eval.c
@@ -33,8 +33,8 @@ pointer varvec,obj;
pointer getval(ctx,sym)
register context *ctx;
register pointer sym;
-{ register struct bindframe *bf=ctx->bindfp;
- register pointer var,val;
+{ register pointer var,val;
+ pointer bf=ctx->bindfp;
pointer *vaddr;
int vt;
if (sym->c.sym.vtype>=V_SPECIAL) {
@@ -48,16 +48,17 @@ register pointer sym;
if (sym->c.sym.vtype==V_CONSTANT) return(sym->c.sym.speval);
GC_POINT;
while (bf!=NULL) {
- var=bf->sym;
- val=bf->val;
+ var=bf->c.bfp.sym;
+ val=bf->c.bfp.val;
if (sym==var) { /*found in bind-frame*/
if (val==UNBOUND) goto getspecial;
return(val);}
else if (var->cix==vectorcp.cix) {
vaddr=getobjv(sym,var,val);
if (vaddr) return(*vaddr);}
- if (bf==bf->lexblink) break;
- bf=bf->lexblink;}
+ if (bf==bf->c.bfp.next) break;
+ bf=bf->c.bfp.next;
+ }
/*get special value from the symbol cell*/
/*if (sym->c.sym.vtype==V_GLOBAL) goto getspecial;*/
getspecial:
@@ -68,8 +69,8 @@ register pointer sym;
pointer setval(ctx,sym,val)
register context *ctx;
register pointer sym,val;
-{ register struct bindframe *bf=ctx->bindfp;
- register pointer var;
+{ register pointer var;
+ pointer bf=ctx->bindfp;
pointer *vaddr;
int vt;
if (sym->c.sym.vtype>=V_SPECIAL) {
@@ -77,14 +78,16 @@ register pointer sym,val;
pointer_update(ctx->specials->c.vec.v[vt],val);
return(val);}
while (bf!=NULL) {
- var=bf->sym;
+ var=bf->c.bfp.sym;
if (sym==var) {
- if (bf->val==UNBOUND) goto setspecial;
- pointer_update(bf->val,val); return(val);}
+ if (bf->c.bfp.val==UNBOUND) goto setspecial;
+ pointer_update(bf->c.bfp.val,val); return(val);}
else if (var->cix==vectorcp.cix) {
- vaddr=getobjv(sym,var,bf->val);
+ vaddr=getobjv(sym,var,bf->c.bfp.val);
if (vaddr) {pointer_update(*vaddr,val); return(val);}}
- bf=bf->lexblink; GC_POINT;}
+ if (bf==bf->c.bfp.next) break;
+ bf=bf->c.bfp.next;
+ GC_POINT;}
/* no local var found. try global binding */
if (sym->c.sym.vtype==V_CONSTANT) error(E_SETCONST,sym);
if (sym->c.sym.vtype==V_GLOBAL) goto setspecial;
@@ -94,16 +97,60 @@ register pointer sym,val;
}
+pointer getfunc_noexcept(ctx,f)
+register context *ctx;
+register pointer f; /*must be a symbol*/
+{ pointer ffp=ctx->fletfp;
+ while (ffp!=NULL && isfletframe(ffp)) {
+ if (ffp->c.ffp.name==f) { return(ffp->c.ffp.fclosure);}
+ else ffp=ffp->c.ffp.next;}
+ return(f->c.sym.spefunc);}
+
+pointer getfunc_closure_noexcept(ctx,f)
+register context *ctx;
+register pointer f;
+{ pointer funcname;
+ if (issymbol(f)) { funcname=f; f=getfunc_noexcept(ctx,f);}
+ else funcname=NIL;
+ if (f==UNBOUND) return(f);
+ if (iscode(f)) return(f);
+ else if (ccar(f)==LAMCLOSURE) return(f);
+ else if (ccar(f)==LAMBDA) {
+ vpush(funcname);
+ // flet-frame
+ if (ctx->fletfp==NULL)
+ // don't pass *unbound* to the REPL
+ f=cons(ctx,makeint(0),ccdr(f));
+ else
+ f=cons(ctx,ctx->fletfp,ccdr(f));
+ // bind-frame
+ if (ctx->bindfp==NULL)
+ // don't pass *unbound* to the REPL
+ f=cons(ctx,makeint(0),f);
+ else
+ f=cons(ctx,ctx->bindfp,f);
+ f=cons(ctx,vpop(),f); // funcname
+ return(cons(ctx,LAMCLOSURE,f));}
+ else return(NIL);}
+
+// getfunc returns a function callable (lambda or compiled code)
+// without considering the local binding environment
pointer getfunc(ctx,f)
register context *ctx;
register pointer f; /*must be a symbol*/
-{ register struct fletframe *ffp=ctx->fletfp;
- while (ffp!=NULL) {
- if (ffp->name==f) { return(ffp->fclosure);}
- else ffp=ffp->lexlink;}
- if (f->c.sym.spefunc==UNBOUND) error(E_UNDEF,f);
- else { /*global function definition is taken, context changes*/
- return(f->c.sym.spefunc);}}
+{ pointer fn=getfunc_noexcept(ctx,f);
+ if (fn==UNBOUND) error(E_UNDEF, f);
+ return(fn);}
+
+// getfunc_closure returns a function callable (lambda-closure or compiled code)
+// considering the local binding environment
+pointer getfunc_closure(ctx,f)
+register context *ctx;
+register pointer f;
+{ pointer fn=getfunc_closure_noexcept(ctx,f);
+ if (fn==UNBOUND) error(E_UNDEF, f);
+ if (fn==NIL) error(E_NOFUNCTION);
+ return(fn);}
/* called from compiled code*/
pointer get_sym_func(s)
@@ -112,19 +159,14 @@ pointer s;
if ((f=s->c.sym.spefunc)==UNBOUND) error(E_UNDEF,s);
else return(f);}
-
-void setfunc(sym,func)
-register pointer sym,func;
-{ pointer_update(sym->c.sym.spefunc,func);}
-
pointer *ovafptr(o,v)
register pointer o,v;
{ register pointer c,*vaddr;
- if (!ispointer(o)) error(E_NOOBJ,o,v);
+ if (!ispointer(o)) error(E_NOOBJECT);
c=classof(o);
vaddr=getobjv(v,c->c.cls.vars,o);
if (vaddr) return(vaddr);
- else error(E_NOOBJVAR,o,v);}
+ else error(E_NOSLOT,v);}
/***** special variable binding *****/
@@ -152,7 +194,9 @@ register context *ctx;
register int count;
{ register pointer s;
register struct specialbindframe *sbfp=ctx->sbindfp;
- if (ctx->special_bind_countspecial_bind_countspecial_bind_count -= count;
while (count-- >0) {
s=sbfp->sym;
@@ -177,34 +221,30 @@ register struct specialbindframe *limit;
ctx->special_bind_count--;}
ctx->sbindfp=sbfp;}}
-struct bindframe *fastbind(ctx,var,val,lex)
+pointer fastbind(ctx,var,val,lex)
register context *ctx;
register pointer var,val;
-struct bindframe *lex;
-{ register struct bindframe *bf;
- bf=(struct bindframe *)(ctx->vsp);
- ctx->vsp += sizeof(struct bindframe)/sizeof(eusinteger_t);
- bf->lexblink=lex;
- bf->dynblink=ctx->bindfp;
- bf->sym=var;
- bf->val=val;
+pointer lex;
+{ pointer bf;
+ bf = makebindframe(ctx,var,val,ctx->bindfp);
+ vpush(bf);
ctx->bindfp=bf; /*update bindfp*/
return(bf); }
-struct bindframe *vbind(ctx,var,val,lex,declscope)
+pointer vbind(ctx,var,val,lex,declscope)
register context *ctx;
register pointer var,val;
-struct bindframe *lex,*declscope;
-{ register struct bindframe *p;
+pointer lex,declscope;
+{ pointer p;
if (!issymbol(var)) error(E_NOSYMBOL);
- if (var->c.sym.vtype==V_CONSTANT) error(E_NOVARIABLE,var);
+ if (var->c.sym.vtype==V_CONSTANT) error(E_ILLVARIABLE,var);
p=ctx->bindfp;
- while (p>declscope) {
- if (p->sym==var)
- if (p->val==UNBOUND) { bindspecial(ctx,var,val); return(ctx->bindfp);}
- else error(E_MULTIDECL);
- if (p==p->lexblink) break;
- p=p->lexblink;}
+ // while (p>declscope) {
+ // if (p->sym==var)
+ // if (p->val==UNBOUND) { bindspecial(ctx,var,val); return(ctx->bindfp);}
+ // else error(E_MULTIDECL);
+ // if (p==p->lexblink) break;
+ // p=p->lexblink;}
/*not found in declare scope*/
if (var->c.sym.vtype>= /* V_SPECIAL */ V_GLOBAL ) {
/* For defun-c-callable in eusforeign.l to create a foreign-pod,
@@ -217,15 +257,15 @@ struct bindframe *lex,*declscope;
return(ctx->bindfp);}
return(fastbind(ctx,var,val,lex));}
-struct bindframe *declare(ctx,decllist,env)
+pointer declare(ctx,decllist,env)
register context *ctx;
pointer decllist;
-struct bindframe *env;
+pointer env;
{ register pointer decl,var;
while (iscons(decllist)) {
decl=ccar(decllist); decllist=ccdr(decllist);
- if (!iscons(decl)) error(E_DECLARE);
+ if (!iscons(decl)) error(E_NOLIST);
if (ccar(decl)==QSPECIAL) { /*special binding*/
decl=ccdr(decl);
while (iscons(decl)) {
@@ -267,26 +307,30 @@ int noarg,allowotherkeys;
n++;}
return(suppliedbits);}
-struct bindframe *bindkeyparams(ctx,formal,argp,noarg,env,bf)
+pointer bindkeyparams(ctx,formal,argp,noarg,env,bf)
register context *ctx;
pointer formal;
pointer *argp;
int noarg;
-struct bindframe *env,*bf;
-{ pointer fvar,initform;
+pointer env,bf;
+{ pointer fvar,initform,svar;
register pointer fkeyvar,akeyvar;
pointer keys[KEYWORDPARAMETERLIMIT],
vars[KEYWORDPARAMETERLIMIT],
- inits[KEYWORDPARAMETERLIMIT];
+ inits[KEYWORDPARAMETERLIMIT],
+ supplied[KEYWORDPARAMETERLIMIT];
register int nokeys=0,i,n,allowotherkeys=0;
/*parse lambda list and make keyword tables*/
while (iscons(formal)) {
- fkeyvar=ccar(formal); formal=ccdr(formal);
+ fkeyvar=ccar(formal); formal=ccdr(formal); svar=UNBOUND;
if (iscons(fkeyvar)) {
fvar=ccar(fkeyvar);
initform=ccdr(fkeyvar);
- if (iscons(initform)) initform=ccar(initform); else initform=NIL;
+ if (iscons(initform)) {
+ if (ccdr(initform)!=NIL) svar=ccar(ccdr(initform));
+ initform=ccar(initform);}
+ else initform=NIL;
if (iscons(fvar)) {
fkeyvar=ccar(fvar); fvar=ccdr(fvar);
if (!iscons(fvar)) error(E_KEYPARAM);
@@ -303,7 +347,7 @@ struct bindframe *env,*bf;
if (islist(formal)) {
fkeyvar=ccar(formal); formal=ccdr(formal);
if (fkeyvar==AUX) break;
- else error(E_USER,(pointer)"something after &allow-other-keys"); }
+ else error(E_ARGUMENT_ERROR,(pointer)"something after &allow-other-keys"); }
break;}
else if (fkeyvar==AUX) break;
else {
@@ -317,9 +361,10 @@ struct bindframe *env,*bf;
keys[nokeys]=fkeyvar;
vars[nokeys]=fvar;
inits[nokeys]=initform;
+ supplied[nokeys]=svar;
nokeys++;
if (nokeys>=KEYWORDPARAMETERLIMIT) {
- error(E_USER, "Too many keyword parameters >%d",KEYWORDPARAMETERLIMIT);
+ error(E_PROGRAM_ERROR, (pointer)"too many keyword parameters >=128");
}
}
n=0;
@@ -334,24 +379,28 @@ struct bindframe *env,*bf;
if (ivsp;
struct specialbindframe *sbfps=ctx->sbindfp;
- struct bindframe *bf=ctx->bindfp;
+ pointer bf=ctx->bindfp;
struct blockframe *myblock;
int n=0,keyno=0,i;
jmp_buf funjmp;
@@ -385,11 +434,19 @@ int noarg;
if (fvar==AUX) goto bindaux;
if (nc.ivec.iv[0];
else cargv[i++].ival=(eusinteger_t)(lisparg->c.str.chars);
- else error(E_USER,(pointer)"unknown type specifier");}
+ else error(E_TYPE_ERROR,(pointer)"unknown type specifier");}
/* &rest arguments? */
while (ic.ivec.iv[0];
else cargs[i].ival=(eusinteger_t)(lisparg->c.str.chars);
offset[i++]=m++;}
- else error(E_USER,(pointer)"unknown type specifier");}
+ else error(E_TYPE_ERROR,(pointer)"unknown type specifier");}
/* &rest arguments? */
while (i= NUM_EXTRA_ARGUMENTS) {
- error(E_USER,(pointer)"too many number of arguments");
+ error(E_ARGUMENT_ERROR,(pointer)"too many number of arguments");
}
}
/* &rest arguments? */
@@ -944,7 +1001,7 @@ pointer args[];
if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
}
if (vcntr >= NUM_EXTRA_ARGUMENTS) {
- error(E_USER,(pointer)"too many number of arguments");
+ error(E_ARGUMENT_ERROR,(pointer)"too many number of arguments");
}
}
/**/
@@ -963,7 +1020,7 @@ pointer args[];
} else if (resulttype==K_STRING) {
p=makepointer(c-2*sizeof(pointer));
if (isvector(p)) return(p);
- else error(E_USER,(pointer)"illegal foreign string");
+ else error(E_VALUE_ERROR,(pointer)"illegal foreign string");
} else if (iscons(resulttype)) {
/* (:string [10]) (:foreign-string [20]) */
if (ccar(resulttype)==K_STRING) { /* R.Hanai 09/07/25 */
@@ -976,8 +1033,8 @@ pointer args[];
if (resulttype!=NIL) j=ckintval(ccar(resulttype));
else j=strlen((char *)c);
return(make_foreign_string(c, j)); }
- error(E_USER,(pointer)"unknown result type");
- } else error(E_USER,(pointer)"result type?");
+ error(E_TYPE_ERROR,(pointer)"unknown result type");
+ } else error(E_TYPE_ERROR,(pointer)"unknown result type");
}
}
@@ -1161,9 +1218,9 @@ pointer args[];
vargv[vcntr_16++] = numbox.i.i1; vargv[vcntr_16++] = numbox.i.i2;
if ( vcntr_8 % 2 == 0 ) vcntr_8 = vcntr_16;
}
- } else error(E_USER,(pointer)"unknown type specifier");
+ } else error(E_TYPE_ERROR,(pointer)"unknown type specifier");
if (max(vcntr_8, vcntr_16) >= NUM_EXTRA_ARGUMENTS) {
- error(E_USER,(pointer)"too many number of arguments");
+ error(E_ARGUMENT_ERROR,(pointer)"too many number of arguments");
}
}
int vcntr = max(vcntr_8, vcntr_16);
@@ -1194,7 +1251,7 @@ pointer args[];
if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
}
if (vcntr >= NUM_EXTRA_ARGUMENTS) {
- error(E_USER,(pointer)"too many number of arguments");
+ error(E_ARGUMENT_ERROR,(pointer)"too many number of arguments");
}
}
/**/
@@ -1209,7 +1266,7 @@ pointer args[];
} else if (resulttype==K_STRING) {
p=makepointer(c-2*sizeof(pointer));
if (isvector(p)) return(p);
- else error(E_USER,(pointer)"illegal foreign string");
+ else error(E_VALUE_ERROR,(pointer)"illegal foreign string");
} else if (iscons(resulttype)) {
/* (:string [10]) (:foreign-string [20]) */
if (ccar(resulttype)==K_STRING) { /* R.Hanai 09/07/25 */
@@ -1222,8 +1279,8 @@ pointer args[];
if (resulttype!=NIL) j=ckintval(ccar(resulttype));
else j=strlen((char *)c);
return(make_foreign_string(c, j)); }
- error(E_USER,(pointer)"unknown result type");
- } else error(E_USER,(pointer)"result type?");
+ error(E_TYPE_ERROR,(pointer)"unknown result type");
+ } else error(E_TYPE_ERROR,(pointer)"unknown result type");
}
}
@@ -1270,7 +1327,7 @@ pointer args[];
else if (p==K_DOUBLE || (WORD_SIZE==64 && p==K_FLOAT)) {
numbox.d=ckfltval(lisparg);
cargv[i++]=numbox.i.i1; cargv[i++]=numbox.i.i2;}
- else error(E_USER,(pointer)"unknown type specifier");}
+ else error(E_TYPE_ERROR,(pointer)"unknown type specifier");}
/* &rest arguments? */
while (j=0) error(E_ILLFUNC);
+ if (noarg>=0) error(E_NOFUNCTION);
while (iscons(args)) { vpush(ccar(args)); args=ccdr(args); n++;}
GC_POINT;
tmp = (*subr)(ctx,n,argp);
GC_POINT;
return(eval(ctx,tmp));
case (eusinteger_t)SUBR_SPECIAL: /* ???? */
- if (noarg>=0) error(E_ILLFUNC);
+ if (noarg>=0) error(E_NOFUNCTION);
else return((*subr)(ctx,args));
/* case (int)SUBR_ENTRY:
func=(*subr)(func);
return(makeint(func)); */
- default: error(E_ILLFUNC); break;}
+ default: error(E_NOFUNCTION); break;}
}
pointer clofunc;
@@ -1470,14 +1527,14 @@ pointer ufuncall(ctx,form,fn,args,env,noarg)
register context *ctx;
pointer form,fn;
register pointer args; /*or 'pointer *' */
-struct bindframe *env;
+pointer env;
int noarg;
{ pointer func,formal,aval,ftype,result,*argp,hook;
register struct callframe *vf=(struct callframe *)(ctx->vsp);
struct specialbindframe *sbfps=ctx->sbindfp;
register int n=0,i;
register pointer (*subr)();
- struct fletframe *oldfletfp=ctx->fletfp, *fenv;
+ pointer oldfletfp=ctx->fletfp, fenv;
GC_POINT;
/* evalhook */
if (Spevalof(QEVALHOOK)!=NIL && ehbypass==0) {
@@ -1508,7 +1565,7 @@ int noarg;
else {
if (islist(fn)) env=ctx->bindfp;
func=fn;}
- if (!ispointer(func)) error(E_ILLFUNC);
+ if (!ispointer(func)) error(E_NOFUNCTION);
/*make a new stack frame*/
stackck; /*stack overflow?*/
@@ -1522,7 +1579,7 @@ int noarg;
if (pisclosure(func)) {
clofunc=func;
fn=func;
- if (fn->c.code.subrtype!=SUBR_FUNCTION) error(E_ILLFUNC);
+ if (fn->c.code.subrtype!=SUBR_FUNCTION) error(E_NOFUNCTION);
#if (WORD_SIZE == 64)
subr=(pointer (*)())((eusinteger_t)(fn->c.code.entry) & ~3L /*0xfffffffc ????*/);
#else
@@ -1548,7 +1605,7 @@ int noarg;
#if !Solaris2 && !SunOS4_1 && !Linux && !IRIX && !IRIX6 && !alpha && !Cygwin
if ((char *)subr>maxmemory) {
prinx(ctx,clofunc, STDOUT);
- error(E_USER,(pointer)"garbage closure, fatal bug!"); }
+ error(E_VALUE_ERROR,(pointer)"invalid closure"); }
#endif
if (noarg<0) {
while (iscons(args)) {
@@ -1578,20 +1635,27 @@ int noarg;
else if (piscons(func)) {
ftype=ccar(func);
func=ccdr(func);
- if (!issymbol(ftype)) error(E_LAMBDA);
+ if (!issymbol(ftype)) error(E_NOFUNCTION);
if (ftype->c.sym.homepkg==keywordpkg) fn=ftype; /*blockname=selector*/
else if (ftype==LAMCLOSURE) {
fn=ccar(func); func=ccdr(func);
- env=(struct bindframe *)intval(ccar(func));
- if (env < (struct bindframe *)ctx->stack ||
- (struct bindframe *)ctx->stacklimit < env) env=0;
+ // bind-frame
+ if (ccar(func)==NULL || isbindframe(ccar(func)))
+ env=ccar(func);
+ else if (isint(ccar(func)) && intval(ccar(func))==0)
+ env=NULL;
+ else error(E_NOBINDFRAME);
func=ccdr(func);
- /* ctx->fletfp=(struct fletframe *)intval(ccar(func)); */
- fenv=(struct fletframe *)intval(ccar(func));
+ // flet-frame
+ if (ccar(func)==NULL || isfletframe(ccar(func)))
+ fenv=ccar(func);
+ else if (isint(ccar(func)) && intval(ccar(func))==0)
+ fenv=NULL;
+ else error(E_NOFLETFRAME);
func=ccdr(func);}
- else if (ftype!=LAMBDA && ftype!=MACRO) error(E_LAMBDA);
+ else if (ftype!=LAMBDA && ftype!=MACRO) error(E_NOFUNCTION);
else env=NULL /*0 ????*/;
- formal=carof(func,E_LAMBDA);
+ formal=carof(func,E_NOFUNCTION);
func=ccdr(func);
if (noarg<0) { /*spread args on stack*/
noarg=0;
@@ -1602,7 +1666,7 @@ int noarg;
vpush(aval); noarg++;}}
else {
argp=(pointer *)args;
- if (ftype==MACRO) error(E_ILLFUNC);}
+ if (ftype==MACRO) error(E_NOFUNCTION);}
GC_POINT;
if (ftype==LAMCLOSURE) { ctx->fletfp=fenv; }
result=funlambda(ctx,fn,formal,func,argp,env,noarg);
@@ -1616,7 +1680,7 @@ int noarg;
/* check return barrier */
#endif
return(result);}
- else error(E_ILLFUNC);
+ else error(E_NOFUNCTION);
}
pointer eval(ctx,form)
@@ -1673,7 +1737,7 @@ pointer env;
else {
c=ccdr(form);
if (c!=NIL && issymbol(c)) return(*ovafptr(eval(ctx,ccar(form)),c));
- else return(ufuncall(ctx,form,ccar(form),(pointer)c,(struct bindframe *)env,-1));}
+ else return(ufuncall(ctx,form,ccar(form),(pointer)c,(pointer)env,-1));}
}
pointer progn(ctx,forms)
@@ -1708,6 +1772,7 @@ pointer csend(context *ctx, ...)
while (i++ < cnt) vpush(va_arg(ap,pointer));
GC_POINT;
res=(pointer)SEND(ctx,cnt+2, spsave);
+ va_end(ap);
ctx->vsp=spsave;
return(res);}
@@ -1731,6 +1796,7 @@ va_dcl
while (i++ < cnt) vpush(va_arg(ap,pointer));
GC_POINT;
res=(pointer)SEND(ctx,cnt+2, spsave);
+ va_end(ap);
ctx->vsp=spsave;
#ifdef SAFETY
take_care(res);
diff --git a/lisp/c/intern.c b/lisp/c/intern.c
index b8f6d1901..f3b683d97 100644
--- a/lisp/c/intern.c
+++ b/lisp/c/intern.c
@@ -45,8 +45,9 @@ register pointer symvec;
if (++hash>=size) hash=0;}
while (1);}
-static pointer extendsymvec(symvec)
+static pointer extendsymvec(symvec, count)
pointer symvec;
+int* count;
{ register pointer newsymvec,sym;
bpointer bp;
register int i,newsize,size,hash;
@@ -58,10 +59,12 @@ pointer symvec;
newsize=buddysize[bp->h.bix+1]-2;
#endif
newsymvec=makevector(C_VECTOR,newsize);
+ *count=0;
for (i=0; ic.vec.v[i]=makeint(0); /*empty mark*/
for (i=0; ic.vec.v[i];
if (issymbol(sym)) {
+ ++(*count);
hash=rehash(sym->c.sym.pname) % newsize;
while (newsymvec->c.vec.v[hash]!=makeint(0)) { /*find an empty slot*/
if (++hash>=newsize) hash=0;}
@@ -74,8 +77,8 @@ pointer symvec;
pointer export(sym,pkg)
pointer sym,pkg;
{ register pointer symvec=pkg->c.pkg.symvector; /*external symbol table*/
- register int size, newsymcount;
- int hash;
+ register int size;
+ int hash, newsymcount;
pointer usedby,usedbylist=pkg->c.pkg.used_by;
pointer pnam,s;
@@ -93,11 +96,13 @@ pointer sym,pkg;
while (1) {
if (symvec->c.vec.v[hash]==sym) return(sym);
if (isint(symvec->c.vec.v[hash])) {
+ newsymcount=intval(pkg->c.pkg.symcount);
+ if(intval(symvec->c.vec.v[hash]) == 0) // only increase count if empty
+ newsymcount+=1;
pointer_update(symvec->c.vec.v[hash],sym);
- newsymcount=intval(pkg->c.pkg.symcount)+1;
+ if (newsymcount > (size / 2))
+ pointer_update(pkg->c.pkg.symvector, extendsymvec(symvec, &newsymcount));
pkg->c.pkg.symcount=makeint(newsymcount);
- if (newsymcount > (size / 2))
- pointer_update(pkg->c.pkg.symvector, extendsymvec(symvec));
return(sym);}
else if (++hash>=size) hash=0;}
}
@@ -123,17 +128,19 @@ pointer pkg; /*destination package*/
newsym=makesymbol(ctx,id,l,pkg);
/*put it in the package*/
while (issymbol(symvec->c.vec.v[hash])) if (++hash>=size) hash=0;
+ l=intval(pkg->c.pkg.intsymcount);
+ if (intval(symvec->c.vec.v[hash]) == 0) // only increase count if empty
+ l+=1;
pointer_update(symvec->c.vec.v[hash],newsym);
if (pkg==keywordpkg) {
newsym->c.sym.vtype=V_CONSTANT;
pointer_update(newsym->c.sym.speval,newsym);
export(newsym,pkg);}
- l=intval(pkg->c.pkg.intsymcount)+1;
- pkg->c.pkg.intsymcount=makeint(l);
if (l>(size/2)) { /*extend hash table*/
vpush(newsym);
- pointer_update(pkg->c.pkg.intsymvector,extendsymvec(symvec));
+ pointer_update(pkg->c.pkg.intsymvector,extendsymvec(symvec, &l));
vpop();}
+ pkg->c.pkg.intsymcount=makeint(l);
/* export all the symbols to avoid incompatibility with old EusLisp*/
if (export_all) export(newsym, pkg);
#ifdef SAFETY
diff --git a/lisp/c/leo.c b/lisp/c/leo.c
index 7db8533f6..bb9ebc5c0 100644
--- a/lisp/c/leo.c
+++ b/lisp/c/leo.c
@@ -138,7 +138,7 @@ pointer (*cfunc)();
class=speval(class);
if (class==UNBOUND || !isclass(class)) error(E_NOCLASS,class);
addmethod(ctx,cons(ctx,sel,
- cons(ctx,makecode(mod,cfunc,SUBR_FUNCTION),NIL)),
+ cons(ctx,makecode(ctx,mod,cfunc,SUBR_FUNCTION,sel),NIL)),
class,doc);}
pointer DEFMETHOD(ctx,arg) /*special form*/
@@ -254,7 +254,7 @@ register pointer argv[];
{ register pointer receiver,klass,selector,meth,result;
register pointer *spsave=ctx->vsp, *altargv;
pointer curclass, component;
- struct bindframe *bf,*bfsave=ctx->bindfp;
+ pointer bf,bfsave=ctx->bindfp;
struct specialbindframe *sbfpsave=ctx->sbindfp;
int sbcount=ctx->special_bind_count;
int i,argoffset;
@@ -319,7 +319,7 @@ register pointer argv[];
{ register pointer receiver,klass,selector,meth,result;
register pointer *spsave=ctx->vsp,*altargv;
pointer curclass, component;
- struct bindframe *bf,*bfsave=ctx->bindfp;
+ pointer bf,bfsave=ctx->bindfp;
struct specialbindframe *sbfpsave=ctx->sbindfp;
int argoffset;
@@ -366,7 +366,7 @@ int n;
pointer argv[];
/* (send-message obj search selector [args]) */
{ pointer receiver,search,selector,meth,form,result,*spsave, curclass;
- struct bindframe *bf,*bfsave=ctx->bindfp;
+ pointer bf,bfsave=ctx->bindfp;
struct specialbindframe *sbfpsave=ctx->sbindfp;
if (n<3) error(E_MISMATCHARG);
@@ -428,7 +428,7 @@ pointer argv[];
take_care(x);
#endif
return(x);}
- else error(E_INSTANTIATE);}
+ else error(E_NOCLASS);}
pointer METHCACHE(ctx,n,argv)
register context *ctx;
@@ -477,6 +477,7 @@ register pointer obj,klass,varid;
register pointer vvec;
extern pointer equal();
+ if (isnum(obj)) error(E_NOOBJECT);
if (!isclass(klass)) error(E_NOCLASS,klass);
objcix=obj->cix;
klasscix=intval(klass->c.cls.cix);
@@ -493,9 +494,9 @@ register pointer obj,klass,varid;
if (equal(vvec->c.vec.v[index]->c.sym.pname, varid)==T) break;
else index++;}
else error(E_NOINT);
- if (index>=vecsize(vvec)) error(E_NOOBJVAR,varid);
+ if (index>=vecsize(vvec)) error(E_NOSLOT,varid);
return(index);}
- else error(E_NOOBJVAR,varid);}
+ else error(E_NOSLOT,varid);}
pointer SLOT(ctx,n,argv)
register context *ctx;
@@ -551,27 +552,36 @@ register context *ctx;
register pointer org;
{ register pointer clone;
pointer klass,x;
- register int i,s;
+ register int i,s,off;
int etype;
- if (isnum(org) || issymbol(org) || isclass(org)) return(org);
+ if (org==NULL || isnum(org) || issymbol(org) || isclass(org)) return(org);
/* eus_rbar *//* if ((org==0) || isnum(org) || issymbol(org) || isclass(org)) return(org); */
- x=org->c.obj.iv[1];
+ klass=classof(org);
+ if (isvecclass(klass)) off=1;
+ else off=0;
+
+ x=org->c.obj.iv[off];
if (p_marked(org)) return(cpvec[intval(x)]);
p_mark_on(org);
- klass=classof(org);
if (isvecclass(klass)) {
etype=elmtypeof(org);
s=vecsize(org);
- clone=makevector(klass,s);
- elmtypeof(clone)=etype;
switch(etype) {
case ELM_BIT: s=(s+WORD_SIZE-1)/WORD_SIZE; break;
case ELM_BYTE: case ELM_CHAR: s=(s+sizeof(eusinteger_t))/sizeof(eusinteger_t); break;
- case ELM_FOREIGN: s=1; break; }}
+ case ELM_FOREIGN: s=1; break; }
+ if (s==0) {
+ p_mark_off(org);
+ return(org);}
+ clone=makevector(klass,vecsize(org));
+ elmtypeof(clone)=etype;}
else {
etype=ELM_FIXED;
s=objsize(org);
+ if (s==0) {
+ p_mark_off(org);
+ return(org);}
clone=(pointer)makeobject(klass);}
if (ctx->vsp>ctx->stacklimit)
@@ -579,28 +589,28 @@ register pointer org;
fprintf(stderr,"cannot copy\n"); euslongjmp(cpyjmp,ERR);}
#ifdef RGC /* R.Hanai */
if (etype == ELM_FIXED || etype == ELM_POINTER) {
- pointer_update(org->c.obj.iv[1],makeint(cpx));
+ pointer_update(org->c.obj.iv[off],makeint(cpx));
} else {
- org->c.obj.iv[1] = makeint(cpx);
+ org->c.obj.iv[off] = makeint(cpx);
}
#else
- pointer_update(org->c.obj.iv[1],makeint(cpx));
+ pointer_update(org->c.obj.iv[off],makeint(cpx));
#endif
vpush(clone);
vpush(x);
cpx += 2;
switch (etype) {
case ELM_FIXED:
- clone->c.obj.iv[1]=copyobj(ctx,x);
- if (s>0) clone->c.obj.iv[0]=copyobj(ctx,org->c.obj.iv[0]);
- for (i=2; ic.obj.iv[i]=copyobj(ctx,org->c.obj.iv[i]);
+ if (off) error(E_PROGRAM_ERROR,(pointer)"object class expected");
+ if (s>0) clone->c.obj.iv[0]=copyobj(ctx,x);
+ for (i=1; ic.obj.iv[i]=copyobj(ctx,org->c.obj.iv[i]);
break;
case ELM_POINTER:
- clone->c.vec.v[0]=copyobj(ctx,x);
+ if (s>0) clone->c.vec.v[0]=copyobj(ctx,x);
for (i=1; ic.vec.v[i]=copyobj(ctx,org->c.vec.v[i]);
break;
default:
- clone->c.vec.v[0]=x; /*copyobj(ctx,x) fails */
+ if (s>0) clone->c.vec.v[0]=x; /*copyobj(ctx,x) fails */
for (i=1; ic.ivec.iv[i]=org->c.ivec.iv[i];
break;}
#ifdef SAFETY
@@ -611,12 +621,15 @@ register pointer org;
void copyunmark(obj)
register pointer obj;
{ pointer x,klass;
- register int i,s;
+ register int i,s,off;
- if (isnum(obj) || pissymbol(obj) || pisclass(obj)) return;
- x=obj->c.obj.iv[1];
+ if (obj==NULL || isnum(obj) || pissymbol(obj) || pisclass(obj)) return;
+ klass=classof(obj);
+ if (isvecclass(klass)) off=1;
+ else off=0;
+ x=obj->c.obj.iv[off];
if (p_marked(obj)) {
- pointer_update(obj->c.obj.iv[1],cpvec[intval(x)+1]);
+ pointer_update(obj->c.obj.iv[off],cpvec[intval(x)+1]);
p_mark_off(obj);
if (pisvector(obj)) {
if (elmtypeof(obj)vsp=spsave;
- if (b==(pointer)ERR) error(E_USER,(pointer)"too big to copy");
+ if (b==(pointer)ERR) error(E_PROGRAM_ERROR,(pointer)"too big to copy");
else return(b);
}
@@ -660,8 +673,8 @@ register pointer argv[];
if (isnum(argv[0])) error(E_NOOBJECT);
if (isvecclass(argv[1])) {
e1=elmtypeof(argv[0]); e2=intval(argv[1]->c.vcls.elmtype);
- if (e1==ELM_FIXED) error(E_USER,(pointer)"a record type object cannot become a vector");
- if (e1==ELM_POINTER && e1!=e2) error(E_USER,(pointer)"element type mismatch");
+ if (e1==ELM_FIXED) error(E_TYPE_ERROR,(pointer)"a record type object cannot become a vector");
+ if (e1==ELM_POINTER && e1!=e2) error(E_TYPE_ERROR,(pointer)"element type mismatch");
/*chage length field*/
n=vecsize(argv[0]);
switch(e1) {
@@ -695,7 +708,7 @@ register pointer argv[];
else error(E_ARRAYINDEX);
return(argv[0]);
}
- else error(E_USER,(pointer)"vector class or number expected");
+ else error(E_TYPE_ERROR,(pointer)"vector class or number expected");
}
pointer REPLACEOBJECT(ctx,n,argv)
diff --git a/lisp/c/lispio.c b/lisp/c/lispio.c
index 91d87f793..cb1614c06 100644
--- a/lisp/c/lispio.c
+++ b/lisp/c/lispio.c
@@ -44,7 +44,7 @@ pointer argv[];
else if (isfilestream(s)) {
if (closestream(s)<0) return(NIL);
return(T);}
- else error(E_USER,(pointer)"file stream expected");}
+ else error(E_TYPE_ERROR,(pointer)"file stream expected");}
pointer getoutstream(ctx,n,strm)
context *ctx;
@@ -232,7 +232,7 @@ pointer argv[];
byte *newcb = malloc(buflength+READLINE_BUF_LENGTH);
if (newcb == NULL) {
free(cb);
- error(E_USER, (pointer)"Memory allocation error by read-line");
+ error(E_PROGRAM_ERROR, (pointer)"Memory allocation error by read-line");
break;
}
memcpy(newcb, cb, buflength);
@@ -370,7 +370,7 @@ pointer argv[];
if (n>=3) nontermp=argv[2];
if (n==4) rdtable=argv[3];
else rdtable=Spevalof(QREADTABLE);
- if (!isreadtable(rdtable)) error(E_USER,(pointer)"readtable expected");
+ if (!isreadtable(rdtable)) error(E_IO_ERROR,(pointer)"readtable expected");
pointer_update(rdtable->c.rdtab.macro->c.vec.v[ch],argv[1]);
if (argv[1]==NIL) rdtable->c.rdtab.syntax->c.str.chars[ch]=(byte)chartype[ch];
else if (nontermp==NIL) rdtable->c.rdtab.syntax->c.str.chars[ch]=(int)ch_termmacro;
@@ -385,7 +385,7 @@ pointer argv[];
ckarg2(1,2);
if (n==2) rdtable=argv[1];
else rdtable=Spevalof(QREADTABLE);
- if (!isreadtable(rdtable)) error(E_USER,(pointer)"readtable expected");
+ if (!isreadtable(rdtable)) error(E_IO_ERROR,(pointer)"readtable expected");
return(rdtable->c.rdtab.macro->c.vec.v[max(0,min(255,ckintval(argv[0])))]);}
pointer SETDISPMACRO(ctx,n,argv)
@@ -400,7 +400,7 @@ register pointer argv[];
if (ch<0 || 256c.rdtab.dispatch->c.vec.v[ch],/*(pointer (*)())*/argv[2]);
return(T);}
@@ -416,7 +416,7 @@ pointer argv[];
if (ch<0 || 256c.rdtab.dispatch->c.vec.v[ch];
return(func);}
@@ -545,12 +545,12 @@ pointer argv[];
case '%': case '&': /*newline*/
for (j=0; j<=param[0]; j++) writech(dest,'\n');
if (argv[0]!=NIL)
- if (flushstream(dest)!=0) error(E_USER,(pointer)"cannot flush stream");
+ if (flushstream(dest)!=0) error(E_IO_ERROR,(pointer)"cannot flush stream");
break;
case '~': /*tilda*/
writech(dest,'~'); break;
case 'T': /*tabulate*/
- writech(dest,9); break;;
+ writech(dest,9); break;
default: break;
}
}
@@ -567,23 +567,28 @@ pointer SIGERROR(ctx,n,argv)
register context *ctx;
register int n;
register pointer *argv;
-{ register int i;
- pointer msg;
+{ register int i=0;
+ pointer msg, errobj;
pointer *argb=ctx->vsp;
- if (isstring(argv[0])) {
- vpush(NIL);
- for (i=0; ic.str.chars),argv[1]);}
- else error((enum errorcode)(ckintval(argv[0])),argv[1]);}
-pointer INSTALL_ERRHANDLER(ctx,n,argv)
-register context *ctx;
-register int n;
-register pointer *argv;
-{ ckarg(1);
- ctx->errhandler=argv[0];
- return(argv[0]);}
+ if (n==0) error(E_MISMATCHARG);
+ if (isclass(argv[0])) {
+ /* ensure is derived from error class */
+ int objcix,klasscix;
+ objcix=intval(argv[0]->c.cls.cix);
+ klasscix=intval(C_ERROR->c.cls.cix);
+ if (!(objcix>=klasscix) || !(objcix<=classtab[klasscix].subcix)) {
+ error(E_TYPE_ERROR, "error class expected");}
+ i++;
+ errobj=makeobject(argv[0]);}
+ else {
+ errobj=makeobject(C_ERROR);}
+ if (isstring(argv[i])) {
+ vpush(NIL);
+ for (; i0 && islist(a)) a=ccdr(a);
if (islist(a)) return(ccar(a));
else if (a==NIL) return(NIL);
@@ -125,7 +125,7 @@ register pointer *argv;
ckarg(2);
i=ckintval(argv[0]);
a=argv[1];
- if (i<0) error(E_NOINT);
+ if (i<0) error(E_SEQINDEX);
if (a==NIL) return(NIL);
else if (!islist(a)) error(E_NOLIST);
while (i-->0 && islist(a)) a=ccdr(a);
@@ -282,19 +282,6 @@ pointer MEMBER(ctx,n,argv)
register context *ctx;
int n;
register pointer argv[];
-{ pointer item=argv[0],list=argv[1],result;
- ckarg(2);
- while (islist(list)) {
- result=equal(ccar(list),item);
- if (result==T) return(list);
- else if (result==UNBOUND) error(E_CIRCULAR);
- else list=ccdr(list);}
- return(NIL);}
-
-pointer SUPERMEMBER(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
{ register pointer item=argv[0],list=argv[1];
pointer key=argv[2],test=argv[3],testnot=argv[4];
register pointer target;
@@ -322,7 +309,7 @@ register pointer item,alist;
if (iscons(temp)) {
if (ccar(temp)==item) return(temp);
else alist=ccdr(alist);}
- else error(E_ALIST);}
+ else error(E_NOLIST);}
return(NIL);}
pointer ASSQ(ctx,n,argv)
@@ -336,33 +323,22 @@ pointer ASSOC(ctx,n,argv)
register context *ctx;
int n;
register pointer argv[];
-{ register pointer item=argv[0],alist=argv[1],temp,compare;
- ckarg(2);
- while (islist(alist)) {
- temp=ccar(alist);
- if (islist(temp)) {
- compare=equal(item,ccar(temp));
- if (compare==T) return(temp);
- else if (compare==UNBOUND) error(E_CIRCULAR);
- else alist=ccdr(alist);}
- else error(E_ALIST);}
- return(NIL);}
-
-pointer SUPERASSOC(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
{ register pointer item=argv[0],alist=argv[1];
pointer key=argv[2],test=argv[3],testnot=argv[4];
+ pointer rassoc=argv[5], iftest=argv[6], ifnottest=argv[7];
register pointer temp,target;
register eusinteger_t compare;
- ckarg(5);
+ ckarg(8);
while (islist(alist)) {
target=ccar(alist);
if (islist(target)) { /*ignore non-pair elements*/
+ if (rassoc==NIL) temp=ccar(target);
+ else temp=ccdr(target);
if (key==NIL) temp=ccar(target);
else temp=call1(ctx,key,target);
- if (testnot!=NIL) compare=(call2(ctx,testnot,item,temp)==NIL);
+ if (ifnottest!=NIL) compare=(call1(ctx,ifnottest,temp)==NIL);
+ else if (iftest!=NIL) compare=(call1(ctx,iftest,temp)!=NIL);
+ else if (testnot!=NIL) compare=(call2(ctx,testnot,item,temp)==NIL);
else if (test==NIL || test==QEQ) compare=(item==temp);
else if (test==QEQUAL) compare=(equal(item,temp)==T);
else compare=(call2(ctx,test,item,temp)!=NIL);
@@ -381,7 +357,7 @@ pointer argv[];
if (!iscons(a)) {
if (a==NIL) return(NIL);
else error(E_NOLIST); }
- if (n<0) error(E_USER,(pointer)"The second argument must be non-negative number");
+ if (n<0) error(E_VALUE_ERROR,(pointer)"second argument must be non-negative number");
while (iscons(a)) { ckpush(ccar(a)); a=ccdr(a); count++;}
n=min(count,n);
ctx->vsp -= n;
@@ -391,15 +367,19 @@ pointer NBUTLAST(ctx,n,argv)
register context *ctx;
register int n;
pointer argv[];
-{ register pointer a=argv[0], b;
- register int count=0;
+{ ckarg2(1,2);
+ register pointer a=argv[0], b;
+ register int count=0, l=0;
register pointer *vspsave=ctx->vsp;
if (n==2) n=ckintval(argv[1]);
else n=1;
if (!iscons(a)) {
if (a==NIL) return(NIL);
else error(E_NOLIST); }
- if (n<0) error(E_USER,(pointer)"The second argument must be non-negative number");
+ if (n<0) error(E_SEQINDEX);
+ while (islist(a)) { l++; a=ccdr(a);}
+ a=argv[0];
+ if (n>=l) return(NIL);
while (iscons(a)) { ckpush(a); a=ccdr(a); count++;}
n=min(count,n);
b= *(ctx->vsp - n - 1);
@@ -436,10 +416,8 @@ register pointer mod;
defun(ctx,"LIST",mod,LIST,NULL);
defun(ctx,"LIST*",mod,LIST_STAR,NULL);
defun(ctx,"MEMQ",mod,MEMQ,NULL);
- defun(ctx,"MEMBER",mod,MEMBER,NULL);
- defun(ctx,"SUPERMEMBER",mod,SUPERMEMBER,NULL);
defun(ctx,"ASSQ",mod,ASSQ,NULL);
- defun(ctx,"ASSOC",mod,ASSOC,NULL);
- defun(ctx,"SUPERASSOC",mod,SUPERASSOC,NULL);
+ defunpkg(ctx,"RAW-MEMBER",mod,MEMBER,syspkg);
+ defunpkg(ctx,"RAW-ASSOC",mod,ASSOC,syspkg);
}
diff --git a/lisp/c/loadelf.c b/lisp/c/loadelf.c
index 043e36828..d41e7c559 100644
--- a/lisp/c/loadelf.c
+++ b/lisp/c/loadelf.c
@@ -88,7 +88,9 @@ char *name;
pointer (*entry)();
{
/* printf("%s %x is added in the module_initializer list\n", name, entry); */
- if (module_count>=MAX_SYSTEM_MODULES) error(E_USER,(pointer)"too many system modules");
+ if (module_count>=MAX_SYSTEM_MODULES) {
+ error(E_PROGRAM_ERROR,(pointer)"too many system modules");
+ }
module_initializers[module_count].module_name= name;
module_initializers[module_count].entry_func= entry;
module_count++;}
@@ -206,7 +208,7 @@ pointer *argv;
char namebuf[256];
ckarg(2);
- if (!isldmod(argv[0])) error(E_USER,(pointer)"not a LOAD-MODULE");
+ if (!isldmod(argv[0])) error(E_TYPE_ERROR,(pointer)"not a LOAD-MODULE");
if (!iscons(argv[1])) error(E_NOLIST);
#if (WORD_SIZE == 64)
dlhandle=(void *)((eusinteger_t)(argv[0]->c.ldmod.handle) & ~3L);
@@ -215,7 +217,7 @@ pointer *argv;
#endif
initnames=argv[1];
module_count=0;
- if (dlhandle==NULL) error(E_USER,(pointer)"This module was not loaded");
+ if (dlhandle==NULL) error(E_PROGRAM_ERROR,(pointer)"This module was not loaded");
while (iscons(initnames)) {
initfunc= dlsym(dlhandle, (char *)ccar(initnames)->c.str.chars);
@@ -311,7 +313,7 @@ pointer argv[];
ckarg2(1,2);
if (n==2) mod=argv[1];
else mod=sysmod;
- if (!isldmod(mod)) error(E_USER,(pointer)"not a LOAD-MODULE");
+ if (!isldmod(mod)) error(E_TYPE_ERROR,(pointer)"not a LOAD-MODULE");
entry_string=(char *)get_string(argv[0]);
#if (WORD_SIZE == 64)
entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L), entry_string);
@@ -332,7 +334,7 @@ pointer argv[];
ckarg2(1,2);
if (n==2) mod=argv[1];
else mod=sysmod;
- if (!isldmod(mod)) error(E_USER,(pointer)"not a LOAD-MODULE");
+ if (!isldmod(mod)) error(E_TYPE_ERROR,(pointer)"not a LOAD-MODULE");
entry_string=(char *)get_string(argv[0]);
#if (WORD_SIZE == 64)
entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L), entry_string);
@@ -357,7 +359,7 @@ pointer *argv;
{ register pointer mod=argv[0];
register int stat;
ckarg(1);
- if (!isldmod(mod)) error(E_USER,(pointer)"not a compiled-module");
+ if (!isldmod(mod)) error(E_TYPE_ERROR,(pointer)"not a compiled-module");
#if (WORD_SIZE == 64)
stat=dlclose((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L));
#else
@@ -422,7 +424,7 @@ pointer SAVE(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
-{ error(E_USER,(pointer)"SAVE is not supported on Solaris");}
+{ error(E_PROGRAM_ERROR,(pointer)"SAVE is not supported on Solaris");}
void loadsave(ctx,mod)
diff --git a/lisp/c/makes.c b/lisp/c/makes.c
index c511be5ce..6920aad46 100644
--- a/lisp/c/makes.c
+++ b/lisp/c/makes.c
@@ -16,7 +16,8 @@ static char *rcsid="@(#)$Id$";
#define nextbuddy(p) ((bpointer)((eusinteger_t)p+(buddysize[p->h.bix]*sizeof(pointer))))
#endif
-extern pointer LAMCLOSURE, K_FUNCTION_DOCUMENTATION;
+extern pointer LAMCLOSURE, MACRO, K_NAME, K_FUNCTION_DOCUMENTATION;
+extern pointer C_BINDFRAME, C_FLETFRAME;
/****************************************************************/
/* boxing and unboxing
@@ -206,27 +207,29 @@ register pointer namestr,nicks,uses;
/*check pkg name collision*/
namestr=Getstring(namestr);
if (findpkg(namestr)) error(E_PKGNAME,namestr);
- vpush(namestr); vpush(nicks); vpush(uses);
- i=0;
+ vpush(nicks); vpush(uses); vpush(namestr);
+ i=1; // package name is the first in the nickname list
while (islist(nicks)) {
if (findpkg(ccar(nicks))) error(E_PKGNAME,ccar(nicks));
vpush(Getstring(ccar(nicks))); i++;
nicks=ccdr(nicks);}
nicks=stackrawlist(ctx,i); /*list up package nicknames*/
+ vpush(nicks);
i=0;
while (islist(uses)) {
if ((p=findpkg(ccar(uses)))) { vpush(p); i++; uses=ccdr(uses);}
else error(E_PKGNAME,ccar(uses));}
uses=stackrawlist(ctx,i);
+ vpush(uses);
pkg=allocobj(PKGCLASS,package, packagecp.cix);
pkg->c.pkg.names=pkg->c.pkg.symvector=pkg->c.pkg.intsymvector=NULL;
pkg->c.pkg.symcount=pkg->c.pkg.intsymcount=makeint(0);
- pkg->c.pkg.use=uses;
pkg->c.pkg.plist=NIL;
pkg->c.pkg.shadows=NIL;
pkg->c.pkg.used_by=NIL;
+ pkg->c.pkg.use=vpop(); // uses
+ pkg->c.pkg.names=vpop(); // nicks
vpush(pkg);
- pkg->c.pkg.names=rawcons(ctx,namestr,nicks);
symvec=makevector(C_VECTOR,SYMBOLHASH);
for (i=0; ic.vec.v[i]=makeint(0);
pkg->c.pkg.symvector=symvec;
@@ -235,18 +238,18 @@ register pointer namestr,nicks,uses;
pkg->c.pkg.intsymvector=symvec;
pkglist=rawcons(ctx,pkg,pkglist);
ctx->lastalloc=pkg;
- ctx->vsp -= 4;
+ ctx->vsp -= 3;
return(pkg);}
pointer mkstream(ctx,dir,string)
register context *ctx;
pointer dir,string;
{ register pointer s;
- vpush(string);
+ vpush(dir); vpush(string);
s=allocobj(STREAM, stream, streamcp.cix);
- s->c.stream.direction=dir;
s->c.stream.count=s->c.stream.tail=makeint(0);
- s->c.stream.buffer=vpop();
+ s->c.stream.buffer=vpop(); // string
+ s->c.stream.direction=vpop(); // dir
s->c.stream.plist=NIL;
return(s);}
@@ -256,13 +259,13 @@ pointer dir,string,fname;
int fno;
{ register pointer s;
if (dir!=K_IN && dir!=K_OUT) error(E_IODIRECTION);
- vpush(string); vpush(fname);
+ vpush(dir); vpush(string); vpush(fname);
s=allocobj(FILESTREAM, filestream, filestreamcp.cix);
- s->c.fstream.direction=dir;
s->c.fstream.count=s->c.fstream.tail=makeint(0);
- s->c.fstream.fname=vpop();
- s->c.fstream.buffer=vpop();
s->c.fstream.fd=makeint(fno);
+ s->c.fstream.fname=vpop(); // fname
+ s->c.fstream.buffer=vpop(); // string
+ s->c.fstream.direction=vpop(); // dir
s->c.fstream.plist=NIL;
return(s);}
@@ -273,18 +276,19 @@ register pointer in,out;
if (!isstream(in) || !isstream(out)) error(E_STREAM);
vpush(in); vpush(out);
ios=allocobj(IOSTREAM, iostream, iostreamcp.cix);
- ios->c.iostream.out=out;
- ios->c.iostream.in=in;
+ ios->c.iostream.out=vpop(); // out
+ ios->c.iostream.in=vpop(); // in
ios->c.iostream.plist=NIL;
- ctx->vsp -= 2;
return(ios);}
-pointer makecode(mod,f,ftype)
-register pointer mod,ftype;
+pointer makecode(ctx,mod,f,ftype,name)
+register context *ctx;
+register pointer mod,ftype,name;
pointer (*f)();
/*actually, f is a pointer to a function returning a pointer*/
{ register pointer cd;
eusinteger_t fentaddr;
+ vpush(mod); vpush(ftype); vpush(name);
cd=allocobj(CODE, code, codecp.cix);
cd->c.code.codevec=mod->c.code.codevec;
cd->c.code.quotevec=mod->c.code.quotevec;
@@ -294,6 +298,8 @@ pointer (*f)();
#if ARM
cd->c.code.entry2=makeint(((eusinteger_t)f)&0x3);
#endif
+ if (name!=NULL) putprop(ctx,cd,name,K_NAME);
+ ctx->vsp-=3;
return(cd);}
@@ -380,19 +386,21 @@ int tag;
extern pointer makeobject();
/* make metaclass cell */
- vpush(vars); vpush(types);
+ vpush(name); vpush(superobj); vpush(vars);
+ vpush(types); vpush(forwards); vpush(metaclass);
if (metaclass && isclass(metaclass)) class=makeobject(metaclass);
else {
if (tag==0)
class=allocobj(METACLASS, _class, metaclasscp.cix);
else
- class=allocobj(VECCLASS, vecclass, vecclasscp.cix);}
- class->c.cls.name=name;
- class->c.cls.super=superobj;
+ class=allocobj(VECCLASS, vecclass, vecclasscp.cix);}
+ vpop(); // metaclass
+ class->c.cls.forwards=vpop(); // forwards
+ class->c.cls.types=vpop(); // types
+ class->c.cls.vars=vpop(); // vars
+ class->c.cls.super=vpop(); // superobj
+ class->c.cls.name=vpop(); // name
class->c.cls.methods=NIL;
- class->c.cls.vars=vars;
- class->c.cls.types=types;
- class->c.cls.forwards=forwards;
class->c.cls.plist=NIL;
if (tag) { /*vector type class*/
class->c.vcls.elmtype=makeint(tag);
@@ -401,7 +409,6 @@ int tag;
/* name->c.sym.vtype=V_SPECIAL; */
name->c.sym.vtype=V_GLOBAL;
enterclass(class); /*determine cix and fill it in the cix slot*/
- vpop(); vpop();
return(class); }
pointer makeobject(class)
@@ -491,7 +498,7 @@ int size;
elmtypeof(cvec)=ELM_BYTE;
vpush(cvec);
mod=allocobj(LDMODULE, ldmodule, ldmodulecp.cix);
- mod->c.ldmod.codevec=vpop();
+ mod->c.ldmod.codevec=vpop(); // cvec
mod->c.ldmod.quotevec=NIL;
mod->c.ldmod.entry=NIL;
#if ARM
@@ -503,8 +510,12 @@ int size;
mod->c.ldmod.handle=NIL;
return(mod);}
-pointer makeclosure(code,quote,f,e0,e1,e2)
-pointer code,quote,e0,*e1,*e2;
+// makeclosure() is generated by the compiler and
+// exclusively used in compiled code
+// stack management is a responsability of the caller,
+// which is also currently generated by the compiler
+pointer makeclosure(code,quote,f,e0,e1)
+pointer code,quote,e0,e1;
pointer (*f)();
{ register pointer clo;
clo=allocobj(CLOSURE, closure, closurecp.cix);
@@ -517,34 +528,88 @@ pointer (*f)();
#endif
clo->c.clo.env0=e0;
clo->c.clo.env1=e1; /*makeint((int)e1>>2);*/
- clo->c.clo.env2=e2; /*makeint((int)e2>>2);*/
return(clo);}
pointer makereadtable(ctx)
register context *ctx;
-{ pointer rdtable,rdsyntax,rdmacro,rddispatch;
- vpush((rdsyntax=makebuffer(256)));
- vpush((rdmacro=makevector(C_VECTOR,256)));
- rddispatch=makevector(C_VECTOR,256);
+{ pointer rdtable;
+ vpush(makebuffer(256)); // rdsyntax
+ vpush(makevector(C_VECTOR,256)); // rdmacro
+ vpush(makevector(C_VECTOR,256)); // rddispatch
rdtable=allocobj(READTABLE, readtable, readtablecp.cix);
- vpush(rdtable);
- rdtable->c.rdtab.dispatch=rddispatch;
- rdtable->c.rdtab.macro=rdmacro;
- rdtable->c.rdtab.syntax=rdsyntax;
+ rdtable->c.rdtab.dispatch=vpop(); // rddispatch
+ rdtable->c.rdtab.macro=vpop(); // rdmacro
+ rdtable->c.rdtab.syntax=vpop(); // rdsyntax
rdtable->c.rdtab.plist=NIL;
- ctx->vsp -= 3;
return(rdtable);}
-pointer makelabref(n,v,nxt)
+pointer makelabref(ctx,n,v,nxt)
+register context *ctx;
pointer n,v,nxt;
{ pointer l;
+ vpush(n); vpush(v); vpush(nxt);
l=alloc(wordsizeof(struct labref), ELM_FIXED, labrefcp.cix,
wordsizeof(struct labref));
- l->c.lab.label=n;
- l->c.lab.value=v;
- l->c.lab.next=nxt;
+ l->c.lab.next=vpop(); // nxt
+ l->c.lab.value=vpop(); // v
+ l->c.lab.label=vpop(); // n
l->c.lab.unsolved=NIL;
return(l);}
+
+pointer makebindframe(ctx,sym,val,nxt)
+register context *ctx;
+pointer sym,val,nxt;
+{ pointer bf;
+ vpush(sym), vpush(val), vpush(nxt);
+ bf=makeobject(C_BINDFRAME);
+ // if (nxt==NULL) nxt=NIL;
+ bf->c.bfp.next=vpop(); // nxt
+ bf->c.bfp.val=vpop(); // val
+ bf->c.bfp.sym=vpop(); // sym
+ return(bf);}
+
+pointer makeflet(ctx,nm,def,scp,nxt)
+register context *ctx;
+pointer nm,def,scp,nxt;
+{ pointer p,ff;
+ vpush(nm); vpush(def); vpush(scp); vpush(nxt);
+ // fletframe scope
+ if (scp==NULL)
+ p=cons(ctx,makeint(0),def);
+ else
+ p=cons(ctx,scp,def);
+ // bindframe scope
+ if (ctx->bindfp==NULL)
+ p=cons(ctx,makeint(0),p);
+ else
+ p=cons(ctx,ctx->bindfp,p);
+ p=cons(ctx,nm,p); // name
+ p=cons(ctx,LAMCLOSURE,p);
+ vpush(p);
+ ff=makeobject(C_FLETFRAME);
+ ff->c.ffp.fclosure=vpop(); // p
+ ff->c.ffp.next=vpop(); // nxt
+ vpop(); // scp
+ vpop(); // def
+ ff->c.ffp.name=vpop(); // nm
+ vpush(ff);
+ ctx->fletfp=ff;
+ return(ff);}
+
+pointer makemacrolet(ctx,nm,def,nxt)
+register context *ctx;
+pointer nm,def,nxt;
+{ pointer p,ff;
+ vpush(nm); vpush(nxt);
+ p=cons(ctx,MACRO,def);
+ vpush(p);
+ ff=makeobject(C_FLETFRAME);
+ ff->c.ffp.fclosure=vpop(); // p
+ ff->c.ffp.next=vpop(); // nxt
+ ff->c.ffp.name=vpop(); // nm
+ vpush(ff);
+ ctx->fletfp=ff;
+ return(ff);}
/****************************************************************
/* extended numbers
@@ -640,7 +705,7 @@ pointer mod,pkg;
pointer (*f)();
{ pointer sym;
sym=intern(ctx,name,strlen(name),pkg);
- pointer_update(sym->c.sym.spefunc,makecode(mod,f,SUBR_FUNCTION));
+ pointer_update(sym->c.sym.spefunc,makecode(ctx,mod,f,SUBR_FUNCTION,sym));
return(sym);}
pointer defmacro(ctx,name,mod,f)
@@ -651,7 +716,7 @@ pointer (*f)();
{ register pointer sym,pkg;
pkg=Spevalof(PACKAGE);
sym=intern(ctx,name,strlen(name),pkg);
- pointer_update(sym->c.sym.spefunc,makecode(mod,f,SUBR_MACRO));
+ pointer_update(sym->c.sym.spefunc,makecode(ctx,mod,f,SUBR_MACRO,sym));
return(sym);}
#if Solaris2 || PTHREAD
@@ -665,7 +730,7 @@ int special_index()
mutex_lock(&spex_lock);
x= next_special_index++;
mutex_unlock(&spex_lock);
- if (x>=MAX_SPECIALS) { error(E_USER,(pointer)"too many special variables >=512"); }
+ if (x>=MAX_SPECIALS) { error(E_PROGRAM_ERROR,(pointer)"too many special variables >=512"); }
return(x);}
#else
int next_special_index=3;
@@ -674,7 +739,7 @@ int special_index()
{ int x;
x= next_special_index++;
- if (x>=MAX_SPECIALS) { error(E_USER,(pointer)"too many special variables >=512"); }
+ if (x>=MAX_SPECIALS) { error(E_PROGRAM_ERROR,(pointer)"too many special variables >=512"); }
return(x);}
#endif
@@ -687,7 +752,7 @@ pointer (*f)();
{ register pointer sym,pkg;
pkg=Spevalof(PACKAGE);
sym=intern(ctx,name,strlen(name),pkg);
- pointer_update(sym->c.sym.spefunc,makecode(mod,f,SUBR_SPECIAL));
+ pointer_update(sym->c.sym.spefunc,makecode(ctx,mod,f,SUBR_SPECIAL,sym));
return(sym);}
pointer defconst(ctx,name,val,pkg)
@@ -747,7 +812,7 @@ pointer compfun(ctx,sym,mod,entry,doc)
register context *ctx;
register pointer sym,mod,doc;
pointer (*entry)();
-{ pointer_update(sym->c.sym.spefunc,makecode(mod,entry,SUBR_FUNCTION));
+{ pointer_update(sym->c.sym.spefunc,makecode(ctx,mod,entry,SUBR_FUNCTION,sym));
if (doc!=NIL) putprop(ctx,sym,doc,K_FUNCTION_DOCUMENTATION);
return(sym);}
@@ -755,7 +820,7 @@ pointer compmacro(ctx,sym,mod,entry,doc)
register context *ctx;
register pointer sym,mod,doc;
pointer (* entry)();
-{ pointer_update(sym->c.sym.spefunc,makecode(mod,entry,SUBR_MACRO));
+{ pointer_update(sym->c.sym.spefunc,makecode(ctx,mod,entry,SUBR_MACRO,sym));
if (doc!=NIL) putprop(ctx,sym, doc, K_FUNCTION_DOCUMENTATION);
return(sym);}
@@ -779,25 +844,6 @@ struct blockframe *link;
ctx->blkfp=blk;
return(blk);}
-struct fletframe *makeflet(ctx,nm,def,scp,link)
-register context *ctx;
-pointer nm,def;
-struct fletframe *scp,*link;
-{ register struct fletframe *ffp=(struct fletframe *)(ctx->vsp);
- register pointer p;
- size_t i;
- for (i=0; iname=nm;
- p=cons(ctx,makeint(hide_ptr((pointer)scp)),def);
- p=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),p);
- p=cons(ctx,nm,p);
- ffp->fclosure=cons(ctx,LAMCLOSURE,p);
- ffp->scope=scp;
- ffp->lexlink=link; ffp->dynlink=ctx->fletfp; /*dynlink is not used*/
- ctx->fletfp=ffp;
- return(ffp);}
-
void mkcatchframe(ctx,lab,jbuf)
context *ctx;
pointer lab;
@@ -859,9 +905,7 @@ int bs_size;
cntx->blkfp=NULL;
cntx->protfp=NULL;
cntx->fletfp=NULL;
- cntx->newfletfp=NULL;
cntx->lastalloc=NULL;
- cntx->errhandler=NULL;
cntx->alloc_big_count=0;
cntx->alloc_small_count=0;
cntx->special_bind_count=0;
diff --git a/lisp/c/makes.new.c b/lisp/c/makes.new.c
deleted file mode 100644
index 257bd2acb..000000000
--- a/lisp/c/makes.new.c
+++ /dev/null
@@ -1,925 +0,0 @@
-/****************************************************************/
-/* make eulisp objects
-/* Copyright Toshihiro MATSUI, ETL, 1987
-/****************************************************************/
-static char *rcsid="@(#)$Id$";
-
-#if Solaris2
-#include
-#include
-#include
-#endif
-
-#include "eus.h"
-
-#if 0 /* move to eus.h */
-#define nextbuddy(p) ((bpointer)((eusinteger_t)p+(buddysize[p->h.bix]*sizeof(pointer))))
-#endif
-
-extern pointer LAMCLOSURE, K_FUNCTION_DOCUMENTATION;
-
-/****************************************************************/
-/* boxing and unboxing
-/****************************************************************/
-#if vax
-float ckfltval(p)
-register int p;
-{ numunion nu;
- if (isflt(p)) {
- nu.ival = p & 0xfffffffc;
-#if vax
- { register short s;
- s=nu.sval.low; nu.sval.low=nu.sval.high; nu.sval.high=s;}
-#endif
- return(nu.fval);}
- else if (isint(p)) { nu.fval=intval(p); return(nu.fval);} /*coerce to float*/
- else error(E_NONUMBER);}
-
-float fltval(p)
-int p;
-{ numunion nu;
- nu.ival= p & 0xfffffffc;
-#if vax
- { register short s;
- s=nu.sval.low; nu.sval.low=nu.sval.high; nu.sval.high=s;}
-#endif
- return(nu.fval);}
-
-pointer makeflt(d)
-double d;
-{ numunion u;
- u.fval=d; /*double to short float*/
-#if vax
- { register short s;
- s=u.sval.low; /*swap upper and lower short*/
- u.sval.low=u.sval.high;
- u.sval.high=s;}
-#endif
- return((pointer)((u.ival & 0xfffffffc) | 1));}
-#endif
-
-pointer Getstring(s)
-register pointer s;
-{ if (issymbol(s)) s=s->c.sym.pname;
- if (!isstring(s)) error(E_NOSTRING);
- return(s);}
-
-byte *get_string(s)
-register pointer s;
-{ if (isstring(s)) return(s->c.str.chars);
- if (issymbol(s)) return(s->c.sym.pname->c.str.chars);
- else error(E_NOSTRING);}
-
-/****************************************************************/
-/* cons & list
-/****************************************************************/
-
-#define allocobj(class,builtin,cid) \
- ((class)? \
- alloc(vecsize(speval(class)->c.cls.vars), ELM_FIXED, \
- intval(speval(class)->c.cls.cix), \
- wordsizeof(struct builtin)): \
- alloc(wordsizeof(struct builtin), ELM_FIXED, cid, \
- wordsizeof(struct builtin)))
-
-pointer rawcons(ctx,a,d)
-register context *ctx;
-register pointer a,d;
-{ register pointer c;
- vpush(a); vpush(d);
- c = alloc(wordsizeof(struct cons), ELM_FIXED, conscp.cix,
- wordsizeof(struct cons));
- c->c.cons.cdr=vpop();
- c->c.cons.car=vpop();
- return(c);}
-
-pointer cons(ctx,a,d)
-register context *ctx;
-register pointer a,d;
-{
- register pointer c;
- register bpointer b;
- /*
- if ((speval(QCONS)==C_CONS) && (b=buddy[1].bp)) {
- b->h.elmtype=ELM_FIXED;
- buddy[1].bp=b->b.nextbcell;
- freeheap -= 3;
- alloccount[1]++;
- c=makepointer(b);
- cixof(c)=conscp.cix;}
- else*/
- {
- vpush(a); vpush(d); /*protect args from garbage collection*/
- c=alloc(vecsize(speval(QCONS)->c.cls.vars), ELM_FIXED,
- intval(speval(QCONS)->c.cls.cix),
- wordsizeof(struct cons));
- ctx->vsp-=2; }
- c->c.cons.car=a; c->c.cons.cdr=d;
- return(c);}
-
-pointer stackrawlist(ctx,n) /*make a list out of elements pushed on vstack*/
-register context *ctx;
-register int n;
-{ register pointer r=NIL, *fsp=ctx->vsp;
- while (n-->0) r=rawcons(ctx,*--fsp,r);
- ctx->vsp=fsp;
- return(r);}
-
-pointer stacknlist(ctx,n) /*make a list out of elements pushed on vstack*/
-register context *ctx;
-register int n;
-{ register pointer r=NIL, *fsp=ctx->vsp;
- while (n-->0) r=cons(ctx,*--fsp,r);
- ctx->vsp=fsp;
- return(r);}
-
-pointer makebuffer(size)
-register int size;
-{ register pointer p;
- p = alloc((size+2*sizeof(eusinteger_t))>>WORDSHIFT, ELM_CHAR, stringcp.cix, (size+2*sizeof(eusinteger_t))>>WORDSHIFT);
- p->c.str.length=makeint(size);
- return(p);}
-
-pointer makestring(s,l)
-register char *s;
-register int l;
-{ register pointer p;
- p=alloc((l+2*sizeof(eusinteger_t))>>WORDSHIFT, ELM_CHAR, stringcp.cix, (l+2*sizeof(eusinteger_t))>>WORDSHIFT );
- p->c.str.length=makeint(l);
- p->c.ivec.iv[l/sizeof(long)]=0; /*terminator*/
- memcpy((void *)p->c.str.chars, (void *)s, l);
- return(p);}
-
-pointer make_foreign_string(eusinteger_t addr, int size)
-{ register pointer p;
- p=alloc(2, ELM_FOREIGN, stringcp.cix, 2);
- p->c.str.length=makeint(size);
- p->c.ivec.iv[0]=addr;
- return(p);}
-
-pointer makesymbol(ctx,str,leng,home)
-register context *ctx;
-char *str;
-int leng;
-pointer home;
-{ register pointer sym;
- int cid;
- vpush(makestring(str,leng));
- sym=allocobj(SYMBOL,symbol,symbolcp.cix);
- sym->c.sym.speval=sym->c.sym.spefunc=UNBOUND;
- sym->c.sym.vtype=V_VARIABLE;
- sym->c.sym.homepkg=home;
- sym->c.sym.plist=NIL;
- sym->c.sym.pname=vpop();
- return(sym);}
-
-pointer searchpkg(token,leng)
-byte *token;
-int leng;
-{ pointer pkg,pkgs,names;
- pkgs=pkglist;
- while (pkgs && islist(pkgs)) {
- pkg=ccar(pkgs); pkgs=ccdr(pkgs);
- names=pkg->c.pkg.names;
- while (islist(names))
- if (strlength(ccar(names))==leng &&
- !memcmp((char *)ccar(names)->c.str.chars, (char *)token, leng)) return(pkg);
- else names=ccdr(names);}
- return(NULL);}
-
-pointer findpkg(pkgname)
-register pointer pkgname; /*string or symbol*/
-{ register pointer pkg,pkgs,names;
- if (ispackage(pkgname)) return(pkgname);
- pkgname=Getstring(pkgname);
- return(searchpkg(pkgname->c.str.chars,strlength(pkgname)));}
-
-pointer makepkg(ctx,namestr,nicks,uses)
-register context *ctx;
-register pointer namestr,nicks,uses;
-{ register pointer pkg,symvec,pkgs,names,p;
- register int i;
- /*check pkg name collision*/
- namestr=Getstring(namestr);
- if (findpkg(namestr)) error(E_PKGNAME,namestr);
- vpush(namestr); vpush(nicks); vpush(uses);
- i=0;
- while (islist(nicks)) {
- if (findpkg(ccar(nicks))) error(E_PKGNAME,ccar(nicks));
- vpush(Getstring(ccar(nicks))); i++;
- nicks=ccdr(nicks);}
- nicks=stackrawlist(ctx,i); /*list up package nicknames*/
- i=0;
- while (islist(uses)) {
- if (p=findpkg(ccar(uses))) { vpush(p); i++; uses=ccdr(uses);}
- else error(E_PKGNAME,ccar(uses));}
- uses=stackrawlist(ctx,i);
- pkg=allocobj(PKGCLASS,package, packagecp.cix);
- pkg->c.pkg.names=pkg->c.pkg.symvector=pkg->c.pkg.intsymvector=NULL;
- pkg->c.pkg.symcount=pkg->c.pkg.intsymcount=makeint(0);
- pkg->c.pkg.use=uses;
- pkg->c.pkg.plist=NIL;
- pkg->c.pkg.shadows=NIL;
- pkg->c.pkg.used_by=NIL;
- vpush(pkg);
- pkg->c.pkg.names=rawcons(ctx,namestr,nicks);
- symvec=makevector(C_VECTOR,SYMBOLHASH);
- for (i=0; ic.vec.v[i]=makeint(0);
- pkg->c.pkg.symvector=symvec;
- symvec=makevector(C_VECTOR,SYMBOLHASH);
- for (i=0; ic.vec.v[i]=makeint(0);
- pkg->c.pkg.intsymvector=symvec;
- pkglist=rawcons(ctx,pkg,pkglist);
- ctx->lastalloc=pkg;
- ctx->vsp -= 4;
- return(pkg);}
-
-pointer mkstream(ctx,dir,string)
-register context *ctx;
-pointer dir,string;
-{ register pointer s;
- vpush(string);
- s=allocobj(STREAM, stream, streamcp.cix);
- s->c.stream.direction=dir;
- s->c.stream.count=s->c.stream.tail=makeint(0);
- s->c.stream.buffer=vpop();
- s->c.stream.plist=NIL;
- return(s);}
-
-pointer mkfilestream(ctx,dir,string,fno,fname)
-register context *ctx;
-pointer dir,string,fname;
-int fno;
-{ register pointer s;
- if (dir!=K_IN && dir!=K_OUT) error(E_IODIRECTION);
- vpush(string); vpush(fname);
- s=allocobj(FILESTREAM, filestream, filestreamcp.cix);
- s->c.fstream.direction=dir;
- s->c.fstream.count=s->c.fstream.tail=makeint(0);
- s->c.fstream.fname=vpop();
- s->c.fstream.buffer=vpop();
- s->c.fstream.fd=makeint(fno);
- s->c.fstream.plist=NIL;
- return(s);}
-
-pointer mkiostream(ctx,in,out)
-register context *ctx;
-register pointer in,out;
-{ register pointer ios;
- if (!isstream(in) || !isstream(out)) error(E_STREAM);
- vpush(in); vpush(out);
- ios=allocobj(IOSTREAM, iostream, iostreamcp.cix);
- ios->c.iostream.out=out;
- ios->c.iostream.in=in;
- ios->c.iostream.plist=NIL;
- ctx->vsp -= 2;
- return(ios);}
-
-pointer makecode(mod,f,ftype)
-register pointer mod,ftype;
-pointer (*f)();
-/*actually, f is a pointer to a function returning a pointer*/
-{ register pointer cd;
- eusinteger_t fentaddr;
- cd=allocobj(CODE, code, codecp.cix);
- cd->c.code.codevec=mod->c.code.codevec;
- cd->c.code.quotevec=mod->c.code.quotevec;
- cd->c.code.subrtype=ftype;
- fentaddr= (eusinteger_t)f>>2;
- cd->c.code.entry=makeint(fentaddr);
- return(cd);}
-
-
-/*
-/* for DEFCLASS and INSTANTIATE
-*/
-
-bumpcix(m,n)
-int m,n;
-{ pointer super;
- if (classtab[m].subcixc.cls.super;
- if (isclass(super)) bumpcix(intval(super->c.cls.cix),n);}}
-
-recixobj(newcix)
-register int newcix;
-{ register struct chunk *cp;
- register bpointer p,tail;
- register int s;
-#if defined(BIX_DEBUG) || defined(DEBUG_COUNT)
- static int count = 0;
-
- count++;
-#endif
-
- for (cp=chunklist; cp!=0; cp=cp->nextchunk) {
- s=buddysize[cp->chunkbix];
- p= &cp->rootcell;
- tail=(bpointer)((eusinteger_t)p+(s<h.cix>=newcix) p->h.cix++;
-#ifdef BIX_DEBUG
- printf( "recixobj:%d:p=0x%lx, bix = %d\n",
- count, p, p->h.bix );
-#endif
- p=nextbuddy(p);}
- } }
-
-resetcix(class,p)
-pointer class;
-cixpair *p;
-{ if (class) {
- p->cix=intval(class->c.cls.cix);
- p->sub=classtab[p->cix].subcix;} }
-
-enterclass(classobj)
-pointer classobj;
-{ pointer super;
- register int i,newcix,temp,supercix;
-
- if (nextcix>=MAXCLASS) error(E_CLASSOVER);
- super= /*spevalof*/ (classobj->c.cls.super);
- if (isclass(super)) {
- supercix=intval(super->c.cls.cix);
- newcix=classtab[supercix].subcix+1;
- for (i=nextcix-1; i>=newcix; i--) {
- /*reconfigure class hierarchy*/
- bumpcix(i,i+1);
- classtab[i+1]=classtab[i]; /*bump classtab entry*/
- temp=intval(classtab[i].def->c.cls.cix);
- classtab[i].def->c.cls.cix=makeint(temp+1); }
- bumpcix(supercix,newcix);
- /*scan chunks and bumps object's cix which is greater than newcix*/
- if (newcixc.cls.cix=makeint(newcix);
- classtab[newcix].def=classobj;
- classtab[newcix].subcix=newcix;
- nextcix++; }
-
-pointer makeclass(ctx,name,superobj,vars,types,forwards,tag,metaclass)
-register context *ctx;
-pointer name,superobj,vars,types,metaclass,forwards;
-int tag;
-{ pointer class;
- extern pointer makeobject();
-
- /* make metaclass cell */
- vpush(vars); vpush(types);
- if (metaclass && isclass(metaclass)) class=makeobject(metaclass);
- else {
- if (tag==0)
- class=allocobj(METACLASS, _class, metaclasscp.cix);
- else
- class=allocobj(VECCLASS, vecclass, vecclasscp.cix);}
- class->c.cls.name=name;
- class->c.cls.super=superobj;
- class->c.cls.methods=NIL;
- class->c.cls.vars=vars;
- class->c.cls.types=types;
- class->c.cls.forwards=forwards;
- class->c.cls.plist=NIL;
- if (tag) { /*vector type class*/
- class->c.vcls.elmtype=makeint(tag);
- class->c.vcls.size=makeint(-1);}
- name->c.sym.speval=class;
-/* name->c.sym.vtype=V_SPECIAL; */
- name->c.sym.vtype=V_GLOBAL;
- enterclass(class); /*determine cix and fill it in the cix slot*/
- vpop(); vpop();
- return(class); }
-
-pointer makeobject(class)
-register pointer class;
-{ register pointer obj,*v;
- register int size;
- size=vecsize(class->c.cls.vars);
- obj=alloc(size, ELM_FIXED, intval(class->c.cls.cix), size);
- v=obj->c.obj.iv;
- while (size>0) v[--size]=NIL;
- return(obj);}
-
-pointer makevector(vclass,size)
-register pointer vclass;
-register int size;
-{ register pointer v,init,*vv;
- register int n,etype;
-
- etype=intval(vclass->c.vcls.elmtype);
- switch(etype) {
- case ELM_BIT: n=(size+WORD_SIZE-1)/WORD_SIZE; init=0; break;
- case ELM_CHAR:
- case ELM_BYTE: n=(size+sizeof(eusinteger_t))/sizeof(eusinteger_t); init=0; break;
- case ELM_FLOAT: n=size; init=(pointer)0; break;
- case ELM_INT: n=size; init=0; break;
- case ELM_FOREIGN: n=1; init=0; break;
- default: n=size; init=NIL;}
- v=alloc(n+1,etype, intval(vclass->c.vcls.cix),n+1);
- v->c.vec.size=makeint(size);
- vv=v->c.vec.v;
- while (--n>=0) vv[n]=init;
- return(v);}
-
-pointer makefvector(s)
-register int s;
-{ register pointer v;
- register bpointer b;
- v=alloc(s+1,ELM_FLOAT, fltvectorcp.cix,s+1);
- v->c.vec.size=makeint(s);
- return(v);}
-
-pointer defvector(ctx,name,super,elm,size) /*define vector class*/
-register context *ctx;
-char *name;
-pointer super;
-int elm,size;
-{ pointer classsym,class,varvector,typevector,forwardvector;
- int i;
- classsym=intern(ctx,name,strlen(name),lisppkg);
- varvector=makevector(C_VECTOR,1);
- vpush(varvector);
- typevector=makevector(C_VECTOR,1);
- typevector->c.vec.v[0]=QINTEGER;
- vpush(typevector);
- forwardvector=makevector(C_VECTOR,1);
- forwardvector->c.vec.v[0]=NIL;
- vpush(forwardvector);
- varvector->c.vec.v[0]=intern(ctx,"LENGTH",6,lisppkg);
- class=makeclass(ctx,classsym,super,varvector,typevector,forwardvector,elm,0); /*!!!*/
- ctx->vsp -= 3;
- return(classsym);}
-
-pointer makematrix(ctx,row,column)
-register context *ctx;
-int row,column;
-{ register pointer v,m;
- register int i;
- v=makefvector(row*column);
- vpush(v);
- m=allocobj(ARRAY, arrayheader, arraycp.cix);
- m->c.ary.entity=v;
- m->c.ary.fillpointer=NIL;
- m->c.ary.rank=makeint(2);
- m->c.ary.offset=makeint(0);
- m->c.ary.dim[0]=makeint(row);
- m->c.ary.dim[1]=makeint(column);
- m->c.ary.plist=NIL;
- for (i=2; ic.ary.dim[i]=NIL;
- vpop();
- return(m);}
-
-pointer makemodule(ctx,size) /*size in bytes*/
-register context *ctx;
-int size;
-{ register pointer mod,cvec;
- cvec=makebuffer(size);
- elmtypeof(cvec)=ELM_BYTE;
- vpush(cvec);
- mod=allocobj(LDMODULE, ldmodule, ldmodulecp.cix);
- mod->c.ldmod.codevec=vpop();
- mod->c.ldmod.quotevec=NIL;
- mod->c.ldmod.entry=NIL;
- mod->c.ldmod.subrtype=NIL;
- mod->c.ldmod.symtab=NIL;
- mod->c.ldmod.objname=NIL;
- mod->c.ldmod.handle=NIL;
- return(mod);}
-
-pointer makeclosure(code,quote,f,e0,e1,e2)
-pointer code,quote,e0,*e1,*e2;
-pointer (*f)();
-{ register pointer clo;
- clo=allocobj(CLOSURE, closure, closurecp.cix);
- clo->c.clo.codevec=code;
- clo->c.clo.quotevec=quote;
- clo->c.clo.subrtype=SUBR_FUNCTION;
- clo->c.clo.entry=makeint((eusinteger_t)f>>2);
- clo->c.clo.env0=e0;
- clo->c.clo.env1=e1; /*makeint((int)e1>>2);*/
- clo->c.clo.env2=e2; /*makeint((int)e2>>2);*/
- return(clo);}
-
-pointer makereadtable(ctx)
-register context *ctx;
-{ pointer rdtable,rdsyntax,rdmacro,rddispatch;
- vpush((rdsyntax=makebuffer(256)));
- vpush((rdmacro=makevector(C_VECTOR,256)));
- rddispatch=makevector(C_VECTOR,256);
- rdtable=allocobj(READTABLE, readtable, readtablecp.cix);
- vpush(rdtable);
- rdtable->c.rdtab.dispatch=rddispatch;
- rdtable->c.rdtab.macro=rdmacro;
- rdtable->c.rdtab.syntax=rdsyntax;
- rdtable->c.rdtab.plist=NIL;
- ctx->vsp -= 3;
- return(rdtable);}
-
-pointer makelabref(n,v,nxt)
-pointer n,v,nxt;
-{ pointer l;
- l=alloc(wordsizeof(struct labref), ELM_FIXED, labrefcp.cix,
- wordsizeof(struct labref));
- l->c.lab.label=n;
- l->c.lab.value=v;
- l->c.lab.next=nxt;
- l->c.lab.unsolved=NIL;
- return(l);}
-
-/****************************************************************
-/* extended numbers
-/****************************************************************/
-pointer makeratio(num, denom)
-int num, denom;
-{ pointer r;
- r=allocobj(RATIO, ratio, ratiocp.cix);
- r->c.ratio.numerator=makeint(num);
- r->c.ratio.denominator=makeint(denom);
- /* printf("ratio cid= %d r=0x%x\n", ratiocp.cix, r); */
- return(r);}
-
-pointer makebig(n)
-int n;
-{ register context *ctx=euscontexts[thr_self()];
- register pointer p,v;
- v=makevector(C_INTVECTOR, n);
- vpush(v);
- p=allocobj(BIGNUM, bignum, bignumcp.cix);
- p->c.bgnm.size=makeint(n);
- p->c.bgnm.bv=v;
- vpop();
- return(p);}
-
-pointer makebig1(x)
-long x;
-{ register context *ctx=euscontexts[thr_self()];
- register pointer p,v;
-
- v=makevector(C_INTVECTOR, 1);
- vpush(v);
- p=allocobj(BIGNUM, bignum, bignumcp.cix);
- p->c.bgnm.size=makeint(1);
- p->c.bgnm.bv=v;
- v->c.ivec.iv[0]=x;
- vpop();
- return(p);}
-
-pointer makebig2(hi,lo)
-long hi, lo;
-{ register context *ctx=euscontexts[thr_self()];
- register pointer p,v;
-
- v=makevector(C_INTVECTOR, 2);
- vpush(v);
- p=allocobj(BIGNUM, bignum, bignumcp.cix);
- p->c.bgnm.size=makeint(2);
- p->c.bgnm.bv=v;
- v->c.ivec.iv[0]=lo;
- v->c.ivec.iv[1]=hi;
- vpop();
- return(p);}
-
-
-/****************************************************************/
-/* defines
-/****************************************************************/
-
-pointer defun(ctx,name,mod,f)
-register context *ctx;
-char *name;
-pointer mod;
-pointer (*f)();
-{ register pointer sym,pkg;
-#if defined(DEFUN_DEBUG) || defined(DEBUG_COUNT)
- static int count=0;
-
- count++;
-#endif
-#ifdef DEFUN_DEBUG
- printf( "defun:%d:%s:", count, name );
-#endif
-
- pkg=Spevalof(PACKAGE);
- sym=intern(ctx,name,strlen(name),pkg);
- sym->c.sym.spefunc=makecode(mod,f,SUBR_FUNCTION);
-#ifdef DEFUN_DEBUG
- printf( "0x%lx\n", sym->c.sym.spefunc->c.code.entry );
-#endif
- return(sym);}
-
-pointer defunpkg(ctx,name,mod,f,pkg)
-register context *ctx;
-char *name;
-pointer mod,pkg;
-pointer (*f)();
-{ pointer sym;
- sym=intern(ctx,name,strlen(name),pkg);
- sym->c.sym.spefunc=makecode(mod,f,SUBR_FUNCTION);
- return(sym);}
-
-pointer defmacro(ctx,name,mod,f)
-register context *ctx;
-char *name;
-pointer mod;
-pointer (*f)();
-{ register pointer sym,pkg;
- pkg=Spevalof(PACKAGE);
- sym=intern(ctx,name,strlen(name),pkg);
- sym->c.sym.spefunc=makecode(mod,f,SUBR_MACRO);
- return(sym);}
-
-#if Solaris2
-int next_special_index=3;
-static mutex_t spex_lock;
-
-int special_index()
-{ int x;
-
- if (next_special_index==3) mutex_init(&spex_lock,USYNC_THREAD,NULL);
- mutex_lock(&spex_lock);
- x= next_special_index++;
- mutex_unlock(&spex_lock);
- if (x>=MAX_SPECIALS) { error(E_USER,(pointer)"too many special variables >=256"); }
- return(x);}
-#else
-int next_special_index=3;
-
-int special_index()
-{ int x;
-
- x= next_special_index++;
- if (x>=MAX_SPECIALS) { error(E_USER,(pointer)"too many special variables >=256"); }
-
- return(x);}
-#endif
-
-pointer defspecial(ctx,name,mod,f) /*define special form*/
-register context *ctx;
-char *name;
-pointer mod;
-pointer (*f)();
-{ register pointer sym,pkg;
- pkg=Spevalof(PACKAGE);
- sym=intern(ctx,name,strlen(name),pkg);
- sym->c.sym.spefunc=makecode(mod,f,SUBR_SPECIAL);
- return(sym);}
-
-pointer defconst(ctx,name,val,pkg)
-register context *ctx;
-char *name;
-pointer val,pkg;
-{ register pointer sym;
- vpush(val);
- sym=intern(ctx,name,strlen(name),pkg);
- sym->c.sym.vtype=V_CONSTANT;
- sym->c.sym.speval=vpop();
- return(sym);}
-
-pointer defvar(ctx,name,val,pkg)
-register context *ctx;
-char *name;
-pointer val,pkg;
-{ register pointer sym;
- int x;
- vpush(val);
- sym=intern(ctx,name,strlen(name),pkg);
- sym->c.sym.vtype=V_GLOBAL;
- sym->c.sym.speval=vpop();
- return(sym);}
-
-pointer deflocal(ctx,name,val,pkg)
-register context *ctx;
-char *name;
-pointer val,pkg;
-{ register pointer sym;
- int x;
- vpush(val);
- sym=intern(ctx,name,strlen(name),pkg);
- x=special_index();
- sym->c.sym.vtype=makeint(x);
- /*sym->c.sym.speval=vpop();*/
- /* put the same value in the global symbol-value
- and in the thread's special binding table */
- ctx->specials->c.vec.v[x]=vpop();
- sym->c.sym.speval=val;
- return(sym);}
-
-pointer defkeyword(ctx,name)
-register context *ctx;
-char *name;
-{ register pointer sym;
- sym=intern(ctx,name,strlen(name),keywordpkg);
- return(sym);}
-
-/*
-/* for making compiled function/macro
-*/
-
-extern pointer putprop();
-
-pointer compfun(ctx,sym,mod,entry,doc)
-register context *ctx;
-register pointer sym,mod,doc;
-pointer (*entry)();
-{ sym->c.sym.spefunc=makecode(mod,entry,SUBR_FUNCTION);
- if (doc!=NIL) putprop(ctx,sym,doc,K_FUNCTION_DOCUMENTATION);
- return(sym);}
-
-pointer compmacro(ctx,sym,mod,entry,doc)
-register context *ctx;
-register pointer sym,mod,doc;
-pointer (* entry)();
-{ sym->c.sym.spefunc=makecode(mod,entry,SUBR_MACRO);
- if (doc!=NIL) putprop(ctx,sym, doc, K_FUNCTION_DOCUMENTATION);
- return(sym);}
-
-/****************************************************************/
-/* stack frames
-/****************************************************************/
-
-struct blockframe *makeblock(ctx,kind,name,jbuf,link)
-register context *ctx;
-pointer kind,name;
-jmp_buf *jbuf;
-struct blockframe *link;
-{ register struct blockframe *blk=ctx->blkfp;
- *(ctx->vsp)=(pointer)ctx->blkfp; blk=(struct blockframe *)(ctx->vsp);
- (ctx->vsp) += wordsizeof(struct blockframe);
- blk->lexklink=link;
- blk->dynklink=ctx->blkfp;
- blk->kind=kind;
- blk->name=name;
- blk->jbp=jbuf;
- ctx->blkfp=blk;
- return(blk);}
-
-struct fletframe *makeflet(ctx,nm,def,scp,link)
-register context *ctx;
-pointer nm,def;
-struct fletframe *scp,*link;
-{ register struct fletframe *ffp=(struct fletframe *)(ctx->vsp);
- register pointer p;
- int i;
- for (i=0; iname=nm;
- p=cons(ctx,makeint(scp),def);
- p=cons(ctx,makeint(ctx->bindfp),p);
- p=cons(ctx,nm,p);
- ffp->fclosure=cons(ctx,LAMCLOSURE,p);
- ffp->scope=scp;
- ffp->lexlink=link; ffp->dynlink=ctx->fletfp; /*dynlink is not used*/
- ctx->fletfp=ffp;
- return(ffp);}
-
-void mkcatchframe(ctx,lab,jbuf)
-context *ctx;
-pointer lab;
-jmp_buf jbuf;
-{ struct catchframe *cfp;
- cfp=(struct catchframe *)ctx->vsp;
- cfp->nextcatch=ctx->catchfp;
- cfp->cf=ctx->callfp;
- cfp->bf=ctx->bindfp;
-/* cfp->blkf=blkfp; */
- cfp->jbp=(jmp_buf *)jbuf;
- cfp->label=lab;
- cfp->ff=ctx->fletfp;
- ctx->vsp += (sizeof(struct catchframe)/sizeof(pointer));
- ctx->catchfp=cfp;}
-
-/****************************************************************/
-/* new thread context
-/****************************************************************/
-extern context *mainctx;
-
-allocate_stack(ctx,n)
-context *ctx;
-register int n;
-{ register int i;
- if (ctx->stack) cfree(ctx->stack);
- n=max(1024,n);
-#if 0 /* ???? */
- i=(int)malloc((n+1)*sizeof(pointer));
- if (i==NULL) error(E_STACKOVER);
- ctx->stack=(pointer *)i;
-#else
- ctx->stack=(pointer *)malloc((n+1)*sizeof(pointer));
- if (i==NULL) error(E_STACKOVER);
-#endif
- ctx->stacklimit= &ctx->stack[n-100];
-#if STACK_DEBUG
- printf( "allocate_stack: 0x%lx -- 0x%lx\n", ctx->stack, ctx->stacklimit );
-#endif
- }
-
-context *makelispcontext(bs_size)
-int bs_size;
-{ pointer *stk, specialtab;
- context *cntx;
- int i;
- struct buddy_free *thrbuddy;
-
- cntx=(context *)malloc(sizeof(context));
- if (cntx==NULL) error(E_ALLOCATION);
- if (bs_size<4096) bs_size=4096;
- stk=(pointer *)malloc(sizeof(pointer) * bs_size);
- if (stk==NULL) error(E_ALLOCATION);
- cntx->stack=stk;
- cntx->vsp=stk;
- cntx->stacklimit = stk+bs_size-64;
-#if STACK_DEBUG
- printf( "makelispcontext: stack: 0x%lx -- 0x%lx\n", cntx->stack, cntx->stacklimit );
-#endif
- cntx->callfp=NULL;
- cntx->catchfp=NULL;
- cntx->bindfp=NULL;
- cntx->sbindfp=NULL;
- cntx->blkfp=NULL;
- cntx->protfp=NULL;
- cntx->fletfp=NULL;
- cntx->newfletfp=NULL;
- cntx->lastalloc=NULL;
- cntx->errhandler=NULL;
- cntx->alloc_big_count=0;
- cntx->alloc_small_count=0;
- cntx->special_bind_count=0;
- cntx->threadobj=NIL;
- cntx->intsig=0;
-
- /* create a special variable table for this thread and link to specials slot*/
- if (C_VECTOR) {
- specialtab=makevector(C_VECTOR,MAX_SPECIALS);
- /* copy initial values of special variables from the main context*/
- for (i=0; ic.vec.v[i]=mainctx->specials->c.vec.v[i];
- cntx->specials=specialtab;}
-
- { register int i;
- register struct methdef *mc;
- mc=(struct methdef *)malloc(sizeof(struct methdef)*MAXMETHCACHE);
- if (mc==NULL) error(E_ALLOCATION);
- for (i=0; imethcache=mc;
- thrbuddy=(struct buddyfree *)
- malloc(sizeof(struct buddyfree) * (MAXTHRBUDDY+1));
- if (thrbuddy==NULL) error(E_ALLOCATION);
- cntx->thr_buddy=thrbuddy;
- for (i=0; ithr_buddy[i].bp=0;
- cntx->thr_buddy[i].count=0;}
- cntx->thr_buddy[MAXTHRBUDDY].bp= (bpointer)-1;
- }
- return(cntx);}
-
-void deletecontext(id,ctx)
-register context *ctx;
-{ if (idstack);
- cfree(ctx);}
-
-#if THREADED
-pointer makethreadport(ctx)
-context *ctx;
-{ sema_t *sem;
- pointer s;
- pointer thrport;
- thrport=allocobj(THREAD, threadport, threadcp.cix);
-
- thrport->c.thrp.plist=NIL;
- thrport->c.thrp.requester=makeint(0);
- vpush(thrport);
-
- /* make three semaphores; reqsem, runsem, donesem */
- s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
- sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
- thrport->c.thrp.reqsem=s;
-
- s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
- sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
- thrport->c.thrp.runsem=s;
-
- s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
- sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
- thrport->c.thrp.donesem=s;
-
- sema_init(sem, 0, USYNC_THREAD, 0);
- thrport->c.thrp.donesem=makeint(sem); */
-
- thrport->c.thrp.contex=makeint((eusinteger_t)ctx>>2);
- thrport->c.thrp.func=NIL;
- thrport->c.thrp.args=NIL;
- thrport->c.thrp.result=NIL;
- thrport->c.thrp.idle=NIL;
- thrport->c.thrp.wait=NIL;
- ctx->threadobj=thrport;
- ctx->lastalloc=thrport;
- vpop();
- return(thrport);}
-#endif
-
diff --git a/lisp/c/matrix.c b/lisp/c/matrix.c
index 3ba8eb10c..63d2b2a0d 100644
--- a/lisp/c/matrix.c
+++ b/lisp/c/matrix.c
@@ -1018,7 +1018,7 @@ pointer *argv;
if (size<=2) error(E_VECINDEX);
x=a->c.fvec.fv[0]; y=a->c.fvec.fv[1]; z=a->c.fvec.fv[2];
norm = sqrt(x*x + y*y + z*z);
- if (fabs(norm)<0.00001) return(NIL); /*error(E_USER,(pointer)"too small axis vector");*/
+ if (fabs(norm)<0.00001) return(NIL); /*error(E_VALUE_ERROR,(pointer)"too small axis vector");*/
x = x/norm; y = y/norm; z= z/norm;
xv = x*x*vers; yv = y*y*vers; zv = z*z*vers;
xyv = x*y*vers; yzv = y*z*vers; zxv = z*x*vers;
diff --git a/lisp/c/memory.c b/lisp/c/memory.c
index ae977a11c..e36c20fb6 100644
--- a/lisp/c/memory.c
+++ b/lisp/c/memory.c
@@ -59,6 +59,11 @@ struct chunk *chunklist=NULL;
long gccount,marktime,sweeptime;
long alloccount[MAXBUDDY];
+/* counter to control new memory allocation when performance is low */
+/* see https://github.com/jsk-ros-pkg/jsk_roseus/issues/728 */
+long gc_consecutive_count;
+#define GC_CONSECUTIVE_COUNT_LIMIT 2
+
/*disposal processing*/
#define MAXDISPOSE 256
static pointer dispose[MAXDISPOSE];
@@ -157,6 +162,20 @@ register int k;
return(k);
}
+int fillchunk(k)
+register int k;
+{ numunion nu;
+ float gcm;
+ int j=0;
+ gcm=min(0.9,fltval(speval(GCMARGIN)));
+ while (freeheap<(totalheap*gcm)) {
+ j=newchunk(k);
+ if (j==ERR) return(j);
+ }
+ gc_consecutive_count=0;
+ return(j);
+}
+
void splitheap(k,buddy) /*heart of the allocator*/
register int k;
register struct buddyfree *buddy;
@@ -217,7 +236,6 @@ register int req; /*index to buddy: must be greater than 0*/
{ register int i, k;
register bpointer b,b2;
numunion nu;
- pointer gcm;
#if THREADED
mutex_lock(&alloc_lock);
@@ -230,9 +248,11 @@ register int req; /*index to buddy: must be greater than 0*/
if (k>=MAXBUDDY) { /*no bigger free cell*/
if (buddysize[req]=MAXBUDDY) {
k=newchunk(req);
@@ -288,14 +308,19 @@ register int req; /*index to buddy: must be greater than 0*/
/* fprintf(stderr, "GC: free=%d total=%d, margin=%f\n",
freeheap, totalheap, fltval(speval(GCMARGIN))); */
gc(); collected=1;
+ if (gc_consecutive_count > GC_CONSECUTIVE_COUNT_LIMIT) {
+ if (fillchunk(DEFAULTCHUNKINDEX) == ERR) {
+#if THREADED
+ mutex_unlock(&alloc_lock);
+#endif
+ error(E_ALLOCATION);}}
goto alloc_again;}
- while (freeheap<(totalheap*min(5.0,fltval(speval(GCMARGIN))))) {
- j=newchunk(DEFAULTCHUNKINDEX); /*still not enough space*/
- if (j==ERR) {
+ j=fillchunk(DEFAULTCHUNKINDEX);
+ if (j==ERR) {
#if THREADED
mutex_unlock(&alloc_lock);
#endif
- error(E_ALLOCATION);}} }
+ error(E_ALLOCATION);} }
if (j>=MAXBUDDY) { /*hard fragmentation seen*/
j=newchunk(DEFAULTCHUNKINDEX);
if (j==ERR) {
@@ -360,7 +385,7 @@ int e,cid;
#endif
}
#if THREADED
- rw_rdlock(&gc_lock);
+ // rw_rdlock(&gc_lock);
#endif
#ifdef DEBUG
fflush( stdout );
@@ -378,7 +403,7 @@ int e,cid;
for (i=0; ib.c[i]=0;
tb[req].count--;
#if THREADED
- rw_unlock(&gc_lock);
+ // rw_unlock(&gc_lock);
#endif
}
b->h.elmtype=e;
@@ -469,7 +494,10 @@ register pointer p;
#ifdef MARK_DEBUG
printf( "mark: markon 0x%lx\n", bp );
#endif
- if (pisclosure(p)) goto markloop; /*avoid marking contents of closure*/
+ if (pisclosure(p)) {
+ // mark local frame vector
+ gcpush(p->c.clo.env1);
+ goto markloop;}
marking=p;
/* printf("%x, %x, %d, %d, %d\n", p, bp, bp->h.elmtype, bp->h.bix, buddysize[bp->h.bix] );*/
if (bp->h.elmtype==ELM_FIXED) { /*contents are all pointers*/
@@ -533,6 +561,7 @@ void markall()
printf( "markall:%d: mark(SYSTEM_OBJECTS)\n", count );
#endif
mark(sysobj); /*mark internally reachable objects*/
+ mark(eussigobj); /*mark unix signal callbacks*/
mark_state=2;
#ifdef MARK_DEBUG
printf( "markall:%d: mark(PACKAGE_LIST)\n", count );
@@ -767,15 +796,17 @@ void resume_all_threads()
#if vxworks
void gc()
{ if (debug) fprintf(stderr,"\n;; gc:");
- breakck;
+ // breakck;
gccount++;
+ gc_consecutive_count++;
markall();
sweepall();
if (debug) {
fprintf(stderr," free/total=%d/%d stack=%d ",
freeheap,totalheap,markctx->vsp-markctx->stack);
}
- breakck; }
+ // breakck;
+}
#else
void gc()
@@ -783,20 +814,31 @@ void gc()
int i, r;
context *ctx=euscontexts[thr_self()];
- if (debug) fprintf(stderr,"\n;; gc: thread=%d ",thr_self());
- breakck;
+ if (speval(QGCHOOK)!=NIL) {
+ fprintf(stderr, ";; `sys:*gc-hook*' has been deprecated! Use `sys:*gc-debug*' instead.\n");
+ }
+ if (debug || speval(QGCDEBUG)!=NIL) {
+ fprintf(stderr,"\n;; gc: thread=%d ",thr_self());
+ }
+ // breakck;
gccount++;
+ gc_consecutive_count++;
times(&tbuf1);
#if THREADED
/* mutex_lock(&alloc_lock); is not needed since gc is assumed to be called
from alloc_small or alloc_big and they have already locked alloc_lock.*/
+ rw_wrlock(&gc_lock);
+/* the mark flag is also used in other parts of the code to judge equivalency
+ of pointers (superequal, copy-object, print-circle). To avoid dead-locks
+ when one of the above functions invokes the gc, return immediately and
+ allocate more memory instead. */
r = mutex_trylock(&mark_lock);
if ( r != 0 ) {
if (debug) fprintf(stderr, ";; gc:mutex_lock %d ", r);
+ rw_unlock(&gc_lock);
return;
}
- rw_wrlock(&gc_lock);
suspend_all_threads();
#endif
@@ -810,22 +852,22 @@ void gc()
#if THREADED
resume_all_threads();
- rw_unlock(&gc_lock);
mutex_unlock(&mark_lock);
+ rw_unlock(&gc_lock);
/* mutex_unlock(&alloc_lock); */
#endif
- if (debug) {
+ if (debug || speval(QGCDEBUG)!=NIL) {
fprintf(stderr," free/total=%ld/%ld stack=%d ",
freeheap,totalheap,(int)(myctx->vsp - myctx->stack));
- fprintf(stderr," mark=%ld sweep=%ld\n", marktime,sweeptime);
+ fprintf(stderr," marktime=%ldms sweeptime=%ldms\n",
+ marktime*1000/sysconf(_SC_CLK_TCK),
+ sweeptime*1000/sysconf(_SC_CLK_TCK));
}
- if (speval(QGCHOOK)!=NIL) {
- pointer gchook=speval(QGCHOOK);
- vpush(makeint(freeheap)); vpush(makeint(totalheap));
- ufuncall(ctx,gchook,gchook,(pointer)(ctx->vsp-2),ctx->bindfp,2);
- ctx->vsp -= 2;
- }
- breakck;
+/* Too unstable to call arbitrary lisp functions here
+ if for example gc is called during an allocation, any new attempt
+ to allocate memory during the function will cause a dead lock.
+*/
+ // breakck;
}
#endif
diff --git a/lisp/c/memory.mutex.c b/lisp/c/memory.mutex.c
index 2da4b48d7..cc010de0b 100644
--- a/lisp/c/memory.mutex.c
+++ b/lisp/c/memory.mutex.c
@@ -112,7 +112,7 @@ register int req; /*index to buddy: must be greater than 0*/
if (k>=MAXBUDDY) { /*no bigger free cell*/
if (buddysize[req]=MAXBUDDY) {
@@ -167,7 +167,7 @@ register int req; /*index to buddy: must be greater than 0*/
freeheap, totalheap, fltval(spevalof(GCMARGIN))); */
gc(); collected=1;
goto alloc_again;}
- while (freeheap<(totalheap*min(5.0,fltval(spevalof(GCMARGIN))))) {
+ while (freeheap<(totalheap*min(0.9,fltval(spevalof(GCMARGIN))))) {
j=newchunk(DEFAULTCHUNKINDEX); /*still not enough space*/
if (j==ERR) { mutex_unlock(&alloc_lock); error(E_ALLOCATION);}} }
if (j>=MAXBUDDY) { /*hard fragmentation seen*/
@@ -259,7 +259,7 @@ int e,cid;
if (k>=MAXBUDDY) { /*no bigger free cell*/
if (buddysize[req]=MAXBUDDY) {
@@ -368,6 +368,7 @@ markall()
mark_state=1;
mark(sysobj); /*mark internally reachable objects*/
+ mark(eussigobj); /*mark unix signal callbacks*/
mark_state=2;
mark(pkglist); /*mark all packages*/
for (i=0; i=MAXBUDDY) { /*no enough room*/
if (bbreq->size=MAXBUDDY) {
@@ -169,6 +169,7 @@ markall()
register context *ctx;
markctx=euscontexts[thr_self()];
mark(sysobj); /*mark internally reachable objects*/
+ mark(eussigobj); /*mark unix signal callbacks*/
mark(pkglist); /*mark all packages*/
for (i=0; i=1) count=ckintval(argv[0]);
+ else count=1;
if (n>=2) stack_size=ckintval(argv[1]);
else stack_size=32*1024; /* default stack=32K word */
if (n==3) c_stack_size=ckintval(argv[2]);
@@ -128,17 +131,20 @@ pointer argv[];
mutex_unlock(&qthread_lock);
#if alpha || PTHREAD
if( thr_create(0, c_stack_size, thread_main, newport, 0, &tid ) != 0 ) {
- deletecontext(tid, ctx);
- error(E_USER,(pointer)"Number of threads reached limit (64)");
+ deletecontext(tid, newctx);
+ if (tid>=MAXTHREAD) {
+ error(E_PROGRAM_ERROR,(pointer)"Number of threads reached limit (64)");}
+ error(E_PROGRAM_ERROR,(pointer)"Could not create a new thread");
}
newport->c.thrp.id=makeint(tid); /* ???? critical region problem */
#else
- thr_create(0, c_stack_size, (void *(*)(void *))thread_main,
- newport, THR_SUSPENDED, &tid);
- if (tid>=MAXTHREAD) {
- deletecontext(tid, ctx);
- error(E_USER,(pointer)"Number of threads reached limit (64)");
- }
+ if ( thr_create(0, c_stack_size, (void *(*)(void *))thread_main,
+ newport, THR_SUSPENDED, &tid) != 0) {
+ deletecontext(tid, newctx);
+ if (tid>=MAXTHREAD) {
+ error(E_PROGRAM_ERROR,(pointer)"Number of threads reached limit (64)");}
+ error(E_PROGRAM_ERROR,(pointer)"Could not create a new thread");
+ }
newport->c.thrp.id=makeint(tid);
thr_continue(tid);
#endif
@@ -152,6 +158,7 @@ int n;
pointer argv[];
{ register pointer port, args;
register int i;
+ if (n<1) error(E_MISMATCHARG);
port=get_free_thread();
port->c.thrp.requester=makeint(thr_self());
port->c.thrp.func=argv[0];
@@ -175,6 +182,7 @@ int n;
pointer argv[];
{ register pointer port, args;
register int i;
+ if (n<1) error(E_MISMATCHARG);
port=get_free_thread();
port->c.thrp.requester=makeint(thr_self());
port->c.thrp.func=argv[0];
@@ -195,7 +203,8 @@ int n;
pointer argv[];
{ register pointer port, result;
ckarg(1);
- port=argv[0];
+ if (isthread(argv[0])) port=argv[0];
+ else error(E_TYPE_ERROR,(pointer)"thread object expected");
if (port->c.thrp.wait!=NIL &&
(/* port->c.thrp.idle==NIL */ 1 ||
port->c.thrp.reqsem->c.ivec.iv[0]>0)) {
@@ -203,7 +212,7 @@ pointer argv[];
result=port->c.thrp.result;
sema_post((sema_t *)port->c.thrp.reqsem->c.ivec.iv); /*ack result transfer*/
return(result);}
- else error(E_USER,(pointer)"wait thread for idle thread");}
+ else error(E_VALUE_ERROR,(pointer)"trying to wait for an idle thread");}
pointer FREE_THREADS(ctx,n,argv)
context *ctx;
@@ -224,6 +233,7 @@ context *ctx;
int n;
pointer argv[];
{ register pointer m;
+ ckarg2(0,1);
m=makevector(C_INTVECTOR, (sizeof(mutex_t)+sizeof(eusinteger_t)-1)/sizeof(eusinteger_t));
#if alpha
pthread_mutex_init((mutex_t *)m->c.ivec.iv,pthread_mutexattr_default);
@@ -332,7 +342,8 @@ pointer SEMA_POST(ctx,n,argv)
context *ctx;
int n;
register pointer argv[];
-{ if (!isintvector(argv[0])) error(E_NOINTVECTOR);
+{ ckarg(1);
+ if (!isintvector(argv[0])) error(E_NOINTVECTOR);
sema_post((sema_t *)argv[0]->c.ivec.iv);
return(T);}
@@ -340,7 +351,8 @@ pointer SEMA_WAIT(ctx,n,argv)
context *ctx;
int n;
pointer argv[];
-{ if (!isintvector(argv[0])) error(E_NOINTVECTOR);
+{ ckarg(1);
+ if (!isintvector(argv[0])) error(E_NOINTVECTOR);
GC_REGION(sema_wait((sema_t *)argv[0]->c.ivec.iv););
return(T);}
@@ -348,7 +360,8 @@ pointer SEMA_TRYWAIT(ctx,n,argv)
context *ctx;
int n;
pointer argv[];
-{ if (!isintvector(argv[0])) error(E_NOINTVECTOR);
+{ ckarg(1);
+ if (!isintvector(argv[0])) error(E_NOINTVECTOR);
if (sema_trywait((sema_t *)argv[0]->c.ivec.iv)==0) return(T);
else return(NIL);}
@@ -371,9 +384,12 @@ pointer THR_SETPRIO(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
-{ int stat;
+{ int stat,tid,prio;
ckarg(2);
- stat=thr_setprio(ckintval(argv[0]),ckintval(argv[1]));
+ tid=ckintval(argv[0]);
+ prio=ckintval(argv[1]);
+ if (tid<0 || tid>=MAXTHREAD) error(E_INDEX_ERROR,(pointer)"no such thread");
+ stat=thr_setprio(tid,prio);
if (stat) return(makeint(-errno));
else return(T);}
@@ -381,9 +397,11 @@ pointer THR_GETPRIO(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
-{ int stat,prio;
+{ int stat,tid,prio;
ckarg(1);
- stat=thr_getprio(ckintval(argv[0]), &prio);
+ tid=ckintval(argv[0]);
+ if (tid<0 || tid>=MAXTHREAD) error(E_INDEX_ERROR,(pointer)"no such thread");
+ stat=thr_getprio(tid, &prio);
if (stat) return(makeint(-errno));
else return(makeint(prio));}
@@ -391,10 +409,10 @@ pointer THR_SETCONCURRENCY(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
-{ int stat;
+{ int stat,tid;
ckarg(1);
#if SunOS4_1 || alpha || PTHREAD
- fprintf(stderr, "thr_setconcurrency is not supprted!\n");
+ fprintf(stderr, "thr_setconcurrency is not supported!\n");
stat = 0;
#else
stat=thr_setconcurrency(ckintval(argv[0]));
@@ -409,7 +427,7 @@ pointer argv[];
{ int concurrency;
ckarg(0);
#if SunOS4_1 || alpha || PTHREAD
- fprintf(stderr, "thr_getconcurrency is not supprted!\n");
+ fprintf(stderr, "thr_getconcurrency is not supported!\n");
concurrency = 0;
#else
concurrency=thr_getconcurrency();
@@ -444,14 +462,16 @@ pointer argv[];
unsigned int thread_id;
pointer result;
struct thread_arg *ta;
- pointer func=argv[0], arg=argv[1];
+ pointer func, arg;
ckarg2(2,3);
+ func=argv[0];
+ arg=argv[1];
if (n==3) stack_size=ckintval(argv[2]);
else stack_size=1024*64;
newctx=(context *)makelispcontext(stack_size);
- fprintf(stderr,"creater newcontext=%p\n", newctx);
+ fprintf(stderr,"create newcontext=%p\n", newctx);
ta=(struct thread_arg *)malloc(sizeof(struct thread_arg));
ta->form=ctx->callfp->form;
ta->newctx=newctx;
@@ -459,7 +479,9 @@ pointer argv[];
ta->arg=arg;
stat=thr_create(0, stack_size, (void (*)(void *))newthread,
ta,0,&thread_id);
- if (stat) result=makeint(-errno);
+ if (stat) {
+ deletecontext(thread_id, newctx);
+ result=makeint(-errno);}
else
result=makeint(thread_id);
return(result);
@@ -474,6 +496,7 @@ pointer argv[];
ckarg(2);
tid=ckintval(argv[0]);
sig=ckintval(argv[1]);
+ if (tid<0 || tid>=MAXTHREAD) error(E_INDEX_ERROR,(pointer)"no such thread");
if (euscontexts[tid]) { thr_kill(tid,sig); return(T);}
else return(NIL);}
@@ -488,6 +511,7 @@ pointer argv[];
return(NIL);
#else
tid=ckintval(argv[0]);
+ if (tid<0 || tid>=MAXTHREAD) error(E_INDEX_ERROR,(pointer)"no such thread");
if (euscontexts[tid]) {
if (thr_suspend(tid)==0) return(T);
else return(makeint(-errno));}
@@ -506,6 +530,7 @@ pointer argv[];
return(NIL);
#else
tid=ckintval(argv[0]);
+ if (tid<0 || tid>=MAXTHREAD) error(E_INDEX_ERROR,(pointer)"no such thread");
if (euscontexts[tid]) {
if (thr_continue(tid)==0) return(T);
else return(makeint(-errno));}
diff --git a/lisp/c/mthread_alpha.c b/lisp/c/mthread_alpha.c
index d1ca32dd8..e04d3ebb9 100644
--- a/lisp/c/mthread_alpha.c
+++ b/lisp/c/mthread_alpha.c
@@ -75,8 +75,9 @@ int thr_create(void *base, size_t size, void (*func)(), void *args, long flags,
int i, stat;
struct thr_arg *arg;
- for( i = 0; i < MAXTHREAD && thread_table[i].using; i++ )
- ;
+ for( i = 0; i < MAXTHREAD && thread_table[i].using; i++ );
+ *tid = i;
+
if( i >= MAXTHREAD )
return -1;
@@ -89,7 +90,6 @@ int thr_create(void *base, size_t size, void (*func)(), void *args, long flags,
stat = pthread_create( &thread_table[i].tid, pthread_attr_default, (pthread_startroutine_t)thr_startup, (pthread_addr_t)arg );
if( stat == 0 )
thread_table[i].using = 1;
- *tid = i;
return( stat );
}
diff --git a/lisp/c/mthread_posix.c b/lisp/c/mthread_posix.c
index dba10310c..eff48e360 100644
--- a/lisp/c/mthread_posix.c
+++ b/lisp/c/mthread_posix.c
@@ -91,8 +91,9 @@ int thr_create(void *base, size_t size, void (*func)(void *), void *args, long f
int i, stat;
struct thr_arg *arg;
- for( i = 0; i < MAXTHREAD && thread_table[i].using; i++ )
- ;
+ for( i = 0; i < MAXTHREAD && thread_table[i].using; i++ );
+ *tid = i;
+
if( i >= MAXTHREAD )
return -1;
@@ -106,7 +107,6 @@ int thr_create(void *base, size_t size, void (*func)(void *), void *args, long f
stat = pthread_create( &thread_table[i].tid, NULL, (void*(*)(void *))thr_startup, arg );
if( stat == 0 )
thread_table[i].using = 1;
- *tid = i;
thr_create_lock=0;
return( stat );
}
diff --git a/lisp/c/paragc.c b/lisp/c/paragc.c
index 8573bab20..d591d5252 100644
--- a/lisp/c/paragc.c
+++ b/lisp/c/paragc.c
@@ -21,6 +21,7 @@ static pmarkall()
register context *ctx;
thread_t tid[512];
thr_create(0, 150*1024, pmark, sysobj, THR_BOUND, &tid[j++]);
+ thr_create(0, 150*1024, pmark, eussigobj, THR_BOUND, &tid[j++]);
/* p=pkglist;
while (p!=NIL) {
thr_create(0, 150*1024, pmark, ccar(p), THR_BOUND, &tid[j++]);
diff --git a/lisp/c/predicates.c b/lisp/c/predicates.c
index c141c22f0..c1ab941be 100644
--- a/lisp/c/predicates.c
+++ b/lisp/c/predicates.c
@@ -165,6 +165,7 @@ register pointer x,y;
register eusinteger_t *cx,*cy;
if (x==y) return(T);
if (isnum(x) || isnum(y)) return(NIL);
+ if (x==NULL || y==NULL) return(NIL);
if (x->cix != y->cix) return(NIL); /*different class*/
if (pissymbol(x)) return(NIL);
xe=elmtypeof(x);
@@ -203,10 +204,10 @@ register pointer argv[];
#if THREADED
mutex_lock(&mark_lock);
mark_locking="SUPEREQUAL";
+#endif
result=superequal(argv[0],argv[1]);
+#if THREADED
mutex_unlock(&mark_lock);
-#else
- result=superequal(argv[0],argv[1]);
#endif
if (result==UNBOUND) error(E_CIRCULAR);
else return(result);}
diff --git a/lisp/c/printer.c b/lisp/c/printer.c
index 6c13a3310..ad4bf238c 100644
--- a/lisp/c/printer.c
+++ b/lisp/c/printer.c
@@ -312,7 +312,7 @@ register context *ctx;
register pointer p;
{ register int i,s;
- if (isnum(p) || (pissymbol(p) && p->c.sym.homepkg != NIL) ) return;
+ if (p==NULL || isnum(p) || (pissymbol(p) && p->c.sym.homepkg != NIL) ) return;
if (!p_marked(p)) {
p_mark_on(p);
if (pissymbol(p)) return;
@@ -550,7 +550,7 @@ register context *ctx;
register pointer x;
register pointer f;
register int prlevel;
-{ register pointer fobj;
+{ register pointer fobj,tmp;
register int shareix=0;
numunion nu;
@@ -586,13 +586,20 @@ register int prlevel;
else if (Spevalof(PROBJECT)!=NIL) prinxobj(ctx,x,f,fobj,prlevel-1);
else if (pisarray(x) && (classof(x)==C_ARRAY)) printarray(ctx,x,f,prlevel-1);
else if (Spevalof(PRSTRUCTURE)!=NIL) printstructure(ctx,x,f,fobj,prlevel-1);
+ else if (Spevalof(PRCIRCLE)!=NIL) {
+ // force NIL to avoid deadlocks (EusLisp/#465)
+ // TODO: consider :prin1 objects in the initial printmark
+ tmp=Spevalof(PRCIRCLE);
+ pointer_update(Spevalof(PRCIRCLE),NIL);
+ csend(ctx,x,K_PRIN1,1,f);
+ pointer_update(Spevalof(PRCIRCLE),tmp)}
else csend(ctx,x,K_PRIN1,1,f);
} }
static void printunmark(p)
register pointer p;
{ register int i,s;
- if (isnum(p)) return;
+ if (p==NULL || isnum(p)) return;
if (!s_marked(p) && !p_marked(p)) return;
if (s_marked(p))
if (p_marked(p)) fprintf(stderr,"smarked?\n");
diff --git a/lisp/c/pthreads.c b/lisp/c/pthreads.c
index 6d587d477..693fd3b05 100644
--- a/lisp/c/pthreads.c
+++ b/lisp/c/pthreads.c
@@ -75,7 +75,7 @@ int thr_kill(int tid, int sig)
int thr_join(int tid, int *depature, void **status)
{
if ( *depature != NULL){
- fprintf(stderr,"Warrning in thr_join: argument 'depature' must be NULL.\n");
+ fprintf(stderr,"Warning in thr_join: argument 'depature' must be NULL.\n");
*depature == -1;
}
return(pthread_join(thread_table[tid][0], status));
diff --git a/lisp/c/reader.c b/lisp/c/reader.c
index 946b432a2..baaa7c657 100644
--- a/lisp/c/reader.c
+++ b/lisp/c/reader.c
@@ -26,6 +26,8 @@ static char *rcsid="@(#)$Id$";
#define syntaxtype(ch) ((enum ch_type)(current_syntax[thr_self()][ch]))
+int read_suppress = FALSE;
+
extern pointer FEATURES,READBASE,QREADTABLE;
extern pointer QNOT, QAND, QOR; /*eval_read_cond, Jan/1995*/
@@ -238,10 +240,11 @@ static pointer readlabdef(ctx,f,labx)
context *ctx;
pointer f; /*stream*/
eusinteger_t labx;
-{ pointer unsol, *unsolp, result,newlab;
+{ if (read_suppress) return(read1(ctx,f));
+ pointer unsol, *unsolp, result,newlab;
if (findlabel(labx)!=NIL) error(E_READLABEL,makeint(labx)); /*already defined*/
- newlab=(pointer)makelabref(makeint(labx),UNBOUND,oblabels[thr_self()]->c.lab.next);
+ newlab=(pointer)makelabref(ctx,makeint(labx),UNBOUND,oblabels[thr_self()]->c.lab.next);
pointer_update(oblabels[thr_self()]->c.lab.next,newlab);
result=read1(ctx,f);
@@ -280,7 +283,8 @@ register context *ctx;
pointer f;
eusinteger_t val;
int subchar;
-{ register pointer obj,element;
+{ if (read_suppress) return(NIL);
+ register pointer obj,element;
obj=findlabel(val);
if (obj==NIL) error(E_READLABEL,makeint(val)); /*undefined label*/
if ((element=obj->c.lab.value)==UNBOUND) return(obj);
@@ -299,7 +303,7 @@ register int size;
register int i=0;
Char ch;
ch=nextch(ctx,f);
- if (size>0) {
+ if (size>0 && !read_suppress) {
result=makevector(C_VECTOR,size);
vpush(result);
while ((ch!=')') && (ch!=EOF) && (ic.vec.v[i],element);i++;}
else {
while (ch!=')' && ch!=EOF) ch=nextch(ctx,f);
- error(E_READ); }
+ error(E_NODELIMITER); }
return(result);}
else {
while ((ch!=')') && (ch!=EOF)) {
@@ -340,7 +344,7 @@ register pointer s;
register pointer rvec;
Char ch;
ch=nextch(ctx,s);
- if (ch!='(') error(E_READFVECTOR);
+ if (ch!='(') error(E_NODELIMITER);
ch=nextch(ctx,s);
while (ch!=')' && ch!=EOF) {
unreadch(s,ch);
@@ -366,12 +370,12 @@ register pointer s;
numunion nu;
ch=nextch(ctx,s);
- if (ch!='(') error(E_READFVECTOR);
+ if (ch!='(') error(E_NODELIMITER);
ch=nextch(ctx,s);
while (ch!=')' && ch!=EOF) {
unreadch(s,ch);
elm=read1(ctx,s);
- if (!isnum(elm)) error(E_READFVECTOR);
+ if (!isnum(elm)) error(E_NONUMBER);
if (isint(elm)) { f=intval(elm); elm=makeflt(f);}
ckpush(elm);
i++;
@@ -390,15 +394,18 @@ register pointer s; /*input stream*/
Char ch;
ch=nextch(ctx,s);
- if (ch!='(') error(E_READOBJECT);
+ if (ch!='(') error(E_NODELIMITER);
+ ch=nextch(ctx,s);
+ if (ch==')') error(E_NOCLASS, NULL);
+ unreadch(s,ch);
name=read1(ctx,s);
- if (!issymbol(name)) error(E_READOBJECT);
+ if (!issymbol(name)) error(E_NOSYMBOL);
klass=speval(name);
if (klass==UNBOUND) error(E_NOCLASS,name);
- if (!isclass(klass)) error(E_READOBJECT);
+ if (!isclass(klass)) error(E_NOCLASS);
if (isvecclass(klass)) {
elem=read1(ctx,s);
- if (!isint(elem)) error(E_READOBJECT); /*vector size*/
+ if (!isint(elem)) error(E_NOINT); /*vector size*/
sz=intval(elem);
result=makevector(klass,sz);
i=1;}
@@ -422,16 +429,20 @@ register pointer s; /*input stream*/
static pointer readstructure(ctx,s)
register context *ctx;
register pointer s; /*input stream*/
-{ register pointer name, klass, slot, elem, result, varvec, *slotp;
+{ if (read_suppress) return(read1(ctx,s));
+ register pointer name, klass, slot, elem, result, varvec, *slotp;
Char ch;
ch=nextch(ctx,s);
- if (ch!='(') error(E_READOBJECT);
+ if (ch!='(') error(E_NODELIMITER);
+ ch=nextch(ctx,s);
+ if (ch==')') error(E_NOCLASS, NULL);
+ unreadch(s,ch);
name=read1(ctx,s);
- if (!issymbol(name)) error(E_READOBJECT);
+ if (!issymbol(name)) error(E_NOSYMBOL);
klass=speval(name);
if (klass==UNBOUND) error(E_NOCLASS,name);
- if (!isclass(klass)) error(E_READOBJECT);
+ if (!isclass(klass)) error(E_NOCLASS);
if (isvecclass(klass)) { error(E_NOCLASS,name);}
else if (isclass(klass)) result=(pointer)makeobject(klass);
else error(E_NOCLASS,name);
@@ -460,7 +471,7 @@ register context *ctx;
register pointer f;
eusinteger_t val;
int subchar;
-{ char ch;
+{ Char ch;
ch=readch(f); return(makeint(ch));}
static pointer read_sharp_comment(ctx,f,val,subchar) /* #| ... |# */
@@ -490,7 +501,7 @@ int subchar;
{ register int i=0,j,c,p,q;
pointer b;
eusinteger_t *bv,x;
- char ch, buf[WORD_SIZE];
+ Char ch, buf[WORD_SIZE];
ch=readch(f);
while (i='0' && ch<'8') { buf[i++] = ch; ch=readch(f);}
unreadch(f,ch); buf[i]=0;
@@ -542,7 +554,7 @@ eusinteger_t val;
int subchar;
char token[];
{ register int i=0;
- char ch;
+ Char ch;
ch=readch(f);
while (syntaxtype(ch)==ch_constituent) {
token[i++]=to_upper(ch); ch=readch(f);}
@@ -555,6 +567,7 @@ pointer f;
{ pointer p;
p=read1(ctx,f);
/* if (debug) prinx(ctx,p,Spevalof(QSTDOUT)); */
+ if (read_suppress) return(UNBOUND);
return(eval(ctx,p));}
static pointer eval_read_cond(ctx,expr)
@@ -580,7 +593,7 @@ pointer expr;
if (r!=NIL) return(T);
else expr=ccdr(expr);}
return(NIL);}}
- error(E_USER,(pointer)"AND/OR/NOT expected in #+ or #-", expr);}
+ error(E_VALUE_ERROR,(pointer)"AND/OR/NOT expected in #+ or #-", expr);}
static pointer read_cond_plus(ctx,f) /* #+ */
register context *ctx;
@@ -588,8 +601,10 @@ register pointer f;
{ register pointer flag,result;
flag=read1(ctx,f);
vpush(flag);
- result=read1(ctx,f);
- if (eval_read_cond(ctx,flag)==NIL) result=(pointer)UNBOUND;
+ if (eval_read_cond(ctx,flag)==NIL) {
+ read_suppress=TRUE; read1(ctx,f);
+ result=(pointer)UNBOUND;}
+ else result=read1(ctx,f);
vpop();
return(result);}
@@ -599,8 +614,10 @@ register pointer f;
{ register pointer flag,result;
flag=read1(ctx,f);
vpush(flag);
- result=read1(ctx,f);
- if (eval_read_cond(ctx,flag)!=NIL) result=(pointer)UNBOUND;
+ if (eval_read_cond(ctx,flag)!=NIL) {
+ read_suppress=TRUE; read1(ctx,f);
+ result=(pointer)UNBOUND;}
+ else result=read1(ctx,f);
vpop();
return(result);}
@@ -639,7 +656,9 @@ char token[];
if (ch==EOF) return(UNBOUND);}
subchar=to_upper(ch);
macrofunc=Spevalof(QREADTABLE)->c.rdtab.dispatch->c.vec.v[subchar];
- if (macrofunc==NIL) error(E_USER,(pointer)"no # macro defined");
+ if (macrofunc==NIL) {
+ if (read_suppress) return(read1(ctx,f));
+ error(E_NAME_ERROR,(pointer)"no # macro defined");}
if (isint(macrofunc)) { /*internal macro*/
intmac=(pointer (*)())(intval(macrofunc));
result=(*intmac)(ctx,f,val,subchar,token);}
@@ -694,6 +713,7 @@ char token[];
doublecolon=0;
pkg=(pointer)searchpkg((byte *)token,colon);}
if (pkg==(pointer)NULL) {
+ if (read_suppress) return(NIL);
if (doublecolon) colon--;
pkgstr=makestring(token,colon);
vpush(pkgstr);
@@ -706,8 +726,9 @@ char token[];
/* sym=findsymbol((char *)&token[colon],leng-colon, pkg->c.pkg.symvector, &hash);*/
if (sym) return(sym);
else {
+ if (read_suppress) return(UNBOUND);
pkgstr=makestring(token,leng);
- fprintf(stderr,"%s ",token);
+ // fprintf(stderr,"%s ",token);
vpush(pkgstr);
error(E_EXTSYMBOL,pkgstr);}
} }
@@ -715,10 +736,10 @@ char token[];
/* news does not have strtol routine! */
#if news || sanyo
int strtol(str,ptr,base)
-register char *str,**ptr;
+register Char *str,**ptr;
register int base;
{ long val=0,sign=1;
- char ch;
+ Char ch;
while (isspace(*str)) str++;
ch= *str;
if (ch=='+') str++; else if (ch=='-') { str++; sign= -1;}
@@ -758,7 +779,7 @@ int len;
else if (k>='A' && k<='Z') k=k-'A'+10;
else if (k>='a' && k<='z') k=k-'a'+10;
else if (k=='.') continue;
- else error(E_USER,(pointer)"illegal integer consituent char");
+ else error(E_CHARRANGE);
mul_int_big(base,b);
add_int_big(k,b); }
if (sign<0) complement_big(b);
@@ -796,9 +817,9 @@ char token[];
else if (syntaxtype(ch)==ch_white) {
result=read1(ctx,f);
ch=nextch(ctx,f);
- if (ch!=delim_char) error(E_READ);
+ if (ch!=delim_char) error(E_NODELIMITER);
break;}
- else error(E_READ);}
+ else error(E_NODELIMITER);}
else { unreadch(f,ch); element=read1(ctx,f);}
if (element!=UNBOUND && element!=(pointer)EOF) ckpush(element);
ch=nextch(ctx,f);}
@@ -903,7 +924,7 @@ int colon;
unreadch(ins,ch); goto step10;
case ch_white:
unreadch(ins,ch); goto step10;
- default: error(E_USER,(pointer)"unknown char type");}
+ default: error(E_IO_ERROR,(pointer)"unknown char type");}
step9:
escaped=1;
if (i>=MAXTOKENLENGTH) error(E_LONGSTRING);
@@ -937,7 +958,7 @@ int colon;
/*float or symbol*/
while (is_digit(token[j],base)) j++;
c=to_upper(token[j]);
- if (c=='E' || c=='D' || c=='F' || c=='L') {
+ if (c=='E' || c=='D' || c=='F' || c=='L' || c=='S') {
c=j; j++;
if ((token[j]=='+') || (token[j]=='-')) j++;
while (is_digit(token[j],base)) j++;
@@ -955,7 +976,7 @@ int colon;
else if (j==i) return(readint(ctx,token,i));
else {
c=to_upper(token[j]);
- if (c=='E' || c=='D' || c=='F' || c=='L') {
+ if (c=='E' || c=='D' || c=='F' || c=='L' || c=='S') {
c=j; j++;
if ((token[j]=='+') || (token[j]=='-')) j++;
while (is_digit(token[j],base)) j++;
@@ -990,7 +1011,7 @@ register pointer ins;
case ch_white: goto step1;
case ch_termmacro: case ch_nontermacro:
macrofunc=Spevalof(QREADTABLE)->c.rdtab.macro->c.vec.v[ch];
- if (macrofunc==NIL) error(E_USER,(pointer)"no char macro defined");
+ if (macrofunc==NIL) error(E_NAME_ERROR,(pointer)"no char macro defined");
if (isint(macrofunc)) { /*internal macro*/
intmac=(pointer (*)())(intval(macrofunc));
result=(*intmac)(ctx,ins,ch,token);}
@@ -1018,6 +1039,7 @@ register context *ctx;
register pointer f,recursivep;
{ register pointer val;
Char ch;
+ read_suppress=FALSE;
current_syntax[thr_self()]=Spevalof(QREADTABLE)->c.rdtab.syntax->c.str.chars;
ch=nextch(ctx,f);
if (ch==EOF) return((pointer)EOF);
diff --git a/lisp/c/reader.new.c b/lisp/c/reader.new.c
deleted file mode 100644
index 8263d6716..000000000
--- a/lisp/c/reader.new.c
+++ /dev/null
@@ -1,1055 +0,0 @@
-/****************************************************************/
-/* euslisp reader
-/* Copyright (c) T.Matsui, Electrotechnical Laboratory
-/* 1986-
-/* 1987-Jan dispatch macros
-/* 1987-May labeled expression #n= and #n#
-/* 1988-July multiple escape |...|
-/****************************************************************/
-static char *rcsid="@(#)$Id$";
-
-#include
-#include
-#include
-#include "eus.h"
-#if !alpha
-#define FALSE (0)
-#define TRUE (1)
-#endif
-
-#define MAXTOKENLENGTH 1024
-#define MAXSTRINGLENGTH 16384
-#define to_upper(c) (islower(c) ? ((c)-'a'+'A') : (c))
-#define to_lower(c) (isupper(c) ? ((c)-'A'+'a') : (c))
-
-#define syntaxtype(ch) ((enum ch_type)(current_syntax[ch]))
-
-extern pointer FEATURES,READBASE,QREADTABLE;
-extern pointer QNOT, QAND, QOR; /*eval_read_cond, Jan/1995*/
-
-static pointer read1(context *, pointer);
-static pointer read2(context *, pointer, int, int, int, char*, int);
-extern pointer makelabref();
-
-extern mul_int_big();
-extern pointer normalize_bignum();
-
-/* the following two global variables are hazardous to multi-threads */
-/* These should be eliminated in the next release. */
-byte *current_syntax;
-pointer oblabels; /*keep labeled-objects in read*/
-
-/****************************************************************/
-/* character type table
-/****************************************************************/
-
-/*exported*/
-enum ch_type chartype[256]={
- ch_illegal, ch_illegal, ch_illegal, ch_illegal, /*0-3*/
- ch_illegal, ch_illegal, ch_illegal, ch_illegal, /*4-7*/
- ch_constituent, ch_white, ch_white, ch_illegal, /*8-b*/
- ch_white, ch_white, ch_illegal, ch_illegal, /*c-f*/
- ch_illegal, ch_illegal, ch_illegal, ch_illegal, /*10-13*/
- ch_illegal, ch_illegal, ch_illegal, ch_illegal, /*14-17*/
- ch_illegal, ch_illegal, ch_illegal, ch_illegal, /*18-1b*/
- ch_illegal, ch_illegal, ch_illegal, ch_illegal, /*1c-1f*/
- ch_white, ch_constituent, ch_termmacro, ch_nontermacro, /*20-23*/
- ch_constituent, ch_constituent, ch_constituent, ch_termmacro, /*24-27*/
- ch_termmacro, ch_termmacro, ch_constituent, ch_constituent, /*28-2b*/
- ch_termmacro, ch_constituent, ch_constituent, ch_constituent, /*2c-2f*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*30-33*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*34-37*/
- ch_constituent, ch_constituent, ch_constituent, ch_termmacro, /*38-3b*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*3c-3f*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*40-43*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*44-47*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*48-4b*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*4c-4f*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*50-53*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*54-57*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*58-5b*/
- ch_sglescape, ch_constituent, ch_constituent, ch_constituent, /*5c-5f*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*60-63*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*64-67*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*68-6b*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*6c-6f*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*70-73*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*74-77*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*78-7b*/
- ch_multiescape, ch_constituent, ch_constituent, ch_constituent, /*7c-7f*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*80*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*90*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*a0*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*b0*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*c0*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*d0*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*e0*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*f0*/
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent,
- ch_constituent, ch_constituent, ch_constituent, ch_constituent};
-
-enum ch_attr charattr[256]={
- illegal, illegal, illegal, illegal, /*0*/
- illegal, illegal, illegal, illegal,
- illegal, illegal, illegal, illegal,
- illegal, illegal, illegal, illegal,
- illegal, illegal, illegal, illegal, /*10*/
- illegal, illegal, illegal, illegal,
- illegal, illegal, illegal, illegal,
- illegal, illegal, illegal, illegal,
- alphabetic, alphabetic, alphabetic, alphabetic, /*20*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphadigit, alphadigit, alphadigit, alphadigit, /*30*/
- alphadigit, alphadigit, alphadigit, alphadigit,
- alphadigit, alphadigit, package_marker, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*40*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*50*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*60*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*70*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*80*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*90*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*a0*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*b0*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*c0*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*d0*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*e0*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic, /*f0*/
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic,
- alphabetic, alphabetic, alphabetic, alphabetic
- };
-
-/****************************************************************/
-/* euLisp READER */
-/****************************************************************/
-/*
-/* reader primitives
-*/
-#if IRIX || Linux_ppc
-#define Char int
-#else
-#define Char char
-#endif
-
-static Char skip(ctx, f, ch)
-context *ctx;
-register pointer f;
-Char ch;
-{ skipblank:
- while (syntaxtype((char)ch)==ch_white) {
- ch=readch(f);
- if (ch==EOF) return(EOF);}
- if (ch == ';' && (Spevalof(QREADTABLE)->c.rdtab.macro->c.vec.v[ch]
- == charmacro[';'])) {
- /*syntax type for comment should be checked*/
- do {
- ch=readch(f);
- if (ch==EOF) return(EOF); }
- while(ch!='\n');
- goto skipblank;} return(ch); }
-
-static int nextch(ctx, f)
-context *ctx;
-register pointer f;
-{
- Char ch;
- ch=readch(f); ch=skip(ctx, f,ch); return(ch);}
-
-
-/****************************************************************/
-/* labeled expression (#n=, #n#)
-/****************************************************************/
-
-static pointer findlabel(labx)
-int labx;
-{ register pointer obj,labid;
- labid=makeint(labx);
- obj=oblabels->c.lab.next;
- while (obj!=NIL) {
- if (obj->c.lab.label==labid) return(obj);
- else obj=obj->c.lab.next; }
- return(NIL);}
-
-static pointer readlabdef(ctx,f,labx)
-context *ctx;
-pointer f; /*stream*/
-int labx;
-{ pointer unsol, *unsolp, result,newlab;
-
- if (findlabel(labx)!=NIL) error(E_READLABEL,makeint(labx)); /*already defined*/
- newlab=(pointer)makelabref(makeint(labx),UNBOUND,oblabels->c.lab.next);
- oblabels->c.lab.next=newlab;
- result=read1(ctx,f);
-
- /*solve references*/
- newlab->c.lab.value=result;
- unsol=newlab->c.lab.unsolved;
- while (unsol!=NIL) {
-#if sun3 || (!alpha && system5) || sanyo
- unsolp=(pointer *)unsol;
-#endif
-#if sun4 || vax || news || mips || alpha || i386
- unsolp=(pointer *)((eusinteger_t)unsol & ~3);/*???? */
-#endif
- unsol= *unsolp;
- *unsolp=result; }
- return(result);}
-
-static addunsolved(labp,addr)
-pointer labp;
-pointer *addr;
-{ *addr=labp->c.lab.unsolved;
-#if sun3 ||( !alpha && system5 ) || sanyo
- labp->c.lab.unsolved=(pointer)addr;
-#endif
-#if sun4 || vax || news || mips || alpha || i386
- { int i;
- i=intval(addr);
- labp->c.lab.unsolved=makeint(i);}
-#endif
-}
-
-static pointer readlabref(ctx,f,val,subchar)
-pointer f;
-{ register pointer obj,element;
- obj=findlabel(val);
- if (obj==NIL) error(E_READLABEL,makeint(val)); /*undefined label*/
- if ((element=obj->c.lab.value)==UNBOUND) return(obj);
- else return(element);}
-
-
-/****************************************************************/
-/* read vector and object
-/* #(, #v(, #f(, #i(, #j(
-/****************************************************************/
-static pointer readvector(ctx,f,size)
-register context *ctx;
-register pointer f;
-register int size;
-{ register pointer result,element;
- register int i=0;
- Char ch;
- ch=nextch(ctx,f);
- if (size>0) {
- result=makevector(C_VECTOR,size);
- vpush(result);
- while ((ch!=')') && (ch!=EOF) && (ic.vec.v[i]); }
- else result->c.vec.v[i]=element;
- i++;
- ch=nextch(ctx,f);}
- if (ch==')')
- while (ic.vec.v[i++]=element;
- else {
- while (ch!=')' && ch!=EOF) ch=nextch(ctx,f);
- error(E_READ); }
- return(result);}
- else {
- while ((ch!=')') && (ch!=EOF)) {
- unreadch(f,ch);
- element=read1(ctx,f);
- ckpush(element);
- i++;
- ch=nextch(ctx,f);}
- result=makevector(C_VECTOR,i);
- while (i>0) {
- i--;
- element=vpop();
- if (islabref(element)) addunsolved(element,&result->c.vec.v[i]);
- else result->c.vec.v[i]=element; }
- return(result); } }
-
-static pointer readivector(ctx,s)
-register context *ctx;
-register pointer s;
-{ register int i=0,x;
- register pointer rvec;
- Char ch;
- ch=nextch(ctx,s);
- if (ch!='(') error(E_READFVECTOR);
- ch=nextch(ctx,s);
- while (ch!=')' && ch!=EOF) {
- if (isdigit(ch)) {
- x=0;
- while (isdigit(ch)) { x=x*10+ch-'0'; ch=readch(s);}
- if (ch=='.') ch=readch(s);}
- else {
- unreadch(s,ch);
- x=intval(read1(ctx,s));
- ch=nextch(ctx,s);}
- ckpush(makeint(x>>16)); ckpush(makeint(x & 0xffff));
- i++;}
- rvec=makevector(C_INTVECTOR,i);
- while (i>0) {
- x=intval(vpop());
- x=(intval(vpop())<<16) + x;
- rvec->c.ivec.iv[--i]=x;}
- return(rvec);}
-
-static pointer readfvector(ctx,s)
-register context *ctx;
-register pointer s;
-{ register int i=0,x;
- register pointer elm;
- float f;
- Char ch;
- numunion nu;
-
- ch=nextch(ctx,s);
- if (ch!='(') error(E_READFVECTOR);
- ch=nextch(ctx,s);
- while (ch!=')' && ch!=EOF) {
- unreadch(s,ch);
- elm=read1(ctx,s);
- if (!isnum(elm)) error(E_READFVECTOR);
- if (isint(elm)) { f=intval(elm); elm=makeflt(f);}
- ckpush(elm);
- i++;
- ch=nextch(ctx,s);}
- elm=makevector(C_FLTVECTOR,i);
- while (i>0) elm->c.fvec.fv[--i]=fltval(vpop());
- return(elm);}
-
-static pointer readobject(ctx,s)
-register context *ctx;
-register pointer s; /*input stream*/
-{
- register pointer name, klass, elem, result;
- register int i,sz;
- Char ch;
-
- ch=nextch(ctx,s);
- if (ch!='(') error(E_READOBJECT);
- name=read1(ctx,s);
- if (!issymbol(name)) error(E_READOBJECT);
- klass=speval(name);
- if (klass==UNBOUND) error(E_NOCLASS,name);
- if (!isclass(klass)) error(E_READOBJECT);
- if (isvecclass(klass)) {
- elem=read1(ctx,s);
- if (!isint(elem)) error(E_READOBJECT); /*vector size*/
- sz=intval(elem);
- result=makevector(klass,sz);
- i=1;}
- else if (isclass(klass)) {
- result=(pointer)makeobject(klass);
- i=0;}
- else error(E_NOCLASS,name);
- vpush(result);
- ch=nextch(ctx,s);
- while (ch!=')' && ch!=EOF) {
- unreadch(s,ch);
- elem=read1(ctx,s);
- if (islabref(elem)) { /*refer to undefined labeled obj*/
- addunsolved(elem,&result->c.obj.iv[i++]); }
- else result->c.obj.iv[i++]=elem;
- ch=nextch(ctx,s);
- }
- vpop();
- return(result); }
-
-static pointer readstructure(ctx,s)
-register context *ctx;
-register pointer s; /*input stream*/
-{ register pointer name, klass, slot, elem, result, varvec, *slotp;
- Char ch;
-
- ch=nextch(ctx,s);
- if (ch!='(') error(E_READOBJECT);
- name=read1(ctx,s);
- if (!issymbol(name)) error(E_READOBJECT);
- klass=speval(name);
- if (klass==UNBOUND) error(E_NOCLASS,name);
- if (!isclass(klass)) error(E_READOBJECT);
- if (isvecclass(klass)) { error(E_NOCLASS,name);}
- else if (isclass(klass)) result=(pointer)makeobject(klass);
- else error(E_NOCLASS,name);
- vpush(result);
- ch=nextch(ctx,s);
- while (ch!=')' && ch!=EOF) {
- unreadch(s,ch);
- slot=read1(ctx,s);
- if (!issymbol(slot)) error(E_NOSYMBOL);
- elem=read1(ctx,s);
- slotp=(pointer *)getobjv(slot,klass->c.cls.vars,result);
- if (slotp!=NULL) {
- if (islabref(elem)) { /*refer to undefined labeled obj*/
- addunsolved(elem,slotp); }
- else *slotp=elem; }
- ch=nextch(ctx,s);
- }
- vpop();
- return(result); }
-
-/****************************************************************/
-/* read dispatch macro expression
-/****************************************************************/
-static pointer read_sharp_char(ctx,f,val,subchar) /* #\ */
-register context *ctx;
-register pointer f;
-int val,subchar;
-{ char ch;
- ch=readch(f); return(makeint(ch));}
-
-static pointer read_sharp_comment(ctx,f,val,subchar) /* #| ... |# */
-register context *ctx;
-register pointer f;
-register int val,subchar;
-{ Char ch;
- val=0;
- ch=readch(f);
- morecomments:
- while (ch!=subchar && ch!='#' && ch!=EOF) ch=readch(f);
- if (ch==EOF) return((pointer)EOF);
- if (ch==subchar) {
- ch=readch(f);
- if (ch=='#') { if (--val<0) return(UNBOUND);}
- goto morecomments;}
- ch=readch(f);
- if (ch==subchar) { ch=readch(f); val++;}
- goto morecomments;}
-
-static pointer read_sharp_hex(ctx,f,val,subchar)
-register context *ctx;
-register pointer f;
-eusinteger_t val;
-int subchar;
-{ register int i=0,j,x,c,p,q;
- pointer b;
- eusinteger_t *bv;
- char ch, buf[WORD_SIZE];
-
- ch=readch(f);
- while (i=0; j--) {
- c=toupper(buf[j]);
- x=(c<='9')?(c-'0'):(c-'A'+10);
- bv[p/(WORD_SIZE-1)] |= ((x << q) & MASK);
- if (q>=(WORD_SIZE-4)) bv[p/(WORD_SIZE-1) + 1] = x>>(WORD_SIZE-1-q);
- p +=4; q = (q+4) % (WORD_SIZE-1);
- }
- b=(pointer)normalize_bignum(b);
- return(b);}
- }
-
-static pointer read_sharp_octal(ctx,f,val,subchar)
-register context *ctx;
-pointer f;
-eusinteger_t val;
-int subchar;
-{ register int i=0;
- char buf[WORD_SIZE/2], ch;
- ch=readch(f); val=0;
- while (i='0' && ch<'8') { buf[i++] = ch; ch=readch(f);}
- unreadch(f,ch); buf[i]=0;
- sscanf(buf,"%lo",&val);
- return(makeint(val));}
-
-static pointer read_sharp_function(ctx,f,val,subchar) /* #' */
-register context *ctx;
-pointer f;
-int val,subchar;
-{ return(cons(ctx,FUNCTION,cons(ctx,read1(ctx,f),NIL)));}
-
-static pointer read_uninterned_symbol(ctx,f,val,subchar,token) /* #: */
-context *ctx;
-pointer f;
-int val,subchar;
-char token[];
-{ register int i=0;
- char ch;
- ch=readch(f);
- while (syntaxtype(ch)==ch_constituent) {
- token[i++]=to_upper(ch); ch=readch(f);}
- token[i]=0; unreadch(f,ch);
- return(makesymbol(ctx,(char *)token,i,NIL));}
-
-static pointer read_sharp_eval(ctx,f)
-register context *ctx;
-pointer f;
-{ pointer p;
- p=read1(ctx,f);
-/* if (debug) prinx(ctx,p,Spevalof(QSTDOUT)); */
- return(eval(ctx,p));}
-
-static pointer eval_read_cond(ctx,expr)
-context *ctx;
-pointer expr;
-{ pointer r;
- if (issymbol(expr)) return(memq(expr,speval(FEATURES)));
- if (iscons(expr)) {
- if (ccar(expr)==QNOT) {
- r=eval_read_cond(ctx,ccar(ccdr(expr)));
- return((r==NIL)?T:NIL);}
- else if (ccar(expr)==QAND) {
- expr=ccdr(expr);
- while (iscons(expr)) {
- r=eval_read_cond(ctx,ccar(expr));
- if (r==NIL) return(NIL);
- else expr=ccdr(expr);}
- return(T);}
- else if (ccar(expr)==QOR) {
- expr=ccdr(expr);
- while (iscons(expr)) {
- r=eval_read_cond(ctx,ccar(expr));
- if (r!=NIL) return(T);
- else expr=ccdr(expr);}
- return(NIL);}}
- error(E_USER,(pointer)"AND/OR/NOT expected in #+ or #-", expr);}
-
-static pointer read_cond_plus(ctx,f) /* #+ */
-register context *ctx;
-register pointer f;
-{ register pointer flag,result;
- flag=read1(ctx,f);
- vpush(flag);
- result=read1(ctx,f);
- if (eval_read_cond(ctx,flag)==NIL) result=(pointer)UNBOUND;
- vpop();
- return(result);}
-
-static pointer read_cond_minus(ctx,f) /* #- */
-register context *ctx;
-register pointer f;
-{ register pointer flag,result;
- flag=read1(ctx,f);
- vpush(flag);
- result=read1(ctx,f);
- if (eval_read_cond(ctx,flag)!=NIL) result=(pointer)UNBOUND;
- vpop();
- return(result);}
-
-static pointer read_sharp_object(ctx,f) /* #< */
-register context *ctx;
-register pointer f;
-{ register pointer element,result,obj;
- register int val;
- Char ch;
- element=read1(ctx,f);
- if (!issymbol(element)) error(E_NOSYMBOL); /*class name*/
- element=speval(element);
- if (element==UNBOUND || !isclass(element)) error(E_NOCLASS,element);
- obj=read1(ctx,f); val=ckintval(obj);
- result=makepointer(val);
- if (classof(result)!=element)
- error(E_TYPEMISMATCH, (pointer)"read #<> class mismatch"); /* ???? */
- ch=readch(f);
- while (ch!='>' && ch!=EOF) ch=readch(f);
- return(result);}
-
-static pointer readsharp(ctx,f,ch,token)
-register context *ctx;
-register pointer f;
-Char ch;
-char token[];
-{ register int i=0,val=0,subchar;
- pointer macrofunc,result;
- pointer (*intmac)();
-
- ch=readch(f);
- if (ch==EOF) return(UNBOUND);
- while (isdigit(ch)) {
- val=val*10+ch-'0'; ch=nextch(ctx,f);
- if (ch==EOF) return(UNBOUND);}
- subchar=to_upper(ch);
- macrofunc=Spevalof(QREADTABLE)->c.rdtab.dispatch->c.vec.v[subchar];
- if (macrofunc==NIL) error(E_USER,(pointer)"no # macro defined");
- if (isint(macrofunc)) { /*internal macro*/
- intmac=(pointer (*)())(intval(macrofunc));
- result=(*intmac)(ctx,f,val,subchar,token);}
- else {
- vpush(f); vpush(makeint(subchar)); vpush(makeint(val));
- result=ufuncall(ctx,macrofunc,macrofunc,(pointer)(ctx->vsp-3),NULL,3);
- ctx->vsp-=3;}
- return(result);}
-
-static pointer readstring(ctx,f,terminator)
-register context *ctx;
-pointer f;
-int terminator;
-{ int tleng = 0, lengmax=MAXSTRINGLENGTH; /* '"' is ignored */
- byte buf[MAXSTRINGLENGTH], *token, *newtoken;
- int ch, malloced=FALSE;
- pointer p;
-
- ch=readch(f);
- token=buf;
- while ((ch!=terminator) && (ch!=EOF)) {
- if (syntaxtype(ch) == ch_sglescape) ch=readch(f); /*read escaped char*/
- token[tleng++]=ch;
- if (tleng >= lengmax) { /*allocate bigger string buffer*/
- /*and copy the accumulated characters so far*/
- newtoken=(byte *)malloc(lengmax*2);
- if (newtoken == NULL) { /*malloc failed*/
- if (malloced==TRUE) cfree(token);
- error(E_LONGSTRING);}
- memcpy(newtoken,token,tleng);
- if (malloced==TRUE) cfree(token);
- malloced=TRUE;
- token=newtoken; lengmax=lengmax*2;
- }
- ch=readch(f);}
- token[tleng] = '\0';
- p=makestring((char *)token,tleng);
- if (malloced==TRUE) cfree(token);
- return(p);
- }
-
-static pointer readsymbol(ctx,leng,colon, token)
-register context *ctx;
-register int leng,colon;
-char token[];
-{ register pointer pkg;
- pointer pkgstr,sym;
- register int doublecolon=1;
- int hash;
- if (colon==0) pkg=keywordpkg;
- else if (colon>0) {
- if (charattr[token[colon-1]]==package_marker) {
- pkg=(pointer)searchpkg((byte *)token,colon-1);}
- else {
- doublecolon=0;
- pkg=(pointer)searchpkg((byte *)token,colon);}
- if (pkg==(pointer)NULL) {
- if (doublecolon) colon--;
- pkgstr=makestring(token,colon);
- vpush(pkgstr);
- error(E_NOPACKAGE,pkgstr);} }
- else pkg=Spevalof(PACKAGE); /*use current package for symbol search*/
- colon++; /*colon-th character starts symbol name string*/
- if (doublecolon) return(intern(ctx,&token[colon],leng-colon,pkg));
- else {
- sym=findsymbol((byte *)&token[colon],leng-colon, pkg->c.pkg.symvector, &hash);
-/* sym=findsymbol((char *)&token[colon],leng-colon, pkg->c.pkg.symvector, &hash);*/
- if (sym) return(sym);
- else {
- pkgstr=makestring(token,leng);
- fprintf(stderr,"%s ",token);
- vpush(pkgstr);
- error(E_EXTSYMBOL,pkgstr);}
- } }
-
-/* STUPID news does not have strtol routine!*/
-#if news || sanyo
-int strtol(str,ptr,base)
-register char *str,**ptr;
-register int base;
-{ long val=0,sign=1;
- char ch;
- while (isspace(*str)) str++;
- ch= *str;
- if (ch=='+') str++; else if (ch=='-') { str++; sign= -1;}
- if (base<=10) {
- while ('0'<= *str && *str<('0'+base)) val=val*base+(*str++)-'0';
- return(sign*val);}
- else {
- while (1) {
- if ('0'<= *str && *str<='9') val=val*base+(*str++ -'0');
- else if ('A'<= *str && *str<('A'+base-10)) val=val*base+(*str++ - 'A'+10);
- else if ('a'<= *str && *str<('a'+base-10)) val=val*base+(*str++ - 'a'+10);
- else break;
- continue;}
- return(sign*val);}}
-#endif
-
-static pointer readint(ctx,token,len)
-context *ctx;
-char *token;
-int len;
-{ int base=intval(Spevalof(READBASE));
- int head,i,sign=1, k;
- pointer b;
-
- if (len<8) {
- i=strtol(token,NULL,base);
- return(makeint(i));}
- else {
- if (token[0]=='+') { head=1;}
- else if (token[0]=='-') {head=1; sign= -1;}
- else head=0;
- b=(pointer)makebig1(0);
- vpush(b);
- for (i=head; i='0' && k<='9') k= k-'0';
- else if (k>='A' && k<='Z') k=k-'A'+10;
- else if (k>='a' && k<='z') k=k-'a'+10;
- else if (k=='.') continue;
- else error(E_USER,(pointer)"illegal integer consituent char");
- mul_int_big(base,b);
- add_int_big(k,b); }
- if (sign<0) complement_big(b);
- b=(pointer)normalize_bignum(b);
- }
- ctx->lastalloc= vpop();
- return(b);}
-
-is_digit(ch,base)
-register int ch,base;
-{ if (ch<'0') return(FALSE);
- if (base<=10)
- if (ch<'0'+base) return(TRUE);
- else return(FALSE);
- else if (ch<='9') return(TRUE);
- else if ('A'<=ch && ch<'A'+base-10) return(TRUE);
- else return(FALSE);}
-
-pointer read_delimited_list(ctx,f,delim_char,token)
-register context *ctx;
-pointer f;
-int delim_char;
-char token[];
-{ pointer result=NIL;
- pointer temp,element;
- Char ch;
- ch=nextch(ctx,f);
- vpush(STOPPER); /*marker*/
- while (ch!=delim_char && ch!=EOF) {
- if (ch=='.') {
- ch=readch(f); unreadch(f,ch);
- if (syntaxtype(ch)==ch_constituent) {
- token[0]='.';
- element=read2(ctx,f,0,0,1,token, -1);}
- else if (syntaxtype(ch)==ch_white) {
- result=read1(ctx,f);
- ch=nextch(ctx,f);
- if (ch!=delim_char) error(E_READ);
- break;}
- else error(E_READ);}
- else { unreadch(f,ch); element=read1(ctx,f);}
- if (element!=UNBOUND && element!=(pointer)EOF) ckpush(element);
- ch=nextch(ctx,f);}
- while ((element=vpop())!=STOPPER) {
- temp=cons(ctx,element,result);
- if (islabref(element)) addunsolved(element,&temp->c.cons.car);
- if (islabref(result)) addunsolved(result,&temp->c.cons.cdr);
- result=temp;}
- return(result); }
-
-static pointer readlist(ctx,f,ch,token)
-register context *ctx;
-pointer f;
-char ch, token[];
-{ return(read_delimited_list(ctx,f,')',token));}
-
-static pointer readquote(ctx,f)
-register context *ctx;
-pointer f;
-{ pointer q;
- q=read1(ctx,f);
- if (q==(pointer)EOF) return((pointer)EOF);
- return(cons(ctx,QUOTE,cons(ctx,q,NIL)));}
-
-static pointer readcomment(ctx,f)
-pointer f;
-{ register Char ch;
- do { ch=readch(f);} while (ch!='\n' && ch!=EOF);
- return(UNBOUND);}
-
-static pointer readrparen(ctx,f)
-{ return(UNBOUND);}
-
-
-
-int gcd(u,v)
-register int u,v;
-{ register int t;
- if(u<0) u = -u;
- if(v<0) v = -v;
- if(uc.rdtab.readcase;
-
- if (multiescaped) goto step9;
- step8:
- if (i>=MAXTOKENLENGTH) error(E_LONGSTRING);
- ch=readch(ins);
- if (ch==EOF) goto step10;
- if (ch<0) ch &= 0xff;
- ctype=syntaxtype(ch);
- switch(ctype) {
- case ch_constituent: case ch_nontermacro:
- if (charattr[ch]==package_marker) colon=i;
- if (readcase==K_DOWNCASE) ch=to_lower(ch);
- else if (readcase==K_PRESERVE) ch=ch;
- else ch=to_upper(ch);
- token[i++]=ch; goto step8;
- case ch_sglescape:
- token[i++]=readch(ins); escaped=1; goto step8;
- case ch_multiescape:
- goto step9;
- case ch_illegal:
- error(E_ILLCH,makeint(ch)); break;
- case ch_termmacro:
- unreadch(ins,ch); goto step10;
- case ch_white:
- unreadch(ins,ch); goto step10;
- default: error(E_USER,(pointer)"unknown char type");}
- step9:
- escaped=1;
- if (i>=MAXTOKENLENGTH) error(E_LONGSTRING);
- ch=readch(ins);
- if (ch==EOF) error(E_EOF);
- ch &= 0xff;
- ctype=syntaxtype(ch);
- switch(ctype) {
- case ch_constituent: case ch_white:
- case ch_nontermacro: case ch_termmacro:
- token[i++]=ch; goto step9;
- case ch_sglescape:
- ch=readch(ins); token[i++]=ch; goto step9;
- case ch_multiescape:
- goto step8;
- default: error(E_ILLCH,makeint(ch));}
- step10:
- /*token is accumulated; analyze syntax*/
- token[i]=0;
- if (escaped) return(readsymbol(ctx,i,colon,token));
- base=intval(Spevalof(READBASE));
-
- j=0;
- if ((token[j]=='+') || (token[j]=='-')) j++;
- else if (token[j]=='.' && token[j+1]=='\0')
- return(readsymbol(ctx,i,colon,token));
- if (is_digit(token[j],base) || token[j]=='.') {
- while (is_digit(token[j],base)) j++;
- if (token[j] == '.') { /*float?*/
- if (++j==i) return(readint(ctx,token,i));
- /*float or symbol*/
- while (is_digit(token[j],base)) j++;
- c=to_upper(token[j]);
- if (c=='E' || c=='D' || c=='F' || c=='L') {
- c=j; j++;
- if ((token[j]=='+') || (token[j]=='-')) j++;
- while (is_digit(token[j],base)) j++;
- if (j==i) { token[c]='E'; return(makeflt(atof(token)));}
- else return(readsymbol(ctx,i,colon,token));}
- else if (j==i) return(makeflt(atof(token)));
- else return(readsymbol(ctx,i,colon,token));}
- else if (token[j] == '/') { /* ratio? */
- slash=j;
- if (++j==i) return(readsymbol(i,colon));
- /*ratio or symbol*/
- while (is_digit(token[j],base)) j++;
- if (j==i) return(readratio(ctx,token,slash));
- else return(readsymbol(i,colon));}
- else if (j==i) return(readint(ctx,token,i));
- else {
- c=to_upper(token[j]);
- if (c=='E' || c=='D' || c=='F' || c=='L') {
- c=j; j++;
- if ((token[j]=='+') || (token[j]=='-')) j++;
- while (is_digit(token[j],base)) j++;
- if (j==i) {/*all digits*/ token[c]='E'; return(makeflt(atof(token)));}
- else return(readsymbol(ctx,i,colon,token));}
- else if (j==i) return(makeflt(atof(token)));
- else return(readsymbol(ctx,i,colon,token));} }
- else return(readsymbol(ctx,i,colon,token));}
-
-static pointer read1(ctx,ins)
-register context *ctx;
-register pointer ins;
-{ register enum ch_type ctype;
- register int firstch;
- register pointer macrofunc,result;
- pointer (*intmac)();
- int colon;
-/* Char ch; */
- int ch;
- char token[MAXTOKENLENGTH];
- pointer readcase;
-
- colon= -1;
- step1:
- ch=readch(ins);
- if (ch==EOF) return((pointer)EOF);
- ch &= 0xff;
- firstch=ch;
- ctype=syntaxtype(ch);
- switch(ctype) {
- case ch_illegal: error(E_ILLCH,makeint(ch));
- case ch_white: goto step1;
- case ch_termmacro: case ch_nontermacro:
- macrofunc=Spevalof(QREADTABLE)->c.rdtab.macro->c.vec.v[ch];
- if (macrofunc==NIL) error(E_USER,(pointer)"no char macro defined");
- if (isint(macrofunc)) { /*internal macro*/
- intmac=(pointer (*)())(intval(macrofunc));
- result=(*intmac)(ctx,ins,ch,token);}
- else {
- vpush(ins); vpush(makeint(ch));
- result=ufuncall(ctx,macrofunc,macrofunc,(pointer)(ctx->vsp-2),NULL,2);
- ctx->vsp-=2;}
-/* if (result==UNBOUND && firstch!=')') goto step1;
- else return(result);*/
- return(result);
- case ch_sglescape: token[0]=readch(ins);
- return(read2(ctx,ins,1,0,1,token,colon));
- case ch_multiescape: return(read2(ctx,ins,1,1,0,token,colon));
- case ch_constituent:
- if (charattr[ch]==package_marker) colon=0;
- readcase=Spevalof(QREADTABLE)->c.rdtab.readcase;
- if (readcase==K_DOWNCASE) ch=to_lower(ch);
- else if (readcase==K_PRESERVE) ch=ch;
- else ch=to_upper(ch);
- token[0]= ch;
- return(read2(ctx,ins,0,0,1,token,colon));}}
-
-pointer reader(ctx,f,recursivep)
-register context *ctx;
-register pointer f,recursivep;
-{ register pointer val;
- Char ch;
- current_syntax=Spevalof(QREADTABLE)->c.rdtab.syntax->c.str.chars;
- ch=nextch(ctx,f);
- if (ch==EOF) return((pointer)EOF);
- while (ch==')') ch=nextch(ctx,f);
- unreadch(f,ch);
- if (recursivep==NIL) {
- oblabels->c.lab.next=NIL;
- val=read1(ctx,f);
- oblabels->c.lab.next=NIL;}
- else val=read1(ctx,f); /*if called recursively, keep #n= scope*/
- if (val==UNBOUND) return(NIL);
- return(val);}
-
-initreader(ctx)
-register context *ctx;
-{ register pointer rdtable;
- register int i;
-
- charmacro['(']=makeint(readlist);
- charmacro[')']=makeint(readrparen);
- charmacro['#']=makeint(readsharp);
- charmacro['\'']=makeint(readquote);
- charmacro['"']=makeint(readstring);
- charmacro[';']=makeint(readcomment);
-
- sharpmacro['\\']=makeint(read_sharp_char);
- sharpmacro['\'']=makeint(read_sharp_function);
- sharpmacro[':']=makeint(read_uninterned_symbol);
- sharpmacro[',']=makeint(read_sharp_eval);
- sharpmacro['.']=makeint(read_sharp_eval);
- sharpmacro['|']=makeint(read_sharp_comment);
- sharpmacro['+']=makeint(read_cond_plus);
- sharpmacro['-']=makeint(read_cond_minus);
- sharpmacro['#']=makeint(readlabref);
- sharpmacro['=']=makeint(readlabdef);
- sharpmacro['(']=makeint(readvector);
- sharpmacro['<']=makeint(read_sharp_object);
- sharpmacro['X']=makeint(read_sharp_hex);
- sharpmacro['O']=makeint(read_sharp_octal);
- sharpmacro['S']=makeint(readstructure);
- sharpmacro['F']=makeint(readfvector);
- sharpmacro['I']=makeint(readivector);
- sharpmacro['J']=makeint(readobject);
- sharpmacro['V']=makeint(readobject);
-
- /* make default readtable */
- rdtable=(pointer)makereadtable(ctx);
- Spevalof(QREADTABLE)=rdtable;
- for (i=0; i<256; i++) {
- rdtable->c.rdtab.syntax->c.str.chars[i]=(int)chartype[i];
- rdtable->c.rdtab.macro->c.vec.v[i]=charmacro[i];
- rdtable->c.rdtab.dispatch->c.vec.v[i]=sharpmacro[i];
- rdtable->c.rdtab.readcase=K_UPCASE;
- }
- }
diff --git a/lisp/c/sequence.c b/lisp/c/sequence.c
index e4b857e40..366a345b2 100644
--- a/lisp/c/sequence.c
+++ b/lisp/c/sequence.c
@@ -126,11 +126,11 @@ pointer argv[];
s=ckintval(argv[1]);
if (n==3) {
e=ckintval(argv[2]);
- if (ec.ivec.iv[n/32]|=(coerceintval(vpop()) & 1)<<(n%32);
#endif
return(r);
- case ELM_FOREIGN: error(E_USER,(pointer)"cannot coerce to foreign string"); } } }
+ case ELM_FOREIGN: error(E_TYPE_ERROR,(pointer)"cannot coerce to foreign string"); } } }
pointer CONCATENATE(ctx,n,argv)
register context *ctx;
@@ -675,7 +675,7 @@ register pointer argv[];
while (pushcount-->0) seq=cons(ctx,vpop(),seq);
return(seq);}
else {
- pushcount+=pushsequence(ctx,seq,end,MAX_SEQUENCE_COUNT);
+ pushcount+=pushsequence(ctx,seq,start,MAX_SEQUENCE_COUNT);
return(makesequence(ctx,pushcount,classof(seq)));}}
pointer REMOVE_DUPLICATES(ctx,n,argv)
@@ -767,7 +767,12 @@ pointer argv[];
lastindex++;} }
else error(E_SEQINDEX);
start++; }
- if (isvector(result)) result->c.vec.size=makeint(lastindex);
+ if (isvector(result)) {
+ end=vecsize(seq);
+ while (startc.vec.size=makeint(lastindex);}
return(result);}
pointer SUBSTITUTE(ctx,n,argv)
@@ -809,7 +814,7 @@ register pointer argv[];
while (pushcount-->0) seq=cons(ctx,vpop(),seq);
return(seq);}
else {
- pushcount+=pushsequence(ctx,seq,end,MAX_SEQUENCE_COUNT);
+ pushcount+=pushsequence(ctx,seq,pushcount,MAX_SEQUENCE_COUNT);
return(makesequence(ctx,pushcount,classof(seq)));}}
pointer NSUBSTITUTE(ctx,n,argv)
@@ -1007,7 +1012,11 @@ pointer argv[];
else if (isvector(seq)) {
COMPTYPE=elmtypeof(seq);
if (COMPTYPE==ELM_CHAR || COMPTYPE==ELM_BYTE) width=1;
- else if (COMPTYPE==ELM_BIT || COMPTYPE==ELM_FOREIGN) error(E_NOVECTOR);
+ else if (COMPTYPE==ELM_BIT || COMPTYPE==ELM_FOREIGN) {
+#if THREADED
+ mutex_unlock(&qsort_lock);
+#endif
+ error(E_NOVECTOR);}
else width=sizeof(eusinteger_t);
qsort(seq->c.vec.v,vecsize(seq),width,(int (*)())compar);}
#if THREADED
@@ -1050,7 +1059,7 @@ pointer argv[];
else if (isvector(a)) return((pointer)vref(a,i));
else if (isarray(a) && a->c.ary.rank==makeint(1))
return((pointer)vref(a->c.ary.entity, i));
- else error(E_USER,(pointer)"no sequence");}
+ else error(E_NOSEQ);}
pointer SETELT(ctx,n,argv)
register context *ctx;
@@ -1064,7 +1073,11 @@ register pointer argv[];
while (i-->0 && islist(a)) a=ccdr(a);
if (islist(a)) {pointer_update(ccar(a),argv[2]);return(argv[2]);}
else error(E_SEQINDEX);}
- else { vset(a,i,argv[2]); return(argv[2]);}}
+ else if (isvector(a)) { vset(a,i,argv[2]); return(argv[2]);}
+ else if (isarray(a) && a->c.ary.rank==makeint(1)) {
+ vset(a->c.ary.entity,i,argv[2]);
+ return(argv[2]);}
+ else error(E_NOSEQ);}
void sequence(ctx,mod)
diff --git a/lisp/c/specials.c b/lisp/c/specials.c
index 18df67935..131aee3f4 100644
--- a/lisp/c/specials.c
+++ b/lisp/c/specials.c
@@ -15,7 +15,7 @@ static char *rcsid="@(#)$Id$";
#include "eus.h"
extern pointer MACRO,LAMBDA,LAMCLOSURE;
extern pointer K_FUNCTION_DOCUMENTATION;
-extern struct bindframe *declare();
+extern pointer declare();
#ifdef EVAL_DEBUG
extern int evaldebug;
@@ -139,17 +139,7 @@ pointer arg;
printf( "FUNCTION_CLOSURE:" );
hoge_print( arg );
#endif
- arg=ccar(arg);
- if (issymbol(arg)) { funcname=arg; arg=getfunc(ctx,arg);}
- else funcname=NIL;
- if (iscode(arg)) return(arg);
- else if (ccar(arg)==LAMCLOSURE) return(arg);
- else if (ccar(arg)==LAMBDA) {
- arg=cons(ctx,makeint(hide_ptr((pointer)(ctx->fletfp))),ccdr(arg));
- arg=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),arg);
- arg=cons(ctx,funcname,arg);
- return(cons(ctx,LAMCLOSURE,arg));}
- else error(E_ILLFUNC);}
+ return getfunc_closure(ctx,ccar(arg));}
pointer MACEXPAND2(ctx,n,argv)
register context *ctx;
@@ -180,10 +170,10 @@ register pointer argv[];
#endif // ARM
if (mac->c.code.subrtype!=(pointer)SUBR_MACRO) return(argv[0]);
#if ARM
- expander=makecode(mac,(pointer (*)())addr,SUBR_FUNCTION);
+ expander=makecode(ctx,mac,(pointer (*)())addr,SUBR_FUNCTION,NULL);
pointer_update(expander->c.code.entry2,mac->c.code.entry2)
#else
- expander=makecode(mac,(pointer (*)())mac->c.code.entry,SUBR_FUNCTION);
+ expander=makecode(ctx,mac,(pointer (*)())mac->c.code.entry,SUBR_FUNCTION,NULL);
#endif
pointer_update(expander->c.code.entry,mac->c.code.entry);}
else if (carof(mac,E_NOLIST)==MACRO) expander=cons(ctx,LAMBDA,ccdr(mac));
@@ -215,6 +205,7 @@ register pointer *argv;
}
printf( "\n" );
#endif
+ if(!(iscons(argv[1]) || argv[1]==NIL)) error(E_NOLIST);
while (islist(argv[1])) {
i=1;
while (ivsp,result;
struct blockframe *myblock;
- struct bindframe *bfp=ctx->bindfp;
+ pointer bfp=ctx->bindfp;
+ pointer ffp=ctx->fletfp;
jmp_buf whilejmp;
int i;
@@ -379,12 +371,16 @@ pointer arg;
myblock=(struct blockframe *)
makeblock(ctx,BLOCKFRAME,NIL,&whilejmp,ctx->blkfp); /* ???? */
if ((result=(pointer)eussetjmp(whilejmp))==0) {
- while (eval(ctx,cond)!=NIL) {GC_POINT;progn(ctx,body);}
+ while (eval(ctx,cond)!=NIL) {
+ GC_POINT;
+ breakck;
+ progn(ctx,body);}
result=NIL;}
else if ((eusinteger_t)result==1) result=makeint(0);
ctx->blkfp=myblock->dynklink;
ctx->vsp=spsave;
ctx->bindfp=bfp;
+ ctx->fletfp=ffp;
return(result);}
pointer COND(ctx,arg)
@@ -409,7 +405,7 @@ pointer PARLET(ctx,args) /*let special form*/
register context *ctx;
pointer args;
{ pointer vlist,vlistsave,var,init,body,result,decl,*spsave=ctx->vsp,*vinits;
- register struct bindframe *env, *bfsave=ctx->bindfp, *declenv;
+ pointer env, bfsave=ctx->bindfp, declenv;
struct specialbindframe *sbfps=ctx->sbindfp;
int i=0,vcount=0;
#if defined(PARLET_DEBUG) || defined(DEBUG_COUNT)
@@ -464,7 +460,7 @@ pointer SEQLET(ctx,args) /* let* special form*/
register context *ctx;
pointer args;
{ pointer vlist,var,init,body,result,decl,*spsave=ctx->vsp;
- register struct bindframe *bf=ctx->bindfp, *env;
+ pointer bf=ctx->bindfp, env;
struct specialbindframe *sbfps=ctx->sbindfp;
#ifdef SPEC_DEBUG
@@ -559,11 +555,29 @@ register pointer arg;
throw(ctx,tag,result);
error(E_NOCATCHER,tag);}
+pointer MACROLET(ctx,arg)
+register context *ctx;
+register pointer arg;
+{ register pointer macs, mac;
+ pointer ffp=ctx->fletfp;
+ pointer result;
+#ifdef SPEC_DEBUG
+ printf( "MACROLET:" ); hoge_print(arg);
+#endif
+ GC_POINT;
+ macs=ccar(arg);
+ while (iscons(macs)) {
+ mac=ccar(macs); macs=ccdr(macs);
+ makemacrolet(ctx,ccar(mac),ccdr(mac),ctx->fletfp);}
+ result=progn(ctx,ccdr(arg));
+ ctx->fletfp=ffp;
+ return(result);}
+
pointer FLET(ctx,arg)
register context *ctx;
register pointer arg;
{ register pointer fns, fn;
- register struct fletframe *ffp=ctx->fletfp;
+ pointer ffp=ctx->fletfp;
pointer result;
#ifdef SPEC_DEBUG
printf( "FLET:" ); hoge_print(arg);
@@ -581,7 +595,7 @@ pointer LABELS(ctx,arg)
register context *ctx;
register pointer arg;
{ register pointer fns, fn;
- register struct fletframe *ffp=ctx->fletfp, *ffpp;
+ pointer ffp=ctx->fletfp, ffpp;
pointer result;
#ifdef SPEC_DEBUG
printf( "LABELS:" ); hoge_print(arg);
@@ -593,9 +607,9 @@ register pointer arg;
makeflet(ctx,ccar(fn),ccdr(fn),ctx->fletfp,ctx->fletfp);}
fns=ccar(arg); ffpp=ctx->fletfp;
while (iscons(fns)) { /*allow mutual references between labels functions*/
- fn=ffpp->fclosure;
- fn=ccdr(fn); fn=ccdr(fn); fn=ccdr(fn); ccar(fn)=makeint(hide_ptr((pointer)(ctx->fletfp)));
- fns=ccdr(fns); ffpp=ffpp->lexlink;}
+ fn=ffpp->c.ffp.fclosure;
+ fn=ccdr(fn); fn=ccdr(fn); fn=ccdr(fn); ccar(fn)=ctx->fletfp;
+ fns=ccdr(fns); ffpp=ffpp->c.ffp.next;}
result=progn(ctx,ccdr(arg));
ctx->fletfp=ffp;
return(result);}
@@ -614,7 +628,7 @@ pointer *argv;
printf( "\n" );
#endif
throw(ctx,makeint(0),T);
- error(E_USER,(pointer)"cannot reset");}
+ error(E_NOCATCHER,makeint(0));}
pointer EVALHOOK(ctx,n,argv)
register context *ctx;
@@ -649,7 +663,8 @@ register context *ctx;
register pointer arg; /*must be called via ufuncall*/
{ pointer name,result,*spsave=ctx->vsp;
struct blockframe *myblock;
- struct bindframe *bfp=ctx->bindfp;
+ pointer bfp=ctx->bindfp;
+ pointer ffp=ctx->fletfp;
jmp_buf blkjmp;
#ifdef SPEC_DEBUG
printf( "BLOCK:" ); hoge_print(arg);
@@ -664,6 +679,7 @@ register pointer arg; /*must be called via ufuncall*/
ctx->blkfp=myblock->dynklink;
/*restorations of bindfp and callfp are caller's responsibility???*/
ctx->bindfp=bfp;
+ ctx->fletfp=ffp;
ctx->vsp=spsave;
return(result);}
@@ -717,8 +733,8 @@ pointer arg;
protform=ccar(arg);
if (islist(arg)) cleanupform=ccdr(arg); else cleanupform=NIL;
cleaner=cons(ctx,NIL,cleanupform);
- cleaner=cons(ctx,makeint(hide_ptr((pointer)(ctx->fletfp))),cleaner);
- cleaner=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),cleaner);
+ cleaner=cons(ctx,ctx->fletfp,cleaner);
+ cleaner=cons(ctx,ctx->bindfp,cleaner);
cleaner=cons(ctx,NIL,cleaner);
cleaner=cons(ctx,LAMCLOSURE,cleaner);
/*(LAMDA-CLOSURE bindfp fletfp () . body) */
@@ -740,7 +756,8 @@ pointer arg;
jmp_buf tagjmp;
struct blockframe *tagblock;
pointer *spsave=ctx->vsp, *tagspsave;
- struct bindframe *bfpsave=ctx->bindfp;
+ pointer bfpsave=ctx->bindfp;
+ pointer ffpsave=ctx->fletfp;
#ifdef SPEC_DEBUG
printf( "TAGBODY:" ); hoge_print(arg);
#endif
@@ -757,6 +774,7 @@ pointer arg;
{
ctx->vsp=tagspsave;
ctx->bindfp=bfpsave;
+ ctx->fletfp=ffpsave;
while (iscons(forms)) {
GC_POINT;
p=ccar(forms);
@@ -774,7 +792,7 @@ pointer arg;
#ifdef SPEC_DEBUG
printf( "GO:" ); hoge_print( arg );
#endif
- tag=carof(arg,"GO TAG?");
+ tag=carof(arg,E_MISMATCHARG);
while (ctx->blkfp!=NULL) {
if (ctx->blkfp->kind==TAGBODYFRAME &&
(body=(pointer)assq(tag,ctx->blkfp->name))!=NIL) {
@@ -782,7 +800,7 @@ pointer arg;
euslongjmp(*(ctx->blkfp->jbp),body);}/* ???? */
/* euslongjmp(*(ctx->blkfp->jbp),body);} *//* ??? eus_rbar */
ctx->blkfp=ctx->blkfp->lexklink;}
- error(E_USER,(pointer)"go tag not found");}
+ error(E_PROGRAM_ERROR,(pointer)"go tag not found");}
pointer EVALWHEN(ctx,arg)
register context *ctx;
@@ -826,7 +844,7 @@ pointer arg;
pointer AND(ctx,arg) /*special form (should be macro)*/
register context *ctx;
register pointer arg;
-{ register pointer r;
+{ register pointer r = T;
#ifdef SPEC_DEBUG
printf( "AND:" ); hoge_print( arg );
#endif
@@ -865,7 +883,7 @@ pointer argv[];
GC_POINT;
while (ic.sym.spefunc,argv[1]);
return(argv[1]);}
pointer SYMFUNC(ctx,n,argv)
@@ -1051,6 +1069,18 @@ pointer *argv;
pointer_update(argv[0]->c.sym.speval,UNBOUND);
return(T);}
+pointer FMAKUNBOUND(ctx,n,argv)
+register context *ctx;
+int n;
+pointer *argv;
+{ ckarg(1);
+ if (!issymbol(argv[0])) error(E_NOSYMBOL);
+#ifdef SPEC_DEBUG
+ printf( "FMAKEUNBOUND:" ); hoge_print( argv[0] );
+#endif
+ pointer_update(argv[0]->c.sym.spefunc,UNBOUND);
+ return(T);}
+
void set_special(ctx, var, val)
context *ctx;
pointer var, val;
@@ -1114,12 +1144,11 @@ pointer argv[];
{ pointer str,sym,pkg;
ckarg2(1,2);
str=argv[0];
+ if (!isstring(str)) error(E_NOSTRING);
if (n==2) {
pkg=findpkg(argv[1]);
- if (pkg==NULL) error(E_NOPACKAGE);}
+ if (pkg==NULL) error(E_NOPACKAGE,argv[1]);}
else pkg=Spevalof(PACKAGE);
- if (!ispackage(pkg)) error(E_NOPACKAGE);
- if (!isstring(str)) error(E_NOSTRING);
#ifdef SPEC_DEBUG
printf( "FINDSYMBOL:" );
{ int i;
@@ -1141,9 +1170,11 @@ register pointer argv[];
int x;
ckarg2(1,3);
str=argv[0];
- if (n>=2) pkg=findpkg(argv[1]);
- else pkg=Spevalof(PACKAGE);
if (!isstring(str)) error(E_NOSTRING);
+ if (n>=2) {
+ pkg=findpkg(argv[1]);
+ if (pkg==NULL) error(E_NOPACKAGE,argv[1]);}
+ else pkg=Spevalof(PACKAGE);
#ifdef SPEC_DEBUG
printf( "INTERN:" );
{ int i;
@@ -1173,25 +1204,42 @@ pointer argv[];
}
printf( "\n" );
#endif
-
- if (n==1) {
- n--;
+ ckarg2(0,1);
+ if (n==0) return(gensym(ctx));
+ char* prefix;
+ int counter;
if (isstring(argv[0])) {
if (intval(argv[0]->c.str.length)>50) error(E_LONGSTRING);
- genhead=argv[0];}
- else if (isint(argv[0])) genindex=intval(argv[0]);
+ prefix=argv[0]->c.str.chars;
+ counter=genindex++;}
+ else if (isint(argv[0])) {
+ prefix=genhead->c.str.chars;
+ counter=intval(argv[0]);}
else error(E_NOSTRING);
- }
- ckarg(0);
- return(gensym(ctx));}
+
+ byte buf[64];
+ sprintf((char *)buf,"%s%d",prefix,counter);
+ return(makesymbol(ctx,(char *)buf,strlen(buf),NIL));
+}
+
+pointer getprop(ctx,sym,attr,retval)
+register context *ctx;
+register pointer sym,attr,retval;
+{ register pointer p;
+ p=sym->c.sym.plist;
+ while (iscons(p)) {
+ if (!iscons(ccar(p))) error(E_NOLIST);
+ if (ccar(ccar(p))==attr) return(ccdr(ccar(p)));
+ else p=ccdr(p);
+ }
+ return(retval);}
pointer GETPROP(ctx,n,argv)
register context *ctx;
int n;
register pointer argv[];
-{ register pointer p,attr=argv[1];
- ckarg2(2,3);
- if (!ispropobj(argv[0]) || !ispropobj(attr)) error(E_NOSYMBOL);
+{ ckarg2(2,3);
+ if (!ispropobj(argv[0]) || !ispropobj(argv[1])) error(E_NOSYMBOL);
#ifdef SPEC_DEBUG
printf( "GETPROP:" );
{ int i;
@@ -1200,11 +1248,7 @@ register pointer argv[];
}
printf( "\n" );
#endif
- p=argv[0]->c.sym.plist;
- while (iscons(p))
- if (ccar(ccar(p))==attr) return(ccdr(ccar(p)));
- else p=ccdr(p);
- if (n==3) return(argv[2]); else return(NIL);}
+ return(getprop(ctx,argv[0],argv[1],n>=3?argv[2]:NIL));}
pointer EXPORT (ctx,n,argv) /*further name conflict checks should be
performed by EusLisp*/
@@ -1222,9 +1266,10 @@ register pointer argv[];
printf( "\n" );
#endif
sym=argv[0];
- if (n==2) pkg = findpkg(argv[1]);
+ if (n==2) {
+ pkg = findpkg(argv[1]);
+ if (pkg==NULL) error(E_NOPACKAGE,argv[1]);}
else pkg=Spevalof(PACKAGE);
- if (!ispackage(pkg)) error(E_NOPACKAGE);
if (issymbol(sym)) export(sym,pkg);
else if (iscons(sym))
while (iscons(sym)) {
@@ -1241,16 +1286,17 @@ register pointer sym,val,attr;
if (ccar(ccar(p))==attr) { pointer_update(ccdr(ccar(p)),val); return(val);}
else p=ccdr(p);
/* no such a property; create it */
+ vpush(sym);
p=cons(ctx,attr,val);
pointer_update(sym->c.sym.plist,cons(ctx,p,sym->c.sym.plist));
+ vpop(); // sym
return(val);}
pointer PUTPROP(ctx,n,argv) /*(putprop sym val attr)*/
register context *ctx;
int n;
register pointer argv[];
-{ register pointer p,pp;
- ckarg(3);
+{ ckarg(3);
if (!ispropobj(argv[0]) || !ispropobj(argv[2])) error(E_NOSYMBOL);
#ifdef SPEC_DEBUG
printf( "PUTPROP:" );
@@ -1309,6 +1355,7 @@ pointer mod;
defspecial(ctx,"UNWIND-PROTECT",mod,UNWINDPROTECT);
defspecial(ctx,"CATCH",mod,CATCH);
defspecial(ctx,"THROW",mod,THROW);
+ defspecial(ctx,"MACROLET",mod,MACROLET);
defspecial(ctx,"FLET",mod,FLET);
defspecial(ctx,"LABELS",mod,LABELS);
defspecial(ctx,"BLOCK",mod,BLOCK);
@@ -1330,6 +1377,7 @@ pointer mod;
defun(ctx,"SYMBOL-BOUND-VALUE",mod,SYMBNDVALUE,NULL);
defun(ctx,"SYMBOL-FUNCTION",mod,SYMFUNC,NULL);
defun(ctx,"MAKUNBOUND",mod,MAKUNBOUND,NULL);
+ defun(ctx,"FMAKUNBOUND",mod,FMAKUNBOUND,NULL);
defun(ctx,"SET",mod,SETSPECIAL,NULL);
defspecial(ctx,"DEFUN",mod,DEFUN);
defspecial(ctx,"DEFMACRO",mod,DEFMACRO);
diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c
index 3e7bdec60..6c77cfe1c 100644
--- a/lisp/c/sysfunc.c
+++ b/lisp/c/sysfunc.c
@@ -22,7 +22,14 @@ pointer GEESEE(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
-{ gc();
+{
+#if THREADED
+ mutex_lock(&alloc_lock);
+#endif
+ gc();
+#if THREADED
+ mutex_unlock(&alloc_lock);
+#endif
return(cons(ctx,makeint(freeheap),
cons(ctx,makeint(totalheap),NIL)));}
@@ -72,7 +79,7 @@ pointer argv[];
if (n==0) return(makeint((ctx->stacklimit+100-ctx->stack)));
else {
newsize=ckintval(argv[0]);
- if (newsize>1024*1024*256) error(E_USER,(pointer)"too big stack"); /*max 256MW*/
+ if (newsize>1024*1024*256) error(E_PROGRAM_ERROR,(pointer)"too big stack"); /*max 256MW*/
allocate_stack(ctx,newsize);
euslongjmp(topjbuf,newsize);}
}
@@ -516,7 +523,7 @@ pointer argv[];
vpush(makepointer(b));
if (ctx->vsp >= ctx->stacklimit) {
sweepall();
- error(E_USER,(pointer)"not enough stack space");}} }
+ error(E_PROGRAM_ERROR,(pointer)"not enough stack space");}} }
b=nextbuddy(b);} }
sweepall();
#if THREADED
@@ -565,7 +572,7 @@ pointer argv[];
vpush(p);
if (ctx->vsp>=ctx->stacklimit) {
sweepall();
- error(E_USER,(pointer)"not enough stack space");} }
+ error(E_PROGRAM_ERROR,(pointer)"not enough stack space");} }
next_buddy:
b=nextbuddy(b);} }
sweepall();
@@ -634,7 +641,7 @@ pointer argv[];
if (size==K_FLOAT) return(makeflt(u->f));
if (size==K_DOUBLE) return(makeflt(u->d));
if (size==K_POINTER) return(mkbigint((eusinteger_t)(u->p))); /* ???? */
- else error(E_USER,(pointer)"unknown access mode");}
+ else error(E_PROGRAM_ERROR,(pointer)"unknown access mode");}
pointer POKE(ctx,n,argv)
register context *ctx;
@@ -680,13 +687,71 @@ pointer argv[];
else if (size==K_FLOAT) u->f=ckfltval(val);
else if (size==K_DOUBLE) u->d=ckfltval(val);
else if (size==K_POINTER) u->p=(void*)ckintval(val);
- else error(E_USER,(pointer)"unknown access mode");
+ else error(E_PROGRAM_ERROR,(pointer)"unknown access mode");
return(val);}
/****************************************************************/
/* stack frame access
/* 1988-Apr-26
/****************************************************************/
+pointer list_callstack(ctx,max)
+register context *ctx;
+int max;
+{ register struct callframe *vf;
+ int i;
+ vf=(struct callframe *)(ctx->callfp);
+ if(vf==NULL) return(NIL);
+ // list whole stack for negative max values
+ for (i=0; vf->vlink && max; vf=vf->vlink) {
+ if (vf->form) {
+ vpush(vf->form);
+ // calculate max based on collected elements, rather than transversed frames
+ i++; max--;}
+ // Check for recursive stacks
+ if ((pointer)vf == (pointer)vf->vlink) {
+ fprintf(stderr,";; recursive callstack detected in %p\n", (pointer)vf);
+ break;}}
+ return(stacknlist(ctx,i));}
+
+pointer LISTCALLSTACK(ctx,n,argv)
+register context *ctx;
+int n;
+pointer *argv;
+{ int i,max=-1;
+ ckarg2(0,1);
+ if(n) max=max(0,intval(argv[0]));
+ return(list_callstack(ctx,max));}
+
+pointer LISTALLBLOCKS(ctx,n,argv)
+register context *ctx;
+int n;
+pointer *argv;
+{ struct blockframe *bfp=ctx->blkfp;
+ int i=0;
+ while (bfp) {
+ if (bfp->kind==BLOCKFRAME) {
+ vpush(bfp->name);
+ i++;}
+ bfp=bfp->lexklink;}
+ return(stacknlist(ctx,i));}
+
+pointer LISTALLTAGS(ctx,n,argv)
+register context *ctx;
+int n;
+pointer *argv;
+{ struct blockframe *bfp=ctx->blkfp;
+ int i=0;
+ while (bfp) {
+ if (bfp->kind==TAGBODYFRAME) {
+ pointer body=bfp->name;
+ while (body!=NIL) {
+ vpush(ccar(ccar(body)));
+ body=ccdr(body);
+ i++;}
+ }
+ bfp=bfp->lexklink;}
+ return(stacknlist(ctx,i));}
+
pointer LISTALLCATCHERS(ctx,n,argv)
register context *ctx;
int n;
@@ -704,14 +769,38 @@ pointer LISTBINDINGS(ctx,n,argv)
register context *ctx;
int n;
pointer *argv;
-{ struct bindframe *bfp=ctx->bindfp, *nextbfp;
+{ pointer bf;
int i=0;
- while (bfp) {
- vpush(cons(ctx,bfp->sym,bfp->val));
+ if (n==0) {
+ bf=ctx->bindfp;}
+ if (n==1) {
+ if (isbindframe(argv[0])) bf=argv[0];
+ else if (isint(argv[0]) && intval(argv[0])==0) return(NIL);
+ else error(E_NOBINDFRAME);}
+ while (bf) {
+ vpush(cons(ctx,bf->c.bfp.sym,bf->c.bfp.val));
+ i++;
+ if (bf==bf->c.bfp.next) break;
+ bf=bf->c.bfp.next;}
+ return(stacknlist(ctx,i));}
+
+pointer LISTFUNCTIONBINDINGS(ctx,n,argv)
+register context *ctx;
+int n;
+pointer *argv;
+{ pointer ff;
+ int i=0;
+ if (n==0) {
+ ff=ctx->fletfp;}
+ if (n==1) {
+ if (isfletframe(argv[0])) ff=argv[0];
+ else if (isint(argv[0]) && intval(argv[0])==0) return(NIL);
+ else error(E_NOFLETFRAME);}
+ while (ff) {
+ vpush(cons(ctx,ff->c.ffp.name,ff->c.ffp.fclosure));
i++;
- nextbfp=bfp->dynblink;
- if (nextbfp==NULL) nextbfp=bfp->lexblink;
- bfp=nextbfp;}
+ if (ff==ff->c.ffp.next) break;
+ ff=ff->c.ffp.next;}
return(stacknlist(ctx,i));}
pointer LISTSPECIALBINDINGS(ctx,n,argv)
@@ -760,7 +849,7 @@ pointer argv[];
if (n==0) con=ctx;
else {
x=ckintval(argv[0]);
- if (x<0 || x>MAXTHREAD) error(E_USER,(pointer)"no such thread");
+ if (x<0 || x>=MAXTHREAD) error(E_INDEX_ERROR,(pointer)"no such thread");
if (x==0) con=ctx;
else con=euscontexts[x];}
p=con->specials;
@@ -799,8 +888,12 @@ pointer mod;
/* defun(ctx,"MALLOC_DEBUG",mod,MALLOC_DEBUG,NULL);
/* defun(ctx,"MALLOC_VERIFY",mod,MALLOC_VERIFY,NULL); */
defun(ctx,"LIST-ALL-REFERENCES",mod,LISTALLREFERENCES,NULL);
+ defun(ctx,"LIST-CALLSTACK",mod,LISTCALLSTACK,NULL);
+ defun(ctx,"LIST-ALL-BLOCKS",mod,LISTALLBLOCKS,NULL);
+ defun(ctx,"LIST-ALL-TAGS",mod,LISTALLTAGS,NULL);
defun(ctx,"LIST-ALL-CATCHERS",mod,LISTALLCATCHERS,NULL);
defun(ctx,"LIST-ALL-BINDINGS",mod,LISTBINDINGS,NULL);
+ defun(ctx,"LIST-ALL-FUNCTION-BINDINGS",mod,LISTFUNCTIONBINDINGS,NULL);
defun(ctx,"LIST-ALL-SPECIAL-BINDINGS",mod,LISTSPECIALBINDINGS,NULL);
defun(ctx,"LIST-ALL-CLASSES",mod,LISTALLCLASSES,NULL);
defun(ctx,"EXPORT-ALL-SYMBOLS", mod, EXPORTALL,NULL);
diff --git a/lisp/c/toplevel.l b/lisp/c/toplevel.l
deleted file mode 100644
index 8a30905b4..000000000
--- a/lisp/c/toplevel.l
+++ /dev/null
@@ -1,353 +0,0 @@
-;;;;
-;;;; euslisp toplevel loop and error/signal handler
-;;;;
-;;;; Copyright 1987,1991, Toshihiro MATSUI, Electrotechnical Laboratory
-;;; 1987-Oct
-;;; 1988 execute unix command
-;;; 1989 reset alarm signal
-;;; 1991-Aug History
-;;; 1991-Nov prompt
-;;; 1996-May *eustop-hook* to intercept control at start-up.
-
-(in-package "LISP")
-
-(export '(- * ** *** + ++ +++ *replevel* *reptype*
- *input-line*
- *prompt*
- *prompt-string*
- *history* *try-unix*
- skip-blank read-list-from-line sigint-handler *signal-handlers*
- *eustop-hook*
- *toplevel-hook*
- *top-selector*
- *timer-job*
- *top-selector-interval*
- evaluate-stream reploop
- euserror
- eustop reset
- toplevel-prompt
- ))
-
-(defvar - nil)
-(defvar * nil)
-(defvar ** nil)
-(defvar *** nil)
-(defvar + nil)
-(defvar ++ nil)
-(defvar +++ nil)
-(defvar toplevel-streams (list *standard-input*))
-(defvar toplevel-streams-bitvec)
-(defvar *eustop-hook* nil)
-(defvar *prompt*)
-(defvar *toplevel-hook*)
-
-(deflocal *replevel* 0)
-(deflocal *reptype* "")
-(deflocal *input-line*)
-(defvar *prompt-string* "eus")
-(defvar *history*)
-(defvar *tc*)
-(defvar *eustop-argument*)
-(defvar *top-selector* (instance port-selector :init))
-(defvar *timer-job* (list 'count-up-timer))
-(defvar *timer-job-count* 0)
-(defvar *top-selector-interval* 10.0)
-(defvar *use-top-selector* (not (unix:getenv "NO_TOP_SELECTOR")))
-(defparameter *try-unix* t)
-
-(eval-when (load eval)
-
-(defun count-up-timer () (incf *timer-job-count*))
-
-(defun skip-blank (s &optional (eof (gensym)))
- (let ((ch (read-char s nil eof)))
- (if (eq ch eof) (return-from skip-blank eof))
- (while (position ch " ") (setq ch (read-char s)))
- (unread-char ch s)
- ch))
-)
-
-;;
-;; read-list-from-line returns eof if eof hit
-;; if a list is entered, its list is returned
-;; otherwise, a list of all input items in a line is returned
-;;
-
-(eval-when (load eval)
-(defun read-list-from-line (&optional (s *standard-input*) (eof (gensym)))
- (let* ((ch) (instream) (sexp) (listed-sexp))
- (setq ch (skip-blank s eof) *input-line* nil)
- (cond
- ((eq ch eof) eof)
- ((eq ch #\() ;)
- (setq sexp (read s nil eof))
- (setq ch (read-char s))
- (unless (eql ch #\newline) (unread-char ch s))
- sexp)
- ((eq ch #\,)
- (read-char s)
- (setq sexp (read s))
- (read-char s)
- sexp)
- (t
- (setq *input-line*
- (read-line s nil eof)
- )
- (if (eq *input-line* eof) (return-from read-list-from-line eof))
- (make-string-input-stream *input-line*)))))
-
-
-(defun sigint-handler (sig code)
- (warning-message 1 "interrupt")
- (if (fboundp 'unix:ualarm)
- (unix:ualarm 0 0)
- (unix:alarm 0))
- (let* ((*replevel* (1+ *replevel*))
- (*reptype* "B"))
- (catch *replevel* (reploop #'toplevel-prompt))))
-
-(defvar *signal-handlers* (make-sequence vector 32))
-
-(defun eussig (sig &rest code &aux (handler (aref *signal-handlers* sig)))
- (cond (handler (funcall handler sig code))
- (t
- (if (fboundp 'unix:ualarm)
- (unix:ualarm 0 0)
- (unix:alarm 0))
- (warning-message 1 "signal ~s ~s~%" sig code)
- (let* ((*replevel* (1+ *replevel*))
- (*reptype* "S"))
- (catch *replevel*
- (reploop #'toplevel-prompt))))))
-
-(defun evaluate-stream (input)
- (let* ((eof (cons nil nil))
- (command (read input nil eof))
- (arglist) (arg) result)
- (cond ((eq command eof) )
- ((symbolp command)
-;; (if *history* (add-history (input . buffer)))
- (cond ((fboundp command)
- (setq arglist nil)
- (while (not (eq (setq arg (read input nil eof)) eof))
- (push arg arglist))
- (setq - (cons command (nreverse arglist)))
- (setq result (eval -)))
- ((and (boundp command)
- (eq (read input nil eof) eof))
- (setq - command)
- (setq result (eval command)))
- ((find-package (string command)) (in-package (string command)))
- (*try-unix*
- (setq - (list 'unix:system (input . buffer)))
- (setq result (unix:system (input . buffer)) ) )
- (t (warn "?~%")) ))
- (t
-;; (if *history* (add-history (input . buffer)))
- (setq - command)
- (setq result (eval command)) ))
- result))
-
-(defun toplevel-prompt (strm)
- (if *history*
- (format strm "~d." (1+ *history-sequence*)))
- (if (> *replevel* 0)
- (format strm "~A~D-" *reptype* *replevel*))
- (if (not (eql *package* *user-package*))
- (format strm "~A:" (package-name *package*)))
- (format strm "~a$ " *prompt-string*))
-
-
-;;
-;; Read-Eval-Print-1
-;;
-(defun rep1 (repstream eof local-bindings &optional (ttyp t))
- (let ((input (read-list-from-line repstream eof)) result)
- (if (eq input eof) (return-from rep1 eof))
- (when (and input (or (not (streamp input))
- (> (length (send input :buffer)) 0)))
- (when *history*
- (add-history
- (cond ((consp input) (format nil "~s" input))
- ((streamp input) (send input :buffer))
- (t (string input)))) )
- ;; if something is going to be put in the history buffer,
- ;; it certainly has some value to be processed by the hook.
- (if *toplevel-hook* (funcall *toplevel-hook*))
- )
- (cond
- ((null input) nil)
- ((symbolp input)
-;; (if *history* (add-history (string input)))
- (setq - input
- result
- (cond
- ((> *replevel* 0)
- (eval-dynamic input local-bindings))
- ((boundp input) (eval input))
- (t '*unbound*)))
- (if ttyp (print result repstream)))
- ((or (null (streamp input)) (listp input))
-;; (if *history* (add-history (format nil "~s" input)))
- (setq - input)
- (setq result (eval input))
- (if ttyp (print result repstream)))
- ((streamp input)
- (setq result (evaluate-stream input) )
- (if ttyp (print result repstream )))
- (t (print "?" repstream)))
- (setq +++ ++ ++ + + -)
- (setq *** ** ** * * result)))
-
-
-;; prompt should be passed to repsel or to any toplevel reader
-;; as a special variable. If it is a local argument, it is stored
-;; in the *topselector* and calls to reploop by the break or by
-;; any other functions destructively change the argument, which
-;; cannot be recovered unless another invocation of reploop is made
-;; with the old prompt argument.
-
-(defun prompt (strm)
- (cond ((stringp *prompt*)
- (princ *prompt* strm ))
- ((functionp *prompt*)
- (funcall *prompt* strm))
- (t
- (format strm "~a" *prompt-string*)) )
- (finish-output strm)
- )
-
-
-(defun reploop-non-select (&optional (repstream *terminal-io*)
- (ttyp (unix:isatty repstream)))
-;read-eval-print loop
- (let* ((*error-handler* 'euserror)
- (eof (gensym))
- (input) (local-bindings) (special-bindings))
- (if (> *replevel* 0)
- (setq local-bindings (sys:list-all-bindings)
- ;special-bindings (sys:list-all-special-bindings)
- ))
- (while t
- (catch :reploop
- (if ttyp (prompt repstream))
- (if (eql (rep1 repstream eof local-bindings ttyp) eof)
- (return-from reploop-non-select nil))
- ))))
-
-(defun repsel (repstream eof ttyp local-bindings)
- (if (eql (rep1 repstream eof local-bindings ttyp) eof)
- (throw :reploop-select nil))
- (if ttyp (prompt repstream) ))
-
-
-(defun reploop-select (&optional (repstream *terminal-io*)
- (ttyp (unix:isatty repstream)))
- (let* ((*error-handler* 'euserror)
- (eof (gensym))
- (input) (local-bindings) (special-bindings))
- (if ttyp (prompt repstream))
- (if (> *replevel* 0)
- (setq local-bindings (sys:list-all-bindings)
- ;special-bindings (sys:list-all-special-bindings)
- ))
- ;; let #'repsel be invoked when any input comes to the repstream
- (send *top-selector* :add-port repstream 'repsel
- repstream eof ttyp local-bindings)
- (catch :reploop-select
- (while t
- (unless
- (send *top-selector* :select *top-selector-interval*)
- (if (functionp *timer-job*)
- (funcall *timer-job*)
- (dolist (tj *timer-job*)
- (if (functionp tj) (funcall tj)) ) )
- )
- ))
- ) )
-
-(defun reploop (prompt &optional (repstream *terminal-io*)
- (ttyp (unix:isatty repstream)))
- (let ((*prompt* prompt))
- (if *use-top-selector*
- (reploop-select repstream ttyp)
- (reploop-non-select repstream ttyp))) )
-
-
-(defun euserror (code msg1 form &optional (msg2))
-#+(or :solaris2 :SunOS4.1 :thread)
- (format *error-output* "~C[1;3~Cm~A ~d error: ~A"
- #x1b (+ 1 48) *program-name*
- (unix::thr-self) msg1) ; thr-self is in unix pkg
-#-(or :solaris2 :SunOS4.1 :thread)
- (format *error-output* "~C[1;3~Cm~A error: ~A"
- #x1b (+ 1 48) *program-name* msg1)
- (if msg2 (format *error-output* " ~A" msg2))
- (if form (format *error-output* " in ~s" form))
- (format *error-output* "~C[0m~%" #x1b)
- (let ((*replevel* (1+ *replevel*))
- (*reptype* "E"))
- (catch *replevel* (reploop #'toplevel-prompt)))
- (throw *replevel* nil))
-
-;;;
-;;; default toplevel
-;;;
-
-(defun eustop (&rest argv)
- (when (unix:isatty *standard-input*)
- (warning-message 4 "~%~A" (lisp-implementation-version))
- (terpri)
- (unix:signal unix::sigint 'sigint-handler
- 2) ; not restart
- (unix:signal unix::sigpipe 'eussig)
- ; setup for history
-#+(or :sun :linux :alpha :solaris2 :mips)
- (when (fboundp 'unix:tcgets)
- (setq *tc* (unix:tcgets *standard-input*))
- (new-history *history-max*))
- )
- (if argv (setq *symbol-input* (find-executable (elt argv 0))))
- (setq *user* (unix:getenv "USER"))
- (setq *eustop-argument* argv)
- (setq *prompt-string* (pathname-name *program-name*))
- ;; load .eusrc file from the home directory
- (let ((rcfile (unix:getenv "EUSRC")))
- (unless rcfile
- (setq rcfile (concatenate string (unix:getenv "HOME") "/.eusrc")))
- (if (probe-file rcfile)
- (load rcfile :verbose nil)))
- ;; load .eusrc from the current directory
- (when (probe-file ".eusrc") (load ".eusrc" :verbose nil))
- (when (and argv
- (equal (pathname-name *program-name*) "euscomp")
- (>= (length argv) 2))
- (apply #'compiler::comp-file-toplevel argv)
- (exit 1))
- ;; load files given in arguments
-; (format t "argv=~a~%" argv)
- (if *eustop-hook* (funcall *eustop-hook* *eustop-argument*))
- (let (exp)
- (dotimes (i (1- (length *eustop-argument*)))
- (setq exp (elt *eustop-argument* (1+ i)))
-; (print exp)
- (cond ((eq (elt exp 0) #\() ;)
- ;; if exp is enclosed by parens, evaluate it.
- (eval (read-from-string exp)))
- ((eq (elt exp 0) #\-)
- ;; if arg is prefixed by a dash, ignore.
- )
- (t (load exp)))))
- ;; enter read-eval-loop session
- (catch :eusexit
- (while t
- (catch 0
- (let ((*replevel* 0) (*reptype* ""))
- (reploop #'toplevel-prompt) )
- (throw :eusexit nil)))))
-
-(defun reset (&optional (n 0)) (throw n nil))
-)
-
-(provide :toplevel "@(#)$Id: toplevel.l,v 1.1.1.1 2003/11/20 07:46:26 eus Exp $")
-
diff --git a/lisp/c/unixcall.c b/lisp/c/unixcall.c
index 5bc0bba8c..e3b2318ef 100644
--- a/lisp/c/unixcall.c
+++ b/lisp/c/unixcall.c
@@ -91,7 +91,9 @@ extern time_t timezone, altzone; /*long*/
#endif
extern int daylight;
+extern pointer K_ISATTY;
extern pointer eussigvec[NSIG];
+extern pointer eussigobj;
extern eusinteger_t coerceintval(pointer);
@@ -313,7 +315,7 @@ register pointer argv[];
set=(sigset_t *)argv[0]->c.ivec.iv;
sigaddset(set, signum);
return(argv[0]);}
- else error(E_USER,(pointer)"integer/bit vector expected for sigaddset");
+ else error(E_TYPE_ERROR,(pointer)"integer/bit vector expected for sigaddset");
}
pointer SIGDELSET(ctx,n,argv)
@@ -329,7 +331,7 @@ register pointer argv[];
set=(sigset_t *)argv[0]->c.ivec.iv;
sigdelset(set, signum);
return(argv[0]);}
- else error(E_USER,(pointer)"integer/bit vector expected for sigaddset");
+ else error(E_TYPE_ERROR,(pointer)"integer/bit vector expected for sigaddset");
}
pointer SIGPROCMASK(ctx,n,argv)
@@ -350,7 +352,7 @@ pointer argv[];
stat=sigprocmask(how, set, oset);
if (stat==0) return(T); else return(makeint(-errno));
}
- else error(E_USER,(pointer)"integer/bit vector expected for sigprocmask");
+ else error(E_TYPE_ERROR,(pointer)"integer/bit vector expected for sigprocmask");
}
pointer KILL(ctx,n,argv)
@@ -370,6 +372,7 @@ pointer argv[];
register pointer a=argv[1],oldval;
extern void eusint();
unsigned long int j;
+ pointer p;
ckarg2(1,3);
s=min(ckintval(argv[0]),NSIG-1);
@@ -377,6 +380,11 @@ pointer argv[];
if (n==1) return(oldval);
if (isint(a)) { f=max(1,intval(a)); eussigvec[s]=NIL;}
else { f=(eusinteger_t)eusint; eussigvec[s]=a;}
+ // update eussigobj value
+ p = eussigobj;
+ for (i=0; ic.iostream.in;
if (isfilestream(a)) fd=intval(a->c.fstream.fd);
- else fd=ckintval(a);
+ else if (isint(a)) fd=intval(a);
+ else return csend(ctx,a,K_ISATTY,0);
/*
#if Cygwin
if (getenv("EMACS") && (strcmp (getenv("EMACS"), "t")) == 0 ) return(T);
@@ -1483,7 +1501,7 @@ register pointer argv[];
ckarg(2);
s=ckintval(argv[0]); /*socket id*/
- if (!isstring(argv[1])) error(E_USER,(pointer)"socket address expected");
+ if (!isstring(argv[1])) error(E_NOSTRING);
sa= (struct sockaddr *)(argv[1]->c.str.chars);
if (sa->sa_family==AF_UNIX) l=strlen(sa->sa_data)+2;
else l=sizeof(struct sockaddr_in);
@@ -1498,7 +1516,7 @@ pointer argv[];
struct sockaddr *sa;
ckarg(2);
s=ckintval(argv[0]); /*socket id*/
- if (!isstring(argv[1])) error(E_USER,(pointer)"socket address expected");
+ if (!isstring(argv[1])) error(E_NOSTRING);
sa= (struct sockaddr *)(argv[1]->c.str.chars);
if (sa->sa_family==AF_UNIX) l=strlen(sa->sa_data)+2;
else l=sizeof(struct sockaddr_in);
@@ -1616,7 +1634,7 @@ eusinteger_t *checkbitvec(pointer a, long *size)
case ELM_BYTE: case ELM_CHAR:
*size=vecsize(a) * 8; return(a->c.ivec.iv);
case ELM_FOREIGN: *size=vecsize(a) * 8; return((eusinteger_t *)a->c.foreign.chars);
- default: error(E_USER,(pointer)"bit-vector expected");
+ default: error(E_BITVECTOR);
}
}
@@ -1658,7 +1676,9 @@ register pointer argv[];
timeout=timeout*1000000;
to.tv_usec=timeout;
GC_REGION(i=select(width, readfds, writefds, exceptfds,&to);)}
- if (i<0) return(makeint(-errno));
+ if (i<0) {
+ if (errno==EINTR) breakck; /* signal received? */
+ return(makeint(-errno));}
else return(makeint(i)); }
pointer SELECT_READ(ctx,n,argv)
diff --git a/lisp/c/unixcall.old.c b/lisp/c/unixcall.old.c
deleted file mode 100644
index b0bb3df87..000000000
--- a/lisp/c/unixcall.old.c
+++ /dev/null
@@ -1,2063 +0,0 @@
-/****************************************************************/
-/* unixcall.c
-/* 1986-Jul-6 original for Ustation
-/* 1986-Dec process id's, file changes, syserrlist
-/* 1987-Feb dup,isatty
-/* 1987-Apr getwd,stat,time
-/* 1988-Jan,Feb socket, select
-/* 1988-Dec ioctl
-/* 1990-Mar VxWorks
-/* Copyright(c) 1988 MATSUI Toshihiro, Electrotechnical Laboratory.
-/****************************************************************/
-
-static char *rcsid="@(#)$Id$";
-
-/* SunOS's gettimeofday used to accept only one argument.
-#ifdef Solaris2
-#define _SVID_GETTOD
-#endif
-*/
-
-#include "eus.h"
-
-#if vxworks
-#define NSIG NUM_SIGNALS
-#define SIG_DFL 0
-#include
-#include
-#include
-#else
-#include
-#include
-#include
-#include
-#include
-#include
-#include
-#include
-#include
-#include
-#include
-#include
-#endif
-
-/*SONY/news doesn't have message queu ipc facilities*/
-#if !vxworks
-#include
-#include
-#endif
-
-#if SunOS4_1 || (mips && !IRIX && !IRIX6)
-/* Sun likes to change ioccom constants frequently. */
-#define IOC_VOID _IOC_VOID
-#define IOC_IN _IOC_IN
-#define IOC_OUT _IOC_OUT
-#define IOC_INOUT _IOC_INOUT
-#endif
-
-#if Linux
-#define IOC_VOID 0
-#endif
-
-#if Solaris2 || Linux || alpha
-#include
-#include
-#else
-extern int errno;
-#endif
-
-#if Linux
-#define IOC_VOID 0
-#endif
-
-
-#if alpha
-#include
-#include
-#include
-#include
-#endif
-
-#if system5 || Linux
-#include
-#endif
-
-extern int sys_nerr;
-/*extern char *sys_errlist[];*/
-extern char *tzname[2];
-extern time_t timezone, altzone; /*long*/
-extern int daylight;
-
-extern pointer eussigvec[NSIG];
-
-extern int coerceintval(pointer);
-
-
-/***************** times and status *****************/
-
-#if !vxworks
-pointer PTIMES(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ struct tms buffer;
- register pointer t;
- long et;
- ckarg(0);
- et=times(&buffer);
- t=cons(ctx,makeint(buffer.tms_cstime),NIL);
- t=cons(ctx,makeint(buffer.tms_cutime),t);
- t=cons(ctx,makeint(buffer.tms_stime),t);
- t=cons(ctx,makeint(buffer.tms_utime),t);
- t=cons(ctx,mkbigint(et),t);
- return(t);}
-
-pointer RUNTIME(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ struct tms buffer;
- ckarg(0);
- times(&buffer);
- return(makeint(buffer.tms_utime+buffer.tms_stime));}
-
-pointer LOCALTIME(ctx,n,argv)
-register context *ctx;
-pointer argv[];
-{ long clock;
- struct tm *tms;
- pointer timevec;
- pointer *tv;
- pointer tz0, tz1, tz;
-
- if (n==1) clock=coerceintval(argv[0]);
- else clock=time(0);
- tms=localtime((time_t *)&clock);
- timevec=makevector(C_VECTOR,10);
- vpush(timevec);
- tz0=makestring(tzname[0],strlen(tzname[0]));
- vpush(tz0);
- tz1=makestring(tzname[1],strlen(tzname[1]));
- vpush(tz1);
- tz=cons(ctx, tz1, NIL);
- tz=cons(ctx, tz0, tz);
- tv=timevec->c.vec.v;
- tv[0]=makeint(tms->tm_sec);
- tv[1]=makeint(tms->tm_min);
- tv[2]=makeint(tms->tm_hour);
- tv[3]=makeint(tms->tm_mday);
- tv[4]=makeint(tms->tm_mon);
- tv[5]=makeint(tms->tm_year);
- tv[6]=makeint(tms->tm_wday);
- tv[7]=makeint(tms->tm_yday);
- tv[8]=(tms->tm_isdst>0)?T:NIL;
- tv[9]=tz;
- vpop(); vpop(); vpop();
- return(timevec);}
-
-pointer ASCTIME(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ register char *at;
- struct tm tms1, *tms;
- pointer a=argv[0];
- int i;
-
- ckarg(1);
- if (isintvector(argv[0])) tms=(struct tm *)a->c.ivec.iv;
- else if (isvector(a)) {
- tms1.tm_sec=ckintval(a->c.vec.v[0]);
- tms1.tm_min=ckintval(a->c.vec.v[1]);
- tms1.tm_hour=ckintval(a->c.vec.v[2]);
- tms1.tm_mday=ckintval(a->c.vec.v[3]);
- tms1.tm_mon=ckintval(a->c.vec.v[4]);
- tms1.tm_year=ckintval(a->c.vec.v[5]);
- tms1.tm_wday=ckintval(a->c.vec.v[6]);
- /* tms1.tm_yday=ckintval(a->c.vec.v[7]); */
- tms1.tm_isdst=(a->c.vec.v[8]==NIL)?0:1;
- tms= &tms1; }
- else error(E_NOINTVECTOR);
- at=asctime(tms);
- return(makestring(at,strlen(at)));}
-
-#if !Solaris2
-pointer GETRUSAGE(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ register int who,i;
- long rusage[18];
- float utime,stime;
- register pointer r=NIL;
- numunion nu;
-
- ckarg(1); who=ckintval(argv[0]);
- getrusage(who,rusage);
- utime=rusage[0]+rusage[1]*1.0e-6;
- stime=rusage[2]+rusage[3]*1.0e-6;
- for (i=17; i>=4; i--) r=cons(ctx,makeint(rusage[i]),r);
- r=cons(ctx,makeflt(stime),r); r=cons(ctx,makeflt(utime),r);
- /*(utime stime maxrss ixrss idrss isrss page-reclaims page-faults swap
- inblock outblock msgsnd msgrcv nsignals
- voluntary-context-switch involuntary-context-switch) */
- return(r);}
-
-pointer GETPAGESIZE(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ ckarg(0);
- return(makeint(getpagesize())); }
-
-#endif
-
-pointer GETTIMEOFDAY(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ struct timeval /*{long tv_sec, tv_usec;}*/ tm;
- float ftime;
- pointer p;
-
- /* (sec usec timezone daylight) */
- /* timezone is seconds west to the GMT */
- gettimeofday(&tm, 0);
- p=cons(ctx, makeint(daylight), NIL);
- p=cons(ctx, makeint(timezone),p);
- p=cons(ctx, mkbigint(tm.tv_usec), p);
- p=cons(ctx, mkbigint(tm.tv_sec), p);
- return(p);}
-
-pointer GETITIMER(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ int stat;
- struct itimerval tmval;
- float interval,value;
- numunion nu;
- ckarg(1);
- stat=getitimer(ckintval(argv[0]), &tmval);
- if (stat<0) return(NIL);
- interval=tmval.it_interval.tv_sec + ( tmval.it_interval.tv_usec*1.0E-6);
- value=tmval.it_value.tv_sec + (tmval.it_value.tv_usec*1.0E-6);
- return(cons(ctx,makeflt(value),
- cons(ctx,makeflt(interval),NIL)));}
-
-pointer SETITIMER(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ int stat;
- pointer result=NIL;
- struct itimerval tmval,oldtmval;
- float interval,value;
- numunion nu;
-
- ckarg(3);
- value=ckfltval(argv[1]); interval=ckfltval(argv[2]);
- tmval.it_value.tv_sec=value;
- tmval.it_value.tv_usec=(value-tmval.it_value.tv_sec)*1.0E6;
- tmval.it_interval.tv_sec=interval;
- tmval.it_interval.tv_usec=(interval-tmval.it_interval.tv_sec)*1.0E6;
- stat=setitimer(ckintval(argv[0]), &tmval, &oldtmval);
- if (stat<0) return(result);
- interval=oldtmval.it_interval.tv_sec + (oldtmval.it_interval.tv_usec*1.0E-6);
- value=oldtmval.it_value.tv_sec + (oldtmval.it_value.tv_usec*1.0E-6);
- return(cons(ctx,makeflt(interval),
- cons(ctx,makeflt(value),result)));}
-#endif /* ! vxworks */
-
-/****************************************************************/
-/* signal handling
-/****************************************************************/
-
-#ifdef SIGADDSET
-#undef SIGADDSET
-#endif
-#ifdef SIGDELSET
-#undef SIGDELSET
-#endif
-
-pointer SIGADDSET(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ int signum;
- sigset_t *set;
- ckarg(2);
- signum=ckintval(argv[1]);
- if (isvector(argv[0]) &&
- ((elmtypeof(argv[0])==ELM_INT) || (elmtypeof(argv[0])==ELM_BIT))) {
- set=(sigset_t *)argv[0]->c.ivec.iv;
- sigaddset(set, signum);
- return(argv[0]);}
- else error(E_USER,(pointer)"integer/bit vector expected for sigaddset");
- }
-
-pointer SIGDELSET(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ int signum;
- sigset_t *set;
- ckarg(2);
- signum=ckintval(argv[1]);
- if (isvector(argv[0]) &&
- ((elmtypeof(argv[0])==ELM_INT) || (elmtypeof(argv[0])==ELM_BIT))) {
- set=(sigset_t *)argv[0]->c.ivec.iv;
- sigdelset(set, signum);
- return(argv[0]);}
- else error(E_USER,(pointer)"integer/bit vector expected for sigaddset");
- }
-
-pointer SIGPROCMASK(ctx,n,argv)
-context *ctx;
-int n;
-pointer argv[];
-{ sigset_t *set, *oset;
- int how, stat;
- ckarg2(2,3);
- how=ckintval(argv[0]);
- if (isvector(argv[1]) &&
- ((elmtypeof(argv[1])==ELM_INT) || (elmtypeof(argv[1])==ELM_BIT))) {
- set=(sigset_t *)argv[1]->c.ivec.iv;
- if (isvector(argv[2]) &&
- ((elmtypeof(argv[2])==ELM_INT) || (elmtypeof(argv[2])==ELM_BIT)))
- oset=(sigset_t *)argv[2]->c.ivec.iv;
- else oset=(sigset_t *)0;
- stat=sigprocmask(how, set, oset);
- if (stat==0) return(T); else return(makeint(-errno));
- }
- else error(E_USER,(pointer)"integer/bit vector expected for sigprocmask");
- }
-
-pointer KILL(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(2);
- return(makeint(kill(ckintval(argv[0]),ckintval(argv[1]))));}
-
-#if Solaris2 || Linux || IRIX || IRIX6
-pointer SIGNAL(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register int s,i;eusinteger_t f;
- struct sigaction sv;
- register pointer a=argv[1],oldval;
- extern void eusint();
-
- ckarg2(1,3);
- s=min(ckintval(argv[0]),NSIG-1);
- oldval=eussigvec[s];
- if (n==1) return(oldval);
- if (isint(a)) { f=max(1,intval(a)); eussigvec[s]=NIL;}
- else { f=(eusinteger_t)eusint; eussigvec[s]=a;}
- sv.sa_handler= (void (*)())f;
-#if Linux
-
-#if LIB6
- for (i=0; i< _SIGSET_NWORDS; i++) sv.sa_mask.__val[i]=0;
-#else
- /* old type sigmask */
- sv.sa_mask=0;
-#endif
-/*LIB6*/
-
-#elif (IRIX || IRIX6) && !IRIX6_2
- for (i=0; i<4; i++) sv.sa_mask.sigbits[i]=0;
-#else
- for (i=0; i<4; i++) sv.sa_mask.__sigbits[i]=0;
-#endif
-
- if (n==3) sv.sa_flags= ckintval(argv[2]);
- else sv.sa_flags=0;
- /* printf("signal %d flag=%d\n", s, sv.sa_flags); */
- s=sigaction(s,&sv,0);
- if (s== -1) return(makeint(-errno)); else return(oldval);
- }
-
-#else
-pointer SIGNAL(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register int s;eusinteger_t f;
- struct sigvec sv;
- register pointer a=argv[1],oldval;
- extern void eusint();
-
- ckarg2(1,3);
- s=min(ckintval(argv[0]),NSIG-1);
- oldval=eussigvec[s];
- if (n==1) return(oldval);
- if (isint(a)) { f=max(1,intval(a)); eussigvec[s]=NIL;}
- else { f=(eusinteger_t)eusint; eussigvec[s]=a;}/* ???? */
- sv.sv_handler=(void (*)())f;
- sv.sv_mask=0; /*sigmask(s)???;*/
-/*news doesn't have system5 compatible signal handling option*/
-#if sun3 || sun4 || mips || alpha
- if (n==3) sv.sv_flags=ckintval(argv[2]);
- else sv.sv_flags=0;
-#endif
- s=sigvec(s,&sv,0);
- if (s== -1) return(makeint(-errno)); else return(oldval);
- }
-
-#endif
-
-#if !vxworks
-
-pointer WAIT(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ int completion=0, stat;
- stat = wait(&completion);
- return(cons(ctx,makeint(stat),
- cons(ctx,makeint(completion),NIL)));}
-
-pointer ALARM(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ ckarg(1);
- return(makeint(alarm(ckintval(argv[0]))));}
-
-
-#if sun3 || sun4 || news || sanyo || alpha
-#if !Solaris2
-pointer UALARM(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ ckarg(2);
- return(makeint(ualarm(ckintval(argv[0]), ckintval(argv[1]))));}
-#endif
-#endif
-
-#endif /*!vxworks*/
-
-/**********************************************/
-/* process, user, and group identification
-/**********************************************/
-
-pointer GETPID(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv; /* unused argument */
-{ ckarg(0);
- return(makeint(getpid()));}
-
-#if !vxworks
-pointer GETPPID(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ ckarg(0);
- return(makeint(getppid()));}
-
-pointer GETPGRP(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-#if system5 | Linux
-{ ckarg(0);
- return(makeint(getpgrp()));}
-#else
-{ int pid;
- if (n==1) pid=ckintval(argv[0]);
- else pid=getpid();
- return(makeint(getpgrp(pid)));}
-#endif
-
-pointer SETPGRP(context *ctx, int n, pointer *argv)
-#if system5 | Linux
-{ ckarg(0);
- return(makeint(setpgrp()));}
-#else
-{ int pid;
- ckarg(2);
- return(makeint(setpgrp(ckintval(argv[0]),ckintval(argv[1]))));}
-#endif
-
-pointer GETUID(context *ctx, int n, pointer *argv)
-{ ckarg(0);
- return(makeint(getuid()));}
-
-pointer GETEUID(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ ckarg(0);
- return(makeint(geteuid()));}
-
-pointer GETGID(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ ckarg(0);
- return(makeint(getgid()));}
-
-pointer GETEGID(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ ckarg(0);
- return(makeint(getegid()));}
-
-pointer SETUID(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ ckarg(1);
- n=setuid(ckintval(argv[0]));
- if (n<0) return(makeint(errno)); else return(T);}
-
-pointer SETGID(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ ckarg(1);
- n=setgid(ckintval(argv[0]));
- if (n<0) return(makeint(errno)); else return(T);}
-
-#endif /*!vxworks*/
-
-#if system5 || Linux
-pointer UNAME(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ struct utsname u;
- pointer s;
- ckarg(0);
- uname(&u);
- vpush(makestring(u.sysname,strlen(u.sysname)));
- vpush(makestring(u.nodename,strlen(u.nodename)));
- vpush(makestring(u.release,strlen(u.release)));
- vpush(makestring(u.version,strlen(u.version)));
- vpush(makestring(u.machine,strlen(u.machine)));
- s=stacknlist(ctx,5);
- return(s);}
-#endif
-
-/****************************************************************/
-/* process creation and deletion
-/****************************************************************/
-#if !vxworks
-pointer FORK(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ ckarg(0);
- return(makeint(fork()));
- }
-
-#if Solaris2
-pointer FORK1(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ ckarg(0);
- return(makeint(fork1()));
- }
-#endif
-
-#if sun3 || sun4 || vax || news || sanyo || (mips && !IRIX && !IRIX6) || i386 || alpha
-pointer VFORK(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ ckarg(0);
- return(makeint(vfork()));}
-#endif
-
-pointer EXEC(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ byte *exeargv[512];
- int i=0,stat;
- if (n>512) error(E_MISMATCHARG);
- while (ic.str.chars;
- i++;}
- exeargv[i]=0;
- stat=execvp(exeargv[0],(char **)exeargv);
- return(makeint(-errno));}
-
-#if !Solaris2
-static pointer SETPRIORITY(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-/* (SETPRIORITY which who priority)
- which 0:process, 1:process-group, 2:user
- who 0:self, others pid, pgrp-id user-id */
-{ ckarg(3);
- return(makeint(setpriority(ckintval(argv[0]),
- ckintval(argv[1]),
- ckintval(argv[2]))));}
-
-static pointer GETPRIORITY(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-/* (GETPRIORITY which who) */
-{ ckarg(2);
- return(makeint(getpriority(ckintval(argv[0]), ckintval(argv[1]))));}
-#endif /*!Solaris2*/
-#endif /*!vxworks*/
-
-pointer EXIT(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ pointer exithook=speval(QEXITHOOK);
-/*
- Exit function can not finish threads which create in Euslisp
-on SunOS 4.1. So we use thr_exit function on SunOS 4.1.
-*/
-#if SunOS4_1 /* changed by H.Nakagaki at 28-Jun-1995 */
- if (n==0) thr_exit(0);
- else thr_exit(ckintval(argv[0]));
-#else
- if (exithook != NIL) {
- ufuncall(ctx,exithook,exithook,(pointer)(ctx->vsp),0,0);}
- if (n==0) exit(0);
- else exit(ckintval(argv[0]));
-#endif
-}
-
-
-/****************************************************************/
-/* unix raw I/O and file systems
-/****************************************************************/
-
-pointer UNIXREAD(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-/* (unix:read stream [length]) */
-/* (unix:read fd buffer [length [offset]]) */
-#if (WORD_SIZE == 64)
-{ register int fd,offset=0;
- register long int size;
-#else
-{ register int fd,size,offset=0;
-#endif
- register pointer strm,buf,count;
- byte *bufp;
-
- ckarg2(1,4);
- strm=argv[0];
- if (isiostream(strm)) strm=strm->c.iostream.in;
- if (isfilestream(strm)) {
- if (strm->c.stream.direction!=K_IN) error(E_IODIRECTION);
- if (isint(strm->c.fstream.fname)) error(E_STREAM);
- buf=strm->c.fstream.buffer;
- bufp=buf->c.str.chars;
- fd=intval(strm->c.fstream.fd);
- if (n==2) size=min(strlength(buf),ckintval(argv[1]));
- else size=strlength(buf);}
- else if (isint(strm)) {
- fd=intval(strm);
- buf=argv[1];
- if (isvector(buf) && (elmtypeof(buf)==ELM_FOREIGN))
- bufp=buf->c.foreign.chars;
- else if (isstring(buf)) bufp=buf->c.str.chars;
- else error(E_NOSTRING);
- if (n>=3) size=min(strlength(buf),ckintval(argv[2]));
- else size=strlength(buf);
- if (n==4) offset=ckintval(argv[3]);}
- else error(E_STREAM);
- size=read(fd, &bufp[offset],size);
- count=makeint(size);
- if (isstream(strm)) {
- strm->c.stream.count=0; strm->c.stream.tail=count;}
- if (size<0) return(makeint(-errno));
- else return(count);}
-
-pointer UNIXWRITE(ctx,n,argv)
-register context *ctx;
-register int n;
-pointer *argv;
-/* (unix:write fd string [count])
- (unix:write stream string [count]) */
-{ register pointer strm,buf;
- register int size,fd;
- byte *bufp;
- ckarg2(2,3);
- strm=argv[0];
- if (isiostream(strm)) strm=strm->c.iostream.out;
- if (isfilestream(strm)) {
- if (strm->c.stream.direction!=K_OUT) error(E_IODIRECTION);
- if (isint(strm->c.fstream.fname)) error(E_STREAM);
- fd=intval(strm->c.fstream.fd);}
- else if (isint(strm)) fd=intval(strm);
- else error(E_STREAM);
- buf=argv[1];
- if (isvector(buf) && (elmtypeof(buf)==ELM_FOREIGN))
- bufp=buf->c.foreign.chars;
- else if (isstring(buf)) bufp=buf->c.str.chars;
- else error(E_NOSTRING);
- size=strlength(buf);
- if (n==3) size=min(size,ckintval(argv[2]));
- size=write(fd,bufp,size);
- return(makeint(size));}
-
-
-pointer UNIXCLOSE(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ ckarg(1);
- if (close(ckintval(argv[0]))==0) return(T); else return(makeint(errno));}
-
-
-pointer LOCKF(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register pointer a=argv[0];
- int fd,func,size,result;
- ckarg2(2,3);
- if (isiostream(a)) a=a->c.iostream.out;
- if (isfilestream(a)) fd=intval(a->c.fstream.fd);
- else if (isint(argv[0])) fd=intval(argv[0]);
- else error(E_STREAM);
- func= ckintval(argv[1]);
- if (n==3) size=ckintval(argv[2]);
- else size=0;
- result=lockf(fd,func,size);
- return(makeint(result));}
-
-pointer FCNTL(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register pointer a=argv[0]; int fd,result;
- ckarg(3);
- if (isiostream(a)) a=a->c.iostream.in;
- if (isfilestream(a)) fd=intval(a->c.fstream.fd);
- else if (isint(argv[0])) fd=intval(argv[0]);
- else error(E_STREAM);
- result=fcntl(fd,ckintval(argv[1]),ckintval(argv[2]));
- return(makeint(result));}
-
-
-pointer IOCTL(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ register pointer strm;
- eusinteger_t ctlarg;
- int request;
- int fd;
- ckarg(3);
- strm=argv[0];
- if (isiostream(strm)) strm=strm->c.iostream.out;
- if (isfilestream(strm)) {
- fd=intval(strm->c.fstream.fd);
- if (isint(strm->c.fstream.fname)) error(E_STREAM);}
- else fd=ckintval(argv[0]);
- if (isint(argv[1])) request=ckintval(argv[1]);
- else if (isflt(argv[1])) error(E_NOINT);
- else request=argv[1]->c.ivec.iv[0];
- if (isstring(argv[2])) ctlarg=(eusinteger_t)(argv[2]->c.str.chars);/* ???? */
- else ctlarg=ckintval(argv[2]);
- return(makeint(ioctl(fd,request,ctlarg)));
- }
-
-
-#if !vxworks && !Solaris2
-int bytesize(p)
-pointer p;
-{ register int s=vecsize(p);
- switch (elmtypeof(p)) {
- case ELM_BIT: return((s+7)/8);
- case ELM_BYTE: case ELM_CHAR: case ELM_FOREIGN: return(s);
- case ELM_FLOAT: return(s*sizeof(float));
- case ELM_INT: return(s*sizeof(int));
- default: return(s*sizeof(pointer));}}
-
-#if Linux_ppc
-#define IOC_IN _IOC_READ
-#define IOC_OUT _IOC_WRITE
-#define IOC_INOUT (IOC_IN | IOC_OUT)
-#endif
-
-
-pointer IOCTL_(ctx,n,argv)
-register context *ctx;
-/* (UNIX:IOCTL_ stream command1 command2) */
-/* equivalent to C's ioctl(dev, _IO(command1, command2), addr) */
-int n;
-register pointer argv[];
-{ register pointer strm;
- int size=0,x,y,fd;
- eusinteger_t addr;
- ckarg(3);
- strm=argv[0];
- if (isiostream(strm)) strm=strm->c.iostream.out;
- if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
- else fd=ckintval(strm);
- if (isint(strm->c.fstream.fname)) error(E_STREAM);
- x=ckintval(argv[1]); y=ckintval(argv[2]);
-#if alpha || Linux_ppc
- if (ioctl(fd,_IO(x, y), addr))
-#else
- if (ioctl(fd,IOC_VOID | (size<<16) | (x<<8) | y, addr))
-#endif
- return(makeint(-errno));
- else return(T); }
-
-pointer IOCTL_R(ctx,n,argv)
-register context *ctx;
-/* (UNIX:IOCTL_R stream x y buffer [size]) */
-/* equivalent to C's ioctl(dev, _IORN(size, x, y), addr) */
-int n;
-register pointer argv[];
-{ register pointer strm;
- int size,x,y,fd;
- eusinteger_t addr;
- ckarg2(4,5);
- strm=argv[0];
- if (isiostream(strm)) strm=strm->c.iostream.out;
- if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
- else fd=ckintval(strm);
- if (isint(strm->c.fstream.fname)) error(E_STREAM);
- x=ckintval(argv[1]); y=ckintval(argv[2]);
- if (isstring(argv[3]) || isintvector(argv[3]))
- addr=(eusinteger_t)(argv[3]->c.str.chars);/* ???? */
- else error(E_NOSTRING);
- if (n==5) size=ckintval(argv[4]);
- else size=bytesize(argv[3]);
-#if alpha
- if (ioctl(fd,_IOC(IOC_OUT, x, y, size), addr))
-#else
- if (ioctl(fd,IOC_OUT | (size<<16) | (x<<8) | y, addr))
-#endif
- return(makeint(-errno));
- else return(T); }
-
-pointer IOCTL_W(ctx,n,argv)
-register context *ctx;
-/* (UNIX:IOCTL_W stream x y buffer [size]) */
-/* equivalent to C's ioctl(dev, _IOWN(size, x, y), addr) */
-int n;
-register pointer argv[];
-{ register pointer strm;
- int size,x,y,fd;
- eusinteger_t addr;
- ckarg2(4,5);
- strm=argv[0];
- if (isiostream(strm)) strm=strm->c.iostream.out;
- if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
- else fd=ckintval(strm);
- if (isint(strm->c.fstream.fname)) error(E_STREAM);
- x=ckintval(argv[1]); y=ckintval(argv[2]);
- if (isstring(argv[3]) || isintvector(argv[3]))
- addr=(eusinteger_t)(argv[3]->c.str.chars);/* ???? */
- else error(E_NOSTRING);
- if (n==5) size=ckintval(argv[4]);
- else size=bytesize(argv[3]);
-#if alpha || Linux_ppc
- if (ioctl(fd,_IOC(IOC_IN, x, y, size), addr))
-#else
- if (ioctl(fd,IOC_IN | (size<<16) | (x<<8) | y, addr))
-#endif
- return(makeint(-errno));
- else return(T); }
-
-pointer IOCTL_WR(ctx,n,argv)
-register context *ctx;
-/* (UNIX:IOCTL_WR stream x y buffer [size]) */
-/* equivalent to C's ioctl(dev, _IOWRN(size, x, y), addr) */
-int n;
-register pointer argv[];
-{ register pointer strm=argv[0];
- int size,x,y,fd;
- eusinteger_t addr;
-
- ckarg2(4,5);
- if (isiostream(strm)) strm=strm->c.iostream.out;
- if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
- else fd=ckintval(strm);
- if (isint(strm->c.fstream.fname)) error(E_STREAM);
- x=ckintval(argv[1]); y=ckintval(argv[2]);
- if (isstring(argv[3]) || isintvector(argv[3]))
- addr=(eusinteger_t)(argv[3]->c.str.chars);
- else error(E_NOSTRING);
- if (n==5) size=ckintval(argv[4]);
- else size=bytesize(argv[3]);
-#if alpha || Linux_ppc
- if (ioctl(fd,_IOC(IOC_INOUT, x, y, size), addr))
-#else
- if (ioctl(fd,IOC_INOUT | (size <<16) | (x<<8) | y, addr))
-#endif
- return(makeint(-errno)) ;
- else return(T); }
-
-#endif /*vxworks*/
-
-/* DUP and DUP2 work only for numeric fd, not for stream obj.*/
-#if !vxworks
-
-pointer DUP(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ int newfd,oldfd;
- ckarg(1);
- oldfd=ckintval(argv[0]);
- newfd=dup(oldfd);
- return(makeint(newfd));}
-
-pointer DUP2(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ int newfd,oldfd,stat;
- ckarg(2);
- newfd=ckintval(argv[0]);
- oldfd=ckintval(argv[1]);
- stat=dup2(newfd,oldfd);
- return(makeint(stat));}
-
-pointer MKNOD(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ int stat;
- ckarg(2);
- stat=mknod((char *)Getstring(argv[0])->c.str.chars,ckintval(argv[1]),0);
- if (stat<0) return(makeint(-errno));
- else return(T);}
-
-pointer MKDIR(ctx, n, argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ int stat, mode;
- ckarg2(1,2);
- if (n==2) mode=ckintval(argv[1]); else mode=0775;
- stat=mkdir((char *)Getstring(argv[0])->c.str.chars,mode);
- if (stat<0) return(makeint(-errno));
- else return(T);}
-
-pointer LINK(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ int stat;
- ckarg(2);
- stat=link(Getstring(argv[0])->c.str.chars,Getstring(argv[1])->c.str.chars);
- if (stat<0) return(makeint(-errno)); else return(T);}
-
-pointer UNLINK(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ pointer s;
- int stat;
- ckarg(1);
- s=Getstring(argv[0]);
- stat=unlink(s->c.str.chars);
- if (stat<0) return(makeint(-errno));
- else return(T);}
-
-pointer RMDIR(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ pointer s;
- int stat;
- ckarg(1);
- s=Getstring(argv[0]);
- stat=rmdir(s->c.str.chars);
- if (stat<0) return(makeint(-errno));
- else return(T);}
-
-pointer RENAME(ctx,n,argv) /*(rename from to)*/
-register context *ctx;
-int n;
-register pointer argv[];
-{ byte *from, *to;
- int stat;
- ckarg(2);
- from =(byte *)get_string(argv[0]);
- to =(byte *)get_string(argv[1]);
- stat=rename((char *)from,(char *) to);
- if (stat<0) return(makeint(-errno));
- else return(T);}
-
-pointer ACCESS(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ pointer path;
- int mode,stat;
- ckarg2(1,2);
- path=Getstring(argv[0]);
- if (n==2) mode=ckintval(argv[1]); else mode=0;
- stat=access(path->c.str.chars,mode);
- if (stat==0) return(T); else return(makeint(-errno));}
-
-/*
-pointer FLOCK(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ int fd=ckintval(argv[0]), op=ckintval(argv[1]), stat;
- ckarg(2);
- stat=flock(fd,op);
- if (stat==0) return(T); else return(makeint(-errno));}
-*/
-
-pointer STAT(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ register pointer a;
- struct stat s;
- ckarg(1);
- if (stat((char *)Getstring(argv[0])->c.str.chars, &s)<0) return(makeint(-errno));
- a=cons(ctx,mkbigint(s.st_ctime),NIL);
- a=cons(ctx,mkbigint(s.st_mtime),a);
- a=cons(ctx,mkbigint(s.st_atime),a);
- a=cons(ctx,makeint(s.st_size),a);
- a=cons(ctx,makeint(s.st_gid),a);
- a=cons(ctx,makeint(s.st_uid),a);
- a=cons(ctx,makeint(s.st_nlink),a);
- a=cons(ctx,makeint(s.st_rdev),a);
- a=cons(ctx,makeint(s.st_dev),a);
- a=cons(ctx,makeint(s.st_ino),a);
- a=cons(ctx,makeint(s.st_mode),a);
- return(a);}
-#endif /* !vxworks*/
-
-#if Solaris2 || linux || alpha
-/*
- Usage: (unix::directory "directory_name")
- Return: a reverse list of file names in "directory_name" dir.
-*/
-
-pointer DIRECTORY(ctx, n, argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register pointer a;
- register char *str;
- byte *s;
- DIR *dirp;
- struct dirent *direntp;
- int flag=0;
-
- ckarg2(0,1);
- if (n==1) s=get_string(argv[0]); else s=(byte *)".";
- dirp = opendir((char *)s);
- while ( (direntp = readdir( dirp )) != NULL ){
- str=direntp->d_name;
- if(flag) a=cons(ctx,makestring(str,strlen(str)),a);
- else { a=cons(ctx,makestring(str,strlen(str)),NIL); flag++;}
- }
- closedir(dirp);
- return (a);
-}
-#else
-pointer DIRECTORY(ctx, n, argv)
-register context *ctx;
-int n;
-pointer argv[];
-{
- printf("Not Implemented!");
- return (NIL);
-}
-#endif
-
-pointer LSEEK(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ pointer strm,fd;
- int whence;
- ckarg2(2,3);
- if (n==3) whence=ckintval(argv[2]); else whence=0;
- strm=argv[0];
- if (isiostream(strm)) strm=strm->c.iostream.out;
- if (isfilestream(strm)){
- fd=strm->c.fstream.fd;
- if (isint(strm->c.fstream.fname)) error(E_STREAM);}
- else fd=strm;
- if (!isint(fd)) error(E_STREAM);
- return(makeint(lseek(intval(fd),ckintval(argv[1]),whence))); }
-
-#if !vxworks
-/*change current working directory*/
-pointer CHDIR(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register int stat;
- ckarg(1);
- stat=chdir(Getstring(argv[0])->c.str.chars);
- if (stat<0) return(makeint(-errno)); else return(T);}
-
-/*change file access mode*/
-pointer CHMOD(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ byte *path;
- int mode,stat;
- ckarg(2);
- path=Getstring(argv[0])->c.str.chars;
- mode=ckintval(argv[1]);
- stat=chmod((char *)path,mode);
- if (stat==0) return(T); else return(makeint(errno));}
-
-/*change file owner*/
-pointer CHOWN(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ byte *path;
- int owner,newowner,stat;
- ckarg(3);
- path=Getstring(argv[0])->c.str.chars;
- owner=ckintval(argv[1]);
- newowner=ckintval(argv[2]);
- stat=chown(path,owner,newowner);
- if (stat==0) return(T); else return(makeint(errno));}
-
-/*create two pipes*/
-pointer PIPE(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ int pfd[2],stat,size;
- register pointer instream,outstream;
-
- ckarg2(0,1);
- if (n==1) size=ckintval(argv[0]); else size=128;
- stat=pipe(pfd);
- if (stat<0) return(makeint(-errno));
- instream=mkfilestream(ctx,K_IN,makebuffer(size),pfd[0],NIL); /*no file named*/
- vpush(instream);
- outstream=mkfilestream(ctx,K_OUT,makebuffer(size),pfd[1],NIL);
- return((pointer)mkiostream(ctx,vpop(),outstream));
- }
-
-
-/* message queu operations */
-#if !news
-pointer MSGGET(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ register int key,qid,mode;
- ckarg2(1,2);
- key=ckintval(argv[0]);
- if (n==2) mode=ckintval(argv[1]); else mode=0666;
- qid=msgget(key,IPC_CREAT | (mode & 0777));
- return(makeint(qid));}
-
-pointer MSGRCV(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ register int qid,mtype,flag,stat;
- register pointer buf,lsave;
- ckarg2(2,4);
- qid=ckintval(argv[0]);
- buf=argv[1];
- if (!isstring(buf)) error(E_NOSTRING);
- if (n>=3) mtype=ckintval(argv[2]); else mtype=0;
- if (n==4) if (argv[3]==NIL) flag=0; else flag=IPC_NOWAIT;
- else flag=0;
- lsave=buf->c.str.length;
- buf->c.str.length=(pointer)(eusinteger_t)mtype;/* ???? */
- rcv_again:
- stat=msgrcv(qid,&buf->c.str.length,intval(lsave),mtype,flag);
- if (stat<0) { breakck; goto rcv_again;}
- mtype=(int)(eusinteger_t)(buf->c.str.length);/* ???? */
- buf->c.str.length=lsave;
- if (stat<0) return(makeint(-errno));
- else return(cons(ctx,makeint(mtype),cons(ctx,makeint(stat),NIL)));}
-
-pointer MSGSND(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ register int qid,msize,mtype,flag,stat;
- register pointer buf,lsave;
- ckarg2(2,5);
- qid=ckintval(argv[0]);
- buf=argv[1];
- if (!isstring(buf)) error(E_NOSTRING);
- lsave=buf->c.str.length;
- if (n>=3) {
- msize=ckintval(argv[2]);
- if (msize>intval(lsave) || msize<0) error(E_ARRAYINDEX);}
- else msize=intval(lsave);
- if (n>=4) mtype=ckintval(argv[3]); else mtype=mypid;
- if (n==5) if (argv[4]==NIL) flag=0; else flag=IPC_NOWAIT;
- else flag=0;
- buf->c.str.length=(pointer)(eusinteger_t)mtype;
- stat=msgsnd(qid,(struct msgbuf *)&buf->c.str.length,msize,flag);
- buf->c.str.length=lsave;
- if (stat<0) return(makeint(-errno));
- else return(makeint(stat));}
-
-pointer MSGCTL(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ int qid,cmnd,stat;
- byte *buf;
- ckarg2(2,3);
- qid=ckintval(argv[0]); cmnd=ckintval(argv[1]);
- if (n==3) buf=get_string(argv[2]);
- else buf=NULL;
- stat=msgctl(qid,cmnd,(struct msqid_ds *)buf);
- if (stat==(int)NULL) return(T); else return(makeint(-errno));}
-#endif
-#endif /*!vxworks*/
-
-/****************************************************************/
-/* UNIX subroutines
-/****************************************************************/
-
-pointer SYSTEM(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ int stat;
- eusinteger_t s;
-/* extern int eusint(); */
- extern void eusint(); /* ???? */
-
- s=(eusinteger_t)signal(SIGCHLD,SIG_DFL);/* ???? */
- if (n==0) stat=system("csh");
- else if (isstring(argv[0])) stat=system((char *)argv[0]->c.str.chars);
- else { signal(SIGCHLD,(void (*)())s); error(E_NOSTRING);}
- signal(SIGCHLD,(void (*)())s);
- return(makeint(stat));}
-
-pointer GETWD(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ char buf[256];
- ckarg(0);
-#if Solaris2 || Linux
- getcwd(buf,256);
-#else
- getwd(buf);
-#endif
- return(makestring(buf,strlen(buf)));}
-
-pointer GETENV(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ register char *envval;
- ckarg(1);
- envval=(char *)getenv((char *)Getstring(argv[0])->c.str.chars);
- if (envval) return(makestring(envval,strlen(envval)));
- else return(NIL);}
-
-#if sun3 || sun4 || vax || mips || i386 || alpha
-pointer PUTENV(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{
- char *b;
- pointer a=argv[0];
- ckarg(1);
- if (!isstring(a)) error(E_NOSTRING);
- b= (char *)malloc(vecsize(a)+1);
- strcpy(b, (char *)a->c.str.chars);
- putenv(b);
- return(makeint((eusinteger_t)b));}
-#endif
-
-pointer ENVIRON(context *ctx, int n, pointer argv[])
-{ extern char **environ;
- char *b;
- int count=0;
- ckarg(0);
- while (b=environ[count++]) {
- vpush(makestring(b, strlen(b)));}
- return(stacknlist(ctx, count-1)); }
-
-pointer SLEEP(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ ckarg(1);
- sleep(ckintval(argv[0]));
- return(T);}
-
-#if sun3 || sun4 && !Solaris2 || Linux || alpha
-pointer USLEEP(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ ckarg(1);
- usleep(ckintval(argv[0]));
- return(T);}
-#endif
-
-pointer ERRNO(ctx,n,argv)
-context *ctx;
-int n;
-pointer argv[];
-{
- return(makeint(errno));
- }
-
-pointer SYSERRLIST(ctx,n,argv)
-register context *ctx;
-register int n;
-pointer argv[];
-{ char *errstr;
- ckarg(1);
- n=ckintval(argv[0]);
- if (0<=n && nc.iostream.in;
- if (isfilestream(a)) fd=intval(a->c.fstream.fd);
- else fd=ckintval(a);
- if (isatty(fd)) return(T); else return(NIL);}
-
-
-/****************************************************************/
-/* functions for I P C (interprocess communication)
-/* using sockets
-/* 1988-Jan socket for internet
-/* 1988-Feb select system call
-/****************************************************************/
-
-pointer SOCKET(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ int proto,s;
- ckarg2(2,3);
- if (n==3) proto=ckintval(argv[2]);
- else proto=0;
- s=socket(ckintval(argv[0]),ckintval(argv[1]),proto);
- if (s<0) return(makeint(-errno));
- else return(makeint(s)); }
-
-pointer BIND(ctx,n,argv) /*bind ipc socket to real path name*/
-register context *ctx;
-int n;
-register pointer argv[];
-{ int s,l;
- pointer sockname;
- struct sockaddr *sa;
-
- ckarg(2);
- s=ckintval(argv[0]); /*socket id*/
- if (!isstring(argv[1])) error(E_USER,(pointer)"socket address expected");
- sa= (struct sockaddr *)(argv[1]->c.str.chars);
- if (sa->sa_family==AF_UNIX) l=strlen(sa->sa_data)+2;
- else l=sizeof(struct sockaddr_in);
- s=(int)bind(s, sa, l);
- if (s) return(makeint(-errno)); else return(makeint(0));}
-
-pointer CONNECT(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ int s,l;
- struct sockaddr *sa;
- ckarg(2);
- s=ckintval(argv[0]); /*socket id*/
- if (!isstring(argv[1])) error(E_USER,(pointer)"socket address expected");
- sa= (struct sockaddr *)(argv[1]->c.str.chars);
- if (sa->sa_family==AF_UNIX) l=strlen(sa->sa_data)+2;
- else l=sizeof(struct sockaddr_in);
- s=(int)connect(s, sa, l);
- breakck;
- if (s) return(makeint(-errno)); else return(makeint(0));
-}
-
-pointer LISTEN(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ int backlog,stat;
- ckarg2(1,2);
- if (n==2) backlog=ckintval(argv[1]);
- else backlog=3;
- stat=listen(ckintval(argv[0]),backlog);
- if (stat<0) return(makeint(-errno)); else return(makeint(0));}
-
-pointer ACCEPT(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ int ns,len,s;
- pointer sockname;
-#if vxworks
- struct sockaddr sockun;
-#else
- struct sockaddr_un sockun;
-#endif
-
- ckarg(1);
- len=sizeof(sockun);
- s=ckintval(argv[0]);
- ns=accept(s, (struct sockaddr *)&sockun, &len);
- if (ns<0) return(makeint(-errno));
- sockname=makestring((char *)&sockun,len);
- return(cons(ctx,makeint(ns),cons(ctx,sockname,NIL)));}
-
-/* non-connected (datagram) socket communication */
-/* Address must be bound to a socket at the receiver side. */
-/* Sender specifies the address when it calls SENDTO. */
-pointer SENDTO(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-/* unix: sendto(sock,msg,len,flags,to,tolen) */
-/* eus: (SENDTO sock addr msg [len [flags]]) */
-{ int len, sock, flags, stat;
- pointer msg, addr;
- ckarg2(3,5);
- sock=ckintval(argv[0]);
- addr=(pointer)Getstring(argv[1]);
- msg=(pointer)Getstring(argv[2]);
- if (n>=4) len=ckintval(argv[3]); else len=vecsize(msg);
- if (n>=5) flags=ckintval(argv[4]); else flags=0;
- stat=sendto(sock, (char *)msg->c.str.chars, len, flags,
- (struct sockaddr *)addr->c.str.chars, vecsize(addr));
- if (stat<0) stat= -errno;
- /* returns the number of bytes actually sent*/
- return(makeint(stat));}
-
-pointer RECVFROM(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-/* unix: recvfrom(s,buf,len,flags,from,fromlen) */
-/* eus: (RECVFROM sock [msg [from [flags]]])
- no address is required since it has already bound to
- the socket */
-{ int len=2000, sock, flags, stat, addrlen;
- unsigned char buf[2000], *bufp=buf, *addrp=NULL;
- pointer msg, addr;
- ckarg2(1,4);
- sock=ckintval(argv[0]);
- if (n>=2) {
- msg=argv[1];
- if (isstring(msg)) msg=(pointer)Getstring(argv[1]); /*message buffer*/
- else msg=makebuffer(ckintval(argv[1]));
- bufp=msg->c.str.chars;
- len=vecsize(msg);}
- if (n>=3) {
- addr=Getstring(argv[2]);
- addrlen=vecsize(addr);
- addrp=addr->c.str.chars;}
- if (n>=4) flags=ckintval(argv[3]); else flags=0;
- stat=recvfrom(sock, (char *)bufp, len, flags, (struct sockaddr *)addrp, &addrlen);
- if (stat<0) return(makeint(-errno));
- /* if the result is negative, it indicates error number,
- otherwise, the actual length of the message is returned. */
- if (n<2) return(makestring((char *)bufp,stat));
- else return(makeint(stat));}
-
-#if !Solaris2
-pointer GETPEERNAME(ctx,n,argv)
-register context *ctx;
-int n;
-pointer argv[];
-{ char name[128];
- int namelen, stat;
- ckarg(1);
- stat=getpeername(ckintval(argv[0]), (struct sockaddr *)name, &namelen);
- if (stat<0) return(makeint(-errno));
- else return(makestring(name,namelen));}
-#endif /*!Solaris2*/
-
-#if !vxworks
-
-eusinteger_t *checkbitvec(pointer a, long *size)
-{ if (a==NIL) { *size=0; return(0);}
- if (!isvector(a)) error(E_NOVECTOR);
- switch(elmtypeof(a)) {
- case ELM_BIT: *size=vecsize(a); return(a->c.ivec.iv);
- case ELM_INT: *size=vecsize(a) * WORD_SIZE; return(a->c.ivec.iv);
- case ELM_BYTE: case ELM_CHAR:
- *size=vecsize(a) * 8; return(a->c.ivec.iv);
- case ELM_FOREIGN: *size=vecsize(a) * 8; return((eusinteger_t *)a->c.foreign.chars);
- default: error(E_USER,(pointer)"bit-vector expected");
- }
-}
-
-pointer SELECT(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ register pointer a=argv[0];
- long i, maxwidth, width,size0, size1, size2;
- fd_set *readfds, *writefds, *exceptfds;
- float timeout;
- struct timeval to;
- numunion nu;
-
- ckarg(4);
- readfds=(fd_set *)checkbitvec(argv[0], &size0);
- writefds=(fd_set *)checkbitvec(argv[1], &size1);
- exceptfds=(fd_set *)checkbitvec(argv[2], &size2);
- maxwidth=min(256, max(max(size0, size1), size2));
-
-/* printf("SELECT: readfds=%x\n", readfds);
- printf("SELECT: writefds=%x\n", writefds);
- printf("SELECT: exceptfds=%x\n", exceptfds); */
-
- /* find the highest numbered fd */
- width=0;
- for (i=0; i __fds_bits[0];*/
- /* fds_bits should be __fds_bits on some operating systems */
- return(makeint(fds)); }
- else return(argv[0]); }
-
-#endif /* !vxworks */
-
-
-/****************************************************************/
-/* physical memory allocator
-/* 1988-Jul
-/****************************************************************/
-pointer SBRK(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ return(makeint(sbrk(ckintval(argv[0]))));}
-
-pointer MALLOC(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ return(makeint(malloc(ckintval(argv[0]))));}
-
-pointer FREE(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ free((void *)ckintval(argv[0]));
- return(makeint(1));}
-
-#if sun3 || sun4 || news || alpha
-pointer VALLOC(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ return(makeint(valloc(ckintval(argv[0]))));}
-#endif
-
-#if sun3 || sun4 || news || alpha || Linux
-
-pointer MMAP(ctx,n,argv)
-register context *ctx;
-int n; register pointer argv[];
-{ int fd;
- eusinteger_t offset,result,len;
- pointer strm;
- ckarg(6);
- strm=argv[4];
- if (isiostream(strm)) strm=strm->c.iostream.in;
- if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
- else fd=ckintval(strm);
- len=ckintval(argv[1]);
- if (isintvector(argv[5]))
- offset=((argv[5]->c.ivec.iv[0])<<16) + argv[5]->c.ivec.iv[1];
- else offset=ckintval(argv[5]);
- result=(eusinteger_t)mmap((caddr_t)ckintval(argv[0]), len,
- ckintval(argv[2]), ckintval(argv[3]), fd, offset);
- if (result== -1) return(makeint(-errno));
- else return((pointer)make_foreign_string(result, len));}
-
-pointer MUNMAP(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ return(makeint(munmap((caddr_t)ckintval(argv[0]),ckintval(argv[1]))));}
-
-/*
-pointer VADVISE(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ n=vadvise(ckintval(argv[0]));
- if (n==0) return(T); else return(makeint(errno));}
-*/
-
-#endif
-
-/****************************************************************/
-/* network library routines
-/****************************************************************/
-#if !vxworks
-
-pointer GETHOSTNAME(ctx,n,argv)
-register context *ctx;
-int n; pointer argv[];
-{ char buf[32]; int stat;
- stat=gethostname(buf,32);
- if (stat==0) return(makestring(buf,strlen(buf)));
- else return(makeint(errno));}
-
-pointer GETHOSTBYNAME(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer *argv;
-{ register struct hostent *hp;
- register pointer s;
-
- ckarg(1);
- hp=gethostbyname((char *)Getstring(argv[0])->c.str.chars);
- if (hp==NULL) return(makeint(-errno));
- s=cons(ctx,makeint(hp->h_addrtype),NIL);
- s=cons(ctx,makestring(hp->h_addr,hp->h_length),s);
- return(s);} /*list of 32bit address and address type*/
-
-pointer GETHOSTBYADDR(ctx,n,argv)
-register context *ctx;
-int n;
-pointer *argv;
-{ pointer addr;
- struct hostent *host;
- ckarg(1);
- addr=Getstring(argv[0]);
- host=gethostbyaddr((char *)addr->c.str.chars, vecsize(addr), 2);
- if (host==NULL) return(makeint(-errno));
- else return(makestring(host->h_name, strlen(host->h_name)));}
-
-pointer GETNETBYNAME(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer *argv;
-{ struct netent *np;
- ckarg(1);
- np=getnetbyname((char *)Getstring(argv[0])->c.str.chars);
- if (np==NULL) return(makeint(-errno));
- return(cons(ctx,makeint(np->n_net),
- cons(ctx,makeint(np->n_addrtype),NIL)));}
-
-pointer GETPROTOBYNAME(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer *argv;
-{ struct protoent *pp;
- ckarg(1);
- pp=getprotobyname((char *)Getstring(argv[0])->c.str.chars);
- if (pp==NULL) return(makeint(-errno));
- return(makeint(pp->p_proto));}
-
-pointer GETSERVBYNAME(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer *argv;
-{ struct servent *sp;
- pointer s;
- byte *p;
- long int port;
-
- ckarg2(1,2);
- if (n==2 && argv[1]!=NIL) p=Getstring(argv[1])->c.str.chars;
- else p=NULL;
- sp=getservbyname((char *)Getstring(argv[0])->c.str.chars,(char *)p);
- if (sp==NULL) return(makeint(-errno));
- s=makestring(sp->s_proto,strlen(sp->s_proto));
- vpush(s);
- port = ntohs(sp->s_port);
- s=cons(ctx,makeint(port),cons(ctx,s,NIL));
- vpop();
- return(s);}
-
-/* Append by I.Hara for IPC */
-/* htons -- convert values between host and network byte order */
-pointer H2NS(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer *argv;
-{ int hostshort;
- unsigned short netshort;
- ckarg(1);
- hostshort=ckintval(argv[0]);
- netshort=htons((short)hostshort);
- return(makeint(netshort));}
-
-pointer N2HS(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer *argv;
-{ int hostshort;
- unsigned short netshort;
- ckarg(1);
- netshort=ckintval(argv[0]);
- hostshort=ntohs((short)netshort);
- return(makeint(hostshort));}
-
-#endif
-
-
-
-
-#ifdef DBM
-/* ndbm --- data base
- 1988-May
- (c) T.Matsui
-*/
-
-#if sun3 || sun4
-
-#include
-
-pointer DBM_OPEN(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ DBM *dbm;
- ckarg(3);
- dbm=dbm_open(Getstring(argv[0])->c.str.chars,
- ckintval(argv[1]),
- ckintval(argv[2]));
- return(makeint(dbm));}
-
-pointer DBM_CLOSE(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(1);
- dbm_close(ckintval(argv[0]));
- return(T);}
-
-pointer DBM_FETCH(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ register pointer s;
- datum key,content;
- ckarg(2);
- s=Getstring(argv[1]);
- key.dptr=(char *)(s->c.str.chars);
- key.dsize=strlength(s);
- content=dbm_fetch(ckintval(argv[0]), key);
- if (content.dptr==NULL) return(NIL);
- return(makestring(content.dptr,content.dsize));}
-
-pointer DBM_STORE(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ register pointer s;
- datum key,content;
- ckarg(4);
- s=Getstring(argv[1]);
- key.dptr=(char *)s->c.str.chars;
- key.dsize=strlength(s);
- s=Getstring(argv[2]);
- content.dptr=(char *)s->c.str.chars;
- content.dsize=strlength(s);
- n=dbm_store(ckintval(argv[0]), key, content, ckintval(argv[3]));
- return((n==0)?T:NIL);}
-
-pointer DBM_DELETE(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ register pointer s;
- datum key;
- ckarg(2);
- s=Getstring(argv[1]);
- key.dptr=(char *)s->c.str.chars;
- key.dsize=strlength(s);
- n=dbm_delete(ckintval(argv[0]), key);
- return((n==0)?T:NIL);}
-
-pointer DBM_FIRSTKEY(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ datum key;
- ckarg(1);
- key=dbm_firstkey(ckintval(argv[0]), key);
- if (key.dptr==NULL) return(NIL);
- return(makestring(key.dptr,key.dsize));}
-
-pointer DBM_NEXTKEY(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ datum key;
- ckarg(1);
- key=dbm_nextkey(ckintval(argv[0]), key);
- if (key.dptr==NULL) return(NIL);
- return(makestring(key.dptr,key.dsize));}
-
-pointer DBM_ERROR(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(1);
- n=dbm_error((DBM *)ckintval(argv[0]));
- return((n==0)?T:NIL);}
-
-pointer DBM_CLEARERR(ctx,n,argv)
-register context *ctx;
-int n;
-register pointer argv[];
-{ ckarg(1);
- dbm_clearerr((DBM *)ckintval(argv[0]));
- return(T);}
-
-#endif /*sun3 || sun4*/
-#endif /*ifdef DBM*/
-
-
-/* initialization of unixcall functions*/
-unixcall(ctx,mod)
-register context *ctx;
-pointer mod;
-{ pointer p=Spevalof(PACKAGE);
-
- Spevalof(PACKAGE)=unixpkg;
-
-/* common to unix and to vxworks */
- defun(ctx,"SIGADDSET",mod,SIGADDSET,NULL);
- defun(ctx,"SIGDELSET",mod,SIGDELSET,NULL);
- defun(ctx,"SIGPROCMASK",mod,SIGPROCMASK,NULL);
- defun(ctx,"KILL",mod,KILL,NULL);
- defun(ctx,"SIGNAL",mod,SIGNAL,NULL);
- defun(ctx,"EXIT",mod,EXIT,NULL);
- defun(ctx,"GETPID",mod,GETPID,NULL);
- defun(ctx,"UREAD",mod,UNIXREAD,NULL);
- defun(ctx,"WRITE",mod,UNIXWRITE,NULL);
- defun(ctx,"UCLOSE",mod,UNIXCLOSE,NULL);
- defun(ctx,"IOCTL",mod,IOCTL,NULL);
- defun(ctx,"LSEEK",mod,LSEEK,NULL);
- defun(ctx,"SBRK",mod,SBRK,NULL);
- defun(ctx,"MALLOC",mod,MALLOC,NULL);
- defun(ctx,"FREE",mod,FREE,NULL);
-
- defun(ctx,"SOCKET",mod,SOCKET,NULL);
- defun(ctx,"BIND",mod,BIND,NULL);
- defun(ctx,"CONNECT",mod,CONNECT,NULL);
- defun(ctx,"LISTEN",mod,LISTEN,NULL);
- defun(ctx,"ACCEPT",mod,ACCEPT,NULL);
- defun(ctx,"SENDTO",mod,SENDTO,NULL);
- defun(ctx,"RECVFROM",mod,RECVFROM,NULL);
-#if !Solaris2
- defun(ctx,"GETPEERNAME",mod,GETPEERNAME,NULL);
-#endif
-/* #endif /*socket*/
-
-/*not supported by vxworks*/
-#if !vxworks
- defun(ctx,"PTIMES",mod,PTIMES,NULL);
- defun(ctx,"RUNTIME",mod,RUNTIME,NULL);
- defun(ctx,"LOCALTIME",mod,LOCALTIME,NULL);
- defun(ctx,"ASCTIME",mod,ASCTIME,NULL);
- defun(ctx,"GETITIMER",mod,GETITIMER,NULL);
- defun(ctx,"SETITIMER",mod,SETITIMER,NULL);
-
-#if !Solaris2
- defun(ctx,"GETRUSAGE",mod,GETRUSAGE,NULL);
- defun(ctx,"GETPAGESIZE",mod,GETPAGESIZE,NULL);
-#endif
-
- defun(ctx,"GETTIMEOFDAY",mod,GETTIMEOFDAY,NULL);
- defun(ctx,"ALARM",mod,ALARM,NULL);
-
-#if sun3 || sun4 || news || sanyo || alpha
-#if !Solaris2
- defun(ctx,"UALARM",mod,UALARM,NULL);
-#endif
-#endif
-
- defun(ctx,"WAIT",mod,WAIT,NULL);
- defun(ctx,"FORK",mod,FORK,NULL);
-#if Solaris2
- defun(ctx,"FORK1",mod,FORK1,NULL);
-#endif
- defun(ctx,"GETPPID",mod,GETPPID,NULL);
- defun(ctx,"GETPGRP",mod,GETPGRP,NULL);
- defun(ctx,"SETPGRP",mod,SETPGRP,NULL);
- defun(ctx,"GETUID",mod,GETUID,NULL);
- defun(ctx,"GETEUID",mod,GETEUID,NULL);
- defun(ctx,"GETGID",mod,GETGID,NULL);
- defun(ctx,"GETEGID",mod,GETEGID,NULL);
- defun(ctx,"SETUID",mod,SETUID,NULL);
- defun(ctx,"SETGID",mod,SETGID,NULL);
- defun(ctx,"MKNOD",mod,MKNOD,NULL);
- defun(ctx,"MKDIR",mod,MKDIR,NULL);
- defun(ctx,"LOCKF",mod,LOCKF,NULL);
- defun(ctx,"FCNTL",mod,FCNTL,NULL);
-#if !Solaris2
- defun(ctx,"IOCTL_",mod,IOCTL_,NULL);
- defun(ctx,"IOCTL_R",mod,IOCTL_R,NULL);
- defun(ctx,"IOCTL_W",mod,IOCTL_W,NULL);
- defun(ctx,"IOCTL_WR",mod,IOCTL_WR,NULL);
-#endif
- defun(ctx,"DUP",mod,DUP,NULL);
- defun(ctx,"DUP2",mod,DUP2,NULL);
- defun(ctx,"SYSTEM",mod,SYSTEM,NULL);
- defun(ctx,"GETWD",mod,GETWD,NULL);
- defun(ctx,"GETENV",mod,GETENV,NULL);
- defun(ctx,"ENVIRON",mod,ENVIRON,NULL);
- defun(ctx,"SLEEP",mod,SLEEP,NULL);
- defun(ctx,"ERRNO",mod,ERRNO,NULL);
- defun(ctx,"SYSERRLIST",mod,SYSERRLIST,NULL);
- defun(ctx,"PAUSE",mod,PAUSE,NULL);
- defun(ctx,"ISATTY",mod,ISATTY,NULL);
- defun(ctx,"LINK",mod,LINK,NULL);
- defun(ctx,"UNLINK",mod,UNLINK,NULL);
- defun(ctx,"RMDIR",mod,RMDIR,NULL);
- defun(ctx,"RENAME",mod,RENAME,NULL);
- defun(ctx,"ACCESS",mod,ACCESS,NULL);
-/* defun(ctx,"FLOCK",mod,FLOCK,NULL); */
- defun(ctx,"STAT",mod,STAT,NULL);
- defun(ctx,"CHDIR",mod,CHDIR,NULL);
- defun(ctx,"CHMOD",mod,CHMOD,NULL);
- defun(ctx,"CHOWN",mod,CHOWN,NULL);
- defun(ctx,"PIPE",mod,PIPE,NULL);
- defun(ctx,"SELECT",mod,SELECT,NULL);
- defun(ctx,"SELECT-READ-FD",mod,SELECT_READ,NULL);
- defun(ctx,"READDIR",mod,DIRECTORY,NULL);
-
-#if !vxworks
- defun(ctx,"GETHOSTNAME",mod,GETHOSTNAME,NULL);
- defun(ctx,"GETHOSTBYNAME",mod,GETHOSTBYNAME,NULL);
- defun(ctx,"GETHOSTBYADDR",mod,GETHOSTBYADDR,NULL);
- defun(ctx,"GETNETBYNAME",mod,GETNETBYNAME,NULL);
- defun(ctx,"GETPROTOBYNAME",mod,GETPROTOBYNAME,NULL);
- defun(ctx,"GETSERVBYNAME",mod,GETSERVBYNAME,NULL);
-/* Append by I.Hara for IPC */
- defun(ctx,"HTONS",mod,H2NS,NULL);
- defun(ctx,"NTOHS",mod,N2HS,NULL);
-#endif
-
-#if sun3 || sun4 || vax || news || sanyo || (mips && !IRIX && !IRIX6) || i386 || alpha
- defun(ctx,"VFORK",mod,VFORK,NULL);
-#endif
- defun(ctx,"EXEC",mod,EXEC,NULL);
-#if !Solaris2
- defun(ctx,"GETPRIORITY",mod,GETPRIORITY,NULL);
- defun(ctx,"SETPRIORITY",mod,SETPRIORITY,NULL);
-#endif
-
-#if sun3 || sun4 || vax || mips || i386 || alpha
- defun(ctx,"PUTENV",mod,PUTENV,NULL);
-#endif
-#if sun3 || sun4 && !Solaris2 || Linux || alpha
- defun(ctx,"USLEEP",mod,USLEEP,NULL);
-#endif
-
-#if !news
- defun(ctx,"MSGGET",mod,MSGGET,NULL);
- defun(ctx,"MSGSND",mod,MSGSND,NULL);
- defun(ctx,"MSGRCV",mod,MSGRCV,NULL);
- defun(ctx,"MSGCTL",mod,MSGCTL,NULL);
-#endif
-
-#if sun3 || sun4 || news || alpha
- defun(ctx,"VALLOC",mod,VALLOC,NULL);
-#endif
-#if sun3 || sun4 || news || alpha || Linux
- defun(ctx,"MMAP",mod,MMAP,NULL);
- defun(ctx,"MUNMAP",mod,MUNMAP,NULL);
-/* defun(ctx,"VADVISE",mod,VADVISE,NULL); */
-#endif
-
-#if system5 || Linux
- defun(ctx,"UNAME",mod,UNAME,NULL);
-#endif
-
-#endif /*socket*/
-
-/*ndbm libraries*/
-#ifdef DBM
-#if sun3 || sun4
- defun(ctx,"DBM-OPEN",mod,DBM_OPEN,NULL);
- defun(ctx,"DBM-CLOSE",mod,DBM_CLOSE,NULL);
- defun(ctx,"DBM-FETCH",mod,DBM_FETCH,NULL);
- defun(ctx,"DBM-STORE",mod,DBM_STORE,NULL);
- defun(ctx,"DBM-DELETE",mod,DBM_DELETE,NULL);
- defun(ctx,"DBM-FIRSTKEY",mod,DBM_FIRSTKEY,NULL);
- defun(ctx,"DBM-NEXTKEY",mod,DBM_NEXTKEY,NULL);
- defun(ctx,"DBM-ERROR",mod,DBM_ERROR,NULL);
- defun(ctx,"DBM-CLEARERR",mod,DBM_CLEARERR,NULL);
-#endif
-
-#endif
-/* restore package*/ Spevalof(PACKAGE)=p;
-}
diff --git a/lisp/c/vectorarray.c b/lisp/c/vectorarray.c
index aa52a5458..ba546d1ed 100644
--- a/lisp/c/vectorarray.c
+++ b/lisp/c/vectorarray.c
@@ -277,8 +277,6 @@ pointer argv[];
/* bit vector
/****************************************************************/
-#define isbitvector(p) (isvector(p) && (elmtypeof(p)==ELM_BIT))
-
pointer BIT(ctx,n,argv)
register context *ctx;
int n;
diff --git a/lisp/comp/builtins.l b/lisp/comp/builtins.l
index ad16a3aa6..abb41c4e4 100644
--- a/lisp/comp/builtins.l
+++ b/lisp/comp/builtins.l
@@ -15,6 +15,7 @@
(putprop sym lab 'builtin-function-entry ))
(def-builtin-entry 'LISP:= "NUMEQUAL")
+(def-builtin-entry 'LISP:/= "NUMNEQUAL")
(def-builtin-entry 'LISP:> "GREATERP")
(def-builtin-entry 'LISP:< "LESSP")
(def-builtin-entry 'LISP:>= "GREQP")
@@ -30,6 +31,12 @@
(def-builtin-entry 'LISP:COS "COS")
(def-builtin-entry 'LISP:TAN "TAN")
(def-builtin-entry 'LISP:ATAN "ATAN")
+(def-builtin-entry 'LISP:SINH "SINH")
+(def-builtin-entry 'LISP:COSH "COSH")
+(def-builtin-entry 'LISP:TANH "TANH")
+(def-builtin-entry 'LISP:ATANH "ATANH")
+(def-builtin-entry 'LISP:ASINH "ASINH")
+(def-builtin-entry 'LISP:ACOSH "ACOSH")
(def-builtin-entry 'LISP:SQRT "SQRT")
(def-builtin-entry 'LISP:LOG "LOG")
(def-builtin-entry 'LISP:EXP "EXP")
@@ -45,6 +52,9 @@
(def-builtin-entry 'LISP:LOGAND "LOGAND")
(def-builtin-entry 'LISP:LOGIOR "LOGIOR")
(def-builtin-entry 'LISP:LOGXOR "LOGXOR")
+(def-builtin-entry 'LISP:LOGEQV "LOGEQV")
+(def-builtin-entry 'LISP:LOGNAND "LOGNAND")
+(def-builtin-entry 'LISP:LOGNOR "LOGNOR")
(def-builtin-entry 'LISP:LOGNOT "LOGNOT")
(def-builtin-entry 'LISP:LOGTEST "LOGTEST")
(def-builtin-entry 'LISP:LOGBITP "LOGBITP")
@@ -68,10 +78,14 @@
(def-builtin-entry 'LISP:CHAR-DOWNCASE "CHDOWNCASE")
(def-builtin-entry 'LISP:COPY-OBJECT "COPYOBJ")
+(def-builtin-entry 'LISP:REPLACE-OBJECT "REPLACEOBJECT")
+(def-builtin-entry 'LISP:BECOME "BECOME")
(def-builtin-entry 'LISP:CLASS "GETCLASS")
+(def-builtin-entry 'LISP:ENTER-CLASS "ENTERCLASS")
(def-builtin-entry 'LISP:SEND "SEND")
(def-builtin-entry 'LISP:SEND-MSG "SEND")
(def-builtin-entry 'LISP:SEND-MESSAGE "SENDMESSAGE")
+(def-builtin-entry 'LISP:SEND-IF-FOUND "SEND_IF_FOUND")
(def-builtin-entry 'LISP:INSTANTIATE "INSTANTIATE")
(def-builtin-entry 'LISP:CLASSP "CLASSP")
(def-builtin-entry 'LISP:SUBCLASSP "SUBCLASSP")
@@ -79,13 +93,14 @@
(def-builtin-entry 'LISP:SLOT "SLOT")
(def-builtin-entry 'LISP:SETSLOT "SETSLOT")
(def-builtin-entry 'LISP:CLONE "CLONE")
-;;(def-builtin-entry 'SYSTEM::METHOD "FINDMETHOD")
+(def-builtin-entry 'LISP::FIND-METHOD "FINDMETHOD")
(def-builtin-entry 'SYSTEM::METHOD-CACHE "METHCACHE")
; (def-builtin-entry 'LISP:OPEN "OPEN") ;rewritten in euslisp
(def-builtin-entry 'LISP:CLOSE "CLOSE")
(def-builtin-entry 'LISP:READ "READ")
(def-builtin-entry 'LISP:READ-LINE "READLINE")
+(def-builtin-entry 'LISP:READ-DELIMITED-LIST "READ_DELIMITED_LIST")
(def-builtin-entry 'LISP:READ-CHAR "READCH")
(def-builtin-entry 'LISP:UNREAD-CHAR "UNREADCH")
(def-builtin-entry 'LISP:PEEK-CHAR "PEEKCH")
@@ -99,10 +114,12 @@
(def-builtin-entry 'LISP:WRITE-WORD "WRTWORD")
(def-builtin-entry 'LISP:WRITE-LONG "WRTLONG")
(def-builtin-entry 'LISP:SET-MACRO-CHARACTER "SETMACROCH")
+(def-builtin-entry 'LISP:GET-MACRO-CHARACTER "GETMACROCH")
(def-builtin-entry 'LISP:SET-DISPATCH-MACRO-CHARACTER "SETDISPMACRO")
(def-builtin-entry 'LISP:GET-DISPATCH-MACRO-CHARACTER "GETDISPMACRO")
(def-builtin-entry 'LISP:FORMAT "XFORMAT")
(def-builtin-entry 'system::SAVE "SAVE")
+(def-builtin-entry 'system::SRCLOAD "SRCLOAD")
(def-builtin-entry 'system::BINLOAD "BINLOAD")
(def-builtin-entry 'LISP:V+ "VPLUS")
(def-builtin-entry 'LISP:V- "VMINUS")
@@ -111,6 +128,8 @@
(def-builtin-entry 'LISP:V.* "SCA3PROD")
(def-builtin-entry 'LISP:V< "VLESSP")
(def-builtin-entry 'LISP:V> "VGREATERP")
+(def-builtin-entry 'LISP:V-ABS "VMINUS_ABS")
+(def-builtin-entry 'LISP:V++ "VPLUSPLUS")
(def-builtin-entry 'LISP:VMIN "VMIN")
(def-builtin-entry 'LISP:VMAX "VMAX")
(def-builtin-entry 'LISP:MINIMAL-BOX "MINIMALBOX")
@@ -120,6 +139,8 @@
(def-builtin-entry 'LISP:NORMALIZE-VECTOR "VNORMALIZE")
(def-builtin-entry 'LISP:DISTANCE "VDISTANCE")
(def-builtin-entry 'LISP:DISTANCE2 "VDISTANCE2")
+(def-builtin-entry 'LISP:DIRECTION "VDIRECTION")
+(def-builtin-entry 'LISP:MIDPOINT "MIDPOINT")
;; (def-builtin-entry 'LISP:TRIANGLE "TRIANGLE") ;obsolete
(def-builtin-entry 'LISP:FLOATVECTOR "MKFLTVEC")
(def-builtin-entry 'LISP:FLOAT-VECTOR "MKFLTVEC")
@@ -165,11 +186,9 @@
(def-builtin-entry 'LISP:EQUAL "EQUAL")
(def-builtin-entry 'LISP:SUPEREQUAL "SUPEREQUAL")
(def-builtin-entry 'LISP:MEMQ "MEMQ")
-;;(def-builtin-entry 'LISP:MEMBER "MEMBER")
-(def-builtin-entry 'LISP:SUPERMEMBER "SUPERMEMBER")
+(def-builtin-entry 'SYS::RAW-MEMBER "MEMBER")
(def-builtin-entry 'LISP:ASSQ "ASSQ")
-;(def-builtin-entry 'LISP:ASSOC "ASSOC")
-(def-builtin-entry 'LISP:SUPERASSOC "SUPERASSOC")
+(def-builtin-entry 'SYS::RAW-ASSOC "ASSOC")
(def-builtin-entry 'LISP:APPEND "APPEND")
(def-builtin-entry 'LISP:NCONC "NCONC")
(def-builtin-entry 'LISP:SUBST "SUBST")
@@ -202,9 +221,18 @@
(def-builtin-entry 'LISP:ELT "ELT")
(def-builtin-entry 'LISP:SETELT "SETELT")
(def-builtin-entry 'LISP:CHAR "EUSCHAR")
+(def-builtin-entry 'LISP:SCHAR "EUSCHAR")
(def-builtin-entry 'LISP:SETCHAR "SETCHAR")
(def-builtin-entry 'LISP:BIT "BIT")
+(def-builtin-entry 'LISP:SBIT "SBIT")
(def-builtin-entry 'LISP:SETBIT "SETBIT")
+(def-builtin-entry 'LISP:BIT-AND "BITAND")
+(def-builtin-entry 'LISP:BIT-IOR "BITIOR")
+(def-builtin-entry 'LISP:BIT-XOR "BITXOR")
+(def-builtin-entry 'LISP:BIT-EQV "BITEQV")
+(def-builtin-entry 'LISP:BIT-NAND "BITNAND")
+(def-builtin-entry 'LISP:BIT-NOR "BITNOR")
+(def-builtin-entry 'LISP:BIT-NOT "BITNOT")
(def-builtin-entry 'LISP:VECTOR "MKVECTOR")
(def-builtin-entry 'LISP:INTEGER-VECTOR "MKINTVECTOR")
(def-builtin-entry 'LISP:SYMBOLP "SYMBOLP")
@@ -224,6 +252,8 @@
;; (def-builtin-entry 'LISP:STRING= "STR_EQ")
(def-builtin-entry 'LISP:STRING> "STR_GT")
(def-builtin-entry 'LISP:STRING>= "STR_GE")
+(def-builtin-entry 'LISP:STRINGEQ "STRINGEQ")
+(def-builtin-entry 'LISP:STRINGEQUAL "STRINGEQUAL")
(def-builtin-entry 'LISP:EVAL "EVAL")
(def-builtin-entry 'LISP:APPLY "APPLY")
(def-builtin-entry 'LISP:FUNCALL "FUNCALL")
@@ -241,6 +271,7 @@
(def-builtin-entry 'LISP::SYMBOL-BOUND-VALUE "SYMBNDVALUE")
(def-builtin-entry 'LISP:SYMBOL-FUNCTION "SYMFUNC")
(def-builtin-entry 'LISP:MAKUNBOUND "MAKUNBOUND")
+(def-builtin-entry 'LISP:FMAKUNBOUND "FMAKUNBOUND")
(def-builtin-entry 'LISP:SET "SETSPECIAL")
(def-builtin-entry 'LISP:FIND-SYMBOL "FINDSYMBOL")
(def-builtin-entry 'LISP:INTERN "INTERN")
@@ -367,8 +398,12 @@
;(def-builtin-entry 'SYS::MALLOC_DEBUG "MALLOC_DEBUG")
;(def-builtin-entry 'SYS::MALLOC_VERIFY "MALLOC_VERIFY")
(def-builtin-entry 'SYS:LIST-ALL-REFERENCES "LISTALLREFERENCES")
+(def-builtin-entry 'SYS:LIST-CALLSTACK "LISTCALLSTACK")
+(def-builtin-entry 'SYS:LIST-ALL-BLOCKS "LISTALLBLOCKS")
+(def-builtin-entry 'SYS:LIST-ALL-TAGS "LISTALLTAGS")
(def-builtin-entry 'SYS:LIST-ALL-CATCHERS "LISTALLCATCHERS")
(def-builtin-entry 'SYS:LIST-ALL-BINDINGS "LISTBINDINGS")
+(def-builtin-entry 'SYS:LIST-ALL-FUNCTION-BINDINGS "LISTFUNCTIONBINDINGS")
(def-builtin-entry 'SYS:LIST-ALL-SPECIAL-BINDINGS "LISTSPECIALBINDINGS")
(def-builtin-entry 'SYS:LIST-ALL-CLASSES "LISTALLCLASSES")
(def-builtin-entry 'SYS::EXPORT-ALL-SYMBOLS "EXPORTALL")
diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l
index dfb725953..3eb880760 100644
--- a/lisp/comp/comp.l
+++ b/lisp/comp/comp.l
@@ -15,14 +15,16 @@
(in-package "COMPILER")
(eval-when (load eval)
- (export '(compile compile-file comfile identifier
+ (export '(compile compile-method compile-file comfile identifier
compile-file-if-src-newer))
- (export '(*safety* *space* *verbose* *optimize* *speed* *cc*)) )
+ (export '(*safety* *space* *verbose* *optimize* *speed* *cc*
+ *type-check-declare*)))
(defun compiled-code-p (x) (derivedp x compiled-code))
(eval-when (load eval)
+(defparameter *type-check-declare* nil)
(defparameter *coptflags* "")
(defparameter *cflags* "")
(defparameter *defun-list* nil)
@@ -48,6 +50,13 @@
(defvar trans)
(defvar *multipass-optimize* t)
+;; `closure-frames' collects variables referenced during preevaluation
+;; `closure-function-frames' collects functions called during preevaluation
+;; this allows to allocate minimal size frames for each closure
+;; both values are locally overwritten at each function invocation,
+;; the global value should never need to be modified
+(defvar closure-frames nil)
+(defvar closure-function-frames nil)
(defun ovafp (form) (and (cdr form) (symbolp (cdr form))))
@@ -68,6 +77,11 @@
(= (var . vtype) 2)
)
+(defun proclaimed-constant-p (var)
+ (declare (type symbol var))
+ (= (var . vtype) 0)
+ )
+
(defun object-variable-names (klass-name)
(let (klass varvec i r)
(if (symbolp klass-name)
@@ -81,16 +95,15 @@
r))
(defun object-variable-type (klass var)
- (declare (type metaclass klass))
(when (not (classp klass))
(if (class-symbolp klass)
(setq klass (symbol-value klass))
- (error "class expected for type check")))
+ (error type-error "class expected for type check")))
(if (numberp var)
(setq var (svref (klass . types) var))
(let ((index (position var (klass . vars))))
(if (null index)
- (send comp :error "no such obj var" var)
+ (send comp :error "no such obj var ~S" var)
(setq var (svref (klass . types) index)))))
(if (consp var) (car var) var))
@@ -101,7 +114,10 @@
(defun check-arg (req n &optional (fn "car/cdr"))
(if (null (= req n))
- (warn "mismatch arg for " fn)))
+ (error argument-error "mismatch arg for ~A" fn)))
+
+(defun function-alias (sym)
+ (or (get sym 'function-alias) sym))
(defun def-function-type (type funcs)
(dolist (f funcs) (putprop f type 'function-result-type)))
@@ -126,7 +142,7 @@
;
(eval-when (load compile eval)
(defclass identifier :super object
- :slots (name type binding level offset))
+ :slots (name type binding level offset bindframe cbindframe clist))
)
;; binding = (constant, local, global, special)
@@ -144,6 +160,63 @@
self))
)
+; function identifier
+;
+(eval-when (load compile eval)
+(defclass function-identifier :super object
+ :slots (name entry binding level offset bindframe cbindframe body newcomp clist))
+)
+
+(eval-when (load eval)
+(defmethod function-identifier
+ (:init (sym bin off &optional lev ent bd cmp)
+ (setq name sym
+ binding bin
+ offset off
+ level lev
+ entry ent
+ body bd
+ newcomp cmp
+ bindframe nil)
+ self)
+ (:init-body (sym bin &optional bd)
+ (setq name sym
+ binding bin
+ body bd)
+ self))
+)
+
+; closure identifier
+;
+(eval-when (load compile eval)
+(defclass closure-identifier :super object
+ :slots (name entry def newcomp cframes fframes))
+)
+
+(eval-when (load eval)
+(defmethod closure-identifier
+ (:init (sym ent form cmp cf ff)
+ (setq name sym
+ entry ent
+ def form
+ newcomp cmp
+ cframes cf
+ fframes ff)
+ self)
+ (:compile ()
+ (let ((cbind (append cframes fframes)))
+ (setq (newcomp . current-cframes) (cons cframes (newcomp . current-cframes)))
+ (setq (newcomp . current-fframes) (cons fframes (newcomp . current-fframes)))
+ (setq (newcomp . current-csize) (cons (length cbind) (newcomp . current-csize)))
+ ;; recalculate function cbindings
+ (setq (newcomp . flets) (copy-object (newcomp . flets)))
+ (dolist (fdef (newcomp . flets))
+ ;; only reassign the most recent level
+ (when (eq (fdef . cbindframe) t)
+ (setq (fdef . cbindframe) (position (fdef . bindframe) cbind))))
+ (send newcomp :compile-a-closure name entry def))))
+)
+
; identifier table
;
(eval-when (load compile eval)
@@ -160,6 +233,27 @@
(while (>= lev 0)
(setq r (assq id (svref frames lev)))
(if r (return-from :get (cdr r)) (dec lev)))))
+ (:get-cframes (fn clevel &optional (lev level))
+ ;; collect the binding offset of all variables which are used inside a function
+ ;; we only need to consider the current closure-level since other levels are
+ ;; accessed through the env0, not env1
+ (let (acc)
+ (while (>= lev 0)
+ ;; collect closure frames
+ (dolist (var (svref frames lev))
+ (setq var (cdr var))
+ (when (and var (= (var . level) clevel)
+ (find fn (var . clist) :test #'equal))
+ (pushnew (var . bindframe) acc)))
+ (dec lev))
+ ;; update cbindframe offset value on the current level
+ (dotimes (lev (1+ level))
+ (dolist (var (svref frames lev))
+ (let* ((var (cdr var))
+ (pos (position (var . bindframe) acc)))
+ (if pos
+ (setq (var . cbindframe) pos)))))
+ acc))
(:enter (id &optional (lev level))
(svset frames lev (cons (cons (id . name) id) (svref frames lev)))
id)
@@ -183,15 +277,21 @@
(eval-when (load compile eval)
(defclass stack-frame :super object
- :slots (offset specials locals))
+ :slots
+ (type ; 'arg, 'local, or 'flet
+ level ; closure level of the frame
+ offset ; offset of the frame on the local stack
+ specials ; number of special variables on the stack
+ locals)) ; number of local variables on the stack
)
(eval-when (load eval)
(defmethod stack-frame
+ (:level (&optional (lvl nil)) (if lvl (setq level lvl)) level)
(:offset (&optional (off nil)) (if off (setq offset off)) offset)
(:special (&optional (i 0)) (setq specials (+ specials i)))
(:local (&optional (i 0)) (setq locals (+ locals i)))
- (:init () (setq offset nil specials 0 locals 0) self))
+ (:init (tp) (setq type tp specials 0 locals 0) self))
)
@@ -203,14 +303,19 @@
(defclass compiler :super object
:slots
(idtable ;identifier-table
- closure-level ;currunt closure level
+ closure-level ;current closure level
+ current-cframes ;current closure bind frames
+ current-fframes ;current closure flet frames
+ current-csize ;current closure env1 size
scope ;current variable scope (for sequential let)
frames ;list of the number of special bindings
+ fletframes ;list of function frames
+ argframes ;list of argument frames
blocks ;block labels
tags ;tagbody go labels
function-closures ; (function ...) list
initcodes ;initialize codes in "eusmain"
- flets
+ flets ;list of flet frames
unwind-frames ;frames need to unwound when jumps
symstr
)))
@@ -250,49 +355,121 @@
(send self :eval `(apply (function ,(car form)) ,(cdr form))))
(t
(let* ((fdef (send self :get-function (car form)))
- (ftype (second fdef)))
+ (ftype (fdef . binding)))
(case ftype
(lambda (send self :funcall (car form) (cdr form)))
(special (send self :special-form (car form) (cdr form)))
(macro (send self :eval (macroexpand form)))
+ (macrolet (send self :eval (eval `(,(fdef . body) ,@(cdr form)))))
(closure (send self :call-closure fdef (cdr form)))
- (t (send self :error "unknown func type" form))) ))))
+ (t (send self :error "unknown func type ~S" form))) ))))
(:get-function (fn)
- (if (not (symbolp fn)) (send self :error "symbol expected for a func. name"))
- (let ((fdef (assq fn flets)))
+ (if (not (symbolp fn)) (send self :error "symbol expected for a function name"))
+ (let ((fdef (find-if #'(lambda (x) (eql (x . name) fn)) flets)))
(if fdef
- fdef
+ (progn
+ (when (and avant-mode closure-function-frames
+ (fdef . level)
+ (> closure-level (fdef . level)))
+ (unless (assoc 'closure-function-frames (sys:list-all-special-bindings))
+ (send self :error "attempting to set global closure-function-frames value"))
+ (unless (listp closure-function-frames)
+ (setq closure-function-frames nil))
+ (pushnew fdef closure-function-frames)
+ (unless (fdef . bindframe)
+ (setq (fdef . bindframe) t)))
+
+ ;; compile-time check to see if we are not missing any frame references
+ (when (and (not avant-mode)
+ (fdef . level)
+ (> closure-level (fdef . level))
+ (fdef . bindframe))
+ (let* ((c-index (- closure-level (fdef . level)))
+ (c-fframes (car (nthcdr (1- c-index) current-fframes)))
+ (c-csize (car (nthcdr (1- c-index) current-csize))))
+ (unless (find (fdef . bindframe) c-fframes)
+ (send self :error "unbound fletframe detected when loading function ~S: ~A"
+ (fdef . name) (fdef . bindframe)))
+ (unless (< (send self :flet-bindframe fdef) c-csize)
+ (send self :error "invalid fletframe index detected when loading function ~S: ~A"
+ (fdef . name) (fdef . cbindframe)))))
+ fdef)
(cond ((fboundp fn)
(setq fdef (symbol-function fn))
(if (compiled-function-p fdef)
- (list fn (cdr (assq (compiled-code-type fdef)
+ (instance function-identifier :init-body
+ fn (cdr (assq (fdef . type)
'((0 . lambda) (1 . macro) (2 . special))))
- fdef)
- (cons fn fdef)))
- (t (list fn 'lambda))))))
+ fdef)
+ (instance function-identifier :init-body
+ fn (car fdef) (cdr fdef))))
+ (t (instance function-identifier :init-body fn 'lambda))))))
(:call-closure (fdef args)
(if *debug* (print (list :call-closure fdef args)))
(dolist (a args) (send self :eval a))
- (send trans :load-local (third fdef) (- closure-level (fourth fdef)))
- (send trans :call-closure (fifth fdef) (length args)))
+ (send trans :load-local (fdef . offset) (- closure-level (fdef . level))
+ (send self :flet-bindframe fdef))
+ (send trans :call-closure (fdef . entry) (length args)))
+ (:get-flet-cframes (fn clevel cstart &optional (function-table flets))
+ ;; collect the binding offset of all flets used inside a function
+ (let (acc)
+ (dolist (f function-table)
+ (when (and f (= (f . level) clevel)
+ (find fn (f . clist) :test #'equal))
+ (pushnew (f . bindframe) acc)))
+ ;; update cbindframe offset value
+ ;; this value is only used at the base level
+ ;; it is recalculated on each closure definition (`:compile-closures')
+ (dolist (f function-table)
+ (let ((pos (position (f . bindframe) acc)))
+ (if pos
+ (setq (f . cbindframe) (+ cstart pos)))))
+ acc))
+ (:flet-bindframe (fdef)
+ (if (and (fdef . cbindframe) (> closure-level (fdef . level)))
+ (fdef . cbindframe)
+ (fdef . bindframe)))
(:variable (var) ;var must be a symbol, ovaf is not allowed here.
(let ((result (send idtable :get var scope)))
- (if result (return-from :variable result))
+ (if (and result
+ (or avant-mode
+ (not (and (> closure-level (result . level)) (eq (result . bindframe) t)))))
+ (return-from :variable result))
(setq result (instance identifier :init var 'special 0 0))
(cond
((proclaimed-special-p var)
(send idtable :enter-special result) )
((proclaimed-global-p var)
(send idtable :enter-special result)) ;Jan, 96
+ ((proclaimed-constant-p var)
+ (send idtable :enter result))
(t
- (format *error-output* "; ~C[34;7m~S~C[0;34m is assumed to be global~C[0m~%"
- #x1b var #x1b #x1b)
+ (unless avant-mode
+ (format *error-output* "; ~C[34;7m~S~C[0;34m is assumed to be global~C[0m~%"
+ #x1b var #x1b #x1b))
(send idtable :enter result)) )
result))
(:var-binding (var)
(if (consp var)
'ovaf
(send (send self :variable var) :binding)))
+ (:var-bindframe (var)
+ (cond
+ ((and (var . cbindframe) (> closure-level (var . level)))
+ (var . cbindframe))
+ ((or (var . bindframe) (= closure-level (var . level)))
+ (var . bindframe))
+ (t
+ (labels ((find-frame (frame-list)
+ (find-if #'(lambda (frame) (= (frame . level) (var . level))) frame-list))
+ (find-offset (frame-list)
+ (let ((fr (find-frame frame-list)))
+ (if fr (fr . offset)))))
+ (case (var . binding)
+ ((local let)
+ (find-offset frames))
+ ((param arg object lambda)
+ (find-offset argframes)))))))
(:special-variable-p (id)
(let ((v (send idtable :find id)))
(if (null v)
@@ -306,43 +483,99 @@
id 'unknown closure-level nil))
(send idtable :enter v)
(when (or (proclaimed-special-p id) (proclaimed-global-p id))
- (if (constantp id) (send self :error "not variable" id))
+ (if (constantp id) (send self :error "not variable ~S" id))
(send v :binding 'special)
))
v))
- (:bind (id binding offset &optional (keyvarp nil))
+ (:bind (id frame binding offset &key keyvarp)
(unless (symbolp id)
- (error "symbol expected for function argument" id))
+ (error type-error "symbol expected for function argument" id))
(let ((v (send self :enter-variable id)))
(declare (type identifier v))
(cond
((eq (v . binding) 'special)
- (send (car frames) :special 1)
+ (send frame :special 1)
(case binding
- (local (if keyvarp (send (car frames) :local 1)))
- (arg (send trans :load-arg offset 0))
- (t (send self :error "illegal binding")))
+ (local (if keyvarp (send frame :local 1)))
+ (arg (send trans :load-arg offset 0)))
(push offset unwind-frames)
(send trans :bind-special id))
(t
- (if (eq binding 'local) (send (car frames) :local 1))
+ (if (eq binding 'local) (send frame :local 1))
(setq (v . binding) binding
(v . offset) offset)))
v))
- (:create-frame ()
- (push (instance stack-frame :init) frames)
- (send idtable :create-frame)
- (setq scope (send idtable :level)))
- (:delete-frame (flag)
- (let* ((f (pop frames)) (nospecials (f . specials)))
+ (:bind-identifier (v frame &key keyvarp)
+ (unless (derivedp v identifier)
+ (error type-error "identifier expected"))
+ (unless (send idtable :find (v . name))
+ (send idtable :enter v))
+ (send self :bind (v . name) frame (v . binding) (v . offset) :keyvarp keyvarp))
+ (:bind-closure-variable (v binding frame i &key (store t))
+ ;; rewrite the variable reference to point to the binding frame instead
+ (setq (v . binding) binding
+ (v . bindframe) (frame . offset)
+ (v . offset) i)
+ (send self :bind-identifier v frame)
+ (if store (send self :store-var v)))
+ (:create-frame (type &optional size comment)
+ ;; create a vector to store closure variables in the heap
+ (let ((frame (instance stack-frame :init type)))
+ (setq (frame . level) closure-level)
+ (when (and size (> size 0))
+ (setq (frame . offset) (send trans :create-frame size comment))
+ (send frame :local 1))
+ (case type
+ (arg
+ (push frame argframes))
+ (local
+ (push frame frames))
+ (flet
+ (push frame fletframes))
+ ;; (t (send self :error "unknow frame type ~S" type))
+ )
+ (case type
+ ((arg local)
+ (send idtable :create-frame)
+ (setq scope (send idtable :level))))
+ frame))
+ (:bind-frame (frame body vlist &optional comment)
+ ;; pre-evaluate body
+ (let ((trans (send trans :copy-translator))
+ (avant-mode t))
+ (send self :progn body))
+ ;; bind frame vector
+ (setq vlist
+ (remove-if-not #'(lambda (v) (and (derivedp v identifier) (v . bindframe))) vlist))
+ (when vlist
+ (send trans :reset-vsp)
+ (setq (frame . offset) (send trans :create-frame (length vlist) comment))
+ (send frame :local 1))
+ (dotimes (i (length vlist))
+ (let ((v (nth i vlist)))
+ (send self :load-var v)
+ (send trans :clearpush-frame (frame . offset) i)
+ (setq (v . bindframe) (frame . offset)
+ (v . offset) i)))
+ frame)
+ (:delete-frame (type flag)
+ (let* ((f
+ (case type
+ (arg (pop argframes))
+ (local (pop frames))
+ (flet (pop fletframes))
+ (t (send self :error "unknown frame type ~S" type))))
+ (nospecials (f . specials)))
(declare (type stack-frame f))
(if (> nospecials 0)
(if flag
(send trans :unbind-special (f . specials))
- (send self :warning "no special object variables allowed")))
+ (send self :error "no special object variables allowed")))
(if flag (send trans :del-frame (f . specials) (f . locals)))
- (send idtable :pop-frame)
- (setq scope (send idtable :level))))
+ (case type
+ ((arg local)
+ (send idtable :pop-frame)
+ (setq scope (send idtable :level))))))
(:load-ovaf (form var)
(let ((form-type (send self :eval form)) (index 0))
(if (null (memq form-type '(integer fixnum float number t nil)))
@@ -352,7 +585,7 @@
(setq index (position var (object-variable-names form-type)))
(if (numberp index)
(send trans :load-indexed-ov index)
- (send self :error "no such object variable" form var))
+ (send self :error "no such object variable ~S ~S" form var))
(object-variable-type form-type index))
(t (send trans :load-ovaf var)
t)) ))
@@ -360,18 +593,52 @@
(when (consp var)
(send self :load-ovaf (car var) (cdr var))
(return-from :load-var t))
- (setq var (send self :variable var))
- (case (var . binding)
- ((special) (send trans :load-global (var . name)))
- ((local let lambda)
- (send trans :load-local (var . offset) (- closure-level (var . level))))
- ((param arg)
- (send trans :load-arg (var . offset) (- closure-level (var . level))))
- ((object)
- (send trans :load-obj (var . offset) (- closure-level (var . level))))
- (unknown
- (send self :error "declared but unknown variable" (var . name)))
- )
+ (unless (derivedp var identifier)
+ (setq var (send self :variable var)))
+ (flet ((push-cframe (&optional (pushvar var))
+ ;; collect referenced variables during pre-evaluation mode
+ (when (and avant-mode closure-frames (> closure-level (var . level)))
+ (unless (assoc 'closure-frames (sys:list-all-special-bindings))
+ (send self :error "attempting to set global closure-frames value"))
+ (unless (listp closure-frames) (setq closure-frames nil))
+ (pushnew pushvar closure-frames)
+ (unless (pushvar . bindframe) (setq (pushvar . bindframe) t))))
+ (check-cframe (&optional (pushvar var))
+ ;; compile-time check to see if we are not missing any frame references
+ (when (and (not avant-mode) (> closure-level (var . level))
+ (numberp (pushvar . bindframe)))
+ (let* ((c-index (- closure-level (var . level)))
+ (c-cframes (car (nthcdr (1- c-index) current-cframes)))
+ (c-csize (car (nthcdr (1- c-index) current-csize))))
+ (unless (find (pushvar . bindframe) c-cframes)
+ (send self :error ";; unbound bindframe detected when loading variable ~S: ~A"
+ (var . name) (pushvar . bindframe)))
+ (unless (< (send self :var-bindframe pushvar) c-csize)
+ (send self :error ";; invalid bindframe index detected when loading variable ~S: ~A"
+ (var . name) (send self :var-bindframe pushvar)))))))
+ (case (var . binding)
+ ;; special variables are accessed through :load-global, so we don't need
+ ;; to add or manage them in bind frames
+ ((special) (send trans :load-global (var . name)))
+ ((local let lambda)
+ (push-cframe)
+ (check-cframe)
+ (send trans :load-local (var . offset) (- closure-level (var . level))
+ (send self :var-bindframe var)))
+ ((param arg)
+ (push-cframe)
+ (check-cframe)
+ (send trans :load-arg (var . offset) (- closure-level (var . level))
+ (send self :var-bindframe var)))
+ ((object)
+ ;; we only need to ensure access to the `self' variable in closures,
+ ;; all other slots are derived from there
+ (push-cframe (send idtable :get 'self))
+ (check-cframe (send idtable :get 'self))
+ (send trans :load-obj (var . offset) (- closure-level (var . level))
+ (send self :var-bindframe var)))
+ (unknown
+ (send self :error "declared but unknown variable ~S" (var . name)))))
(send var :type))
(:store-ovaf (form varname)
(let ((form-type (send self :eval form)))
@@ -385,20 +652,26 @@
t)
(send trans :store-ovaf varname))))
(:store-var (var)
- (setq var (send self :variable var))
+ (unless (derivedp var identifier)
+ (setq var (send self :variable var)))
(case (var . binding)
((special) (send trans :store-global (var . name)))
((local let lambda)
- (send trans :store-local (var . offset) (- closure-level (var . level))))
- ((param arg) (send trans :store-arg (var . offset)
- (- closure-level (var . level))))
- ((object) (send trans :store-obj (var . offset)
- (- closure-level (var . level)))))))
+ (send trans :store-local (var . offset) (- closure-level (var . level))
+ (send self :var-bindframe var)))
+ ((param arg)
+ (send trans :store-arg (var . offset) (- closure-level (var . level))
+ (send self :var-bindframe var)))
+ ((object)
+ (send trans :store-obj (var . offset) (- closure-level (var . level))
+ (send self :var-bindframe var)))))
+ ) ; defmethod
) ;eval-when
(eval-when (load eval)
(defmethod compiler
(:funcall (sym args)
+ (setq sym (function-alias sym))
(let ((argcount (length args)) (arg-type-list nil) (entry))
(declare (type integer argcount))
(if (null (memq sym '(slot setslot)))
@@ -571,7 +844,7 @@
(eval-when (load eval)
(defmethod compiler
(:special-form (fn args)
- (case fn
+ (case (function-alias fn)
((quote) (send trans :load-quote (car args)) t)
((setq) (send self :setq args))
((if) (send self :if args) t)
@@ -589,17 +862,18 @@
((go) (send self :go (car args)) t)
((flet) (send self :flet (car args) (cdr args) nil) t)
((labels) (send self :flet (car args) (cdr args) t) t)
+ ((macrolet) (send self :macrolet (car args) (cdr args)) t)
((unwind-protect)
(send self :unwind-protect (car args) (cdr args)) t)
((progn) (send self :progn args) t)
((function) (send self :function (car args)) t)
((the) (send self :eval (cadr args)) (coerce-type (car args)))
- ((defun) (send self :warning "defun must be at toplevel") t)
- ((defmacro) (send self :warning "defmacro must be at toplevel") t)
- ((defmethod) (send self :warning "defmethod must be at toplevel") t)
+ ((defun) (send self :warning "defun must be at toplevel~%") t)
+ ((defmacro) (send self :warning "defmacro must be at toplevel~%") t)
+ ((defmethod) (send self :warning "defmethod must be at toplevel~%") t)
((eval-when) (send self :warning
- "eval-when must appear at toplevel, ignored") t)
- (t (send self :error "Compiling method is not yet implemented." fn))))
+ "eval-when must appear at toplevel, ignored~%") t)
+ (t (send self :error "Compiling method is not yet implemented for ~S" fn))))
) ;defmethod
) ;eval-when
@@ -703,48 +977,88 @@
(send self :store-var var)
(progn ;ovaf?
(if (not (symbolp (cdr var)))
- (send self :error "illegal ovaf" var))
+ (send self :error "illegal ovaf ~S" var))
(send self :store-ovaf (car var) (cdr var))))
(and (null var-val) (null duped) (send self :load-var var)))
result-type))
- (:let* (bodies) ;sequential let
- (let ((local-list (pop bodies)) (unwind-save unwind-frames))
- (send self :create-frame)
+ (:let* (bodies &optional (rec t)) ;sequential let
+ (let ((unwind-save unwind-frames) (i 0)
+ local-list bindframe vlist closure-vlist decl-vars)
+ (when rec
+ ;; in let* we need to sequentially bind variables directly into the frame.
+ ;; if we try to sequentially bind to locals and then assign to the frame,
+ ;; we won't be able to catch closure references within the assignment values
+ ;; e.g. (let* ((a 0) (b #'(lambda () a))) ...)
+ ;; to do this, we pre-execute the whole method and extract a list with all of
+ ;; the referenced variables. This list is then used to create a frame of
+ ;; appropriate size and bind the variables directly as they appear
+ (let ((trans (send trans :copy-translator))
+ (newcomp (send self :copy-compiler nil))
+ (avant-mode t))
+ (setq closure-vlist (send newcomp :let* bodies nil))))
+ (setq local-list (pop bodies))
+ (setq bindframe (send self :create-frame 'local (length closure-vlist) "seqlet"))
+ ;; handle declarations
(while (and bodies (consp (car bodies)) (eq (caar bodies) 'declare))
- (send self :declare (cdr (pop bodies))))
+ (setq decl-vars (append decl-vars (send self :declare (cdr (pop bodies))))))
+ ;; eval and bind
(dolist (init-form local-list)
- (send self :eval (if (listp init-form) (cadr init-form) nil))
- (send self :bind
- (if (listp init-form) (car init-form) init-form)
- 'local (1- (send trans :offset-from-fp))) )
+ (let* ((var (if (listp init-form) (car init-form) init-form))
+ (cvar (and rec (find var closure-vlist :key #'(lambda (x) (x . name))))))
+ (send self :eval (if (listp init-form) (cadr init-form) nil))
+ (if cvar
+ (progn
+ (send self :bind-closure-variable cvar 'let bindframe i)
+ (inc i))
+ (let ((offset (1- (send trans :offset-from-fp))))
+ (push (send self :bind var bindframe 'local offset) vlist)))))
+ ;; set/check declarations
+ (send self :check-declare-variables decl-vars)
+ ;; eval body
(send self :progn bodies)
+ ;; unwind/restore
(setq unwind-frames unwind-save)
- (send self :delete-frame t)))
+ (send self :delete-frame 'local t)
+ ;; return value
+ (remove-if-not #'(lambda (v) (v . bindframe)) (nreverse vlist))))
(:let (bodies) ;parallel let
- (let ((local-list (pop bodies)) var special-list offset
- (unwind-save unwind-frames))
- (send self :create-frame)
+ (let ((local-list (pop bodies)) (unwind-save unwind-frames)
+ bindframe special-list vlist decl-vars)
+ (setq bindframe (send self :create-frame 'local))
+ ;; handle declarations
(while (and bodies (consp (car bodies)) (eq (caar bodies) 'declare))
- (send self :declare (cdr (pop bodies))))
+ (setq decl-vars (append decl-vars (send self :declare (cdr (pop bodies))))))
+ ;; eval to locals
(dolist (init-form local-list)
- (setq scope (1- (send idtable :level)))
- (setq var (if (listp init-form) (pop init-form) init-form))
- (send self :eval (if (listp init-form) (car init-form) nil))
- (setq offset (1- (send trans :offset-from-fp)))
- (cond
- ((send self :special-variable-p var)
- (send (car frames) :local 1) ;a trick
- (push (list var offset) special-list))
- (t (send self :bind var 'local offset))))
- ;all the evaluation have finished, bind specials
+ (let (var offset)
+ (setq scope (1- (send idtable :level)))
+ (setq var (if (listp init-form) (car init-form) init-form))
+ (send self :eval (if (listp init-form) (cadr init-form) nil))
+ (setq offset (1- (send trans :offset-from-fp)))
+ (if (send self :special-variable-p var)
+ (push (list var offset) vlist)
+ (push (send self :bind var bindframe 'local offset) vlist))))
+ (setq vlist (nreverse vlist))
+ ;; collect specials
+ (dolist (v vlist)
+ (unless (derivedp v identifier)
+ (send bindframe :local 1) ;a trick
+ (push v special-list)))
+ ;; all the evaluation have finished, bind specials
(dolist (spe special-list)
- (setq offset (send trans :offset-from-fp))
- (send trans :load-local (cadr spe) 0)
- (send self :bind (car spe) 'local offset))
+ (let ((offset (send trans :offset-from-fp)))
+ (send trans :load-local (cadr spe) 0)
+ (send self :bind (car spe) bindframe 'local offset)))
(setq scope (send idtable :level))
+ ;; bind closure variables
+ (send self :bind-frame bindframe bodies vlist "parlet")
+ ;; set/check declarations
+ (send self :check-declare-variables decl-vars)
+ ;; eval body
(send self :progn bodies)
+ ;; unwind/restore
(setq unwind-frames unwind-save)
- (send self :delete-frame t)))
+ (send self :delete-frame 'local t)))
(:cond (clauses)
(let (clause pred next t-found (exit (send self :genlabel "CON")))
(while clauses
@@ -813,16 +1127,79 @@
(send self :eval lab)
(send self :eval val)
(send trans :throw))
+ (:closure (form &optional comment cframes fframes)
+ ;; the closure environment is represented as a vector with each of the referenced frames
+ ;; each frame itself is also represented as a vector and shared between closure instances,
+ ;; ensuring cross read and write access to the variables.
+ ;; the reference frames are judged by pre-evaluating the code and collecting variable
+ ;; references, which are then passed to this method through the `cframes' argument.
+
+ (let (frame)
+ (when (or cframes fframes)
+ ;; create a new vector which holds all necessary frames
+ (let ((size (+ (length cframes) (length fframes))))
+ (setq frame (send self :create-frame nil size comment))
+ ;; pack from variables and then function frames
+ (dotimes (i (length cframes))
+ (let ((f (nth i cframes)))
+ (send trans :load-local f 0)
+ (send trans :store-local i 0 (frame . offset))))
+ (dotimes (i (length fframes))
+ (let ((f (nth i fframes))
+ (j (+ i (length cframes))))
+ (send trans :load-local f 0)
+ (send trans :store-local j 0 (frame . offset))))))
+ ;; makeclosure
+ (send trans :closure form (plusp closure-level) (not (not frame)))))
+ (:lambda-preevaluation (fn &optional name newcomp)
+ ;; pre-evaluate a closure definition and collect all referenced variables.
+ ;; then, add the reference function to each variable's `clist'
+ (let ((param (cadr fn))
+ (forms (cddr fn)))
+ (unless newcomp
+ (setq newcomp (send self :copy-compiler))
+ (setq (newcomp . idtable) idtable)
+ (setq (newcomp . flets) flets))
+ (flet ((lambda-closure-frames ()
+ (send newcomp :enter-block name)
+ (send newcomp :lambda param forms nil)
+ (send newcomp :leave-block)
+ (when (listp closure-frames)
+ (dolist (v closure-frames)
+ (pushnew fn (identifier-clist v))))
+ (when (listp closure-function-frames)
+ (dolist (f closure-function-frames)
+ (pushnew fn (function-identifier-clist f))))))
+ ;; we need to collect references recursively: #'(lambda () #'(lambda () a))
+ ;; but don't want to carry them sequentially: #'(lambda () 1) #'(lambda () a)
+ ;; to do that, we only overwrite the `closure-frames' on the first evaluation
+ (cond
+ ((and closure-frames closure-function-frames)
+ (lambda-closure-frames))
+ ((and closure-frames (not closure-function-frames))
+ (let ((closure-function-frames t))
+ (lambda-closure-frames)))
+ ((and (not closure-frames) closure-function-frames)
+ (let ((closure-frames t))
+ (lambda-closure-frames)))
+ (t ;; both null
+ (let ((closure-frames t)
+ (closure-function-frames t))
+ (lambda-closure-frames))))
+ (send trans :discard 1))))
(:unwind-protect (prot cleanup)
- (let ((cleaner (send self :genlabel "UWP"))
- (newcomp))
- (push (send trans :offset-from-fp) unwind-frames)
- (send trans :closure cleaner) ;make cleanup closure
- (setq newcomp (send self :copy-compiler))
- (send self :add-closure
- (list cleaner
- (cons 'lambda (cons nil cleanup))
- newcomp))
+ (let ((fn (cons 'lambda (cons nil cleanup)))
+ cleaner newcomp)
+ (if avant-mode
+ (send self :lambda-preevaluation fn)
+ (let* ((cframes (send idtable :get-cframes fn closure-level))
+ (fframes (send self :get-flet-cframes fn closure-level (length cframes))))
+ (setq cleaner (send self :genlabel "UWP"))
+ (push (send trans :offset-from-fp) unwind-frames)
+ ;; make cleanup closure
+ (send self :closure cleaner "unwind protect" cframes fframes)
+ (setq newcomp (send self :copy-compiler))
+ (send self :add-closure nil cleaner fn newcomp cframes fframes)))
(send trans :bind-cleaner)
(send self :eval prot)
(send trans :call-cleaner cleaner)
@@ -836,7 +1213,7 @@
(:enter-block (lab)
(let ((spsave (send trans :offset-from-fp))
(blklab (send self :genlabel "BLK")))
- (if (null (symbolp lab)) (send self :warning "no symbolic block label"))
+ (if (null (symbolp lab)) (send self :error "no symbolic block label"))
(push (list lab blklab closure-level spsave) blocks)
blklab))
(:leave-block () (setq blocks (cdr blocks)))
@@ -847,7 +1224,7 @@
(send self :leave-block))
(:return-from (lab val)
(let ((blklab (assq lab blocks)) (need-unwind) (offset))
- (if (null blklab) (send self :error "no such block" lab))
+ (if (null blklab) (send self :error "no such block ~S" lab))
(send self :eval val)
(if (> closure-level (third blklab))
(send self :error "return-from in a closure cannot be compiled"))
@@ -872,7 +1249,7 @@
(setq tags oldtags)))
(:go (lab)
(let ((tag (assq lab tags)) (offset) (need-unwind))
- (if (null tag) (send self :error "no such tag to go" lab))
+ (if (null tag) (send self :error "no such tag ~S" lab))
(setq offset (third tag))
(setq need-unwind (and unwind-frames (>= (first unwind-frames) offset)))
(send trans :go-tag offset need-unwind)
@@ -880,40 +1257,116 @@
(:function (fn)
(if (symbolp fn) ; #'FUNC
(let ((flet-def (send self :get-function fn)))
- (if (eq (second flet-def) 'closure)
- (send trans :load-local (third flet-def)
- (- closure-level (fourth flet-def)))
+ (if (eq (flet-def . binding) 'closure)
+ (send trans :load-local (flet-def . offset)
+ (- closure-level (flet-def . level))
+ (send self :flet-bindframe flet-def))
(send trans :getfunc fn)))
- (let ((entry (send self :genlabel "CLO")) ; #'(lambda (...) ...)
- (newcomp))
- (send trans :closure entry)
- (setq newcomp (send self :copy-compiler))
- (send self :add-closure (list entry fn newcomp))
- )))
- (:flet (funcs bodies recursive-scope &aux (flets-save flets))
+ (let (entry newcomp) ; #'(lambda (...) ...)
+ (if avant-mode
+ (send self :lambda-preevaluation fn)
+ (let* ((cframes (send idtable :get-cframes fn closure-level))
+ (fframes (send self :get-flet-cframes fn closure-level (length cframes))))
+ (setq entry (send self :genlabel "CLO"))
+ (send self :closure entry "lambda-closure" cframes fframes)
+ (setq newcomp (send self :copy-compiler))
+ (send self :add-closure nil entry fn newcomp cframes fframes))))))
+ (:flet (funcs bodies recursive-scope)
;recursive-scope==T for labels, NIL for flet
- (let (entry newcomp newcomps flets-exchange)
+ (let (newcomp newcomps flets-tmp flist fletframe)
+ (if (not recursive-scope) ; copy compiler before binding the functions
+ (setq newcomp (send self :copy-compiler)))
(dolist (fn funcs)
- (setq entry (send self :genlabel "FLET"))
- (send trans :closure entry) ;makeclosure
- (push (list (car fn) ;func name
- 'closure ;func bind type
- (1- (send trans :offset-from-fp))
- closure-level
- entry)
- flets)
- (setq newcomp (send self :copy-compiler))
- (push newcomp newcomps)
- (send self :add-closure (list entry (cons 'lambda (cdr fn))
- newcomp)))
+ (let ((entry (send self :genlabel "FLET"))
+ (offset (1- (send trans :offset-from-fp)))
+ (body (cons 'lambda (cdr fn))))
+ (when recursive-scope
+ (setq newcomp (send self :copy-compiler))
+ (push newcomp newcomps))
+ (push (instance function-identifier :init
+ (car fn) 'closure offset closure-level entry body newcomp)
+ flets-tmp)))
+
+ ;; pre-evaluate closures
+ (let ((trans (send trans :copy-translator))
+ (newcomp (send self :copy-compiler))
+ (avant-mode t))
+ (setq (newcomp . flets) (append flets-tmp flets))
+ (setq (newcomp . idtable) idtable)
+ (dolist (fn flets-tmp)
+ (send self :lambda-preevaluation (fn . body) (fn . name) newcomp)))
+
+ ;; pre-evaluate body
+ (let ((trans (send trans :copy-translator))
+ (newcomp (send self :copy-compiler nil))
+ (avant-mode t))
+ (setq (newcomp . flets) (append flets-tmp flets))
+ (send newcomp :progn bodies))
+
+ ;; bind frames
+ (setq flist (remove-if-not #'(lambda (v) (v . bindframe)) (reverse flets-tmp)))
(if recursive-scope
- (send-all newcomps :change-flets flets))
+ ;; when recursive setup the bindframe beforehand
+ (setq fletframe (send self :create-frame 'flet (length flist) "flet")))
+
+ (if (not avant-mode)
+ (dolist (fn (reverse flets-tmp))
+ (let* ((cframes (send (newcomp . idtable) :get-cframes (fn . body) closure-level))
+ (fframes (send self :get-flet-cframes
+ (fn . body) closure-level (length cframes))))
+ (when recursive-scope
+ ;; append the current frame if any references are found
+ (when (send self :get-flet-cframes
+ (fn . body) closure-level (length cframes) flist)
+ (pushnew (fletframe . offset) fframes)))
+ (send self :closure (fn . entry) "flet env" cframes fframes)
+ (setq (fn . offset) (1- (send trans :offset-from-fp)))
+ (send self :add-closure
+ (fn . name) (fn . entry) (fn . body) (fn . newcomp) cframes fframes))))
+
+ (if (not recursive-scope)
+ ;; when not recursive setup the bindframe after the closure declaration
+ (setq fletframe (send self :create-frame 'flet (length flist) "flet")))
+
+ (send fletframe :local (length flets-tmp))
+
+ (dotimes (i (length flist))
+ (let ((fn (nth i flist)))
+ (send trans :load-local (fn . offset) (- closure-level (fn . level)))
+ (send trans :store-local i 0 (fletframe . offset))
+ (setq (fn . bindframe) (fletframe . offset)
+ (fn . offset) i)))
+
+ ;; reset cbindframes to force re-evaluation
+ ;; this is needed to ensure that each closure has an
+ ;; unique and compatible mapping
+ (send self :reset-flets-cbindframe flets-tmp)
+
+ ;; evaluate body
+ (setq flets (append flets-tmp flets))
+ (if recursive-scope (send-all newcomps :change-flets flets))
(send self :progn bodies)
- (setq flets (nthcdr (length funcs) flets))
- (send trans :del-frame 0 (length funcs))))
+ (if (not recursive-scope) (send newcomp :change-flets flets))
+ ;; unwind/restore
+ (send self :reset-flets-cbindframe flets-tmp)
+ (setq flets (nthcdr (length flets-tmp) flets))
+ (send self :delete-frame 'flet nil)
+ (send trans :del-frame (fletframe . specials) (fletframe . locals))))
+ (:macrolet (funcs bodies)
+ (dolist (fn funcs)
+ (push (instance function-identifier :init-body
+ (car fn) 'macrolet `(lambda ,@(cdr fn)))
+ flets))
+ (send self :progn bodies)
+ (setq flets (nthcdr (length funcs) flets)))
(:change-flets (newflets) (setq flets newflets))
+ (:reset-flets-cbindframe (flets-tmp)
+ (dolist (fdef flets-tmp)
+ (when (fdef . cbindframe)
+ (setq (fdef . cbindframe) t))))
(:declare (args)
- (let (v)
+ ;; bind statements and return type declared variables
+ (let (v acc)
(declare (type identifier v))
(dolist (decl args)
(case (car decl)
@@ -924,13 +1377,15 @@
(type
(dolist (id (cddr decl))
(setq v (send self :enter-variable id))
- (send v :type (cadr decl))))
+ (send v :type (cadr decl))
+ (push (cons id (v . type)) acc)))
(ftype
(def-function-type (cadr decl) (cddr decl)))
((integer :integer fixnum :fixnum :float float)
(dolist (id (cdr decl))
(setq v (send self :enter-variable id))
- (send v :type (car decl))))
+ (send v :type (car decl))
+ (push (cons id (v . type)) acc)))
(optimize (setq *optimize* (cadr decl)))
(safety (setq *safety* (cadr decl)))
(space (setq *space* (cadr decl)))
@@ -939,30 +1394,53 @@
(t (cond ((class-symbolp (car decl))
(dolist (id (cdr decl))
(setq v (send self :enter-variable id))
- (send v :type (car decl))))
- (t (send self :warning "unknown declaration" decl))))
- ))))
- (:lambda (param forms)
+ (send v :type (car decl))
+ (push (cons id (v . type)) acc)))
+ (t (send self :error "unknown declaration ~S" decl))))))
+ (nreverse acc)))
+ (:check-declare-variables (decl-vars)
+ (dolist (dvar decl-vars)
+ (let* ((id (car dvar))
+ (tp (cdr dvar))
+ (v (send self :variable id)))
+ (if (eq (send v :type) t) (send v :type tp))
+ (when *type-check-declare*
+ (unless (eql (v . binding) 'unknown)
+ (send self :load-var id)
+ (send trans :type-check-declare tp))))))
+ (:lambda (param forms &optional (rec t))
(let ((labels nil)
(i 0)
(reqn 0)
(optn 0)
(keyn 0)
+ (auxn 0)
+ (opt-supplied-vars)
(opt-vars (memq '&optional param))
(rest-var (memq '&rest param))
(key-forms (memq '&key param))
(aux-vars (memq '&aux param))
(key-vars)
+ (key-supplied-vars)
(req-vars nil)
(opt-forms nil)
(key-names nil)
(key-inits nil)
(key-base 0)
+ (decl-vars nil)
(specially-bound nil)
(allowotherkeys (memq '&allow-other-keys param))
(unwind-save unwind-frames)
- (vname nil)
- (label2))
+ (cvar-i 0) argframe vlist closure-vlist)
+ (when rec
+ ;; as in let*, we need to sequentially bind variables directly to the frame
+ ;; so we pre-evaluate the whole method, and then create/populate the frame
+ (let* ((trans (send trans :copy-translator))
+ (newcomp (send self :copy-compiler nil))
+ (avant-mode t)
+ (preevaluation-result (send newcomp :lambda param forms nil)))
+ (setq closure-vlist (car preevaluation-result))
+ (send self :check-declare-variables (cadr preevaluation-result))))
(setq req-vars
(reverse
(nthcdr (length (cond (opt-vars)
@@ -981,22 +1459,42 @@
opt-vars)
key-forms (cdr key-forms)
keyn (length key-forms))
- (when allowotherkeys
- (setq key-forms (subseq key-forms 0 (dec keyn))))
+ (when key-forms
+ (cond
+ (allowotherkeys
+ (setq key-forms (subseq key-forms 0 (dec keyn (length allowotherkeys)))))
+ (aux-vars
+ (setq key-forms (subseq key-forms 0 (dec keyn (length aux-vars)))))))
+ (setq aux-vars (cdr aux-vars)
+ auxn (length aux-vars))
;; prepare labels for the init-forms of optional variables
(if opt-vars
(while (<= i optn) ;optn+1 labels
(push (send self :genlabel "ENT") labels)
(inc i))
(if rest-var (setq labels (list (send self :genlabel "RST")))))
+;; extract optional supplied-p variables
+ (dolist (opt opt-vars)
+ (let (svar)
+ (when (and (listp opt) (cddr opt))
+ (setq svar (caddr opt))
+ (unless (and (symbolp (caddr opt)) (not (constantp svar)))
+ (send self :error "optional supplied variable")))
+ (push svar opt-supplied-vars)))
+ (setq opt-supplied-vars (nreverse opt-supplied-vars))
;; extract optional variable names
(setq opt-vars (mapcar #'(lambda (x) (if (listp x) (car x) x)) opt-vars))
- (send self :create-frame)
;; parse keyword variables
(if key-forms
- (let (init key var)
+ (let (init key var svar)
(dolist (k key-forms)
(cond ((listp k)
+ ;; key-supplied-vars
+ (when (cddr k)
+ (setq svar (caddr k))
+ (unless (and (symbolp svar) (not (constantp svar)))
+ (send self :error "keyword supplied variable")))
+ ;; key-inits / key-names
(setq init (cadr k) k (car k))
(cond ((listp k)
(setq key (car k) var (cadr k))
@@ -1009,80 +1507,165 @@
*keyword-package*))) ))
(t (setq init nil
var k
+ svar nil
key (intern (symbol-name var)
*keyword-package*))))
(setq key-names (cons key key-names)
key-vars (cons var key-vars)
+ key-supplied-vars (cons svar key-supplied-vars)
key-inits (cons init key-inits))) ;end dolist
- (nreverse key-names)
- (nreverse key-vars)
- (nreverse key-inits)
+ (setq key-names (nreverse key-names))
+ (setq key-vars (nreverse key-vars))
+ (setq key-inits (nreverse key-inits))
+ (setq key-supplied-vars (nreverse key-supplied-vars))
;(format t ";key-names length=~d ~s~%" (length key-names) key-names)
(if (>= (length key-names) 128) ;; KEYWORDPARAMETERLIMIT
(send self :error "Too many keyword parameters>128 ~s" key-names))
) )
;; declaration
(while (and forms (consp (car forms)) (eq (caar forms) 'declare))
- (send self :declare (cdr (pop forms))))
+ (setq decl-vars (append decl-vars (send self :declare (cdr (pop forms))))))
;; (print "declaration")
(send trans :check-req-arg reqn (+ optn
(if rest-var 1
(if key-forms keyn 0))))
+;; create argument frame
+ (setq argframe (send self :create-frame 'arg (length closure-vlist) "argv"))
;; (print "bind")
(setq i 0)
- (dolist (v req-vars) ;for all required arguments
- (send self :bind v 'arg i)
- (inc i))
+ (dolist (v req-vars) ;for all required arguments
+ (let ((cvar (and rec (find v closure-vlist :key #'(lambda (x) (x . name))))))
+ (if cvar
+ (progn
+ (send trans :load-arg i 0)
+ (send self :bind-closure-variable cvar (cvar . binding) argframe cvar-i)
+ (inc cvar-i))
+ (push (send self :bind v argframe 'arg i) vlist)))
+ (inc i))
(while (cdr labels)
- (send trans :check-opt-arg i (car labels))
- (send self :eval (pop opt-forms))
- (send trans :label (pop labels))
- (send self :bind (pop opt-vars) 'local
- (1- (send trans :offset-from-fp)))
- (inc i))
+ (let ((var (pop opt-vars))
+ (svar (pop opt-supplied-vars)))
+ (when svar ; initialize supplied-p to t
+ (send trans :load-t)
+ (let ((c-svar (and rec (find svar closure-vlist :key #'(lambda (x) (x . name))))))
+ (if c-svar
+ (progn
+ (send self :bind-closure-variable c-svar 'lambda argframe cvar-i)
+ (inc cvar-i)
+ (setq svar c-svar))
+ (let ((offset (1- (send trans :offset-from-fp))))
+ (setq svar (send self :bind svar argframe 'local offset)))))
+ (push svar vlist))
+ (let ((cvar (and rec (find var closure-vlist :key #'(lambda (x) (x . name))))))
+ (if cvar
+ (progn
+ (send self :bind-closure-variable cvar 'lambda argframe cvar-i
+ :store nil)
+ (inc cvar-i)
+ (send self :load-var cvar)
+ (send trans :check-opt-arg-frame i (car labels))
+ (setq var cvar))
+ (send trans :check-opt-arg i (car labels))))
+ (when svar ; set supplied-p to nil
+ (send trans :load-nil)
+ (send self :store-var svar))
+ ;; set init value
+ (send self :eval (pop opt-forms))
+ (if (derivedp var identifier)
+ (send self :store-var var))
+ (send trans :label (pop labels))
+ (unless (derivedp var identifier)
+ (let ((offset (1- (send trans :offset-from-fp))))
+ (push (send self :bind var argframe 'local offset) vlist)))
+ (inc i)))
(when labels
(send trans :label (pop labels)))
(cond
(rest-var
(send trans :rest (+ reqn optn))
- (send self :bind rest-var 'local
- (1- (send trans :offset-from-fp))))
+ (let ((cvar (and rec (find rest-var closure-vlist :key #'(lambda (x) (x . name))))))
+ (if cvar
+ (progn
+ (send self :bind-closure-variable cvar 'lambda argframe cvar-i)
+ (inc cvar-i))
+ (let ((offset (1- (send trans :offset-from-fp))))
+ (push (send self :bind rest-var argframe 'local offset) vlist)))))
((and (> optn 0) (null key-forms)) (send trans :check-rest-arg i)))
(when key-forms
- (setq key-base (send trans :offset-from-fp))
- (send trans :parse-key-params (coerce key-names vector)
- (+ reqn optn)
- keyn allowotherkeys)
- (dotimes (i keyn)
+ (let ((key-base (send trans :offset-from-fp)))
+ (send trans :reset-vsp)
+ ;; bind given arguments
+ (send trans :parse-key-params (coerce key-names vector)
+ (+ reqn optn)
+ keyn allowotherkeys)
+ ;; bind defaults / supplied arguments
+ (dotimes (j keyn)
+ (let ((var (pop key-vars))
+ (svar (pop key-supplied-vars)))
(setq labels (send self :genlabel "KEY"))
- (send trans :check-key-arg i labels)
- ; go around evaluating default for a key-var
+ (when svar ; set supplied-p variables to t
+ (send trans :load-t)
+ (let ((c-svar (and rec (find svar closure-vlist :key #'(lambda (x) (x . name))))))
+ (if c-svar
+ (progn
+ (send self :bind-closure-variable c-svar 'lambda argframe cvar-i)
+ (inc cvar-i)
+ (setq svar c-svar))
+ (let ((offset (1- (send trans :offset-from-fp))))
+ (setq svar (send self :bind svar argframe 'local offset)))))
+ (push svar vlist))
+ (send trans :check-key-arg j labels)
+ (when svar ; set supplied-p variables to nil
+ (send trans :load-nil)
+ (send self :store-var svar))
+ ;; set default values
(send self :eval (pop key-inits))
- (setq vname (pop key-vars))
- (cond ((send self :special-variable-p vname)
- (setq label2 (send self :genlabel "KEY"))
- (send trans :jump label2)
+ (cond ((send self :special-variable-p var)
+ (send trans :store-local (+ key-base j) 0)
(send trans :label labels)
- (send trans :adjust 1)
- (send trans :load-local (+ i key-base) 0)
- (send trans :label label2)
- (send self :bind vname 'local (+ key-base i) t) )
+ (send trans :load-local (+ key-base j) 0)
+ (push (send self :bind var argframe 'local (+ key-base j) :keyvarp t)
+ vlist))
(t ;non-special
- (send self :bind vname 'local (+ key-base i))
- (send trans :store-local (+ key-base i) 0)
- (send trans :label labels) ) )
+ (setq var (send self :bind var argframe 'local (+ key-base j)))
+ (send self :store-var var)
+ (push var vlist)
+ (send trans :label labels)
+ (let ((cvar (and rec (find (var . name) closure-vlist
+ :key #'(lambda (x) (x . name))))))
+ (when cvar
+ ;; `:bind-closure-variable' only adds new entries
+ ;; manually reassign values instead
+ (send self :load-var var)
+ (send trans :clearpush-frame (argframe . offset) cvar-i)
+ (setq (var . binding) 'lambda
+ (var . bindframe) (argframe . offset)
+ (var . clist) (cvar . clist)
+ (var . offset) cvar-i)
+ (inc cvar-i)))))))
) )
;;; bind aux variables
(dolist (av aux-vars)
- (if (consp av) (send self :eval (cadr av)) (send self :eval nil))
- (send self :bind (if (listp av) (car av) av)
- 'local
- (1- (send trans :offset-from-fp))))
+ (if (consp av) (send self :eval (cadr av)) (send trans :load-nil))
+ (let* ((var (if (listp av) (car av) av))
+ (cvar (and rec (find var closure-vlist :key #'(lambda (x) (x . name))))))
+ (if cvar
+ (progn
+ (send self :bind-closure-variable cvar 'lambda argframe cvar-i)
+ (inc cvar-i))
+ (let ((offset (1- (send trans :offset-from-fp))))
+ (push (send self :bind var argframe 'local offset) vlist)))))
+;;; set/check declaration types
+ (send self :check-declare-variables decl-vars)
;;; evaluate lambda body
(send self :progn forms)
+;;; unwind/restore
(setq unwind-frames unwind-save)
- (send self :delete-frame t)
- ))
+ (send self :delete-frame 'arg t)
+;;; return value
+ (list
+ (remove-if-not #'(lambda (v) (v . bindframe)) (nreverse vlist))
+ decl-vars)))
(:lambda-block (name arglist bodies cname)
(let ((ctime (unix:runtime))
blklabel)
@@ -1120,6 +1703,10 @@
(if (and (stringp (car bodies)) (cdr bodies))
(pop bodies)
(format nil "~s" arglist)))
+ (when closure-frames
+ (send self :error "closure-frames should always be nil at the toplevel"))
+ (when closure-function-frames
+ (send self :error "closure-function-frames should always be nil at the toplevel"))
(send self :lambda-block name arglist bodies cname)
(send self :add-initcode (list fun-macro cname name doc))))
(:defmethod (methods)
@@ -1129,7 +1716,7 @@
(objvars (object-variable-names myclass))
(i 0) (v nil) doc)
(setq methods (cdr methods))
- (send self :create-frame) ;enter object variables
+ (send self :create-frame 'local) ;enter object variables
(dolist (ovar objvars)
(setq v (send self :enter-variable ovar)
(v . binding) 'object
@@ -1152,7 +1739,7 @@
(send self :add-initcode
(list 'defmethod myclass selector entry doc) ))
(setq myclass nil)
- (send self :delete-frame nil)
+ (send self :delete-frame 'local nil)
))
) ;defmethod
) ;eval-when
@@ -1160,27 +1747,32 @@
(eval-when (load eval)
(defmethod compiler
(:add-initcode (form) (setq initcodes (cons form initcodes)))
- (:add-closure (clo) (setq function-closures (cons clo function-closures)))
+ (:add-closure (name entry def newcomp cframes fframes)
+ (let ((clo (instance closure-identifier :init name entry def newcomp cframes fframes)))
+ (setq function-closures (cons clo function-closures))))
(:closure-level (increment) (inc closure-level increment))
- (:compile-a-closure (entry def)
- (if *debug* (format t ";closure: ~s~%" def))
- (let* ((param (cadr def)) (bodies (cddr def)))
+ (:compile-a-closure (name entry def)
+ (if *debug* (format t ";closure: ~s: ~s~%" name def))
+ (let* ((param (cadr def)) (bodies (cddr def)) blklabel)
(setq function-closures nil)
(send trans :declare-forward-function entry)
(send trans :enter entry "closure or cleaner")
; (send trans :pushenv)
+ (setq blklabel (send self :enter-block name))
(send self :lambda param bodies)
+ (send trans :label blklabel)
(send trans :return)
+ (send self :leave-block)
(send self :compile-closures)
)
)
(:compile-closures ()
(dolist (aclosure (reverse function-closures))
- (send (caddr aclosure) :compile-a-closure (car aclosure) (cadr aclosure)))
+ (send aclosure :compile))
(setq function-closures nil))
(:toplevel-eval (form)
(setq function-closures nil)
- (let* ((fn (car form)))
+ (let* ((fn (function-alias (car form))))
(case fn
((defun defmacro)
(send self :defun fn (cadr form) (caddr form) (cdddr form))
@@ -1244,189 +1836,190 @@
(setq o (pathname o))
(setq o (merge-pathnames o file))
(setq o (merge-pathnames ".o" o)))
- (let ((name nil) (c nil) (form nil)
- (ins) (cccom)
- (file.c (merge-pathnames ".c" file))
- (file.h (merge-pathnames ".h" file))
- (file.q (merge-pathnames ".q" file))
- (file.o (if o o (merge-pathnames ".o" file)))
- (file.so (if o (merge-pathnames ".so" o)
- (merge-pathnames ".so" file)))
- (file.dll (if o (merge-pathnames ".dll" o)
- (merge-pathnames ".dll" file)))
- (cpack *package*))
- (unless (eq (unix:access (send (pathname file) :directory-string) unix::O_RDWR) t) ;; source directory is not writable
- (warn ";; ~A is write protected, use temporary compile directory to ~A~%" file (send o :directory-string))
- (setq file.c (merge-pathnames ".c" o)
- file.h (merge-pathnames ".h" o)
- file.q (merge-pathnames ".q" o)))
- (when (null (probe-file file))
- (setq file (merge-pathnames ".l" file))
- (if (null (probe-file file))
- (error "file ~A not found~%" file)))
- (warn "compiling file: ~A~%" (namestring file))
- (setq ins (open file))
- (setq *defun-list* nil)
- (when *multipass-optimize*
- (while t
- (setq form (read ins nil '$eof$))
- (if (eq form '$eof$) (return nil))
- (send self :toplevel form t t))
- (unix:lseek ins 0))
- (nreverse *defun-list*)
- (send trans :init-file file file.c file.h entry)
- (send idtable :init-frames)
- (setq frames nil
- scope 0
- blocks nil
- initcodes nil)
- (while t
- (setq form (read ins nil '$eof$))
- (if (eq form '$eof$) (return nil))
- (send self :toplevel form t))
- (setq initcodes (reverse initcodes))
- (send trans :eusmain entry)
- (dolist (form initcodes) (send self :toplevel-execution form))
- (send trans :load-nil)
- (send trans :return)
- (send self :compile-closures)
- (send trans :declare-ftab)
- (send trans :ftab-initializer)
- (let ((symvec (cpack . symvector)) (symcnt (cpack . symcount)))
- (setq (cpack . symvector) (make-array 0)
- (cpack . symcount) 1)
- ;; write every symbol in this package as internal symbols
- ;; (warn "writing quote vector file in ~s~%" *package*)
- (send trans :write-quote-vector)
- (setq (cpack . symvector) symvec
- (cpack . symcount) symcnt))
- (send trans :close)
- (close ins)
- (setq cccom
- (concatenate
- string
- *cc*
- " -c"
- (if o (concatenate string " -o " (namestring o)))
- (cond ((memq :sun3 *features*) " -Dsun3 -w")
- ((memq :sun4 *features*) " -Dsun4 -w")
-; ((memq :mips *features*) " -Dmips -G 0 -w")
-; ((memq :irix *features*) " -Dmips -DIRIX -signed -w")
- ((memq :irix *features*) " -Dmips -DIRIX -w ")
- ((memq :irix6 *features*) " -Dmips -DIRIX6 -woff all")
- ((memq :vax *features*) " -Dvax -J")
- ((memq :news *features*) " -Dnews")
- ((memq :sanyo *features*) " -Dsanyo")
- ((memq :darwin *features*)
- (if (memq :x86_64 *features*)
- " -DDarwin -Dx86_64 -DLinux -w -falign-functions=8 "
- " -DDarwin -Di386 -DLinux -w -falign-functions=4 "))
- ((and (memq :linux *features*) (memq :gcc3 *features*))
- (cond
- ((memq :x86_64 *features*)
- " -Dx86_64 -DLinux -Wimplicit -falign-functions=8 -DGCC3 ")
- ((memq :aarch64 *features*)
- " -Daarch64 -fPIC -Darmv8 -DARM -DLinux -Wimplicit -falign-functions=8 -DGCC3 ")
- ((memq :arm *features*)
- " -DARM -DLinux -Wimplicit -falign-functions=4 -DGCC3 ")
- ((memq :word-size=64 *features*)
- " -DLinux -Wimplicit -falign-functions=8 -DGCC3 ")
- (t " -Di386 -DLinux -Wimplicit -falign-functions=4 -fno-stack-protector -DGCC3 ")))
- ((memq :linux *features*)
- (if (memq :x86_64 *features*)
- " -Dx86_64 -DLinux -Wimplicit -malign-functions=8 "
- " -Di386 -DLinux -Wimplicit -malign-functions=4 "))
- ((memq :alpha *features*) " -Dalpha -Dsystem5 -D_REENTRANT -w")
- ((memq :cygwin *features*) " -DCygwin -D_REENTRANT -DX_V11R6_1 -falign-functions=4")
- ((memq :i386 *features*) " -Di386")
- (t (warn "cpu type is not properly set")))
- (cond ((memq :sunos4 *features*) " -DSunOS4 -Bstatic")
- ((memq :sunos4.1 *features*) " -DSunOS4_1")
- ((memq :Solaris2 *features*) " -DSolaris2")
- (t ""))
- (if (memq :gcc *features*) " -DGCC -fsigned-char " )
- (if (memq :thread *features*) " -DTHREADED" )
- (if (memq :pthread *features*) " -DPTHREAD" )
- (if (memq :rgc *features*) " -DRGC -D__USE_POLLING -D__HEAP_EXPANDABLE -D__GC_SEPARATE_THREAD" )
- (if pic
- (cond ((memq :SunOS4.1 *features*) " -fpic")
- ((memq :cygwin *features*) "")
- ((memq :Gcc *features*) " -fpic ")
- ((memq :Solaris2 *features*) " -K pic")
- ((memq :linux *features*) " -fpic")
- ((memq :irix *features*) " -KPIC")
- ((memq :irix6 *features*) " -KPIC")
- ((memq :alpha *features*) " -fpic")
- (t " -pic"))
- )
- cc-option
- " -I" (namestring *eusdir*) "include"
- *coptflags* *cflags*
- " " (namestring file.c)
- (if (and (memq :sunos4.1 *features*) pic)
- (concatenate string
- "; ld -o "
- (namestring file.so)
- " "
- (namestring file.o))
- )
- (if (and (or (memq :irix *features*)
- (memq :irix6 *features*)) pic)
- (concatenate string
- "; ld -shared -o "
- (namestring file.so)
- " "
- (namestring file.o))
- )
- (if (and (memq :linux *features*) pic)
- (concatenate string
- (cond
- ((memq :darwin *features*)
- "; gcc -dynamiclib -flat_namespace -undefined suppress -o ")
- ((memq :sh4 *features*)
- "; sh4-linux-gcc -shared -o ")
- ((memq :ia32 *features*)
- "; ld -melf_i386 -shared -build-id -o ")
- ((memq :i386 *features*)
- "; gcc -shared -Xlinker -build-id -o ")
- (t
- "; ld -shared -build-id -o "))
- (namestring file.so)
- " "
- (namestring file.o))
- "")
- (if (and (memq :alpha *features*) pic)
- (concatenate string
- "; ld -shared -update_registry so_locations -expect_unresolved '*' -g0 -O1 -o "
- (namestring file.so)
- " "
- (namestring file.o))
- "")
- (if (and (memq :cygwin *features*)
- (not *kernel*))
- (concatenate string
- "; gcc -shared -g -falign-functions=4 -Wl,--export-all-symbols -Wl,--unresolved-symbols=ignore-all -Wl,--enable-runtime-pseudo-reloc -o "
- (namestring file.dll) " "
- (namestring file.o) " "
- *eusdir* (unix:getenv "ARCHDIR")
- "/bin/"
- "eusgl.a "
- "-lm -lpthread "
- ))
- ))
- (when cc
- (warn "~A" cccom)
- (unix:system cccom))
- (dolist (f *defun-list*) (remprop f 'user-function-entry))
- (terpri *error-output*)
- ))
+ (unwind-protect
+ (let ((name nil) (c nil) (form nil)
+ (ins) (cccom)
+ (file.c (merge-pathnames ".c" file))
+ (file.h (merge-pathnames ".h" file))
+ (file.o (if o o (merge-pathnames ".o" file)))
+ (file.so (if o (merge-pathnames ".so" o)
+ (merge-pathnames ".so" file)))
+ (file.dll (if o (merge-pathnames ".dll" o)
+ (merge-pathnames ".dll" file)))
+ (cpack *package*))
+ (unless (eq (unix:access (send (pathname file) :directory-string) unix::O_RDWR) t) ;; source directory is not writable
+ (warn ";; ~A is write protected, use temporary compile directory to ~A~%" file (send o :directory-string))
+ (setq file.c (merge-pathnames ".c" o)
+ file.h (merge-pathnames ".h" o)))
+ (when (null (probe-file file))
+ (setq file (merge-pathnames ".l" file))
+ (if (null (probe-file file))
+ (error io-error "file ~A not found~%" file)))
+ (warn "compiling file: ~A~%" (namestring file))
+ (setq ins (open file))
+ (setq *defun-list* nil)
+ (when *multipass-optimize*
+ (while t
+ (setq form (read ins nil '$eof$))
+ (if (eq form '$eof$) (return nil))
+ (send self :toplevel form t t))
+ (unix:lseek ins 0))
+ (nreverse *defun-list*)
+ (send trans :init-file file file.c file.h entry)
+ (send idtable :init-frames)
+ (setq frames nil
+ scope 0
+ blocks nil
+ initcodes nil)
+ (while t
+ (setq form (read ins nil '$eof$))
+ (if (eq form '$eof$) (return nil))
+ (send self :toplevel form t))
+ (setq initcodes (reverse initcodes))
+ (send trans :eusmain entry)
+ (dolist (form initcodes) (send self :toplevel-execution form))
+ (send trans :load-nil)
+ (send trans :return)
+ (send self :compile-closures)
+ (send trans :declare-ftab)
+ (send trans :ftab-initializer)
+ (let ((symvec (cpack . symvector)) (symcnt (cpack . symcount)))
+ (setq (cpack . symvector) (make-array 0)
+ (cpack . symcount) 1)
+ ;; write every symbol in this package as internal symbols
+ ;; (warn "writing quote vector file in ~s~%" *package*)
+ (send trans :write-quote-vector)
+ (setq (cpack . symvector) symvec
+ (cpack . symcount) symcnt))
+ (send trans :close)
+ (close ins)
+ (setq cccom
+ (concatenate
+ string
+ *cc*
+ " -c"
+ (if o (concatenate string " -o " (namestring o)))
+ (cond ((memq :sun3 *features*) " -Dsun3 -w")
+ ((memq :sun4 *features*) " -Dsun4 -w")
+; ((memq :mips *features*) " -Dmips -G 0 -w")
+; ((memq :irix *features*) " -Dmips -DIRIX -signed -w")
+ ((memq :irix *features*) " -Dmips -DIRIX -w ")
+ ((memq :irix6 *features*) " -Dmips -DIRIX6 -woff all")
+ ((memq :vax *features*) " -Dvax -J")
+ ((memq :news *features*) " -Dnews")
+ ((memq :sanyo *features*) " -Dsanyo")
+ ((memq :darwin *features*)
+ (if (memq :x86_64 *features*)
+ " -DDarwin -Dx86_64 -DLinux -w -falign-functions=8 "
+ " -DDarwin -Di386 -DLinux -w -falign-functions=4 "))
+ ((and (memq :linux *features*) (memq :gcc3 *features*))
+ (cond
+ ((memq :x86_64 *features*)
+ " -Dx86_64 -DLinux -Wimplicit -falign-functions=8 -DGCC3 ")
+ ((memq :aarch64 *features*)
+ " -Daarch64 -fPIC -Darmv8 -DARM -DLinux -Wimplicit -falign-functions=8 -DGCC3 ")
+ ((memq :arm *features*)
+ " -DARM -DLinux -Wimplicit -falign-functions=4 -DGCC3 ")
+ ((memq :word-size=64 *features*)
+ " -DLinux -Wimplicit -falign-functions=8 -DGCC3 ")
+ (t " -Di386 -DLinux -Wimplicit -falign-functions=4 -fno-stack-protector -DGCC3 ")))
+ ((memq :linux *features*)
+ (if (memq :x86_64 *features*)
+ " -Dx86_64 -DLinux -Wimplicit -malign-functions=8 "
+ " -Di386 -DLinux -Wimplicit -malign-functions=4 "))
+ ((memq :alpha *features*) " -Dalpha -Dsystem5 -D_REENTRANT -w")
+ ((memq :cygwin *features*) " -DCygwin -D_REENTRANT -DX_V11R6_1 -falign-functions=4")
+ ((memq :i386 *features*) " -Di386")
+ (t (warn "cpu type is not properly set")))
+ (cond ((memq :sunos4 *features*) " -DSunOS4 -Bstatic")
+ ((memq :sunos4.1 *features*) " -DSunOS4_1")
+ ((memq :Solaris2 *features*) " -DSolaris2")
+ (t ""))
+ (if (memq :gcc *features*) " -DGCC -fsigned-char " )
+ (if (memq :thread *features*) " -DTHREADED" )
+ (if (memq :pthread *features*) " -DPTHREAD" )
+ (if (memq :rgc *features*) " -DRGC -D__USE_POLLING -D__HEAP_EXPANDABLE -D__GC_SEPARATE_THREAD" )
+ (format nil " -DCOMPTIMEVERSION=\\\"~A\\\"" compiler-implementation-version)
+ (if pic
+ (cond ((memq :SunOS4.1 *features*) " -fpic")
+ ((memq :cygwin *features*) "")
+ ((memq :Gcc *features*) " -fpic ")
+ ((memq :Solaris2 *features*) " -K pic")
+ ((memq :linux *features*) " -fpic")
+ ((memq :irix *features*) " -KPIC")
+ ((memq :irix6 *features*) " -KPIC")
+ ((memq :alpha *features*) " -fpic")
+ (t " -pic"))
+ )
+ cc-option
+ " -I" (namestring *eusdir*) "include"
+ *coptflags* *cflags*
+ " " (namestring file.c)
+ (if (and (memq :sunos4.1 *features*) pic)
+ (concatenate string
+ "; ld -o "
+ (namestring file.so)
+ " "
+ (namestring file.o))
+ )
+ (if (and (or (memq :irix *features*)
+ (memq :irix6 *features*)) pic)
+ (concatenate string
+ "; ld -shared -o "
+ (namestring file.so)
+ " "
+ (namestring file.o))
+ )
+ (if (and (memq :linux *features*) pic)
+ (concatenate string
+ (cond
+ ((memq :darwin *features*)
+ "; gcc -dynamiclib -flat_namespace -undefined suppress -o ")
+ ((memq :sh4 *features*)
+ "; sh4-linux-gcc -shared -o ")
+ ((memq :ia32 *features*)
+ "; ld -melf_i386 -shared -build-id -o ")
+ ((memq :i386 *features*)
+ "; gcc -shared -Xlinker -build-id -o ")
+ (t
+ "; ld -shared -build-id -o "))
+ (namestring file.so)
+ " "
+ (namestring file.o))
+ "")
+ (if (and (memq :alpha *features*) pic)
+ (concatenate string
+ "; ld -shared -update_registry so_locations -expect_unresolved '*' -g0 -O1 -o "
+ (namestring file.so)
+ " "
+ (namestring file.o))
+ "")
+ (if (and (memq :cygwin *features*)
+ (not *kernel*))
+ (concatenate string
+ "; gcc -shared -g -falign-functions=4 -Wl,--export-all-symbols -Wl,--unresolved-symbols=ignore-all -Wl,--enable-runtime-pseudo-reloc -o "
+ (namestring file.dll) " "
+ (namestring file.o) " "
+ *eusdir* (unix:getenv "ARCHDIR")
+ "/bin/"
+ "eusgl.a "
+ "-lm -lpthread "
+ ))
+ ))
+ (when cc
+ (warn "~A" cccom)
+ (unix:system cccom))
+ (dolist (f *defun-list*) (remprop f 'user-function-entry))
+ (unless avant-mode (terpri *error-output*))
+ )
+ (send trans :clear-external-functions)))
(:specials () (mapcar 'car (send idtable :frame 0)))
- (:copy-compiler ()
+ (:copy-compiler (&optional (closurep t))
(let ((newcomp) (initcode-save initcodes) (closure-save function-closures))
(setq initcodes nil
function-closures nil)
(setq newcomp (copy-object self))
- (send newcomp :closure-level 1)
+ (if closurep (send newcomp :closure-level 1))
(setq initcodes initcode-save
function-closures closure-save)
newcomp))
@@ -1451,40 +2044,73 @@
(eval-when (load eval)
(defun dump-function (file &rest names)
- (with-open-file (f file :direction :output)
+ (let (acc)
+ (with-open-file (f file :direction :output)
(dolist (funmac names)
(let ((def (symbol-function funmac)) dump)
- (setq dump
- (case (car def)
- (lambda `(defun ,funmac . ,(cdr def)))
- (macro `(defun ,funmac . ,(cdr def)))))
- (pprint dump f) ))) )
+ (when (consp def)
+ (setq dump
+ (case (car def)
+ (lambda `(defun ,funmac . ,(cdr def)))
+ (macro `(defmacro ,funmac . ,(cdr def)))
+ (t (error value-error "unknown function type: ~A" (car def)))))
+ (pprint dump f)
+ (push funmac acc)))))
+ (nreverse acc)))
+
+(defun dump-method (file obj &rest methods)
+ (let (acc)
+ (with-open-file (f file :direction :output)
+ (dolist (meth methods)
+ (let ((def (if (classp obj)
+ (let ((body (assoc meth (send obj :methods))))
+ (if body (list obj body)))
+ (find-method obj meth))))
+ (when def
+ (multiple-value-bind (cls body) def
+ (when (and (consp body) (not (compiled-function-p (second body))))
+ (pprint `(defmethod ,(send cls :name) ,body) f)
+ (push meth acc)))))))
+ (nreverse acc)))
(defun comfile (&rest files) (dolist (f files) (send comp :compile-file f)))
(defun compile-file (file &rest keys)
(send* comp :compile-file file keys))
+(defun compile-tmp (fname)
+ (let (pname)
+ (compile-file fname)
+ (unix:unlink fname)
+ (setq pname (make-pathname :defaults fname :type "c"))
+ (unix:unlink (namestring pname))
+ (setq pname (make-pathname :defaults fname :type "h"))
+ (unix:unlink (namestring pname))
+ (setq pname (make-pathname :defaults fname :type
+ #-(or :linux :cygwin) "o"
+ #+:cygwin "dll"
+ #+:linux "so"
+ ))
+ (load pname)
+ (unix:unlink (namestring pname))
+ #+(or :linux :cygwin)
+ (unix:unlink (namestring (make-pathname :defaults fname :type "o")))
+ pname))
+
(defun compile (&rest funcs)
- (let ((fname (format nil "eus~d~A.l" (unix:getpid)
- (symbol-name (gensym "C")))) (pname))
- (apply #'dump-function fname funcs)
- (compile-file fname)
- (unix:unlink fname)
- (setq pname (make-pathname :defaults fname :type "c"))
- (unix:unlink (namestring pname))
- (setq pname (make-pathname :defaults fname :type "h"))
- (unix:unlink (namestring pname))
- (setq pname (make-pathname :defaults fname :type
- #-(or :linux :cygwin) "o"
- #+:cygwin "dll"
- #+:linux "so"
- ))
- (load pname)
- (unix:unlink (namestring pname))
- (setq pname (make-pathname :defaults fname :type "q"))
- (unix:unlink (namestring pname))
- funcs
- ))
+ (let* ((fname (format nil "eus~d~A.l" (unix:getpid)
+ (symbol-name (gensym "C"))))
+ (res (apply #'dump-function fname funcs)))
+ (when res
+ (compile-tmp fname)
+ res)))
+
+(defun compile-method (obj &rest meths)
+ (let* ((fname (format nil "eus~d~A.l" (unix:getpid)
+ (symbol-name (gensym "C"))))
+ (res (apply #'dump-method fname obj meths)))
+ (when res
+ (compile-tmp fname)
+ res)))
(defun compile-file-if-src-newer (srcfile &optional (objdir "./")
&rest args)
@@ -1497,14 +2123,15 @@
)
srcfile ))
+(defun compiler-implementation-version ()
+ (format nil "EusLisp compiler version ~A" compiler-implementation-version))
(defun comp-file-toplevel (&rest argv)
- (warn "EusLisp compiler version 1.54 June/1986 ... May/1996")
+ (warn (compiler-implementation-version))
(terpri *error-output*)
(sys:alloc 60000)
(setq lisp::*prompt-string* "euscomp$ ")
- (let ((i 1) (l (length argv)) (arg) (flag)
- (*error-handler* 'lisp::euserror))
+ (let ((i 1) (l (length argv)) (arg) (flag))
(cond ((< l 1) (apply #'eustop argv))
((< l 2)
(format t
diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l
index d763c1fb8..db80dc765 100644
--- a/lisp/comp/trans.l
+++ b/lisp/comp/trans.l
@@ -34,26 +34,41 @@
(eval-when (load eval)
+;; the `avant-mode' variable is set during pre-evaluation
+;; in the compiler class, this is used to allocate closure frames
+;; in the translator class, this is used to prevent file output
+(defparameter avant-mode nil)
+
+;; the ftab is used to call functions by symbol
+;; it is used when the function has no builtin definition and
+;; when the function definition is not found in the current file
(defparameter ftab-next 0)
(defparameter external-functions nil)
+(defun maybe-format (fstream format-string &rest args)
+ ;; suppress all output in pre-evaluation mode
+ (unless avant-mode
+ (apply #'format fstream format-string args)))
+
(defun ftab-index (sym)
(let ((index (get sym :ftab-index)))
(if (null index)
(prog1 (setf (get sym :ftab-index) ftab-next)
(push sym external-functions)
(incf ftab-next))
- index)))
+ (prog1 index
+ (unless (< index ftab-next)
+ (error value-error "invalid ftab-index found in ~S: ~A~%" sym index))))))
(defmethod translator
(:label (l)
(send self :clearpush)
- (format cfile "~A:~%" l))
+ (maybe-format cfile "~A:~%" l))
(:comment (&rest c)
- (princ "/*" cfile)
- (while c (princ (pop c) cfile))
- (princ "*/" cfile)
- (terpri cfile))
+ (maybe-format cfile "/*")
+ (while c (if cfile (princ (pop c) cfile)))
+ (maybe-format cfile "*/")
+ (if cfile (terpri cfile)))
#+:rgc
(:nonpop ()
(if push push
@@ -63,16 +78,30 @@
(progn (dec pushcount) (format nil "local[~d]" pushcount))))
(:store (dest)
(if (or (null push) (not (equal push dest)))
- (format cfile " ~A = ~A;~%" dest (send self :pop))
+ (maybe-format cfile " ~A = ~A;~%" dest (send self :pop))
(setq push nil)))
(:push (src)
(send self :clearpush)
(setq push src))
(:clearpush () ;flush out reserved push
(when push
- (format cfile " local[~d]= ~A;~%" pushcount push)
+ (maybe-format cfile " local[~d]= ~A;~%" pushcount push)
(inc pushcount))
- (setq push nil)) )
+ (setq push nil))
+ (:create-frame (size &optional comment)
+ (send self :clearpush)
+ (send self :reset-vsp)
+ (prog1 pushcount
+ (maybe-format cfile " local[~d]= makevector(C_VECTOR,~d);" pushcount size)
+ (if comment (maybe-format cfile " /*~A*/" comment))
+ (if cfile (terpri cfile))
+ (inc pushcount)))
+ (:clearpush-frame (bindframe count)
+ (when push
+ (maybe-format cfile " local[~d]->c.vec.v[~d]= ~A;~%"
+ bindframe count push))
+ (setq push nil))
+)
(defmethod translator
(:quote-entry (q)
@@ -97,11 +126,11 @@
(:offset-from-fp ()
(send self :clearpush)
pushcount)
- (:reset-vsp () (format cfile " ctx->vsp=local+~d;~%" pushcount))
+ (:reset-vsp () (maybe-format cfile " ctx->vsp=local+~d;~%" pushcount))
(:bind-special (id)
(send self :store "w")
(send self :reset-vsp)
- (format cfile " bindspecial(ctx,fqv[~d],w);~%"
+ (maybe-format cfile " bindspecial(ctx,fqv[~d],w);~%"
(send self :quote-entry id))
; (send self :reset-fsp)
(inc pushcount 3) ;3 longs for special bind frame
@@ -109,7 +138,7 @@
(:unbind-special (count)
(send self :clearpush)
(send self :reset-vsp)
- (format cfile " unbindx(ctx,~d);~%" count)
+ (maybe-format cfile " unbindx(ctx,~d);~%" count)
; (send self :reset-fsp)
)
(:pushenv ()
@@ -117,54 +146,64 @@
(send self :push "env")
(send self :clearpush))
(:enter (cname lname)
- (terpri cfile)
+ (if cfile (terpri cfile))
(send self :comment lname)
(setq pushcount 0) ;reset pushcount
;because a4(vfp) changes here
- (format cfile "static pointer ~A(ctx,n,argv,env)~%" cname)
- (format cfile "register context *ctx;~%")
- (format cfile "register int n; register pointer argv[]; pointer env;~%")
- (format cfile "{ register pointer *local=ctx->vsp, w, *fqv=qv;~%")
- (format cfile " numunion nu;~%")
+ (maybe-format cfile "static pointer ~A(ctx,n,argv,env)~%" cname)
+ (maybe-format cfile "register context *ctx;~%")
+ (maybe-format cfile "register int n; register pointer argv[]; pointer env;~%")
+ (maybe-format cfile "{ register pointer *local=ctx->vsp, w, *fqv=qv;~%")
+ (maybe-format cfile " numunion nu;~%")
)
(:check-req-arg (req opt) ;check number of required arguments
- (if (> *safety* 1) (format cfile " breakck;~%"))
+ (if (> *safety* 1) (maybe-format cfile " breakck;~%"))
(if (> *safety* 0)
(if (>= req 0)
- (format cfile " if (n~A~d) maerror();~%"
+ (maybe-format cfile " if (n~A~d) maerror();~%"
(if (= opt 0) "!=" "<") req))) )
(:check-opt-arg (m lab)
- (format cfile " if (n>=~d) { local[~d]=(argv[~d]); goto ~A;}~%"
- (1+ m) pushcount m lab))
+ (maybe-format cfile " if (n>=~d) { local[~d]=(argv[~d]); goto ~A;}~%"
+ (1+ m) pushcount m lab))
+ (:check-opt-arg-frame (m lab)
+ (format cfile " if (n>=~d) { ~A=(argv[~d]); goto ~A;}~%"
+ (1+ m) (send self :pop) m lab))
(:check-rest-arg (m)
(if (> *safety* 0)
- (format cfile " if (n>~d) maerror();~%" m)) )
+ (maybe-format cfile " if (n>~d) maerror();~%" m)) )
(:rest (pcnt)
(send self :clearpush)
(send self :reset-vsp)
(send self :push (format nil "minilist(ctx,&argv[n],n-~d)" pcnt)))
(:parse-key-params (keyvec req+opt keyn allowotherkeys)
(send self :clearpush)
- (send self :reset-vsp)
- (format cfile
+ (maybe-format cfile
" n=parsekeyparams(fqv[~d], &argv[~d], n-~d, local+~d, ~A);~%"
(send self :quote-entry keyvec) req+opt req+opt
- pushcount
+ pushcount
(if allowotherkeys 1 0))
(inc pushcount keyn))
(:check-key-arg (n lab)
- (format cfile " if (n & (1<<~A)) goto ~A;~%" n lab))
- (:getbase (n argp)
- (cond ((= n 0) (if argp "argv" "local"))
+ (maybe-format cfile " if (n & (1<<~A)) goto ~A;~%" n lab))
+ (:getbase (n argp &optional bindframe)
+ (if (not (numberp bindframe)) (setq bindframe nil))
+ (cond ((= n 0)
+ (cond
+ (bindframe
+ (format nil "local[~d]->c.vec.v" bindframe))
+ (argp "argv")
+ (t "local")))
(t
(let* ((f "env->"))
(while (> n 1)
(setq f (concatenate string f
"c.clo.env0->"))
(dec n))
+ (when (and (not bindframe) (not avant-mode))
+ (error value-error "; empty bindframe in closure reference!~%"))
(setq f (concatenate string f
- (if argp "c.clo.env1"
- "c.clo.env2")))
+ (format nil "c.clo.env1->c.vec.v[~d]->c.vec.v"
+ (or bindframe -1))))
f))))
(:load-t () (send self :push "T"))
(:load-nil () (send self :push "NIL"))
@@ -184,34 +223,34 @@
)
(defmethod translator
- (:load-arg (n level)
+ (:load-arg (n level &optional bindframe)
(send self :push
- (format nil "~A[~d]" (send self :getbase level 'arg) n)))
- (:load-local (n level)
+ (format nil "~A[~d]" (send self :getbase level 'arg bindframe) n)))
+ (:load-local (n level &optional bindframe)
(send self :push
- (format nil "~A[~d]" (send self :getbase level nil) n)))
- (:load-obj (n level)
+ (format nil "~A[~d]" (send self :getbase level nil bindframe) n)))
+ (:load-obj (n level &optional bindframe)
(send self :push
(format nil "~A[0]->c.obj.iv[~d]"
- (send self :getbase level 'arg) n)))
+ (send self :getbase level 'arg bindframe) n)))
(:load-global (ent)
(send self :push (format nil "loadglobal(fqv[~d])"
(send self :quote-entry ent))))
- (:store-arg (n level)
- (send self :store (format nil "~A[~d]" (send self :getbase level 'arg) n)))
- (:store-local (offset level)
- (send self :store (format nil "~A[~d]" (send self :getbase level nil) offset)))
- (:store-obj (var level)
+ (:store-arg (n level &optional bindframe)
+ (send self :store (format nil "~A[~d]" (send self :getbase level 'arg bindframe) n)))
+ (:store-local (offset level &optional bindframe)
+ (send self :store (format nil "~A[~d]" (send self :getbase level nil bindframe) offset)))
+ (:store-obj (var level &optional bindframe)
#+:rgc
- (let ((p1 (send self :getbase level 'arg))
+ (let ((p1 (send self :getbase level 'arg bindframe))
(p2 var))
(send self :store (format nil "noticeCollector1(~A[0]->c.obj.iv[~d]);~% ~A[0]->c.obj.iv[~d]"
p1 p2 p1 p2)))
#-:rgc
(send self :store (format nil "~A[0]->c.obj.iv[~d]"
- (send self :getbase level 'arg) var)))
+ (send self :getbase level 'arg bindframe) var)))
(:store-global (var)
- (format cfile " storeglobal(fqv[~d],~A);~%"
+ (maybe-format cfile " storeglobal(fqv[~d],~A);~%"
(send self :quote-entry var) (send self :pop)))
(:load-ovaf (var)
(send self :push
@@ -247,13 +286,13 @@
(if (null entry) (setq entry (get sym 'builtin-function-entry)))
(send self :clearpush)
(send self :reset-vsp)
- (unless (functionp sym)
+ (if (and (not (functionp sym)) (not avant-mode))
(format *error-output* "; ~C[34;7m~S~C[0;34m is assumed to be undefined function~C[0m~%"
#x1b sym #x1b #x1b))
(if entry
- (format cfile " w=(pointer)~A(ctx,~d,local+~d); /*~A*/~%"
+ (maybe-format cfile " w=(pointer)~A(ctx,~d,local+~d); /*~A*/~%"
entry n (- pushcount n) sym)
- (format cfile " w=(*ftab[~d])(ctx,~d,local+~d,&ftab[~d],fqv[~d]); /*~A*/~%"
+ (maybe-format cfile " w=(*ftab[~d])(ctx,~d,local+~d,&ftab[~d],fqv[~d]); /*~A*/~%"
(ftab-index sym)
n (- pushcount n)
(ftab-index sym)
@@ -265,11 +304,15 @@
;closure object on the top of stack
(send self :store "w") ;closure
(send self :reset-vsp)
- (format cfile " w=~a(ctx,~d,local+~d,w);~%" entry argc (- pushcount argc))
+ (maybe-format cfile " w=~a(ctx,~d,local+~d,w);~%" entry argc (- pushcount argc))
(send self :discard argc)
(send self :push "w"))
(:getfunc (sym)
- (send self :push (format nil "(pointer)get_sym_func(fqv[~d])"
+ ;; getfunc_closure allocates new cons cells
+ ;; properly set vsp before calling
+ (send self :clearpush)
+ (send self :reset-vsp)
+ (send self :push (format nil "(pointer)getfunc_closure(ctx,fqv[~d])"
(send self :quote-entry sym))))
)
@@ -283,8 +326,8 @@
(:check-cons-nil () ; check if stack-top is cons or nil.
(if (equal push "w")
(send self :pop)
- (format cfile " w=~a;~%" (send self :pop)))
- (format cfile " if (!iscons(w) && w!=NIL) error(E_NOLIST);~%")
+ (maybe-format cfile " w=~a;~%" (send self :pop)))
+ (maybe-format cfile " if (!iscons(w) && w!=NIL) error(E_NOLIST);~%")
(send self :push "w"))
(:car ()
(if (< *optimize* 2)
@@ -362,68 +405,69 @@
(send self :reset-vsp)
(send self :push (format nil "cons(ctx,~A,w)" (send self :pop))))
(:svref () ; reference to a simple general vector element
- (format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop))
+ (maybe-format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop))
(let ((vec (send self :pop)))
- (format cfile " w=(~A->c.vec.v[i]);}~%" vec))
+ (maybe-format cfile " w=(~A->c.vec.v[i]);}~%" vec))
(send self :push "w"))
(:svset () ; store to a simple general vector
(send self :store "w") ;value
- (format cfile " { register eusinteger_t i; register pointer v;~%")
- (format cfile " i=intval(~A); v=~A;~%" (send self :pop)
+ (maybe-format cfile " { register eusinteger_t i; register pointer v;~%")
+ (maybe-format cfile " i=intval(~A); v=~A;~%" (send self :pop)
(send self :pop))
#+:rgc
- (format cfile " noticeCollector(v->c.vec.v[i], w);~%")
- (format cfile " v->c.vec.v[i]=w;}~%")
+ (maybe-format cfile " noticeCollector(v->c.vec.v[i], w);~%")
+ (maybe-format cfile " v->c.vec.v[i]=w;}~%")
(send self :push "w"))
(:char ()
- (format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop))
+ (maybe-format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop))
(let ((vec (send self :pop)))
- (format cfile " w=makeint(~A->c.str.chars[i]);}~%" vec))
+ (maybe-format cfile " if (!isstring(~A)) error(E_NOSTRING);~%" vec)
+ (maybe-format cfile " w=makeint(~A->c.str.chars[i]);}~%" vec))
(send self :push "w"))
(:setchar ()
(send self :store "w") ;value
- (format cfile " { register eusinteger_t i; register pointer v;~%")
- (format cfile " i=intval(~A); v=~A;~%" (send self :pop)
+ (maybe-format cfile " { register eusinteger_t i; register pointer v;~%")
+ (maybe-format cfile " i=intval(~A); v=~A;~%" (send self :pop)
(send self :pop))
- (format cfile " v->c.str.chars[i]=intval(w);}~%")
+ (maybe-format cfile " v->c.str.chars[i]=intval(w);}~%")
(send self :push "w"))
(:bit ()
- (format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop))
+ (maybe-format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop))
(let ((vec (send self :pop)))
- (format cfile " w=makeint(~A->c.str.chars[i/8]&(1<<(i&7))?1:0);}~%" vec))
+ (maybe-format cfile " w=makeint(~A->c.str.chars[i/8]&(1<<(i&7))?1:0);}~%" vec))
(send self :push "w"))
(:setbit ()
(send self :store "w") ;value
- (format cfile " { register eusinteger_t i; register byte *v;~%")
- (format cfile " i=intval(~A); v=~A->c.str.chars;~%" (send self :pop)
+ (maybe-format cfile " { register eusinteger_t i; register byte *v;~%")
+ (maybe-format cfile " i=intval(~A); v=~A->c.str.chars;~%" (send self :pop)
(send self :pop))
- (format cfile " if (((eusinteger_t)w)&4) v[i/8]|=(1<<(intval(i)&7));~%")
- (format cfile " else v[i/8]&= ~~(1<<(intval(i)&7));}~%")
+ (maybe-format cfile " if (((eusinteger_t)w)&4) v[i/8]|=(1<<(intval(i)&7));~%")
+ (maybe-format cfile " else v[i/8]&= ~~(1<<(intval(i)&7));}~%")
(send self :push "w"))
(:vref (type) ; reference to a simple vector element
- (format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop))
+ (maybe-format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop))
(let ((vec (send self :pop)))
(case type
- (character (format cfile " w=makeint(~A->c.str.chars[i]);}~%" vec))
- (integer (format cfile " w=makeint(~A->c.ivec.iv[i]);}~%" vec))
- (float (format cfile " w=makeflt(~A->c.fvec.fv[i]);}~%" vec))
- (pointer (format cfile " w=(~A->c.vec.v[i]);}~%" vec))
- (T (send self :error "unknown vector element type")))
+ (character (maybe-format cfile " w=makeint(~A->c.str.chars[i]);}~%" vec))
+ (integer (maybe-format cfile " w=makeint(~A->c.ivec.iv[i]);}~%" vec))
+ (float (maybe-format cfile " w=makeflt(~A->c.fvec.fv[i]);}~%" vec))
+ (pointer (maybe-format cfile " w=(~A->c.vec.v[i]);}~%" vec))
+ (T (send self :error "unknown vector element type ~S" type)))
(send self :push "w")))
(:vset (type) ; store to a vector element whose type is apparent
(send self :store "w") ;value
- (format cfile " { register eusinteger_t i; register pointer v;~%")
- (format cfile " i=intval(~A); v=~A;~%" (send self :pop)
+ (maybe-format cfile " { register eusinteger_t i; register pointer v;~%")
+ (maybe-format cfile " i=intval(~A); v=~A;~%" (send self :pop)
(send self :pop))
(case type
- (character (format cfile " v->c.str.chars[i]=intval(w);}~%"))
- (integer (format cfile " v->c.ivec.iv[i]=intval(w);}~%"))
- (float (format cfile " v->c.fvec.fv[i]=fltval(w);}~%"))
+ (character (maybe-format cfile " v->c.str.chars[i]=intval(w);}~%"))
+ (integer (maybe-format cfile " v->c.ivec.iv[i]=intval(w);}~%"))
+ (float (maybe-format cfile " v->c.fvec.fv[i]=fltval(w);}~%"))
(pointer
#+:rgc
- (format cfile " noticeCollector(v->c.vec.v[i], w);~%")
- (format cfile " v->c.vec.v[i]=w;}~%"))
- (T (send self :error "unknown vector element type")))
+ (maybe-format cfile " noticeCollector(v->c.vec.v[i], w);~%")
+ (maybe-format cfile " v->c.vec.v[i]=w;}~%"))
+ (T (send self :error "unknown vector element type ~S" type)))
(send self :push "w"))
(:nullx ()
(send self :push (format nil "((~A)==NIL?T:NIL)" (send self :pop))))
@@ -441,22 +485,70 @@
(numberp . "numberp") (integerp . "isint")
(floatp . "isflt") (stringp . "isstring")
))))))
+ (:type-check-declare (type)
+ (let* ((ckfn (case type
+ (symbol "issymbol")
+ (cons "iscons")
+ (list "islist(w) || w==NIL")
+ (number "numberp")
+ (integer "isint")
+ (float "isflt")
+ (string "isstring")
+ (array "isarray(w) || isvector(w)")
+ (vector "isvector")
+ (float-vector "isfltvector")
+ (integer-vector "isintvector")
+ (bit-vector "isbitvector")
+ (stream "isstream")
+ (metaclass "isclass")
+ (package "ispackage")
+ (t
+ (unless (eq type t) (warn "unknown type declaration: ~A~%" type))
+ nil)))
+ (errc (case type
+ (symbol "E_NOSYMBOL")
+ (cons "E_NOLIST")
+ (list "E_NOLIST")
+ (number "E_NONUMBER")
+ (integer "E_NOINT")
+ (float "E_TYPE_ERROR, (pointer)\"float expected\"")
+ (string "E_NOSTRING")
+ (array "E_NOARRAY")
+ (vector "E_NOVECTOR")
+ (float-vector "E_FLOATVECTOR")
+ (integer-vector "E_NOINTVECTOR")
+ (bit-vector "E_BITVECTOR")
+ (stream "E_STREAM")
+ (metaclass "E_NOCLASS, w")
+ (package "E_NOPACKAGE, w")
+ (t
+ (unless (eq type t) (warn "unknown type declaration: ~A~%" type))
+ nil))))
+ (if (and ckfn errc)
+ (progn
+ (send self :store "w")
+ (case type
+ ((list array)
+ (maybe-format cfile " if (!(~A)) error(~A);~%" ckfn errc))
+ (t
+ (maybe-format cfile " if (!~A(w)) error(~A);~%" ckfn errc))))
+ (setq push nil))))
(:if-nil (lab)
- (format cfile " if (~A==NIL) goto ~A;~%" (send self :pop) lab))
+ (maybe-format cfile " if (~A==NIL) goto ~A;~%" (send self :pop) lab))
(:if-t (lab)
- (format cfile " if (~A!=NIL) goto ~A;~%" (send self :pop) lab))
+ (maybe-format cfile " if (~A!=NIL) goto ~A;~%" (send self :pop) lab))
(:if-eq (lab)
- (format cfile " if (~A==~A) goto ~A;~%" (send self :pop)
+ (maybe-format cfile " if (~A==~A) goto ~A;~%" (send self :pop)
(send self :pop) lab))
(:if-neq (lab)
- (format cfile " if (~A!=~A) goto ~A;~%" (send self :pop)
+ (maybe-format cfile " if (~A!=~A) goto ~A;~%" (send self :pop)
(send self :pop) lab))
;;; integer arithmetics, machine architecture dependent
(:int-op2 (op) ;+,-,*,logand,logior
(cond ((memq op '(+ - logand logior))
(send self :store "w")
(when (memq op '(+ -))
- (format cfile
+ (maybe-format cfile
"#if sun4 || vax || mips || alpha || Linux~% w=(pointer)((eusinteger_t)w-2);~%#endif~%"))
(send self :push
(format nil "(pointer)((eusinteger_t)~A ~A (eusinteger_t)w)"
@@ -464,11 +556,11 @@
(cdr (assq op '((+ . "+") (- . "-") (logand . "&")
(logior . "|")))))))
(t
- (format cfile " { eusinteger_t i,j;~%")
- (format cfile
+ (maybe-format cfile " { eusinteger_t i,j;~%")
+ (maybe-format cfile
" j=intval(~A); i=intval(~A);~%"
(send self :pop) (send self :pop))
- (format cfile
+ (maybe-format cfile
" local[~d]=(makeint(i ~A j));}~%"
pushcount
(cdr (assq op '((+ . "+") (- . "-") (logand . "&")
@@ -486,22 +578,22 @@
((eq comparator '=) (send self :if-eq lab))
((eq type 'int)
(send self :store "w")
- (format cfile " if ((eusinteger_t)~A ~A (eusinteger_t)w) goto ~A;~%"
+ (maybe-format cfile " if ((eusinteger_t)~A ~A (eusinteger_t)w) goto ~A;~%"
(send self :pop) comparator lab))
((eq type 'float)
- (format cfile " { double left,right;~%")
- (format cfile
+ (maybe-format cfile " { double left,right;~%")
+ (maybe-format cfile
" right=fltval(~A); left=fltval(~A);~%"
(send self :pop) (send self :pop))
- (format cfile " if (left ~A right) goto ~A;}~%" comparator lab))
- (t (send self :error "illegal compare"))))
+ (maybe-format cfile " if (left ~A right) goto ~A;}~%" comparator lab))
+ (t (send self :error "illegal compare ~S" type))))
;;; floating arithemtics
(:flt-op2 (op)
- (format cfile " { double x,y;~%")
- (format cfile
+ (maybe-format cfile " { double x,y;~%")
+ (maybe-format cfile
" y=fltval(~A); x=fltval(~A);~%"
(send self :pop) (send self :pop))
- (format cfile
+ (maybe-format cfile
" local[~d]=(makeflt(x ~A y));}~%"
pushcount
(cdr (assq op '((+ . +) (- . -) (* . *) (/ . /)))))
@@ -516,31 +608,32 @@
(consp . "iscons") (stringp . "isstring")))))
(:if-type (type lab)
(send self :store "w")
- (format cfile " if (~A(w)) goto ~A;~%"
+ (maybe-format cfile " if (~A(w)) goto ~A;~%"
(send self :type-checker type) lab))
(:if-not-type (type lab)
(send self :store "w")
- (format cfile " if (!~A(w)) goto ~A;~%"
+ (maybe-format cfile " if (!~A(w)) goto ~A;~%"
(send self :type-checker type) lab))
;;;
(:jump (lab)
(send self :clearpush)
- (format cfile " goto ~A;~%" lab))
+ (maybe-format cfile " goto ~A;~%" lab))
(:return ()
(send self :clearpush)
- (format cfile " ctx->vsp=local; return(local[0]);}~%")
- (if (not (= (dec pushcount) 0)) (warn ":return pushcount is ~d " pushcount)))
+ (maybe-format cfile " ctx->vsp=local; return(local[0]);}~%")
+ (when (and (not (= (dec pushcount) 0)) (not avant-mode))
+ (error value-error ":return pushcount is ~d~%" pushcount)))
(:del-frame (spe loc) ;number of special bindings and local variables
(send self :store "w")
(send self :discard (+ (* 3 spe) loc))
(send self :push "w"))
(:entercatch (exit)
- (format cfile " {jmp_buf jb;~%")
+ (maybe-format cfile " {jmp_buf jb;~%")
(send self :store "w")
(send self :reset-vsp)
- (format cfile
+ (maybe-format cfile
" mkcatchframe(ctx,w,(jmp_buf *)jb);~%")
- (format cfile
+ (maybe-format cfile
" if ((w=(pointer)eussetjmp(jb))!=0) { /*fsp=vsp;*/ goto ~A;}~%"
exit)
; (send self :reset-fsp)
@@ -548,19 +641,19 @@
(:exitcatch (exlab)
(send self :store "w")
(send self :label exlab)
- (format cfile " if (w==(pointer)(1)) w=makeint(0);~%")
- (format cfile " restorecatch(ctx);};~%")
+ (maybe-format cfile " if (w==(pointer)(1)) w=makeint(0);~%")
+ (maybe-format cfile " restorecatch(ctx);};~%")
; (send self :reset-fsp)
(dec pushcount 6)
(send self :push "w")) ;result of catch
(:throw ()
(send self :store "w") ;result
(send self :reset-vsp)
- (format cfile " throw(ctx,vpop(),w);~%")
- (format cfile " error(E_NOCATCHER,NULL);~%"))
+ (maybe-format cfile " throw(ctx,vpop(),w);~%")
+ (maybe-format cfile " error(E_NOCATCHER,NULL);~%"))
(:bind-cleaner ()
(send self :store "w") ;must be a closure
- (format cfile
+ (maybe-format cfile
" local[~d]=(pointer)(ctx->protfp); local[~d]=w;
ctx->protfp=(struct protectframe *)(local+~d);~%"
pushcount (1+ pushcount) pushcount)
@@ -568,31 +661,41 @@
(:call-cleaner (cleaner)
(send self :store "w")
(send self :reset-vsp)
- (format cfile " ~A(ctx,0,local+~d,ctx->protfp->cleaner);~%" cleaner pushcount)
- (format cfile " ctx->protfp=ctx->protfp->protlink;~%")
+ (maybe-format cfile " ~A(ctx,0,local+~d,ctx->protfp->cleaner);~%" cleaner pushcount)
+ (maybe-format cfile " ctx->protfp=ctx->protfp->protlink;~%")
(dec pushcount 2)
(send self :push "w"))
(:return-from (k need-unwind)
(send self :store "w") ;save result
(send self :reset-vsp)
(if need-unwind
- (format cfile " unwind(ctx,local+~d);~%" k))
- (format cfile " local[~d]=w;~%" k)
+ (if (zerop k)
+ (maybe-format cfile " unwind(ctx,local-1);~%")
+ (maybe-format cfile " unwind(ctx,local+~d);~%" (1- k))))
+ (maybe-format cfile " local[~d]=w;~%" k)
(inc pushcount))
(:go-tag (k need-unwind)
(send self :reset-vsp)
(if need-unwind
- (format cfile " unwind(ctx,local+~d);~%" k))
+ (if (zerop k)
+ (maybe-format cfile " unwind(ctx,local-1);~%")
+ (maybe-format cfile " unwind(ctx,local+~d);~%" (1- k))))
(inc pushcount))
- (:closure (lab)
- (send self :clearpush)
- (send self :reset-vsp)
+ (:closure (lab env0 env1)
+ (if env1
+ (progn
+ (send self :reset-vsp) ; use the push-count before decrease
+ (send self :store "w")) ; store to w before increasing the pushcount
+ (progn
+ (send self :clearpush) ; clear other pending values
+ (send self :reset-vsp))) ; use the push-count after increase
(send self :push
- (format nil "makeclosure(codevec,quotevec,~A,env,argv,local)" lab)))
+ (format nil "makeclosure(codevec,quotevec,~A,~A,~A)"
+ lab (if env0 "env" "NIL") (if env1 "w" "NIL"))))
(:defun (sym cname doc)
(send self :clearpush)
(send self :reset-vsp)
- (format cfile
+ (maybe-format cfile
" compfun(ctx,fqv[~d],module,~A,fqv[~d]);~%"
(send self :quote-entry sym)
cname
@@ -600,7 +703,7 @@
(:defmacro (sym label doc)
(send self :clearpush)
(send self :reset-vsp)
- (format cfile
+ (maybe-format cfile
" compmacro(ctx,fqv[~d],module,~A,fqv[~d]);~%"
(send self :quote-entry sym)
label
@@ -611,15 +714,25 @@
; addcmethod(module,cfunc,sel,klass)
(send self :clearpush)
(send self :reset-vsp)
- (format cfile
+ (maybe-format cfile
" addcmethod(ctx,module,~A,fqv[~d],fqv[~d],~A);~%"
label
(send self :quote-entry sel)
(send self :quote-entry klass)
(send self :quote-fqv-entry doc) ))
(:declare-forward-function (name)
- (format hfile "static pointer ~A();~%" name))
+ (maybe-format hfile "static pointer ~A();~%" name))
(:quote () quotev)
+ (:copy-translator ()
+ (let ((newtrans) (cfile-save cfile) (hfile-save hfile))
+ (unwind-protect
+ (progn
+ (setq cfile nil)
+ (setq hfile nil)
+ (setq newtrans (copy-object self)))
+ (setq cfile cfile-save)
+ (setq hfile hfile-save))
+ newtrans))
(:init ()
(setq push nil
pushcount 0 ))
@@ -629,76 +742,83 @@
quotev nil
external-functions nil
ftab-next 0)
- (format cfile "/* ~a : entry=~a */~%" (namestring cname) entry)
- (format cfile "/* compiled by ~a */~%" (lisp:lisp-implementation-version))
- (format cfile "#include \"eus.h\"~%") ;should specify -I opt.
+ (maybe-format cfile "/* ~a : entry=~a */~%" (namestring cname) entry)
+ (maybe-format cfile "/* compiled by ~a */~%" (lisp:lisp-implementation-version))
+ (maybe-format cfile "#include \"eus.h\"~%") ;should specify -I opt.
#+:rgc
- (format cfile "#include \"collector.h\"~%")
- (format cfile "#include \"~A.~A\"~%" (pathname-name hname) (pathname-type hname))
+ (maybe-format cfile "#include \"collector.h\"~%")
+ (maybe-format cfile "#include \"~A.~A\"~%" (pathname-name hname) (pathname-type hname))
#-:alpha
- (format cfile "#pragma init (register_~a)~%" entry)
- (format cfile "extern double fabs();~%")
- (format cfile "extern pointer fcallx();~%")
- (format cfile "static void init_ftab();~%")
+ (maybe-format cfile "#pragma init (register_~a)~%" entry)
+ (maybe-format cfile "extern double fabs();~%")
+ (maybe-format cfile "extern pointer fcallx();~%")
+ (maybe-format cfile "static void init_ftab();~%")
(cond
((> *optimize* 2)
- (format cfile "#define loadglobal(s) s->c.sym.speval~%")
+ (maybe-format cfile "#define loadglobal(s) s->c.sym.speval~%")
#+:rgc
- (format cfile "#define storeglobal(s,val) {noticeCollector(s->c.sym.speval,(val)); s->c.sym.speval=(val)~%")
+ (maybe-format cfile "#define storeglobal(s,val) {noticeCollector(s->c.sym.speval,(val)); s->c.sym.speval=(val)~%")
#-:rgc
- (format cfile "#define storeglobal(s,val) s->c.sym.speval=(val)~%"))
- (t (format cfile "extern pointer loadglobal(),storeglobal();~%")))
- (format cfile "static pointer module,*qv,codevec,quotevec;~%")
+ (maybe-format cfile "#define storeglobal(s,val) s->c.sym.speval=(val)~%"))
+ (t (maybe-format cfile "extern pointer loadglobal(),storeglobal();~%")))
+ (maybe-format cfile "static pointer module,*qv,codevec,quotevec;~%")
(if (memq 'lisp::solaris2 *features*)
- (format cfile "static pointer ___~a();~%" entry)
- (format cfile "extern pointer ___~a();~%" entry))
- (format cfile "extern pointer build_quote_vector();~%")
- (format cfile "static int register_~a()~%" entry)
- (format cfile " { add_module_initializer(~s, ___~a);}~%~%"
+ (maybe-format cfile "static pointer ___~a();~%" entry)
+ (maybe-format cfile "extern pointer ___~a();~%" entry))
+ (maybe-format cfile "extern pointer build_quote_vector();~%")
+ (maybe-format cfile "static int register_~a()~%" entry)
+ (maybe-format cfile " { add_module_initializer(~s, ___~a);}~%~%"
(concatenate string "___" (pathname-name source-name))
entry)
(dolist (f *defun-list*)
- (format cfile "static pointer ~a();~%" (get f 'user-function-entry)))
+ (maybe-format cfile "static pointer ~a();~%" (get f 'user-function-entry)))
)
(:eusmain (entry)
- (format cfile "~%/* initializer*/~%pointer ___~A(ctx,n,argv,env)
+ (maybe-format cfile "~%/* initializer*/~%pointer ___~A(ctx,n,argv,env)
register context *ctx; int n; pointer *argv; pointer env;~%" entry)
- (format cfile "{ register pointer *local=ctx->vsp, w, *fqv;~% register int i;~%")
- (format cfile " numunion nu;~%")
- (format cfile " module=argv[0];~%")
- (format cfile " quotevec=build_quote_vector(ctx,QUOTE_STRINGS_SIZE, quote_strings);~%")
- (format cfile " module->c.code.quotevec=quotevec;~%")
- (format cfile " codevec=module->c.code.codevec;~%")
- (format cfile " fqv=qv=quotevec->c.vec.v;~%")
- (format cfile " init_ftab();~%")
+ (maybe-format cfile "{ register pointer *local=ctx->vsp, w, *fqv;~% register int i;~%")
+ (maybe-format cfile " numunion nu;~%")
+ (maybe-format cfile "#if defined(COMPTIMEVERSION)~%")
+ (maybe-format cfile " checkcompversion(COMPTIMEVERSION);~%")
+ (maybe-format cfile "#else~%")
+ (maybe-format cfile " checkcompversion(NULL);~%")
+ (maybe-format cfile "#endif~%")
+ (maybe-format cfile " module=argv[0];~%")
+ (maybe-format cfile " quotevec=build_quote_vector(ctx,QUOTE_STRINGS_SIZE, quote_strings);~%")
+ (maybe-format cfile " module->c.code.quotevec=quotevec;~%")
+ (maybe-format cfile " codevec=module->c.code.codevec;~%")
+ (maybe-format cfile " fqv=qv=quotevec->c.vec.v;~%")
+ (maybe-format cfile " init_ftab();~%")
)
(:write-quote-vector ()
- (format hfile "#define QUOTE_STRINGS_SIZE ~d~%" (length quotev))
- (format hfile "~astatic char *quote_strings[QUOTE_STRINGS_SIZE]={~%"
+ (maybe-format hfile "#define QUOTE_STRINGS_SIZE ~d~%" (length quotev))
+ (maybe-format hfile "~astatic char *quote_strings[QUOTE_STRINGS_SIZE]={~%"
(if (memq :solaris2 *features*) "const " ""))
(dolist (q quotev)
(let* ((s (prin1-to-string q)) (len (length s)) (ch))
- (format hfile " \"")
+ (maybe-format hfile " \"")
(dotimes (i len)
(cond ((eql (char s i) #\\) ;escaped
(write-byte #\\ hfile) (write-byte #\\ hfile))
((eql (char s i) #\") ;double quote
- (format hfile "\\\""))
+ (maybe-format hfile "\\\""))
((eql (char s i) #\newline)
- (format hfile "\\n"))
+ (maybe-format hfile "\\n"))
(t (write-byte (char s i) hfile))))
- (format hfile "\",~%")))
- (format hfile " };~%")
+ (maybe-format hfile "\",~%")))
+ (maybe-format hfile " };~%")
)
(:declare-ftab ()
(if (> ftab-next 0)
- (format hfile "static pointer (*ftab[~d])();~%~%" ftab-next)))
+ (maybe-format hfile "static pointer (*ftab[~d])();~%~%" ftab-next)))
(:ftab-initializer ()
- (format cfile "static void init_ftab()~%{")
+ (maybe-format cfile "static void init_ftab()~%{")
(when (> ftab-next 0)
- (format cfile " register int i;~%")
- (format cfile " for (i=0; i<~d; i++) ftab[i]=fcallx;~%" ftab-next))
- (format cfile "}~%")
+ (maybe-format cfile " register int i;~%")
+ (maybe-format cfile " for (i=0; i<~d; i++) ftab[i]=fcallx;~%" ftab-next))
+ (maybe-format cfile "}~%")
+ (send self :clear-external-functions))
+ (:clear-external-functions ()
(dolist (ef external-functions)
(remprop ef :ftab-index)) )
(:close ()
diff --git a/lisp/image/jpeg/eusjpeg.l b/lisp/image/jpeg/eusjpeg.l
index 5c3b2fe08..22df92094 100644
--- a/lisp/image/jpeg/eusjpeg.l
+++ b/lisp/image/jpeg/eusjpeg.l
@@ -30,7 +30,7 @@
)
(setq rgb-image (send rgb-image :to24))
(if (not (derivedp rgb-image color-image24))
- (error "jpeg-compress expected 24-bit color-image, but ~s~%"
+ (error value-error "jpeg-compress expected 24-bit color-image, but ~s~%"
rgb-image))
;; We cannot predict exact size of the compressed file.
;; So, prepare a buffer for no compression.
diff --git a/lisp/image/pbmfile.l b/lisp/image/pbmfile.l
index e540685c6..7fb2811ef 100644
--- a/lisp/image/pbmfile.l
+++ b/lisp/image/pbmfile.l
@@ -57,10 +57,10 @@
(maxval (read-pbm-token f eof))
(size (* width height)) )
(if (/= maxval 255)
- (error "unknown pgm file format maxval=~A" maxval))
+ (error io-error "unknown pgm file format maxval=~A" maxval))
(dotimes (i size)
(setq token (read-pbm-token f eof))
- (if (eql token eof) (error "unexpected EOF"))
+ (if (eql token eof) (error io-error "unexpected EOF"))
(setf (char img i) token))
(setq img (instance grayscale-image :init width height img))
(send img :name (send f :fname))
@@ -72,7 +72,7 @@
(eof (cons nil nil))
(maxval (read-pbm-token f eof)) )
(if (/= maxval 255)
- (error "unknown pgm file format maxval=~A" maxval))
+ (error io-error "unknown pgm file format maxval=~A" maxval))
(setq img (make-string size))
(read-char f)
(replace img (setq img1 (send (send f :instream) :tail-string)))
@@ -83,7 +83,7 @@
(unix:uread (send f :infd) img
(- size offset)
offset))
- (if (<= read-length 0) (error "EOF hit while reading pgm file"))
+ (if (<= read-length 0) (error io-error "EOF hit while reading pgm file"))
(incf offset read-length)
; (print offset)
)
@@ -101,7 +101,7 @@
img sbuf
offset (buflen (* size 3)) rdlen)
(if (/= maxval 255)
- (error "unknown ppm file format maxval=~A" maxval))
+ (error io-error "unknown ppm file format maxval=~A" maxval))
(read-char f)
(replace rgb (setq sbuf (send (send f :instream) :tail-string)))
(setq offset (length sbuf))
@@ -122,20 +122,20 @@
(maxval (read-pbm-token f eof))
(size (* width height)) (ii) )
(if (/= maxval 255)
- (error "unknown ppm file format maxval=~A" maxval))
+ (error io-error "unknown ppm file format maxval=~A" maxval))
(dotimes (i size)
(setq ii (* i 3))
;; red
(setq token (read-pbm-token f eof))
- (if (eql token eof) (error "unexpected EOF"))
+ (if (eql token eof) (error io-error "unexpected EOF"))
(setf (char rgb ii) token)
;; green
(setq token (read-pbm-token f eof))
- (if (eql token eof) (error "unexpected EOF"))
+ (if (eql token eof) (error io-error "unexpected EOF"))
(setf (char rgb (1+ ii)) token)
;; blue
(setq token (read-pbm-token f eof))
- (if (eql token eof) (error "unexpected EOF"))
+ (if (eql token eof) (error io-error "unexpected EOF"))
(setf (char rgb (+ ii 2)) token))
(setq rgbimg (instance color-image24 :init
width height rgb))
@@ -158,13 +158,13 @@
(eof (cons nil nil))
(size) )
(unless (eql (char-upcase ch) #\P)
- (error "not a p[bgp]m file") )
+ (error io-error "not a p[bgp]m file") )
(setq ch (read-char f))
(setq width (read-pbm-token f eof)
height (read-pbm-token f eof))
(setq size (* width height))
(if (or (> size (* 4096 4096)) (< size 0))
- (error "image too big or negative"))
+ (error index-error "image too big or negative"))
(unless buf0
(case ch
((#\1 #\4) (setq buf0 (make-string (/ (+ size 7) 8))))
@@ -177,7 +177,7 @@
(#\4 (read-binary-pbm f buf0 width height))
(#\5 (read-binary-pgm f buf0 width height))
(#\6 (read-binary-ppm f buf0 width height))
- (t (error "unknown pbm magic number")))))
+ (t (error io-error "unknown pbm magic number")))))
(defun read-pnm-file (file &optional buf)
(with-open-file (f file)
diff --git a/lisp/image/piximage.l b/lisp/image/piximage.l
index ed553a84a..4a14e9aed 100644
--- a/lisp/image/piximage.l
+++ b/lisp/image/piximage.l
@@ -182,7 +182,7 @@
(cond ((= deepth 1) :bit)
((<= deepth 8) :byte)
((<= deepth 32) :integer)
- (t (error "image depth > 32 is not supported"))))))
+ (t (error value-error "image depth > 32 is not supported"))))))
(setq rank 2
displaced-index-offset 0)
(setq depth deepth dim1 w dim0 h entity imgvec)
@@ -736,7 +736,7 @@
(let ((pix (send self :pixel x y)))
(list (ldb pix 11 5) (ldb pix 5 6) (ldb pix 0 5))))
(:to16 () self)
- (:component (n) (error "component of 16bpp image is not yet implemented"))
+ (:component (n) (error value-error "component of 16bpp image is not yet implemented"))
)
(defmethod color-image24
diff --git a/lisp/l/array.l b/lisp/l/array.l
index e7bc5b7e0..fbc018509 100644
--- a/lisp/l/array.l
+++ b/lisp/l/array.l
@@ -76,7 +76,7 @@
(inc offset)
(inc increments)
(if (> increments major-dimension)
- (error "array dimension mismatch")))))
+ (error index-error "array dimension mismatch")))))
vec))
(defun make-array (dim &key (element-type vector)
@@ -99,14 +99,14 @@
(setq entity (instantiate element-type dim))
(setq a entity)
(setq dim (list dim)))
- (t
+ ((consp dim)
(setq a (instantiate array))
(let* ((i 0)
(rank (length dim))
(total-size (apply #'* dim)))
- (if (> rank 7) (error "array rank limit over"))
+ (if (> rank 7) (error program-error "array rank limit over"))
(unless (every #'integerp dim)
- (error "integer expected for array dimensions"))
+ (error type-error "integer expected for array dimensions"))
(setq entity
(cond ((vectorp displaced-to) displaced-to)
((arrayp displaced-to) (array-entity displaced-to))
@@ -120,7 +120,8 @@
(setf (array-displaced-index-offset a) displaced-index-offset)
(do ((i 0 (1+ i)))
((>= i rank))
- (setslot a array (+ i 5) (elt dim i))))))
+ (setslot a array (+ i 5) (elt dim i)))))
+ (t (error type-error "integer or list expected")))
(when initial-element (fill entity initial-element))
(when initial-contents
(fill-initial-contents entity 0 dim initial-contents))
@@ -134,7 +135,7 @@
tsize))
(defun fill-pointer (a)
- (if (arrayp a) (a . fill-pointer) (error "not an array")) )
+ (if (arrayp a) (a . fill-pointer) (error type-error "array expected")) )
(defun array-rank (a) (a . rank))
(defun array-dimensions (a)
@@ -148,7 +149,7 @@
(defun array-vector (a)
(cond ((vectorp a) a)
((arrayp a) (array-entity a))
- (t (error "not array"))))
+ (t (error type-error "array expected"))))
(defun row-major-aref (a index)
(aref (array-entity a) index))
diff --git a/lisp/l/async.l b/lisp/l/async.l
index 3130bb705..a3be90ab3 100644
--- a/lisp/l/async.l
+++ b/lisp/l/async.l
@@ -58,7 +58,7 @@
(:lock-slots ()
(if (not (eql (unix:thr-self) main-thread))
- (error "not the main thread"))
+ (error program-error "not the main thread"))
(sys:mutex-lock lock-of-slots)
(when (sys:mutex-trylock entrance-lock)
(dolist (thr sub-threads)
@@ -67,7 +67,7 @@
(:unlock-slots ()
(if (not (eql (unix:thr-self) main-thread))
- (error "not the main thread"))
+ (error program-error "not the main thread"))
(sys:mutex-lock lock-of-slots)
(dolist (thr sub-threads)
(unix:thr-continue thr))
@@ -77,7 +77,7 @@
(defmacro def-async-method (class-name &rest methods)
(let ((class (symbol-value class-name)))
(if (not (subclassp class asynchronous-object))
- (error "not a class of asynchronous object"))
+ (error type-error "not a class of asynchronous object"))
(dolist (method methods)
(send-msg class :add-async-method (car method)))
`(defmethod ,class-name
diff --git a/lisp/l/common.l b/lisp/l/common.l
index 4c2c22520..902e9254f 100644
--- a/lisp/l/common.l
+++ b/lisp/l/common.l
@@ -22,11 +22,14 @@
case classcase otherwise
string alias
caaar caadr cadar cdaar cdadr cddar cdddr
- fourth fifth sixth seventh eighth
- cadddr cddddr cadddr caaddr cdaddr caddddr
+ fourth fifth sixth seventh eighth ninth tenth
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr caddddr
flatten list-insert list-delete adjoin union intersection
set-difference set-exclusive-or rotate-list last copy-tree
- copy-list nreconc rassoc acons member assoc subsetp maplist mapcon))
+ supermember superassoc
+ copy-list nreconc acons member assoc assoc-if assoc-if-not
+ rassoc rassoc-if rassoc-if-not subsetp maplist mapcon))
(export '(find find-if find-if-not position position-if position-if-not
count count-if count-if-not member-if member-if-not
@@ -69,7 +72,6 @@
(cadr lisp-implementation-version)
(caddr lisp-implementation-version)
))
-(setq euserror nil)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic macros
@@ -122,7 +124,7 @@
(list 'setf var h))
(defmacro defvar (var &optional (init nil) (doc nil))
- (unless (symbolp var) (error 20))
+ (unless (symbolp var) (error type-error "symbol expected"))
`(when (eql (send ',var :vtype) 1)
(send ',var :vtype 2)
(if (not (boundp ',var))
@@ -130,17 +132,17 @@
',var))
(defmacro deflocal (var &optional (init nil) (doc nil))
- (unless (symbolp var) (error 20))
+ (unless (symbolp var) (error type-error "symbol expected"))
`(progn
(send ',var :special ,init ,doc)
',var))
(defmacro defparameter (var init &optional (doc nil))
- (unless (symbolp var) (error 20))
+ (unless (symbolp var) (error type-error "symbol expected"))
`(send ',var :global ,init ,doc))
(defmacro defconstant (sym val &optional doc)
- (unless (symbolp sym) (error 20))
+ (unless (symbolp sym) (error type-error "symbol expected"))
`(send ',sym :constant ,val ,doc) )
@@ -148,10 +150,11 @@
(let ((endvar (gensym "DOTIMES")))
`(let ((,(car vars) 0) (,endvar ,(cadr vars)))
(declare (integer ,(car vars) ,endvar))
- (while (< ,(car vars) ,endvar)
+ (or
+ (while (< ,(car vars) ,endvar)
,@forms
(setq ,(car vars) (1+ ,(car vars))))
- ,(caddr vars))))
+ ,(caddr vars)))))
(defmacro dolist (vars &rest forms)
(let ((lists (gensym "DOLIST")) (decl (car forms)))
@@ -160,10 +163,11 @@
(setq decl nil))
`(let ((,(car vars) nil) (,lists ,(cadr vars)))
,decl
- (while ,lists
+ (or
+ (while ,lists
(setq ,(car vars) (pop ,lists))
,@forms)
- ,(caddr vars))))
+ ,(caddr vars)))))
(defmacro do-symbols (vars &rest forms)
(let* ((symbols (gensym "DOSYM"))
@@ -179,11 +183,12 @@
(,i 0)
(,svec (,pkgv . intsymvector))
(,size (length ,svec)))
- (while (< ,i ,size)
+ (or
+ (while (< ,i ,size)
(setq ,v (elt ,svec ,i))
(inc ,i)
(when (symbolp ,v) . ,forms))
- ,(caddr vars))))
+ ,(caddr vars)))))
(defmacro do-external-symbols (vars &rest forms)
(let* ((symbols (gensym "DOEXTSYM"))
@@ -199,11 +204,12 @@
(,i 0)
(,svec (,pkgv . symvector))
(,size (length ,svec)))
- (while (< ,i ,size)
+ (or
+ (while (< ,i ,size)
(setq ,v (elt ,svec ,i))
(inc ,i)
(when (symbolp ,v) . ,forms))
- ,(caddr vars))))
+ ,(caddr vars)))))
(defmacro do-all-symbols (var &rest forms)
(let ((apackage (gensym "DOALLSYM")))
@@ -230,14 +236,17 @@
`(block nil
(let
,(mapcar
- #'(lambda (v) (list (car v) (cadr v)))
+ #'(lambda (v) (if (consp v)
+ (list (car v) (cadr v))
+ v))
vars)
,decl
(tagbody
,tag
(if ,(car endtest) (return (progn . ,(cdr endtest))))
,@body
- (psetq . ,(mapcan #'(lambda (v) (if (cddr v) (list (car v) (caddr v))))
+ (psetq . ,(mapcan #'(lambda (v) (if (and (consp v) (cddr v))
+ (list (car v) (caddr v))))
vars))
(go ,tag))) )))
@@ -249,14 +258,17 @@
`(block nil
(let*
,(mapcar
- #'(lambda (v) (list (car v) (cadr v)))
+ #'(lambda (v) (if (consp v)
+ (list (car v) (cadr v))
+ v))
vars)
,decl
(tagbody
,tag
(if ,(car endtest) (return (progn . ,(cdr endtest))))
,@body
- (setq . ,(mapcan #'(lambda (v) (if (cddr v) (list (car v) (caddr v))))
+ (setq . ,(mapcan #'(lambda (v) (if (and (consp v) (cddr v))
+ (list (car v) (caddr v))))
vars))
(go ,tag))) )))
@@ -320,17 +332,19 @@
;; string
(defun string (x)
- (if (stringp x) x
- (if (symbolp x) (copy-seq (x . pname))
- (if (numberp x) (format nil "~d" x)
- (error x)))))
+ (cond ((stringp x) x)
+ ((symbolp x) (copy-seq (symbol-pname x)))
+ ((numberp x) (princ-to-string x))
+ (t (error type-error "cannot coerce to string ~a" x))))
;
; more list functions
;
(eval-when (load eval)
- (defun alias (new old) (setslot new symbol 'function
- (symbol-function old)))
+ (defun alias (new old)
+ (prog1 (setslot new symbol 'function
+ (symbol-function old))
+ (putprop new old 'compiler::function-alias)))
(alias 'list-length 'length)
(alias 'values 'list)
)
@@ -346,19 +360,31 @@
(alias 'first 'car)
(alias 'second 'cadr)
(alias 'third 'caddr)
-(defun fourth (x) (cadr (cddr x)))
-(defun fifth (x) (caddr (cddr x)))
-(defun sixth (x) (caddr (cdddr x)))
-(defun seventh (x) (caddr (cddddr x)))
+(defun fourth (x) (cadr (cddr x)))
+(defun fifth (x) (caddr (cddr x)))
+(defun sixth (x) (caddr (cdddr x)))
+(defun seventh (x) (caddr (cddddr x)))
(defun eighth (x) (cadddr (cddddr x)))
-#|
-(defun cadddr (x) (car (cdddr x)))
-|#
-(defun cddddr (x) (cddr (cddr x)))
-(defun cadddr (x) (cadr (cddr x)))
+(defun ninth (x) (car (cddddr (cddddr x))))
+(defun tenth (x) (cadr (cddddr (cddddr x))))
+(defun caaaar (x) (caar (caar x)))
+(defun caaadr (x) (caar (cadr x)))
+(defun caadar (x) (caar (cdar x)))
(defun caaddr (x) (caar (cddr x)))
+(defun cadaar (x) (cadr (caar x)))
+(defun cadadr (x) (cadr (cadr x)))
+(defun caddar (x) (cadr (cdar x)))
+(defun cadddr (x) (cadr (cddr x)))
+(defun cdaaar (x) (cdar (caar x)))
+(defun cdaadr (x) (cdar (cadr x)))
+(defun cdadar (x) (cdar (cdar x)))
(defun cdaddr (x) (cdar (cddr x)))
+(defun cddaar (x) (cddr (caar x)))
+(defun cddadr (x) (cddr (cadr x)))
+(defun cdddar (x) (cddr (cdar x)))
+(defun cddddr (x) (cddr (cddr x)))
(defun caddddr (x) (cadr (cdddr x)))
+
(defun flatten (l &optional accumulator)
(cond
((null l) accumulator)
@@ -371,15 +397,21 @@
if pos is bigger than the length of list, item is nconc'ed at the tail"
(cond ((null list) (list item))
((>= pos (length list)) (nconc list (list item)))
- ((= pos 0) (cons item list))
+ ((= pos 0)
+ (rplacd list (cons (car list) (cdr list)))
+ (rplaca list item))
(t (let ((tail (cons item (nthcdr pos list))))
(rplacd (nthcdr (1- pos) list) tail)
list))))
(defun list-delete (lst n) "(lst n) delete nth element of lst"
- (if (= n 0)
- (setq lst (cdr lst))
- (rplacd (nthcdr (1- n) lst) (nthcdr (1+ n) lst)) )
+ (cond ((null lst) nil)
+ ((>= n (length lst)) nil)
+ ((= n 0)
+ (rplaca lst (cadr lst))
+ (rplacd lst (cddr lst)))
+ (t
+ (rplacd (nthcdr (1- n) lst) (nthcdr (1+ n) lst))))
lst)
(defun adjoin (item list &key (test #'eq) (test-not) (key #'identity))
@@ -429,21 +461,34 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
(push l2 result2)))
(nconc result1 result2)))
+(alias 'supermember 'system::raw-member)
+(alias 'superassoc 'system::raw-assoc)
+
(defun rotate-list (l) (append (cdr l) (list (car l))))
-(defun last (x)
- (while (consp (cdr x)) (setq x (cdr x)))
- x)
+(defun last (x &optional (n 1))
+ (unless (and (integerp n) (>= n 0))
+ (error value-error "last &optional n must be a non negative integer"))
+ (nthcdr (max (- (length x) n) 0) x))
(defun copy-tree (x) (subst t t x))
(defun copy-list (x) (nreverse (reverse x)))
(defun nreconc (x y) (nconc (nreverse x) y))
-(defun rassoc (item alist)
- (dolist (a alist)
- (if (equal item (cdr a)) (return-from rassoc a))))
(defun acons (key datum alist) (cons (cons key datum) alist))
(defun member (item list &key key test test-not)
- (supermember item list key test test-not))
+ (system::raw-member item list key test test-not))
(defun assoc (item alist &key key test test-not)
- (superassoc item alist key test test-not))
+ (system::raw-assoc item alist key test test-not nil nil nil))
+(defun assoc-if (pred alist &key key)
+ (system::raw-assoc nil alist key nil nil nil pred nil))
+(defun assoc-if-not (pred alist &key key)
+ (system::raw-assoc nil alist key nil nil nil nil pred))
+(defun rassoc (item alist &key key (test #'equal) test-not)
+ ;; in common lisp the default test is #'eq, but in euslisp
+ ;; we are using #'equal for backward compability (jsk_recognition/2735)
+ (system::raw-assoc item alist key test test-not t nil nil))
+(defun rassoc-if (pred alist &key key)
+ (system::raw-assoc nil alist key nil nil t pred nil))
+(defun rassoc-if-not (pred alist &key key)
+ (system::raw-assoc nil alist key nil nil t nil pred))
(defun subsetp (sub super &key key test test-not)
(every #'(lambda (s) (member s super :key key :test test :test-not test-not))
sub))
@@ -536,7 +581,7 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
(defun make-list (leng &key initial-element)
(let (r)
- (unless (integerp leng) (error "integer required for length of make-list"))
+ (unless (integerp leng) (error type-error "integer required for length of make-list"))
(dotimes (i leng r)
(push initial-element r))))
@@ -758,7 +803,7 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
(dolist (v varlist)
(cond ((consp v)
(if (member (car v) variables)
- (error "duplicated object variable name"))
+ (error name-error "duplicated object variable name"))
(push (car v) variables)
(setq p (position :type v))
(push (if p (elt v (1+ p)) t) types)
@@ -766,11 +811,11 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
(push (if p (elt v (1+ p)) nil) forwards))
((symbolp v)
(if (member v variables)
- (error "duplicated object variable name"))
+ (error name-error "duplicated object variable name"))
(push v variables)
(push t types)
(push nil forwards))
- (t (error "variable name expected for :slots"))))
+ (t (error name-error "variable name expected for :slots"))))
(setq variables (coerce (nreverse variables) vector)
types (coerce (nreverse types) vector)
forwards (coerce (nreverse forwards) vector))
@@ -845,7 +890,7 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
(readtable-macro to) (instantiate vector 256)
(readtable-dispatch-macro to) (instantiate vector 256)))
(if (or (null (readtablep from)) (null (readtablep to)))
- (error "readtable expected"))
+ (error type-error "readtable expected"))
(replace (readtable-syntax to) (readtable-syntax from))
(replace (readtable-macro to) (readtable-macro from))
(replace (readtable-dispatch-macro to) (readtable-dispatch-macro from))
@@ -870,11 +915,9 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
;;
(eval-when (load eval)
(defun keywordp (sym)
- (declare (type symbol sym))
(and (symbolp sym) (eq (sym . homepkg) *keyword-package*)))
(defun constantp (obj)
- (declare (type symbol obj))
(if (symbolp obj)
(if (or (keywordp obj) (eq (obj . vtype) 0)) t nil)
(if (listp obj)
@@ -894,11 +937,9 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
(defun vector-class-p (p) (derivedp p vectorclass))
(defun compiled-function-p (x) (derivedp x compiled-code))
(defun input-stream-p (obj)
- (declare (stream obj))
(or (and (derivedp obj stream) (eq (obj . direction) :input))
(derivedp obj io-stream)))
(defun output-stream-p (obj)
- (declare (stream obj))
(or (and (derivedp obj stream) (eq (obj . direction) :output))
(derivedp obj io-stream)))
(defun io-stream-p (obj) (derivedp obj io-stream))
@@ -949,15 +990,15 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
(eval-when (load eval)
(defun reduce (func seq &key (start 0) (end (length seq))
- from-end initial-value)
+ from-end (initial-value nil initial-value-p))
(let ((length (- end start)))
(when from-end (setq seq (reverse seq)))
(cond
- ((and (= length 1) (null initial-value)) (elt seq start))
+ ((and (= length 1) (null initial-value-p)) (elt seq start))
((= length 0)
- (if initial-value initial-value (funcall func)))
+ (if initial-value-p initial-value (funcall func)))
(t
- (unless initial-value
+ (unless initial-value-p
(setq initial-value
(funcall func (elt seq start) (elt seq (inc start))))
(dec length 2) (inc start))
@@ -1042,15 +1083,15 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
(putprop ',access-fn
,(when (not (endp (cdr rest)))
(unless (stringp (cadr rest))
- (error "A doc-string expected."))
+ (error type-error "doc-string expected"))
(unless (endp (cddr rest))
- (error "Extra arguments."))
+ (error argument-error "extra arguments"))
(cadr rest))
'setf-documentation)
',access-fn))
(t
(unless (= (list-length (cadr rest)) 1)
- (error "(store-variable) expected."))
+ (error value-error "(store-variable) expected."))
`(progn (putprop ',access-fn ',rest 'setf-lambda)
(remprop ',access-fn 'setf-update-fn)
(remprop ',access-fn 'setf-method)
@@ -1092,11 +1133,11 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
newvalue (cdr place)))
; ((get (car place) 'setf-method)
; (apply (get (car form) 'setf-method) (cdr place)))
- (t (error "SETF?")))))
+ (t (error value-error "SETF?")))))
(defun setf-expand (l)
(cond ((endp l) nil)
- ((endp (cdr l)) (error "~S is an illegal SETF form." l))
+ ((endp (cdr l)) (error argument-error "~S is an illegal SETF form." l))
(t
(cons (setf-expand-1 (car l) (cadr l))
(setf-expand (cddr l))))))
@@ -1105,7 +1146,7 @@ if pos is bigger than the length of list, item is nconc'ed at the tail"
;;; SETF macro.
(defmacro setf (&rest rest)
(cond ((endp rest) nil)
- ((endp (cdr rest)) (error "~S is an illegal SETF form." rest))
+ ((endp (cdr rest)) (error argument-error "~S is an illegal SETF form." rest))
((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest)))
(t (cons 'progn (setf-expand rest)))))
diff --git a/lisp/l/compfiles.l b/lisp/l/compfiles.l
index 6cb8b337f..d60fac743 100644
--- a/lisp/l/compfiles.l
+++ b/lisp/l/compfiles.l
@@ -10,6 +10,7 @@
(compile-file "hashtab.l" :cc nil)
(compile-file "array.l" :cc nil)
(compile-file "extnum.l" :cc nil)
+(compile-file "conditions.l" :cc nil)
(compile-file "mathtran.l" :cc nil)
(compile-file "eusdebug.l" :cc nil)
(in-package "GEO")
diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l
new file mode 100644
index 000000000..ba1ec6fc3
--- /dev/null
+++ b/lisp/l/conditions.l
@@ -0,0 +1,279 @@
+(eval-when (load eval)
+
+(in-package "LISP")
+
+(export '(defcondition install-handler remove-handler invoke-next-handler signals
+ eussig *signal-handlers*
+ assertion-error euserror sigint-handler interruption handler-bind handler-case))
+
+(deflocal *condition-handler*)
+(defvar *current-condition-handler*)
+
+(defmethod condition
+ (:init (&rest init-args &key message &allow-other-keys)
+ ;; Initialize slots
+ (do* ((key (pop init-args) (pop init-args))
+ (val (pop init-args) (pop init-args)))
+ ((null key))
+ (send self :set-val (symbol-pname key) val))
+ self)
+ (:message (&optional (val nil supplied-p)) (if supplied-p (setq message val) message)))
+
+(defmethod error
+ (:init (&rest init-args &key (message "") (callstack (sys:list-callstack)) &allow-other-keys)
+ (send-super* :init :message message :callstack callstack init-args))
+ (:callstack (&optional val) (if val (setq callstack val) callstack))
+ (:form (&optional val) (if val (setq form val) form)))
+
+(defclass condition-handler :slots (fn) :super propertied-object)
+(defmethod condition-handler
+ (:init (fn)
+ (unless (functionp fn) (error type-error "function expected"))
+ ;; set slots
+ (setq (self . fn) fn)
+ ;; set name
+ (let ((name
+ (cond
+ ((symbolp fn) fn)
+ ((compiled-function-p fn) (get fn :name))
+ ((listp fn) (second fn)))))
+ (if name (setf (get self :name) name)))
+ self)
+ (:function (&optional val) (if val (setq fn val) fn)))
+
+(defmacro defcondition (name &key slots (super 'condition))
+ `(progn
+ (defclass ,name :slots ,slots :super ,super)
+ ,(if slots
+ `(defmethod ,name
+ ,@(mapcar
+ #'(lambda (s)
+ `(,(intern (send s :pname) *keyword-package*) (&optional (val nil supplied-p))
+ (if supplied-p (setq (self . ,s) val) (self . ,s))))
+ slots)))
+ ',name))
+
+(defun install-handler-raw (label handler)
+ ;; ensure condition class
+ (if (eq label t) (setq label condition))
+ (unless (and (classp label) (derivedp (instantiate label) condition))
+ (error type-error "condition class expected"))
+ (push (cons label (instance condition-handler :init handler))
+ *condition-handler*)
+ t)
+
+(defun install-handler (label handler)
+ (if (eq label t) (setq label condition))
+ (unless (and (classp label) (derivedp (instantiate label) condition))
+ (error type-error "condition class expected"))
+ ;; recursively force registration on all previous scopes
+ (let ((handler-list
+ (remove-if-not #'(lambda (val) (eql val '*condition-handler*))
+ (sys:list-all-special-bindings)
+ :key #'car))
+ (item
+ (cons label (instance condition-handler :init handler))))
+ (when handler-list
+ (dolist (val handler-list)
+ (list-insert item 0 (cdr val))))
+ (push item *condition-handler*))
+ t)
+
+(defun install-error-handler (handler)
+ (warning-message 1
+ ";; `lisp::install-error-handler' is obsolete. Try to use `install-handler' instead.~%")
+ (install-handler error
+ #'(lambda (err)
+ (when (send err :callstack)
+ (print-callstack (send err :callstack) *max-callstack-depth*))
+ (funcall handler 0 (send err :message) (send err :form)))))
+
+(defun remove-handler (label &optional handler)
+ (let* ((handler-special
+ ;; recursively force deletion on all previous scopes
+ ;; start with oldest scope
+ (reverse
+ (remove-if-not #'(lambda (val) (eql val '*condition-handler*))
+ (sys:list-all-special-bindings)
+ :key #'car)))
+ (handler-list
+ (append (mapcar #'cdr handler-special) (list *condition-handler*)))
+ (global-handler
+ (car handler-list))
+ (pos
+ (if handler
+ (position-if #'(lambda (val) (and (eql (car val) label)
+ (derivedp (cdr val) condition-handler)
+ (eql (send (cdr val) :function) handler)))
+ global-handler)
+ (position label global-handler :key #'car))))
+ (when pos
+ (let ((item (nth pos global-handler))
+ res)
+ (dolist (val handler-list)
+ (let ((local-pos
+ (position item val :test #'eq)))
+ (when local-pos
+ (list-delete val local-pos)
+ (setq res t))))
+ ;; return the deletion result of the innnermost scope (i.e. local scope)
+ res))))
+
+(defmacro handler-bind (bindings &rest forms)
+ `(let ((*condition-handler* (copy-list *condition-handler*)))
+ ,@(mapcar #'(lambda (bind) `(install-handler-raw ,@bind)) bindings)
+ ,@forms))
+
+(defmacro handler-case (form &rest cases)
+ (let ((handler-frame (gensym "HANDLER-CASE-")))
+ (flet ((expand-case (tag arglst &rest body)
+ (unless (or (null arglst) (and (consp arglst) (null (cdr arglst))))
+ (error argument-error "expected single parameter list"))
+ `(,tag #'(lambda ,(if arglst arglst (list (gensym)))
+ ;; ignore?
+ (throw ',handler-frame
+ (progn ,@body))))))
+ `(catch ',handler-frame
+ (handler-bind
+ ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) (reverse cases))
+ ,form)))))
+
+(defmacro atomic (form &rest cases)
+ (flet ((expand-case (place index tag arglst &rest body)
+ (unless (or (null arglst) (and (consp arglst) (null (cdr arglst))))
+ (error argument-error "expected single parameter list"))
+ (if (null arglst) (setq arglst (list (gensym))))
+ `(,tag #'(lambda ,arglst
+ (setf (elt ,place ,index) ,(car arglst))
+ ,@body))))
+ (let ((holder (gensym))
+ (i (length cases)))
+ `(let ((,holder (make-list ,(length cases) :initial-element nil)))
+ (prog1
+ (handler-bind
+ ,(mapcar #'(lambda (cs) (apply #'expand-case holder (decf i) cs))
+ (reverse cases))
+ ,form)
+ (mapc #'signals (remove nil ,holder)))))))
+
+(defun invoke-next-handler (obj)
+ (unless (derivedp obj condition)
+ (error type-error "condition class expected"))
+ (when (null *current-condition-handler*)
+ ;; no active handler; use signals instead
+ (return-from invoke-next-handler (signals obj)))
+ (dolist (handle *current-condition-handler*)
+ (when (derivedp obj (car handle))
+ ;; call handler
+ (let ((*current-condition-handler*
+ (remove handle *current-condition-handler* :test #'equal :count 1)))
+ (return-from invoke-next-handler (funcall (send (cdr handle) :function) obj))))))
+
+(defun signals (obj &rest init-args)
+ (when (classp obj)
+ (setq obj (instantiate obj))
+ (send* obj :init init-args))
+ ;; init-args is not used if instantiated objects are given
+ (unless (derivedp obj condition) (error type-error "condition class expected"))
+ (dolist (handle *condition-handler*)
+ (when (derivedp obj (car handle))
+ ;; call handler
+ (let ((*current-condition-handler*
+ (if *current-condition-handler*
+ (remove handle *current-condition-handler* :test #'equal :count 1)
+ (remove handle (copy-list *condition-handler*) :test #'equal :count 1))))
+ (return-from signals (funcall (send (cdr handle) :function) obj))))))
+
+(defun print-callstack (&optional (stack (sys:list-callstack)) max (os *error-output*))
+ (let ((tms (if max
+ (min max (length stack))
+ (length stack))))
+ (when (plusp tms)
+ (format os "Call Stack~A:~%" (if max (format nil " (max depth ~A)" max) ""))
+ (dotimes (i tms)
+ (format os "~3D: at ~S~%" i (nth i stack))))))
+
+(defun print-error-message (err &optional (os *error-output*))
+ (unless (derivedp err condition) (error type-error "condition class expected"))
+ (when (send err :message)
+ (format os "~C[1;3~Cm~A~C[0m: ~A"
+ #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (send err :message))
+ (if (and (derivedp err error) (send err :form))
+ (format os " in ~S" (send err :form)))
+ (terpri os)))
+
+
+;;;
+;;; assertion error
+;;;
+
+(defcondition assertion-error :super error)
+
+
+;;;
+;;; error handling
+;;;
+
+(defun euserror (err)
+ (when (send err :callstack)
+ (print-callstack (send err :callstack) *max-callstack-depth*))
+ (print-error-message err)
+ (if (not (zerop (unix:thr-self)))
+ (throw 0 nil))
+ (let ((*replevel* (1+ *replevel*))
+ (*reptype* "E"))
+ (while (catch *replevel* (reploop #'toplevel-prompt))))
+ (throw *replevel* t))
+
+
+;;;
+;;; unix:signal handling
+;;;
+
+(defcondition unix::signal-received :slots (sig code))
+(defmacro unix::install-signal-handler (sig obj &rest init-args)
+ `(progn
+ (defcondition ,obj :super unix::signal-received)
+ (unix:signal ,sig
+ #'(lambda (sig code) (signals ,obj :sig sig :code code ,@init-args)))))
+
+(defmacro unix::with-alarm-interrupt (&rest body)
+ (let ((interval (gensym)) (value (gensym)))
+ `(multiple-value-bind ,(list interval value) (unix:setitimer 0 0 0)
+ ,@body
+ (unix:setitimer 0 ,value ,interval))))
+
+(defcondition interruption)
+(defun sigint-handler (c)
+ (unix::with-alarm-interrupt
+ (signals interruption :message "keyboard interrupt")))
+
+(defun interruption-handler (c)
+ (print-error-message c)
+ (let* ((*replevel* (1+ *replevel*))
+ (*reptype* "B"))
+ (while (catch *replevel* (reploop #'toplevel-prompt)))))
+
+
+;;
+;; old handlers for backward compatibility
+;;
+(defvar *signal-handlers* (make-sequence vector 32))
+
+(defun eussig (sig &rest code &aux (handler (aref *signal-handlers* sig)))
+ (cond (handler (funcall handler sig code))
+ (t
+ (if (fboundp 'unix:ualarm)
+ (unix:ualarm 0 0)
+ (unix:alarm 0))
+ (warning-message 1 "signal ~s ~s~%" sig code)
+ (let* ((*replevel* (1+ *replevel*))
+ (*reptype* "S"))
+ (catch *replevel*
+ (reploop #'toplevel-prompt))))))
+
+
+;; install handlers
+(install-handler error #'euserror)
+(install-handler interruption 'interruption-handler)
+)
diff --git a/lisp/l/constants.l b/lisp/l/constants.l
index 3166b5b1a..08fbdb04e 100644
--- a/lisp/l/constants.l
+++ b/lisp/l/constants.l
@@ -16,13 +16,14 @@
most-negative-float
least-positive-float
least-negative-float
+ char= char< char> char<= char>= char/=
quit bye
))
(export '(af_unix af_inet sock_stream sock_dgram))
;; (export '(unix eus common ieee-floating-point sparc m68020))
-(nconc *features* '(:unix :eus :common))
+(nconc *features* '(:unix :eus :common :condition :closure))
#+(or :sun :mips :linux :cygwin)
(nconc *features* '(:ieee-floating-point))
#+:sun4
@@ -94,6 +95,7 @@
(setq (tio . outstream) *standard-output*))
(send *system-package* :nicknames '("SI" "SYS"))
+(send (find-package "COMPILER") :nicknames '("COMP"))
#+:ustation
@@ -304,7 +306,7 @@
; (structure (si::putprop ,s ,v 'structure-documentation))
; (type (si::putprop ,s ,v 'type-documentation))
; (setf (si::putprop ,s ,v 'setf-documentation))
-; (t (error "~S is an illegal documentation type." ,d))))
+; (t (error value-error "~S is an illegal documentation type." ,d))))
(defsetf matrix-row (x y) (val) `(set-matrix-row ,x ,y ,val))
(defsetf matrix-column (x y) (val) `(set-matrix-column ,x ,y ,val))
@@ -337,14 +339,12 @@
(defconstant *default-readtable* (copy-readtable))
-(setf (symbol-function 'char=) (symbol-function '=))
-(setf (symbol-function 'char<) (symbol-function '<))
-(setf (symbol-function 'char>) (symbol-function '>))
-(setf (symbol-function 'char<=) (symbol-function '<=))
-(setf (symbol-function 'char>=) (symbol-function '>=))
-(setf (symbol-function 'char/=) (symbol-function '/=))
-
-(setf (symbol-function 'quit) (symbol-function 'unix::exit))
-(setf (symbol-function 'bye) (symbol-function 'unix::exit))
-
+(alias 'char= '=)
+(alias 'char< '<)
+(alias 'char> '>)
+(alias 'char<= '<=)
+(alias 'char>= '>=)
+(alias 'char/= '/=)
+(alias 'quit 'unix::exit)
+(alias 'bye 'unix::exit)
diff --git a/lisp/l/coordinates.l b/lisp/l/coordinates.l
index b1c8b5d1a..f7ec29b20 100644
--- a/lisp/l/coordinates.l
+++ b/lisp/l/coordinates.l
@@ -91,7 +91,7 @@
(send self :changed)
self))
(:move-to (c &optional (wrt :local) &aux cc)
- (unless (coordinates-p c) (error "coordinates expected for :move-to"))
+ (unless (coordinates-p c) (error type-error "coordinates expected for :move-to"))
(cond ((or (memq wrt '(:local local)) (eq wrt self))
(setq cc (transform-coords self c))
(send self :newcoords cc))
@@ -168,7 +168,7 @@
(rotate-matrix rot theta nil nil rot))
((matrixp theta)
(m* theta rot rot))
- (t (error "illegal rotation"))))
+ (t (error value-error "illegal rotation"))))
((float-vector-p axis)
(send self :rotate-with-matrix (rotation-matrix theta axis) wrt))
((null axis)
@@ -388,7 +388,7 @@
(case (send self :dimension)
(3 *world-coords*)
(2 *world-coords2*)
- (t (error "dimension?"))) ))
+ (t (error value-error "dimension?"))) ))
(:transform-vector (v)
(send (send self :worldcoords) :transform-vector v))
(:rotate-vector (v)
@@ -439,7 +439,7 @@
(t (send self :error ":transform wrt?" wrt)))
(send self :newcoords rot pos))
(:move-to (c &optional (wrt :local) &aux cc)
- (unless (coordinates-p c) (error "coordinates expected for :move-to"))
+ (unless (coordinates-p c) (error type-error "coordinates expected for :move-to"))
(cond ((or (memq wrt '(:local local)) (eq wrt self))
(setq cc (transform-coords self c))
(send self :newcoords cc))
diff --git a/lisp/l/eusdebug.l b/lisp/l/eusdebug.l
index e674b7694..166b70cd1 100644
--- a/lisp/l/eusdebug.l
+++ b/lisp/l/eusdebug.l
@@ -23,11 +23,13 @@
*remote-port*
remote-error reval *server-streams* remote-port))
-(defmacro assert (pred &optional (message "") &rest args)
- `(while (not ,pred)
- (format *error-output* ,message ,@args)
- (finish-output *error-output*)
- (reploop "ass: " )))
+(defun assert (pred &optional (message "assertion failed") &rest args)
+ (if (not pred)
+ (handler-case (apply #'error assertion-error message args)
+ (assertion-error (err)
+ ;; set pred as the new form
+ (send err :form (cadr (send err :form)))
+ (invoke-next-handler err)))))
(defun warning-message (color format &rest mesg)
(format *error-output* "~C[3~Cm" #x1b (+ color 48))
@@ -87,14 +89,13 @@
(defun apropos (strng &optional pack)
(setq strng (string strng))
(flet ((print-symbol-apropos (sym)
- (format t ";; ~S~A~A~A~%"
+ (format t ";; ~S~A~A"
sym
(if (fboundp sym)
- (if (special-form-p sym)
- " Special form"
- (if (macro-function sym)
- " Macro"
- " Function"))
+ (cond
+ ((special-form-p sym) " Special form")
+ ((macro-function sym) " Macro")
+ (t " Function"))
"")
(if (boundp sym)
(case (send sym :vtype)
@@ -102,8 +103,9 @@
(1 " Global=")
(2 " Global Special=")
(t " Thread Special="))
- "")
- (if (boundp sym) (symbol-bound-value sym) ""))))
+ ""))
+ (if (boundp sym) (format t "~S" (symbol-bound-value sym)))
+ (format t "~%")))
(cond (pack
(do-symbols (sym pack)
(when (substringp strng (string sym))
@@ -169,7 +171,7 @@
(catch *replevel* (reploop prompt) )))
(defun setbreak (func)
- (unless (fboundp func) (error "no func def. for setbreak"))
+ (unless (fboundp func) (error name-error "no func def. for setbreak"))
(when (not (get func 'broken-function))
(setf (get func 'broken-function) (symbol-function func)
(symbol-function func)
@@ -253,11 +255,13 @@
(cond ((symbolp input) (print (eval-dynamic input)))
(t
(catch 'step-error
- (let ((*error-handler*
- '(lambda (&rest x)
- (format *error-output*
- "step evaluation error ~A~%" x)
- (throw 'step-error nil))))
+ (handler-bind ((error
+ '(lambda (x)
+ (let ((errmsg (with-output-to-string (str)
+ (lisp::print-error-message x str))))
+ (format *error-output*
+ "step evaluation error ~A~%" errmsg)
+ (throw 'step-error nil)))))
(print (eval input)))))))
(t (format t ";; e?"))))
(dec *tracelevel*)
@@ -369,10 +373,10 @@
(print (elt obj command)))
(t
(catch 'inspect-eval
- (let ((*error-handler*
- '(lambda (ec form &optional msg1 msg2)
- (warn "error ~s ~s ~s" form msg1 msg2)
- (throw 'inspect-eval t))))
+ (handler-bind ((error
+ '(lambda (x)
+ (lisp::print-error-message x)
+ (throw 'inspect-eval t))))
(print (eval command)))))))))))
(defmacro inspect (obj)
@@ -406,7 +410,7 @@
(setf (get ',func :call-count) 0
(get ',func :elapsed-time) 0))))
((or (not (fboundp ',func)) (macro-function ',func))
- (error "not a function"))
+ (error type-error "function expected"))
(t
(let ((fdef (symbol-function ',func)) )
(setf (get ',func :call-count) 0
@@ -657,20 +661,19 @@ finds method-class pair which include name as substring of the method name"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *remote-port*)
-(defun remote-error (code msg1 form &optional (msg2))
- (format *error-output* "~A remote error: ~A" *program-name* msg1)
- (if msg2 (format *error-output* " ~A" msg2))
- (if form (format *error-output* " in ~s" form))
- (terpri *error-output*)
- (throw 'reval nil))
+(defun remote-error (err)
+ (let ((errmsg (with-output-to-string (str)
+ (lisp::print-error-message err str))))
+ (format *error-output* "remote error: ~A" errmsg))
+ (throw 'reval nil))
(defun reval (s) ;remote eval
(let* ((*standard-input* (send s :instream))
(*standard-output* (send s :outstream))
- (*error-output* *standard-output*)
- (*error-handler* 'remote-error))
- (catch 'reval
- (print (eval (read s)) s))))
+ (*error-output* *standard-output*))
+ (handler-bind ((error 'remote-error))
+ (catch 'reval
+ (print (eval (read s)) s)))))
(defvar *server-streams* nil)
diff --git a/lisp/l/eusforeign.l b/lisp/l/eusforeign.l
index 910790cee..07316b687 100644
--- a/lisp/l/eusforeign.l
+++ b/lisp/l/eusforeign.l
@@ -117,7 +117,7 @@
(cond ((numberp fentry))
((system::find-entry fentry fmod)
(setq fentry (system::find-entry2 fentry fmod)))
- (t (error "no such foreign entry ~s" fentry)))
+ (t (error name-error "no such foreign entry ~s" fentry)))
(instance foreign-code :init fentry param result))
;;;
@@ -405,7 +405,7 @@
)
))
#-(or :sun3 :sun4 :i386 :x86_64)
- (error "not yet implemented for this processor")
+ (error program-error "not yet implemented for this processor")
(cond
((listp func)
(if (eq (car func) 'lisp:lambda-closure)
@@ -503,7 +503,7 @@
s (cddr sl)
element_size (byte-size typespec))
(unless (keywordp typespec)
- (error "keyword expected for cstruct type"))
+ (error argument-error "keyword expected for cstruct type"))
(when (eq (car s) '*)
(setq typespec :pointer
element_size lisp::sizeof-*) ;pointer
@@ -530,16 +530,16 @@
(car slotlist)))
(:offset (id &optional index)
(let ((slot (send self :slot id)))
- (unless slot (error "no such cstruct slot ~s" id))
+ (unless slot (error name-error "no such cstruct slot ~s" id))
(cond (index
- (if (>= index (elt slot 2)) (error "index out of range"))
+ (if (>= index (elt slot 2)) (error index-error "index out of range"))
(+ (elt slot 4) (* index (elt slot 3))) )
(t (elt slot 4)))))
(:access (id &optional index)
(let ((slot (send self :slot id)) (offset))
- (unless slot (error "no such cstruct slot"))
+ (unless slot (error name-error "no such cstruct slot"))
(cond (index
- (if (>= index (elt slot 2)) (error "index out of range"))
+ (if (>= index (elt slot 2)) (error index-error "index out of range"))
(setq offset (+ (elt slot 4) (* index (elt slot 3))) ))
(t (setq offset (elt slot 4))))
(list (elt slot 1) offset)))
@@ -625,7 +625,7 @@
(+ ,offset
(* i ,element_size))
,element_type))))))
- (t (error "illegal type specifier")))
+ (t (error type-error "illegal type specifier")))
(push getter accessors)
(push setter accessors)
(push setter-fn accessors)
diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l
index e69909e04..0ed126a3c 100644
--- a/lisp/l/eusstart.l
+++ b/lisp/l/eusstart.l
@@ -42,10 +42,10 @@
;; specials.c
(export '(quote eval apply funcall progn prog1 function))
(export '(mapc mapcar mapcan setq if when cond while let let*
- unwind-protect catch throw flet labels block return-from
+ unwind-protect catch throw macrolet flet labels block return-from
return reset go tagbody evalhook macroexpand2 eval-when
the and or proclaim declare symbol-value symbol-function
- makunbound defun defmacro find-symbol intern gensym
+ makunbound fmakunbound defun defmacro find-symbol intern gensym
list-all-packages find-package
sxhash get export putprop))
;; makepackage ??
@@ -89,7 +89,7 @@
NTH NTHCDR CONS RPLACA RPLACA2 RPLACD RPLACD2
APPEND NCONC SUBST NSUBST
ATOM EQ EQL NULL NOT LIST LIST* EQUAL SUPEREQUAL
- MEMQ MEMBER SUPERMEMBER ASSQ ASSOC SUPERASSOC
+ MEMQ MEMBER ASSQ ASSOC
BUTLAST NBUTLAST SYMBOLP STRINGP LISTP CONSP
ENDP NUMBERP INTEGERP FLOATP BOUNDP FBOUNDP STREAMP))
@@ -124,6 +124,7 @@
(export '(
SIGADDSET SIGDELSET SIGPROCMASK
KILL SIGNAL #| EXIT |# GETPID
+ INSTALL-SIGNAL-HANDLER
UREAD WRITE UCLOSE
IOCTL LSEEK MALLOC FREE SOCKET BIND CONNECT LISTEN
ACCEPT SENDTO RECVFROM GETPEERNAME))
@@ -171,12 +172,13 @@
(export '( GC GCTIME RGCCOUNT RGCTIME RGCALLOCATED
*GC-MERGE* *GC-MARGIN*
- *GC-HOOK* *EXIT-HOOK*
+ *GC-HOOK* *GC-DEBUG* *EXIT-HOOK*
ALLOC NEWSTACK RECLAIM RECLAIM-TREE
OBJECT-SIZE MEMORY-REPORT CLEAR-MEMORY-REPORT
ROOM LIST-ALL-CHUNKS LIST-ALL-INSTANCES ADDRESS PEEK POKE
- LIST-ALL-REFERENCES LIST-ALL-CATCHERS LIST-ALL-BINDINGS
- LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES))
+ LIST-ALL-REFERENCES LIST-ALL-BLOCKS LIST-ALL-TAGS LIST-ALL-CATCHERS
+ LIST-ALL-BINDINGS LIST-ALL-FUNCTION-BINDINGS LIST-ALL-SPECIAL-BINDINGS
+ LIST-ALL-CLASSES LIST-CALLSTACK))
(export '*threads*)
@@ -263,10 +265,10 @@
(if (unix::isatty 0)
(defun system::exec-module-init (name &optional (file))
- (let ((func (cadr (superassoc name system::*load-entries* nil #'equal nil))))
+ (let ((func (cadr (system::raw-assoc name system::*load-entries* nil #'equal nil nil nil nil))))
(if (null func)
- (setq func (cadr (superassoc (concatenate string "___" name)
- system::*load-entries* nil #'equal nil))))
+ (setq func (cadr (system::raw-assoc (concatenate string "___" name)
+ system::*load-entries* nil #'equal nil nil nil nil))))
(cond (func
(format *error-output* ";; ~a " name)
(finish-output *error-output*)
@@ -280,10 +282,10 @@
t)
(t (format *error-output* ";; ~a-undefined " name) nil))))
(defun system::exec-module-init (name &optional (file))
- (let ((func (cadr (superassoc name system::*load-entries* nil #'equal nil))))
+ (let ((func (cadr (system::raw-assoc name system::*load-entries* nil #'equal nil nil nil nil))))
(if (null func)
- (setq func (cadr (superassoc (concatenate string "___" name)
- system::*load-entries* nil #'equal nil))))
+ (setq func (cadr (system::raw-assoc (concatenate string "___" name)
+ system::*load-entries* nil #'equal nil nil nil nil))))
(cond (func
(funcall func func)
t)
@@ -314,17 +316,16 @@
(system::exec-module-init "eusdebug" "l/eusdebug.l")
(system::exec-module-init "eusforeign" "l/eusforeign.l")
(system::exec-module-init "extnum" "l/extnum.l")
+(system::exec-module-init "conditions" "l/conditions.l")
(unless (find-package "GEOMETRY")
(make-package "GEOMETRY" :nicknames '("GEO"))
(in-package "GEOMETRY"))
(system::exec-module-init "coordinates" "l/coordinates.l")
(in-package "LISP")
-(setf (symbol-function 'get-internal-run-time)
- (symbol-function 'unix::runtime))
+(alias 'get-internal-run-time 'unix::runtime)
;; toplevel needs the compiler package
;; (format t ";;; Loading compiler modules.~%")
- (make-package "COMPILER" :nicknames '("COMP"))
;;
(system::exec-module-init "tty" "l/tty.l")
(system::exec-module-init "history" "l/history.l")
@@ -338,6 +339,7 @@
(system::exec-module-init "builtins" "comp/builtins.l")
(in-package "LISP")
(import '(comp:comfile
+ comp:compile-method
comp:compile-file
comp:compile-file-if-src-newer
sys:gc
@@ -345,9 +347,9 @@
;; unix::exit
))
)
- (export '(compile comfile compile-file compile-file-if-src-newer
+ (export '(compile compile-method comfile compile-file compile-file-if-src-newer
gc alloc runtime))
- (setf (symbol-function 'exit) (symbol-function 'unix::exit))
+ (alias 'exit 'unix::exit)
;;
;(when (substringp "P" (string-upcase (pathname-name *program-name*)))
(in-package "SYSTEM")
diff --git a/lisp/l/exports.l b/lisp/l/exports.l
index ef5a29800..981d932a4 100644
--- a/lisp/l/exports.l
+++ b/lisp/l/exports.l
@@ -39,10 +39,10 @@
;; specials.c
(export '(quote eval apply funcall progn prog1 function))
(export '(mapc mapcar mapcan setq if when cond while let let*
- unwind-protect catch throw flet labels block return-from
+ unwind-protect catch throw macrolet flet labels block return-from
return reset go tagbody evalhook macroexpand2 eval-when
the and or proclaim declare symbol-value symbol-function
- makunbound defun defmacro find-symbol intern gensym
+ makunbound fmakunbound defun defmacro find-symbol intern gensym
list-all-packages find-package
sxhash get export putprop))
;; makepackage ??
@@ -87,7 +87,7 @@
NTH NTHCDR CONS RPLACA RPLACA2 RPLACD RPLACD2
APPEND NCONC SUBST NSUBST
ATOM EQ EQL NULL NOT LIST LIST* EQUAL SUPEREQUAL
- MEMQ MEMBER SUPERMEMBER ASSQ ASSOC SUPERASSOC
+ MEMQ MEMBER ASSQ ASSOC
BUTLAST NBUTLAST SYMBOLP STRINGP LISTP CONSP
ENDP NUMBERP INTEGERP FLOATP BOUNDP FBOUNDP STREAMP))
@@ -170,8 +170,9 @@
ALLOC NEWSTACK RECLAIM RECLAIM-TREE
OBJECT-SIZE MEMORY-REPORT CLEAR-MEMORY-REPORT
ROOM LIST-ALL-CHUNKS LIST-ALL-INSTANCES ADDRESS PEEK POKE
- LIST-ALL-REFERENCES LIST-ALL-CATCHERS LIST-ALL-BINDINGS
- LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES))
+ LIST-ALL-REFERENCES LIST-ALL-BLOCKS LIST-ALL-TAGS LIST-ALL-CATCHERS
+ LIST-ALL-BINDINGS LIST-ALL-FUNCTION-BINDINGS LIST-ALL-SPECIAL-BINDINGS
+ LIST-ALL-CLASSES LIST-CALLSTACK))
#|
diff --git a/lisp/l/hashtab.l b/lisp/l/hashtab.l
index 525b9ce5d..fa3cf69e9 100644
--- a/lisp/l/hashtab.l
+++ b/lisp/l/hashtab.l
@@ -12,6 +12,7 @@
((key :type vector)
(value :type vector)
(size :type :integer)
+ (fill-count :type :integer)
(count :type :integer)
(hash-function)
(test-function)
@@ -45,11 +46,13 @@
(:enter (sym val)
(let ((entry (send self :find sym)))
(when (>= entry size) ;new entry?
- (when (> count (/ size rehash-size))
+ (when (> fill-count (/ size rehash-size))
(send self :extend)
(setq entry (send self :find sym)) )
+ (setq entry (- entry size))
(inc count)
- (setq entry (- entry size)))
+ (if (eq (svref key entry) empty)
+ (inc fill-count)))
(svset key entry sym)
(svset value entry val)
val))
@@ -74,6 +77,7 @@
x size
size altsize
altsize x
+ fill-count 0
count 0)
(dotimes (i altsize)
(setq x (svref altkey i))
@@ -118,6 +122,8 @@
(dotimes (i size)
(setf (aref key i) empty
(aref value i) nil))
+ (setq count 0)
+ (setq fill-count 0)
self)
(:prin1 (&optional (strm t) &rest mesgs)
(send-super* :prin1 strm
@@ -133,6 +139,7 @@
empty (gensym "EMPTY")
deleted (gensym "DEL")
not-found nofound
+ fill-count 0
count 0
rehash-size rehash)
(dotimes (i s) (svset key i empty))
@@ -225,7 +232,7 @@
(:dequeue (&optional (error-p nil))
(cond ((null car)
(if error-p
- (error "nothing queued ~s" self)
+ (error value-error "nothing queued ~s" self)
nil))
((eq car cdr) ;last element
(prog1 (car car) (setq car nil cdr nil)))
diff --git a/lisp/l/loader.l b/lisp/l/loader.l
index dbf9a055a..bb3697497 100644
--- a/lisp/l/loader.l
+++ b/lisp/l/loader.l
@@ -63,22 +63,22 @@
(setq mode (+ mode unix::O_CREAT unix::O_TRUNC)))
(:overwrite (inc mode unix::O_CREAT))
((nil :error)(setq mode (+ mode unix::O_CREAT unix::O_EXCL)))
- (t (error "unknown if-exist flag")))
+ (t (error value-error "unknown if-exist flag")))
(case if-does-not-exist
(:error (setq mode (logand mode (lognot unix::O_CREAT))))
(:create (setq mode (logior mode unix::O_CREAT)))
(default (if (not (memq if-exists '(:overwrite :append)))
(setq mode (logior mode unix::O_CREAT))))
(nil)
- (t (error "unknown if-does-not-exist flag")))
+ (t (error value-error "unknown if-does-not-exist flag")))
(setq strm (sys::openfile fname mode permission buffer-size)) )
- (t (error "unknown stream direction")) )
+ (t (error value-error "unknown stream direction")) )
; (format t "mode=~d permission=~d buffer-size=~d~%"
; mode permission buffer-size)
(when (numberp strm)
(if (null if-does-not-exist)
(return-from open nil)
- (error (concatenate string "cannot open " fname))))
+ (error io-error "cannot open ~A" fname)))
strm ) ) )
(eval-when (load eval)
@@ -261,7 +261,7 @@
(if (and (pathname-directory fname)
(eql (first (pathname-directory fname)) :root))
(if (null (setq load-result (try-load fname)))
- (error "file ~s not found" fname)
+ (error io-error "file ~s not found" fname)
load-result)
(progn
(dolist (p (union *loader-current-directory* *load-path*
@@ -269,7 +269,7 @@
(setq path (concatenate-pathnames p fname))
(setq load-result (try-load path))
(if load-result (return-from load load-result)))
- (error "file ~s not found" fname))) )) )
+ (error io-error "file ~s not found" fname))) )) )
(defun load-files (&rest files)
(dolist (f files) (load f :verbose t))
@@ -312,7 +312,7 @@
(setq size2
(unix:uread (send f :infd) buf size))
(if (/= size size2)
- (error "cannot read binary file"))
+ (error io-error "cannot read binary file"))
)
buf))
@@ -408,7 +408,7 @@
(setq f (namestring f))
(if (probe-file f)
(elt (unix:stat (namestring f)) 7)
- (error "file ~s not found" f)
+ (error io-error "file ~s not found" f)
))
(defun directory-p (f &aux stat)
diff --git a/lisp/l/mathtran.l b/lisp/l/mathtran.l
index 2dd7308d2..32b20beb0 100644
--- a/lisp/l/mathtran.l
+++ b/lisp/l/mathtran.l
@@ -29,7 +29,7 @@
(cond
((consp sy)
(multiple-value-setq (sy form) (expr sy))
- (if form (error "illegal math expression for % macro"))
+ (if form (error io-error "illegal math expression for % macro"))
(values sy exp))
((consp (first exp)) ;function call or array ref.
(setf arglist (pop exp))
@@ -115,7 +115,7 @@
`(let* ,letpairs . ,exp)
(first exp)))))
(multiple-value-setq (result exp) (rel-expr exp))
- (if exp (error "illegal expression in % macro"))
+ (if exp (error io-error "illegal expression in % macro"))
(reconstruct-form result) ))
(defun infix2prefix (file &optional char)
diff --git a/lisp/l/object.l b/lisp/l/object.l
index 928c199d3..d76fba017 100644
--- a/lisp/l/object.l
+++ b/lisp/l/object.l
@@ -20,7 +20,7 @@
self)
(:warning (format &rest mesgs)
(apply #'warn format mesgs))
- (:error (&rest mesgs) (send* self :warning mesgs) (reploop "err: "))
+ (:error (&rest mesgs) (apply #'error mesgs))
(:slots ()
(let ((vars (metaclass-vars (class self))) (slots nil))
(dotimes (i (length vars))
diff --git a/lisp/l/packsym.l b/lisp/l/packsym.l
index 7ed3cc73c..123936c15 100644
--- a/lisp/l/packsym.l
+++ b/lisp/l/packsym.l
@@ -25,23 +25,18 @@
(:pname () pname)
(:func () function)
(:value (val)
- (if (= vtype 0) (error 11 self))
+ (if (= vtype 0) (error type-error "attempted to set constant ~a" self))
(setq value val))
(:constant (c &optional (doc nil))
- (when (= vtype 0)
- (eval-when (eval load)
- (format *error-output*
- "multiple defconstant for ~s: ~s --> ~s~%" self value c))
- (eval-when (compile)
- (unless (equal value c)
- (format *error-output*
- "multiple defconstant for ~s: ~s --> ~s~%" self value c))))
+ (when (and (= vtype 0) (not (equal value c)))
+ (format *error-output*
+ "multiple defconstant for ~s: ~s --> ~s~%" self value c))
(if doc (putprop self doc :variable-documentation))
(setq vtype 0
value c)
self)
(:special (v &optional (doc nil)) ;thread local special var
- (if (= vtype 0) (error 11 self))
+ (if (= vtype 0) (error type-error "attempted to set constant ~a" self))
(if doc (putprop self doc :variable-documentation))
(setq vtype (system::next-special-index)) ; originally, 2
(set self v) ;(setq value v) is wrong
@@ -67,12 +62,12 @@
(defun symbol-plist (sym) (send sym :plist))
(defun remprop (sym attr) (send sym :remprop attr))
;(defun set (var val)
-; (if (symbolp var) (send var :value val) (error 11 var)))
+; (if (symbolp var) (send var :value val) (error type-error "attempted to set constant ~a" var)))
(defun symbol-package (sym) (send sym :home-package))
(defun symbol-name (sym) (declare (symbol sym))
- (if (symbolp sym) (sym . pname) (error "not a symbol")))
+ (if (symbolp sym) (sym . pname) (error type-error "symbol expected")))
(defun make-symbol (str &optional(pkg *package*))
- (if (not (stringp str)) (error "no string"))
+ (if (not (stringp str)) (error type-error "string expected"))
(let ((sym (instantiate symbol)))
(declare (type symbol sym))
(setq (sym . pname) str
@@ -125,7 +120,7 @@
(do-external-symbols (sym pkg)
(setq h (send self :find sym))
(if (and h (not (eq (svref intsymvector h) sym)))
- (error "symbol conflict ~s in ~s" sym self)))
+ (error name-error "symbol conflict ~s in ~s" sym self)))
(setq use (adjoin pkg use))
(send pkg :used-by self)))) )
(:unuse (pkg)
@@ -147,15 +142,17 @@
(if (not (symbolp sym)) (return-from :enter nil))
(let ((hash (mod (sxhash sym) (length intsymvector)))
(size (length intsymvector)))
- (if (>= intsymcount size) (error "can not enter ~a into this package, maximum symbol size is ~a" sym size))
+ (if (>= intsymcount size) (error program-error "can not enter ~a into this package, maximum symbol size is ~a" sym size))
(while (symbolp (svref intsymvector hash))
(if (>= (setq hash (1+ hash)) size) (setq hash 0)))
+ (if (= (elt intsymvector hash) 0)
+ (setq intsymcount (1+ intsymcount)))
(svset intsymvector hash sym)
- (setq intsymcount (1+ intsymcount))
+ ;; TODO: expand if necessary
sym))
(:find (s) ;find symbol just in this package
(declare (symbol s))
- (if (null (symbolp s)) (error "symbol expected"))
+ (if (null (symbolp s)) (error type-error "symbol expected"))
(let* ((size (length intsymvector)) (hash (mod (sxhash s) size)) sym)
(declare (symbol sym))
(while t
@@ -163,7 +160,7 @@
(cond ((eq sym 0) (return-from :find nil))
((eq sym 1) #|deleted mark -- do nothing|# )
((equal (sym . pname) (s . pname)) (return-from :find (mod hash size))))
- (if (>= (setq hash (1+ hash)) (* 2 size)) (error "can not find ~a in this package" sym)))
+ (if (>= (setq hash (1+ hash)) (* 2 size)) (error name-error "can not find ~a in this package" sym)))
nil))
(:shadow (sym)
(when (null (send self :find sym))
@@ -171,7 +168,7 @@
(:import (sym)
(let ((s (send self :find sym)))
(if (and s (not (eq sym (svref intsymvector s))))
- (error "~a cannot be imported due to symbol conflict" sym)
+ (error name-error "~a cannot be imported due to symbol conflict" sym)
(send self :enter sym))) )
(:unintern (sym)
(let ((pos))
@@ -179,16 +176,14 @@
(setq (sym . homepkg) nil))
(setq pos (send self :find sym))
(when pos
- (svset intsymvector pos 1) ;deleted mark
- (setq intsymcount (1- intsymcount)))
+ (svset intsymvector pos 1)) ;deleted mark
(setq pos (send self :find-external sym))
(when pos
- (svset symvector pos 1) ;deleted mark
- (setq symcount (1- symcount)))
+ (svset symvector pos 1)) ;deleted mark
))
(:find-external (s)
(declare (symbol s))
- (if (null (symbolp s)) (error "symbol expected"))
+ (if (null (symbolp s)) (error type-error "symbol expected"))
(let* ((size (length symvector)) (hash (mod (sxhash s) size)) sym)
(declare (symbol sym))
(while t
@@ -239,7 +234,7 @@
(defmacro in-package (pkgname)
`(if (find-package ,pkgname)
(setq *package* (find-package ,pkgname))
- (error "no such package")))
+ (error name-error "no such package")))
(defun rename-package (pkg new-name &optional new-nicks)
(setq pkg (find-package pkg))
@@ -255,9 +250,9 @@
(while x (send pkg :import (car x)) (setq x (rest x))))
t)
(defun symbol-string (s)
- (if (symbolp s) (s . pname) (error "not a symbol")))
+ (if (symbolp s) (s . pname) (error type-error "symbol expected")))
(defun unintern (s &optional (pkg *package*))
- (if (symbolp s) (send pkg :unintern s) (error "no symbol")))
+ (if (symbolp s) (send pkg :unintern s) (error type-error "symbol expected")))
)
(defun package-stats (&optional (s t) &aux use used)
diff --git a/lisp/l/par.l b/lisp/l/par.l
index 6d562f724..042d70c68 100644
--- a/lisp/l/par.l
+++ b/lisp/l/par.l
@@ -104,12 +104,11 @@
-(defun thread-error (code msg1 form &optional (msg2))
+(defun thread-error (err)
(let* ((thr (system::thread-self))
(s (get thr :stdio)))
- (format s "~A ~d error: ~A" *program-name* (send thr :id) msg1)
- (if msg2 (format s " ~A" msg2))
- (if form (format s " in ~s" form))
+ (format s "~A ~d error: ~A" *program-name* (send thr :id) (get err :msg))
+ (if (get err :form) (format s " in ~s" (get err :form)))
(terpri s)
(throw :thread-loop-again nil)) )
@@ -118,7 +117,7 @@
(let* ((thr (system::thread-self))
(id (send thr :id)))
(setf (get thr :stdio) s)
- (lisp::install-error-handler 'thread-error)
+ (install-handler error 'thread-error)
(catch :thread-loop
(while t
(catch :thread-loop-again
diff --git a/lisp/l/process.l b/lisp/l/process.l
index 7bbcb78ab..8d9a4212d 100644
--- a/lisp/l/process.l
+++ b/lisp/l/process.l
@@ -140,7 +140,7 @@
(if (position #\space exec)
(unix:system exec)
(apply #'unix:exec exec args))
- (error "exec") (exit 1))
+ (error program-error "exec") (exit 1))
(t (if *debug* (format t ";; child_pid=~D~%" pid))))
(setq ios (instance io-stream :init
(send stdout :instream) (send stdin :outstream)))
@@ -153,7 +153,7 @@
;;
#+(or :linux :solaris2 :cygwin :alpha)
- (setf (symbol-function 'directory) (symbol-function 'unix::readdir))
+ (alias 'directory 'unix::readdir)
#-(or :linux :solaris2 :cygwin :alpha)
(defun directory (&optional (dir "."))
(let ((fnlist) (ls) (eof (cons nil nil)) (fn))
diff --git a/lisp/l/stream.l b/lisp/l/stream.l
index ae73f01f8..648915068 100644
--- a/lisp/l/stream.l
+++ b/lisp/l/stream.l
@@ -154,7 +154,7 @@
(offset 0))
(let* (uread-length)
(if (and (not (stringp buf)) (< (length buf) n-bytes))
- (error "buffer string is too short for :read-bytes"))
+ (error index-error "buffer string is too short for :read-bytes"))
(when (plusp (setq uread-length (send self :chars-left)))
(replace buf (send self :tail-string) :end1 n-bytes)
(setq uread-length (min n-bytes uread-length))
@@ -163,7 +163,7 @@
(while (< offset n-bytes)
(setq uread-length
(unix:uread fd buf (- n-bytes offset) offset) )
- (if (<= uread-length 0) (error "EOF hit"))
+ (if (<= uread-length 0) (error io-error "EOF hit"))
(incf offset uread-length) )
buf
))
@@ -194,7 +194,7 @@
;
(eval-when (load eval)
(defun make-string-input-stream (s &optional start end)
- (if (null (stringp s)) (error "non string"))
+ (if (null (stringp s)) (error type-error "string expected"))
(setq s (instance stream :init :input s start end))
s)
@@ -641,8 +641,8 @@
(cond ((streamp strm) (send strm :infd))
((numberp strm) strm)
((find-method strm :fd) (send strm :fd))
- (t (error "stream or fd expected for select port")) ))
- (if (>= fd *max-port-fd*) (error "too many streams for selection"))
+ (t (error type-error "stream or fd expected for select port")) ))
+ (if (>= fd *max-port-fd*) (error value-error "too many streams for selection"))
fd))
(:add-port (strm handler &rest arglist)
(let ((fd (send self :get-stream-fd strm)))
diff --git a/lisp/l/string.l b/lisp/l/string.l
index ced534c15..4af38f5e3 100644
--- a/lisp/l/string.l
+++ b/lisp/l/string.l
@@ -50,7 +50,7 @@
(cadr code)
(if (= (length (mnemonic . pname)) 1)
ch
- (error "unknown #\ code"))))
+ (error io-error "unknown #\ code"))))
(t ch))))
(set-dispatch-macro-character #\# #\\ 'read_sharp_backslash)
@@ -64,16 +64,9 @@
(defun true-string (s)
(if (symbolp s) (symbol-pname s) s))
-(defun string (x)
- (cond ((stringp x) x)
- ((symbolp x) (copy-seq (symbol-pname x)))
- ((numberp x) (princ-to-string x))
- (t (error "cannot coerce to string " x))))
-
(defun make-string (size) (instantiate string size))
(defun string-left-trim (bag str)
- (declare (string str))
(let ((n 0))
(declare (type integer n))
(setq str (true-string str))
@@ -81,7 +74,6 @@
(subseq str n (length str))))
(defun string-right-trim (bag str)
- (declare (string str))
(let ((leng (length str)))
(setq str (true-string str))
(while (position (char str (1- leng)) bag) (dec leng))
@@ -91,16 +83,16 @@
(string-left-trim bag (string-right-trim bag str)))
(defun nstring-downcase (str &key (start 0) (end (length str)))
- (declare (type integer start end) (string str))
- (if (not (stringp str)) (error "no string"))
+ (declare (string str))
+ (if (not (stringp str)) (error type-error "string expected"))
(while (< start end)
(setchar str start (char-downcase (char str start)))
(inc start))
str)
(defun nstring-upcase (str &key (start 0) (end (length str)))
- (declare (type integer start end))
- (if (not (stringp str)) (error "no string"))
+ (declare (string str))
+ (if (not (stringp str)) (error type-error "string expected"))
(while (< start end)
(setchar str start (char-upcase (char str start)))
(inc start))
@@ -280,7 +272,7 @@
(cond ((symbolp p) (string p))
((stringp p) p)
((pathnamep p) (send p :namestring))
- (t (error "not a pathname ~s" p))))
+ (t (error type-error "pathname expected ~s" p))))
(defun pathname-directory (s) ((pathname s) . directory))
(defun pathname-name (s) ((pathname s) . name))
@@ -334,7 +326,7 @@
; (merge-pathnames
; (pathname-name pathnam) target-dir)
)
- (t (error "cannot locate the file")))) )
+ (t (error io-error "cannot locate the file")))) )
)
@@ -383,7 +375,7 @@
(setq directory
(append '(:root ) (rest directory)))
self)
- (t (error "cannot parse url ~a" url-string)) ))
+ (t (error value-error "cannot parse url ~a" url-string)) ))
)
(:percent-escape (&key (queryp t) (revert nil))
(send self :parse-namestring
@@ -421,7 +413,7 @@
(send file :directory (append '(:root #| "usr" "www" "data" |#)
(rest (send file :directory))))
(list protocol server port file))
- (t (error "cannot parse url ~a" url-string)) ))
+ (t (error value-error "cannot parse url ~a" url-string)) ))
)
(defvar *url-escape-unreserved-characters* "-_.~:/=?&")
diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l
index a821a242d..e54eac2b9 100644
--- a/lisp/l/toplevel.l
+++ b/lisp/l/toplevel.l
@@ -1,5 +1,5 @@
;;;;
-;;;; euslisp toplevel loop and error/signal handler
+;;;; euslisp toplevel loop
;;;;
;;;; Copyright 1987,1991, Toshihiro MATSUI, Electrotechnical Laboratory
;;; 1987-Oct
@@ -16,15 +16,14 @@
*prompt*
*prompt-string*
*history* *try-unix*
- skip-blank read-list-from-line sigint-handler *signal-handlers*
+ sigcont-handler
+ skip-blank read-list-from-line
*eustop-hook*
*toplevel-hook*
*top-selector*
*timer-job*
*top-selector-interval*
evaluate-stream reploop
- eussig
- euserror
eustop reset
toplevel-prompt
))
@@ -60,6 +59,12 @@
(defun count-up-timer () (incf *timer-job-count*))
+;; compile from toplevel.l to function properly
+;; (access to *replevel* on compile-time?)
+(defun sigcont-handler (c)
+ (when (memq *replevel* (sys::list-all-catchers))
+ (reset *replevel*)))
+
(defun skip-blank (s &optional (eof (gensym)))
(let ((ch (read-char s nil eof)))
(if (eq ch eof) (return-from skip-blank eof))
@@ -97,56 +102,34 @@
(if (eq *input-line* eof) (return-from read-list-from-line eof))
(make-string-input-stream *input-line*)))))
-
-(defun sigint-handler (sig code)
- (warning-message 1 "interrupt")
- (if (fboundp 'unix:ualarm)
- (unix:ualarm 0 0)
- (unix:alarm 0))
- (let* ((*replevel* (1+ *replevel*))
- (*reptype* "B"))
- (catch *replevel* (reploop #'toplevel-prompt))))
-
-(defvar *signal-handlers* (make-sequence vector 32))
-
-(defun eussig (sig &rest code &aux (handler (aref *signal-handlers* sig)))
- (cond (handler (funcall handler sig code))
- (t
- (if (fboundp 'unix:ualarm)
- (unix:ualarm 0 0)
- (unix:alarm 0))
- (warning-message 1 "signal ~s ~s~%" sig code)
- (let* ((*replevel* (1+ *replevel*))
- (*reptype* "S"))
- (catch *replevel*
- (reploop #'toplevel-prompt))))))
-
(defun evaluate-stream (input)
(let* ((eof (cons nil nil))
(command (read input nil eof))
(arglist) (arg) result)
- (cond ((eq command eof) )
+ (flet ((normal-eval (comm)
+ (setq - comm)
+ (setq result (eval comm))))
+ (cond
+ ((eq command eof) )
((symbolp command)
;; (if *history* (add-history (input . buffer)))
(cond ((fboundp command)
(setq arglist nil)
(while (not (eq (setq arg (read input nil eof)) eof))
(push arg arglist))
- (setq - (cons command (nreverse arglist)))
- (setq result (eval -)))
- ((and (boundp command)
- (eq (read input nil eof) eof))
- (setq - command)
- (setq result (eval command)))
+ (if (and (null arglist) (boundp command))
+ (normal-eval command) ;; eval symbol if bound and w/o args
+ (normal-eval (cons command (nreverse arglist)))))
+ ((boundp command)
+ (normal-eval command))
((find-package (string command)) (in-package (string command)))
- (*try-unix*
- (setq - (list 'unix:system (input . buffer)))
- (setq result (unix:system (input . buffer)) ) )
- (t (warn "?~%")) ))
+ ((and *try-unix*
+ ;; try normal-eval when unix command is not found (errno 127)
+ (not (equal (normal-eval (list 'unix:system (input . buffer))) #x7f00))))
+ (t (normal-eval command)) ))
(t
;; (if *history* (add-history (input . buffer)))
- (setq - command)
- (setq result (eval command)) ))
+ (normal-eval command) )))
result))
(defun toplevel-prompt (strm)
@@ -226,8 +209,7 @@
(defun reploop-non-select (&optional (repstream *terminal-io*)
(ttyp (unix:isatty repstream)))
;read-eval-print loop
- (let* ((*error-handler* 'euserror)
- (eof (gensym))
+ (let* ((eof (gensym))
(input) (local-bindings) (special-bindings))
(if (> *replevel* 0)
(setq local-bindings (sys:list-all-bindings)
@@ -248,8 +230,7 @@
(defun reploop-select (&optional (repstream *terminal-io*)
(ttyp (unix:isatty repstream)))
- (let* ((*error-handler* 'euserror)
- (eof (gensym))
+ (let* ((eof (gensym))
(input) (local-bindings) (special-bindings))
(if ttyp (prompt repstream))
(if (> *replevel* 0)
@@ -273,50 +254,36 @@
(defun reploop (prompt &optional (repstream *terminal-io*)
(ttyp (unix:isatty repstream)))
- (let ((*prompt* prompt))
+ (let ((*prompt* prompt)
+ (*current-condition-handler* nil))
(if *use-top-selector*
(reploop-select repstream ttyp)
(reploop-non-select repstream ttyp))) )
-
-
-(defun euserror (code msg1 form &optional (msg2))
- (if (and msg2 (zerop (length msg1))) (setq msg1 msg2 msg2 nil))
-#+(or :solaris2 :SunOS4.1 :thread)
- (format *error-output* "~C[1;3~Cm~A ~d error: ~A"
- #x1b (+ 1 48) *program-name*
- (unix::thr-self) msg1) ; thr-self is in unix pkg
-#-(or :solaris2 :SunOS4.1 :thread)
- (format *error-output* "~C[1;3~Cm~A error: ~A"
- #x1b (+ 1 48) *program-name* msg1)
- (if msg2 (format *error-output* " ~A" msg2))
- (if form (format *error-output* " in ~s" form))
- (format *error-output* "~C[0m~%" #x1b)
- (let ((*replevel* (1+ *replevel*))
- (*reptype* "E"))
- (catch *replevel* (reploop #'toplevel-prompt)))
- (throw *replevel* nil))
;;;
;;; default toplevel
;;;
-
(defun eustop (&rest argv)
(when (unix:isatty *standard-input*)
(warning-message 4 "~%~A" (lisp-implementation-version))
(terpri *error-output*)
- (unix:signal unix::sigint 'sigint-handler
- 2) ; not restart
- (unix:signal unix::sigpipe 'eussig)
; setup for history
#+(or :sun :linux :alpha :solaris2 :mips)
(when (fboundp 'unix:tcgets)
(setq *tc* (unix:tcgets *standard-input*))
(new-history *history-max*))
)
+ ;; setup global variables
(if argv (setq *symbol-input* (find-executable (elt argv 0))))
(setq *user* (unix:getenv "USER"))
(setq *eustop-argument* argv)
(setq *prompt-string* (pathname-name *program-name*))
+ ;; install signal handlers
+ (unix:install-signal-handler unix::sigint unix::sigint-received)
+ (unix:install-signal-handler unix::sigcont unix::sigcont-received)
+ (install-handler unix::sigint-received 'sigint-handler)
+ (install-handler unix::sigcont-received 'sigcont-handler)
+ (unix:signal unix::sigpipe 'eussig)
;; load .eusrc file from the home directory
(let ((rcfile (unix:getenv "EUSRC")))
(unless rcfile
@@ -330,22 +297,20 @@
(>= (length argv) 2))
(apply #'compiler::comp-file-toplevel argv)
(exit 1))
- ;; load files given in arguments
; (format t "argv=~a~%" argv)
(if *eustop-hook* (funcall *eustop-hook* *eustop-argument*))
- (let (exp)
- (dotimes (i (1- (length *eustop-argument*)))
- (setq exp (elt *eustop-argument* (1+ i)))
-; (print exp)
- (cond ((eq (elt exp 0) #\() ;)
- ;; if exp is enclosed by parens, evaluate it.
- (eval (read-from-string exp)))
- ((eq (elt exp 0) #\-)
- ;; if arg is prefixed by a dash, ignore.
- )
- (t (load exp)))))
;; enter read-eval-loop session
(catch :eusexit
+ ;; load files given in arguments
+ (catch 0
+ (dolist (exp (cdr *eustop-argument*))
+ (cond ((eq (elt exp 0) #\() ;)
+ ;; if exp is enclosed by parens, evaluate it.
+ (eval (read-from-string exp)))
+ ((eq (elt exp 0) #\-)
+ ;; if arg is prefixed by a dash, ignore.
+ )
+ (t (load exp)))))
(while t
(catch 0
(let ((*replevel* 0) (*reptype* ""))
diff --git a/lisp/opengl/src/gltexture.l b/lisp/opengl/src/gltexture.l
index 1f82f0770..21f7d0935 100644
--- a/lisp/opengl/src/gltexture.l
+++ b/lisp/opengl/src/gltexture.l
@@ -14,7 +14,7 @@
(ob (send img :entity))
(b (make-string (* ow oh od))))
(when (not (= od 3))
- (error "not supported depth"))
+ (error value-error "not supported depth"))
(dotimes (x ow)
(dotimes (y oh)
(dotimes (z od)
@@ -31,7 +31,7 @@
(th (ash 1 (ceiling (log oh 2))))
(td od))
(when (not (= od 3))
- (error "not supported depth"))
+ (error value-error "not supported depth"))
(cond ((not (and (= ow tw) (= oh th)))
;; rescale to boundary
(let ((b (make-string (* tw th td))))
@@ -73,7 +73,7 @@
(not (= texture-width (ash 1 (ceiling (log texture-width 2))))))
(and texture-height
(not (= texture-height (ash 1 (ceiling (log texture-height 2)))))))
- (error "make-cube-with-texture: argument error"))
+ (error argument-error "make-cube-with-texture: argument error"))
(let* ((c (apply #'user::make-cube (append (list xsize ysize zsize) args)))
(faces (list (car (send c :get-face nil :top))
diff --git a/lisp/opengl/src/glview.l b/lisp/opengl/src/glview.l
index 5a7e99a62..726254b40 100644
--- a/lisp/opengl/src/glview.l
+++ b/lisp/opengl/src/glview.l
@@ -84,11 +84,11 @@
(:shininess (&optional shi)
(cond ((null shi) shininess)
((numberp shi) (setq shininess shi))
- (t (error "number expected for colormaterial :shininess"))))
+ (t (error type-error "number expected for colormaterial :shininess"))))
(:transparency (&optional trans)
(cond ((null trans) transparency)
((numberp trans) (setq transparency trans))
- (t (error "number expected for colormaterial :transparency"))))
+ (t (error type-error "number expected for colormaterial :transparency"))))
(:opengl ()
(glMaterialfv GL_FRONT_AND_BACK GL_AMBIENT ambient)
(glMaterialfv GL_FRONT_AND_BACK GL_DIFFUSE diffuse)
@@ -668,7 +668,7 @@
(7
(glLightfv GL_LIGHT7 GL_POSITION (float-vector x y z 0.0)))
(t
- (error (format nil "unkown light number ~a" light)))))
+ (error value-error "unkown light number ~a" light))))
diff --git a/lisp/tool/compile_l.l b/lisp/tool/compile_l.l
index c9471d188..7f11a0857 100644
--- a/lisp/tool/compile_l.l
+++ b/lisp/tool/compile_l.l
@@ -45,6 +45,7 @@
(comp::compile-file-if-src-newer "hashtab.l" *objdir*)
(comp::compile-file-if-src-newer "eusforeign.l" *objdir*)
(comp::compile-file-if-src-newer "extnum.l" *objdir*)
+(comp::compile-file-if-src-newer "conditions.l" *objdir*)
(comp::compile-file-if-src-newer "mathtran.l" *objdir*)
(comp::compile-file-if-src-newer "toplevel.l" *objdir*)
(comp::compile-file-if-src-newer "tty.l" *objdir*)
diff --git a/lisp/xwindow/Xcolor.l b/lisp/xwindow/Xcolor.l
index a8c9f8f51..d10cec425 100644
--- a/lisp/xwindow/Xcolor.l
+++ b/lisp/xwindow/Xcolor.l
@@ -47,7 +47,7 @@
(defun find-visual (type depth &optional (screen 0))
(setq type (visual-type type))
- (unless (integerp type) (error "illegal visual type ~A" type))
+ (unless (integerp type) (error type-error "illegal visual type ~A" type))
(let ((vinfo (make-array 16 :element-type :integer)))
(if (= (MatchVisualInfo *display* screen depth type vinfo) 0)
nil ; specified visual not found
@@ -156,7 +156,7 @@ or a list of three short (not byte) integers representing red, green and blue."
)
((and (integerp r) (integerp g) (integerp b))
(setq colordef (instance Xcolor :init 0 r g b)))
- (t (error "invalid color specification")))
+ (t (error value-error "invalid color specification")))
;; RGB description is obtained in colordef
(cond ((null pix) ;pixel is not specified --> allocate color cell
(AllocColor *display* cmapid colordef)
@@ -168,7 +168,7 @@ or a list of three short (not byte) integers representing red, green and blue."
(if (= 0 (StoreColor *display* cmapid colordef))
nil
pix))
- (t (error "invalid pixel"))))
+ (t (error value-error "invalid pixel"))))
(:store-hls (pix hue lightness saturation)
(let ((rgb (geo:hls2rgb hue lightness saturation 65536)))
(send self :store pix (first rgb) (second rgb) (third rgb))
@@ -252,7 +252,7 @@ or a list of three short (not byte) integers representing red, green and blue."
(send self :store nil rgb)))
(when (null pix)
(send self :free (subseq lut 0 index))
- (error "color allocation"))
+ (error program-error "color allocation"))
(setf (aref lut index) pix))
)
(incf index))
@@ -261,12 +261,12 @@ or a list of three short (not byte) integers representing red, green and blue."
(let ((lut (assoc LUT-name LUT-list)) (new-lut))
(cond ((null lut)
(setq new-lut (send self :allocate-colors rgb-list private))
- (if (null new-lut) (error "colorcells allocation failure"))
+ (if (null new-lut) (error program-error "colorcells allocation failure"))
(setq LUT-list (cons (cons LUT-name new-lut) LUT-list))
new-lut)
((= (length rgb-list) (length (cdr lut))) (cdr lut))
;already created
- (t (error "size mismatch with the LUT already created")))
+ (t (error value-error "size mismatch with the LUT already created")))
))
(:define-gray-scale-LUT (LUT-name levels &optional (private nil))
(let* ((pixels)
diff --git a/lisp/xwindow/Xeus.l b/lisp/xwindow/Xeus.l
index ee1665543..d21376b0b 100644
--- a/lisp/xwindow/Xeus.l
+++ b/lisp/xwindow/Xeus.l
@@ -480,7 +480,7 @@
(:northeast . 3) (:west . 4) (:center . 5)
(:east . 6) (:southwest . 7) (:south . 8)
(:southeast . 9) (:static . 10))))) )
- (unless (integerp g) (error "invalid gravity name" g))
+ (unless (integerp g) (error type-error "invalid gravity name" g))
g)
diff --git a/lisp/xwindow/Xevent.l b/lisp/xwindow/Xevent.l
index cd667d4bc..7b23a625d 100644
--- a/lisp/xwindow/Xevent.l
+++ b/lisp/xwindow/Xevent.l
@@ -411,14 +411,13 @@ instead of 12th of motoinNotify events."
(defmacro wml (&rest forms) `(window-main-loop . ,forms))
-(defun wmlerror (code msg1 form &optional (msg2))
+(defun wmlerror (err)
#+(or :solaris2 :SunOS4.1 :pthread)
(format *error-output* "~A ~d error: ~A" *program-name*
- (unix::thr-self) msg1) ; thr-self is in unix pkg
+ (unix::thr-self) (get err :msg)) ; thr-self is in unix pkg
#-(or :solaris2 :SunOS4.1 :pthread)
- (format *error-output* "~A error: ~A" *program-name* msg1)
- (if msg2 (format *error-output* " ~A" msg2))
- (if form (format *error-output* " in ~s" form))
+ (format *error-output* "~A error: ~A" *program-name* (get err :msg))
+ (if (get err :form) (format *error-output* " in ~s" (get err :form)))
(terpri *error-output*)
(throw :window-main-loop-again nil))
@@ -426,7 +425,7 @@ instead of 12th of motoinNotify events."
(progn
(defun window-main-thread2 ()
(let ((num-events 0))
- (lisp::install-error-handler #'wmlerror)
+ (install-handler error #'wmlerror)
(sync *display* 1)
(catch :window-main-loop
(while t
diff --git a/lisp/xwindow/Xgraphics.l b/lisp/xwindow/Xgraphics.l
index 671a16c4c..10683d7dc 100644
--- a/lisp/xwindow/Xgraphics.l
+++ b/lisp/xwindow/Xgraphics.l
@@ -372,7 +372,7 @@
(:XorReverse . 11) (:CopyInverted . 12)
(:OrInverted . 13) (:Nand . 14)
(:Set . 15))))))
- (unless (integerp f) (error "not integer or keyword for :function"))
+ (unless (integerp f) (error type-error "not integer or keyword for :function"))
f)
(:function (x)
"0=Clear, 1=And, 2=AndReverse, 3=Copy
diff --git a/lisp/xwindow/Xitem.l b/lisp/xwindow/Xitem.l
index 64a5df5a3..cc229f214 100644
--- a/lisp/xwindow/Xitem.l
+++ b/lisp/xwindow/Xitem.l
@@ -636,7 +636,7 @@
(unless (probe-file fname)
(setq fname (format nil "~A/lib/bitmaps/~A" *eusdir* fname))
(if (null (probe-file fname))
- (error "bitmap file ~S not found." fname)))
+ (error io-error "bitmap file ~S not found." fname)))
(ReadBitmapFile *display* (defaultrootwindow *display*)
fname width height bitmap x_hot y_hot)
(setq bitmap-width (c-int width))
diff --git a/test/argparse.l b/test/argparse.l
index 5c8bcd8ac..0b6265a5c 100644
--- a/test/argparse.l
+++ b/test/argparse.l
@@ -16,7 +16,7 @@
(defun write-tmp-file (fname send-lst)
`(with-open-file (test-file ,fname :direction :output :if-exists :supersede)
(princ-line "(defun exit-on-error (&rest args) (exit 1))" test-file)
- (princ-line "(lisp::install-error-handler 'exit-on-error)" test-file)
+ (princ-line "(install-handler error 'exit-on-error)" test-file)
(princ-line "(require :argparse \"lib/llib/argparse.l\")" test-file)
(terpri test-file)
(princ-line "(setq argparse (instantiate argparse:argument-parser))" test-file)
diff --git a/test/bignum.l b/test/bignum.l
index 91e9a014f..68f8f2d73 100644
--- a/test/bignum.l
+++ b/test/bignum.l
@@ -1,5 +1,4 @@
-;(setq sys::*gc-hook* #'(lambda (a b) (format t "GC! free:~A total:~A~%" a b)))
-(setq sys::*gc-hook* #'(lambda (a b) ()))
+;;(setq sys::*gc-debug* t)
(require :unittest "lib/llib/unittest.l")
diff --git a/test/conditions.l b/test/conditions.l
new file mode 100644
index 000000000..d97e0e637
--- /dev/null
+++ b/test/conditions.l
@@ -0,0 +1,443 @@
+;;;; Most tests are derived from Common Lisp ANSI compliance test suite
+;;;; at https://common-lisp.net/project/ansi-test
+;;;;
+;;;; Tests with features that are still not supported but hopefully eventually
+;;;; will be are commented out
+;;;;
+;;;; 2020 by Guilherme de Campos Affonso
+;;;;
+
+;; TODO: add tests for `install-handler', `invoke-next-handler', and other eus-only functions
+
+
+(require :unittest "lib/llib/unittest.l")
+
+(init-unit-test :exit-on-error nil)
+
+(defmacro define-ansi-test (name clause &rest res)
+ `(deftest ,name
+ (assert ,(if (and (consp res) (not (cdr res))) ;; single element list
+ `(equal ,clause ',@res)
+ `(equal ,clause ',res)))))
+
+
+(deftest defcondition.1
+ (defcondition _condition.1)
+ (let ((c (instantiate _condition.1)))
+ (assert (derivedp c condition))
+ (assert (derivedp c _condition.1))
+ (assert (not (derivedp (instantiate condition) _condition.1)))
+ (assert (eq (class c) _condition.1))))
+
+(deftest defcondition.2
+ (defcondition _condition.2 :slots (a b c))
+ (let ((c (instantiate _condition.2)))
+ (assert (memq :a (send c :methods)))
+ (assert (memq :b (send c :methods)))
+ (assert (memq :c (send c :methods)))
+ (assert (memq 'a (coerce (send _condition.2 :slots) cons)))
+ (assert (memq 'b (coerce (send _condition.2 :slots) cons)))
+ (assert (memq 'c (coerce (send _condition.2 :slots) cons)))
+ (assert (null (send c :get-val 'a)))
+ (assert (null (send c :get-val 'b)))
+ (assert (null (send c :get-val 'c)))))
+
+(deftest defcondition.3
+ (defcondition _condition.3.a :slots (a))
+ (defcondition _condition.3.b :slots (b) :super _condition.3.a)
+ (let ((ca (instantiate _condition.3.a))
+ (cb (instantiate _condition.3.b)))
+ (assert (derivedp cb _condition.3.a))
+ (assert (not (derivedp ca _condition.3.b)))
+ (assert (memq :a (send cb :methods)))
+ (assert (memq :b (send cb :methods)))
+ (assert (memq 'a (coerce (send _condition.3.b :slots) cons)))
+ (assert (memq 'b (coerce (send _condition.3.b :slots) cons)))))
+
+(deftest signals.1
+ (assert (null (signals condition))))
+
+(deftest signals.2
+ (defcondition _condition.signals.2)
+ (let ((c (instance _condition.signals.2 :init)))
+ (assert (eq c
+ (handler-case (signals c)
+ (_condition.signals.2 (c1) c1))))))
+
+(deftest signals.3
+ (defcondition _condition.signals.3)
+ (assert (eql :ok
+ (handler-case (signals _condition.signals.3)
+ (_condition.signals.3 () :ok)))))
+
+(deftest signals.4
+ (defcondition _condition.signals.4 :slots (test))
+ (assert (eql 'good
+ (handler-case (signals _condition.signals.4 :test 'good)
+ (_condition.signals.4 (c) (send c :test))))))
+
+(deftest signals.5
+ (defcondition _condition.signals.5 :slots (val))
+ (assert (eql :ok
+ (handler-case
+ (handler-case
+ (signals _condition.signals.5 :val 3)
+ (_condition.signals.5 (c)
+ (decf (_condition.signals.5-val c))
+ (if (> (send c :val) 0)
+ (signals c)
+ :ok)))
+ (_condition.signals.5 (c) :not-ok)))))
+
+(deftest invoke-next-handler.1
+ (defcondition _condition.invoke-next-handler.1)
+ (assert (null
+ (handler-case (signals _condition.invoke-next-handler.1)
+ (_condition.invoke-next-handler.1 (c)
+ (invoke-next-handler c))))))
+
+(deftest invoke-next-handler.2
+ (defcondition _condition.invoke-next-handler.2)
+ (assert (eql :ok
+ (handler-bind ((_condition.invoke-next-handler.2 #'(lambda (c) :ok)))
+ (handler-case (signals _condition.invoke-next-handler.2)
+ (_condition.invoke-next-handler.2 (c)
+ (invoke-next-handler c)))))))
+
+(deftest invoke-next-handler.3
+ (defcondition _condition.invoke-next-handler.3)
+ (assert (null (invoke-next-handler (instance _condition.invoke-next-handler.3))))
+ (install-handler _condition.invoke-next-handler.3 #'(lambda (c) :ok))
+ (assert (eql :ok (invoke-next-handler (instance _condition.invoke-next-handler.3))))
+ (assert (remove-handler _condition.invoke-next-handler.3)))
+
+(deftest install-handler.1
+ (defcondition _condition.install-handler.1)
+ (install-handler _condition.install-handler.1 #'(lambda (c) :ok))
+ (assert (eql :ok (signals _condition.install-handler.1)))
+ (assert (remove-handler _condition.install-handler.1)))
+
+(deftest install-handler.2
+ (defcondition _condition.install-handler.2)
+ (install-handler _condition.install-handler.2 #'identity)
+ (let ((c (instance _condition.install-handler.2 :init)))
+ (assert (eq c (signals c))))
+ (assert (remove-handler _condition.install-handler.2)))
+
+(deftest install-handler.3
+ (defcondition _condition.install-handler.3)
+ (handler-bind ((_condition.install-handler.3 #'(lambda (c) :not-ok)))
+ (assert (eql :not-ok (signals _condition.install-handler.3)))
+ (install-handler _condition.install-handler.3 #'(lambda (c) :ok))
+ (assert (eql :ok (signals _condition.install-handler.3))))
+ (assert (remove-handler _condition.install-handler.3)))
+
+(deftest remove-handler.1
+ (defcondition _condition.remove-handler.1)
+ (assert (not (remove-handler _condition.remove-handler.1))))
+
+(deftest remove-handler.2
+ (defcondition _condition.remove-handler.2)
+ (install-handler _condition.remove-handler.2 #'identity)
+ (assert (remove-handler _condition.remove-handler.2 #'identity))
+ (assert (not (remove-handler _condition.remove-handler.2))))
+
+(deftest remove-handler.3
+ (defcondition _condition.remove-handler.3)
+ (handler-bind ((_condition.remove-handler.3 #'identity))
+ (assert (not (remove-handler _condition.remove-handler.3))))
+ (assert (not (remove-handler _condition.remove-handler.3))))
+
+(deftest remove-handler.4
+ (defcondition _condition.remove-handler.4)
+ (install-handler _condition.remove-handler.4 #'(lambda (c) (list 1 2 3)))
+ (handler-bind ((_condition.remove-handler.4
+ #'(lambda (c) (cons 0 (invoke-next-handler c)))))
+ (assert (equal (list 0 1 2 3) (signals _condition.remove-handler.4)))
+ (assert (remove-handler _condition.remove-handler.4))
+ (assert (equal (list 0) (signals _condition.remove-handler.4))))
+ (assert (not (remove-handler _condition.remove-handler.4))))
+
+;;;; adapted from ansi-test/tests/conditions/error.lsp
+(defun frob-simple-condition (c expected-fmt &rest expected-args)
+ "Check that condition message matches the expected formatting"
+ (and (derivedp c condition)
+ (string= (send c :message)
+ (apply #'format nil expected-fmt expected-args))))
+
+(defun frob-simple-error (c expected-fmt &rest expected-args)
+ (and (derivedp c error)
+ (apply #'frob-simple-condition c expected-fmt expected-args)))
+
+
+(define-ansi-test error.1
+ (let ((fmt "Error"))
+ (handler-case
+ (error fmt)
+ (error (c) (frob-simple-error c fmt))))
+ t)
+
+(define-ansi-test error.2
+ (let* ((fmt "Error")
+ (cnd (instance error :init :message fmt)))
+ (handler-case
+ (signals cnd)
+ (error (c) (frob-simple-error c fmt))))
+ t)
+
+(define-ansi-test error.3
+ (let ((fmt "Error"))
+ (handler-case
+ (signals error :message fmt)
+ (error (c) (frob-simple-error c fmt))))
+ t)
+
+(define-ansi-test error.4
+ (let ((fmt "Error: ~A"))
+ (handler-case
+ (error fmt 10)
+ (error (c) (frob-simple-error c fmt 10))))
+ t)
+
+(define-ansi-test error.6
+ (handler-case
+ (signals condition)
+ (error (c) :wrong)
+ (condition (c) :right))
+ :right)
+
+
+;;;; adapted from ansi-test/tests/conditions/handler-bind.lsp
+(define-ansi-test handler-bind.1
+ (handler-bind ())
+ nil)
+
+(define-ansi-test handler-bind.2
+ (handler-bind () (values)))
+
+(define-ansi-test handler-bind.3
+ (handler-bind () (values 1 2 3))
+ 1 2 3)
+
+(define-ansi-test handler-bind.4
+ (let ((x 0))
+ (values
+ (handler-bind () (incf x) (+ x 10))
+ x))
+ 11 1)
+
+(define-ansi-test handler-bind.5
+ (catch :foo
+ (handler-bind ((error #'(lambda (c) (throw :foo 'good))))
+ (error "an error")))
+ good)
+
+;; (define-ansi-test handler-bind.5.b
+;; (block foo
+;; (handler-bind ((error #'(lambda (c) (return-from foo 'good))))
+;; (error "an error")))
+;; good)
+
+;; INVERSE ORDER FROM COMMON LISP!!!
+(define-ansi-test handler-bind.6
+ (catch :foo
+ (handler-bind
+ ((error #'(lambda (c) (throw :foo 'bad))))
+ (handler-bind ((error #'(lambda (c) (error c)))
+ (error #'(lambda (c) (throw :foo 'good))))
+ (error "an error"))))
+ good)
+
+(defun handler-bind.7-handler-fn (c)
+ (declare (ignore c))
+ (throw 'foo 'good))
+
+(define-ansi-test handler-bind.7
+ (catch 'foo
+ (handler-bind ((error #'handler-bind.7-handler-fn))
+ (error "an error")))
+ good)
+
+(define-ansi-test handler-bind.8
+ (catch 'foo
+ (handler-bind ((error 'handler-bind.7-handler-fn))
+ (error "an error")))
+ good)
+
+;; (define-ansi-test handler-bind.9
+;; (catch 'foo
+;; (handler-bind ((error #.(symbol-function
+;; 'handler-bind.7-handler-fn)))
+;; (error "an error")))
+;; good)
+
+(define-ansi-test handler-bind.10
+ (catch :done
+ (flet ((foo () (signals condition))
+ (succeed (c) (declare (ignore c)) (throw :done 'good))
+ (fail (c) (declare (ignore c)) (throw :done 'bad)))
+ (handler-bind
+ ((error #'fail)
+ (condition #'succeed))
+ (foo))))
+ good)
+
+(define-ansi-test handler-bind.11
+ (catch :done
+ (handler-bind
+ ((error #'(lambda (c) c))
+ (error #'(lambda (c) (declare (ignore c)) (throw :done 'good))))
+ (error "an error")))
+ good)
+
+;; INVERSE ORDER FROM COMMON LISP!!!
+(define-ansi-test handler-bind.12
+ (catch :done
+ (handler-bind
+ ((error #'(lambda (c) c)))
+ (handler-bind
+ ((error #'(lambda (c) (declare (ignore c)) (throw :done 'good))))
+ (error "an error"))))
+ good)
+
+(define-ansi-test handler-bind.13
+ (handler-bind
+ ((error #'(lambda (c) (declare (ignore c))
+ (throw 'done 'good))))
+ (catch 'done
+ (error "an error")))
+ good)
+
+(define-ansi-test handler-bind.17
+ (catch 'done
+ (handler-bind
+ ((error
+ #'(lambda (c) (declare (ignore c))
+ (throw 'done 'good))))
+ (error "an error")))
+ good)
+
+
+;;;; adapted from ansi-test/tests/conditions/handler-case.lsp
+(define-ansi-test handler-case.1
+ (handler-case
+ (error "an error")
+ (error () t))
+ t)
+
+(define-ansi-test handler-case.2
+ (handler-case
+ (error "an error")
+ (type-error () nil)
+ (error () t))
+ t)
+
+(define-ansi-test handler-case.3
+ (handler-case
+ (error "an error")
+ (error (c) (and (derivedp c error) t))
+ (error () 'bad)
+ (condition () 'bad2))
+ t)
+
+(define-ansi-test handler-case.4
+ (handler-case
+ (error "an error")
+ (type-error (c) c)
+ (error (c) (and (derivedp c error) t))
+ (error () 'bad)
+ (condition () 'bad2))
+ t)
+
+(define-ansi-test handler-case.5
+ (handler-case
+ (error "an error")
+ (error (c) (and (derivedp c error) t))
+ (error () 'bad))
+ t)
+
+(define-ansi-test handler-case.6
+ (handler-case (values)
+ (error () nil)))
+
+(define-ansi-test handler-case.7
+ (handler-case 'foo (condition () 'bar))
+ foo)
+
+(define-ansi-test handler-case.8
+ (handler-case 'foo (t () 'bar))
+ foo)
+
+(define-ansi-test handler-case.9
+ (handler-case (values 1 2 3 4 5 6 7 8) (condition () nil))
+ 1 2 3 4 5 6 7 8)
+
+(define-ansi-test handler-case.10
+ (handler-case
+ (error "foo")
+ (condition () 'good))
+ good)
+
+(define-ansi-test handler-case.12
+ (handler-case (error "foo")
+ (nil () nil)
+ (error (c) (not (not (derivedp c error)))))
+ t)
+
+(define-ansi-test handler-case.13
+ (handler-case (error "foo")
+ (error (c) (values))))
+
+(define-ansi-test handler-case.14
+ (handler-case (error "foo")
+ (error (c)
+ (values 1 2 3 4 5 6 7 8)))
+ 1 2 3 4 5 6 7 8)
+
+(define-ansi-test handler-case.15
+ (handler-case
+ (handler-case (error "foo")
+ (warning () 'bad))
+ (error () 'good))
+ good)
+
+(define-ansi-test handler-case.16
+ (handler-case
+ (handler-case (error "foo")
+ (error () 'good))
+ (error () 'bad))
+ good)
+
+;; in euslisp `invoke-next-handler' is used for re-raising
+;; (define-ansi-test handler-case.17
+;; (let ((i 0))
+;; (values
+;; (handler-case
+;; (handler-case (error "foo")
+;; (error () (incf i) (error "bar")))
+;; (error () 'good))
+;; i))
+;; good 1)
+
+;; (define-ansi-test handler-case.18
+;; (let ((i 0))
+;; (values
+;; (handler-case
+;; (handler-case (error "foo")
+;; (error (c) (incf i) (error c)))
+;; (error () 'good))
+;; i))
+;; good 1)
+
+;; (define-ansi-test handler-case.20
+;; (handler-case
+;; 10
+;; (:no-error (x) (+ x 3)))
+;; 13)
+
+(define-ansi-test handler-case.27
+ (handler-case (error "foo") (error ()))
+ nil)
+
+(run-all-tests)
+(exit 0)
diff --git a/test/const.l b/test/const.l
index 5c0dfca00..0459c4bc9 100644
--- a/test/const.l
+++ b/test/const.l
@@ -11,11 +11,11 @@
(eval `(defconstant ,(intern (format nil "TEST1::*CONST~d*" i)) i)))
(make-package "TEST2")
(dotimes (i (+ (length ((find-package "TEST2") . intsymvector)) 10))
- (catch 'error
- (labels ((error2 (&rest args) (print args *error-output*)(throw 'error nil)))
- (lisp::install-error-handler 'error2)
- (shadow (intern (format nil "*CONST~d*" i)) (find-package "TEST2"))
- (eval `(defconstant ,(intern (format nil "TEST2::*CONST~d*" i)) i)))))
+ (handler-case
+ (progn
+ (shadow (intern (format nil "*CONST~d*" i)) (find-package "TEST2"))
+ (eval `(defconstant ,(intern (format nil "TEST2::*CONST~d*" i)) i)))
+ (name-error (err) (lisp::print-error-message err))))
(make-package "TEST3")
(setq num (+ (length ((find-package "TEST3") . intsymvector)) 10))
(dotimes (i num)
diff --git a/test/coords.l b/test/coords.l
index 1d33a97e9..6194821eb 100644
--- a/test/coords.l
+++ b/test/coords.l
@@ -1,6 +1,6 @@
(require :unittest "lib/llib/unittest.l")
-;;(setq sys::*gc-hook* #'(lambda (a b) (format t "GC! free:~A total:~A~%" a b)))
+;;(setq sys::*gc-debug* t)
(init-unit-test)
diff --git a/test/hashtable.l b/test/hashtable.l
new file mode 100644
index 000000000..3fb5c94e5
--- /dev/null
+++ b/test/hashtable.l
@@ -0,0 +1,105 @@
+(require :unittest "lib/llib/unittest.l")
+
+(init-unit-test)
+
+(deftest test-hashtable-delete ()
+ (let ((ht (make-hash-table :size 10)))
+ (dotimes (i (send ht :size))
+ (send ht :enter i t)
+ (send ht :delete i))
+ (assert (find (lisp::hash-table-empty ht) (hash-table-key ht))
+ "No empty members left in hash table")))
+
+(deftest test-hashtable-count ()
+ (flet ((check-count (ht)
+ (assert (= (hash-table-count ht)
+ (- (hash-table-size ht)
+ (count (lisp::hash-table-empty ht) (hash-table-key ht))
+ (count (lisp::hash-table-deleted ht) (hash-table-key ht))))
+ "Hash-table count value does not match!")
+ (when (find 'lisp::fill-count (send hash-table :slots))
+ (assert (= (ht . lisp::fill-count)
+ (- (hash-table-size ht)
+ (count (lisp::hash-table-empty ht) (hash-table-key ht))))
+ "Hash-table count value does not match!"))))
+ (let ((ht (make-hash-table :size 10 :rehash-size 2.0)))
+ (dotimes (i 6) (send ht :enter i t))
+ (check-count ht)
+ (dotimes (i 6) (send ht :delete i))
+ (check-count ht)
+ (send ht :extend)
+ (check-count ht))))
+
+(deftest test-package-unintern ()
+ (let ((pkg (make-package (symbol-pname (gensym "TEST-PACKAGE")))))
+ (dotimes (i (length (package-intsymvector pkg)))
+ (unintern
+ (intern (format nil "A~c" (+ #\A i)) pkg)
+ pkg))
+ (assert (find 0 (package-intsymvector pkg))
+ "No empty members left in package")))
+
+(deftest test-package-unintern-export ()
+ (let ((pkg (make-package (symbol-pname (gensym "TEST-PACKAGE")))))
+ (dotimes (i (length (package-intsymvector pkg)))
+ (let ((sym (intern (format nil "A~c" (+ #\A i)) pkg)))
+ (export sym pkg)
+ (unintern sym pkg)))
+ (assert (find 0 (package-intsymvector pkg))
+ "No empty internal members left in package")
+ (assert (find 0 (package-symvector pkg))
+ "No empty external members left in package")))
+
+;; (deftest test-package-enter-unintern ()
+;; (let ((pkg (make-package "TEST-PACKAGE")))
+;; (dotimes (i (length (package-intsymvector pkg)))
+;; (let ((sym (intern (format nil "~c" (+ #\A i)) *user-package*)))
+;; (send pkg :unintern (send pkg :enter sym))))
+;; (assert (find 0 (package-intsymvector pkg))
+;; "No empty members left in package")))
+
+(deftest test-package-intsymcount ()
+ (flet ((check-count (pkg)
+ (assert (= (package-intsymcount pkg)
+ (- (length (package-intsymvector pkg))
+ (count 0 (package-intsymvector pkg))))
+ "Package intsymcount value does not match!")))
+ (let* ((pkg (make-package (symbol-pname (gensym "TEST-PACKAGE"))))
+ (half-len (/ (length (package-intsymvector pkg)) 2)))
+ (dotimes (i half-len)
+ (intern (format nil "A~c" (+ #\A i)) pkg))
+ (check-count pkg)
+ (dotimes (i half-len)
+ (unintern (intern (format nil "A~c" (+ #\A i)) pkg) pkg))
+ (check-count pkg)
+ ;; assuming a rehash-size of 2.0
+ (intern (format nil "A~c" (+ #\A half-len)) pkg) ;; extend
+ (check-count pkg))))
+
+(deftest test-package-symcount ()
+ (flet ((check-count (pkg)
+ (assert (= (package-intsymcount pkg)
+ (- (length (package-intsymvector pkg))
+ (count 0 (package-intsymvector pkg))))
+ "Package intsymcount value does not match!")
+ (assert (= (package-symcount pkg)
+ (- (length (package-symvector pkg))
+ (count 0 (package-symvector pkg))))
+ "Package symcount value does not match!")))
+ (let* ((pkg (make-package (symbol-pname (gensym "TEST-PACKAGE"))))
+ (half-len (/ (length (package-intsymvector pkg)) 2)))
+ (dotimes (i half-len)
+ (let ((sym (intern (format nil "A~c" (+ #\A i)) pkg)))
+ (export sym pkg)))
+ (check-count pkg)
+ (dotimes (i half-len)
+ (unintern (intern (format nil "A~c" (+ #\A i)) pkg) pkg))
+ (check-count pkg)
+ ;; assuming a rehash-size of 2.0
+ (intern (format nil "A~c" (+ #\A half-len)) pkg) ;; extend
+ (check-count pkg))))
+
+
+(eval-when (load eval)
+ (run-all-tests)
+ (exit))
diff --git a/test/min-max.l b/test/min-max.l
index d405a723a..4a3d73a40 100644
--- a/test/min-max.l
+++ b/test/min-max.l
@@ -3,13 +3,12 @@
(init-unit-test)
(defmacro check-min-max (op ans &rest args)
- `(let (ret tret)
- (format *error-output* "check: (apply ~A ~A)~%" ,op ',args)
- (lisp::install-error-handler #'(lambda (&rest args) (throw :min-max-test :min-max-error)))
- (setq tret (catch :min-max-test
- (setq ret (funcall ,op ,@args))))
- (lisp::install-error-handler 'unittest-error) ;; revert error-handler
- (assert (equal ,ans tret)
+ `(let (ret)
+ (format *error-output* "check: ~A~%" '(funcall ,op ,@args))
+ (setq ret
+ (handler-case (funcall ,op ,@args)
+ (error () :min-max-error)))
+ (assert (equal ,ans ret)
)))
(deftest test-max
diff --git a/test/object.l b/test/object.l
index dffb835c1..2b7bc561b 100644
--- a/test/object.l
+++ b/test/object.l
@@ -1,6 +1,6 @@
(require :unittest "lib/llib/unittest.l")
-;(setq sys::*gc-hook* #'(lambda (a b) (format t "GC! free:~A total:~A~%" a b)))
+;(setq sys::*gc-debug* t)
(init-unit-test)