From 5a852b88262b17dfbe4238e71641aa92ededfbdd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=89ricles=20Lima?= Date: Sat, 21 Jul 2018 15:44:41 -0300 Subject: [PATCH 001/387] Supports short float notation --- lisp/c/reader.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/c/reader.c b/lisp/c/reader.c index 946b432a2..138ea5f0b 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -937,7 +937,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 +955,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++; From 30d537a3d3199680257bce012fbd4e6fc417f1e1 Mon Sep 17 00:00:00 2001 From: Furushchev Date: Sat, 14 Jul 2018 01:18:47 +0900 Subject: [PATCH 002/387] fix: remove/delete sequence with :end :count --- lisp/c/sequence.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/lisp/c/sequence.c b/lisp/c/sequence.c index e4b857e40..c20c274ae 100644 --- a/lisp/c/sequence.c +++ b/lisp/c/sequence.c @@ -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) From 5829cb6d7cc972ce2954efc9fe6f41de2611c0f1 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 26 Jul 2018 19:03:16 +0900 Subject: [PATCH 003/387] Fix count in substitute --- lisp/c/sequence.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/sequence.c b/lisp/c/sequence.c index c20c274ae..84403fdb3 100644 --- a/lisp/c/sequence.c +++ b/lisp/c/sequence.c @@ -814,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) From d14bf1770a155480eeb0c617e0a254ccffc809a9 Mon Sep 17 00:00:00 2001 From: Furushchev Date: Sun, 26 Nov 2017 13:36:36 +0900 Subject: [PATCH 004/387] support supplied-p for &key / &optional --- lisp/c/eval.c | 31 ++++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 400625124..b8953fc80 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -273,20 +273,24 @@ pointer formal; pointer *argp; int noarg; struct bindframe *env,*bf; -{ pointer fvar,initform; +{ 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); @@ -317,6 +321,7 @@ 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); @@ -334,12 +339,16 @@ struct bindframe *env,*bf; if (i Date: Fri, 10 Aug 2018 10:02:47 +0900 Subject: [PATCH 005/387] Add cxr functions --- lisp/l/common.l | 35 ++++++++++++++++++++++++----------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index 4c2c22520..4007e09ef 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -22,8 +22,9 @@ 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)) @@ -346,19 +347,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) From 37c389af892faff7d354511fe21bdaf186349517 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 10 Aug 2018 09:00:39 +0900 Subject: [PATCH 006/387] Fix assoc :key and add *-if *-if-not functions --- lisp/c/eus_proto.h | 2 -- lisp/c/lists.c | 47 ++++++++++---------------------------------- lisp/comp/builtins.l | 6 ++---- lisp/l/common.l | 20 +++++++++++++------ lisp/l/eusstart.l | 14 ++++++------- lisp/l/exports.l | 2 +- 6 files changed, 34 insertions(+), 57 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 5de3c9afe..bb3ea5d1d 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -285,11 +285,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*/); diff --git a/lisp/c/lists.c b/lisp/c/lists.c index 0debff1bb..193c156df 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -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; @@ -336,33 +323,21 @@ 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 (key==NIL) temp=ccar(target); - else temp=call1(ctx,key,target); - if (testnot!=NIL) compare=(call2(ctx,testnot,item,temp)==NIL); + if (rassoc==NIL) temp=ccar(target); + else temp=ccdr(target); + if (key!=NIL) temp=call1(ctx,key,temp); + 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); @@ -436,10 +411,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/comp/builtins.l b/lisp/comp/builtins.l index ad16a3aa6..fc33008d6 100644 --- a/lisp/comp/builtins.l +++ b/lisp/comp/builtins.l @@ -165,11 +165,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") diff --git a/lisp/l/common.l b/lisp/l/common.l index 4007e09ef..29e624736 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -27,7 +27,8 @@ 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)) + 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 @@ -449,14 +450,21 @@ if pos is bigger than the length of list, item is nconc'ed at the tail" (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 test-not) + (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)) diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index e69909e04..60e92c385 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -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)) @@ -263,10 +263,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 +280,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) diff --git a/lisp/l/exports.l b/lisp/l/exports.l index ef5a29800..c58531cf2 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -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)) From 23c5b19648c797a4a0404bc318ae686b14115173 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 1 Jul 2018 11:11:34 +0900 Subject: [PATCH 007/387] Implement macrolet --- lisp/c/eus_proto.h | 1 + lisp/c/makes.c | 18 +++++++++++++++++- lisp/c/specials.c | 19 +++++++++++++++++++ lisp/l/eusstart.l | 2 +- lisp/l/exports.l | 2 +- 5 files changed, 39 insertions(+), 3 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index bb3ea5d1d..a8cb1dba9 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -558,6 +558,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*/); diff --git a/lisp/c/makes.c b/lisp/c/makes.c index c511be5ce..b04bf00f6 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -16,7 +16,7 @@ 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_FUNCTION_DOCUMENTATION; /****************************************************************/ /* boxing and unboxing @@ -798,6 +798,22 @@ struct fletframe *scp,*link; ctx->fletfp=ffp; return(ffp);} +struct fletframe *makemacrolet(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; + ffp->fclosure=cons(ctx,MACRO,def); + 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; diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 18df67935..993588ef0 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -559,6 +559,24 @@ register pointer arg; throw(ctx,tag,result); error(E_NOCATCHER,tag);} +pointer MACROLET(ctx,arg) +register context *ctx; +register pointer arg; +{ register pointer fns, fn; + register struct fletframe *ffp=ctx->fletfp; + pointer result; +#ifdef SPEC_DEBUG + printf( "MACROLET:" ); hoge_print(arg); +#endif + GC_POINT; + fns=ccar(arg); + while (iscons(fns)) { + fn=ccar(fns); fns=ccdr(fns); + makemacrolet(ctx,ccar(fn),ccdr(fn),ffp,ctx->fletfp);} + result=progn(ctx,ccdr(arg)); + ctx->fletfp=ffp; + return(result);} + pointer FLET(ctx,arg) register context *ctx; register pointer arg; @@ -1309,6 +1327,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); diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index 60e92c385..5fb735d0b 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -42,7 +42,7 @@ ;; 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 diff --git a/lisp/l/exports.l b/lisp/l/exports.l index c58531cf2..85ca4fbb3 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -39,7 +39,7 @@ ;; 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 From a3d2d778b545398e8de47352e4f91b6f701c0b54 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 1 Jul 2018 12:55:25 +0900 Subject: [PATCH 008/387] Update macrolet documentation --- doc/jlatex/jcontrols.tex | 2 ++ doc/jlatex/jgenerals.tex | 20 ++++++++++---------- doc/jlatex/jintro.tex | 2 +- doc/jlatex/jsymbols.tex | 2 +- doc/latex/controls.tex | 2 ++ doc/latex/generals.tex | 20 ++++++++++---------- doc/latex/intro.tex | 2 +- doc/latex/symbols.tex | 2 +- 8 files changed, 28 insertions(+), 24 deletions(-) diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index 4472a3a97..3192dd54e 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} diff --git a/doc/jlatex/jgenerals.tex b/doc/jlatex/jgenerals.tex index 6208c1e3c..80fc52598 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}は、該当しない。 特殊書式は、文脈の評価および制御フローの管理のための 基本的な言語構造である。 インタプリタとコンパイラは、これらの構造をそれぞれ正しく処理する diff --git a/doc/jlatex/jintro.tex b/doc/jlatex/jintro.tex index d7e03bc5a..7f201ae63 100644 --- a/doc/jlatex/jintro.tex +++ b/doc/jlatex/jintro.tex @@ -144,7 +144,7 @@ \subsection{Common Lispとの互換性} \item いくつかのデータ型: bignum, character, deftype \item いくつかの特殊書式: - progv, compiler-let,macrolet + progv, compiler-let, symbol-macrolet \end{enumerate} 次の特徴は、まだ完全でない。： diff --git a/doc/jlatex/jsymbols.tex b/doc/jlatex/jsymbols.tex index 1ccb041fc..72f87f344 100644 --- a/doc/jlatex/jsymbols.tex +++ b/doc/jlatex/jsymbols.tex @@ -105,7 +105,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/latex/controls.tex b/doc/latex/controls.tex index 498569663..20f22ff75 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} diff --git a/doc/latex/generals.tex b/doc/latex/generals.tex index 279cf77a1..a2dc2e9b3 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 diff --git a/doc/latex/intro.tex b/doc/latex/intro.tex index 4a1e63a36..f7a56d38d 100644 --- a/doc/latex/intro.tex +++ b/doc/latex/intro.tex @@ -221,7 +221,7 @@ \subsection{Compatibility with Common Lisp} 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 + progv, compiler-let, symbol-macrolet \end{enumerate} Following features are incomplete: diff --git a/doc/latex/symbols.tex b/doc/latex/symbols.tex index 30304107d..98699df6c 100644 --- a/doc/latex/symbols.tex +++ b/doc/latex/symbols.tex @@ -114,7 +114,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. From 96b1caca21f18108893f943b76fb2b4798f4f2e7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 13 Jul 2018 16:41:22 +0900 Subject: [PATCH 009/387] Rename variables in macrolet --- lisp/c/specials.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 993588ef0..24fa30479 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -562,17 +562,17 @@ register pointer arg; pointer MACROLET(ctx,arg) register context *ctx; register pointer arg; -{ register pointer fns, fn; +{ register pointer macs, mac; register struct fletframe *ffp=ctx->fletfp; pointer result; #ifdef SPEC_DEBUG printf( "MACROLET:" ); hoge_print(arg); #endif GC_POINT; - fns=ccar(arg); - while (iscons(fns)) { - fn=ccar(fns); fns=ccdr(fns); - makemacrolet(ctx,ccar(fn),ccdr(fn),ffp,ctx->fletfp);} + macs=ccar(arg); + while (iscons(macs)) { + mac=ccar(macs); macs=ccdr(macs); + makemacrolet(ctx,ccar(mac),ccdr(mac),ffp,ctx->fletfp);} result=progn(ctx,ccdr(arg)); ctx->fletfp=ffp; return(result);} From cf54e4f8be800212f6860f97d142c2e0bf229eba Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 25 Jul 2018 16:47:13 +0900 Subject: [PATCH 010/387] Return variable name in defparameter and defconstant --- lisp/l/common.l | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index 29e624736..859e0353f 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -139,11 +139,15 @@ (defmacro defparameter (var init &optional (doc nil)) (unless (symbolp var) (error 20)) - `(send ',var :global ,init ,doc)) + `(progn + (send ',var :global ,init ,doc) + ',var)) (defmacro defconstant (sym val &optional doc) (unless (symbolp sym) (error 20)) - `(send ',sym :constant ,val ,doc) ) + `(progn + (send ',sym :constant ,val ,doc) + ',sym)) (defmacro dotimes (vars &rest forms) From df800fa77f26cb5813ba5c82ea8dcfb9ab76139c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 25 Jul 2018 16:37:17 +0900 Subject: [PATCH 011/387] Return T when AND has no arguments --- lisp/c/specials.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 24fa30479..d7905b69a 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -844,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 From 9e917a796394ad4e568260313466f4c144163806 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 7 Sep 2018 21:19:28 +0900 Subject: [PATCH 012/387] Fix quotient for one int argument --- lisp/c/arith.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/lisp/c/arith.c b/lisp/c/arith.c index 751aeeb4f..77911af0b 100644 --- a/lisp/c/arith.c +++ b/lisp/c/arith.c @@ -816,9 +816,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 Date: Sat, 8 Sep 2018 09:42:19 +0900 Subject: [PATCH 013/387] Fix logand return value for zero arguments --- lisp/c/arith.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/c/arith.c b/lisp/c/arith.c index 77911af0b..a72b28fa5 100644 --- a/lisp/c/arith.c +++ b/lisp/c/arith.c @@ -1158,6 +1158,8 @@ pointer LOGAND(context *ctx, int n, pointer argv[]) eusinteger_t *rbv, *bbv, *pbv; pointer b,p,r=argv[0]; + if (n==0) return(makeint(~0)); + if (isbignum(r)) { r=copy_big(r); rsize=bigsize(r); rbv=bigvec(r); p=argv[i++]; From 1cae022c54decd32379cd3d366ff63d81e5e8a7c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 8 Sep 2018 09:56:46 +0900 Subject: [PATCH 014/387] Make width an optional argument in dpb --- lisp/c/arith.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/c/arith.c b/lisp/c/arith.c index a72b28fa5..9684f2bdc 100644 --- a/lisp/c/arith.c +++ b/lisp/c/arith.c @@ -1374,11 +1374,11 @@ pointer argv[]; #else register unsigned int val,target,mask=~0; #endif - ckarg(4); + ckarg2(3,4); val=ckintval(argv[0]); target=ckintval(argv[1]); pos=ckintval(argv[2]); - width=ckintval(argv[3]); + if (n==4) width=ckintval(argv[3]); mask=mask<<(WORD_SIZE-(pos+width)); mask=mask>>(WORD_SIZE-width); val &= mask; From 007fe5a8b2c86581f74c95942ae0b9d361a277e5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 8 Sep 2018 10:28:08 +0900 Subject: [PATCH 015/387] Fix * return value for zero arguments --- lisp/c/arith.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/c/arith.c b/lisp/c/arith.c index 9684f2bdc..f13cb2dcc 100644 --- a/lisp/c/arith.c +++ b/lisp/c/arith.c @@ -703,6 +703,8 @@ register pointer argv[]; for (i=0; i Date: Fri, 12 Oct 2018 10:13:08 +0900 Subject: [PATCH 016/387] Export char functions --- lisp/l/constants.l | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/l/constants.l b/lisp/l/constants.l index 3166b5b1a..9a51f876c 100644 --- a/lisp/l/constants.l +++ b/lisp/l/constants.l @@ -16,6 +16,7 @@ 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)) From 064d9e1dec92e11ca2c9a24d072c1858ac8fccdd Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 15 Oct 2018 15:17:41 +0900 Subject: [PATCH 017/387] Raise less errors on read_cond --- lisp/c/reader.c | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/lisp/c/reader.c b/lisp/c/reader.c index 138ea5f0b..7ce89e100 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,7 +240,8 @@ 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); @@ -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) && (i='0' && ch<'8') { buf[i++] = ch; ch=readch(f);} @@ -555,6 +561,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) @@ -588,6 +595,7 @@ register pointer f; { register pointer flag,result; flag=read1(ctx,f); vpush(flag); + read_suppress=TRUE; result=read1(ctx,f); if (eval_read_cond(ctx,flag)==NIL) result=(pointer)UNBOUND; vpop(); @@ -599,6 +607,7 @@ register pointer f; { register pointer flag,result; flag=read1(ctx,f); vpush(flag); + read_suppress=TRUE; result=read1(ctx,f); if (eval_read_cond(ctx,flag)!=NIL) result=(pointer)UNBOUND; vpop(); @@ -639,7 +648,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_USER,(pointer)"no # macro defined");} if (isint(macrofunc)) { /*internal macro*/ intmac=(pointer (*)())(intval(macrofunc)); result=(*intmac)(ctx,f,val,subchar,token);} @@ -694,6 +705,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); @@ -1018,6 +1030,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); From 1070ddc4757dc90c46af1306373369a1e1ca0f65 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 19 Oct 2018 10:22:13 +0900 Subject: [PATCH 018/387] Do not suppress when read_cond evaluates --- lisp/c/reader.c | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/c/reader.c b/lisp/c/reader.c index 7ce89e100..3b8866c8b 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -595,9 +595,10 @@ register pointer f; { register pointer flag,result; flag=read1(ctx,f); vpush(flag); - read_suppress=TRUE; - 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);} @@ -607,9 +608,10 @@ register pointer f; { register pointer flag,result; flag=read1(ctx,f); vpush(flag); - read_suppress=TRUE; - 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);} From c7d65855bbe9bbd67049cf7f51a3d746ace8caf6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 18 Dec 2018 13:07:45 +0900 Subject: [PATCH 019/387] export makemacrolet --- lisp/c/eus_proto.h | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index a8cb1dba9..6af38098b 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -356,6 +356,7 @@ extern pointer compfun(context */*ctx*/, pointer /*sym*/, pointer /*mod*/, point 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 struct fletframe *makemacrolet(context */*ctx*/, pointer /*nm*/, pointer /*def*/, struct fletframe */*scp*/, struct fletframe */*link*/); 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*/); From 2a7edd12d5f5b6f37c1eeb1edb07cdba0af97495 Mon Sep 17 00:00:00 2001 From: Shingo Kitagawa Date: Thu, 8 Feb 2018 14:34:58 +0900 Subject: [PATCH 020/387] add &optional n in last --- lisp/l/common.l | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index 859e0353f..150fe335c 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -448,9 +448,10 @@ if pos is bigger than the length of list, item is nconc'ed at the tail" (nconc result1 result2))) (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 (integerp n) + (error "last &optional n must be 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)) From 016673322a20959f8448cf4e2fcceb45d2580f26 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 14 Dec 2018 10:36:16 +0900 Subject: [PATCH 021/387] Add doc and check for positive arg in 'last' function --- doc/jlatex/jsequences.tex | 4 ++-- doc/latex/sequences.tex | 4 ++-- lisp/l/common.l | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index 6780e5ffb..a32d6a711 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -272,8 +272,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}個の要素を削除したリストを返す。} diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex index ab94ba857..bba998b4a 100644 --- a/doc/latex/sequences.tex +++ b/doc/latex/sequences.tex @@ -274,8 +274,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.} diff --git a/lisp/l/common.l b/lisp/l/common.l index 150fe335c..faed0e7b2 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -449,8 +449,8 @@ if pos is bigger than the length of list, item is nconc'ed at the tail" (defun rotate-list (l) (append (cdr l) (list (car l)))) (defun last (x &optional (n 1)) - (unless (integerp n) - (error "last &optional n must be integer")) + (unless (and (integerp n) (>= n 0)) + (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))) From 0f33dd50563251cea5edc1b92f84bee294bebbdb Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 19 Apr 2019 10:34:18 +0900 Subject: [PATCH 022/387] Allow ommiting start value on 'do' --- lisp/l/common.l | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index faed0e7b2..f45f9f7da 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -236,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))) ))) @@ -255,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))) ))) From ab0bc356758bbdfcd7f871057fdeee9a2fdd9b53 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 19 Jun 2019 15:32:50 +0900 Subject: [PATCH 023/387] Update help file --- doc/latex/euslisp.hlp | 611 +++++++++++++++++++++--------------------- 1 file changed, 306 insertions(+), 305 deletions(-) diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 44148cfbf..e49c751d1 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,34 @@ "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" 5641 3 +"tagbody" 6 "controls" 6244 3 +"go" 6 "controls" 6374 3 +"prog" 3 "controls" 6589 3 +"do" 3 "controls" 6772 3 +"do*" 3 "controls" 7287 3 +"dotimes" 3 "controls" 7538 3 +"dolist" 3 "controls" 7766 3 +"until" 3 "controls" 8163 3 +"loop" 3 "controls" 8252 3 +"eq" 2 "controls" 8584 3 +"eql" 2 "controls" 8811 3 +"equal" 2 "controls" 8948 3 +"superequal" 2 "controls" 9209 3 +"null" 2 "controls" 9318 3 +"not" 2 "controls" 9406 3 +"atom" 2 "controls" 9470 3 +"every" 2 "controls" 9696 3 +"some" 2 "controls" 9860 3 +"functionp" 2 "controls" 10055 3 +"compiled-function-p" 2 "controls" 10462 3 "defclass" 3 "objects" 3223 3 "defmethod" 6 "objects" 3684 3 "defclassmethod" 3 "objects" 3859 2 @@ -191,40 +192,40 @@ "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 +"defvar" 3 "symbols" 5035 3 +"defparameter" 3 "symbols" 5254 3 +"defconstant" 3 "symbols" 5432 3 +"keywordp" 2 "symbols" 5846 3 +"constantp" 2 "symbols" 5941 3 +"documentation" 2 "symbols" 6044 3 +"gensym" 2 "symbols" 6131 3 +"gentemp" 2 "symbols" 6580 3 +"*lisp-package*" 4 "symbols" 9144 2 +"*user-package*" 4 "symbols" 9188 2 +"*unix-package*" 4 "symbols" 9232 2 +"*system-package*" 4 "symbols" 9278 2 +"*keyword-package*" 4 "symbols" 9327 2 +"find-symbol" 2 "symbols" 9370 3 +"make-symbol" 2 "symbols" 9572 3 +"intern" 2 "symbols" 9666 3 +"list-all-packages" 2 "symbols" 9967 3 +"find-package" 2 "symbols" 10040 3 +"make-package" 2 "symbols" 10148 3 +"in-package" 2 "symbols" 10353 3 +"package-name" 2 "symbols" 10489 3 +"package-nicknames" 2 "symbols" 10576 3 +"rename-package" 2 "symbols" 10652 3 +"package-use-list" 2 "symbols" 10886 3 +"packagep" 2 "symbols" 10972 3 +"use-package" 2 "symbols" 11032 3 +"unuse-package" 2 "symbols" 11228 3 +"shadow" 2 "symbols" 11332 3 +"export" 2 "symbols" 11453 3 +"unexport" 2 "symbols" 12348 3 +"import" 2 "symbols" 12487 3 +"do-symbols" 3 "symbols" 12825 3 +"do-external-symbols" 3 "symbols" 13007 3 +"do-all-symbols" 3 "symbols" 13168 3 "elt" 2 "sequences" 521 3 "length" 2 "sequences" 854 3 "subseq" 2 "sequences" 1335 3 @@ -281,107 +282,107 @@ "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 +"butlast" 2 "sequences" 10693 3 +"cons" 2 "sequences" 10800 3 +"list" 2 "sequences" 10890 3 +"list*" 2 "sequences" 10959 3 +"list-length" 2 "sequences" 11128 3 +"make-list" 2 "sequences" 11224 3 +"rplaca" 2 "sequences" 11353 3 +"rplacd" 2 "sequences" 11467 3 +"memq" 2 "sequences" 11579 3 +"member" 2 "sequences" 11672 3 +"assq" 2 "sequences" 11995 2 +"assoc" 2 "sequences" 12025 3 +"rassoc" 2 "sequences" 12303 3 +"pairlis" 2 "sequences" 12409 3 +"acons" 2 "sequences" 12638 3 +"append" 2 "sequences" 12761 3 +"nconc" 2 "sequences" 12899 3 +"subst" 2 "sequences" 13016 3 +"flatten" 2 "sequences" 13110 3 +"push" 3 "sequences" 13379 3 +"pop" 3 "sequences" 13464 3 +"pushnew" 3 "sequences" 13598 3 +"adjoin" 2 "sequences" 13833 3 +"union" 2 "sequences" 13941 3 +"subsetp" 2 "sequences" 14054 3 +"intersection" 2 "sequences" 14253 3 +"set-difference" 2 "sequences" 14408 3 +"set-exclusive-or" 2 "sequences" 14588 3 +"list-insert" 2 "sequences" 14757 3 +"copy-tree" 2 "sequences" 15024 3 +"mapc" 2 "sequences" 15263 3 +"mapcar" 2 "sequences" 15490 3 +"mapcan" 2 "sequences" 15756 3 +"array-rank-limit" 4 "sequences" 17411 2 +"array-dimension-limit" 4 "sequences" 17488 2 +"vectorp" 2 "sequences" 17618 3 +"vector" 2 "sequences" 17814 3 +"make-array" 2 "sequences" 17916 3 +"svref" 2 "sequences" 18234 3 +"aref" 2 "sequences" 18356 3 +"vector-push" 2 "sequences" 18643 3 +"vector-push-extend" 2 "sequences" 18940 3 +"arrayp" 2 "sequences" 19112 3 +"array-total-size" 2 "sequences" 19198 3 +"fill-pointer" 2 "sequences" 19285 3 +"array-rank" 2 "sequences" 19417 3 +"array-dimensions" 2 "sequences" 19488 3 +"array-dimension" 2 "sequences" 19561 3 +"bit" 2 "sequences" 19684 3 +"bit-and" 2 "sequences" 19837 2 +"bit-ior" 2 "sequences" 19887 2 +"bit-xor" 2 "sequences" 19937 2 +"bit-eqv" 2 "sequences" 19987 2 +"bit-nand" 2 "sequences" 20038 2 +"bit-nor" 2 "sequences" 20088 2 +"bit-not" 2 "sequences" 20139 3 +"digit-char-p" 2 "sequences" 20630 3 +"alpha-char-p" 2 "sequences" 20719 3 +"upper-case-p" 2 "sequences" 20851 3 +"lower-case-p" 2 "sequences" 20940 3 +"alphanumericp" 2 "sequences" 21031 3 +"char-upcase" 2 "sequences" 21204 3 +"char-downcase" 2 "sequences" 21275 3 +"char" 2 "sequences" 21337 3 +"schar" 2 "sequences" 21420 3 +"stringp" 2 "sequences" 21596 3 +"string-upcase" 2 "sequences" 21705 3 +"string-downcase" 2 "sequences" 21822 3 +"nstring-upcase" 2 "sequences" 21938 3 +"nstring-downcase" 2 "sequences" 22029 3 +"string=" 2 "sequences" 22127 3 +"string-equal" 2 "sequences" 22268 3 +"string" 2 "sequences" 22417 3 +"string<" 2 "sequences" 22917 2 +"string<=" 2 "sequences" 22950 2 +"string>" 2 "sequences" 22982 2 +"string>=" 2 "sequences" 23015 2 +"string-left-trim" 2 "sequences" 23054 2 +"string-right-trim" 2 "sequences" 23093 3 +"string-trim" 2 "sequences" 23371 3 +"substringp" 2 "sequences" 23568 3 +"make-foreign-string" 2 "sequences" 24603 3 +"sxhash" 2 "sequences" 26213 3 +"make-hash-table" 2 "sequences" 26737 3 +"gethash" 2 "sequences" 26845 3 +"remhash" 2 "sequences" 27196 3 +"maphash" 2 "sequences" 27288 3 +"hash-table-p" 2 "sequences" 27385 3 +"hash-table" 0 "sequences" 27463 4 +":hash-function" 1 "sequences" 27951 3 +"queue" 0 "sequences" 28590 4 +":init" 1 "sequences" 28659 3 +":enqueue" 1 "sequences" 28729 3 +":dequeue" 1 "sequences" 28809 3 +":empty?" 1 "sequences" 29023 3 +":length" 1 "sequences" 29082 3 +":trim" 1 "sequences" 29139 3 +":search" 1 "sequences" 29223 3 +":delete" 1 "sequences" 29380 3 +":first" 1 "sequences" 29497 3 +":last" 1 "sequences" 29575 3 "streamp" 2 "io" 483 3 "input-stream-p" 2 "io" 606 3 "output-stream-p" 2 "io" 698 3 @@ -531,148 +532,148 @@ "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 +"sys:gc" 2 "sysfunc" 4802 3 +"sys:*gc-hook*" 5 "sysfunc" 4933 2 +"sys:gctime" 2 "sysfunc" 5021 3 +"sys:alloc" 2 "sysfunc" 5224 3 +"sys:newstack" 2 "sysfunc" 5366 3 +"sys:*gc-merge*" 5 "sysfunc" 5479 2 +"sys:*gc-margin*" 5 "sysfunc" 5927 2 +"sys:reclaim" 2 "sysfunc" 6229 3 +"sys:reclaim-tree" 2 "sysfunc" 6386 3 +"sys::bktrace" 2 "sysfunc" 6492 3 +"sys:memory-report" 2 "sysfunc" 6601 3 +"sys:room" 2 "sysfunc" 6726 3 +"sys:address" 2 "sysfunc" 6825 3 +"sys:peek" 2 "sysfunc" 6994 3 +"sys:poke" 2 "sysfunc" 7987 3 +"sys:list-all-chunks" 2 "sysfunc" 8362 3 +"sys:object-size" 2 "sysfunc" 8472 3 +"unix:ptimes" 2 "sysfunc" 9583 3 +"unix:runtime" 2 "sysfunc" 9848 3 +"unix:localtime" 2 "sysfunc" 9955 3 +"unix:asctime" 2 "sysfunc" 10512 3 +"unix:getpid" 2 "sysfunc" 10785 3 +"unix:getppid" 2 "sysfunc" 10870 3 +"unix:getpgrp" 2 "sysfunc" 10945 3 +"unix:setpgrp" 2 "sysfunc" 11004 3 +"unix:getuid" 2 "sysfunc" 11061 3 +"unix:geteuid" 2 "sysfunc" 11120 3 +"unix:getgid" 2 "sysfunc" 11195 3 +"unix:getegid" 2 "sysfunc" 11262 3 +"unix:setuid" 2 "sysfunc" 11338 3 +"unix:setgid" 2 "sysfunc" 11413 3 +"unix:fork" 2 "sysfunc" 11492 3 +"unix:vfork" 2 "sysfunc" 11751 3 +"unix:exec" 2 "sysfunc" 11889 3 +"unix:wait" 2 "sysfunc" 11968 3 +"unix::exit" 2 "sysfunc" 12044 3 +"sys:*exit-hook*" 5 "sysfunc" 12180 2 +"unix:getpriority" 2 "sysfunc" 12280 3 +"unix:setpriority" 2 "sysfunc" 12452 3 +"unix:getrusage" 2 "sysfunc" 13051 3 +"unix:system" 2 "sysfunc" 14145 3 +"unix:getenv" 2 "sysfunc" 14281 3 +"unix:putenv" 2 "sysfunc" 14375 3 +"unix:sleep" 2 "sysfunc" 14542 3 +"unix:usleep" 2 "sysfunc" 14633 3 +"unix:uread" 2 "sysfunc" 14896 3 +"unix:write" 2 "sysfunc" 15353 3 +"unix:fcntl" 2 "sysfunc" 15534 2 +"unix:ioctl" 2 "sysfunc" 15581 2 +"unix:ioctl_" 2 "sysfunc" 15628 2 +"unix:ioctl_r" 2 "sysfunc" 15679 2 +"unix:ioctl_w" 2 "sysfunc" 15753 2 +"unix:ioctl_wr" 2 "sysfunc" 15828 2 +"unix:uclose" 2 "sysfunc" 15901 3 +"unix:dup" 2 "sysfunc" 15982 3 +"unix:pipe" 2 "sysfunc" 16063 3 +"unix:lseek" 2 "sysfunc" 16146 3 +"unix:link" 2 "sysfunc" 16293 3 +"unix:unlink" 2 "sysfunc" 16351 3 +"unix:mknod" 2 "sysfunc" 16489 3 +"unix:mkdir" 2 "sysfunc" 16607 3 +"unix:access" 2 "sysfunc" 16730 3 +"unix:stat" 2 "sysfunc" 16805 3 +"unix:chdir" 2 "sysfunc" 17364 3 +"unix:getwd" 2 "sysfunc" 17448 3 +"unix:chmod" 2 "sysfunc" 17507 3 +"unix:chown" 2 "sysfunc" 17595 3 +"unix:isatty" 2 "sysfunc" 17677 3 +"unix:msgget" 2 "sysfunc" 17817 3 +"unix:msgsnd" 2 "sysfunc" 17922 2 +"unix:msgrcv" 2 "sysfunc" 17982 2 +"unix:socket" 2 "sysfunc" 18037 3 +"unix:bind" 2 "sysfunc" 18302 3 +"unix:connect" 2 "sysfunc" 18460 3 +"unix:listen" 2 "sysfunc" 18564 3 +"unix:accept" 2 "sysfunc" 18763 3 +"unix:recvfrom" 2 "sysfunc" 18928 3 +"unix:sendto" 2 "sysfunc" 19323 3 +"unix:getservbyname" 2 "sysfunc" 19689 3 +"unix:gethostbyname" 2 "sysfunc" 19848 3 +"unix:syserrlist" 2 "sysfunc" 19991 3 +"unix:signal" 2 "sysfunc" 20164 3 +"unix:kill" 2 "sysfunc" 20575 3 +"unix:pause" 2 "sysfunc" 20660 3 +"unix:alarm" 2 "sysfunc" 20746 3 +"unix:ualarm" 2 "sysfunc" 20912 3 +"unix:getitimer" 2 "sysfunc" 21099 3 +"unix:setitimer" 2 "sysfunc" 21640 3 +"unix:select" 2 "sysfunc" 21986 3 +"unix:select-read-fd" 2 "sysfunc" 22828 3 +"unix:thr-self" 2 "sysfunc" 23362 3 +"unix:thr-getprio" 2 "sysfunc" 23453 3 +"unix:thr-setprio" 2 "sysfunc" 23556 3 +"unix:thr-getconcurrency" 2 "sysfunc" 23951 3 +"unix:thr-setconcurrency" 2 "sysfunc" 24097 3 +"unix:thr-create" 2 "sysfunc" 24686 3 +"unix:malloc" 2 "sysfunc" 25055 3 +"unix:free" 2 "sysfunc" 25135 3 +"unix:valloc" 2 "sysfunc" 25229 2 +"unix:mmap" 2 "sysfunc" 25259 2 +"unix:munmap" 2 "sysfunc" 25329 2 +"unix:vadvise" 2 "sysfunc" 25369 2 +"unix:tiocgetp" 2 "sysfunc" 26088 3 +"unix:tiocsetp" 2 "sysfunc" 26161 3 +"unix:tiocsetn" 2 "sysfunc" 26222 2 +"unix:tiocgetd" 2 "sysfunc" 26275 2 +"unix:tiocflush" 2 "sysfunc" 26330 3 +"unix:tiocgpgrp" 2 "sysfunc" 26390 3 +"unix:tiocspgrp" 2 "sysfunc" 26458 3 +"unix:tiocoutq" 2 "sysfunc" 26524 2 +"unix:fionread" 2 "sysfunc" 26565 2 +"unix:tiocsetc" 2 "sysfunc" 26606 2 +"unix:tioclbis" 2 "sysfunc" 26643 2 +"unix:tioclbic" 2 "sysfunc" 26680 2 +"unix:tioclset" 2 "sysfunc" 26717 2 +"unix:tioclget" 2 "sysfunc" 26754 2 +"unix:tcseta" 2 "sysfunc" 26790 3 +"unix:tcsets" 2 "sysfunc" 26869 3 +"unix:tcsetsw" 2 "sysfunc" 26937 3 +"unix:tcsetsf" 2 "sysfunc" 27066 3 +"unix:tiocsetc" 2 "sysfunc" 27245 2 +"unix:tcsetaf" 2 "sysfunc" 27284 2 +"unix:tcsetaw" 2 "sysfunc" 27323 2 +"unix:tcgeta" 2 "sysfunc" 27361 2 +"unix:tcgets" 2 "sysfunc" 27399 2 +"unix:tcgetattr" 2 "sysfunc" 27440 2 +"unix:tcsetattr" 2 "sysfunc" 27481 2 +"dbm-open" 2 "sysfunc" 27986 3 +"dbm-store" 2 "sysfunc" 28776 3 +"dbm-fetch" 2 "sysfunc" 28991 3 +"cd" 2 "sysfunc" 30431 3 +"ez" 2 "sysfunc" 30526 3 +"piped-fork" 2 "sysfunc" 30643 3 +"xfork" 2 "sysfunc" 31067 3 +"rusage" 2 "sysfunc" 31738 3 +"load-foreign" 3 "sysfunc" 38551 3 +"defforeign" 3 "sysfunc" 41109 3 +"defun-c-callable" 3 "sysfunc" 43628 3 +"pod-address" 2 "sysfunc" 44643 3 +"array-entity" 3 "sysfunc" 44908 3 +"float2double" 2 "sysfunc" 45191 3 +"double2float" 2 "sysfunc" 45410 3 "float-vector" 2 "matrix" 389 3 "float-vector-p" 2 "matrix" 660 3 "v+" 2 "matrix" 724 3 From 23375dbde3e4063288e97862113ce89f53d4f10e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 27 Mar 2019 17:00:35 +0900 Subject: [PATCH 024/387] Fix variable evaluation on 'evaluate-stream' --- lisp/l/toplevel.l | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index a821a242d..02ca3df32 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -125,28 +125,30 @@ (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) From 622760fa70c0e5453aa8234ff3cc58dd93973274 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 27 Feb 2019 12:46:05 +0900 Subject: [PATCH 025/387] Raise errors on 'assert' --- lisp/l/eusdebug.l | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/lisp/l/eusdebug.l b/lisp/l/eusdebug.l index e674b7694..7e07830c5 100644 --- a/lisp/l/eusdebug.l +++ b/lisp/l/eusdebug.l @@ -23,11 +23,9 @@ *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 "Assertation Error") &rest args) + (if (not pred) + (apply #'error message args))) (defun warning-message (color format &rest mesg) (format *error-output* "~C[3~Cm" #x1b (+ color 48)) From ca80f477002dd76acc6ddc3152a9a791abab5bcf Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 19 Jun 2019 14:47:00 +0900 Subject: [PATCH 026/387] Add name to compiled-code --- lisp/c/eus.c | 2 +- lisp/c/eus.h | 6 +++++- lisp/c/eus_proto.h | 2 +- lisp/c/leo.c | 2 +- lisp/c/makes.c | 16 +++++++++------- lisp/c/specials.c | 4 ++-- 6 files changed, 19 insertions(+), 13 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 6dc23e193..f71bd150f 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -748,7 +748,7 @@ static void initclasses() "IDLE", "WAIT"); C_THREAD=speval(THREAD); /*13*/ - CODE=basicclass("COMPILED-CODE",C_OBJECT,&codecp,4,"CODEVECTOR","QUOTEVECTOR", + CODE=basicclass("COMPILED-CODE",C_PROPOBJ,&codecp,4,"CODEVECTOR","QUOTEVECTOR", "TYPE","ENTRY"); C_CODE=speval(CODE); /*14*/ diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 97852175b..db7b67b1b 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,6 +239,7 @@ struct code { }; struct fcode { /*foreign function code*/ + pointer plist; pointer codevec; pointer quotevec; pointer subrtype; @@ -247,6 +249,7 @@ struct fcode { /*foreign function code*/ 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*/ @@ -1050,7 +1054,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); diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 6af38098b..5967146f3 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -324,7 +324,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*/); diff --git a/lisp/c/leo.c b/lisp/c/leo.c index 7db8533f6..2da91dcf4 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*/ diff --git a/lisp/c/makes.c b/lisp/c/makes.c index b04bf00f6..b597c43ed 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -279,8 +279,9 @@ register pointer in,out; 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; @@ -294,6 +295,7 @@ pointer (*f)(); #if ARM cd->c.code.entry2=makeint(((eusinteger_t)f)&0x3); #endif + if (name!=NULL) putprop(ctx,cd,name,intern(ctx,"NAME",4,keywordpkg)); return(cd);} @@ -640,7 +642,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 +653,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 @@ -687,7 +689,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 +749,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 +757,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);} diff --git a/lisp/c/specials.c b/lisp/c/specials.c index d7905b69a..4b2a9dbf0 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -180,10 +180,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)); From 6e2c9b729fb3c2016bb8ae99c32b045c71261db9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 20 Jun 2019 22:59:18 +0900 Subject: [PATCH 027/387] Use defkeyword --- lisp/c/makes.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/makes.c b/lisp/c/makes.c index b597c43ed..b4b9a86b6 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -295,7 +295,7 @@ pointer (*f)(); #if ARM cd->c.code.entry2=makeint(((eusinteger_t)f)&0x3); #endif - if (name!=NULL) putprop(ctx,cd,name,intern(ctx,"NAME",4,keywordpkg)); + if (name!=NULL) putprop(ctx,cd,name,defkeyword(ctx,"NAME")); return(cd);} From 5f28bef17b97a3cdde4e14856c8ef9078ac4cc43 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 14 Jun 2019 11:25:11 +0900 Subject: [PATCH 028/387] Add condition handling --- lib/eus.init.l | 2 +- lisp/Makefile.Alpha | 1 + lisp/Makefile.SunOS4.sub | 3 +++ lisp/Makefile.generic2 | 3 +++ lisp/l/compfiles.l | 1 + lisp/l/conditions.l | 47 ++++++++++++++++++++++++++++++++++++++++ lisp/l/eusstart.l | 1 + lisp/tool/compile_l.l | 1 + 8 files changed, 58 insertions(+), 1 deletion(-) create mode 100644 lisp/l/conditions.l 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/lisp/Makefile.Alpha b/lisp/Makefile.Alpha index b887f7574..bcb6c222c 100644 --- a/lisp/Makefile.Alpha +++ b/lisp/Makefile.Alpha @@ -137,6 +137,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.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.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/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..1bb12e660 --- /dev/null +++ b/lisp/l/conditions.l @@ -0,0 +1,47 @@ +(eval-when(load eval) + +(in-package "LISP") + +(export '(condition error fatal-error handler-bind handler-case signals)) + +(defclass condition :super propertied-object) +(defclass error :super condition) +(defclass fatal-error :super error) + +(defvar *condition-handlers* nil) + +(defmethod condition + (:init (&rest init-args &key &allow-other-keys) + (while init-args + (let* ((name (pop init-args)) + (value (pop init-args))) + (setf (get self name) value))) + self)) + +(defun add-handler (label callback) + (assert (and (classp label) (derivedp (instantiate label) condition)) + "Condition class expected!") + (assert (functionp callback) "Function expected!") + (push (cons label callback) *condition-handlers*)) + +(defmacro handler-bind (bindings &rest forms) + `(let ((*condition-handlers* (copy-list *condition-handlers*))) + ,@(mapcar #'(lambda (bind) `(add-handler ,@bind)) (reverse bindings)) + ,@forms)) + +(defmacro handler-case (form &rest cases) + (flet ((expand-case (tag arglst &rest body) + `(,tag #'(lambda ,(if arglst arglst (list (gensym))) + ;; ignore? + (throw :handler-case + (progn ,@body)))))) + `(catch :handler-case + (handler-bind + ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) cases) + ,form)))) + +(defun signals (class &rest init-args) + (let* ((inst (instantiate class)) + (handle (assoc inst *condition-handlers* :test #'derivedp))) + (if handle (funcall (cdr handle) (send* inst :init init-args))))) +) diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index 5fb735d0b..69515dfc0 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -314,6 +314,7 @@ (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")) 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*) From 17fb026fb0767183c6529fad4506827ef2d5a467 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 18 Jun 2019 16:26:05 +0900 Subject: [PATCH 029/387] Raise signal on error --- lisp/c/eus.c | 92 ++++++++++++++++++--------------------------- lisp/l/conditions.l | 19 ++++++++++ 2 files changed, 55 insertions(+), 56 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index f71bd150f..cc8e8020c 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -307,7 +307,6 @@ va_dcl register context *ctx; register struct callframe *vf; pointer msg; - int i, n; #ifdef USE_STDARG va_start(args,ec); @@ -320,18 +319,11 @@ 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"); }} + /* get call stack */ + pointer callstack=NIL; + vf=(struct callframe *)(ctx->callfp); + for (; vf->vlink != NULL; vf=vf->vlink) { + callstack = cons(ctx,vf->form,callstack);} /* error(errstr) must be error(E_USER,errstr) */ if ((int)ec < E_END) errstr=errmsg[(int)ec]; @@ -348,58 +340,46 @@ 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_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; - } + dest=(pointer)mkstream(ctx,K_OUT,makebuffer(64)); + prinx(ctx,va_arg(args,pointer),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_USER: + errstr = (char*)va_arg(args,pointer); + default: + msg=makestring(errstr,strlen(errstr));} /* call user's error handler function */ - errhandler=ctx->errhandler; - if (errhandler==NIL || errhandler==NULL) errhandler=Spevalof(ERRHANDLER); + errhandler=getfunc(ctx, intern(ctx,"SIGNALS",7,lisppkg)); + argc = 9; + pointer arglst[argc]; Spevalof(QEVALHOOK)=NIL; /* reset eval hook */ if (errhandler!=NIL) { - vpush(makeint((unsigned int)ec)); - vpush(makestring(errstr,strlen(errstr))); - 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_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; - default: argc=3; break;} - ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-argc),ctx->bindfp,argc); - ctx->vsp-=argc; - } - - /*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*/ - } + arglst[0]=speval(intern(ctx,"ERROR",5,lisppkg)); + arglst[1]=defkeyword(ctx,"ERROR-CODE"); + arglst[2]=makeint((unsigned int)ec); + arglst[3]=defkeyword(ctx,"MSG"); + arglst[4]=msg; + arglst[5]=defkeyword(ctx,"CALLSTACK"); + arglst[6]=callstack; + arglst[7]=defkeyword(ctx,"FORM"); + if (ctx->callfp) arglst[8]=ctx->callfp->form; else arglst[8]=NIL; + return(ufuncall(ctx,errhandler,errhandler,(pointer)&arglst,ctx->bindfp,argc));} +} #ifdef USE_STDARG pointer basicclass(char *name, ...) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 1bb12e660..ab38631d7 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -44,4 +44,23 @@ (let* ((inst (instantiate class)) (handle (assoc inst *condition-handlers* :test #'derivedp))) (if handle (funcall (cdr handle) (send* inst :init init-args))))) + +(defun myerror (err) + (when (and (plusp *max-callstack-depth*) (get err :callstack)) + (format *error-output* "Call Stack (most recent call last):~%") + (let ((i 0)) + (dolist (form + (nthcdr (max 0 (- (length (get err :callstack)) *max-callstack-depth*)) + (get err :callstack))) + (format *error-output* "~3D: at ~A~%" (incf i) form)))) + + (warning-message 1 "~A" (metaclass-name (class err))) + (if (get err :msg) (warning-message 1 ": ~A" (get err :msg))) + (terpri *error-output*) + (let ((*replevel* (1+ *replevel*)) + (*reptype* "E")) + (while (catch *replevel* (reploop #'toplevel-prompt)))) + (throw *replevel* t)) + +(add-handler error #'myerror) ) From 3c9b1b4106a0ea2ca6c861667f5d3b4f39aa737e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 18 Jun 2019 19:26:52 +0900 Subject: [PATCH 030/387] Add continue --- lisp/l/conditions.l | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index ab38631d7..fadb57db1 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -2,7 +2,7 @@ (in-package "LISP") -(export '(condition error fatal-error handler-bind handler-case signals)) +(export '(condition error fatal-error handler-bind handler-case signals continue)) (defclass condition :super propertied-object) (defclass error :super condition) @@ -57,10 +57,13 @@ (warning-message 1 "~A" (metaclass-name (class err))) (if (get err :msg) (warning-message 1 ": ~A" (get err :msg))) (terpri *error-output*) - (let ((*replevel* (1+ *replevel*)) + (catch (- (1+ *replevel*)) + (let ((*replevel* (1+ *replevel*)) (*reptype* "E")) (while (catch *replevel* (reploop #'toplevel-prompt)))) - (throw *replevel* t)) + (throw *replevel* t))) + +(defun continue (val) (throw (- *replevel*) val)) (add-handler error #'myerror) ) From 6a6de4f1bd31a81b6281d03a876539f660f432bf Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 19 Jun 2019 12:11:29 +0900 Subject: [PATCH 031/387] Add next-handler --- lisp/c/eus.c | 2 ++ lisp/l/conditions.l | 36 ++++++++++++++++++++++-------------- 2 files changed, 24 insertions(+), 14 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index cc8e8020c..de931d52a 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -119,6 +119,7 @@ pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; pointer TOPLEVEL,QEVALHOOK,ERRHANDLER,FATALERROR; +pointer CONDITIONHANDLER; pointer QGCHOOK, QEXITHOOK; pointer QUNBOUND,QDEBUG; pointer QTHREADS; /* system:*threads* */ @@ -639,6 +640,7 @@ static void initsymbols() QREADTABLE=deflocal(ctx,"*READTABLE*",NIL,lisppkg); TOPLEVEL=defvar(ctx,"*TOPLEVEL*",NIL,lisppkg); ERRHANDLER=deflocal(ctx,"*ERROR-HANDLER*",NIL,lisppkg); + CONDITIONHANDLER=deflocal(ctx,"*CONDITION-HANDLER*",NIL,lisppkg); QEVALHOOK=deflocal(ctx,"*EVALHOOK*",NIL,lisppkg); QUNBOUND=intern(ctx,"*UNBOUND*",9,lisppkg); RANDSTATE=deflocal(ctx,"*RANDOM-STATE*",UNBOUND,lisppkg); diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index fadb57db1..e3e6a3540 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -2,14 +2,12 @@ (in-package "LISP") -(export '(condition error fatal-error handler-bind handler-case signals continue)) +(export '(condition error fatal-error handler-bind handler-case signals continue next-handler)) (defclass condition :super propertied-object) (defclass error :super condition) (defclass fatal-error :super error) -(defvar *condition-handlers* nil) - (defmethod condition (:init (&rest init-args &key &allow-other-keys) (while init-args @@ -22,10 +20,10 @@ (assert (and (classp label) (derivedp (instantiate label) condition)) "Condition class expected!") (assert (functionp callback) "Function expected!") - (push (cons label callback) *condition-handlers*)) + (push (cons label callback) *condition-handler*)) (defmacro handler-bind (bindings &rest forms) - `(let ((*condition-handlers* (copy-list *condition-handlers*))) + `(let ((*condition-handler* (copy-list *condition-handler*))) ,@(mapcar #'(lambda (bind) `(add-handler ,@bind)) (reverse bindings)) ,@forms)) @@ -40,10 +38,15 @@ ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) cases) ,form)))) -(defun signals (class &rest init-args) - (let* ((inst (instantiate class)) - (handle (assoc inst *condition-handlers* :test #'derivedp))) - (if handle (funcall (cdr handle) (send* inst :init init-args))))) +(defun signals (obj &rest init-args) + (if (classp obj) (setq obj (instantiate obj))) + (if init-args (send* obj :init init-args)) + (assert (derivedp obj condition) "Condition class expected!") + (block signals + (dolist (handle *condition-handler*) + (when (derivedp obj (car handle)) + (catch :next-handler + (return-from signals (funcall (cdr handle) obj))))))) (defun myerror (err) (when (and (plusp *max-callstack-depth*) (get err :callstack)) @@ -54,16 +57,21 @@ (get err :callstack))) (format *error-output* "~3D: at ~A~%" (incf i) form)))) - (warning-message 1 "~A" (metaclass-name (class err))) - (if (get err :msg) (warning-message 1 ": ~A" (get err :msg))) + (warning-message 1 "~A" (string-upcase (metaclass-name (class err)))) + (if (get err :msg) (format *error-output* ": ~A" (get err :msg))) (terpri *error-output*) (catch (- (1+ *replevel*)) (let ((*replevel* (1+ *replevel*)) - (*reptype* "E")) - (while (catch *replevel* (reploop #'toplevel-prompt)))) - (throw *replevel* t))) + (*reptype* "E")) + ;; do not carry handlers through the error stack + ;; i.e. restore previous global `*condition-handler*' + (let ((old (assoc '*condition-handler* (sys:list-all-special-bindings)))) + (if old (setq *condition-handler* (cdr old)))) + (while (catch *replevel* (reploop #'toplevel-prompt)))) + (throw *replevel* t))) (defun continue (val) (throw (- *replevel*) val)) +(defun next-handler () (throw :next-handler nil)) (add-handler error #'myerror) ) From eda0079833641e455e013447e86a63bf5e7249ca Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 20 Jun 2019 14:09:17 +0900 Subject: [PATCH 032/387] Initialize error class from c --- lisp/c/eus.c | 39 ++++++++++++++++++++++++--------------- lisp/c/eus.h | 1 + lisp/l/conditions.l | 4 ---- 3 files changed, 25 insertions(+), 19 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index de931d52a..5767420d5 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -95,6 +95,10 @@ cixpair extnumcp; cixpair ratiocp; cixpair complexcp; cixpair bignumcp; +/* conditions */ +cixpair conditioncp; +cixpair errorcp; +cixpair fatalerrorcp; struct built_in_cid builtinclass[64]; @@ -147,6 +151,7 @@ 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, C_FATALERROR; /*class names*/ pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL, @@ -304,10 +309,9 @@ va_dcl va_list args; pointer errhandler; register char *errstr; - register int argc; register context *ctx; register struct callframe *vf; - pointer msg; + pointer msg,form,callstack; #ifdef USE_STDARG va_start(args,ec); @@ -321,7 +325,7 @@ va_dcl ctx=euscontexts[thr_self()]; /* get call stack */ - pointer callstack=NIL; + callstack=NIL; vf=(struct callframe *)(ctx->callfp); for (; vf->vlink != NULL; vf=vf->vlink) { callstack = cons(ctx,vf->form,callstack);} @@ -364,22 +368,22 @@ va_dcl default: msg=makestring(errstr,strlen(errstr));} + /* get form */ + if (ctx->callfp) form=ctx->callfp->form; else form=NIL; + /* call user's error handler function */ errhandler=getfunc(ctx, intern(ctx,"SIGNALS",7,lisppkg)); - argc = 9; - pointer arglst[argc]; + + pointer errobj,arglst; + errobj=makeobject(C_ERROR); + putprop(ctx,errobj,msg,defkeyword(ctx,"MSG")); + putprop(ctx,errobj,callstack,defkeyword(ctx,"CALLSTACK")); + putprop(ctx,errobj,form,defkeyword(ctx,"FORM")); + arglst=cons(ctx,errobj,NIL); + Spevalof(QEVALHOOK)=NIL; /* reset eval hook */ if (errhandler!=NIL) { - arglst[0]=speval(intern(ctx,"ERROR",5,lisppkg)); - arglst[1]=defkeyword(ctx,"ERROR-CODE"); - arglst[2]=makeint((unsigned int)ec); - arglst[3]=defkeyword(ctx,"MSG"); - arglst[4]=msg; - arglst[5]=defkeyword(ctx,"CALLSTACK"); - arglst[6]=callstack; - arglst[7]=defkeyword(ctx,"FORM"); - if (ctx->callfp) arglst[8]=ctx->callfp->form; else arglst[8]=NIL; - return(ufuncall(ctx,errhandler,errhandler,(pointer)&arglst,ctx->bindfp,argc));} + return(ufuncall(ctx,errhandler,errhandler,arglst,ctx->bindfp,-1));} } #ifdef USE_STDARG @@ -804,6 +808,11 @@ static void initclasses() BIGNUM=basicclass("BIGNUM", C_EXTNUM, &bignumcp, 2, "SIZE", "BV"); C_BIGNUM=speval(BIGNUM); +/* conditions */ + C_CONDITION=speval(basicclass("CONDITION",C_PROPOBJ,&conditioncp,0)); + C_ERROR=speval(basicclass("ERROR",C_CONDITION,&errorcp,0)); + C_FATALERROR=speval(basicclass("FATAL-ERROR",C_ERROR,&fatalerrorcp,0)); + for (i=0;i Date: Thu, 20 Jun 2019 18:08:08 +0900 Subject: [PATCH 033/387] Add error classes --- lisp/c/eus.c | 48 ++++++++++++++++++++++++++++++++++++++++++++- lisp/l/conditions.l | 10 ++++++---- 2 files changed, 53 insertions(+), 5 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 5767420d5..fee0402d4 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -99,6 +99,9 @@ cixpair bignumcp; cixpair conditioncp; cixpair errorcp; cixpair fatalerrorcp; +/* errors */ +cixpair syntaxerrorcp, programerrorcp, nameerrorcp; +cixpair typeerrorcp, indexerrorcp, ioerrorcp; struct built_in_cid builtinclass[64]; @@ -161,6 +164,10 @@ pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE; pointer FOREIGNCODE,ARRAY,BITVECTOR; pointer EXTNUM, RATIO, COMPLEX, BIGNUM; +/*error classes*/ +pointer C_SYNTAXERROR, C_PROGRAMERROR, C_NAMEERROR; +pointer C_TYPEERROR, C_INDEXERROR, C_IOERROR; + /*toplevel & evaluation control*/ int intsig,intcode; int ehbypass; @@ -375,7 +382,40 @@ va_dcl errhandler=getfunc(ctx, intern(ctx,"SIGNALS",7,lisppkg)); pointer errobj,arglst; - errobj=makeobject(C_ERROR); + switch((unsigned int)ec) { + // SYNTAX ERROR + case E_ILLFUNC: case E_ILLCH: case E_READ: case E_WRITE: + case E_LAMBDA: case E_PARAMETER: case E_FORMATSTRING: case E_NOOBJ: + case E_DECLARE: case E_DECLFORM: case E_KEYPARAM: case E_NOKEYPARAM: + errobj=makeobject(C_SYNTAXERROR); break; + // PROGRAM ERROR + case E_MISMATCHARG: case E_NOCATCHER: case E_NOBLOCK: case E_PKGNAME: + case E_MULTIDECL: case E_SYMBOLCONFLICT: case E_LONGSTRING: case E_CHARRANGE: + case E_CLASSOVER: case E_DUPOBJVAR: case E_INSTANTIATE: case E_CIRCULAR: + errobj=makeobject(C_PROGRAMERROR); break; + // NAME ERROR + case E_UNBOUND: case E_UNDEF: case E_EXTSYMBOL: case E_NOMETHOD: + case E_NOPACKAGE: case E_NOOBJVAR: case E_SHARPMACRO: + errobj=makeobject(C_NAMEERROR); break; + // TYPE ERROR + case E_NOSYMBOL: case E_NOLIST: case E_STREAM: case E_NOSTRING: + case E_NONUMBER: case E_NOINT: case E_NOCLASS: case E_NOOBJECT: + case E_NOMACRO: case E_NOSEQ: case E_NOARRAY: case E_NOVECTOR: + case E_NOINTVECTOR: case E_FLOATVECTOR: case E_BITVECTOR: + case E_TYPEMISMATCH: case E_SETCONST: case E_NOVARIABLE: + case E_ALIST: case E_NOSUPER: case E_ROTAXIS: case E_SOCKET: + errobj=makeobject(C_TYPEERROR); break; + // INDEX ERROR + case E_ARRAYINDEX: case E_VECINDEX: case E_SEQINDEX: + case E_STARTEND: case E_VECSIZE: case E_ARRAYDIMENSION: + errobj=makeobject(C_INDEXERROR); break; + // IO ERROR + case E_IODIRECTION: case E_OPENFILE: case E_EOF: + case E_READLABEL: case E_READFVECTOR: case E_READOBJECT: + errobj=makeobject(C_IOERROR); break; + default: + errobj=makeobject(C_ERROR);} + putprop(ctx,errobj,msg,defkeyword(ctx,"MSG")); putprop(ctx,errobj,callstack,defkeyword(ctx,"CALLSTACK")); putprop(ctx,errobj,form,defkeyword(ctx,"FORM")); @@ -812,6 +852,12 @@ static void initclasses() C_CONDITION=speval(basicclass("CONDITION",C_PROPOBJ,&conditioncp,0)); C_ERROR=speval(basicclass("ERROR",C_CONDITION,&errorcp,0)); C_FATALERROR=speval(basicclass("FATAL-ERROR",C_ERROR,&fatalerrorcp,0)); + C_SYNTAXERROR=speval(basicclass("SYNTAX-ERROR",C_ERROR,&syntaxerrorcp,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_INDEXERROR=speval(basicclass("INDEX-ERROR",C_ERROR,&indexerrorcp,0)); + C_IOERROR=speval(basicclass("IO-ERROR",C_ERROR,&ioerrorcp,0)); for (i=0;i Date: Thu, 20 Jun 2019 18:08:40 +0900 Subject: [PATCH 034/387] Do not raise fatal errors on carof/cdrof --- lisp/c/eus.h | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 7dc0ff089..c3f8a2af9 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -718,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) From a8193c3ee3eead12fb23802818d6eea9a27d0a5a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 22 Jun 2019 18:34:59 +0900 Subject: [PATCH 035/387] Update error classes --- lisp/c/arith.c | 4 +- lisp/c/eus.c | 177 ++++++++++++++++++++++++---------------------- lisp/c/eus.h | 132 ++++++++++++++++++---------------- lisp/c/eval.c | 28 ++++---- lisp/c/leo.c | 6 +- lisp/c/lists.c | 2 +- lisp/c/reader.c | 26 +++---- lisp/c/specials.c | 5 +- 8 files changed, 197 insertions(+), 183 deletions(-) diff --git a/lisp/c/arith.c b/lisp/c/arith.c index f13cb2dcc..2f43e0b20 100644 --- a/lisp/c/arith.c +++ b/lisp/c/arith.c @@ -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 */ diff --git a/lisp/c/eus.c b/lisp/c/eus.c index fee0402d4..80a94dfd3 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -100,8 +100,8 @@ cixpair conditioncp; cixpair errorcp; cixpair fatalerrorcp; /* errors */ -cixpair syntaxerrorcp, programerrorcp, nameerrorcp; -cixpair typeerrorcp, indexerrorcp, ioerrorcp; +cixpair argumenterrorcp, programerrorcp, nameerrorcp; +cixpair typeerrorcp, valueerrorcp, indexerrorcp, ioerrorcp; struct built_in_cid builtinclass[64]; @@ -165,8 +165,8 @@ pointer FOREIGNCODE,ARRAY,BITVECTOR; pointer EXTNUM, RATIO, COMPLEX, BIGNUM; /*error classes*/ -pointer C_SYNTAXERROR, C_PROGRAMERROR, C_NAMEERROR; -pointer C_TYPEERROR, C_INDEXERROR, C_IOERROR; +pointer C_ARGUMENTERROR, C_PROGRAMERROR, C_NAMEERROR; +pointer C_TYPEERROR, C_VALUEERROR, C_INDEXERROR, C_IOERROR; /*toplevel & evaluation control*/ int intsig,intcode; @@ -202,6 +202,7 @@ jmp_buf topjbuf; */ char *errmsg[100]={ +/* FATAL ERROR */ "", /*0*/ "stack overflow", /*1 errcode=1..10 are fatal errors*/ "allocation", /*2*/ @@ -212,72 +213,74 @@ 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", +/* ARGUMENT 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", "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 */ + "", + "illegal start/end index", "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 */ "", "E_END", }; @@ -357,9 +360,9 @@ va_dcl 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_EXTSYMBOL: case E_SYMBOLCONFLICT: dest=(pointer)mkstream(ctx,K_OUT,makebuffer(64)); prinx(ctx,va_arg(args,pointer),dest); msgstr=(char*)malloc(2+ strlen(errstr) + intval(dest->c.stream.count)); @@ -383,36 +386,37 @@ va_dcl pointer errobj,arglst; switch((unsigned int)ec) { - // SYNTAX ERROR - case E_ILLFUNC: case E_ILLCH: case E_READ: case E_WRITE: - case E_LAMBDA: case E_PARAMETER: case E_FORMATSTRING: case E_NOOBJ: - case E_DECLARE: case E_DECLFORM: case E_KEYPARAM: case E_NOKEYPARAM: - errobj=makeobject(C_SYNTAXERROR); break; + // 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_MISMATCHARG: case E_NOCATCHER: case E_NOBLOCK: case E_PKGNAME: - case E_MULTIDECL: case E_SYMBOLCONFLICT: case E_LONGSTRING: case E_CHARRANGE: - case E_CLASSOVER: case E_DUPOBJVAR: case E_INSTANTIATE: case E_CIRCULAR: - errobj=makeobject(C_PROGRAMERROR); break; + 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_UNBOUND: case E_UNDEF: case E_EXTSYMBOL: case E_NOMETHOD: - case E_NOPACKAGE: case E_NOOBJVAR: case E_SHARPMACRO: - errobj=makeobject(C_NAMEERROR); break; + 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_NOSYMBOL: case E_NOLIST: case E_STREAM: case E_NOSTRING: - case E_NONUMBER: case E_NOINT: case E_NOCLASS: case E_NOOBJECT: - case E_NOMACRO: case E_NOSEQ: case E_NOARRAY: case E_NOVECTOR: - case E_NOINTVECTOR: case E_FLOATVECTOR: case E_BITVECTOR: - case E_TYPEMISMATCH: case E_SETCONST: case E_NOVARIABLE: - case E_ALIST: case E_NOSUPER: case E_ROTAXIS: case E_SOCKET: - errobj=makeobject(C_TYPEERROR); break; + 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_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_ARRAYINDEX: case E_VECINDEX: case E_SEQINDEX: - case E_STARTEND: case E_VECSIZE: case E_ARRAYDIMENSION: - errobj=makeobject(C_INDEXERROR); break; + case E_INDEX_ERROR: case E_STARTEND: case E_ARRAYDIMENSION: case E_ARRAYINDEX: + case E_VECSIZE: case E_VECINDEX: case E_SEQINDEX: + errobj=makeobject(C_INDEXERROR); break; // IO ERROR - case E_IODIRECTION: case E_OPENFILE: case E_EOF: - case E_READLABEL: case E_READFVECTOR: case E_READOBJECT: - errobj=makeobject(C_IOERROR); break; + 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; default: errobj=makeobject(C_ERROR);} @@ -852,10 +856,11 @@ static void initclasses() C_CONDITION=speval(basicclass("CONDITION",C_PROPOBJ,&conditioncp,0)); C_ERROR=speval(basicclass("ERROR",C_CONDITION,&errorcp,0)); C_FATALERROR=speval(basicclass("FATAL-ERROR",C_ERROR,&fatalerrorcp,0)); - C_SYNTAXERROR=speval(basicclass("SYNTAX-ERROR",C_ERROR,&syntaxerrorcp,0)); + 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)); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index c3f8a2af9..d838454c4 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -939,71 +939,79 @@ 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_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*/ + +/* INDEX ERROR */ + E_INDEX_ERROR, + E_STARTEND, + 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, /* the following error is added by APT */ E_USER, diff --git a/lisp/c/eval.c b/lisp/c/eval.c index b8953fc80..01815b8ba 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -120,11 +120,11 @@ register pointer sym,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,o,v);} /***** special variable binding *****/ @@ -197,7 +197,7 @@ register pointer var,val; struct bindframe *lex,*declscope; { register struct bindframe *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) @@ -225,7 +225,7 @@ struct bindframe *env; 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)) { @@ -1467,19 +1467,19 @@ register int noarg; else return((*subr)(ctx,noarg,args,0)); break; case (eusinteger_t)SUBR_MACRO:/* ???? */ - if (noarg>=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; @@ -1525,7 +1525,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?*/ @@ -1539,7 +1539,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 @@ -1595,7 +1595,7 @@ 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); @@ -1606,9 +1606,9 @@ int noarg; /* ctx->fletfp=(struct fletframe *)intval(ccar(func)); */ fenv=(struct fletframe *)intval(ccar(func)); 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; @@ -1619,7 +1619,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); @@ -1633,7 +1633,7 @@ int noarg; /* check return barrier */ #endif return(result);} - else error(E_ILLFUNC); + else error(E_NOFUNCTION); } pointer eval(ctx,form) diff --git a/lisp/c/leo.c b/lisp/c/leo.c index 2da91dcf4..01f2441ed 100644 --- a/lisp/c/leo.c +++ b/lisp/c/leo.c @@ -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; @@ -493,9 +493,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; diff --git a/lisp/c/lists.c b/lisp/c/lists.c index 193c156df..f9d1e185e 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -309,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) diff --git a/lisp/c/reader.c b/lisp/c/reader.c index 3b8866c8b..88b9d2bc1 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -318,7 +318,7 @@ register int size; while (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)) { @@ -344,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); @@ -370,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++; @@ -394,15 +394,15 @@ register pointer s; /*input stream*/ Char ch; ch=nextch(ctx,s); - if (ch!='(') error(E_READOBJECT); + if (ch!='(') error(E_NODELIMITER); 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;} @@ -431,12 +431,12 @@ register pointer s; /*input stream*/ Char ch; ch=nextch(ctx,s); - if (ch!='(') error(E_READOBJECT); + if (ch!='(') error(E_NODELIMITER); 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); @@ -810,9 +810,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);} diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 4b2a9dbf0..c809f647a 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -149,7 +149,7 @@ pointer 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);} + else error(E_NOFUNCTION);} pointer MACEXPAND2(ctx,n,argv) register context *ctx; @@ -215,6 +215,7 @@ register pointer *argv; } printf( "\n" ); #endif + if(!iscons(argv[1])) error(E_NOLIST); while (islist(argv[1])) { i=1; while (i Date: Sat, 22 Jun 2019 22:32:13 +0900 Subject: [PATCH 036/387] Update user error function --- lisp/c/eus.c | 8 +++++--- lisp/c/lispio.c | 27 ++++++++++++++++++++------- lisp/l/common.l | 8 ++++---- lisp/l/conditions.l | 6 +++--- lisp/l/packsym.l | 6 +++--- 5 files changed, 35 insertions(+), 20 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 80a94dfd3..abce76795 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -322,6 +322,7 @@ va_dcl register context *ctx; register struct callframe *vf; pointer msg,form,callstack; + pointer errobj,arglst; #ifdef USE_STDARG va_start(args,ec); @@ -374,6 +375,9 @@ va_dcl free(msgstr); break; case E_USER: + errobj = (pointer)va_arg(args,pointer); + 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: errstr = (char*)va_arg(args,pointer); default: msg=makestring(errstr,strlen(errstr));} @@ -384,7 +388,6 @@ va_dcl /* call user's error handler function */ errhandler=getfunc(ctx, intern(ctx,"SIGNALS",7,lisppkg)); - pointer errobj,arglst; switch((unsigned int)ec) { // ARGUMENT ERROR case E_ARGUMENT_ERROR: case E_MISMATCHARG: case E_PARAMETER: @@ -417,8 +420,7 @@ va_dcl 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; - default: - errobj=makeobject(C_ERROR);} + } putprop(ctx,errobj,msg,defkeyword(ctx,"MSG")); putprop(ctx,errobj,callstack,defkeyword(ctx,"CALLSTACK")); diff --git a/lisp/c/lispio.c b/lisp/c/lispio.c index 91d87f793..8f13521ea 100644 --- a/lisp/c/lispio.c +++ b/lisp/c/lispio.c @@ -567,15 +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])) { + + 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 (i=0; ic.str.chars),argv[1]);} - else error((enum errorcode)(ckintval(argv[0])),argv[1]);} + for (; ic.str.chars));} pointer INSTALL_ERRHANDLER(ctx,n,argv) register context *ctx; diff --git a/lisp/l/common.l b/lisp/l/common.l index f45f9f7da..88669720c 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -124,7 +124,7 @@ (list 'setf var h)) (defmacro defvar (var &optional (init nil) (doc nil)) - (unless (symbolp var) (error 20)) + (unless (symbolp var) (error "symbol expected")) `(when (eql (send ',var :vtype) 1) (send ',var :vtype 2) (if (not (boundp ',var)) @@ -132,19 +132,19 @@ ',var)) (defmacro deflocal (var &optional (init nil) (doc nil)) - (unless (symbolp var) (error 20)) + (unless (symbolp var) (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 "symbol expected")) `(progn (send ',var :global ,init ,doc) ',var)) (defmacro defconstant (sym val &optional doc) - (unless (symbolp sym) (error 20)) + (unless (symbolp sym) (error "symbol expected")) `(progn (send ',sym :constant ,val ,doc) ',sym)) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 0b7e569ca..7f4e94443 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -14,8 +14,8 @@ (defun add-handler (label callback) (assert (and (classp label) (derivedp (instantiate label) condition)) - "Condition class expected!") - (assert (functionp callback) "Function expected!") + "condition class expected") + (assert (functionp callback) "function expected") (push (cons label callback) *condition-handler*)) (defmacro handler-bind (bindings &rest forms) @@ -37,7 +37,7 @@ (defun signals (obj &rest init-args) (if (classp obj) (setq obj (instantiate obj))) (if init-args (send* obj :init init-args)) - (assert (derivedp obj condition) "Condition class expected!") + (assert (derivedp obj condition) "condition class expected") (block signals (dolist (handle *condition-handler*) (when (derivedp obj (car handle)) diff --git a/lisp/l/packsym.l b/lisp/l/packsym.l index 7ed3cc73c..2702c2f26 100644 --- a/lisp/l/packsym.l +++ b/lisp/l/packsym.l @@ -25,7 +25,7 @@ (:pname () pname) (:func () function) (:value (val) - (if (= vtype 0) (error 11 self)) + (if (= vtype 0) (error "attempted to set constant ~a" self)) (setq value val)) (:constant (c &optional (doc nil)) (when (= vtype 0) @@ -41,7 +41,7 @@ value c) self) (:special (v &optional (doc nil)) ;thread local special var - (if (= vtype 0) (error 11 self)) + (if (= vtype 0) (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,7 +67,7 @@ (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 "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"))) From c09a3b5e1367b57aabc6838814748ef126cdd6d2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 26 Jun 2019 08:59:08 +0900 Subject: [PATCH 037/387] Add types for lisp errors --- lisp/comp/comp.l | 6 +++--- lisp/image/jpeg/eusjpeg.l | 2 +- lisp/image/pbmfile.l | 24 ++++++++++++------------ lisp/image/piximage.l | 4 ++-- lisp/l/array.l | 10 +++++----- lisp/l/async.l | 2 +- lisp/l/common.l | 30 +++++++++++++++--------------- lisp/l/coordinates.l | 8 ++++---- lisp/l/eusdebug.l | 4 ++-- lisp/l/eusforeign.l | 16 ++++++++-------- lisp/l/hashtab.l | 2 +- lisp/l/loader.l | 16 ++++++++-------- lisp/l/mathtran.l | 4 ++-- lisp/l/packsym.l | 28 ++++++++++++++-------------- lisp/l/stream.l | 10 +++++----- lisp/l/string.l | 20 +++++++------------- lisp/opengl/src/gltexture.l | 6 +++--- lisp/opengl/src/glview.l | 6 +++--- lisp/xwindow/Xcolor.l | 12 ++++++------ lisp/xwindow/Xeus.l | 2 +- lisp/xwindow/Xgraphics.l | 2 +- lisp/xwindow/Xitem.l | 2 +- 22 files changed, 105 insertions(+), 111 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index dfb725953..122f699f1 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -85,7 +85,7 @@ (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)))) @@ -312,7 +312,7 @@ v)) (:bind (id binding offset &optional (keyvarp nil)) (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 @@ -1263,7 +1263,7 @@ (when (null (probe-file file)) (setq file (merge-pathnames ".l" file)) (if (null (probe-file file)) - (error "file ~A not found~%" file))) + (error io-error "file ~A not found~%" file))) (warn "compiling file: ~A~%" (namestring file)) (setq ins (open file)) (setq *defun-list* nil) 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..de7c8b15b 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) @@ -104,9 +104,9 @@ (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)) @@ -134,7 +134,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 +148,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..6adbe2037 100644 --- a/lisp/l/async.l +++ b/lisp/l/async.l @@ -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 88669720c..8f832ce64 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -124,7 +124,7 @@ (list 'setf var h)) (defmacro defvar (var &optional (init nil) (doc nil)) - (unless (symbolp var) (error "symbol expected")) + (unless (symbolp var) (error type-error "symbol expected")) `(when (eql (send ',var :vtype) 1) (send ',var :vtype 2) (if (not (boundp ',var)) @@ -132,19 +132,19 @@ ',var)) (defmacro deflocal (var &optional (init nil) (doc nil)) - (unless (symbolp var) (error "symbol expected")) + (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 "symbol expected")) + (unless (symbolp var) (error type-error "symbol expected")) `(progn (send ',var :global ,init ,doc) ',var)) (defmacro defconstant (sym val &optional doc) - (unless (symbolp sym) (error "symbol expected")) + (unless (symbolp sym) (error type-error "symbol expected")) `(progn (send ',sym :constant ,val ,doc) ',sym)) @@ -332,10 +332,10 @@ ;; 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 @@ -568,7 +568,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)))) @@ -790,7 +790,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) @@ -798,11 +798,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)) @@ -877,7 +877,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)) @@ -1074,9 +1074,9 @@ 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)) 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 7e07830c5..498239cc2 100644 --- a/lisp/l/eusdebug.l +++ b/lisp/l/eusdebug.l @@ -167,7 +167,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) @@ -404,7 +404,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 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/hashtab.l b/lisp/l/hashtab.l index 525b9ce5d..da1807331 100644 --- a/lisp/l/hashtab.l +++ b/lisp/l/hashtab.l @@ -225,7 +225,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/packsym.l b/lisp/l/packsym.l index 2702c2f26..f1d429b07 100644 --- a/lisp/l/packsym.l +++ b/lisp/l/packsym.l @@ -25,7 +25,7 @@ (:pname () pname) (:func () function) (:value (val) - (if (= vtype 0) (error "attempted to set constant ~a" self)) + (if (= vtype 0) (error type-error "attempted to set constant ~a" self)) (setq value val)) (:constant (c &optional (doc nil)) (when (= vtype 0) @@ -41,7 +41,7 @@ value c) self) (:special (v &optional (doc nil)) ;thread local special var - (if (= vtype 0) (error "attempted to set constant ~a" 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 +67,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 "attempted to set constant ~a" 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 +125,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,7 +147,7 @@ (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))) (svset intsymvector hash sym) @@ -155,7 +155,7 @@ 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 +163,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 +171,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)) @@ -188,7 +188,7 @@ )) (: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 +239,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 +255,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/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..8aa3a2554 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,12 +64,6 @@ (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) @@ -92,7 +86,7 @@ (defun nstring-downcase (str &key (start 0) (end (length str))) (declare (type integer start end) (string str)) - (if (not (stringp str)) (error "no string")) + (if (not (stringp str)) (error type-error "string expected")) (while (< start end) (setchar str start (char-downcase (char str start))) (inc start)) @@ -100,7 +94,7 @@ (defun nstring-upcase (str &key (start 0) (end (length str))) (declare (type integer start end)) - (if (not (stringp str)) (error "no string")) + (if (not (stringp str)) (error type-error "string expected")) (while (< start end) (setchar str start (char-upcase (char str start))) (inc start)) @@ -280,7 +274,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 +328,7 @@ ; (merge-pathnames ; (pathname-name pathnam) target-dir) ) - (t (error "cannot locate the file")))) ) + (t (error io-error "cannot locate the file")))) ) ) @@ -383,7 +377,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 +415,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/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/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/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)) From 8057b1f219a0d15880a966d10a59431ab58da51d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 26 Jun 2019 10:58:31 +0900 Subject: [PATCH 038/387] Update euserror and install-error-handler --- lisp/c/eus.h | 1 - lisp/c/eus_proto.h | 1 - lisp/c/lispio.c | 9 --------- lisp/c/makes.c | 1 - lisp/l/conditions.l | 21 ++++++++++++++------- lisp/l/par.l | 9 ++++----- lisp/l/toplevel.l | 18 ------------------ lisp/xwindow/Xevent.l | 11 +++++------ 8 files changed, 23 insertions(+), 48 deletions(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index d838454c4..db0d157ea 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -538,7 +538,6 @@ typedef struct { struct protectframe *protfp; struct fletframe *fletfp, *newfletfp; pointer lastalloc; - pointer errhandler; pointer threadobj; struct methdef *methcache; struct buddyfree *thr_buddy; diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 5967146f3..f06760321 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -257,7 +257,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*/); diff --git a/lisp/c/lispio.c b/lisp/c/lispio.c index 8f13521ea..b0c9a264f 100644 --- a/lisp/c/lispio.c +++ b/lisp/c/lispio.c @@ -590,14 +590,6 @@ register pointer *argv; else error(E_NOSTRING); error(E_USER,errobj,(pointer)(msg->c.str.chars));} -pointer INSTALL_ERRHANDLER(ctx,n,argv) -register context *ctx; -register int n; -register pointer *argv; -{ ckarg(1); - ctx->errhandler=argv[0]; - return(argv[0]);} - void lispio(ctx,mod) register context *ctx; @@ -630,6 +622,5 @@ pointer mod; defunpkg(ctx,"RESET-READTABLE",mod,RESETREADTABLE,syspkg); defun(ctx,"FORMAT",mod,XFORMAT,NULL); defun(ctx,"ERROR",mod,SIGERROR,NULL); - defun(ctx,"INSTALL-ERROR-HANDLER",mod,INSTALL_ERRHANDLER,NULL); } diff --git a/lisp/c/makes.c b/lisp/c/makes.c index b4b9a86b6..da386840f 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -879,7 +879,6 @@ int bs_size; 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/l/conditions.l b/lisp/l/conditions.l index 7f4e94443..34f61e17d 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -2,7 +2,8 @@ (in-package "LISP") -(export '(handler-bind handler-case signals continue next-handler)) +(export '(install-handler remove-handler signals + handler-bind handler-case continue next-handler)) (defmethod condition (:init (&rest init-args &key &allow-other-keys) @@ -12,15 +13,21 @@ (setf (get self name) value))) self)) -(defun add-handler (label callback) +(defun install-handler (label handler) (assert (and (classp label) (derivedp (instantiate label) condition)) "condition class expected") - (assert (functionp callback) "function expected") - (push (cons label callback) *condition-handler*)) + (assert (functionp handler) "function expected") + (push (cons label handler) *condition-handler*)) + +(defun remove-handler (label &optional handler) + (setq *condition-handler* + (if handler + (remove (cons label handler) *condition-handler* :test #'equal :count 1) + (remove label *condition-handler* :key #'car :count 1)))) (defmacro handler-bind (bindings &rest forms) `(let ((*condition-handler* (copy-list *condition-handler*))) - ,@(mapcar #'(lambda (bind) `(add-handler ,@bind)) (reverse bindings)) + ,@(mapcar #'(lambda (bind) `(install-handler ,@bind)) (reverse bindings)) ,@forms)) (defmacro handler-case (form &rest cases) @@ -44,7 +51,7 @@ (catch :next-handler (return-from signals (funcall (cdr handle) obj))))))) -(defun myerror (err) +(defun euserror (err) (when (and (plusp *max-callstack-depth*) (get err :callstack)) (format *error-output* "Call Stack (most recent call last):~%") (let ((i 0)) @@ -71,5 +78,5 @@ (defun continue (val) (throw (- *replevel*) val)) (defun next-handler () (throw :next-handler nil)) -(add-handler error #'myerror) +(install-handler error #'euserror) ) 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/toplevel.l b/lisp/l/toplevel.l index 02ca3df32..68795ffbc 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -279,24 +279,6 @@ (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 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 From 902cd09b12b07c7346629aa4c041f4bfd748e2ba Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 26 Jun 2019 16:54:14 +0900 Subject: [PATCH 039/387] Add retry --- lisp/l/conditions.l | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 34f61e17d..0c13e1cd5 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -2,8 +2,8 @@ (in-package "LISP") -(export '(install-handler remove-handler signals - handler-bind handler-case continue next-handler)) +(export '(install-handler remove-handler handler-bind handler-case + signals continue retry next-handler)) (defmethod condition (:init (&rest init-args &key &allow-other-keys) @@ -51,23 +51,31 @@ (catch :next-handler (return-from signals (funcall (cdr handle) obj))))))) -(defun euserror (err) +(defun print-error-callstack (err) (when (and (plusp *max-callstack-depth*) (get err :callstack)) (format *error-output* "Call Stack (most recent call last):~%") (let ((i 0)) (dolist (form (nthcdr (max 0 (- (length (get err :callstack)) *max-callstack-depth*)) (get err :callstack))) - (format *error-output* "~3D: at ~A~%" (incf i) form)))) + (format *error-output* "~3D: at ~A~%" (incf i) form))))) +(defun print-error-msg (err) (if (get err :msg) (format *error-output* "~C[1;3~Cm~A~C[0m: ~A~%" #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (get err :msg)) (format *error-output* "~C[1;3~Cm~A~C[0m~%" - #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b)) + #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b))) + +(defvar *current-error* nil) + +(defun euserror (err) + (print-error-callstack err) + (print-error-msg err) (catch (- (1+ *replevel*)) (let ((*replevel* (1+ *replevel*)) - (*reptype* "E")) + (*reptype* "E") + (*current-error* err)) ;; do not carry handlers through the error stack ;; i.e. restore previous global `*condition-handler*' (let ((old (assoc '*condition-handler* (sys:list-all-special-bindings)))) @@ -76,6 +84,7 @@ (throw *replevel* t))) (defun continue (val) (throw (- *replevel*) val)) +(defun retry () (throw (- *replevel*) (eval (get *current-error* :form)))) (defun next-handler () (throw :next-handler nil)) (install-handler error #'euserror) From b5e08900909d87270eae7bcb777db93a0eecbad1 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 26 Jun 2019 20:03:55 +0900 Subject: [PATCH 040/387] Remove fatal-error class --- lisp/c/eus.c | 3 +-- lisp/c/eus.h | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index abce76795..aa6f379e3 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -154,7 +154,7 @@ 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, C_FATALERROR; +pointer C_CONDITION, C_ERROR; /*class names*/ pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL, @@ -857,7 +857,6 @@ static void initclasses() /* conditions */ C_CONDITION=speval(basicclass("CONDITION",C_PROPOBJ,&conditioncp,0)); C_ERROR=speval(basicclass("ERROR",C_CONDITION,&errorcp,0)); - C_FATALERROR=speval(basicclass("FATAL-ERROR",C_ERROR,&fatalerrorcp,0)); 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)); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index db0d157ea..aa9809cc7 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -692,7 +692,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, C_FATALERROR; +extern pointer C_CONDITION, C_ERROR; /*class names*/ extern pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL, From cc865a65f60ba8aa6295031f8d7c023b91e0f48f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 27 Jun 2019 16:15:59 +0900 Subject: [PATCH 041/387] Add resume and sys:print-stack --- lisp/c/eus.h | 3 +++ lisp/c/eus_proto.h | 2 ++ lisp/c/eval.c | 12 ++++++++++-- lisp/c/specials.c | 16 ++++++++++++++++ lisp/c/sysfunc.c | 18 ++++++++++++++++++ lisp/l/eusstart.l | 4 ++-- 6 files changed, 51 insertions(+), 4 deletions(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index aa9809cc7..80c53d584 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -477,7 +477,10 @@ enum ch_attr { /****************************************************************/ struct callframe { struct callframe *vlink; + struct bindframe *bf; /*bind frame save*/ + struct fletframe *ff; /*flet frame save*/ pointer form; + jmp_buf* jbp; }; struct bindframe { /*to achieve lexical binding in the interpreter*/ diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index f06760321..c77c61c46 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -561,6 +561,7 @@ 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 RESUME(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer RESET(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer EVALHOOK(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer BLOCK(context */*ctx*/, pointer /*arg*/); @@ -623,6 +624,7 @@ 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 PRINTSTACK(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 LISTSPECIALBINDINGS(context */*ctx*/, int /*n*/, pointer */*argv*/); diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 01815b8ba..9d05bf539 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1528,15 +1528,23 @@ int noarg; if (!ispointer(func)) error(E_NOFUNCTION); /*make a new stack frame*/ + jmp_buf catchbuf; stackck; /*stack overflow?*/ breakck; /*signal exists?*/ vf->vlink=ctx->callfp; - vf->form=form; + vf->bf=ctx->bindfp; + vf->ff=ctx->fletfp; + vf->form=form; + vf->jbp=&catchbuf; ctx->callfp=vf; ctx->vsp+=sizeof(struct callframe)/(sizeof(pointer)); argp=ctx->vsp; - if (pisclosure(func)) { + if ((result=(pointer)eussetjmp(catchbuf))!=0) { + ctx->bindfp=ctx->callfp->bf; + ctx->fletfp=ctx->callfp->ff; + return(result);} + else if (pisclosure(func)) { clofunc=func; fn=func; if (fn->c.code.subrtype!=SUBR_FUNCTION) error(E_NOFUNCTION); diff --git a/lisp/c/specials.c b/lisp/c/specials.c index c809f647a..98736b30e 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -619,6 +619,21 @@ register pointer arg; ctx->fletfp=ffp; return(result);} +pointer RESUME(ctx,n,argv) +register context *ctx; +int n; +pointer *argv; +{ register struct callframe *vf; + ckarg(2); + int depth=ckintval(argv[0]); + pointer result=argv[1]; + vf=(struct callframe *)(ctx->callfp); + + for(;depth> 0 && vf->vlink; depth--, vf=vf->vlink) {}; + ctx->callfp=vf; + unwind(ctx,(pointer *)ctx->callfp); + euslongjmp(*(vf->jbp),result);} + pointer RESET(ctx,n,argv) register context *ctx; int n; @@ -1336,6 +1351,7 @@ pointer mod; defmacro(ctx,"RETURN",mod,RETURN); defspecial(ctx,"TAGBODY",mod,TAGBODY); defspecial(ctx,"GO",mod,GO); + defun(ctx,"RESUME",mod,RESUME,NULL); defun(ctx,"RESET",mod,RESET,NULL); defun(ctx,"EVALHOOK",mod,EVALHOOK,NULL); defun(ctx,"MACROEXPAND2",mod,MACEXPAND2,NULL); diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index 3e7bdec60..c8a215c35 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -687,6 +687,23 @@ pointer argv[]; /* stack frame access /* 1988-Apr-26 /****************************************************************/ +pointer PRINTSTACK(ctx,n,argv) +register context *ctx; +int n; +pointer *argv; +{ register struct callframe *vf; + int i,max=-1; + ckarg2(0,1); + if(n) max=max(0,intval(argv[0])); + vf=(struct callframe *)(ctx->callfp); + for (i=0; vf->vlink && max; vf=vf->vlink, i++, max--) { + prinx(ctx,makeint(i),STDOUT); + int osf=ctx->slashflag; + ctx->slashflag=1; prinx(ctx,makestring(": ",2),STDOUT); ctx->slashflag=osf; + prinx(ctx,vf->form,STDOUT); + terpri(STDOUT);} + return(NIL);} + pointer LISTALLCATCHERS(ctx,n,argv) register context *ctx; int n; @@ -799,6 +816,7 @@ 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,"PRINT-STACK",mod,PRINTSTACK,NULL); defun(ctx,"LIST-ALL-CATCHERS",mod,LISTALLCATCHERS,NULL); defun(ctx,"LIST-ALL-BINDINGS",mod,LISTBINDINGS,NULL); defun(ctx,"LIST-ALL-SPECIAL-BINDINGS",mod,LISTSPECIALBINDINGS,NULL); diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index 69515dfc0..be02c690b 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -43,7 +43,7 @@ (export '(quote eval apply funcall progn prog1 function)) (export '(mapc mapcar mapcan setq if when cond while let let* unwind-protect catch throw macrolet flet labels block return-from - return reset go tagbody evalhook macroexpand2 eval-when + return resume reset go tagbody evalhook macroexpand2 eval-when the and or proclaim declare symbol-value symbol-function makunbound defun defmacro find-symbol intern gensym list-all-packages find-package @@ -176,7 +176,7 @@ 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-SPECIAL-BINDINGS LIST-ALL-CLASSES PRINT-STACK)) (export '*threads*) From 97e9a07ab8f280338ca48db94d9740fb47364779 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 27 Jun 2019 16:33:26 +0900 Subject: [PATCH 042/387] Use callfp saved frames on catchframe --- lisp/c/compsub.c | 2 +- lisp/c/eus.c | 2 +- lisp/c/eus.h | 2 -- lisp/c/makes.c | 3 --- lisp/c/specials.c | 4 ++-- 5 files changed, 4 insertions(+), 9 deletions(-) diff --git a/lisp/c/compsub.c b/lisp/c/compsub.c index aa24a727d..18f6ef7ad 100644 --- a/lisp/c/compsub.c +++ b/lisp/c/compsub.c @@ -80,6 +80,6 @@ register context *ctx; { register struct catchframe *cfp=ctx->catchfp; ctx->vsp = (pointer *)cfp; ctx->callfp = cfp->cf; - ctx->bindfp = cfp->bf; + ctx->bindfp = cfp->cf->bf; ctx->catchfp= cfp->nextcatch;} diff --git a/lisp/c/eus.c b/lisp/c/eus.c index aa6f379e3..48e5aa96f 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -1095,7 +1095,7 @@ char *prompt; 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->bindfp=ctx->callfp->bf; ctx->vsp=(pointer *)ctx->catchfp; ctx->catchfp=(struct catchframe *)*(ctx->vsp); return(val);} diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 80c53d584..758c5fdd5 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -502,9 +502,7 @@ struct blockframe { 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; }; diff --git a/lisp/c/makes.c b/lisp/c/makes.c index da386840f..431603568 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -824,11 +824,8 @@ jmp_buf *jbuf; 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;} diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 98736b30e..af0836c01 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -522,8 +522,8 @@ pointer arg; if ((val=(pointer)eussetjmp(catchbuf))==0) val=progn(ctx,body); else if ((eusinteger_t)val==1) val=makeint(0); /*longjmp cannot return 0*/ ctx->callfp=ctx->catchfp->cf; - ctx->bindfp=ctx->catchfp->bf; - ctx->fletfp=ctx->catchfp->ff; + ctx->bindfp=ctx->callfp->bf; + ctx->fletfp=ctx->callfp->ff; ctx->vsp=(pointer *)ctx->catchfp; ctx->catchfp=(struct catchframe *)*ctx->vsp; #ifdef __RETURN_BARRIER From af4678d9507b53261ca7f955c4a7b2ce91036177 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 27 Jun 2019 16:46:36 +0900 Subject: [PATCH 043/387] Use resume instead of continue and retry --- lisp/c/eus.c | 2 +- lisp/c/specials.c | 12 +++++++----- lisp/l/conditions.l | 27 ++++++++++----------------- 3 files changed, 18 insertions(+), 23 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 48e5aa96f..e85963e59 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -429,7 +429,7 @@ va_dcl Spevalof(QEVALHOOK)=NIL; /* reset eval hook */ if (errhandler!=NIL) { - return(ufuncall(ctx,errhandler,errhandler,arglst,ctx->bindfp,-1));} + ufuncall(ctx,errhandler,errhandler,arglst,ctx->bindfp,-1);} } #ifdef USE_STDARG diff --git a/lisp/c/specials.c b/lisp/c/specials.c index af0836c01..93c3f1069 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -623,15 +623,17 @@ pointer RESUME(ctx,n,argv) register context *ctx; int n; pointer *argv; -{ register struct callframe *vf; - ckarg(2); +{ ckarg2(1,2); int depth=ckintval(argv[0]); - pointer result=argv[1]; - vf=(struct callframe *)(ctx->callfp); - + register struct callframe *vf=(struct callframe *)(ctx->callfp); + pointer result; + /* unwind stack */ for(;depth> 0 && vf->vlink; depth--, vf=vf->vlink) {}; ctx->callfp=vf; unwind(ctx,(pointer *)ctx->callfp); + /* resume with value */ + if (n==1) result=eval(ctx,vf->form); + else result=argv[1]; euslongjmp(*(vf->jbp),result);} pointer RESET(ctx,n,argv) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 0c13e1cd5..14c2dba1e 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -2,8 +2,8 @@ (in-package "LISP") -(export '(install-handler remove-handler handler-bind handler-case - signals continue retry next-handler)) +(export '(install-handler remove-handler signals + handler-bind handler-case next-handler)) (defmethod condition (:init (&rest init-args &key &allow-other-keys) @@ -67,25 +67,18 @@ (format *error-output* "~C[1;3~Cm~A~C[0m~%" #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b))) -(defvar *current-error* nil) - (defun euserror (err) (print-error-callstack err) (print-error-msg err) - (catch (- (1+ *replevel*)) - (let ((*replevel* (1+ *replevel*)) - (*reptype* "E") - (*current-error* err)) - ;; do not carry handlers through the error stack - ;; i.e. restore previous global `*condition-handler*' - (let ((old (assoc '*condition-handler* (sys:list-all-special-bindings)))) - (if old (setq *condition-handler* (cdr old)))) - (while (catch *replevel* (reploop #'toplevel-prompt)))) - (throw *replevel* t))) + (let ((*replevel* (1+ *replevel*)) + (*reptype* "E")) + ;; do not carry handlers through the error stack + ;; i.e. restore previous global `*condition-handler*' + (let ((old (assoc '*condition-handler* (sys:list-all-special-bindings)))) + (if old (setq *condition-handler* (cdr old)))) + (while (catch *replevel* (reploop #'toplevel-prompt)))) + (throw *replevel* t)) -(defun continue (val) (throw (- *replevel*) val)) -(defun retry () (throw (- *replevel*) (eval (get *current-error* :form)))) (defun next-handler () (throw :next-handler nil)) - (install-handler error #'euserror) ) From 35a1b7474fd318869d5333b3fce558c15db3d164 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 29 Jun 2019 09:05:38 +0900 Subject: [PATCH 044/387] Update error printing --- lisp/l/conditions.l | 10 +++++----- lisp/l/toplevel.l | 1 - 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 14c2dba1e..cd58df0f9 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -2,7 +2,7 @@ (in-package "LISP") -(export '(install-handler remove-handler signals +(export '(install-handler remove-handler signals euserror handler-bind handler-case next-handler)) (defmethod condition @@ -61,11 +61,11 @@ (format *error-output* "~3D: at ~A~%" (incf i) form))))) (defun print-error-msg (err) - (if (get err :msg) - (format *error-output* "~C[1;3~Cm~A~C[0m: ~A~%" + (when (get err :msg) + (format *error-output* "~C[1;3~Cm~A~C[0m: ~A" #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (get err :msg)) - (format *error-output* "~C[1;3~Cm~A~C[0m~%" - #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b))) + (if (get err :form) (format *error-output* " in ~A" (get err :form))) + (terpri *error-output*))) (defun euserror (err) (print-error-callstack err) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 68795ffbc..11d2d7d67 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -24,7 +24,6 @@ *top-selector-interval* evaluate-stream reploop eussig - euserror eustop reset toplevel-prompt )) From a964e4a60bdf03b7c0b498c307c0b0a9474b4149 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 3 Jul 2019 14:26:40 +0900 Subject: [PATCH 045/387] Add logger.l --- lib/llib/logger.l | 75 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) create mode 100644 lib/llib/logger.l diff --git a/lib/llib/logger.l b/lib/llib/logger.l new file mode 100644 index 000000000..dbbcfc145 --- /dev/null +++ b/lib/llib/logger.l @@ -0,0 +1,75 @@ +(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 +(defclass logger-message :super condition) + +;; 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-pval (slots instance &rest body) + `(let (,@(mapcar #'(lambda (name) `(,name (get ,instance ,(intern (symbol-pname name) *keyword-package*)))) slots)) + ,@body)) + +(defun format-log-message (log) + (with-pval (msg lvl args) log + (format nil "[~A] ~A" + (symbol-pname (get-level-name lvl)) + (apply #'format nil msg args)))) + + +;; Loggers signalers +(defun log-debug (msg &rest format-args) + (signals logger-message :msg msg :lvl (get-level :debug) :args format-args)) +(defun log-info (msg &rest format-args) + (signals logger-message :msg msg :lvl (get-level :info) :args format-args)) +(defun log-warn (msg &rest format-args) + (signals logger-message :msg msg :lvl (get-level :warn) :args format-args)) +(defun log-error (msg &rest format-args) + (signals logger-message :msg msg :lvl (get-level :error) :args format-args)) +(defun log-fatal (msg &rest format-args) + (signals logger-message :msg msg :lvl (get-level :fatal) :args format-args)) + + +;; Printing callback +(defun logger-callback (log) + (when (>= (get log :lvl) *logger-level*) + (let ((lvl (get log :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)) From 8a9307f906da74b2cc9e5ec80274a490d2736578 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 3 Jul 2019 18:36:54 +0900 Subject: [PATCH 046/387] Update callstack printing --- lisp/c/eus.c | 5 +---- lisp/c/eus_proto.h | 3 ++- lisp/c/sysfunc.c | 27 +++++++++++++++------------ lisp/l/conditions.l | 26 +++++++++++++------------- lisp/l/eusstart.l | 2 +- 5 files changed, 32 insertions(+), 31 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index e85963e59..2894fca7f 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -336,10 +336,7 @@ va_dcl ctx=euscontexts[thr_self()]; /* get call stack */ - callstack=NIL; - vf=(struct callframe *)(ctx->callfp); - for (; vf->vlink != NULL; vf=vf->vlink) { - callstack = cons(ctx,vf->form,callstack);} + callstack=list_callstack(ctx,-1); /* error(errstr) must be error(E_USER,errstr) */ if ((int)ec < E_END) errstr=errmsg[(int)ec]; diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index c77c61c46..79c27eef6 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -624,7 +624,8 @@ 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 PRINTSTACK(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 LISTSPECIALBINDINGS(context */*ctx*/, int /*n*/, pointer */*argv*/); diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index c8a215c35..ea201d9da 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -687,22 +687,25 @@ pointer argv[]; /* stack frame access /* 1988-Apr-26 /****************************************************************/ -pointer PRINTSTACK(ctx,n,argv) +pointer list_callstack(ctx,max) +register context *ctx; +int max; +{ register struct callframe *vf; + int i; + vf=(struct callframe *)(ctx->callfp); + // list whole stack for negative max values + for (i=0; vf->vlink && max; vf=vf->vlink, i++, max--) { + vpush(vf->form);} + return(stacknlist(ctx,i));} + +pointer LISTCALLSTACK(ctx,n,argv) register context *ctx; int n; pointer *argv; -{ register struct callframe *vf; - int i,max=-1; +{ int i,max=-1; ckarg2(0,1); if(n) max=max(0,intval(argv[0])); - vf=(struct callframe *)(ctx->callfp); - for (i=0; vf->vlink && max; vf=vf->vlink, i++, max--) { - prinx(ctx,makeint(i),STDOUT); - int osf=ctx->slashflag; - ctx->slashflag=1; prinx(ctx,makestring(": ",2),STDOUT); ctx->slashflag=osf; - prinx(ctx,vf->form,STDOUT); - terpri(STDOUT);} - return(NIL);} + return(list_callstack(ctx,max));} pointer LISTALLCATCHERS(ctx,n,argv) register context *ctx; @@ -816,7 +819,7 @@ 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,"PRINT-STACK",mod,PRINTSTACK,NULL); + defun(ctx,"LIST-CALLSTACK",mod,LISTCALLSTACK,NULL); defun(ctx,"LIST-ALL-CATCHERS",mod,LISTALLCATCHERS,NULL); defun(ctx,"LIST-ALL-BINDINGS",mod,LISTBINDINGS,NULL); defun(ctx,"LIST-ALL-SPECIAL-BINDINGS",mod,LISTSPECIALBINDINGS,NULL); diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index cd58df0f9..6bbcea48a 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -51,24 +51,24 @@ (catch :next-handler (return-from signals (funcall (cdr handle) obj))))))) -(defun print-error-callstack (err) - (when (and (plusp *max-callstack-depth*) (get err :callstack)) - (format *error-output* "Call Stack (most recent call last):~%") - (let ((i 0)) - (dolist (form - (nthcdr (max 0 (- (length (get err :callstack)) *max-callstack-depth*)) - (get err :callstack))) - (format *error-output* "~3D: at ~A~%" (incf i) form))))) +(defun print-callstack (stack &optional 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 ~A~%" i (nth i stack)))))) -(defun print-error-msg (err) +(defun print-error-msg (err &optional (os *error-output*)) (when (get err :msg) - (format *error-output* "~C[1;3~Cm~A~C[0m: ~A" + (format os "~C[1;3~Cm~A~C[0m: ~A" #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (get err :msg)) - (if (get err :form) (format *error-output* " in ~A" (get err :form))) - (terpri *error-output*))) + (if (get err :form) (format os " in ~A" (get err :form))) + (terpri os))) (defun euserror (err) - (print-error-callstack err) + (print-callstack (get err :callstack) *max-callstack-depth*) (print-error-msg err) (let ((*replevel* (1+ *replevel*)) (*reptype* "E")) diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index be02c690b..72f1169c0 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -176,7 +176,7 @@ 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 PRINT-STACK)) + LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) (export '*threads*) From c7631e698e0c31980cb232d235c19a3b5e68c936 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 22 Jul 2019 17:36:49 +0900 Subject: [PATCH 047/387] Fix error form printing --- lisp/l/conditions.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 6bbcea48a..94c201076 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -64,7 +64,7 @@ (when (get err :msg) (format os "~C[1;3~Cm~A~C[0m: ~A" #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (get err :msg)) - (if (get err :form) (format os " in ~A" (get err :form))) + (if (get err :form) (format os " in ~S" (get err :form))) (terpri os))) (defun euserror (err) From 32eb80d0a87dc8363f677a24d79caf2ec3e4ca6a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 22 Jul 2019 18:37:32 +0900 Subject: [PATCH 048/387] Fix E_USER and introduce E_REPL --- lisp/c/eus.c | 10 ++++++++-- lisp/c/eus.h | 5 ++++- lisp/c/lispio.c | 2 +- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 2894fca7f..c0ee29890 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -282,6 +282,9 @@ char *errmsg[100]={ "illegal #n= or #n# label", /* USER ERROR */ "", +/* REPL ERROR */ + "", +/* END ERROR */ "E_END", }; @@ -371,10 +374,10 @@ va_dcl msg=makestring(msgstr,strlen(msgstr)); free(msgstr); break; - case E_USER: + case E_REPL: errobj = (pointer)va_arg(args,pointer); 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_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));} @@ -417,6 +420,9 @@ va_dcl 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; } putprop(ctx,errobj,msg,defkeyword(ctx,"MSG")); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 758c5fdd5..1a95a9ada 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -1013,9 +1013,12 @@ enum errorcode { E_FORMATSTRING, E_READLABEL, -/* the following error is added by APT */ +/* custom error */ E_USER, +/* error from the lisp REPL */ + E_REPL, + /* E_END must locate at the end of the error list */ E_END }; diff --git a/lisp/c/lispio.c b/lisp/c/lispio.c index b0c9a264f..9014b4bf0 100644 --- a/lisp/c/lispio.c +++ b/lisp/c/lispio.c @@ -588,7 +588,7 @@ register pointer *argv; for (; ic.str.chars));} + error(E_REPL,errobj,(pointer)(msg->c.str.chars));} void lispio(ctx,mod) From 4e0dda9d83d1d157f03d3c8f67378725f821b571 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 22 Jul 2019 19:22:38 +0900 Subject: [PATCH 049/387] Allow print-callstack call with no args --- lisp/l/conditions.l | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 94c201076..6daad6095 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -51,7 +51,7 @@ (catch :next-handler (return-from signals (funcall (cdr handle) obj))))))) -(defun print-callstack (stack &optional max (os *error-output*)) +(defun print-callstack (&optional (stack (sys:list-callstack)) max (os *error-output*)) (let ((tms (if max (min max (length stack)) (length stack)))) @@ -68,7 +68,8 @@ (terpri os))) (defun euserror (err) - (print-callstack (get err :callstack) *max-callstack-depth*) + (when (get err :callstack) + (print-callstack (get err :callstack) *max-callstack-depth*)) (print-error-msg err) (let ((*replevel* (1+ *replevel*)) (*reptype* "E")) From c54b6d31556e7cb91a0828c8d48e1f64f7bb67fb Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 22 Jul 2019 23:05:10 +0900 Subject: [PATCH 050/387] Fix typo --- lisp/c/lispio.c | 2 +- lisp/c/unixcall.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/c/lispio.c b/lisp/c/lispio.c index 9014b4bf0..6feca4655 100644 --- a/lisp/c/lispio.c +++ b/lisp/c/lispio.c @@ -550,7 +550,7 @@ pointer argv[]; case '~': /*tilda*/ writech(dest,'~'); break; case 'T': /*tabulate*/ - writech(dest,9); break;; + writech(dest,9); break; default: break; } } diff --git a/lisp/c/unixcall.c b/lisp/c/unixcall.c index 5bc0bba8c..684f053f2 100644 --- a/lisp/c/unixcall.c +++ b/lisp/c/unixcall.c @@ -1374,7 +1374,7 @@ int n; pointer *argv; { ckarg(1); struct timespec treq; - GC_REGION(treq.tv_sec=ckintval(argv[0]));; + GC_REGION(treq.tv_sec=ckintval(argv[0])); treq.tv_nsec = 0; if (nanosleep(&treq, NULL)<0) return(NIL); return(T);} From c78fc4950628b2850c43b05092d5acd599da3bb2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 24 Jul 2019 16:33:17 +0900 Subject: [PATCH 051/387] Check for interruptions on while loop --- lisp/c/specials.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 93c3f1069..0e0ec49e7 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -380,7 +380,10 @@ 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; From ac6a572555787c9fe9dda2d218954b9b544f371f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 24 Jul 2019 16:34:54 +0900 Subject: [PATCH 052/387] Track remaining time in unix:sleep when resuming process --- lisp/c/unixcall.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/lisp/c/unixcall.c b/lisp/c/unixcall.c index 684f053f2..581985952 100644 --- a/lisp/c/unixcall.c +++ b/lisp/c/unixcall.c @@ -1373,23 +1373,26 @@ register context *ctx; int n; pointer *argv; { ckarg(1); - struct timespec treq; + struct timespec treq,trem; GC_REGION(treq.tv_sec=ckintval(argv[0])); treq.tv_nsec = 0; - if (nanosleep(&treq, NULL)<0) return(NIL); + while (nanosleep(&treq, &trem)<0) { + breakck; /*signal exists?*/ + treq=trem;} return(T);} - #if sun3 || sun4 && !Solaris2 || Linux || alpha || Cygwin pointer USLEEP(ctx,n,argv) register context *ctx; int n; pointer *argv; { ckarg(1); - struct timespec treq; + struct timespec treq,trem; GC_REGION(treq.tv_sec = ckintval(argv[0])/1000000; treq.tv_nsec = (ckintval(argv[0])%1000000)*1000); - if (nanosleep(&treq, NULL)<0) return(NIL); + while (nanosleep(&treq, &trem)<0) { + breakck; + treq=trem;} return(T);} #endif From 6c0a706ea8125c41681494d37a35231be95a2c15 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 25 Jul 2019 18:23:26 +0900 Subject: [PATCH 053/387] Add unix:signal handling conditions --- lisp/l/conditions.l | 40 +++++++++++++++++++++++++++++++++++++--- lisp/l/toplevel.l | 18 +++++------------- 2 files changed, 42 insertions(+), 16 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 6daad6095..e128cd664 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -1,8 +1,8 @@ -(eval-when(load eval) +(eval-when (load eval) (in-package "LISP") -(export '(install-handler remove-handler signals euserror +(export '(install-handler remove-handler signals euserror sigint-handler handler-bind handler-case next-handler)) (defmethod condition @@ -51,6 +51,8 @@ (catch :next-handler (return-from signals (funcall (cdr handle) obj))))))) +(defun next-handler () (throw :next-handler nil)) + (defun print-callstack (&optional (stack (sys:list-callstack)) max (os *error-output*)) (let ((tms (if max (min max (length stack)) @@ -67,6 +69,11 @@ (if (get err :form) (format os " in ~S" (get err :form))) (terpri os))) + +;;; +;;; error handling +;;; + (defun euserror (err) (when (get err :callstack) (print-callstack (get err :callstack) *max-callstack-depth*)) @@ -80,6 +87,33 @@ (while (catch *replevel* (reploop #'toplevel-prompt)))) (throw *replevel* t)) -(defun next-handler () (throw :next-handler nil)) + +;;; +;;; unix:signal handling +;;; + +(defclass unix::signal-received :super condition) +(defclass unix::sigint-received :super unix::signal-received) +(defclass unix::sigcont-received :super unix::signal-received) + +(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)))) + +(defun sigint-handler (c) + (unix::with-alarm-interrupt + (print-error-msg c) + (let* ((*replevel* (1+ *replevel*)) + (*reptype* "B")) + (catch *replevel* (reploop #'toplevel-prompt))))) + +(defun sigcont-handler (c) + (reset *replevel*)) + +;; install handlers (install-handler error #'euserror) +(install-handler unix::sigint-received #'sigint-handler) +(install-handler unix::sigcont-received #'sigcont-handler) ) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 11d2d7d67..ce2e61f36 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -16,7 +16,7 @@ *prompt* *prompt-string* *history* *try-unix* - skip-blank read-list-from-line sigint-handler *signal-handlers* + skip-blank read-list-from-line *signal-handlers* *eustop-hook* *toplevel-hook* *top-selector* @@ -96,16 +96,6 @@ (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))) @@ -287,8 +277,10 @@ (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::sigint + #'(lambda (sig code) (signals unix::sigint-received :msg "keyboard interrupt"))) + (unix:signal unix::sigcont + #'(lambda (sig code) (signals unix::sigcont-received))) (unix:signal unix::sigpipe 'eussig) ; setup for history #+(or :sun :linux :alpha :solaris2 :mips) From 87f8b9f98c70b43c432cecf5081b53399bdb02d4 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 25 Jul 2019 18:29:38 +0900 Subject: [PATCH 054/387] Update documentation --- doc/jlatex/euslisp.hlp | 445 ++++++++++++++++++++-------------------- doc/jlatex/jsysfunc.tex | 11 +- doc/latex/euslisp.hlp | 120 +++++------ doc/latex/sysfunc.tex | 14 +- 4 files changed, 299 insertions(+), 291 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 3c0be3805..c15f42d65 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,34 @@ "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 "defclass" 3 "jobjects" 4063 3 "defmethod" 6 "jobjects" 4582 3 "defclassmethod" 3 "jobjects" 4812 2 @@ -191,40 +192,40 @@ "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 +"defvar" 3 "jsymbols" 5873 3 +"defparameter" 3 "jsymbols" 6137 3 +"defconstant" 3 "jsymbols" 6361 3 +"keywordp" 2 "jsymbols" 6889 3 +"constantp" 2 "jsymbols" 7017 3 +"documentation" 2 "jsymbols" 7147 3 +"gensym" 2 "jsymbols" 7266 3 +"gentemp" 2 "jsymbols" 7833 3 +"*lisp-package*" 4 "jsymbols" 11229 2 +"*user-package*" 4 "jsymbols" 11282 2 +"*unix-package*" 4 "jsymbols" 11343 2 +"*system-package*" 4 "jsymbols" 11398 2 +"*keyword-package*" 4 "jsymbols" 11462 2 +"find-symbol" 2 "jsymbols" 11522 3 +"make-symbol" 2 "jsymbols" 11778 3 +"intern" 2 "jsymbols" 11895 3 +"list-all-packages" 2 "jsymbols" 12249 3 +"find-package" 2 "jsymbols" 12351 3 +"make-package" 2 "jsymbols" 12466 3 +"in-package" 2 "jsymbols" 12739 3 +"package-name" 2 "jsymbols" 12878 3 +"package-nicknames" 2 "jsymbols" 12979 3 +"rename-package" 2 "jsymbols" 13058 3 +"package-use-list" 2 "jsymbols" 13335 3 +"packagep" 2 "jsymbols" 13427 3 +"use-package" 2 "jsymbols" 13514 3 +"unuse-package" 2 "jsymbols" 13777 3 +"shadow" 2 "jsymbols" 13890 3 +"export" 2 "jsymbols" 14034 3 +"unexport" 2 "jsymbols" 15261 3 +"import" 2 "jsymbols" 15411 3 +"do-symbols" 3 "jsymbols" 15823 3 +"do-external-symbols" 3 "jsymbols" 16051 3 +"do-all-symbols" 3 "jsymbols" 16250 3 "elt" 2 "jsequences" 584 3 "length" 2 "jsequences" 968 3 "subseq" 2 "jsequences" 1609 3 @@ -281,107 +282,107 @@ "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 +"butlast" 2 "jsequences" 12629 3 +"cons" 2 "jsequences" 12752 3 +"list" 2 "jsequences" 12869 3 +"list*" 2 "jsequences" 12938 3 +"list-length" 2 "jsequences" 13192 3 +"make-list" 2 "jsequences" 13300 3 +"rplaca" 2 "jsequences" 13430 3 +"rplacd" 2 "jsequences" 13607 3 +"memq" 2 "jsequences" 13782 3 +"member" 2 "jsequences" 13895 3 +"assq" 2 "jsequences" 14383 2 +"assoc" 2 "jsequences" 14413 3 +"rassoc" 2 "jsequences" 14723 3 +"pairlis" 2 "jsequences" 14839 3 +"acons" 2 "jsequences" 15091 3 +"append" 2 "jsequences" 15237 3 +"nconc" 2 "jsequences" 15439 3 +"subst" 2 "jsequences" 15611 3 +"flatten" 2 "jsequences" 15721 3 +"push" 3 "jsequences" 16016 3 +"pop" 3 "jsequences" 16131 3 +"pushnew" 3 "jsequences" 16283 3 +"adjoin" 2 "jsequences" 16541 3 +"union" 2 "jsequences" 16672 3 +"subsetp" 2 "jsequences" 16794 3 +"intersection" 2 "jsequences" 17055 3 +"set-difference" 2 "jsequences" 17209 3 +"set-exclusive-or" 2 "jsequences" 17413 3 +"list-insert" 2 "jsequences" 17587 3 +"copy-tree" 2 "jsequences" 17899 3 +"mapc" 2 "jsequences" 18175 3 +"mapcar" 2 "jsequences" 18434 3 +"mapcan" 2 "jsequences" 18734 3 +"array-rank-limit" 4 "jsequences" 20917 2 +"array-dimension-limit" 4 "jsequences" 20992 2 +"vectorp" 2 "jsequences" 21199 3 +"vector" 2 "jsequences" 21438 3 +"make-array" 2 "jsequences" 21554 3 +"svref" 2 "jsequences" 21900 3 +"aref" 2 "jsequences" 22059 3 +"vector-push" 2 "jsequences" 22533 3 +"vector-push-extend" 2 "jsequences" 22923 3 +"arrayp" 2 "jsequences" 23131 3 +"array-total-size" 2 "jsequences" 23262 3 +"fill-pointer" 2 "jsequences" 23341 3 +"array-rank" 2 "jsequences" 23467 3 +"array-dimensions" 2 "jsequences" 23541 3 +"array-dimension" 2 "jsequences" 23638 3 +"bit" 2 "jsequences" 23785 3 +"bit-and" 2 "jsequences" 23975 2 +"bit-ior" 2 "jsequences" 24025 2 +"bit-xor" 2 "jsequences" 24075 2 +"bit-eqv" 2 "jsequences" 24125 2 +"bit-nand" 2 "jsequences" 24176 2 +"bit-nor" 2 "jsequences" 24226 2 +"bit-not" 2 "jsequences" 24277 3 +"digit-char-p" 2 "jsequences" 24829 3 +"alpha-char-p" 2 "jsequences" 24942 3 +"upper-case-p" 2 "jsequences" 25113 3 +"lower-case-p" 2 "jsequences" 25229 3 +"alphanumericp" 2 "jsequences" 25346 3 +"char-upcase" 2 "jsequences" 25565 3 +"char-downcase" 2 "jsequences" 25636 3 +"char" 2 "jsequences" 25698 3 +"schar" 2 "jsequences" 25786 3 +"stringp" 2 "jsequences" 25989 3 +"string-upcase" 2 "jsequences" 26119 3 +"string-downcase" 2 "jsequences" 26252 3 +"nstring-upcase" 2 "jsequences" 26384 3 +"nstring-downcase" 2 "jsequences" 26493 3 +"string=" 2 "jsequences" 26609 3 +"string-equal" 2 "jsequences" 26800 3 +"string" 2 "jsequences" 26986 3 +"string<" 2 "jsequences" 27624 2 +"string<=" 2 "jsequences" 27657 2 +"string>" 2 "jsequences" 27689 2 +"string>=" 2 "jsequences" 27722 2 +"string-left-trim" 2 "jsequences" 27761 2 +"string-right-trim" 2 "jsequences" 27800 3 +"string-trim" 2 "jsequences" 28112 3 +"substringp" 2 "jsequences" 28301 3 +"make-foreign-string" 2 "jsequences" 30590 3 +"sxhash" 2 "jsequences" 32625 3 +"make-hash-table" 2 "jsequences" 33288 3 +"gethash" 2 "jsequences" 33391 3 +"remhash" 2 "jsequences" 33804 3 +"maphash" 2 "jsequences" 33922 3 +"hash-table-p" 2 "jsequences" 34028 3 +"hash-table" 0 "jsequences" 34136 4 +":hash-function" 1 "jsequences" 34744 3 +"queue" 0 "jsequences" 35395 4 +":init" 1 "jsequences" 35464 3 +":enqueue" 1 "jsequences" 35518 3 +":dequeue" 1 "jsequences" 35606 3 +":empty?" 1 "jsequences" 35864 3 +":length" 1 "jsequences" 35933 3 +":trim" 1 "jsequences" 35990 3 +":search" 1 "jsequences" 36104 3 +":delete" 1 "jsequences" 36243 3 +":first" 1 "jsequences" 36406 3 +":last" 1 "jsequences" 36514 3 "streamp" 2 "jio" 591 3 "input-stream-p" 2 "jio" 741 3 "output-stream-p" 2 "jio" 859 3 @@ -608,65 +609,65 @@ "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 +"unix:kill" 2 "jsysfunc" 25639 3 +"unix:pause" 2 "jsysfunc" 25749 3 +"unix:alarm" 2 "jsysfunc" 25861 3 +"unix:ualarm" 2 "jsysfunc" 26192 3 +"unix:getitimer" 2 "jsysfunc" 26480 3 +"unix:setitimer" 2 "jsysfunc" 26724 3 +"unix:select" 2 "jsysfunc" 27137 3 +"unix:select-read-fd" 2 "jsysfunc" 28261 3 +"unix:thr-self" 2 "jsysfunc" 28974 3 +"unix:thr-getprio" 2 "jsysfunc" 29072 3 +"unix:thr-setprio" 2 "jsysfunc" 29179 3 +"unix:thr-getconcurrency" 2 "jsysfunc" 29679 3 +"unix:thr-setconcurrency" 2 "jsysfunc" 29810 3 +"unix:thr-create" 2 "jsysfunc" 30575 3 +"unix:malloc" 2 "jsysfunc" 31045 3 +"unix:free" 2 "jsysfunc" 31140 3 +"unix:valloc" 2 "jsysfunc" 31249 2 +"unix:mmap" 2 "jsysfunc" 31279 2 +"unix:munmap" 2 "jsysfunc" 31349 2 +"unix:vadvise" 2 "jsysfunc" 31389 2 +"unix:tiocgetp" 2 "jsysfunc" 32371 3 +"unix:tiocsetp" 2 "jsysfunc" 32455 3 +"unix:tiocsetn" 2 "jsysfunc" 32533 2 +"unix:tiocgetd" 2 "jsysfunc" 32586 2 +"unix:tiocflush" 2 "jsysfunc" 32641 3 +"unix:tiocgpgrp" 2 "jsysfunc" 32718 3 +"unix:tiocspgrp" 2 "jsysfunc" 32805 3 +"unix:tiocoutq" 2 "jsysfunc" 32896 2 +"unix:fionread" 2 "jsysfunc" 32937 2 +"unix:tiocsetc" 2 "jsysfunc" 32978 2 +"unix:tioclbis" 2 "jsysfunc" 33015 2 +"unix:tioclbic" 2 "jsysfunc" 33052 2 +"unix:tioclset" 2 "jsysfunc" 33089 2 +"unix:tioclget" 2 "jsysfunc" 33126 2 +"unix:tcseta" 2 "jsysfunc" 33162 3 +"unix:tcsets" 2 "jsysfunc" 33261 3 +"unix:tcsetsw" 2 "jsysfunc" 33352 3 +"unix:tcsetsf" 2 "jsysfunc" 33506 3 +"unix:tiocsetc" 2 "jsysfunc" 33722 2 +"unix:tcsetaf" 2 "jsysfunc" 33761 2 +"unix:tcsetaw" 2 "jsysfunc" 33800 2 +"unix:tcgeta" 2 "jsysfunc" 33838 2 +"unix:tcgets" 2 "jsysfunc" 33876 2 +"unix:tcgetattr" 2 "jsysfunc" 33917 2 +"unix:tcsetattr" 2 "jsysfunc" 33958 2 +"dbm-open" 2 "jsysfunc" 34618 3 +"dbm-store" 2 "jsysfunc" 35729 3 +"dbm-fetch" 2 "jsysfunc" 36043 3 +"cd" 2 "jsysfunc" 37822 3 +"ez" 2 "jsysfunc" 37924 3 +"piped-fork" 2 "jsysfunc" 38060 3 +"rusage" 2 "jsysfunc" 38211 3 +"load-foreign" 3 "jsysfunc" 46015 3 +"defforeign" 3 "jsysfunc" 49246 3 +"defun-c-callable" 3 "jsysfunc" 51547 3 +"pod-address" 2 "jsysfunc" 52822 3 +"array-entity" 3 "jsysfunc" 53149 3 +"float2double" 2 "jsysfunc" 53453 3 +"double2float" 2 "jsysfunc" 53691 3 "connect-vxw" 2 "jvxw" 3159 3 "vxw" 2 "jvxw" 3910 3 "defvxw" 3 "jvxw" 5715 3 diff --git a/doc/jlatex/jsysfunc.tex b/doc/jlatex/jsysfunc.tex index 668e90af6..c3bf44b48 100644 --- a/doc/jlatex/jsysfunc.tex +++ b/doc/jlatex/jsysfunc.tex @@ -508,8 +508,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 +526,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/euslisp.hlp b/doc/latex/euslisp.hlp index e49c751d1..b8ffe2cae 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -614,66 +614,66 @@ "unix:gethostbyname" 2 "sysfunc" 19848 3 "unix:syserrlist" 2 "sysfunc" 19991 3 "unix:signal" 2 "sysfunc" 20164 3 -"unix:kill" 2 "sysfunc" 20575 3 -"unix:pause" 2 "sysfunc" 20660 3 -"unix:alarm" 2 "sysfunc" 20746 3 -"unix:ualarm" 2 "sysfunc" 20912 3 -"unix:getitimer" 2 "sysfunc" 21099 3 -"unix:setitimer" 2 "sysfunc" 21640 3 -"unix:select" 2 "sysfunc" 21986 3 -"unix:select-read-fd" 2 "sysfunc" 22828 3 -"unix:thr-self" 2 "sysfunc" 23362 3 -"unix:thr-getprio" 2 "sysfunc" 23453 3 -"unix:thr-setprio" 2 "sysfunc" 23556 3 -"unix:thr-getconcurrency" 2 "sysfunc" 23951 3 -"unix:thr-setconcurrency" 2 "sysfunc" 24097 3 -"unix:thr-create" 2 "sysfunc" 24686 3 -"unix:malloc" 2 "sysfunc" 25055 3 -"unix:free" 2 "sysfunc" 25135 3 -"unix:valloc" 2 "sysfunc" 25229 2 -"unix:mmap" 2 "sysfunc" 25259 2 -"unix:munmap" 2 "sysfunc" 25329 2 -"unix:vadvise" 2 "sysfunc" 25369 2 -"unix:tiocgetp" 2 "sysfunc" 26088 3 -"unix:tiocsetp" 2 "sysfunc" 26161 3 -"unix:tiocsetn" 2 "sysfunc" 26222 2 -"unix:tiocgetd" 2 "sysfunc" 26275 2 -"unix:tiocflush" 2 "sysfunc" 26330 3 -"unix:tiocgpgrp" 2 "sysfunc" 26390 3 -"unix:tiocspgrp" 2 "sysfunc" 26458 3 -"unix:tiocoutq" 2 "sysfunc" 26524 2 -"unix:fionread" 2 "sysfunc" 26565 2 -"unix:tiocsetc" 2 "sysfunc" 26606 2 -"unix:tioclbis" 2 "sysfunc" 26643 2 -"unix:tioclbic" 2 "sysfunc" 26680 2 -"unix:tioclset" 2 "sysfunc" 26717 2 -"unix:tioclget" 2 "sysfunc" 26754 2 -"unix:tcseta" 2 "sysfunc" 26790 3 -"unix:tcsets" 2 "sysfunc" 26869 3 -"unix:tcsetsw" 2 "sysfunc" 26937 3 -"unix:tcsetsf" 2 "sysfunc" 27066 3 -"unix:tiocsetc" 2 "sysfunc" 27245 2 -"unix:tcsetaf" 2 "sysfunc" 27284 2 -"unix:tcsetaw" 2 "sysfunc" 27323 2 -"unix:tcgeta" 2 "sysfunc" 27361 2 -"unix:tcgets" 2 "sysfunc" 27399 2 -"unix:tcgetattr" 2 "sysfunc" 27440 2 -"unix:tcsetattr" 2 "sysfunc" 27481 2 -"dbm-open" 2 "sysfunc" 27986 3 -"dbm-store" 2 "sysfunc" 28776 3 -"dbm-fetch" 2 "sysfunc" 28991 3 -"cd" 2 "sysfunc" 30431 3 -"ez" 2 "sysfunc" 30526 3 -"piped-fork" 2 "sysfunc" 30643 3 -"xfork" 2 "sysfunc" 31067 3 -"rusage" 2 "sysfunc" 31738 3 -"load-foreign" 3 "sysfunc" 38551 3 -"defforeign" 3 "sysfunc" 41109 3 -"defun-c-callable" 3 "sysfunc" 43628 3 -"pod-address" 2 "sysfunc" 44643 3 -"array-entity" 3 "sysfunc" 44908 3 -"float2double" 2 "sysfunc" 45191 3 -"double2float" 2 "sysfunc" 45410 3 +"unix:kill" 2 "sysfunc" 20659 3 +"unix:pause" 2 "sysfunc" 20744 3 +"unix:alarm" 2 "sysfunc" 20830 3 +"unix:ualarm" 2 "sysfunc" 21126 3 +"unix:getitimer" 2 "sysfunc" 21365 3 +"unix:setitimer" 2 "sysfunc" 21906 3 +"unix:select" 2 "sysfunc" 22252 3 +"unix:select-read-fd" 2 "sysfunc" 23094 3 +"unix:thr-self" 2 "sysfunc" 23628 3 +"unix:thr-getprio" 2 "sysfunc" 23719 3 +"unix:thr-setprio" 2 "sysfunc" 23822 3 +"unix:thr-getconcurrency" 2 "sysfunc" 24217 3 +"unix:thr-setconcurrency" 2 "sysfunc" 24363 3 +"unix:thr-create" 2 "sysfunc" 24952 3 +"unix:malloc" 2 "sysfunc" 25321 3 +"unix:free" 2 "sysfunc" 25401 3 +"unix:valloc" 2 "sysfunc" 25495 2 +"unix:mmap" 2 "sysfunc" 25525 2 +"unix:munmap" 2 "sysfunc" 25595 2 +"unix:vadvise" 2 "sysfunc" 25635 2 +"unix:tiocgetp" 2 "sysfunc" 26354 3 +"unix:tiocsetp" 2 "sysfunc" 26427 3 +"unix:tiocsetn" 2 "sysfunc" 26488 2 +"unix:tiocgetd" 2 "sysfunc" 26541 2 +"unix:tiocflush" 2 "sysfunc" 26596 3 +"unix:tiocgpgrp" 2 "sysfunc" 26656 3 +"unix:tiocspgrp" 2 "sysfunc" 26724 3 +"unix:tiocoutq" 2 "sysfunc" 26790 2 +"unix:fionread" 2 "sysfunc" 26831 2 +"unix:tiocsetc" 2 "sysfunc" 26872 2 +"unix:tioclbis" 2 "sysfunc" 26909 2 +"unix:tioclbic" 2 "sysfunc" 26946 2 +"unix:tioclset" 2 "sysfunc" 26983 2 +"unix:tioclget" 2 "sysfunc" 27020 2 +"unix:tcseta" 2 "sysfunc" 27056 3 +"unix:tcsets" 2 "sysfunc" 27135 3 +"unix:tcsetsw" 2 "sysfunc" 27203 3 +"unix:tcsetsf" 2 "sysfunc" 27332 3 +"unix:tiocsetc" 2 "sysfunc" 27511 2 +"unix:tcsetaf" 2 "sysfunc" 27550 2 +"unix:tcsetaw" 2 "sysfunc" 27589 2 +"unix:tcgeta" 2 "sysfunc" 27627 2 +"unix:tcgets" 2 "sysfunc" 27665 2 +"unix:tcgetattr" 2 "sysfunc" 27706 2 +"unix:tcsetattr" 2 "sysfunc" 27747 2 +"dbm-open" 2 "sysfunc" 28252 3 +"dbm-store" 2 "sysfunc" 29042 3 +"dbm-fetch" 2 "sysfunc" 29257 3 +"cd" 2 "sysfunc" 30697 3 +"ez" 2 "sysfunc" 30792 3 +"piped-fork" 2 "sysfunc" 30909 3 +"xfork" 2 "sysfunc" 31333 3 +"rusage" 2 "sysfunc" 32004 3 +"load-foreign" 3 "sysfunc" 38817 3 +"defforeign" 3 "sysfunc" 41375 3 +"defun-c-callable" 3 "sysfunc" 43894 3 +"pod-address" 2 "sysfunc" 44909 3 +"array-entity" 3 "sysfunc" 45174 3 +"float2double" 2 "sysfunc" 45457 3 +"double2float" 2 "sysfunc" 45676 3 "float-vector" 2 "matrix" 389 3 "float-vector-p" 2 "matrix" 660 3 "v+" 2 "matrix" 724 3 diff --git a/doc/latex/sysfunc.tex b/doc/latex/sysfunc.tex index d2aaf239e..1dd1e191a 100644 --- a/doc/latex/sysfunc.tex +++ b/doc/latex/sysfunc.tex @@ -522,8 +522,9 @@ \subsubsection{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 +541,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 +563,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 From 678f7ddc24a362adbcc7152893df0df8560a3ca5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 26 Jul 2019 15:03:16 +0900 Subject: [PATCH 055/387] Remove deprecated eussig and *signal-handlers* --- lisp/c/toplevel.l | 353 ---------------------------------------------- lisp/l/toplevel.l | 20 +-- 2 files changed, 2 insertions(+), 371 deletions(-) delete mode 100644 lisp/c/toplevel.l 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/l/toplevel.l b/lisp/l/toplevel.l index ce2e61f36..1529607fe 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,14 +16,13 @@ *prompt* *prompt-string* *history* *try-unix* - skip-blank read-list-from-line *signal-handlers* + skip-blank read-list-from-line *eustop-hook* *toplevel-hook* *top-selector* *timer-job* *top-selector-interval* evaluate-stream reploop - eussig eustop reset toplevel-prompt )) @@ -96,20 +95,6 @@ (if (eq *input-line* eof) (return-from read-list-from-line eof)) (make-string-input-stream *input-line*))))) -(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)) @@ -281,7 +266,6 @@ #'(lambda (sig code) (signals unix::sigint-received :msg "keyboard interrupt"))) (unix:signal unix::sigcont #'(lambda (sig code) (signals unix::sigcont-received))) - (unix:signal unix::sigpipe 'eussig) ; setup for history #+(or :sun :linux :alpha :solaris2 :mips) (when (fboundp 'unix:tcgets) From 5bd7a7eb8f6c9649da74a5e64099daa725a25a23 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 16 Aug 2019 15:16:11 +0900 Subject: [PATCH 056/387] Do not use lambda on signals for roseus compatibility --- lisp/l/conditions.l | 9 +++++---- lisp/l/eusstart.l | 1 + lisp/l/toplevel.l | 7 ++----- 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index e128cd664..d50b46b6d 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -95,6 +95,9 @@ (defclass unix::signal-received :super condition) (defclass unix::sigint-received :super unix::signal-received) (defclass unix::sigcont-received :super unix::signal-received) +(defmacro unix::install-signal-handler (sig obj &rest init-args) + `(unix:signal ,sig '(lambda-closure ,(gensym) 0 0 (sig code) + (signals ,obj ,@init-args)))) (defmacro unix::with-alarm-interrupt (&rest body) (let ((interval (gensym)) (value (gensym))) @@ -109,11 +112,9 @@ (*reptype* "B")) (catch *replevel* (reploop #'toplevel-prompt))))) -(defun sigcont-handler (c) - (reset *replevel*)) - ;; install handlers (install-handler error #'euserror) (install-handler unix::sigint-received #'sigint-handler) -(install-handler unix::sigcont-received #'sigcont-handler) +;; in order to remain in the same stack, reset command must not be compiled +(install-handler unix::sigcont-received `(lambda-closure ,(gensym) 0 0 (c) (reset *replevel*))) ) diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index 72f1169c0..445496438 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -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)) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 1529607fe..2c8aeff8a 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -257,15 +257,12 @@ ;;; ;;; 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 - #'(lambda (sig code) (signals unix::sigint-received :msg "keyboard interrupt"))) - (unix:signal unix::sigcont - #'(lambda (sig code) (signals unix::sigcont-received))) + (unix:install-signal-handler unix::sigint unix::sigint-received :msg "keyboard interrupt") + (unix:install-signal-handler unix::sigcont unix::sigcont-received) ; setup for history #+(or :sun :linux :alpha :solaris2 :mips) (when (fboundp 'unix:tcgets) From 4520f2165e8d0dba3b68de74674bdd3beb9f0995 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 27 Aug 2019 19:11:33 +0900 Subject: [PATCH 057/387] Avoid closures in sigint-handler --- lisp/l/conditions.l | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index d50b46b6d..2d315e8d5 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -112,9 +112,10 @@ (*reptype* "B")) (catch *replevel* (reploop #'toplevel-prompt))))) +;; TODO: fix sigcont-handler (avoid compilation?) ;; install handlers (install-handler error #'euserror) -(install-handler unix::sigint-received #'sigint-handler) +(install-handler unix::sigint-received 'sigint-handler) ;; in order to remain in the same stack, reset command must not be compiled (install-handler unix::sigcont-received `(lambda-closure ,(gensym) 0 0 (c) (reset *replevel*))) ) From 332668032a23b6fa30af039124c062b3fb762619 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 27 Aug 2019 19:12:06 +0900 Subject: [PATCH 058/387] Fix print-callstack formating --- lisp/l/conditions.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 2d315e8d5..a52fd3b93 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -60,7 +60,7 @@ (when (plusp tms) (format os "Call Stack~A:~%" (if max (format nil " (max depth ~A)" max) "")) (dotimes (i tms) - (format os "~3D: at ~A~%" i (nth i stack)))))) + (format os "~3D: at ~S~%" i (nth i stack)))))) (defun print-error-msg (err &optional (os *error-output*)) (when (get err :msg) From 744f0f9be1cd0b50c6e7c90d68d8647305e43f7e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 28 Aug 2019 14:31:05 +0900 Subject: [PATCH 059/387] Do not overwrite env with closures in sigint --- lisp/l/conditions.l | 12 ++++++++---- lisp/l/toplevel.l | 2 -- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index a52fd3b93..997152fe2 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -96,8 +96,10 @@ (defclass unix::sigint-received :super unix::signal-received) (defclass unix::sigcont-received :super unix::signal-received) (defmacro unix::install-signal-handler (sig obj &rest init-args) - `(unix:signal ,sig '(lambda-closure ,(gensym) 0 0 (sig code) - (signals ,obj ,@init-args)))) + (let ((fname (intern (format nil "~A-SIGNALIZE-CONDITION" (symbol-pname sig)) *unix-package*))) + `(progn + (defun ,fname (sig code) (signals ,obj ,@init-args)) + (unix:signal ,sig #',fname)))) (defmacro unix::with-alarm-interrupt (&rest body) (let ((interval (gensym)) (value (gensym))) @@ -112,10 +114,12 @@ (*reptype* "B")) (catch *replevel* (reploop #'toplevel-prompt))))) -;; TODO: fix sigcont-handler (avoid compilation?) ;; install handlers +(unix:install-signal-handler unix::sigint unix::sigint-received :msg "keyboard interrupt") +(unix:install-signal-handler unix::sigcont unix::sigcont-received)) (install-handler error #'euserror) (install-handler unix::sigint-received 'sigint-handler) -;; in order to remain in the same stack, reset command must not be compiled (install-handler unix::sigcont-received `(lambda-closure ,(gensym) 0 0 (c) (reset *replevel*))) +;; in order to remain in the same stack, reset command must not be compiled +;; TODO: find out why this happens ) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 2c8aeff8a..9f64b68cf 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -261,8 +261,6 @@ (when (unix:isatty *standard-input*) (warning-message 4 "~%~A" (lisp-implementation-version)) (terpri *error-output*) - (unix:install-signal-handler unix::sigint unix::sigint-received :msg "keyboard interrupt") - (unix:install-signal-handler unix::sigcont unix::sigcont-received) ; setup for history #+(or :sun :linux :alpha :solaris2 :mips) (when (fboundp 'unix:tcgets) From 812eed482ff3180c1914b926d407f38db8b771ec Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 28 Aug 2019 15:19:54 +0900 Subject: [PATCH 060/387] Allow reseting to previous interruption stacks --- lisp/l/conditions.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 997152fe2..a6cda8cbe 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -112,7 +112,7 @@ (print-error-msg c) (let* ((*replevel* (1+ *replevel*)) (*reptype* "B")) - (catch *replevel* (reploop #'toplevel-prompt))))) + (while (catch *replevel* (reploop #'toplevel-prompt)))))) ;; install handlers (unix:install-signal-handler unix::sigint unix::sigint-received :msg "keyboard interrupt") From a7e88440da183bfcde5cd702cb69415e14c04090 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 6 Sep 2019 09:48:16 +0900 Subject: [PATCH 061/387] Signals 'interruption-event' --- lisp/l/conditions.l | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index a6cda8cbe..0003a7f01 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -3,7 +3,7 @@ (in-package "LISP") (export '(install-handler remove-handler signals euserror sigint-handler - handler-bind handler-case next-handler)) + interruption-event handler-bind handler-case next-handler)) (defmethod condition (:init (&rest init-args &key &allow-other-keys) @@ -107,15 +107,21 @@ ,@body (unix:setitimer 0 ,value ,interval)))) +(defclass interruption-event :super condition) (defun sigint-handler (c) (unix::with-alarm-interrupt - (print-error-msg c) - (let* ((*replevel* (1+ *replevel*)) - (*reptype* "B")) - (while (catch *replevel* (reploop #'toplevel-prompt)))))) + (signals interruption-event :msg "keyboard interrupt"))) + +(defun interruption-handler (c) + (print-error-msg c) + (let* ((*replevel* (1+ *replevel*)) + (*reptype* "B")) + (while (catch *replevel* (reploop #'toplevel-prompt))))) + +(install-handler interruption-event 'interruption-handler) ;; install handlers -(unix:install-signal-handler unix::sigint unix::sigint-received :msg "keyboard interrupt") +(unix:install-signal-handler unix::sigint unix::sigint-received) (unix:install-signal-handler unix::sigcont unix::sigcont-received)) (install-handler error #'euserror) (install-handler unix::sigint-received 'sigint-handler) From b31dc3c73c605e17f3fa7aa6424d703c24c527ca Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 Sep 2019 17:07:34 +0900 Subject: [PATCH 062/387] Avoid errors when sigcont is received on toplevel --- lisp/l/conditions.l | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 0003a7f01..d82ce835e 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -125,7 +125,10 @@ (unix:install-signal-handler unix::sigcont unix::sigcont-received)) (install-handler error #'euserror) (install-handler unix::sigint-received 'sigint-handler) -(install-handler unix::sigcont-received `(lambda-closure ,(gensym) 0 0 (c) (reset *replevel*))) +(install-handler unix::sigcont-received + `(lambda-closure ,(gensym) 0 0 (c) + (when (memq *replevel* (sys::list-all-catchers)) + (reset *replevel*)))) ;; in order to remain in the same stack, reset command must not be compiled ;; TODO: find out why this happens ) From a2e0a6f1200c90bb6f81ea5023160115df853924 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 13 Sep 2019 15:40:26 +0900 Subject: [PATCH 063/387] Use slots not props in conditions --- lisp/c/eus.c | 10 +++++----- lisp/l/conditions.l | 22 +++++++++++----------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index c0ee29890..a1397a9e3 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -425,9 +425,9 @@ va_dcl errobj=makeobject(C_ERROR); break; } - putprop(ctx,errobj,msg,defkeyword(ctx,"MSG")); - putprop(ctx,errobj,callstack,defkeyword(ctx,"CALLSTACK")); - putprop(ctx,errobj,form,defkeyword(ctx,"FORM")); + pointer_update(errobj->c.obj.iv[0],msg); + pointer_update(errobj->c.obj.iv[1],callstack); + pointer_update(errobj->c.obj.iv[2],form); arglst=cons(ctx,errobj,NIL); Spevalof(QEVALHOOK)=NIL; /* reset eval hook */ @@ -858,8 +858,8 @@ static void initclasses() C_BIGNUM=speval(BIGNUM); /* conditions */ - C_CONDITION=speval(basicclass("CONDITION",C_PROPOBJ,&conditioncp,0)); - C_ERROR=speval(basicclass("ERROR",C_CONDITION,&errorcp,0)); + C_CONDITION=speval(basicclass("CONDITION",C_OBJECT,&conditioncp,1,"MSG")); + 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)); diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index d82ce835e..c75e30b05 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -6,12 +6,12 @@ interruption-event handler-bind handler-case next-handler)) (defmethod condition - (:init (&rest init-args &key &allow-other-keys) - (while init-args - (let* ((name (pop init-args)) - (value (pop init-args))) - (setf (get self name) value))) - self)) + (:init (&optional msg) (send self :msg msg) self) + (:msg (&optional val) (if val (setq msg val) msg))) + +(defmethod error + (:callstack (&optional val) (if val (setq callstack val) callstack)) + (:form (&optional val) (if val (setq form val) form))) (defun install-handler (label handler) (assert (and (classp label) (derivedp (instantiate label) condition)) @@ -63,10 +63,10 @@ (format os "~3D: at ~S~%" i (nth i stack)))))) (defun print-error-msg (err &optional (os *error-output*)) - (when (get err :msg) + (when (send err :msg) (format os "~C[1;3~Cm~A~C[0m: ~A" - #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (get err :msg)) - (if (get err :form) (format os " in ~S" (get err :form))) + #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (send err :msg)) + (if (send err :form) (format os " in ~S" (send err :form))) (terpri os))) @@ -75,8 +75,8 @@ ;;; (defun euserror (err) - (when (get err :callstack) - (print-callstack (get err :callstack) *max-callstack-depth*)) + (when (send err :callstack) + (print-callstack (send err :callstack) *max-callstack-depth*)) (print-error-msg err) (let ((*replevel* (1+ *replevel*)) (*reptype* "E")) From 5c0b1069e2d8bc4333c3bc61fbaa5a4b8eaed070 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 17 Sep 2019 16:53:55 +0900 Subject: [PATCH 064/387] Update logger.l to use slots --- lib/llib/logger.l | 26 +++++++++++++++++++------- lisp/l/conditions.l | 9 +++++---- 2 files changed, 24 insertions(+), 11 deletions(-) diff --git a/lib/llib/logger.l b/lib/llib/logger.l index dbbcfc145..5b7dffb4b 100644 --- a/lib/llib/logger.l +++ b/lib/llib/logger.l @@ -5,7 +5,13 @@ (export '(set-logger-level log-debug log-info log-warn log-error log-fatal)) ;; Condition instance for logger messages -(defclass logger-message :super condition) +(defclass logger-message :super condition :slots (lvl args)) +(defmethod logger-message + (:init (&key msg lvl args) + (send self :set-val 'msg msg) + (send self :set-val 'lvl lvl) + (send self :set-val 'args args) + self)) ;; Logger level related (defconstant logger-table @@ -31,12 +37,18 @@ (defmacro level-belongs (lvl &rest options) `(or ,@(mapcar #'(lambda (val) `(= ,lvl (get-level ,val))) options))) -(defmacro with-pval (slots instance &rest body) - `(let (,@(mapcar #'(lambda (name) `(,name (get ,instance ,(intern (symbol-pname name) *keyword-package*)))) slots)) - ,@body)) +(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-pval (msg lvl args) log + (with-slots (msg lvl args) log (format nil "[~A] ~A" (symbol-pname (get-level-name lvl)) (apply #'format nil msg args)))) @@ -57,8 +69,8 @@ ;; Printing callback (defun logger-callback (log) - (when (>= (get log :lvl) *logger-level*) - (let ((lvl (get log :lvl)) + (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) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index c75e30b05..9fcadb672 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -14,9 +14,9 @@ (:form (&optional val) (if val (setq form val) form))) (defun install-handler (label handler) - (assert (and (classp label) (derivedp (instantiate label) condition)) - "condition class expected") - (assert (functionp handler) "function expected") + (unless (and (classp label) (derivedp (instantiate label) condition)) + (error type-error "condition class expected")) + (unless (functionp handler) type-error "function expected") (push (cons label handler) *condition-handler*)) (defun remove-handler (label &optional handler) @@ -44,7 +44,7 @@ (defun signals (obj &rest init-args) (if (classp obj) (setq obj (instantiate obj))) (if init-args (send* obj :init init-args)) - (assert (derivedp obj condition) "condition class expected") + (unless (derivedp obj condition) (error type-error "condition class expected")) (block signals (dolist (handle *condition-handler*) (when (derivedp obj (car handle)) @@ -63,6 +63,7 @@ (format os "~3D: at ~S~%" i (nth i stack)))))) (defun print-error-msg (err &optional (os *error-output*)) + (unless (derivedp err error) (error type-error "error class expected")) (when (send err :msg) (format os "~C[1;3~Cm~A~C[0m: ~A" #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (send err :msg)) From 66b3e3b73cbb1881b668fb4dd2947ab3034c9363 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 17 Sep 2019 17:46:34 +0900 Subject: [PATCH 065/387] Implement 'defcondition' --- lib/llib/logger.l | 8 +------- lisp/l/conditions.l | 17 +++++++++++++++-- 2 files changed, 16 insertions(+), 9 deletions(-) diff --git a/lib/llib/logger.l b/lib/llib/logger.l index 5b7dffb4b..0850fc29f 100644 --- a/lib/llib/logger.l +++ b/lib/llib/logger.l @@ -5,13 +5,7 @@ (export '(set-logger-level log-debug log-info log-warn log-error log-fatal)) ;; Condition instance for logger messages -(defclass logger-message :super condition :slots (lvl args)) -(defmethod logger-message - (:init (&key msg lvl args) - (send self :set-val 'msg msg) - (send self :set-val 'lvl lvl) - (send self :set-val 'args args) - self)) +(defcondition logger-message :slots (lvl args)) ;; Logger level related (defconstant logger-table diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 9fcadb672..af9957d26 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -2,8 +2,9 @@ (in-package "LISP") -(export '(install-handler remove-handler signals euserror sigint-handler - interruption-event handler-bind handler-case next-handler)) +(export '(defcondition install-handler remove-handler signals euserror + sigint-handler interruption-event handler-bind handler-case + next-handler)) (defmethod condition (:init (&optional msg) (send self :msg msg) self) @@ -13,6 +14,18 @@ (:callstack (&optional val) (if val (setq callstack val) callstack)) (:form (&optional val) (if val (setq form val) form))) +(defmacro defcondition (name &key slots (super condition)) + (let ((all-slots (append (coerce (send super :slots) cons) slots))) + `(progn + (defclass ,name :slots ,slots :super ,super) + (defmethod ,name + (:init (&key ,@all-slots) + ,@(mapcar #'(lambda (place) `(send self :set-val ',place ,place)) all-slots) + self) + ,@(mapcar #'(lambda (s) `(,(intern (send s :pname) *keyword-package*) (&optional val) + (if val (send self :set-val ',s val) ,s))) + slots))))) + (defun install-handler (label handler) (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) From f018d1e7b701f3bc514e56758cb138e252f51161 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 18 Sep 2019 14:18:59 +0900 Subject: [PATCH 066/387] Fix bugs --- lisp/l/conditions.l | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index af9957d26..435c2a467 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -7,7 +7,7 @@ next-handler)) (defmethod condition - (:init (&optional msg) (send self :msg msg) self) + (:init (&key msg) (send self :msg msg) self) (:msg (&optional val) (if val (setq msg val) msg))) (defmethod error @@ -15,7 +15,7 @@ (:form (&optional val) (if val (setq form val) form))) (defmacro defcondition (name &key slots (super condition)) - (let ((all-slots (append (coerce (send super :slots) cons) slots))) + (let ((all-slots (append (coerce (send (symbol-value super) :slots) cons) slots))) `(progn (defclass ,name :slots ,slots :super ,super) (defmethod ,name @@ -76,11 +76,12 @@ (format os "~3D: at ~S~%" i (nth i stack)))))) (defun print-error-msg (err &optional (os *error-output*)) - (unless (derivedp err error) (error type-error "error class expected")) + (unless (derivedp err condition) (error type-error "condition class expected")) (when (send err :msg) (format os "~C[1;3~Cm~A~C[0m: ~A" #x1b (+ 1 48) (string-upcase (metaclass-name (class err))) #x1b (send err :msg)) - (if (send err :form) (format os " in ~S" (send err :form))) + (if (and (derivedp err error) (send err :form)) + (format os " in ~S" (send err :form))) (terpri os))) From 38680f9df38d302e66024f32cc051d2ae61301a6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 20 Sep 2019 08:48:43 +0900 Subject: [PATCH 067/387] Fix bug in defcondition expansion --- lisp/l/conditions.l | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 435c2a467..6661c4798 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -15,7 +15,8 @@ (:form (&optional val) (if val (setq form val) form))) (defmacro defcondition (name &key slots (super condition)) - (let ((all-slots (append (coerce (send (symbol-value super) :slots) cons) slots))) + (let* ((super (if (symbolp super) (symbol-value super) super)) + (all-slots (append (coerce (send super :slots) cons) slots))) `(progn (defclass ,name :slots ,slots :super ,super) (defmethod ,name From 94c1d076347b972409830f66ca18fc45d4008159 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 20 Sep 2019 08:49:02 +0900 Subject: [PATCH 068/387] Change install-handler return value --- lisp/l/conditions.l | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 6661c4798..cc51ab71f 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -31,7 +31,8 @@ (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) (unless (functionp handler) type-error "function expected") - (push (cons label handler) *condition-handler*)) + (push (cons label handler) *condition-handler*) + t) (defun remove-handler (label &optional handler) (setq *condition-handler* From 68e01f7f785d6399a2cea425f91e706c4c01fbda Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 20 Sep 2019 14:22:14 +0900 Subject: [PATCH 069/387] Avoid closures in unix signal handlers --- lisp/l/conditions.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index cc51ab71f..a197b3e76 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -116,7 +116,7 @@ (let ((fname (intern (format nil "~A-SIGNALIZE-CONDITION" (symbol-pname sig)) *unix-package*))) `(progn (defun ,fname (sig code) (signals ,obj ,@init-args)) - (unix:signal ,sig #',fname)))) + (unix:signal ,sig ',fname)))) (defmacro unix::with-alarm-interrupt (&rest body) (let ((interval (gensym)) (value (gensym))) From 45557190c240f98fc249712f61eb107d585076d1 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 20 Sep 2019 16:32:02 +0900 Subject: [PATCH 070/387] Fix defcondition --- lisp/l/conditions.l | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index a197b3e76..db0d2c216 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -15,17 +15,18 @@ (:form (&optional val) (if val (setq form val) form))) (defmacro defcondition (name &key slots (super condition)) - (let* ((super (if (symbolp super) (symbol-value super) super)) - (all-slots (append (coerce (send super :slots) cons) slots))) - `(progn - (defclass ,name :slots ,slots :super ,super) - (defmethod ,name - (:init (&key ,@all-slots) - ,@(mapcar #'(lambda (place) `(send self :set-val ',place ,place)) all-slots) - self) + `(progn + (defclass ,name :slots ,slots :super ,super) + (defmethod ,name ,@(mapcar #'(lambda (s) `(,(intern (send s :pname) *keyword-package*) (&optional val) (if val (send self :set-val ',s val) ,s))) - slots))))) + slots)) + (let ((all-slots (coerce (send ,name :slots) cons))) + (eval + `(defmethod ,',name + (:init (&key ,@all-slots) + ,@(mapcar #'(lambda (place) `(send self :set-val ',place ,place)) all-slots) + self)))))) (defun install-handler (label handler) (unless (and (classp label) (derivedp (instantiate label) condition)) From db160e49e55ad0c04e9a3f00e7455fa75fe7eac1 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 2 Oct 2019 09:41:39 +0900 Subject: [PATCH 071/387] Do not print uninterned symbol name before error msg --- lisp/c/reader.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/reader.c b/lisp/c/reader.c index 88b9d2bc1..eb5ab9704 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -721,7 +721,7 @@ char token[]; if (sym) return(sym); else { pkgstr=makestring(token,leng); - fprintf(stderr,"%s ",token); + // fprintf(stderr,"%s ",token); vpush(pkgstr); error(E_EXTSYMBOL,pkgstr);} } } From 50e56984552cceff90406b5d7717579c9a2c922e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 2 Oct 2019 13:45:37 +0900 Subject: [PATCH 072/387] Don't overwrite gensym name --- lisp/c/specials.c | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 0e0ec49e7..3fffbbd56 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -1212,17 +1212,23 @@ 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,n,argv) register context *ctx; From 170dc8e0e61378b9e2277f927b493597f8827291 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 2 Oct 2019 18:26:59 +0900 Subject: [PATCH 073/387] Avoid segfault on #S() and #J() --- lisp/c/reader.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lisp/c/reader.c b/lisp/c/reader.c index eb5ab9704..5b1d54a24 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -395,6 +395,9 @@ register pointer s; /*input stream*/ ch=nextch(ctx,s); 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_NOSYMBOL); klass=speval(name); @@ -432,6 +435,9 @@ register pointer s; /*input stream*/ ch=nextch(ctx,s); 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_NOSYMBOL); klass=speval(name); From b0dd5cd5b10aa05d32a4c74551bc509ff7e5112c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 2 Oct 2019 18:48:50 +0900 Subject: [PATCH 074/387] Avoid segfault on 'slot' for non-objects --- lisp/c/leo.c | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/c/leo.c b/lisp/c/leo.c index 01f2441ed..39d93937c 100644 --- a/lisp/c/leo.c +++ b/lisp/c/leo.c @@ -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); From 34d800b38382906fbb3a5c7b19f9ed39119db178 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Oct 2019 09:36:52 +0900 Subject: [PATCH 075/387] Remove unused .q file --- lisp/comp/comp.l | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 122f699f1..21abaca92 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1248,7 +1248,6 @@ (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))) @@ -1258,8 +1257,7 @@ (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))) + file.h (merge-pathnames ".h" o))) (when (null (probe-file file)) (setq file (merge-pathnames ".l" file)) (if (null (probe-file file)) @@ -1481,8 +1479,6 @@ )) (load pname) (unix:unlink (namestring pname)) - (setq pname (make-pathname :defaults fname :type "q")) - (unix:unlink (namestring pname)) funcs )) From ea94602a87bd17dbf57675b1fc3fbaf951e69487 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Oct 2019 09:52:41 +0900 Subject: [PATCH 076/387] Unlink .o files on 'compile' function --- lisp/comp/comp.l | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 21abaca92..e49e2fe60 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1479,6 +1479,8 @@ )) (load pname) (unix:unlink (namestring pname)) + #+(or :linux :cygwin) + (unix:unlink (namestring (make-pathname :defaults fname :type "o"))) funcs )) From 32541a82e47fa1e62c230c0a0119ad7461dea431 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 3 Oct 2019 16:52:29 +0900 Subject: [PATCH 077/387] Check for recursion on list_callstack --- lisp/c/sysfunc.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index ea201d9da..447ab5507 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -695,7 +695,12 @@ int max; vf=(struct callframe *)(ctx->callfp); // list whole stack for negative max values for (i=0; vf->vlink && max; vf=vf->vlink, i++, max--) { - vpush(vf->form);} + vpush(vf->form); + // Check for recursive stacks + if ((pointer)vf == (pointer)vf->vlink) { + fprintf(stderr,";; recursive callstack detected in %p\n", (pointer)vf); + i++; + break;}} return(stacknlist(ctx,i));} pointer LISTCALLSTACK(ctx,n,argv) From 8c2f7e589e820c79fba5496aac9676f398fec421 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 3 Oct 2019 17:19:30 +0900 Subject: [PATCH 078/387] Simplify defcondition by centralizing computaion on 'condition' class --- lisp/l/conditions.l | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index db0d2c216..15eaf78aa 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -7,26 +7,27 @@ next-handler)) (defmethod condition - (:init (&key msg) (send self :msg msg) self) + (:init (&rest init-args &key msg &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) (:msg (&optional val) (if val (setq msg val) msg))) (defmethod error (:callstack (&optional val) (if val (setq callstack val) callstack)) (:form (&optional val) (if val (setq form val) form))) -(defmacro defcondition (name &key slots (super condition)) +(defmacro defcondition (name &key slots (super 'condition)) `(progn (defclass ,name :slots ,slots :super ,super) (defmethod ,name + (:init (&rest init-args) (send-super* :init init-args)) ,@(mapcar #'(lambda (s) `(,(intern (send s :pname) *keyword-package*) (&optional val) (if val (send self :set-val ',s val) ,s))) - slots)) - (let ((all-slots (coerce (send ,name :slots) cons))) - (eval - `(defmethod ,',name - (:init (&key ,@all-slots) - ,@(mapcar #'(lambda (place) `(send self :set-val ',place ,place)) all-slots) - self)))))) + slots)))) (defun install-handler (label handler) (unless (and (classp label) (derivedp (instantiate label) condition)) From fda30b2b5f653537121062c783776365f580d69c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 8 Oct 2019 13:39:53 +0900 Subject: [PATCH 079/387] Do not jump at next-handler and introduce *current-condition* --- lisp/l/conditions.l | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 15eaf78aa..0fbd4af65 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -6,6 +6,9 @@ sigint-handler interruption-event handler-bind handler-case next-handler)) +(defvar *current-condition*) +(defvar *current-condition-handler*) ;; for next-handler + (defmethod condition (:init (&rest init-args &key msg &allow-other-keys) ;; Initialize slots @@ -62,13 +65,19 @@ (if (classp obj) (setq obj (instantiate obj))) (if init-args (send* obj :init init-args)) (unless (derivedp obj condition) (error type-error "condition class expected")) - (block signals - (dolist (handle *condition-handler*) - (when (derivedp obj (car handle)) - (catch :next-handler - (return-from signals (funcall (cdr handle) obj))))))) - -(defun next-handler () (throw :next-handler nil)) + (do ((*current-condition-handler* *condition-handler* (cdr *current-condition-handler*)) + (*current-condition* obj)) + ((null *current-condition-handler*)) + (when (derivedp obj (caar *current-condition-handler*)) + (return (funcall (cdar *current-condition-handler*) obj))))) + +(defun next-handler (&optional (obj *current-condition*)) + (do ((*current-condition-handler* + (cdr *current-condition-handler*) + (cdr *current-condition-handler*))) + ((null *current-condition-handler*)) + (when (derivedp obj (caar *current-condition-handler*)) + (return (funcall (cdar *current-condition-handler*) obj))))) (defun print-callstack (&optional (stack (sys:list-callstack)) max (os *error-output*)) (let ((tms (if max From 6a8bbe71337a0778aa930a4b088147e254674299 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 8 Oct 2019 14:21:48 +0900 Subject: [PATCH 080/387] Define condition on unix::install-signal-handler expansion --- lisp/l/conditions.l | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 0fbd4af65..c198ec48a 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -120,12 +120,12 @@ ;;; unix:signal handling ;;; -(defclass unix::signal-received :super condition) -(defclass unix::sigint-received :super unix::signal-received) -(defclass unix::sigcont-received :super unix::signal-received) +(defcondition unix::signal-received) (defmacro unix::install-signal-handler (sig obj &rest init-args) (let ((fname (intern (format nil "~A-SIGNALIZE-CONDITION" (symbol-pname sig)) *unix-package*))) `(progn + (unless (boundp ',obj) + (defcondition ,obj :super unix::signal-received)) (defun ,fname (sig code) (signals ,obj ,@init-args)) (unix:signal ,sig ',fname)))) From 3bfdf07fa245e0abd9ba445e2ea575dbd08d21ca Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 8 Oct 2019 15:19:53 +0900 Subject: [PATCH 081/387] Change condition slot name msg -> message --- lisp/c/eus.c | 2 +- lisp/l/conditions.l | 16 ++++++++-------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index a1397a9e3..fe780a282 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -858,7 +858,7 @@ static void initclasses() C_BIGNUM=speval(BIGNUM); /* conditions */ - C_CONDITION=speval(basicclass("CONDITION",C_OBJECT,&conditioncp,1,"MSG")); + 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)); diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index c198ec48a..c67780a2a 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -10,14 +10,14 @@ (defvar *current-condition-handler*) ;; for next-handler (defmethod condition - (:init (&rest init-args &key msg &allow-other-keys) + (: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) - (:msg (&optional val) (if val (setq msg val) msg))) + (:message (&optional val) (if val (setq message val) message))) (defmethod error (:callstack (&optional val) (if val (setq callstack val) callstack)) @@ -88,11 +88,11 @@ (dotimes (i tms) (format os "~3D: at ~S~%" i (nth i stack)))))) -(defun print-error-msg (err &optional (os *error-output*)) +(defun print-error-message (err &optional (os *error-output*)) (unless (derivedp err condition) (error type-error "condition class expected")) - (when (send err :msg) + (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 :msg)) + #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))) @@ -105,7 +105,7 @@ (defun euserror (err) (when (send err :callstack) (print-callstack (send err :callstack) *max-callstack-depth*)) - (print-error-msg err) + (print-error-message err) (let ((*replevel* (1+ *replevel*)) (*reptype* "E")) ;; do not carry handlers through the error stack @@ -138,10 +138,10 @@ (defclass interruption-event :super condition) (defun sigint-handler (c) (unix::with-alarm-interrupt - (signals interruption-event :msg "keyboard interrupt"))) + (signals interruption-event :message "keyboard interrupt"))) (defun interruption-handler (c) - (print-error-msg c) + (print-error-message c) (let* ((*replevel* (1+ *replevel*)) (*reptype* "B")) (while (catch *replevel* (reploop #'toplevel-prompt))))) From bac6cdf6ebb96bedbe8bfcde9c533d0a471f6a87 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 8 Oct 2019 17:13:38 +0900 Subject: [PATCH 082/387] Use nil name for sigcont-received handler --- lisp/l/conditions.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index c67780a2a..5391df6af 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -154,7 +154,7 @@ (install-handler error #'euserror) (install-handler unix::sigint-received 'sigint-handler) (install-handler unix::sigcont-received - `(lambda-closure ,(gensym) 0 0 (c) + '(lambda-closure nil 0 0 (c) (when (memq *replevel* (sys::list-all-catchers)) (reset *replevel*)))) ;; in order to remain in the same stack, reset command must not be compiled From ee166d7b9509d6f34fba98a1d4b56280b4ed07d2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 8 Oct 2019 20:11:12 +0900 Subject: [PATCH 083/387] Update condition slot name in logger.l --- lib/llib/logger.l | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/lib/llib/logger.l b/lib/llib/logger.l index 0850fc29f..ecbd78c41 100644 --- a/lib/llib/logger.l +++ b/lib/llib/logger.l @@ -42,23 +42,23 @@ ,@body))) (defun format-log-message (log) - (with-slots (msg lvl args) log + (with-slots (message lvl args) log (format nil "[~A] ~A" (symbol-pname (get-level-name lvl)) - (apply #'format nil msg args)))) + (apply #'format nil message args)))) ;; Loggers signalers (defun log-debug (msg &rest format-args) - (signals logger-message :msg msg :lvl (get-level :debug) :args format-args)) + (signals logger-message :message msg :lvl (get-level :debug) :args format-args)) (defun log-info (msg &rest format-args) - (signals logger-message :msg msg :lvl (get-level :info) :args format-args)) + (signals logger-message :message msg :lvl (get-level :info) :args format-args)) (defun log-warn (msg &rest format-args) - (signals logger-message :msg msg :lvl (get-level :warn) :args format-args)) + (signals logger-message :message msg :lvl (get-level :warn) :args format-args)) (defun log-error (msg &rest format-args) - (signals logger-message :msg msg :lvl (get-level :error) :args format-args)) + (signals logger-message :message msg :lvl (get-level :error) :args format-args)) (defun log-fatal (msg &rest format-args) - (signals logger-message :msg msg :lvl (get-level :fatal) :args format-args)) + (signals logger-message :message msg :lvl (get-level :fatal) :args format-args)) ;; Printing callback From 51233ff6b7c4c72bd4f5fa8adbeab8440fe8516d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 4 Oct 2019 09:54:34 +0900 Subject: [PATCH 084/387] Add macrolet compiler --- lisp/comp/comp.l | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index e49e2fe60..c50b2c6b1 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -255,6 +255,7 @@ (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 `(,(third fdef) ,@(cdr form))))) (closure (send self :call-closure fdef (cdr form))) (t (send self :error "unknown func type" form))) )))) (:get-function (fn) @@ -589,6 +590,7 @@ ((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) @@ -911,6 +913,12 @@ (send self :progn bodies) (setq flets (nthcdr (length funcs) flets)) (send trans :del-frame 0 (length funcs)))) + (:macrolet (funcs bodies) + (dolist (fn funcs) + (push (list (car fn) 'macrolet `(lambda ,@(cdr fn))) + flets)) + (send self :progn bodies) + (setq flets (nthcdr (length funcs) flets))) (:change-flets (newflets) (setq flets newflets)) (:declare (args) (let (v) From 7b90b6c1f1da522129b3048a827f4474290b3817 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 4 Oct 2019 09:55:30 +0900 Subject: [PATCH 085/387] Remove unused &aux in comp :flet --- lisp/comp/comp.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index c50b2c6b1..bc8109fc1 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -892,7 +892,7 @@ (setq newcomp (send self :copy-compiler)) (send self :add-closure (list entry fn newcomp)) ))) - (:flet (funcs bodies recursive-scope &aux (flets-save flets)) + (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet (let (entry newcomp newcomps flets-exchange) (dolist (fn funcs) From a8a74599798330f50c8c731f99a664d18eb64ea5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 7 Oct 2019 16:26:53 +0900 Subject: [PATCH 086/387] Add &key supplied-p compiler --- lisp/comp/comp.l | 48 +++++++++++++++++++++++++++++++++++------------ lisp/comp/trans.l | 1 - 2 files changed, 36 insertions(+), 13 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index bc8109fc1..17898b311 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -961,16 +961,14 @@ (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) (specially-bound nil) (allowotherkeys (memq '&allow-other-keys param)) - (unwind-save unwind-frames) - (vname nil) - (label2)) + (unwind-save unwind-frames)) (setq req-vars (reverse (nthcdr (length (cond (opt-vars) @@ -1002,9 +1000,15 @@ (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)) @@ -1021,10 +1025,12 @@ *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) + (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)) @@ -1057,16 +1063,34 @@ (1- (send trans :offset-from-fp)))) ((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)) + (svar-key-base key-base) + vname svar label2) + ;; reset vsp + (send trans :reset-vsp) + ;; initialize all supplied-p variables to t + (dolist (svar key-supplied-vars) + (when svar + (send trans :load-t) + (send self :bind svar 'local key-base) + (inc key-base))) + (send trans :parse-key-params (coerce key-names vector) + (+ reqn optn) + keyn allowotherkeys) + (dotimes (i keyn) (setq labels (send self :genlabel "KEY")) (send trans :check-key-arg i labels) ; go around evaluating default for a key-var - (send self :eval (pop key-inits)) (setq vname (pop key-vars)) + (setq svar (pop key-supplied-vars)) + ;; set supplied-p variables to nil + (when svar + (send trans :load-nil) + (send trans :store-local svar-key-base 0) + ;; (send self :bind svar 'local svar-key-base) + (inc svar-key-base)) + (send self :eval (pop key-inits)) + ;; set default values (cond ((send self :special-variable-p vname) (setq label2 (send self :genlabel "KEY")) (send trans :jump label2) @@ -1078,7 +1102,7 @@ (t ;non-special (send self :bind vname 'local (+ key-base i)) (send trans :store-local (+ key-base i) 0) - (send trans :label labels) ) ) + (send trans :label labels)))) ) ) ;;; bind aux variables (dolist (av aux-vars) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index d763c1fb8..750e7822f 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -145,7 +145,6 @@ (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 " n=parsekeyparams(fqv[~d], &argv[~d], n-~d, local+~d, ~A);~%" (send self :quote-entry keyvec) req+opt req+opt From a52c11b352600c9c9d2cc3102c4bdf894787ed62 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 7 Oct 2019 17:23:38 +0900 Subject: [PATCH 087/387] Add &optional supplied-p compiler --- lisp/comp/comp.l | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 17898b311..38da6505f 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -956,6 +956,8 @@ (reqn 0) (optn 0) (keyn 0) + (svar-base 0) + (opt-supplied-vars) (opt-vars (memq '&optional param)) (rest-var (memq '&rest param)) (key-forms (memq '&key param)) @@ -995,6 +997,15 @@ (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))) + (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) @@ -1047,8 +1058,19 @@ (dolist (v req-vars) ;for all required arguments (send self :bind v 'arg i) (inc i)) + ;; initialize all supplied-p variables to t + (dolist (svar opt-supplied-vars) + (when svar + (send trans :load-t) + (send self :bind svar 'local (1- (send trans :offset-from-fp))))) (while (cdr labels) (send trans :check-opt-arg i (car labels)) + ;; set supplied-p variables to nil + (when (pop opt-supplied-vars) + (send trans :load-nil) + (send trans :store-local svar-base 0) + (inc svar-base)) + ;; set init value (send self :eval (pop opt-forms)) (send trans :label (pop labels)) (send self :bind (pop opt-vars) 'local @@ -1087,7 +1109,6 @@ (when svar (send trans :load-nil) (send trans :store-local svar-key-base 0) - ;; (send self :bind svar 'local svar-key-base) (inc svar-key-base)) (send self :eval (pop key-inits)) ;; set default values From 78d198d74860d0fbeb6be807a847e5207dffcac3 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 2 Oct 2019 17:58:48 +0900 Subject: [PATCH 088/387] Allow to use nil as reduce :initial-value --- lisp/l/common.l | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index 8f832ce64..c58e24328 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -981,15 +981,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)) From 3cba0057058c4752bf595d94cd036b4737a096ed Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Oct 2019 22:29:32 +0900 Subject: [PATCH 089/387] Add conditions documentation --- doc/latex/controls.tex | 56 ++++++++++++++++++++++++++++++++++++++ doc/latex/euslisp.hlp | 61 +++++++++++++++++++++++++++--------------- 2 files changed, 96 insertions(+), 21 deletions(-) diff --git a/doc/latex/controls.tex b/doc/latex/controls.tex index 20f22ff75..532be3055 100644 --- a/doc/latex/controls.tex +++ b/doc/latex/controls.tex @@ -138,6 +138,7 @@ \subsection{Blocks and Exits} \end{refdesc} + \subsection{Iteration} \begin{refdesc} @@ -271,4 +272,59 @@ \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. + +\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.} +\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}{}{} + +\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 registered for 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{next-handler}{\&optional (obj lisp::*current-condition*)}{ + Can be called from inside a condition handler to call the next handler matching {\em obj}.} + +\end{refdesc} + \newpage diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index b8ffe2cae..ef8899857 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -22,27 +22,46 @@ "catch" 6 "controls" 4721 3 "throw" 6 "controls" 4956 3 "unwind-protect" 6 "controls" 5090 3 -"while" 6 "controls" 5641 3 -"tagbody" 6 "controls" 6244 3 -"go" 6 "controls" 6374 3 -"prog" 3 "controls" 6589 3 -"do" 3 "controls" 6772 3 -"do*" 3 "controls" 7287 3 -"dotimes" 3 "controls" 7538 3 -"dolist" 3 "controls" 7766 3 -"until" 3 "controls" 8163 3 -"loop" 3 "controls" 8252 3 -"eq" 2 "controls" 8584 3 -"eql" 2 "controls" 8811 3 -"equal" 2 "controls" 8948 3 -"superequal" 2 "controls" 9209 3 -"null" 2 "controls" 9318 3 -"not" 2 "controls" 9406 3 -"atom" 2 "controls" 9470 3 -"every" 2 "controls" 9696 3 -"some" 2 "controls" 9860 3 -"functionp" 2 "controls" 10055 3 -"compiled-function-p" 2 "controls" 10462 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" 10870 4 +":init" 1 "controls" 10957 3 +"error" 0 "controls" 11230 4 +"argument-error" 0 "controls" 11331 4 +"program-error" 0 "controls" 11368 4 +"name-error" 0 "controls" 11402 4 +"type-error" 0 "controls" 11436 4 +"value-error" 0 "controls" 11471 4 +"index-error" 0 "controls" 11506 4 +"io-error" 0 "controls" 11538 4 +"lisp::*condition-handler*" 5 "controls" 11586 2 +"lisp::*current-condition*" 5 "controls" 11671 2 +"defcondition" 3 "controls" 11746 3 +"install-handler" 2 "controls" 11948 3 +"remove-handler" 2 "controls" 12249 3 +"handler-bind" 2 "controls" 12465 3 +"handler-case" 3 "controls" 12733 3 +"signals" 2 "controls" 13031 3 +"next-handler" 2 "controls" 13276 3 "defclass" 3 "objects" 3223 3 "defmethod" 6 "objects" 3684 3 "defclassmethod" 3 "objects" 3859 2 From aa57fb1315eaac0e551333208d98a6c442055e32 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Oct 2019 23:39:21 +0900 Subject: [PATCH 090/387] Remove unused *error-handler* --- contrib/utyo/select.l | 1 - lisp/c/eus.c | 3 +-- lisp/c/eus.h | 2 +- lisp/comp/comp.l | 3 +-- lisp/l/eusdebug.l | 20 ++++++++++---------- lisp/l/eusstart.l | 2 +- lisp/l/exports.l | 2 +- lisp/l/toplevel.l | 6 ++---- 8 files changed, 17 insertions(+), 22 deletions(-) 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/lisp/c/eus.c b/lisp/c/eus.c index fe780a282..fca846088 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -125,7 +125,7 @@ pointer SELF; pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; -pointer TOPLEVEL,QEVALHOOK,ERRHANDLER,FATALERROR; +pointer TOPLEVEL,QEVALHOOK,FATALERROR; pointer CONDITIONHANDLER; pointer QGCHOOK, QEXITHOOK; pointer QUNBOUND,QDEBUG; @@ -692,7 +692,6 @@ static void initsymbols() PRLEVEL=deflocal(ctx,"*PRINT-LEVEL*",NIL,lisppkg); QREADTABLE=deflocal(ctx,"*READTABLE*",NIL,lisppkg); TOPLEVEL=defvar(ctx,"*TOPLEVEL*",NIL,lisppkg); - ERRHANDLER=deflocal(ctx,"*ERROR-HANDLER*",NIL,lisppkg); CONDITIONHANDLER=deflocal(ctx,"*CONDITION-HANDLER*",NIL,lisppkg); QEVALHOOK=deflocal(ctx,"*EVALHOOK*",NIL,lisppkg); QUNBOUND=intern(ctx,"*UNBOUND*",9,lisppkg); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 1a95a9ada..7c5895878 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -663,7 +663,7 @@ 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 TOPLEVEL,QEVALHOOK; extern pointer QGCHOOK, QEXITHOOK; extern pointer QUNBOUND,QDEBUG; extern pointer QTHREADS; diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 38da6505f..18c5b904b 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1554,8 +1554,7 @@ (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/l/eusdebug.l b/lisp/l/eusdebug.l index 498239cc2..42a783bfa 100644 --- a/lisp/l/eusdebug.l +++ b/lisp/l/eusdebug.l @@ -251,11 +251,11 @@ (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) + (format *error-output* + "step evaluation error ~A~%" x) + (throw 'step-error nil)))) (print (eval input))))))) (t (format t ";; e?")))) (dec *tracelevel*) @@ -367,7 +367,7 @@ (print (elt obj command))) (t (catch 'inspect-eval - (let ((*error-handler* + (handler-bind ((error '(lambda (ec form &optional msg1 msg2) (warn "error ~s ~s ~s" form msg1 msg2) (throw 'inspect-eval t)))) @@ -665,10 +665,10 @@ finds method-class pair which include name as substring of the method name" (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/eusstart.l b/lisp/l/eusstart.l index 445496438..628b66f9e 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -25,7 +25,7 @@ (export '(*print-case* *print-circle* *print-object* *print-structure* *print-length* *print-level* *readtable* *toplevel* *read-base* *print-base* - *error-handler* *evalhook* *debug* *exit-on-fatal-error* + *evalhook* *debug* *exit-on-fatal-error* *unbound* *random-state* *features* *package* *standard-input* *standard-output* diff --git a/lisp/l/exports.l b/lisp/l/exports.l index 85ca4fbb3..6a5b5e6ee 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -22,7 +22,7 @@ (export '(*print-case* *print-circle* *print-object* *print-structure* *print-length* *print-level* *readtable* *toplevel* *read-base* *print-base* - *error-handler* *evalhook* *debug* + *evalhook* *debug* *unbound* *random-state* *features* *package* *standard-input* *standard-output* diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 9f64b68cf..c86e29063 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -202,8 +202,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) @@ -224,8 +223,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) From b65448fe760d8c11ccfcd1cb7a9ab760aab30308 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Oct 2019 08:45:15 +0900 Subject: [PATCH 091/387] Change condition name interruption-event -> interruption --- lisp/l/conditions.l | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 5391df6af..4075d6534 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -3,7 +3,7 @@ (in-package "LISP") (export '(defcondition install-handler remove-handler signals euserror - sigint-handler interruption-event handler-bind handler-case + sigint-handler interruption handler-bind handler-case next-handler)) (defvar *current-condition*) @@ -135,10 +135,10 @@ ,@body (unix:setitimer 0 ,value ,interval)))) -(defclass interruption-event :super condition) +(defcondition interruption) (defun sigint-handler (c) (unix::with-alarm-interrupt - (signals interruption-event :message "keyboard interrupt"))) + (signals interruption :message "keyboard interrupt"))) (defun interruption-handler (c) (print-error-message c) @@ -146,7 +146,7 @@ (*reptype* "B")) (while (catch *replevel* (reploop #'toplevel-prompt))))) -(install-handler interruption-event 'interruption-handler) +(install-handler interruption 'interruption-handler) ;; install handlers (unix:install-signal-handler unix::sigint unix::sigint-received) From ba0b4ec8a2d5726e6bde0ea069cde91661aad8d2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Oct 2019 11:36:03 +0900 Subject: [PATCH 092/387] Update conditions documentation --- doc/latex/controls.tex | 9 -- doc/latex/euslisp.hlp | 300 ++++++++++++++++++++------------------- doc/latex/evaluation.tex | 106 +++++++------- doc/latex/sysfunc.tex | 2 +- 4 files changed, 202 insertions(+), 215 deletions(-) diff --git a/doc/latex/controls.tex b/doc/latex/controls.tex index 532be3055..f5ab7bfb8 100644 --- a/doc/latex/controls.tex +++ b/doc/latex/controls.tex @@ -284,15 +284,6 @@ \subsection{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.} -\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}{}{} \vardesc{lisp::*condition-handler*}{ Holds the alist of conditions and handlers.} diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index ef8899857..04f3aa1c7 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -45,23 +45,15 @@ "compiled-function-p" 2 "controls" 10463 3 "condition" 0 "controls" 10870 4 ":init" 1 "controls" 10957 3 -"error" 0 "controls" 11230 4 -"argument-error" 0 "controls" 11331 4 -"program-error" 0 "controls" 11368 4 -"name-error" 0 "controls" 11402 4 -"type-error" 0 "controls" 11436 4 -"value-error" 0 "controls" 11471 4 -"index-error" 0 "controls" 11506 4 -"io-error" 0 "controls" 11538 4 -"lisp::*condition-handler*" 5 "controls" 11586 2 -"lisp::*current-condition*" 5 "controls" 11671 2 -"defcondition" 3 "controls" 11746 3 -"install-handler" 2 "controls" 11948 3 -"remove-handler" 2 "controls" 12249 3 -"handler-bind" 2 "controls" 12465 3 -"handler-case" 3 "controls" 12733 3 -"signals" 2 "controls" 13031 3 -"next-handler" 2 "controls" 13276 3 +"lisp::*condition-handler*" 5 "controls" 11249 2 +"lisp::*current-condition*" 5 "controls" 11334 2 +"defcondition" 3 "controls" 11409 3 +"install-handler" 2 "controls" 11611 3 +"remove-handler" 2 "controls" 11912 3 +"handler-bind" 2 "controls" 12128 3 +"handler-case" 3 "controls" 12396 3 +"signals" 2 "controls" 12694 3 +"next-handler" 2 "controls" 12939 3 "defclass" 3 "objects" 3223 3 "defmethod" 6 "objects" 3684 3 "defclassmethod" 3 "objects" 3859 2 @@ -482,75 +474,89 @@ "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 +"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 +"lisp::print-error-message" 2 "evaluation" 5697 3 +"interruption" 0 "evaluation" 5832 4 +"unix::signal-received" 0 "evaluation" 5882 4 +"unix::sigint-received" 0 "evaluation" 5931 4 +"unix::sigcont-received" 0 "evaluation" 5993 4 +"unix:install-signal-handler" 3 "evaluation" 6061 3 +"*prompt-string*" 5 "evaluation" 11489 2 +"*program-name*" 5 "evaluation" 11553 2 +"eustop" 2 "evaluation" 11665 3 +"sigint-handler" 2 "evaluation" 11737 3 +"euserror" 2 "evaluation" 11913 3 +"reset" 2 "evaluation" 12037 3 +"exit" 2 "evaluation" 12156 3 +"*top-selector*" 5 "evaluation" 12321 2 +"h" 2 "evaluation" 12448 3 +"!" 2 "evaluation" 12560 3 +"new-history" 2 "evaluation" 13418 3 +"compile-file" 2 "evaluation" 19090 3 +"compile" 2 "evaluation" 19771 3 +"compile-file-if-src-newer" 2 "evaluation" 20022 3 +"compiler:*optimize*" 5 "evaluation" 20243 2 +"compiler:*verbose*" 5 "evaluation" 20304 2 +"compiler:*safety*" 5 "evaluation" 20464 2 +"load" 2 "evaluation" 20592 3 +"load-files" 2 "evaluation" 24019 3 +"*modules*" 5 "evaluation" 24121 2 +"provide" 2 "evaluation" 24210 3 +"require" 2 "evaluation" 24537 3 +"system:binload" 2 "evaluation" 25504 3 +"system::txtload" 2 "evaluation" 25696 2 +"describe" 2 "evaluation" 25793 3 +"describe-list" 2 "evaluation" 25926 3 +"inspect" 3 "evaluation" 26037 3 +"more" 2 "evaluation" 26282 3 +"break" 2 "evaluation" 26562 3 +"help" 2 "evaluation" 26766 3 +"apropos" 2 "evaluation" 27377 3 +"apropos-list" 2 "evaluation" 27746 3 +"constants" 2 "evaluation" 27876 3 +"variables" 2 "evaluation" 28025 3 +"functions" 2 "evaluation" 28179 3 +"btrace" 2 "evaluation" 28332 3 +"step-hook" 2 "evaluation" 28421 2 +"step" 2 "evaluation" 28448 3 +"trace" 2 "evaluation" 28572 3 +"untrace" 2 "evaluation" 28719 3 +"timing" 3 "evaluation" 28774 3 +"time" 3 "evaluation" 28905 3 +"lisp::print-callstack" 2 "evaluation" 29005 3 +"sys:list-callstack" 2 "evaluation" 29259 3 +"sys:list-all-catchers" 2 "evaluation" 29453 3 +"sys:list-all-instances" 2 "evaluation" 29532 3 +"sys:list-all-bindings" 2 "evaluation" 29829 3 +"sys:list-all-special-bindings" 2 "evaluation" 29950 3 +"dump-object" 2 "evaluation" 30556 2 +"dump-structure" 2 "evaluation" 30604 3 +"dump-loadable-structure" 2 "evaluation" 30735 3 +"sys:save" 2 "evaluation" 31607 3 +"lisp-implementation-type" 2 "evaluation" 34317 3 +"lisp-implementation-version" 2 "evaluation" 34386 3 "sys:gc" 2 "sysfunc" 4802 3 "sys:*gc-hook*" 5 "sysfunc" 4933 2 "sys:gctime" 2 "sysfunc" 5021 3 @@ -632,67 +638,67 @@ "unix:getservbyname" 2 "sysfunc" 19689 3 "unix:gethostbyname" 2 "sysfunc" 19848 3 "unix:syserrlist" 2 "sysfunc" 19991 3 -"unix:signal" 2 "sysfunc" 20164 3 -"unix:kill" 2 "sysfunc" 20659 3 -"unix:pause" 2 "sysfunc" 20744 3 -"unix:alarm" 2 "sysfunc" 20830 3 -"unix:ualarm" 2 "sysfunc" 21126 3 -"unix:getitimer" 2 "sysfunc" 21365 3 -"unix:setitimer" 2 "sysfunc" 21906 3 -"unix:select" 2 "sysfunc" 22252 3 -"unix:select-read-fd" 2 "sysfunc" 23094 3 -"unix:thr-self" 2 "sysfunc" 23628 3 -"unix:thr-getprio" 2 "sysfunc" 23719 3 -"unix:thr-setprio" 2 "sysfunc" 23822 3 -"unix:thr-getconcurrency" 2 "sysfunc" 24217 3 -"unix:thr-setconcurrency" 2 "sysfunc" 24363 3 -"unix:thr-create" 2 "sysfunc" 24952 3 -"unix:malloc" 2 "sysfunc" 25321 3 -"unix:free" 2 "sysfunc" 25401 3 -"unix:valloc" 2 "sysfunc" 25495 2 -"unix:mmap" 2 "sysfunc" 25525 2 -"unix:munmap" 2 "sysfunc" 25595 2 -"unix:vadvise" 2 "sysfunc" 25635 2 -"unix:tiocgetp" 2 "sysfunc" 26354 3 -"unix:tiocsetp" 2 "sysfunc" 26427 3 -"unix:tiocsetn" 2 "sysfunc" 26488 2 -"unix:tiocgetd" 2 "sysfunc" 26541 2 -"unix:tiocflush" 2 "sysfunc" 26596 3 -"unix:tiocgpgrp" 2 "sysfunc" 26656 3 -"unix:tiocspgrp" 2 "sysfunc" 26724 3 -"unix:tiocoutq" 2 "sysfunc" 26790 2 -"unix:fionread" 2 "sysfunc" 26831 2 -"unix:tiocsetc" 2 "sysfunc" 26872 2 -"unix:tioclbis" 2 "sysfunc" 26909 2 -"unix:tioclbic" 2 "sysfunc" 26946 2 -"unix:tioclset" 2 "sysfunc" 26983 2 -"unix:tioclget" 2 "sysfunc" 27020 2 -"unix:tcseta" 2 "sysfunc" 27056 3 -"unix:tcsets" 2 "sysfunc" 27135 3 -"unix:tcsetsw" 2 "sysfunc" 27203 3 -"unix:tcsetsf" 2 "sysfunc" 27332 3 -"unix:tiocsetc" 2 "sysfunc" 27511 2 -"unix:tcsetaf" 2 "sysfunc" 27550 2 -"unix:tcsetaw" 2 "sysfunc" 27589 2 -"unix:tcgeta" 2 "sysfunc" 27627 2 -"unix:tcgets" 2 "sysfunc" 27665 2 -"unix:tcgetattr" 2 "sysfunc" 27706 2 -"unix:tcsetattr" 2 "sysfunc" 27747 2 -"dbm-open" 2 "sysfunc" 28252 3 -"dbm-store" 2 "sysfunc" 29042 3 -"dbm-fetch" 2 "sysfunc" 29257 3 -"cd" 2 "sysfunc" 30697 3 -"ez" 2 "sysfunc" 30792 3 -"piped-fork" 2 "sysfunc" 30909 3 -"xfork" 2 "sysfunc" 31333 3 -"rusage" 2 "sysfunc" 32004 3 -"load-foreign" 3 "sysfunc" 38817 3 -"defforeign" 3 "sysfunc" 41375 3 -"defun-c-callable" 3 "sysfunc" 43894 3 -"pod-address" 2 "sysfunc" 44909 3 -"array-entity" 3 "sysfunc" 45174 3 -"float2double" 2 "sysfunc" 45457 3 -"double2float" 2 "sysfunc" 45676 3 +"unix:signal" 2 "sysfunc" 20169 3 +"unix:kill" 2 "sysfunc" 20664 3 +"unix:pause" 2 "sysfunc" 20749 3 +"unix:alarm" 2 "sysfunc" 20835 3 +"unix:ualarm" 2 "sysfunc" 21131 3 +"unix:getitimer" 2 "sysfunc" 21370 3 +"unix:setitimer" 2 "sysfunc" 21911 3 +"unix:select" 2 "sysfunc" 22257 3 +"unix:select-read-fd" 2 "sysfunc" 23099 3 +"unix:thr-self" 2 "sysfunc" 23633 3 +"unix:thr-getprio" 2 "sysfunc" 23724 3 +"unix:thr-setprio" 2 "sysfunc" 23827 3 +"unix:thr-getconcurrency" 2 "sysfunc" 24222 3 +"unix:thr-setconcurrency" 2 "sysfunc" 24368 3 +"unix:thr-create" 2 "sysfunc" 24957 3 +"unix:malloc" 2 "sysfunc" 25326 3 +"unix:free" 2 "sysfunc" 25406 3 +"unix:valloc" 2 "sysfunc" 25500 2 +"unix:mmap" 2 "sysfunc" 25530 2 +"unix:munmap" 2 "sysfunc" 25600 2 +"unix:vadvise" 2 "sysfunc" 25640 2 +"unix:tiocgetp" 2 "sysfunc" 26359 3 +"unix:tiocsetp" 2 "sysfunc" 26432 3 +"unix:tiocsetn" 2 "sysfunc" 26493 2 +"unix:tiocgetd" 2 "sysfunc" 26546 2 +"unix:tiocflush" 2 "sysfunc" 26601 3 +"unix:tiocgpgrp" 2 "sysfunc" 26661 3 +"unix:tiocspgrp" 2 "sysfunc" 26729 3 +"unix:tiocoutq" 2 "sysfunc" 26795 2 +"unix:fionread" 2 "sysfunc" 26836 2 +"unix:tiocsetc" 2 "sysfunc" 26877 2 +"unix:tioclbis" 2 "sysfunc" 26914 2 +"unix:tioclbic" 2 "sysfunc" 26951 2 +"unix:tioclset" 2 "sysfunc" 26988 2 +"unix:tioclget" 2 "sysfunc" 27025 2 +"unix:tcseta" 2 "sysfunc" 27061 3 +"unix:tcsets" 2 "sysfunc" 27140 3 +"unix:tcsetsw" 2 "sysfunc" 27208 3 +"unix:tcsetsf" 2 "sysfunc" 27337 3 +"unix:tiocsetc" 2 "sysfunc" 27516 2 +"unix:tcsetaf" 2 "sysfunc" 27555 2 +"unix:tcsetaw" 2 "sysfunc" 27594 2 +"unix:tcgeta" 2 "sysfunc" 27632 2 +"unix:tcgets" 2 "sysfunc" 27670 2 +"unix:tcgetattr" 2 "sysfunc" 27711 2 +"unix:tcsetattr" 2 "sysfunc" 27752 2 +"dbm-open" 2 "sysfunc" 28257 3 +"dbm-store" 2 "sysfunc" 29047 3 +"dbm-fetch" 2 "sysfunc" 29262 3 +"cd" 2 "sysfunc" 30702 3 +"ez" 2 "sysfunc" 30797 3 +"piped-fork" 2 "sysfunc" 30914 3 +"xfork" 2 "sysfunc" 31338 3 +"rusage" 2 "sysfunc" 32009 3 +"load-foreign" 3 "sysfunc" 38822 3 +"defforeign" 3 "sysfunc" 41380 3 +"defun-c-callable" 3 "sysfunc" 43899 3 +"pod-address" 2 "sysfunc" 44914 3 +"array-entity" 3 "sysfunc" 45179 3 +"float2double" 2 "sysfunc" 45462 3 +"double2float" 2 "sysfunc" 45681 3 "float-vector" 2 "matrix" 389 3 "float-vector-p" 2 "matrix" 660 3 "v+" 2 "matrix" 724 3 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index f4e08d7b5..a0588406d 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,43 @@ \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}{}{} + +\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}.} + \end{refdesc} \newpage @@ -242,7 +230,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 +276,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) @@ -695,6 +677,14 @@ \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.} diff --git a/doc/latex/sysfunc.tex b/doc/latex/sysfunc.tex index 1dd1e191a..7f22267ba 100644 --- a/doc/latex/sysfunc.tex +++ b/doc/latex/sysfunc.tex @@ -518,7 +518,7 @@ \subsubsection{File Systems and I/O} \end{refdesc} -\subsubsection{Signals} +\subsubsection{Unix Signals} \begin{refdesc} From cf4abee5f6285f631a9722473cc38bcae7ccb889 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Oct 2019 13:35:43 +0900 Subject: [PATCH 093/387] Force global scope on install-handler --- lisp/l/conditions.l | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 4075d6534..52fad17b2 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -33,8 +33,12 @@ slots)))) (defun install-handler (label handler) + ;; ensure condition class (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) + ;; ensure global scope + (when (and (consp handler) (eql (car handler) 'lambda-closure)) + (setq handler `(lambda-closure ,(second handler) 0 0 ,@(nthcdr 4 handler)))) (unless (functionp handler) type-error "function expected") (push (cons label handler) *condition-handler*) t) From 931d9edff727cbf29fb493bf19ca5bf01aa25808 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Oct 2019 15:22:37 +0900 Subject: [PATCH 094/387] Catch 0 when loading files from command line --- lisp/l/toplevel.l | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index c86e29063..0b3ccbd45 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -282,22 +282,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* "")) From 61385d84e8f170c7b42e90e1eb0f618cf99c7c19 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Oct 2019 15:26:11 +0900 Subject: [PATCH 095/387] Check for supplied-p in condition setter/getter --- lisp/l/conditions.l | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 52fad17b2..930bc671f 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -17,7 +17,7 @@ ((null key)) (send self :set-val (symbol-pname key) val)) self) - (:message (&optional val) (if val (setq message val) message))) + (:message (&optional (val nil supplied-p)) (if supplied-p (setq message val) message))) (defmethod error (:callstack (&optional val) (if val (setq callstack val) callstack)) @@ -28,8 +28,8 @@ (defclass ,name :slots ,slots :super ,super) (defmethod ,name (:init (&rest init-args) (send-super* :init init-args)) - ,@(mapcar #'(lambda (s) `(,(intern (send s :pname) *keyword-package*) (&optional val) - (if val (send self :set-val ',s val) ,s))) + ,@(mapcar #'(lambda (s) `(,(intern (send s :pname) *keyword-package*) (&optional (val nil supplied-p)) + (if supplied-p (send self :set-val ',s val) ,s))) slots)))) (defun install-handler (label handler) From 7b3c53c3e5a9e49737440b51d81d3ee4c6e1c9e9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Oct 2019 16:49:52 +0900 Subject: [PATCH 096/387] Add japanese condition documentation --- doc/jlatex/euslisp.hlp | 11 ++++++++++ doc/jlatex/jcontrols.tex | 45 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index c15f42d65..940ba6fc8 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -43,6 +43,17 @@ "some" 2 "jcontrols" 11921 3 "functionp" 2 "jcontrols" 12197 3 "compiled-function-p" 2 "jcontrols" 12686 3 +"condition" 0 "jcontrols" 13307 4 +":init" 1 "jcontrols" 13400 3 +"lisp::*condition-handler*" 5 "jcontrols" 13730 2 +"lisp::*current-condition*" 5 "jcontrols" 13848 2 +"defcondition" 3 "jcontrols" 13943 3 +"install-handler" 2 "jcontrols" 14181 3 +"remove-handler" 2 "jcontrols" 14558 3 +"handler-bind" 2 "jcontrols" 14823 3 +"handler-case" 3 "jcontrols" 15188 3 +"signals" 2 "jcontrols" 15583 3 +"next-handler" 2 "jcontrols" 15988 3 "defclass" 3 "jobjects" 4063 3 "defmethod" 6 "jobjects" 4582 3 "defclassmethod" 3 "jobjects" 4812 2 diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index 3192dd54e..d2712fe8b 100644 --- a/doc/jlatex/jcontrols.tex +++ b/doc/jlatex/jcontrols.tex @@ -274,4 +274,49 @@ \subsection{述語} \end{refdesc} +\subsection{コンディション} + +コンディションシステムを用いることによってプログラムのより上位な層に情報を伝達つし、正しい対応を促すことができる。 + +\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}{ +コンディション{\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{next-handler}{\&optional (obj lisp::*current-condition*)}{ +コンディションハンドラーの中から呼ぶことによって、{\em obj}にマッチングする次のhandlerを呼び出すことが可能である。} + +\end{refdesc} + \newpage From 4780519e2d67255a661317cdaf61f4d405444276 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 12 Oct 2019 10:04:20 +0900 Subject: [PATCH 097/387] Add more japanese documentation --- doc/jlatex/euslisp.hlp | 152 ++++++++++++++++++++----------------- doc/jlatex/jevaluation.tex | 104 ++++++++++++------------- 2 files changed, 130 insertions(+), 126 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 940ba6fc8..da84d104c 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -469,75 +469,89 @@ "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 +"lisp::print-error-message" 2 "jevaluation" 7011 3 +"interruption" 0 "jevaluation" 7138 4 +"unix::signal-received" 0 "jevaluation" 7188 4 +"unix::sigint-received" 0 "jevaluation" 7237 4 +"unix::sigcont-received" 0 "jevaluation" 7299 4 +"unix:install-signal-handler" 3 "jevaluation" 7367 3 +"*prompt-string*" 5 "jevaluation" 11584 2 +"*program-name*" 5 "jevaluation" 11667 2 +"eustop" 2 "jevaluation" 11811 3 +"sigint-handler" 2 "jevaluation" 11890 3 +"euserror" 2 "jevaluation" 12061 3 +"reset" 2 "jevaluation" 12226 3 +"exit" 2 "jevaluation" 12358 3 +"*top-selector*" 5 "jevaluation" 12532 2 +"h" 2 "jevaluation" 12658 3 +"!" 2 "jevaluation" 12786 3 +"new-history" 2 "jevaluation" 13767 3 +"compile-file" 2 "jevaluation" 21290 3 +"compile" 2 "jevaluation" 22088 3 +"compile-file-if-src-newer" 2 "jevaluation" 22444 3 +"compiler:*optimize*" 5 "jevaluation" 22745 2 +"compiler:*verbose*" 5 "jevaluation" 22832 2 +"compiler:*safety*" 5 "jevaluation" 23016 2 +"load" 2 "jevaluation" 23166 3 +"load-files" 2 "jevaluation" 27087 3 +"*modules*" 5 "jevaluation" 27202 2 +"provide" 2 "jevaluation" 27306 3 +"require" 2 "jevaluation" 27723 3 +"system:binload" 2 "jevaluation" 28965 3 +"system::txtload" 2 "jevaluation" 29188 2 +"describe" 2 "jevaluation" 29291 3 +"describe-list" 2 "jevaluation" 29438 3 +"inspect" 3 "jevaluation" 29578 3 +"more" 2 "jevaluation" 29915 3 +"break" 2 "jevaluation" 30288 3 +"help" 2 "jevaluation" 30585 3 +"apropos" 2 "jevaluation" 30876 3 +"apropos-list" 2 "jevaluation" 31287 3 +"constants" 2 "jevaluation" 31432 3 +"variables" 2 "jevaluation" 31607 3 +"functions" 2 "jevaluation" 31800 3 +"btrace" 2 "jevaluation" 31987 3 +"step-hook" 2 "jevaluation" 32093 2 +"step" 2 "jevaluation" 32120 3 +"trace" 2 "jevaluation" 32259 3 +"untrace" 2 "jevaluation" 32448 3 +"timing" 3 "jevaluation" 32519 3 +"time" 3 "jevaluation" 32664 3 +"lisp::print-callstack" 2 "jevaluation" 32779 3 +"sys:list-callstack" 2 "jevaluation" 33020 3 +"sys:list-all-catchers" 2 "jevaluation" 33227 3 +"sys:list-all-instances" 2 "jevaluation" 33308 3 +"sys:list-all-bindings" 2 "jevaluation" 33697 3 +"sys:list-all-special-bindings" 2 "jevaluation" 33847 3 +"dump-object" 2 "jevaluation" 34648 2 +"dump-structure" 2 "jevaluation" 34696 3 +"dump-loadable-structure" 2 "jevaluation" 34851 3 +"sys:save" 2 "jevaluation" 35913 3 +"lisp-implementation-type" 2 "jevaluation" 39317 3 +"lisp-implementation-version" 2 "jevaluation" 39389 3 "sys:gc" 2 "jsysfunc" 6326 3 "sys:*gc-hook*" 5 "jsysfunc" 6522 2 "sys:gctime" 2 "jsysfunc" 6638 3 diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 7cfd22043..d7a6eaf01 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -3,36 +3,6 @@ \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}{ @@ -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,43 @@ \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}{}{} + +\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}によって初期化される。} \end{refdesc} @@ -248,21 +236,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} @@ -637,6 +619,14 @@ \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}タグを返す。} From 9d3057be1ba110db37c4bac7ab54e76e0c5eaedf Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 13 Oct 2019 13:23:22 +0900 Subject: [PATCH 098/387] Add type-check in handler-bind and handler-case --- lisp/l/conditions.l | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 930bc671f..fa9e293f4 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -36,6 +36,9 @@ ;; ensure condition class (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) + ;; ensure function + (unless (functionp handler) + (error type-error "function expected")) ;; ensure global scope (when (and (consp handler) (eql (car handler) 'lambda-closure)) (setq handler `(lambda-closure ,(second handler) 0 0 ,@(nthcdr 4 handler)))) @@ -56,6 +59,8 @@ (defmacro handler-case (form &rest cases) (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-case From fe04314b04ecfa50fe776c1e66eba303cbf5b9fd Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 31 Oct 2019 10:50:22 +0900 Subject: [PATCH 099/387] Change function name resume -> unwind --- lisp/c/eus_proto.h | 2 +- lisp/c/specials.c | 4 ++-- lisp/l/eusstart.l | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 79c27eef6..4c7f24b40 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -561,7 +561,7 @@ 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 RESUME(context */*ctx*/, int /*n*/, pointer */*argv*/); +extern pointer UNWIND(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer RESET(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer EVALHOOK(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer BLOCK(context */*ctx*/, pointer /*arg*/); diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 3fffbbd56..2f48763f4 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -622,7 +622,7 @@ register pointer arg; ctx->fletfp=ffp; return(result);} -pointer RESUME(ctx,n,argv) +pointer UNWIND(ctx,n,argv) register context *ctx; int n; pointer *argv; @@ -1362,7 +1362,7 @@ pointer mod; defmacro(ctx,"RETURN",mod,RETURN); defspecial(ctx,"TAGBODY",mod,TAGBODY); defspecial(ctx,"GO",mod,GO); - defun(ctx,"RESUME",mod,RESUME,NULL); + defun(ctx,"UNWIND",mod,UNWIND,NULL); defun(ctx,"RESET",mod,RESET,NULL); defun(ctx,"EVALHOOK",mod,EVALHOOK,NULL); defun(ctx,"MACROEXPAND2",mod,MACEXPAND2,NULL); diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index 628b66f9e..d8ef67560 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -43,7 +43,7 @@ (export '(quote eval apply funcall progn prog1 function)) (export '(mapc mapcar mapcan setq if when cond while let let* unwind-protect catch throw macrolet flet labels block return-from - return resume reset go tagbody evalhook macroexpand2 eval-when + return unwind reset go tagbody evalhook macroexpand2 eval-when the and or proclaim declare symbol-value symbol-function makunbound defun defmacro find-symbol intern gensym list-all-packages find-package From 60046f1a496f501a0ad0431ede11d8e84ff8940b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 7 Nov 2019 17:19:48 +0900 Subject: [PATCH 100/387] Remove ongoing handlers on signal to avoid nested evaluation --- lisp/l/conditions.l | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index fa9e293f4..53f7856e4 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -74,11 +74,12 @@ (if (classp obj) (setq obj (instantiate obj))) (if init-args (send* obj :init init-args)) (unless (derivedp obj condition) (error type-error "condition class expected")) - (do ((*current-condition-handler* *condition-handler* (cdr *current-condition-handler*)) - (*current-condition* obj)) - ((null *current-condition-handler*)) - (when (derivedp obj (caar *current-condition-handler*)) - (return (funcall (cdar *current-condition-handler*) obj))))) + (dolist (handle *condition-handler*) + (when (derivedp obj (car handle)) + ;; remove ongoing handler to avoid nested evaluation + (let ((*current-condition* obj) + (*condition-handler* (remove handle *condition-handler* :test #'equal :count 1))) + (return-from signals (funcall (cdr handle) obj)))))) (defun next-handler (&optional (obj *current-condition*)) (do ((*current-condition-handler* From 566353ea725186d20bc9bcd1df0dd831000cc566 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 7 Nov 2019 17:37:35 +0900 Subject: [PATCH 101/387] Remove next-handler --- doc/jlatex/euslisp.hlp | 1 - doc/jlatex/jcontrols.tex | 3 --- doc/latex/controls.tex | 3 --- doc/latex/euslisp.hlp | 1 - lisp/l/conditions.l | 12 +----------- 5 files changed, 1 insertion(+), 19 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index da84d104c..afd2a75f2 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -53,7 +53,6 @@ "handler-bind" 2 "jcontrols" 14823 3 "handler-case" 3 "jcontrols" 15188 3 "signals" 2 "jcontrols" 15583 3 -"next-handler" 2 "jcontrols" 15988 3 "defclass" 3 "jobjects" 4063 3 "defmethod" 6 "jobjects" 4582 3 "defclassmethod" 3 "jobjects" 4812 2 diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index d2712fe8b..4c15056d7 100644 --- a/doc/jlatex/jcontrols.tex +++ b/doc/jlatex/jcontrols.tex @@ -314,9 +314,6 @@ \subsection{コンディション} {\em obj}によって示されるコンディションをsignalizeする。最初にマッチングされたhandlerの返り値を返す。マッチングされたhandlerがないためにはnilを返す。 {\em obj}はコンディションのインスタンスか、 {\em init-args}によって初期化されるコンディションクラスである。} -\funcdesc{next-handler}{\&optional (obj lisp::*current-condition*)}{ -コンディションハンドラーの中から呼ぶことによって、{\em obj}にマッチングする次のhandlerを呼び出すことが可能である。} - \end{refdesc} \newpage diff --git a/doc/latex/controls.tex b/doc/latex/controls.tex index f5ab7bfb8..b786f32de 100644 --- a/doc/latex/controls.tex +++ b/doc/latex/controls.tex @@ -313,9 +313,6 @@ \subsection{Conditions} 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{next-handler}{\&optional (obj lisp::*current-condition*)}{ - Can be called from inside a condition handler to call the next handler matching {\em obj}.} - \end{refdesc} \newpage diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 04f3aa1c7..acb4e9844 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -53,7 +53,6 @@ "handler-bind" 2 "controls" 12128 3 "handler-case" 3 "controls" 12396 3 "signals" 2 "controls" 12694 3 -"next-handler" 2 "controls" 12939 3 "defclass" 3 "objects" 3223 3 "defmethod" 6 "objects" 3684 3 "defclassmethod" 3 "objects" 3859 2 diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 53f7856e4..ac09e1cf2 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -3,11 +3,9 @@ (in-package "LISP") (export '(defcondition install-handler remove-handler signals euserror - sigint-handler interruption handler-bind handler-case - next-handler)) + sigint-handler interruption handler-bind handler-case)) (defvar *current-condition*) -(defvar *current-condition-handler*) ;; for next-handler (defmethod condition (:init (&rest init-args &key message &allow-other-keys) @@ -81,14 +79,6 @@ (*condition-handler* (remove handle *condition-handler* :test #'equal :count 1))) (return-from signals (funcall (cdr handle) obj)))))) -(defun next-handler (&optional (obj *current-condition*)) - (do ((*current-condition-handler* - (cdr *current-condition-handler*) - (cdr *current-condition-handler*))) - ((null *current-condition-handler*)) - (when (derivedp obj (caar *current-condition-handler*)) - (return (funcall (cdar *current-condition-handler*) obj))))) - (defun print-callstack (&optional (stack (sys:list-callstack)) max (os *error-output*)) (let ((tms (if max (min max (length stack)) From 1a4d4a1df87da7f61f530a46004b84a7e3a348a8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 7 Nov 2019 18:17:20 +0900 Subject: [PATCH 102/387] Revert handler-bind order to match common-lisp --- lisp/l/conditions.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index ac09e1cf2..f8046d8de 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -52,7 +52,7 @@ (defmacro handler-bind (bindings &rest forms) `(let ((*condition-handler* (copy-list *condition-handler*))) - ,@(mapcar #'(lambda (bind) `(install-handler ,@bind)) (reverse bindings)) + ,@(mapcar #'(lambda (bind) `(install-handler ,@bind)) bindings) ,@forms)) (defmacro handler-case (form &rest cases) From 58cd06363c423f16d004cb349a87c8aae3ab5c05 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 13 Nov 2019 13:05:04 +0900 Subject: [PATCH 103/387] Add :recursive option to handlers --- lisp/l/conditions.l | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index f8046d8de..38df1a888 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -30,7 +30,7 @@ (if supplied-p (send self :set-val ',s val) ,s))) slots)))) -(defun install-handler (label handler) +(defun install-handler (label handler &key (recursive t)) ;; ensure condition class (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) @@ -41,7 +41,10 @@ (when (and (consp handler) (eql (car handler) 'lambda-closure)) (setq handler `(lambda-closure ,(second handler) 0 0 ,@(nthcdr 4 handler)))) (unless (functionp handler) type-error "function expected") - (push (cons label handler) *condition-handler*) + ;; use objects instead of alist? + (if recursive + (push (cons label (cons :recursive handler)) *condition-handler*) + (push (cons label handler) *condition-handler*)) t) (defun remove-handler (label &optional handler) @@ -52,7 +55,7 @@ (defmacro handler-bind (bindings &rest forms) `(let ((*condition-handler* (copy-list *condition-handler*))) - ,@(mapcar #'(lambda (bind) `(install-handler ,@bind)) bindings) + ,@(mapcar #'(lambda (bind) `(install-handler ,@bind :recursive nil)) bindings) ,@forms)) (defmacro handler-case (form &rest cases) @@ -76,8 +79,13 @@ (when (derivedp obj (car handle)) ;; remove ongoing handler to avoid nested evaluation (let ((*current-condition* obj) - (*condition-handler* (remove handle *condition-handler* :test #'equal :count 1))) - (return-from signals (funcall (cdr handle) obj)))))) + (*condition-handler* (copy-list *condition-handler*))) + (if (and (consp (cdr handle)) (eq (cadr handle) :recursive)) + ;; recursive + (return-from signals (funcall (cddr handle) obj)) + ;; non recursive + (let ((*condition-handler* (remove handle *condition-handler* :test #'equal :count 1))) + (return-from signals (funcall (cdr handle) obj)))))))) (defun print-callstack (&optional (stack (sys:list-callstack)) max (os *error-output*)) (let ((tms (if max @@ -146,12 +154,12 @@ (*reptype* "B")) (while (catch *replevel* (reploop #'toplevel-prompt))))) -(install-handler interruption 'interruption-handler) ;; install handlers +(install-handler error #'euserror) +(install-handler interruption 'interruption-handler) (unix:install-signal-handler unix::sigint unix::sigint-received) (unix:install-signal-handler unix::sigcont unix::sigcont-received)) -(install-handler error #'euserror) (install-handler unix::sigint-received 'sigint-handler) (install-handler unix::sigcont-received '(lambda-closure nil 0 0 (c) From 7871167d5e8ac58be6f9371856025f1dcc51d370 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 13 Nov 2019 13:05:21 +0900 Subject: [PATCH 104/387] Update :recursive documentation --- doc/jlatex/euslisp.hlp | 8 ++++---- doc/jlatex/jcontrols.tex | 6 ++++-- doc/latex/controls.tex | 7 ++++--- doc/latex/euslisp.hlp | 8 ++++---- 4 files changed, 16 insertions(+), 13 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index afd2a75f2..a22b04338 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -49,10 +49,10 @@ "lisp::*current-condition*" 5 "jcontrols" 13848 2 "defcondition" 3 "jcontrols" 13943 3 "install-handler" 2 "jcontrols" 14181 3 -"remove-handler" 2 "jcontrols" 14558 3 -"handler-bind" 2 "jcontrols" 14823 3 -"handler-case" 3 "jcontrols" 15188 3 -"signals" 2 "jcontrols" 15583 3 +"remove-handler" 2 "jcontrols" 14839 3 +"handler-bind" 2 "jcontrols" 15104 3 +"handler-case" 3 "jcontrols" 15469 3 +"signals" 2 "jcontrols" 15864 3 "defclass" 3 "jobjects" 4063 3 "defmethod" 6 "jobjects" 4582 3 "defclassmethod" 3 "jobjects" 4812 2 diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index 4c15056d7..306187f8b 100644 --- a/doc/jlatex/jcontrols.tex +++ b/doc/jlatex/jcontrols.tex @@ -294,9 +294,11 @@ \subsection{コンディション} \macrodesc{defcondition}{name \&key slots (super 'condition)}{ 新しいコンディションを定義する。{\em slots}に含まれる各スロットに対するsetter/getterと{\em :init}メソッドも一緒に定義される。} -\funcdesc{install-handler}{label handler}{ +\funcdesc{install-handler}{label handler \&key (recursive t)}{ Callback関数{\em handler}を定義し、{\em label}を親クラスとするコンディションがsignalizeされたらその関数を実行する。 -{\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。} +{\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。 +{\em recursive}がnilの時、{\em handler}の再帰的呼び出しは行われず、{\em handler}実行中に新たな{\em label}に属するコンディションがsignalizeされればその次に登録されているハンドラーが呼び出される。 +} \funcdesc{remove-handler}{label \&optional handler}{ コンディション{\em label}で登録された最後のhandlerを登録解除する。 diff --git a/doc/latex/controls.tex b/doc/latex/controls.tex index b786f32de..b68f0d1e1 100644 --- a/doc/latex/controls.tex +++ b/doc/latex/controls.tex @@ -294,15 +294,16 @@ \subsection{Conditions} \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}{ +\funcdesc{install-handler}{label handler \&key (recursive t)}{ 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).} + {\em label} is a condition class and {\em handler} is a funcallable object which takes one parameter (the condition instance signalized). + If {\em recursive} is nil, recursive calling of {\em handler} is disabled, and new conditions belonging to {\em label} signalized from within {\em handler} cause the next registered handler function to be executed.} \funcdesc{remove-handler}{label \&optional handler}{ Removes the last handler registered for 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}{ +\funcdesc{handler-bind}{(\&rest (label handler \&key (recursive nil))) \&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).} diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index acb4e9844..5c5195182 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -49,10 +49,10 @@ "lisp::*current-condition*" 5 "controls" 11334 2 "defcondition" 3 "controls" 11409 3 "install-handler" 2 "controls" 11611 3 -"remove-handler" 2 "controls" 11912 3 -"handler-bind" 2 "controls" 12128 3 -"handler-case" 3 "controls" 12396 3 -"signals" 2 "controls" 12694 3 +"remove-handler" 2 "controls" 12149 3 +"handler-bind" 2 "controls" 12365 3 +"handler-case" 3 "controls" 12655 3 +"signals" 2 "controls" 12953 3 "defclass" 3 "objects" 3223 3 "defmethod" 6 "objects" 3684 3 "defclassmethod" 3 "objects" 3859 2 From 3016c77ad7f03eb90ecc16485f16a116e10ae193 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 13 Nov 2019 13:08:29 +0900 Subject: [PATCH 105/387] Do not check for unix signals during gc to avoid dead_lock on signal handlers --- lisp/c/memory.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/c/memory.c b/lisp/c/memory.c index ae977a11c..183e41b5d 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -767,7 +767,7 @@ void resume_all_threads() #if vxworks void gc() { if (debug) fprintf(stderr,"\n;; gc:"); - breakck; + // breakck; gccount++; markall(); sweepall(); @@ -775,7 +775,8 @@ void gc() fprintf(stderr," free/total=%d/%d stack=%d ", freeheap,totalheap,markctx->vsp-markctx->stack); } - breakck; } + // breakck; +} #else void gc() @@ -784,7 +785,7 @@ void gc() context *ctx=euscontexts[thr_self()]; if (debug) fprintf(stderr,"\n;; gc: thread=%d ",thr_self()); - breakck; + // breakck; gccount++; times(&tbuf1); @@ -825,7 +826,7 @@ void gc() ufuncall(ctx,gchook,gchook,(pointer)(ctx->vsp-2),ctx->bindfp,2); ctx->vsp -= 2; } - breakck; + // breakck; } #endif From a133f234a8fff49edb93fe2f9091f57043baaf45 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 13 Nov 2019 15:18:08 +0900 Subject: [PATCH 106/387] Use vpush in error handler --- lisp/c/eus.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index fca846088..fa0606b43 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -325,7 +325,7 @@ va_dcl register context *ctx; register struct callframe *vf; pointer msg,form,callstack; - pointer errobj,arglst; + pointer errobj; #ifdef USE_STDARG va_start(args,ec); @@ -428,11 +428,11 @@ va_dcl pointer_update(errobj->c.obj.iv[0],msg); pointer_update(errobj->c.obj.iv[1],callstack); pointer_update(errobj->c.obj.iv[2],form); - arglst=cons(ctx,errobj,NIL); Spevalof(QEVALHOOK)=NIL; /* reset eval hook */ if (errhandler!=NIL) { - ufuncall(ctx,errhandler,errhandler,arglst,ctx->bindfp,-1);} + vpush(errobj); + ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-1),ctx->bindfp,1);} } #ifdef USE_STDARG From e48718eea1d271e10353529a5e41301c06320e0e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 21 Nov 2019 14:34:14 +0900 Subject: [PATCH 107/387] Revert "Add resume and sys:print-stack" This reverts commit 18929e54ee2e795d84178cae82ab20ec2c071a7b. --- lisp/c/eus.h | 3 --- lisp/c/eus_proto.h | 1 - lisp/c/eval.c | 12 ++---------- lisp/c/specials.c | 18 ------------------ lisp/l/eusstart.l | 2 +- 5 files changed, 3 insertions(+), 33 deletions(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 7c5895878..5d13b6da3 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -477,10 +477,7 @@ enum ch_attr { /****************************************************************/ struct callframe { struct callframe *vlink; - struct bindframe *bf; /*bind frame save*/ - struct fletframe *ff; /*flet frame save*/ pointer form; - jmp_buf* jbp; }; struct bindframe { /*to achieve lexical binding in the interpreter*/ diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 4c7f24b40..4d84dac0b 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -561,7 +561,6 @@ 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 UNWIND(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer RESET(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer EVALHOOK(context */*ctx*/, int /*n*/, pointer */*argv*/); extern pointer BLOCK(context */*ctx*/, pointer /*arg*/); diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 9d05bf539..01815b8ba 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1528,23 +1528,15 @@ int noarg; if (!ispointer(func)) error(E_NOFUNCTION); /*make a new stack frame*/ - jmp_buf catchbuf; stackck; /*stack overflow?*/ breakck; /*signal exists?*/ vf->vlink=ctx->callfp; - vf->bf=ctx->bindfp; - vf->ff=ctx->fletfp; - vf->form=form; - vf->jbp=&catchbuf; + vf->form=form; ctx->callfp=vf; ctx->vsp+=sizeof(struct callframe)/(sizeof(pointer)); argp=ctx->vsp; - if ((result=(pointer)eussetjmp(catchbuf))!=0) { - ctx->bindfp=ctx->callfp->bf; - ctx->fletfp=ctx->callfp->ff; - return(result);} - else if (pisclosure(func)) { + if (pisclosure(func)) { clofunc=func; fn=func; if (fn->c.code.subrtype!=SUBR_FUNCTION) error(E_NOFUNCTION); diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 2f48763f4..7b88ae663 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -622,23 +622,6 @@ register pointer arg; ctx->fletfp=ffp; return(result);} -pointer UNWIND(ctx,n,argv) -register context *ctx; -int n; -pointer *argv; -{ ckarg2(1,2); - int depth=ckintval(argv[0]); - register struct callframe *vf=(struct callframe *)(ctx->callfp); - pointer result; - /* unwind stack */ - for(;depth> 0 && vf->vlink; depth--, vf=vf->vlink) {}; - ctx->callfp=vf; - unwind(ctx,(pointer *)ctx->callfp); - /* resume with value */ - if (n==1) result=eval(ctx,vf->form); - else result=argv[1]; - euslongjmp(*(vf->jbp),result);} - pointer RESET(ctx,n,argv) register context *ctx; int n; @@ -1362,7 +1345,6 @@ pointer mod; defmacro(ctx,"RETURN",mod,RETURN); defspecial(ctx,"TAGBODY",mod,TAGBODY); defspecial(ctx,"GO",mod,GO); - defun(ctx,"UNWIND",mod,UNWIND,NULL); defun(ctx,"RESET",mod,RESET,NULL); defun(ctx,"EVALHOOK",mod,EVALHOOK,NULL); defun(ctx,"MACROEXPAND2",mod,MACEXPAND2,NULL); diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index d8ef67560..4b9059126 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -43,7 +43,7 @@ (export '(quote eval apply funcall progn prog1 function)) (export '(mapc mapcar mapcan setq if when cond while let let* unwind-protect catch throw macrolet flet labels block return-from - return unwind reset go tagbody evalhook macroexpand2 eval-when + return reset go tagbody evalhook macroexpand2 eval-when the and or proclaim declare symbol-value symbol-function makunbound defun defmacro find-symbol intern gensym list-all-packages find-package From 497e07af08ba38e272390ca7ac43b8ba145857be Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 21 Nov 2019 14:34:22 +0900 Subject: [PATCH 108/387] Revert "Use callfp saved frames on catchframe" This reverts commit bce5c25ca922851703c073b7054821e23e558a7d. --- lisp/c/compsub.c | 2 +- lisp/c/eus.c | 2 +- lisp/c/eus.h | 2 ++ lisp/c/makes.c | 3 +++ lisp/c/specials.c | 4 ++-- 5 files changed, 9 insertions(+), 4 deletions(-) diff --git a/lisp/c/compsub.c b/lisp/c/compsub.c index 18f6ef7ad..aa24a727d 100644 --- a/lisp/c/compsub.c +++ b/lisp/c/compsub.c @@ -80,6 +80,6 @@ register context *ctx; { register struct catchframe *cfp=ctx->catchfp; ctx->vsp = (pointer *)cfp; ctx->callfp = cfp->cf; - ctx->bindfp = cfp->cf->bf; + ctx->bindfp = cfp->bf; ctx->catchfp= cfp->nextcatch;} diff --git a/lisp/c/eus.c b/lisp/c/eus.c index fa0606b43..086164c36 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -1097,7 +1097,7 @@ char *prompt; 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->callfp->bf; + ctx->bindfp=ctx->catchfp->bf; ctx->vsp=(pointer *)ctx->catchfp; ctx->catchfp=(struct catchframe *)*(ctx->vsp); return(val);} diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 5d13b6da3..2632032df 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -499,7 +499,9 @@ struct blockframe { 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; }; diff --git a/lisp/c/makes.c b/lisp/c/makes.c index 431603568..da386840f 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -824,8 +824,11 @@ jmp_buf *jbuf; 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;} diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 7b88ae663..8d557cdd2 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -525,8 +525,8 @@ pointer arg; if ((val=(pointer)eussetjmp(catchbuf))==0) val=progn(ctx,body); else if ((eusinteger_t)val==1) val=makeint(0); /*longjmp cannot return 0*/ ctx->callfp=ctx->catchfp->cf; - ctx->bindfp=ctx->callfp->bf; - ctx->fletfp=ctx->callfp->ff; + ctx->bindfp=ctx->catchfp->bf; + ctx->fletfp=ctx->catchfp->ff; ctx->vsp=(pointer *)ctx->catchfp; ctx->catchfp=(struct catchframe *)*ctx->vsp; #ifdef __RETURN_BARRIER From b422980638ae4160078e7b35ec4485e92cbeea2a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 21 Nov 2019 14:09:39 +0900 Subject: [PATCH 109/387] Use ~S on apropos symbol printing --- lisp/l/eusdebug.l | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/l/eusdebug.l b/lisp/l/eusdebug.l index 42a783bfa..8d0a6a2f5 100644 --- a/lisp/l/eusdebug.l +++ b/lisp/l/eusdebug.l @@ -85,14 +85,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) @@ -100,8 +99,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)) From 8f6f03c2b456b05c63f198aab6b7bc8a608a3662 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 21 Nov 2019 15:43:41 +0900 Subject: [PATCH 110/387] Not needed to restore global *condition-handler* because we added :recursive nil --- lisp/l/conditions.l | 4 ---- 1 file changed, 4 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 38df1a888..d70c10f1a 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -116,10 +116,6 @@ (print-error-message err) (let ((*replevel* (1+ *replevel*)) (*reptype* "E")) - ;; do not carry handlers through the error stack - ;; i.e. restore previous global `*condition-handler*' - (let ((old (assoc '*condition-handler* (sys:list-all-special-bindings)))) - (if old (setq *condition-handler* (cdr old)))) (while (catch *replevel* (reploop #'toplevel-prompt)))) (throw *replevel* t)) From de8f71876a9d46c5434bef413b5b19ee7d6e6ea3 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 21 Nov 2019 18:17:47 +0900 Subject: [PATCH 111/387] Set error class :init defaults --- lisp/l/conditions.l | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index d70c10f1a..848257802 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -18,6 +18,8 @@ (: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))) @@ -72,8 +74,10 @@ ,form)))) (defun signals (obj &rest init-args) - (if (classp obj) (setq obj (instantiate obj))) - (if init-args (send* obj :init 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)) From 3e598e204119fb943a1ab3c18964aa676cafeaea Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 28 Nov 2019 15:07:35 +0900 Subject: [PATCH 112/387] Update handler-bind parameters in jp documentation --- doc/jlatex/euslisp.hlp | 4 ++-- doc/jlatex/jcontrols.tex | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index a22b04338..db6c77d8b 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -51,8 +51,8 @@ "install-handler" 2 "jcontrols" 14181 3 "remove-handler" 2 "jcontrols" 14839 3 "handler-bind" 2 "jcontrols" 15104 3 -"handler-case" 3 "jcontrols" 15469 3 -"signals" 2 "jcontrols" 15864 3 +"handler-case" 3 "jcontrols" 15491 3 +"signals" 2 "jcontrols" 15886 3 "defclass" 3 "jobjects" 4063 3 "defmethod" 6 "jobjects" 4582 3 "defclassmethod" 3 "jobjects" 4812 2 diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index 306187f8b..6de885539 100644 --- a/doc/jlatex/jcontrols.tex +++ b/doc/jlatex/jcontrols.tex @@ -304,7 +304,7 @@ \subsection{コンディション} コンディション{\em label}で登録された最後のhandlerを登録解除する。 {\em handler}が与えられた場合、最後に登録された({\em label . handler})のペアを登録解除する。} -\funcdesc{handler-bind}{(\&rest (label handler)) \&rest forms}{ +\funcdesc{handler-bind}{(\&rest (label handler \&key (recursive nil))) \&rest forms}{ コンディション{\rm label}とハンドラー{\em handler}をロカルにbindし、{\em forms}を実行する。 {\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。} From 6b8804a5fc386507a2d6c9eae00c174fffe94268 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 4 Dec 2019 19:41:36 +0900 Subject: [PATCH 113/387] Check for thread existance in get_free_thread to avoid unnecessary dead locks --- lisp/c/mthread.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/c/mthread.c b/lisp/c/mthread.c index a5f513722..e71db2b3c 100644 --- a/lisp/c/mthread.c +++ b/lisp/c/mthread.c @@ -29,6 +29,8 @@ int mark_lock_thread; pointer get_free_thread() { register pointer port; + if (speval(QTHREADS)==NIL) { + error(E_USER,"No threads found. Please create with 'sys:make-thread'");} GC_REGION(sema_wait(&free_thread_sem);); mutex_lock(&free_thread_lock); port=ccar(free_threads); From 79dc8e2b9c0a43e63648830b206edef6054d227d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 7 Dec 2019 10:15:02 +0900 Subject: [PATCH 114/387] Remove unused fatalerror cixpair --- lisp/c/eus.c | 1 - 1 file changed, 1 deletion(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 086164c36..f37ada2c4 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -98,7 +98,6 @@ cixpair bignumcp; /* conditions */ cixpair conditioncp; cixpair errorcp; -cixpair fatalerrorcp; /* errors */ cixpair argumenterrorcp, programerrorcp, nameerrorcp; cixpair typeerrorcp, valueerrorcp, indexerrorcp, ioerrorcp; From 3e9c2bf2716f8d46e68c19331ad955a312a8b3fd Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 7 Dec 2019 18:37:00 +0900 Subject: [PATCH 115/387] Move *condition-handler* definition to conditions.l --- lisp/c/eus.c | 2 -- lisp/l/conditions.l | 1 + 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index f37ada2c4..650fc4fd7 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -125,7 +125,6 @@ pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; pointer TOPLEVEL,QEVALHOOK,FATALERROR; -pointer CONDITIONHANDLER; pointer QGCHOOK, QEXITHOOK; pointer QUNBOUND,QDEBUG; pointer QTHREADS; /* system:*threads* */ @@ -691,7 +690,6 @@ static void initsymbols() PRLEVEL=deflocal(ctx,"*PRINT-LEVEL*",NIL,lisppkg); QREADTABLE=deflocal(ctx,"*READTABLE*",NIL,lisppkg); TOPLEVEL=defvar(ctx,"*TOPLEVEL*",NIL,lisppkg); - CONDITIONHANDLER=deflocal(ctx,"*CONDITION-HANDLER*",NIL,lisppkg); QEVALHOOK=deflocal(ctx,"*EVALHOOK*",NIL,lisppkg); QUNBOUND=intern(ctx,"*UNBOUND*",9,lisppkg); RANDSTATE=deflocal(ctx,"*RANDOM-STATE*",UNBOUND,lisppkg); diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 848257802..28eb7f176 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -5,6 +5,7 @@ (export '(defcondition install-handler remove-handler signals euserror sigint-handler interruption handler-bind handler-case)) +(deflocal *condition-handler*) (defvar *current-condition*) (defmethod condition From c4732d0d1eda0307a4e89434ecb856e2e798e15a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 8 Dec 2019 13:11:40 +0900 Subject: [PATCH 116/387] Return bool in remove-handler --- lisp/l/conditions.l | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 28eb7f176..c2fea0df3 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -51,10 +51,14 @@ t) (defun remove-handler (label &optional handler) - (setq *condition-handler* - (if handler - (remove (cons label handler) *condition-handler* :test #'equal :count 1) - (remove label *condition-handler* :key #'car :count 1)))) + (let ((item + (if handler + (find (cons label handler) *condition-handler* :test #'equal) + (find label *condition-handler* :key #'car)))) + (when item + (setq *condition-handler* + (remove item *condition-handler* :test #'equal :count 1)) + t))) (defmacro handler-bind (bindings &rest forms) `(let ((*condition-handler* (copy-list *condition-handler*))) From b03c1023b9e8d89b17e02612ff41ac8beecbf5e5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 8 Dec 2019 14:28:14 +0900 Subject: [PATCH 117/387] Introduce condition-handler class to hold :recursive slot and others --- lisp/l/conditions.l | 41 +++++++++++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 14 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index c2fea0df3..ee6e1e124 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -24,6 +24,24 @@ (:callstack (&optional val) (if val (setq callstack val) callstack)) (:form (&optional val) (if val (setq form val) form))) +(defclass condition-handler :slots (function recursive) :super propertied-object) +(defmethod condition-handler + (:init (function &key recursive) + (unless (functionp function) (error type-error "function expected")) + ;; set slots + (send self :set-val "FUNCTION" function) + (send self :set-val "RECURSIVE" recursive) + ;; set name + (let ((name + (cond + ((symbolp function) function) + ((compiled-function-p function) (get function :name)) + ((listp function) (second function))))) + (if name (setf (get self :name) name))) + self) + (:function (&optional val) (if val (setq function val) function)) + (:recursive (&optional (val nil supplied-p)) (if supplied-p (setq recursive val) recursive))) + (defmacro defcondition (name &key slots (super 'condition)) `(progn (defclass ,name :slots ,slots :super ,super) @@ -37,23 +55,20 @@ ;; ensure condition class (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) - ;; ensure function - (unless (functionp handler) - (error type-error "function expected")) ;; ensure global scope (when (and (consp handler) (eql (car handler) 'lambda-closure)) (setq handler `(lambda-closure ,(second handler) 0 0 ,@(nthcdr 4 handler)))) - (unless (functionp handler) type-error "function expected") - ;; use objects instead of alist? - (if recursive - (push (cons label (cons :recursive handler)) *condition-handler*) - (push (cons label handler) *condition-handler*)) + (push (cons label (instance condition-handler :init handler :recursive recursive)) + *condition-handler*) t) (defun remove-handler (label &optional handler) (let ((item (if handler - (find (cons label handler) *condition-handler* :test #'equal) + (find-if #'(lambda (val) (and (eql (car val) label) + (derivedp (cdr val) condition-handler) + (eql (send (cdr val) :function) handler))) + *condition-handler*) (find label *condition-handler* :key #'car)))) (when item (setq *condition-handler* @@ -89,12 +104,10 @@ ;; remove ongoing handler to avoid nested evaluation (let ((*current-condition* obj) (*condition-handler* (copy-list *condition-handler*))) - (if (and (consp (cdr handle)) (eq (cadr handle) :recursive)) - ;; recursive - (return-from signals (funcall (cddr handle) obj)) - ;; non recursive + (if (send (cdr handle) :recursive) + (return-from signals (funcall (send (cdr handle) :function) obj)) (let ((*condition-handler* (remove handle *condition-handler* :test #'equal :count 1))) - (return-from signals (funcall (cdr handle) obj)))))))) + (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 From b6d16056ee5c3e90a1efba74025b61da05d05ea5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 8 Dec 2019 14:30:50 +0900 Subject: [PATCH 118/387] Allow to use local scopes on handlers --- lisp/l/conditions.l | 3 --- 1 file changed, 3 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index ee6e1e124..5ea8bfdeb 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -55,9 +55,6 @@ ;; ensure condition class (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) - ;; ensure global scope - (when (and (consp handler) (eql (car handler) 'lambda-closure)) - (setq handler `(lambda-closure ,(second handler) 0 0 ,@(nthcdr 4 handler)))) (push (cons label (instance condition-handler :init handler :recursive recursive)) *condition-handler*) t) From edfe5f5e769fe384cfee08a02167861af75359be Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 Dec 2019 11:06:52 +0900 Subject: [PATCH 119/387] Do not raise 'assumed to be global' compile warnings for constants --- lisp/comp/comp.l | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 18c5b904b..7a97f8e85 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -68,6 +68,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) @@ -285,6 +290,8 @@ (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) From 2dccabaaf79b2c424085656ab9c303762cf84ec4 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 23 Dec 2019 11:18:41 +0900 Subject: [PATCH 120/387] Change slot name function->fn --- lisp/l/conditions.l | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 5ea8bfdeb..266a66596 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -24,22 +24,22 @@ (:callstack (&optional val) (if val (setq callstack val) callstack)) (:form (&optional val) (if val (setq form val) form))) -(defclass condition-handler :slots (function recursive) :super propertied-object) +(defclass condition-handler :slots (fn recursive) :super propertied-object) (defmethod condition-handler - (:init (function &key recursive) - (unless (functionp function) (error type-error "function expected")) + (:init (fn &key recursive) + (unless (functionp fn) (error type-error "function expected")) ;; set slots - (send self :set-val "FUNCTION" function) + (send self :set-val "FN" fn) (send self :set-val "RECURSIVE" recursive) ;; set name (let ((name (cond - ((symbolp function) function) - ((compiled-function-p function) (get function :name)) - ((listp function) (second function))))) + ((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 function val) function)) + (:function (&optional val) (if val (setq fn val) fn)) (:recursive (&optional (val nil supplied-p)) (if supplied-p (setq recursive val) recursive))) (defmacro defcondition (name &key slots (super 'condition)) From d283b6ca340e70df239d0bc404556e445b8c1d0c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 23 Dec 2019 14:00:11 +0900 Subject: [PATCH 121/387] Reimplement ERRHANDLER for compatibility with previously compiled files --- lisp/c/eus.c | 3 ++- lisp/c/eus.h | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 650fc4fd7..e17057338 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -124,7 +124,7 @@ pointer SELF; pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; -pointer TOPLEVEL,QEVALHOOK,FATALERROR; +pointer TOPLEVEL,QEVALHOOK,ERRHANDLER,FATALERROR; pointer QGCHOOK, QEXITHOOK; pointer QUNBOUND,QDEBUG; pointer QTHREADS; /* system:*threads* */ @@ -690,6 +690,7 @@ static void initsymbols() PRLEVEL=deflocal(ctx,"*PRINT-LEVEL*",NIL,lisppkg); QREADTABLE=deflocal(ctx,"*READTABLE*",NIL,lisppkg); TOPLEVEL=defvar(ctx,"*TOPLEVEL*",NIL,lisppkg); + ERRHANDLER=deflocal(ctx,"*ERROR-HANDLER*",NIL,lisppkg); QEVALHOOK=deflocal(ctx,"*EVALHOOK*",NIL,lisppkg); QUNBOUND=intern(ctx,"*UNBOUND*",9,lisppkg); RANDSTATE=deflocal(ctx,"*RANDOM-STATE*",UNBOUND,lisppkg); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 2632032df..290e6b0f3 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -662,7 +662,7 @@ extern pointer SELF; extern pointer CLASS; extern pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; extern pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; -extern pointer TOPLEVEL,QEVALHOOK; +extern pointer TOPLEVEL,QEVALHOOK,ERRHANDLER; extern pointer QGCHOOK, QEXITHOOK; extern pointer QUNBOUND,QDEBUG; extern pointer QTHREADS; From e8aa293fc1dd3ea55c3bb96a1a2edc82c10e2419 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 23 Dec 2019 14:00:28 +0900 Subject: [PATCH 122/387] Remove .old files --- lisp/c/arith.old.c | 1446 --------------------------- lisp/c/charstring.old.c | 202 ---- lisp/c/eus.h.bsd | 785 --------------- lisp/c/eus.old.h | 795 --------------- lisp/c/unixcall.old.c | 2063 --------------------------------------- 5 files changed, 5291 deletions(-) delete mode 100644 lisp/c/arith.old.c delete mode 100644 lisp/c/charstring.old.c delete mode 100644 lisp/c/eus.h.bsd delete mode 100644 lisp/c/eus.old.h delete mode 100644 lisp/c/unixcall.old.c 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/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/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/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; -} From 088a9f2dfbffe4ddb4092113d9343940bdda4d8a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 23 Dec 2019 14:29:39 +0900 Subject: [PATCH 123/387] Fix error-handler parameters at eusdebug.l --- lisp/l/eusdebug.l | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/lisp/l/eusdebug.l b/lisp/l/eusdebug.l index 8d0a6a2f5..071a06c2f 100644 --- a/lisp/l/eusdebug.l +++ b/lisp/l/eusdebug.l @@ -253,9 +253,11 @@ (catch 'step-error (handler-bind ((error '(lambda (x) - (format *error-output* - "step evaluation error ~A~%" x) - (throw 'step-error nil)))) + (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*) @@ -368,9 +370,9 @@ (t (catch 'inspect-eval (handler-bind ((error - '(lambda (ec form &optional msg1 msg2) - (warn "error ~s ~s ~s" form msg1 msg2) - (throw 'inspect-eval t)))) + '(lambda (x) + (lisp::print-error-message x) + (throw 'inspect-eval t)))) (print (eval command))))))))))) (defmacro inspect (obj) @@ -655,12 +657,11 @@ 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)) From ad5cd28c7052db3c94d05c22319ac75f35e86e00 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 24 Dec 2019 10:34:16 +0900 Subject: [PATCH 124/387] Introduce 'invoke-next-handler' with an skip option --- lisp/l/conditions.l | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 266a66596..8602cc249 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -2,8 +2,8 @@ (in-package "LISP") -(export '(defcondition install-handler remove-handler signals euserror - sigint-handler interruption handler-bind handler-case)) +(export '(defcondition install-handler remove-handler invoke-next-handler signals + euserror sigint-handler interruption handler-bind handler-case)) (deflocal *condition-handler*) (defvar *current-condition*) @@ -90,21 +90,33 @@ ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) cases) ,form)))) +(defun invoke-next-handler (obj &optional (skip 0)) + (unless (derivedp obj condition) + (error type-error "condition class expected")) + (unless (and (integerp skip) (not (minusp skip))) + (error type-error "positive integer expected")) + (dolist (handle *condition-handler*) + (when (derivedp obj (car handle)) + (if (<= skip 0) + ;; call handler + (let ((*current-condition* obj) + (*condition-handler* (copy-list *condition-handler*))) + (if (send (cdr handle) :recursive) + ;; recursive + (return-from invoke-next-handler (funcall (send (cdr handle) :function) obj)) + ;; non-recursive: remove ongoing handler to avoid nested evaluation + (let ((*condition-handler* (remove handle *condition-handler* :test #'equal :count 1))) + (return-from invoke-next-handler (funcall (send (cdr handle) :function) obj))))) + ;; decrease skip count + (decf skip))))) + (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)) - ;; remove ongoing handler to avoid nested evaluation - (let ((*current-condition* obj) - (*condition-handler* (copy-list *condition-handler*))) - (if (send (cdr handle) :recursive) - (return-from signals (funcall (send (cdr handle) :function) obj)) - (let ((*condition-handler* (remove handle *condition-handler* :test #'equal :count 1))) - (return-from signals (funcall (send (cdr handle) :function) obj)))))))) + (invoke-next-handler obj)) (defun print-callstack (&optional (stack (sys:list-callstack)) max (os *error-output*)) (let ((tms (if max From f9c7663232300f903524a15bab7fe0f4181e1d94 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 24 Dec 2019 10:54:55 +0900 Subject: [PATCH 125/387] Add documentation for 'invoke-next-handler' --- doc/jlatex/euslisp.hlp | 1 + doc/jlatex/jcontrols.tex | 8 ++++++-- doc/latex/controls.tex | 4 ++++ doc/latex/euslisp.hlp | 1 + 4 files changed, 12 insertions(+), 2 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index db6c77d8b..5c61f45c8 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -53,6 +53,7 @@ "handler-bind" 2 "jcontrols" 15104 3 "handler-case" 3 "jcontrols" 15491 3 "signals" 2 "jcontrols" 15886 3 +"invoke-next-handler" 2 "jcontrols" 16307 3 "defclass" 3 "jobjects" 4063 3 "defmethod" 6 "jobjects" 4582 3 "defclassmethod" 3 "jobjects" 4812 2 diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index 6de885539..ec8a999f0 100644 --- a/doc/jlatex/jcontrols.tex +++ b/doc/jlatex/jcontrols.tex @@ -313,8 +313,12 @@ \subsection{コンディション} {\em arg-list}はコンディションインスタンスを保持する一個(あるいはゼロ個)のパラメータを持つリストである。} \funcdesc{signals}{obj \&rest init-args}{ -{\em obj}によって示されるコンディションをsignalizeする。最初にマッチングされたhandlerの返り値を返す。マッチングされたhandlerがないためにはnilを返す。 -{\em obj}はコンディションのインスタンスか、 {\em init-args}によって初期化されるコンディションクラスである。} +{\em obj}によって示されるコンディションをsignalizeする。最初にマッチングされたhandlerの返り値を返す。マッチングされずどのhandlerも呼ばれない時にはnilを返す。 +{\em obj}はコンディションインスタンスか、 {\em init-args}によって初期化されるコンディションクラスである。} + +\funcdesc{invoke-next-handler}{obj \&optional (skip 0)}{ + signalsと似ているが、呼び出し時にhandlerをスキップできる。(skip + 1)番目にマッチングされたhandlerの返り値を返す。どのhandlerも呼ばれない時にはnilを返す。 +{\em obj}は初期化されたコンディションインスタンスである。} \end{refdesc} diff --git a/doc/latex/controls.tex b/doc/latex/controls.tex index b68f0d1e1..931d941c9 100644 --- a/doc/latex/controls.tex +++ b/doc/latex/controls.tex @@ -314,6 +314,10 @@ \subsection{Conditions} 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 \&optional (skip 0)}{ + Similar to {\it signals}, but allows to skip handlers. Returns the result of the $(skip + 1)$ matching handler or {\it nil} if unhandled. + {\em obj} must be an initialized condition instance.} + \end{refdesc} \newpage diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 5c5195182..425988660 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -53,6 +53,7 @@ "handler-bind" 2 "controls" 12365 3 "handler-case" 3 "controls" 12655 3 "signals" 2 "controls" 12953 3 +"invoke-next-handler" 2 "controls" 13205 3 "defclass" 3 "objects" 3223 3 "defmethod" 6 "objects" 3684 3 "defclassmethod" 3 "objects" 3859 2 From d7b170b56cbc1f560d74ecb135108c2c374d588e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 29 Dec 2019 10:55:52 +0900 Subject: [PATCH 126/387] Remove unused ERRHANDLER (again) This reverts commit 130bec2640ff1d125c1f987ad568682a8cb649e8. --- lisp/c/eus.c | 3 +-- lisp/c/eus.h | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index e17057338..650fc4fd7 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -124,7 +124,7 @@ pointer SELF; pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; -pointer TOPLEVEL,QEVALHOOK,ERRHANDLER,FATALERROR; +pointer TOPLEVEL,QEVALHOOK,FATALERROR; pointer QGCHOOK, QEXITHOOK; pointer QUNBOUND,QDEBUG; pointer QTHREADS; /* system:*threads* */ @@ -690,7 +690,6 @@ static void initsymbols() PRLEVEL=deflocal(ctx,"*PRINT-LEVEL*",NIL,lisppkg); QREADTABLE=deflocal(ctx,"*READTABLE*",NIL,lisppkg); TOPLEVEL=defvar(ctx,"*TOPLEVEL*",NIL,lisppkg); - ERRHANDLER=deflocal(ctx,"*ERROR-HANDLER*",NIL,lisppkg); QEVALHOOK=deflocal(ctx,"*EVALHOOK*",NIL,lisppkg); QUNBOUND=intern(ctx,"*UNBOUND*",9,lisppkg); RANDSTATE=deflocal(ctx,"*RANDOM-STATE*",UNBOUND,lisppkg); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 290e6b0f3..2632032df 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -662,7 +662,7 @@ 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 TOPLEVEL,QEVALHOOK; extern pointer QGCHOOK, QEXITHOOK; extern pointer QUNBOUND,QDEBUG; extern pointer QTHREADS; From 92d78e002600d5b706e030db78484a517623c3a4 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 3 Jan 2020 17:17:33 +0900 Subject: [PATCH 127/387] Force global scope on (global) install-handler --- lisp/l/conditions.l | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 8602cc249..ccd77b7fe 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -51,7 +51,7 @@ (if supplied-p (send self :set-val ',s val) ,s))) slots)))) -(defun install-handler (label handler &key (recursive t)) +(defun install-handler-raw (label handler &key recursive) ;; ensure condition class (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) @@ -59,6 +59,12 @@ *condition-handler*) t) +(defun install-handler (label handler &key (recursive t)) + ;; ensure global scope + (when (and (consp handler) (eql (car handler) 'lambda-closure)) + (setq handler `(lambda-closure ,(second handler) 0 0 ,@(nthcdr 4 handler)))) + (install-handler-raw label handler :recursive recursive)) + (defun remove-handler (label &optional handler) (let ((item (if handler @@ -74,7 +80,7 @@ (defmacro handler-bind (bindings &rest forms) `(let ((*condition-handler* (copy-list *condition-handler*))) - ,@(mapcar #'(lambda (bind) `(install-handler ,@bind :recursive nil)) bindings) + ,@(mapcar #'(lambda (bind) `(install-handler-raw ,@bind :recursive nil)) bindings) ,@forms)) (defmacro handler-case (form &rest cases) From 17bcb5da728e5b8a753c295998bba7bae4a6aced Mon Sep 17 00:00:00 2001 From: Shun Hasegawa Date: Fri, 3 Jan 2020 20:52:15 +0900 Subject: [PATCH 128/387] Suppress breakck --- lisp/c/eval.c | 2 +- lisp/c/lists.c | 2 +- lisp/c/specials.c | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 01815b8ba..f1373edc7 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1529,7 +1529,7 @@ int noarg; /*make a new stack frame*/ stackck; /*stack overflow?*/ - breakck; /*signal exists?*/ + // breakck; /*signal exists?*/ vf->vlink=ctx->callfp; vf->form=form; ctx->callfp=vf; diff --git a/lisp/c/lists.c b/lisp/c/lists.c index f9d1e185e..e5c0395d6 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -222,7 +222,7 @@ register pointer argv[]; while (--n>=0) { c=argv[n]; if (islist(c)) { - while (islist(ccdr(c))) { breakck; c=ccdr(c);} + while (islist(ccdr(c))) { c=ccdr(c);} pointer_update(ccdr(c),a); a=argv[n];} } diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 8d557cdd2..c60c72f9e 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -382,7 +382,7 @@ pointer arg; if ((result=(pointer)eussetjmp(whilejmp))==0) { while (eval(ctx,cond)!=NIL) { GC_POINT; - breakck; + // breakck; progn(ctx,body);} result=NIL;} else if ((eusinteger_t)result==1) result=makeint(0); From 77528b001496f24fe488d41250150369cd27c73e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 3 Jan 2020 21:56:41 +0900 Subject: [PATCH 129/387] Only check for SIGINT when memory may be unstable --- lisp/c/eval.c | 3 ++- lisp/c/lists.c | 5 ++++- lisp/c/specials.c | 3 ++- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/lisp/c/eval.c b/lisp/c/eval.c index f1373edc7..5ad4de0d1 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1529,7 +1529,8 @@ int noarg; /*make a new stack frame*/ stackck; /*stack overflow?*/ - // breakck; /*signal exists?*/ + // Memory state is not stable enough to call arbitrary callbacks + if (ctx->intsig==2) sigbreak(); /*signal exists?*/ vf->vlink=ctx->callfp; vf->form=form; ctx->callfp=vf; diff --git a/lisp/c/lists.c b/lisp/c/lists.c index e5c0395d6..ef1683ade 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -222,7 +222,10 @@ register pointer argv[]; while (--n>=0) { c=argv[n]; if (islist(c)) { - while (islist(ccdr(c))) { c=ccdr(c);} + while (islist(ccdr(c))) { + // Memory state is not stable enough to call arbitrary callbacks + if (ctx->intsig==2) sigbreak(); + c=ccdr(c);} pointer_update(ccdr(c),a); a=argv[n];} } diff --git a/lisp/c/specials.c b/lisp/c/specials.c index c60c72f9e..f16a76df0 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -382,7 +382,8 @@ pointer arg; if ((result=(pointer)eussetjmp(whilejmp))==0) { while (eval(ctx,cond)!=NIL) { GC_POINT; - // breakck; + // Memory state is not stable enough to call arbitrary callbacks + if (ctx->intsig==2) sigbreak(); progn(ctx,body);} result=NIL;} else if ((eusinteger_t)result==1) result=makeint(0); From 5dbb6c2b5bb5848ec609345539408f51bb129f9b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 3 Jan 2020 22:10:15 +0900 Subject: [PATCH 130/387] Add breakck on unix::select --- lisp/c/unixcall.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/c/unixcall.c b/lisp/c/unixcall.c index 581985952..1756c0375 100644 --- a/lisp/c/unixcall.c +++ b/lisp/c/unixcall.c @@ -1661,7 +1661,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) From 3ad892c72c04161559f4260d00309e3bf281b0d7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 9 Jun 2020 13:17:14 +0900 Subject: [PATCH 131/387] Revert "Only check for SIGINT when memory may be unstable" This reverts commit b5788f39dfff56f8903f8d82d81b9f25706745e2. --- lisp/c/eval.c | 3 +-- lisp/c/lists.c | 5 +---- lisp/c/specials.c | 3 +-- 3 files changed, 3 insertions(+), 8 deletions(-) diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 5ad4de0d1..f1373edc7 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1529,8 +1529,7 @@ int noarg; /*make a new stack frame*/ stackck; /*stack overflow?*/ - // Memory state is not stable enough to call arbitrary callbacks - if (ctx->intsig==2) sigbreak(); /*signal exists?*/ + // breakck; /*signal exists?*/ vf->vlink=ctx->callfp; vf->form=form; ctx->callfp=vf; diff --git a/lisp/c/lists.c b/lisp/c/lists.c index ef1683ade..e5c0395d6 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -222,10 +222,7 @@ register pointer argv[]; while (--n>=0) { c=argv[n]; if (islist(c)) { - while (islist(ccdr(c))) { - // Memory state is not stable enough to call arbitrary callbacks - if (ctx->intsig==2) sigbreak(); - c=ccdr(c);} + while (islist(ccdr(c))) { c=ccdr(c);} pointer_update(ccdr(c),a); a=argv[n];} } diff --git a/lisp/c/specials.c b/lisp/c/specials.c index f16a76df0..c60c72f9e 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -382,8 +382,7 @@ pointer arg; if ((result=(pointer)eussetjmp(whilejmp))==0) { while (eval(ctx,cond)!=NIL) { GC_POINT; - // Memory state is not stable enough to call arbitrary callbacks - if (ctx->intsig==2) sigbreak(); + // breakck; progn(ctx,body);} result=NIL;} else if ((eusinteger_t)result==1) result=makeint(0); From 8fdcb46794e1e8f0170b3c5d5f5e11328a99f20a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 9 Jun 2020 13:17:34 +0900 Subject: [PATCH 132/387] Revert "Suppress breakck" This reverts commit 813c55b69375832dfa54bb35ecf8f48b89d8639f. --- lisp/c/eval.c | 2 +- lisp/c/lists.c | 2 +- lisp/c/specials.c | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/c/eval.c b/lisp/c/eval.c index f1373edc7..01815b8ba 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1529,7 +1529,7 @@ int noarg; /*make a new stack frame*/ stackck; /*stack overflow?*/ - // breakck; /*signal exists?*/ + breakck; /*signal exists?*/ vf->vlink=ctx->callfp; vf->form=form; ctx->callfp=vf; diff --git a/lisp/c/lists.c b/lisp/c/lists.c index e5c0395d6..f9d1e185e 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -222,7 +222,7 @@ register pointer argv[]; while (--n>=0) { c=argv[n]; if (islist(c)) { - while (islist(ccdr(c))) { c=ccdr(c);} + while (islist(ccdr(c))) { breakck; c=ccdr(c);} pointer_update(ccdr(c),a); a=argv[n];} } diff --git a/lisp/c/specials.c b/lisp/c/specials.c index c60c72f9e..8d557cdd2 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -382,7 +382,7 @@ pointer arg; if ((result=(pointer)eussetjmp(whilejmp))==0) { while (eval(ctx,cond)!=NIL) { GC_POINT; - // breakck; + breakck; progn(ctx,body);} result=NIL;} else if ((eusinteger_t)result==1) result=makeint(0); From 2f997664fb6cb12b266ae8606ac907c1ee0ecff2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 9 Jun 2020 15:21:33 +0900 Subject: [PATCH 133/387] Propagate 'sig' and 'code' arguments through unix::signal-received condition --- lisp/l/conditions.l | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index ccd77b7fe..a7c8171c4 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -161,13 +161,13 @@ ;;; unix:signal handling ;;; -(defcondition unix::signal-received) +(defcondition unix::signal-received :slots (sig code)) (defmacro unix::install-signal-handler (sig obj &rest init-args) (let ((fname (intern (format nil "~A-SIGNALIZE-CONDITION" (symbol-pname sig)) *unix-package*))) `(progn (unless (boundp ',obj) (defcondition ,obj :super unix::signal-received)) - (defun ,fname (sig code) (signals ,obj ,@init-args)) + (defun ,fname (sig code) (signals ,obj :sig sig :code code ,@init-args)) (unix:signal ,sig ',fname)))) (defmacro unix::with-alarm-interrupt (&rest body) From 8b25765ca6956286986224d0df14b75081e8ad46 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 9 Jun 2020 16:22:33 +0900 Subject: [PATCH 134/387] Introduce assertion-error --- lisp/l/conditions.l | 9 ++++++++- lisp/l/eusdebug.l | 4 ++-- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index a7c8171c4..afa5029b1 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -3,7 +3,7 @@ (in-package "LISP") (export '(defcondition install-handler remove-handler invoke-next-handler signals - euserror sigint-handler interruption handler-bind handler-case)) + assertion-error euserror sigint-handler interruption handler-bind handler-case)) (deflocal *condition-handler*) (defvar *current-condition*) @@ -143,6 +143,13 @@ (terpri os))) +;;; +;;; assertion error +;;; + +(defcondition assertion-error :super error) + + ;;; ;;; error handling ;;; diff --git a/lisp/l/eusdebug.l b/lisp/l/eusdebug.l index 071a06c2f..f151517cf 100644 --- a/lisp/l/eusdebug.l +++ b/lisp/l/eusdebug.l @@ -23,9 +23,9 @@ *remote-port* remote-error reval *server-streams* remote-port)) -(defun assert (pred &optional (message "Assertation Error") &rest args) +(defun assert (pred &optional (message "") &rest args) (if (not pred) - (apply #'error message args))) + (apply #'error assertion-error message args))) (defun warning-message (color format &rest mesg) (format *error-output* "~C[3~Cm" #x1b (+ color 48)) From db951bf507b10ae9d5470b59c1789598ab7c55e0 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 9 Jun 2020 16:28:57 +0900 Subject: [PATCH 135/387] Use predicate as form in assert --- lisp/l/eusdebug.l | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/l/eusdebug.l b/lisp/l/eusdebug.l index f151517cf..f9bd60145 100644 --- a/lisp/l/eusdebug.l +++ b/lisp/l/eusdebug.l @@ -23,9 +23,13 @@ *remote-port* remote-error reval *server-streams* remote-port)) -(defun assert (pred &optional (message "") &rest args) +(defun assert (pred &optional (message "assertion failed") &rest args) (if (not pred) - (apply #'error assertion-error message args))) + (handler-case (apply #'error assertion-error message args) + (assertion-error (err) + ;; set pred as the new form + (send err :form (cadr (send err :form))) + (signals err))))) (defun warning-message (color format &rest mesg) (format *error-output* "~C[3~Cm" #x1b (+ color 48)) From 18a7f7d87f45d943579c7b9a015ca92803e76026 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 9 Jun 2020 16:30:30 +0900 Subject: [PATCH 136/387] Adapt unittest.l to new error handlers --- lib/llib/unittest.l | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/lib/llib/unittest.l b/lib/llib/unittest.l index e862755df..445003b93 100644 --- a/lib/llib/unittest.l +++ b/lib/llib/unittest.l @@ -41,27 +41,28 @@ ) 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) +(defun unittest-error (err) + (when (send err :callstack) + (lisp::print-callstack (send err :callstack) lisp::*max-callstack-depth*)) + (lisp::print-error-message err) + (warning-message 1 " exitting...~%") + (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)) + (push (list (send err :form) (send err :message) (send (class err) :name)) + (unit-test-result-failures (car (last (*unit-test* . result)))))) + (format *error-output* "~C[3~Cm[ERROR] test ~A failed" #x1b 49 (send err :form)) + (format *error-output* " ... (~A ~A)" (send err :message) (send (class err) :name)) + (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) +(defun unittest-sigint-handler (c) + (format *error-output* "unittest-sigint-handler ~A~%" (send c :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)))))) + (push (list "" (format nil "signal-handler ~A" (send c :sig)) (send (class c) :name)) + (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))) @@ -218,9 +219,10 @@ (if xml-fname (setq log-fname xml-fname)) (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) + (unix:install-signal-handler unix::sighup unix::sighup-received) + (install-handler error 'unittest-error) + (install-handler unix::sigint-received 'unittest-sigint-handler) + (install-handler unix::sighup-received 'unittest-sigint-handler) (setq *unit-test* (instance unit-test-container :init :log-fname log-fname)) From c11d34d6220aa99aa99901f815d59b5c207f2d88 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Jun 2020 12:41:17 +0900 Subject: [PATCH 137/387] Revert handler-case order to match case and cond statements --- lisp/l/conditions.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index afa5029b1..844539119 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -93,7 +93,7 @@ (progn ,@body)))))) `(catch :handler-case (handler-bind - ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) cases) + ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) (reverse cases)) ,form)))) (defun invoke-next-handler (obj &optional (skip 0)) From 79a2022a2a590bb99810fe94c5a158720383601e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Jun 2020 14:59:42 +0900 Subject: [PATCH 138/387] Make better use of conditions on unittest.l --- lib/llib/unittest.l | 115 +++++++++++++++++++++----------------------- 1 file changed, 55 insertions(+), 60 deletions(-) diff --git a/lib/llib/unittest.l b/lib/llib/unittest.l index 445003b93..c10a84c85 100644 --- a/lib/llib/unittest.l +++ b/lib/llib/unittest.l @@ -41,30 +41,6 @@ ) str2)) -(defun unittest-error (err) - (when (send err :callstack) - (lisp::print-callstack (send err :callstack) lisp::*max-callstack-depth*)) - (lisp::print-error-message err) - (warning-message 1 " exitting...~%") - - (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 (send err :form) (send err :message) (send (class err) :name)) - (unit-test-result-failures (car (last (*unit-test* . result)))))) - (format *error-output* "~C[3~Cm[ERROR] test ~A failed" #x1b 49 (send err :form)) - (format *error-output* " ... (~A ~A)" (send err :message) (send (class err) :name)) - (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 (c) - (format *error-output* "unittest-sigint-handler ~A~%" (send c :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" (send c :sig)) (send (class c) :name)) - (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 @@ -92,15 +68,22 @@ (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 " ~%") ) ) @@ -127,12 +110,26 @@ (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) + (format *error-output* "~C[3~Cm[ERROR] test ~A failed" #x1b 49 (send failure :form)) + (format *error-output* " ... (~A)" (send failure :message)) + (format *error-output* ".~C[0m~%" #x1b)) + ((derivedp failure unix::signal-received) + (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 lisp::*exit-on-fatal-error* (send self :abort))) (:set-time-to-current-result (time) ;; msec (if result (setf (unit-test-result-time (car result)) (round time)))) @@ -141,7 +138,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) ) ;; @@ -182,10 +179,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)) @@ -220,9 +233,6 @@ (setq lisp::*exit-on-fatal-error* t) (unix:install-signal-handler unix::sighup unix::sighup-received) - (install-handler error 'unittest-error) - (install-handler unix::sigint-received 'unittest-sigint-handler) - (install-handler unix::sighup-received 'unittest-sigint-handler) (setq *unit-test* (instance unit-test-container :init :log-fname log-fname)) @@ -232,21 +242,6 @@ `(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) From 8c7f9fdb028488fa374b6336c55006e85050d443 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Jun 2020 15:01:26 +0900 Subject: [PATCH 139/387] Start print-result with new line at unittest.l --- lib/llib/unittest.l | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/llib/unittest.l b/lib/llib/unittest.l index c10a84c85..85d1a3b10 100644 --- a/lib/llib/unittest.l +++ b/lib/llib/unittest.l @@ -156,6 +156,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) From 294708cb41799457ffbbbe9472fedd885c56d33b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Jun 2020 15:48:18 +0900 Subject: [PATCH 140/387] Introduce exit-on-error slot to allow to proceed testing after errors on unittest.l --- lib/llib/unittest.l | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/lib/llib/unittest.l b/lib/llib/unittest.l index 85d1a3b10..923788f73 100644 --- a/lib/llib/unittest.l +++ b/lib/llib/unittest.l @@ -90,14 +90,15 @@ (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)) @@ -129,7 +130,7 @@ (exit 1)) (:maybe-abort () - (when lisp::*exit-on-fatal-error* (send self :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)))) @@ -226,16 +227,16 @@ (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)) - - (setq lisp::*exit-on-fatal-error* t) (unix:install-signal-handler unix::sighup unix::sighup-received) - (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)) From cb29436e379cb650566238469609afc3f427b446 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Jun 2020 17:09:47 +0900 Subject: [PATCH 141/387] Print test name on failure messages at unittest.l --- lib/llib/unittest.l | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/lib/llib/unittest.l b/lib/llib/unittest.l index 923788f73..57e32b640 100644 --- a/lib/llib/unittest.l +++ b/lib/llib/unittest.l @@ -115,12 +115,21 @@ (if result (push failure (unit-test-result-failures (car result)))) (cond ((derivedp failure error) - (format *error-output* "~C[3~Cm[ERROR] test ~A failed" #x1b 49 (send failure :form)) + (if result + (format *error-output* "~C[3~Cm[ERROR] test ~A failed at ~A" #x1b 49 + (unit-test-result-name (car result)) + (send failure :form)) + (format *error-output* "~C[3~Cm[ERROR] test failed at ~A" #x1b 49 + (send failure :form))) (format *error-output* " ... (~A)" (send failure :message)) (format *error-output* ".~C[0m~%" #x1b)) ((derivedp failure unix::signal-received) - (format *error-output* "~C[3~Cm[ERROR] test interrupted with signal ~A" #x1b 49 - (send failure :sig)) + (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 From eb1add8b2191d7a1c60a1c64743047666a687106 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Jun 2020 17:40:29 +0900 Subject: [PATCH 142/387] Adapt tests to new error handlers --- test/argparse.l | 2 +- test/const.l | 10 +++++----- test/min-max.l | 13 ++++++------- 3 files changed, 12 insertions(+), 13 deletions(-) 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/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/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 From f92b313dbddb954b79bf635b76e6942ff492a824 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Jun 2020 21:31:10 +0900 Subject: [PATCH 143/387] Add condition tests --- test/conditions.l | 359 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 359 insertions(+) create mode 100644 test/conditions.l diff --git a/test/conditions.l b/test/conditions.l new file mode 100644 index 000000000..c458e43d9 --- /dev/null +++ b/test/conditions.l @@ -0,0 +1,359 @@ +;;;; 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)))))) + +;;;; 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) expected-fmt))) + +(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) + +(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) From d43e7265864da69d64f8ccfc8daeae20215835dd Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 15 Apr 2021 20:23:09 +0900 Subject: [PATCH 144/387] Remove :recursive option in handlers --- doc/jlatex/jcontrols.tex | 15 +++++------- doc/latex/controls.tex | 12 ++++------ lisp/l/conditions.l | 49 +++++++++++++++++----------------------- 3 files changed, 32 insertions(+), 44 deletions(-) diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index ec8a999f0..c7743cd7b 100644 --- a/doc/jlatex/jcontrols.tex +++ b/doc/jlatex/jcontrols.tex @@ -294,17 +294,15 @@ \subsection{コンディション} \macrodesc{defcondition}{name \&key slots (super 'condition)}{ 新しいコンディションを定義する。{\em slots}に含まれる各スロットに対するsetter/getterと{\em :init}メソッドも一緒に定義される。} -\funcdesc{install-handler}{label handler \&key (recursive t)}{ +\funcdesc{install-handler}{label handler}{ Callback関数{\em handler}を定義し、{\em label}を親クラスとするコンディションがsignalizeされたらその関数を実行する。 -{\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。 -{\em recursive}がnilの時、{\em handler}の再帰的呼び出しは行われず、{\em handler}実行中に新たな{\em label}に属するコンディションがsignalizeされればその次に登録されているハンドラーが呼び出される。 -} +{\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。} \funcdesc{remove-handler}{label \&optional handler}{ コンディション{\em label}で登録された最後のhandlerを登録解除する。 {\em handler}が与えられた場合、最後に登録された({\em label . handler})のペアを登録解除する。} -\funcdesc{handler-bind}{(\&rest (label handler \&key (recursive nil))) \&rest forms}{ +\funcdesc{handler-bind}{(\&rest (label handler)) \&rest forms}{ コンディション{\rm label}とハンドラー{\em handler}をロカルにbindし、{\em forms}を実行する。 {\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。} @@ -313,12 +311,11 @@ \subsection{コンディション} {\em arg-list}はコンディションインスタンスを保持する一個(あるいはゼロ個)のパラメータを持つリストである。} \funcdesc{signals}{obj \&rest init-args}{ -{\em obj}によって示されるコンディションをsignalizeする。最初にマッチングされたhandlerの返り値を返す。マッチングされずどのhandlerも呼ばれない時にはnilを返す。 +{\em obj}によって示されるコンディションをsignalizeする。最初にマッチングされたhandlerの返り値を返す。マッチングされずにどのhandlerも呼ばれない場合はnilを返す。 {\em obj}はコンディションインスタンスか、 {\em init-args}によって初期化されるコンディションクラスである。} -\funcdesc{invoke-next-handler}{obj \&optional (skip 0)}{ - signalsと似ているが、呼び出し時にhandlerをスキップできる。(skip + 1)番目にマッチングされたhandlerの返り値を返す。どのhandlerも呼ばれない時にはnilを返す。 -{\em obj}は初期化されたコンディションインスタンスである。} +\funcdesc{invoke-next-handler}{obj}{ + コンディションハンドラーの中から呼ばれた場合、コンディションインタンス{\em obj}と次にマッチングされたhandlerの返り値を返す。マッチングされずにどのhandlerも呼ばれない場合はnilを返す。} \end{refdesc} diff --git a/doc/latex/controls.tex b/doc/latex/controls.tex index 931d941c9..4c8d724e8 100644 --- a/doc/latex/controls.tex +++ b/doc/latex/controls.tex @@ -294,16 +294,15 @@ \subsection{Conditions} \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 \&key (recursive t)}{ +\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). - If {\em recursive} is nil, recursive calling of {\em handler} is disabled, and new conditions belonging to {\em label} signalized from within {\em handler} cause the next registered handler function to be executed.} + {\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 registered for condition {\em label}. If {\em handler} is given, removes the last registered pair of ({\em label . handler}) instead.} -\funcdesc{handler-bind}{(\&rest (label handler \&key (recursive nil))) \&rest forms}{ +\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).} @@ -314,9 +313,8 @@ \subsection{Conditions} 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 \&optional (skip 0)}{ - Similar to {\it signals}, but allows to skip handlers. Returns the result of the $(skip + 1)$ matching handler or {\it nil} if unhandled. - {\em obj} must be an initialized condition instance.} +\funcdesc{invoke-next-handler}{obj}{ + Can be used from within a condition handler to call the next handler matching the the {\it obj} condition. {\it obj} must be an initialized condition instance. Returns the result of the matching handler or {\it nil} if unhandled.} \end{refdesc} diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 844539119..98741d60e 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -6,7 +6,7 @@ assertion-error euserror sigint-handler interruption handler-bind handler-case)) (deflocal *condition-handler*) -(defvar *current-condition*) +(defvar *current-condition-handler*) (defmethod condition (:init (&rest init-args &key message &allow-other-keys) @@ -24,13 +24,12 @@ (:callstack (&optional val) (if val (setq callstack val) callstack)) (:form (&optional val) (if val (setq form val) form))) -(defclass condition-handler :slots (fn recursive) :super propertied-object) +(defclass condition-handler :slots (fn) :super propertied-object) (defmethod condition-handler - (:init (fn &key recursive) + (:init (fn) (unless (functionp fn) (error type-error "function expected")) ;; set slots (send self :set-val "FN" fn) - (send self :set-val "RECURSIVE" recursive) ;; set name (let ((name (cond @@ -39,8 +38,7 @@ ((listp fn) (second fn))))) (if name (setf (get self :name) name))) self) - (:function (&optional val) (if val (setq fn val) fn)) - (:recursive (&optional (val nil supplied-p)) (if supplied-p (setq recursive val) recursive))) + (:function (&optional val) (if val (setq fn val) fn))) (defmacro defcondition (name &key slots (super 'condition)) `(progn @@ -51,19 +49,19 @@ (if supplied-p (send self :set-val ',s val) ,s))) slots)))) -(defun install-handler-raw (label handler &key recursive) +(defun install-handler-raw (label handler) ;; ensure condition class (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) - (push (cons label (instance condition-handler :init handler :recursive recursive)) + (push (cons label (instance condition-handler :init handler)) *condition-handler*) t) -(defun install-handler (label handler &key (recursive t)) +(defun install-handler (label handler) ;; ensure global scope (when (and (consp handler) (eql (car handler) 'lambda-closure)) (setq handler `(lambda-closure ,(second handler) 0 0 ,@(nthcdr 4 handler)))) - (install-handler-raw label handler :recursive recursive)) + (install-handler-raw label handler)) (defun remove-handler (label &optional handler) (let ((item @@ -80,7 +78,7 @@ (defmacro handler-bind (bindings &rest forms) `(let ((*condition-handler* (copy-list *condition-handler*))) - ,@(mapcar #'(lambda (bind) `(install-handler-raw ,@bind :recursive nil)) bindings) + ,@(mapcar #'(lambda (bind) `(install-handler-raw ,@bind)) bindings) ,@forms)) (defmacro handler-case (form &rest cases) @@ -96,25 +94,15 @@ ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) (reverse cases)) ,form)))) -(defun invoke-next-handler (obj &optional (skip 0)) +(defun invoke-next-handler (obj) (unless (derivedp obj condition) (error type-error "condition class expected")) - (unless (and (integerp skip) (not (minusp skip))) - (error type-error "positive integer expected")) - (dolist (handle *condition-handler*) + (dolist (handle *current-condition-handler*) (when (derivedp obj (car handle)) - (if (<= skip 0) - ;; call handler - (let ((*current-condition* obj) - (*condition-handler* (copy-list *condition-handler*))) - (if (send (cdr handle) :recursive) - ;; recursive - (return-from invoke-next-handler (funcall (send (cdr handle) :function) obj)) - ;; non-recursive: remove ongoing handler to avoid nested evaluation - (let ((*condition-handler* (remove handle *condition-handler* :test #'equal :count 1))) - (return-from invoke-next-handler (funcall (send (cdr handle) :function) obj))))) - ;; decrease skip count - (decf skip))))) + ;; 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) @@ -122,7 +110,12 @@ (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")) - (invoke-next-handler obj)) + (dolist (handle *condition-handler*) + (when (derivedp obj (car handle)) + ;; call handler + (let ((*current-condition-handler* + (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 From 45d36aaceb62f346fc90191eaaa68b4d375ad852 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 15 Apr 2021 20:25:04 +0900 Subject: [PATCH 145/387] Update documentation help files --- doc/jlatex/euslisp.hlp | 10 +++++----- doc/latex/euslisp.hlp | 10 +++++----- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 5c61f45c8..b0684ca1f 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -49,11 +49,11 @@ "lisp::*current-condition*" 5 "jcontrols" 13848 2 "defcondition" 3 "jcontrols" 13943 3 "install-handler" 2 "jcontrols" 14181 3 -"remove-handler" 2 "jcontrols" 14839 3 -"handler-bind" 2 "jcontrols" 15104 3 -"handler-case" 3 "jcontrols" 15491 3 -"signals" 2 "jcontrols" 15886 3 -"invoke-next-handler" 2 "jcontrols" 16307 3 +"remove-handler" 2 "jcontrols" 14558 3 +"handler-bind" 2 "jcontrols" 14823 3 +"handler-case" 3 "jcontrols" 15188 3 +"signals" 2 "jcontrols" 15583 3 +"invoke-next-handler" 2 "jcontrols" 16007 3 "defclass" 3 "jobjects" 4063 3 "defmethod" 6 "jobjects" 4582 3 "defclassmethod" 3 "jobjects" 4812 2 diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 425988660..12a89d1e7 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -49,11 +49,11 @@ "lisp::*current-condition*" 5 "controls" 11334 2 "defcondition" 3 "controls" 11409 3 "install-handler" 2 "controls" 11611 3 -"remove-handler" 2 "controls" 12149 3 -"handler-bind" 2 "controls" 12365 3 -"handler-case" 3 "controls" 12655 3 -"signals" 2 "controls" 12953 3 -"invoke-next-handler" 2 "controls" 13205 3 +"remove-handler" 2 "controls" 11912 3 +"handler-bind" 2 "controls" 12128 3 +"handler-case" 3 "controls" 12396 3 +"signals" 2 "controls" 12694 3 +"invoke-next-handler" 2 "controls" 12946 3 "defclass" 3 "objects" 3223 3 "defmethod" 6 "objects" 3684 3 "defclassmethod" 3 "objects" 3859 2 From d6461247e1d55406f503ba23e19eb06d87bcbfa7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 16 Apr 2021 17:06:51 +0900 Subject: [PATCH 146/387] Update *current-condition-handler* recursively --- lisp/l/conditions.l | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 98741d60e..84b3aa3f5 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -114,7 +114,9 @@ (when (derivedp obj (car handle)) ;; call handler (let ((*current-condition-handler* - (remove handle (copy-list *condition-handler*) :test #'equal :count 1))) + (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*)) From 14a8e6899350aa29518c94e6af5a2396d417b95c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 26 Aug 2021 14:03:56 +0900 Subject: [PATCH 147/387] Use separate handler-case catch frames to avoid confusion on nested scenarios with code jumping (e.g. ros::spin-once) --- lisp/l/conditions.l | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 84b3aa3f5..ad7041984 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -81,18 +81,27 @@ ,@(mapcar #'(lambda (bind) `(install-handler-raw ,@bind)) bindings) ,@forms)) +(defun get-handler-frame (&optional (name "HANDLER-CASE-")) + (let ((handler-frame (symbol-pname (gensym name)))) + (while (find-symbol handler-frame *keyword-package*) + (setq handler-frame (symbol-pname (gensym name)))) + (intern handler-frame *keyword-package*))) + (defmacro handler-case (form &rest cases) - (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-case - (progn ,@body)))))) - `(catch :handler-case - (handler-bind - ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) (reverse cases)) - ,form)))) + (let ((handler-frame (get-handler-frame))) + (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)))))) + `(prog1 + (catch ,handler-frame + (handler-bind + ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) (reverse cases)) + ,form)) + (send *keyword-package* :unintern ,handler-frame))))) (defun invoke-next-handler (obj) (unless (derivedp obj condition) From c6829fd8af6d8a2368c0e44e5d9deaf437b32a23 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 11 Sep 2021 08:23:31 +0900 Subject: [PATCH 148/387] Avoid nested condition handlers in assert --- lisp/l/eusdebug.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/eusdebug.l b/lisp/l/eusdebug.l index f9bd60145..166b70cd1 100644 --- a/lisp/l/eusdebug.l +++ b/lisp/l/eusdebug.l @@ -29,7 +29,7 @@ (assertion-error (err) ;; set pred as the new form (send err :form (cadr (send err :form))) - (signals err))))) + (invoke-next-handler err))))) (defun warning-message (color format &rest mesg) (format *error-output* "~C[3~Cm" #x1b (+ color 48)) From d368fcd2017a7c758443e63c30b23f2accf95f3a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 29 Sep 2021 17:05:31 +0900 Subject: [PATCH 149/387] Allow unix:install-signal-handler to take integer arguments --- lisp/l/conditions.l | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index ad7041984..ac220e2af 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -174,12 +174,11 @@ (defcondition unix::signal-received :slots (sig code)) (defmacro unix::install-signal-handler (sig obj &rest init-args) - (let ((fname (intern (format nil "~A-SIGNALIZE-CONDITION" (symbol-pname sig)) *unix-package*))) - `(progn - (unless (boundp ',obj) - (defcondition ,obj :super unix::signal-received)) - (defun ,fname (sig code) (signals ,obj :sig sig :code code ,@init-args)) - (unix:signal ,sig ',fname)))) + `(progn + (defcondition ,obj :super unix::signal-received) + (unix:signal ,sig + ;; ensure global scope + ',`(lambda-closure nil 0 0 (sig code) (signals ,obj :sig sig :code code ,@init-args))))) (defmacro unix::with-alarm-interrupt (&rest body) (let ((interval (gensym)) (value (gensym))) From 9d0186fec33497537ded991d482d9026455e7b5c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 1 Oct 2021 09:59:34 +0900 Subject: [PATCH 150/387] Fix mismatch parenthesis --- lisp/l/conditions.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index ac220e2af..1c9509373 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -202,7 +202,7 @@ (install-handler error #'euserror) (install-handler interruption 'interruption-handler) (unix:install-signal-handler unix::sigint unix::sigint-received) -(unix:install-signal-handler unix::sigcont unix::sigcont-received)) +(unix:install-signal-handler unix::sigcont unix::sigcont-received) (install-handler unix::sigint-received 'sigint-handler) (install-handler unix::sigcont-received '(lambda-closure nil 0 0 (c) From 7f30d2c26acc20eade1035dd15167d5154f54247 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 1 Oct 2021 10:55:06 +0900 Subject: [PATCH 151/387] Define sigcont-handler and compile from toplevel.l --- lisp/l/conditions.l | 7 +------ lisp/l/toplevel.l | 7 +++++++ 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 1c9509373..739c65949 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -204,10 +204,5 @@ (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 - '(lambda-closure nil 0 0 (c) - (when (memq *replevel* (sys::list-all-catchers)) - (reset *replevel*)))) -;; in order to remain in the same stack, reset command must not be compiled -;; TODO: find out why this happens +(install-handler unix::sigcont-received 'sigcont-handler) ) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 0b3ccbd45..423c7533a 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -16,6 +16,7 @@ *prompt* *prompt-string* *history* *try-unix* + sigcont-handler skip-blank read-list-from-line *eustop-hook* *toplevel-hook* @@ -58,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)) From 68c47d62bfaad096f8482484c5852f609b248b1e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 1 Oct 2021 10:58:09 +0900 Subject: [PATCH 152/387] Install signal handlers from within eustop --- lisp/l/conditions.l | 4 ---- lisp/l/toplevel.l | 6 ++++++ 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 739c65949..873f5be2d 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -201,8 +201,4 @@ ;; install handlers (install-handler error #'euserror) (install-handler interruption 'interruption-handler) -(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) ) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 423c7533a..6cad9a780 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -272,10 +272,16 @@ (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) ;; load .eusrc file from the home directory (let ((rcfile (unix:getenv "EUSRC"))) (unless rcfile From 2775c335ed4d53e198f578c2261dc3d41029a5c9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 1 Oct 2021 14:28:56 +0900 Subject: [PATCH 153/387] Fix deprecated error call on GO --- lisp/c/specials.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 8d557cdd2..8d761d165 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -796,7 +796,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) { From 5eef0d7c1d908927cf59765f1ebd66b42fd0cae0 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 1 Oct 2021 16:37:47 +0900 Subject: [PATCH 154/387] Only list valid frames in sys:list-callstack --- lisp/c/sysfunc.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index 447ab5507..288a04789 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -694,12 +694,14 @@ int max; int i; vf=(struct callframe *)(ctx->callfp); // list whole stack for negative max values - for (i=0; vf->vlink && max; vf=vf->vlink, i++, max--) { - vpush(vf->form); + 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); - i++; break;}} return(stacknlist(ctx,i));} From 1cd06bfe0f5af5a54c1be3896873a4310e125d28 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 1 Oct 2021 16:39:10 +0900 Subject: [PATCH 155/387] Unwind callframes to avoid memory faults on TAGBODY --- lisp/c/eus.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 650fc4fd7..7dc824d22 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -308,6 +308,8 @@ register pointer *p; 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 From 567044c49bbb74901905c88451b2d8e35e48239e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 1 Oct 2021 18:12:43 +0900 Subject: [PATCH 156/387] Use signals when there is no active handler in invoke-next-handler --- lisp/l/conditions.l | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 873f5be2d..8d9e828d0 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -106,6 +106,9 @@ (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 From 8865edff9be36a47d7e298496877a27d5db28dbc Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 1 Oct 2021 19:58:13 +0900 Subject: [PATCH 157/387] Avoid segfaults and fix formating in E_NOPACKAGE --- lisp/c/specials.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 8d761d165..caf7bc8d5 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -1136,12 +1136,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; @@ -1163,9 +1162,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; @@ -1250,9 +1251,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)) { From c957fb8ca8bf10f6c99d11eee9533e20fe7da7d5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 7 Sep 2020 12:41:58 +0900 Subject: [PATCH 158/387] Add fmakunbound --- lisp/c/eus_proto.h | 1 + lisp/c/specials.c | 13 +++++++++++++ lisp/l/eusstart.l | 2 +- lisp/l/exports.l | 2 +- 4 files changed, 16 insertions(+), 2 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 4d84dac0b..d869a7e49 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -585,6 +585,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*/); diff --git a/lisp/c/specials.c b/lisp/c/specials.c index caf7bc8d5..4c509c210 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -1073,6 +1073,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; @@ -1361,6 +1373,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/l/eusstart.l b/lisp/l/eusstart.l index 4b9059126..b0c6e11c3 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -45,7 +45,7 @@ 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 ?? diff --git a/lisp/l/exports.l b/lisp/l/exports.l index 6a5b5e6ee..49790d4a9 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -42,7 +42,7 @@ 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 ?? From 2142186d5cfd4dc853ac0bcae96ab1b75761ff9f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 7 Sep 2020 12:42:09 +0900 Subject: [PATCH 159/387] Add fmakunbound compiler entry --- lisp/comp/builtins.l | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/comp/builtins.l b/lisp/comp/builtins.l index fc33008d6..c97e11de7 100644 --- a/lisp/comp/builtins.l +++ b/lisp/comp/builtins.l @@ -239,6 +239,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") From 4a420d444c9ced6561777097d7ef2cf6878c9098 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 7 Sep 2020 12:42:22 +0900 Subject: [PATCH 160/387] Add fmakunbound documentation --- doc/jlatex/jsymbols.tex | 4 ++++ doc/latex/symbols.tex | 5 +++++ 2 files changed, 9 insertions(+) diff --git a/doc/jlatex/jsymbols.tex b/doc/jlatex/jsymbols.tex index 72f87f344..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})))}と等価である。} diff --git a/doc/latex/symbols.tex b/doc/latex/symbols.tex index 98699df6c..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})))}} From 6d4745cb171e2162ba6602081790837c60dd5aee Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 4 Oct 2021 19:15:25 +0900 Subject: [PATCH 161/387] Update assoc documentation --- doc/jlatex/jsequences.tex | 13 +++++++++---- doc/latex/sequences.tex | 10 +++++++++- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index a32d6a711..0b79cba1e 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -319,13 +319,18 @@ \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{rassoc}{item alist}{ +\funcdesc{assoc-if}{pred alist \&key key}{ +{\em alist}の要素の{\bf car}が{\em pred}の条件にあった最初のものを返す。 +合わなければ、NILを返す。} + +\funcdesc{rassoc}{item alist \&key key (test \#'eq) test-not}{ {\bf cdr}が{\em item}に等しい{\em alist}のなかの最初の組を返す。} +\funcdesc{rassoc-if}{pred alist \&key key}{ +{\bf cdr}が{\em pred}にあった{\em alist}のなかの最初の組を返す。} + \funcdesc{pairlis}{l1 l2 \&optional alist}{ {\em l1}と{\em l2}の中の一致する要素を対にしたリストを作る。 もし{\em alist}が与えられたとき、 diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex index bba998b4a..53a804a8d 100644 --- a/doc/latex/sequences.tex +++ b/doc/latex/sequences.tex @@ -320,9 +320,17 @@ \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}{ +searches the association list {\em alist}. The value returned is the +first pair in the {\em alist} such that the {\em car} of the pair satisfies +the {\em pred}, or NIL if there is no such pair in the {\em alist}.} + +\funcdesc{rassoc}{item alist \&key key (test \#'eq) 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 is 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 From d64b0e8fb5ae4721d3f983845118c337480432a3 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 4 Oct 2021 19:15:48 +0900 Subject: [PATCH 162/387] Update doc help files --- doc/jlatex/euslisp.hlp | 263 +++++++++++++++++++++-------------------- doc/latex/euslisp.hlp | 263 +++++++++++++++++++++-------------------- 2 files changed, 266 insertions(+), 260 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index b0684ca1f..72c8ae78b 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -196,47 +196,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" 5873 3 -"defparameter" 3 "jsymbols" 6137 3 -"defconstant" 3 "jsymbols" 6361 3 -"keywordp" 2 "jsymbols" 6889 3 -"constantp" 2 "jsymbols" 7017 3 -"documentation" 2 "jsymbols" 7147 3 -"gensym" 2 "jsymbols" 7266 3 -"gentemp" 2 "jsymbols" 7833 3 -"*lisp-package*" 4 "jsymbols" 11229 2 -"*user-package*" 4 "jsymbols" 11282 2 -"*unix-package*" 4 "jsymbols" 11343 2 -"*system-package*" 4 "jsymbols" 11398 2 -"*keyword-package*" 4 "jsymbols" 11462 2 -"find-symbol" 2 "jsymbols" 11522 3 -"make-symbol" 2 "jsymbols" 11778 3 -"intern" 2 "jsymbols" 11895 3 -"list-all-packages" 2 "jsymbols" 12249 3 -"find-package" 2 "jsymbols" 12351 3 -"make-package" 2 "jsymbols" 12466 3 -"in-package" 2 "jsymbols" 12739 3 -"package-name" 2 "jsymbols" 12878 3 -"package-nicknames" 2 "jsymbols" 12979 3 -"rename-package" 2 "jsymbols" 13058 3 -"package-use-list" 2 "jsymbols" 13335 3 -"packagep" 2 "jsymbols" 13427 3 -"use-package" 2 "jsymbols" 13514 3 -"unuse-package" 2 "jsymbols" 13777 3 -"shadow" 2 "jsymbols" 13890 3 -"export" 2 "jsymbols" 14034 3 -"unexport" 2 "jsymbols" 15261 3 -"import" 2 "jsymbols" 15411 3 -"do-symbols" 3 "jsymbols" 15823 3 -"do-external-symbols" 3 "jsymbols" 16051 3 -"do-all-symbols" 3 "jsymbols" 16250 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 @@ -305,95 +306,97 @@ "member" 2 "jsequences" 13895 3 "assq" 2 "jsequences" 14383 2 "assoc" 2 "jsequences" 14413 3 -"rassoc" 2 "jsequences" 14723 3 -"pairlis" 2 "jsequences" 14839 3 -"acons" 2 "jsequences" 15091 3 -"append" 2 "jsequences" 15237 3 -"nconc" 2 "jsequences" 15439 3 -"subst" 2 "jsequences" 15611 3 -"flatten" 2 "jsequences" 15721 3 -"push" 3 "jsequences" 16016 3 -"pop" 3 "jsequences" 16131 3 -"pushnew" 3 "jsequences" 16283 3 -"adjoin" 2 "jsequences" 16541 3 -"union" 2 "jsequences" 16672 3 -"subsetp" 2 "jsequences" 16794 3 -"intersection" 2 "jsequences" 17055 3 -"set-difference" 2 "jsequences" 17209 3 -"set-exclusive-or" 2 "jsequences" 17413 3 -"list-insert" 2 "jsequences" 17587 3 -"copy-tree" 2 "jsequences" 17899 3 -"mapc" 2 "jsequences" 18175 3 -"mapcar" 2 "jsequences" 18434 3 -"mapcan" 2 "jsequences" 18734 3 -"array-rank-limit" 4 "jsequences" 20917 2 -"array-dimension-limit" 4 "jsequences" 20992 2 -"vectorp" 2 "jsequences" 21199 3 -"vector" 2 "jsequences" 21438 3 -"make-array" 2 "jsequences" 21554 3 -"svref" 2 "jsequences" 21900 3 -"aref" 2 "jsequences" 22059 3 -"vector-push" 2 "jsequences" 22533 3 -"vector-push-extend" 2 "jsequences" 22923 3 -"arrayp" 2 "jsequences" 23131 3 -"array-total-size" 2 "jsequences" 23262 3 -"fill-pointer" 2 "jsequences" 23341 3 -"array-rank" 2 "jsequences" 23467 3 -"array-dimensions" 2 "jsequences" 23541 3 -"array-dimension" 2 "jsequences" 23638 3 -"bit" 2 "jsequences" 23785 3 -"bit-and" 2 "jsequences" 23975 2 -"bit-ior" 2 "jsequences" 24025 2 -"bit-xor" 2 "jsequences" 24075 2 -"bit-eqv" 2 "jsequences" 24125 2 -"bit-nand" 2 "jsequences" 24176 2 -"bit-nor" 2 "jsequences" 24226 2 -"bit-not" 2 "jsequences" 24277 3 -"digit-char-p" 2 "jsequences" 24829 3 -"alpha-char-p" 2 "jsequences" 24942 3 -"upper-case-p" 2 "jsequences" 25113 3 -"lower-case-p" 2 "jsequences" 25229 3 -"alphanumericp" 2 "jsequences" 25346 3 -"char-upcase" 2 "jsequences" 25565 3 -"char-downcase" 2 "jsequences" 25636 3 -"char" 2 "jsequences" 25698 3 -"schar" 2 "jsequences" 25786 3 -"stringp" 2 "jsequences" 25989 3 -"string-upcase" 2 "jsequences" 26119 3 -"string-downcase" 2 "jsequences" 26252 3 -"nstring-upcase" 2 "jsequences" 26384 3 -"nstring-downcase" 2 "jsequences" 26493 3 -"string=" 2 "jsequences" 26609 3 -"string-equal" 2 "jsequences" 26800 3 -"string" 2 "jsequences" 26986 3 -"string<" 2 "jsequences" 27624 2 -"string<=" 2 "jsequences" 27657 2 -"string>" 2 "jsequences" 27689 2 -"string>=" 2 "jsequences" 27722 2 -"string-left-trim" 2 "jsequences" 27761 2 -"string-right-trim" 2 "jsequences" 27800 3 -"string-trim" 2 "jsequences" 28112 3 -"substringp" 2 "jsequences" 28301 3 -"make-foreign-string" 2 "jsequences" 30590 3 -"sxhash" 2 "jsequences" 32625 3 -"make-hash-table" 2 "jsequences" 33288 3 -"gethash" 2 "jsequences" 33391 3 -"remhash" 2 "jsequences" 33804 3 -"maphash" 2 "jsequences" 33922 3 -"hash-table-p" 2 "jsequences" 34028 3 -"hash-table" 0 "jsequences" 34136 4 -":hash-function" 1 "jsequences" 34744 3 -"queue" 0 "jsequences" 35395 4 -":init" 1 "jsequences" 35464 3 -":enqueue" 1 "jsequences" 35518 3 -":dequeue" 1 "jsequences" 35606 3 -":empty?" 1 "jsequences" 35864 3 -":length" 1 "jsequences" 35933 3 -":trim" 1 "jsequences" 35990 3 -":search" 1 "jsequences" 36104 3 -":delete" 1 "jsequences" 36243 3 -":first" 1 "jsequences" 36406 3 -":last" 1 "jsequences" 36514 3 +"assoc-if" 2 "jsequences" 14612 3 +"rassoc" 2 "jsequences" 14786 3 +"rassoc-if" 2 "jsequences" 14936 3 +"pairlis" 2 "jsequences" 15062 3 +"acons" 2 "jsequences" 15314 3 +"append" 2 "jsequences" 15460 3 +"nconc" 2 "jsequences" 15662 3 +"subst" 2 "jsequences" 15834 3 +"flatten" 2 "jsequences" 15944 3 +"push" 3 "jsequences" 16239 3 +"pop" 3 "jsequences" 16354 3 +"pushnew" 3 "jsequences" 16506 3 +"adjoin" 2 "jsequences" 16764 3 +"union" 2 "jsequences" 16895 3 +"subsetp" 2 "jsequences" 17017 3 +"intersection" 2 "jsequences" 17278 3 +"set-difference" 2 "jsequences" 17432 3 +"set-exclusive-or" 2 "jsequences" 17636 3 +"list-insert" 2 "jsequences" 17810 3 +"copy-tree" 2 "jsequences" 18122 3 +"mapc" 2 "jsequences" 18398 3 +"mapcar" 2 "jsequences" 18657 3 +"mapcan" 2 "jsequences" 18957 3 +"array-rank-limit" 4 "jsequences" 21140 2 +"array-dimension-limit" 4 "jsequences" 21215 2 +"vectorp" 2 "jsequences" 21422 3 +"vector" 2 "jsequences" 21661 3 +"make-array" 2 "jsequences" 21777 3 +"svref" 2 "jsequences" 22123 3 +"aref" 2 "jsequences" 22282 3 +"vector-push" 2 "jsequences" 22756 3 +"vector-push-extend" 2 "jsequences" 23146 3 +"arrayp" 2 "jsequences" 23354 3 +"array-total-size" 2 "jsequences" 23485 3 +"fill-pointer" 2 "jsequences" 23564 3 +"array-rank" 2 "jsequences" 23690 3 +"array-dimensions" 2 "jsequences" 23764 3 +"array-dimension" 2 "jsequences" 23861 3 +"bit" 2 "jsequences" 24008 3 +"bit-and" 2 "jsequences" 24198 2 +"bit-ior" 2 "jsequences" 24248 2 +"bit-xor" 2 "jsequences" 24298 2 +"bit-eqv" 2 "jsequences" 24348 2 +"bit-nand" 2 "jsequences" 24399 2 +"bit-nor" 2 "jsequences" 24449 2 +"bit-not" 2 "jsequences" 24500 3 +"digit-char-p" 2 "jsequences" 25052 3 +"alpha-char-p" 2 "jsequences" 25165 3 +"upper-case-p" 2 "jsequences" 25336 3 +"lower-case-p" 2 "jsequences" 25452 3 +"alphanumericp" 2 "jsequences" 25569 3 +"char-upcase" 2 "jsequences" 25788 3 +"char-downcase" 2 "jsequences" 25859 3 +"char" 2 "jsequences" 25921 3 +"schar" 2 "jsequences" 26009 3 +"stringp" 2 "jsequences" 26212 3 +"string-upcase" 2 "jsequences" 26342 3 +"string-downcase" 2 "jsequences" 26475 3 +"nstring-upcase" 2 "jsequences" 26607 3 +"nstring-downcase" 2 "jsequences" 26716 3 +"string=" 2 "jsequences" 26832 3 +"string-equal" 2 "jsequences" 27023 3 +"string" 2 "jsequences" 27209 3 +"string<" 2 "jsequences" 27847 2 +"string<=" 2 "jsequences" 27880 2 +"string>" 2 "jsequences" 27912 2 +"string>=" 2 "jsequences" 27945 2 +"string-left-trim" 2 "jsequences" 27984 2 +"string-right-trim" 2 "jsequences" 28023 3 +"string-trim" 2 "jsequences" 28335 3 +"substringp" 2 "jsequences" 28524 3 +"make-foreign-string" 2 "jsequences" 30813 3 +"sxhash" 2 "jsequences" 32848 3 +"make-hash-table" 2 "jsequences" 33511 3 +"gethash" 2 "jsequences" 33614 3 +"remhash" 2 "jsequences" 34027 3 +"maphash" 2 "jsequences" 34145 3 +"hash-table-p" 2 "jsequences" 34251 3 +"hash-table" 0 "jsequences" 34359 4 +":hash-function" 1 "jsequences" 34967 3 +"queue" 0 "jsequences" 35618 4 +":init" 1 "jsequences" 35687 3 +":enqueue" 1 "jsequences" 35741 3 +":dequeue" 1 "jsequences" 35829 3 +":empty?" 1 "jsequences" 36087 3 +":length" 1 "jsequences" 36156 3 +":trim" 1 "jsequences" 36213 3 +":search" 1 "jsequences" 36327 3 +":delete" 1 "jsequences" 36466 3 +":first" 1 "jsequences" 36629 3 +":last" 1 "jsequences" 36737 3 "streamp" 2 "jio" 591 3 "input-stream-p" 2 "jio" 741 3 "output-stream-p" 2 "jio" 859 3 diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 12a89d1e7..15e03a6d1 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -196,47 +196,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" 5035 3 -"defparameter" 3 "symbols" 5254 3 -"defconstant" 3 "symbols" 5432 3 -"keywordp" 2 "symbols" 5846 3 -"constantp" 2 "symbols" 5941 3 -"documentation" 2 "symbols" 6044 3 -"gensym" 2 "symbols" 6131 3 -"gentemp" 2 "symbols" 6580 3 -"*lisp-package*" 4 "symbols" 9144 2 -"*user-package*" 4 "symbols" 9188 2 -"*unix-package*" 4 "symbols" 9232 2 -"*system-package*" 4 "symbols" 9278 2 -"*keyword-package*" 4 "symbols" 9327 2 -"find-symbol" 2 "symbols" 9370 3 -"make-symbol" 2 "symbols" 9572 3 -"intern" 2 "symbols" 9666 3 -"list-all-packages" 2 "symbols" 9967 3 -"find-package" 2 "symbols" 10040 3 -"make-package" 2 "symbols" 10148 3 -"in-package" 2 "symbols" 10353 3 -"package-name" 2 "symbols" 10489 3 -"package-nicknames" 2 "symbols" 10576 3 -"rename-package" 2 "symbols" 10652 3 -"package-use-list" 2 "symbols" 10886 3 -"packagep" 2 "symbols" 10972 3 -"use-package" 2 "symbols" 11032 3 -"unuse-package" 2 "symbols" 11228 3 -"shadow" 2 "symbols" 11332 3 -"export" 2 "symbols" 11453 3 -"unexport" 2 "symbols" 12348 3 -"import" 2 "symbols" 12487 3 -"do-symbols" 3 "symbols" 12825 3 -"do-external-symbols" 3 "symbols" 13007 3 -"do-all-symbols" 3 "symbols" 13168 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 @@ -305,95 +306,97 @@ "member" 2 "sequences" 11672 3 "assq" 2 "sequences" 11995 2 "assoc" 2 "sequences" 12025 3 -"rassoc" 2 "sequences" 12303 3 -"pairlis" 2 "sequences" 12409 3 -"acons" 2 "sequences" 12638 3 -"append" 2 "sequences" 12761 3 -"nconc" 2 "sequences" 12899 3 -"subst" 2 "sequences" 13016 3 -"flatten" 2 "sequences" 13110 3 -"push" 3 "sequences" 13379 3 -"pop" 3 "sequences" 13464 3 -"pushnew" 3 "sequences" 13598 3 -"adjoin" 2 "sequences" 13833 3 -"union" 2 "sequences" 13941 3 -"subsetp" 2 "sequences" 14054 3 -"intersection" 2 "sequences" 14253 3 -"set-difference" 2 "sequences" 14408 3 -"set-exclusive-or" 2 "sequences" 14588 3 -"list-insert" 2 "sequences" 14757 3 -"copy-tree" 2 "sequences" 15024 3 -"mapc" 2 "sequences" 15263 3 -"mapcar" 2 "sequences" 15490 3 -"mapcan" 2 "sequences" 15756 3 -"array-rank-limit" 4 "sequences" 17411 2 -"array-dimension-limit" 4 "sequences" 17488 2 -"vectorp" 2 "sequences" 17618 3 -"vector" 2 "sequences" 17814 3 -"make-array" 2 "sequences" 17916 3 -"svref" 2 "sequences" 18234 3 -"aref" 2 "sequences" 18356 3 -"vector-push" 2 "sequences" 18643 3 -"vector-push-extend" 2 "sequences" 18940 3 -"arrayp" 2 "sequences" 19112 3 -"array-total-size" 2 "sequences" 19198 3 -"fill-pointer" 2 "sequences" 19285 3 -"array-rank" 2 "sequences" 19417 3 -"array-dimensions" 2 "sequences" 19488 3 -"array-dimension" 2 "sequences" 19561 3 -"bit" 2 "sequences" 19684 3 -"bit-and" 2 "sequences" 19837 2 -"bit-ior" 2 "sequences" 19887 2 -"bit-xor" 2 "sequences" 19937 2 -"bit-eqv" 2 "sequences" 19987 2 -"bit-nand" 2 "sequences" 20038 2 -"bit-nor" 2 "sequences" 20088 2 -"bit-not" 2 "sequences" 20139 3 -"digit-char-p" 2 "sequences" 20630 3 -"alpha-char-p" 2 "sequences" 20719 3 -"upper-case-p" 2 "sequences" 20851 3 -"lower-case-p" 2 "sequences" 20940 3 -"alphanumericp" 2 "sequences" 21031 3 -"char-upcase" 2 "sequences" 21204 3 -"char-downcase" 2 "sequences" 21275 3 -"char" 2 "sequences" 21337 3 -"schar" 2 "sequences" 21420 3 -"stringp" 2 "sequences" 21596 3 -"string-upcase" 2 "sequences" 21705 3 -"string-downcase" 2 "sequences" 21822 3 -"nstring-upcase" 2 "sequences" 21938 3 -"nstring-downcase" 2 "sequences" 22029 3 -"string=" 2 "sequences" 22127 3 -"string-equal" 2 "sequences" 22268 3 -"string" 2 "sequences" 22417 3 -"string<" 2 "sequences" 22917 2 -"string<=" 2 "sequences" 22950 2 -"string>" 2 "sequences" 22982 2 -"string>=" 2 "sequences" 23015 2 -"string-left-trim" 2 "sequences" 23054 2 -"string-right-trim" 2 "sequences" 23093 3 -"string-trim" 2 "sequences" 23371 3 -"substringp" 2 "sequences" 23568 3 -"make-foreign-string" 2 "sequences" 24603 3 -"sxhash" 2 "sequences" 26213 3 -"make-hash-table" 2 "sequences" 26737 3 -"gethash" 2 "sequences" 26845 3 -"remhash" 2 "sequences" 27196 3 -"maphash" 2 "sequences" 27288 3 -"hash-table-p" 2 "sequences" 27385 3 -"hash-table" 0 "sequences" 27463 4 -":hash-function" 1 "sequences" 27951 3 -"queue" 0 "sequences" 28590 4 -":init" 1 "sequences" 28659 3 -":enqueue" 1 "sequences" 28729 3 -":dequeue" 1 "sequences" 28809 3 -":empty?" 1 "sequences" 29023 3 -":length" 1 "sequences" 29082 3 -":trim" 1 "sequences" 29139 3 -":search" 1 "sequences" 29223 3 -":delete" 1 "sequences" 29380 3 -":first" 1 "sequences" 29497 3 -":last" 1 "sequences" 29575 3 +"assoc-if" 2 "sequences" 12305 3 +"rassoc" 2 "sequences" 12561 3 +"rassoc-if" 2 "sequences" 12701 3 +"pairlis" 2 "sequences" 12818 3 +"acons" 2 "sequences" 13047 3 +"append" 2 "sequences" 13170 3 +"nconc" 2 "sequences" 13308 3 +"subst" 2 "sequences" 13425 3 +"flatten" 2 "sequences" 13519 3 +"push" 3 "sequences" 13788 3 +"pop" 3 "sequences" 13873 3 +"pushnew" 3 "sequences" 14007 3 +"adjoin" 2 "sequences" 14242 3 +"union" 2 "sequences" 14350 3 +"subsetp" 2 "sequences" 14463 3 +"intersection" 2 "sequences" 14662 3 +"set-difference" 2 "sequences" 14817 3 +"set-exclusive-or" 2 "sequences" 14997 3 +"list-insert" 2 "sequences" 15166 3 +"copy-tree" 2 "sequences" 15433 3 +"mapc" 2 "sequences" 15672 3 +"mapcar" 2 "sequences" 15899 3 +"mapcan" 2 "sequences" 16165 3 +"array-rank-limit" 4 "sequences" 17820 2 +"array-dimension-limit" 4 "sequences" 17897 2 +"vectorp" 2 "sequences" 18027 3 +"vector" 2 "sequences" 18223 3 +"make-array" 2 "sequences" 18325 3 +"svref" 2 "sequences" 18643 3 +"aref" 2 "sequences" 18765 3 +"vector-push" 2 "sequences" 19052 3 +"vector-push-extend" 2 "sequences" 19349 3 +"arrayp" 2 "sequences" 19521 3 +"array-total-size" 2 "sequences" 19607 3 +"fill-pointer" 2 "sequences" 19694 3 +"array-rank" 2 "sequences" 19826 3 +"array-dimensions" 2 "sequences" 19897 3 +"array-dimension" 2 "sequences" 19970 3 +"bit" 2 "sequences" 20093 3 +"bit-and" 2 "sequences" 20246 2 +"bit-ior" 2 "sequences" 20296 2 +"bit-xor" 2 "sequences" 20346 2 +"bit-eqv" 2 "sequences" 20396 2 +"bit-nand" 2 "sequences" 20447 2 +"bit-nor" 2 "sequences" 20497 2 +"bit-not" 2 "sequences" 20548 3 +"digit-char-p" 2 "sequences" 21039 3 +"alpha-char-p" 2 "sequences" 21128 3 +"upper-case-p" 2 "sequences" 21260 3 +"lower-case-p" 2 "sequences" 21349 3 +"alphanumericp" 2 "sequences" 21440 3 +"char-upcase" 2 "sequences" 21613 3 +"char-downcase" 2 "sequences" 21684 3 +"char" 2 "sequences" 21746 3 +"schar" 2 "sequences" 21829 3 +"stringp" 2 "sequences" 22005 3 +"string-upcase" 2 "sequences" 22114 3 +"string-downcase" 2 "sequences" 22231 3 +"nstring-upcase" 2 "sequences" 22347 3 +"nstring-downcase" 2 "sequences" 22438 3 +"string=" 2 "sequences" 22536 3 +"string-equal" 2 "sequences" 22677 3 +"string" 2 "sequences" 22826 3 +"string<" 2 "sequences" 23326 2 +"string<=" 2 "sequences" 23359 2 +"string>" 2 "sequences" 23391 2 +"string>=" 2 "sequences" 23424 2 +"string-left-trim" 2 "sequences" 23463 2 +"string-right-trim" 2 "sequences" 23502 3 +"string-trim" 2 "sequences" 23780 3 +"substringp" 2 "sequences" 23977 3 +"make-foreign-string" 2 "sequences" 25012 3 +"sxhash" 2 "sequences" 26622 3 +"make-hash-table" 2 "sequences" 27146 3 +"gethash" 2 "sequences" 27254 3 +"remhash" 2 "sequences" 27605 3 +"maphash" 2 "sequences" 27697 3 +"hash-table-p" 2 "sequences" 27794 3 +"hash-table" 0 "sequences" 27872 4 +":hash-function" 1 "sequences" 28360 3 +"queue" 0 "sequences" 28999 4 +":init" 1 "sequences" 29068 3 +":enqueue" 1 "sequences" 29138 3 +":dequeue" 1 "sequences" 29218 3 +":empty?" 1 "sequences" 29432 3 +":length" 1 "sequences" 29491 3 +":trim" 1 "sequences" 29548 3 +":search" 1 "sequences" 29632 3 +":delete" 1 "sequences" 29789 3 +":first" 1 "sequences" 29906 3 +":last" 1 "sequences" 29984 3 "streamp" 2 "io" 483 3 "input-stream-p" 2 "io" 606 3 "output-stream-p" 2 "io" 698 3 From d3a21db46f6b2138a62864de28d2ab53ead2fc8b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 19 Nov 2019 16:04:08 +0900 Subject: [PATCH 163/387] Add sys:list-all-blocks --- lisp/c/sysfunc.c | 15 +++++++++++++++ lisp/l/eusstart.l | 2 +- lisp/l/exports.l | 2 +- 3 files changed, 17 insertions(+), 2 deletions(-) diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index 288a04789..fcdeba632 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -714,6 +714,20 @@ pointer *argv; 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; +{ pointer blocks=NIL; + 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 LISTALLCATCHERS(ctx,n,argv) register context *ctx; int n; @@ -827,6 +841,7 @@ pointer mod; /* 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-CATCHERS",mod,LISTALLCATCHERS,NULL); defun(ctx,"LIST-ALL-BINDINGS",mod,LISTBINDINGS,NULL); defun(ctx,"LIST-ALL-SPECIAL-BINDINGS",mod,LISTSPECIALBINDINGS,NULL); diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index b0c6e11c3..a9326e812 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -176,7 +176,7 @@ 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-REFERENCES LIST-ALL-BLOCKS LIST-ALL-CATCHERS LIST-ALL-BINDINGS LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) (export '*threads*) diff --git a/lisp/l/exports.l b/lisp/l/exports.l index 49790d4a9..114cbe841 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -170,7 +170,7 @@ 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-REFERENCES LIST-ALL-BLOCKS LIST-ALL-CATCHERS LIST-ALL-BINDINGS LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES)) From 36d3147ab262bb344672e0cb3c90346a51ee300f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 4 Oct 2021 19:35:29 +0900 Subject: [PATCH 164/387] Add sys:list-all-blocks documentation --- doc/jlatex/euslisp.hlp | 19 ++++++++++--------- doc/jlatex/jevaluation.tex | 3 +++ doc/latex/euslisp.hlp | 19 ++++++++++--------- doc/latex/evaluation.tex | 3 +++ 4 files changed, 26 insertions(+), 18 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 72c8ae78b..820b04674 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -546,15 +546,16 @@ "lisp::print-callstack" 2 "jevaluation" 32779 3 "sys:list-callstack" 2 "jevaluation" 33020 3 "sys:list-all-catchers" 2 "jevaluation" 33227 3 -"sys:list-all-instances" 2 "jevaluation" 33308 3 -"sys:list-all-bindings" 2 "jevaluation" 33697 3 -"sys:list-all-special-bindings" 2 "jevaluation" 33847 3 -"dump-object" 2 "jevaluation" 34648 2 -"dump-structure" 2 "jevaluation" 34696 3 -"dump-loadable-structure" 2 "jevaluation" 34851 3 -"sys:save" 2 "jevaluation" 35913 3 -"lisp-implementation-type" 2 "jevaluation" 39317 3 -"lisp-implementation-version" 2 "jevaluation" 39389 3 +"sys:list-all-blocks" 2 "jevaluation" 33305 3 +"sys:list-all-instances" 2 "jevaluation" 33386 3 +"sys:list-all-bindings" 2 "jevaluation" 33775 3 +"sys:list-all-special-bindings" 2 "jevaluation" 33925 3 +"dump-object" 2 "jevaluation" 34726 2 +"dump-structure" 2 "jevaluation" 34774 3 +"dump-loadable-structure" 2 "jevaluation" 34929 3 +"sys:save" 2 "jevaluation" 35991 3 +"lisp-implementation-type" 2 "jevaluation" 39395 3 +"lisp-implementation-version" 2 "jevaluation" 39467 3 "sys:gc" 2 "jsysfunc" 6326 3 "sys:*gc-hook*" 5 "jsysfunc" 6522 2 "sys:gctime" 2 "jsysfunc" 6638 3 diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index d7a6eaf01..311a26f13 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -630,6 +630,9 @@ \subsection{デバッグ補助} \funcdesc{sys:list-all-catchers}{}{ すべての{\bf catch}タグを返す。} +\funcdesc{sys:list-all-blocks}{}{ +すべての{\bf block}タグを返す。} + \funcdesc{sys:list-all-instances}{aclass \&optional scan-sub}{ すべてのヒープの中から{\em aclass}で指定されるインスタンスをすべて 探し、集める。 diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 15e03a6d1..1b48e5171 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -551,15 +551,16 @@ "lisp::print-callstack" 2 "evaluation" 29005 3 "sys:list-callstack" 2 "evaluation" 29259 3 "sys:list-all-catchers" 2 "evaluation" 29453 3 -"sys:list-all-instances" 2 "evaluation" 29532 3 -"sys:list-all-bindings" 2 "evaluation" 29829 3 -"sys:list-all-special-bindings" 2 "evaluation" 29950 3 -"dump-object" 2 "evaluation" 30556 2 -"dump-structure" 2 "evaluation" 30604 3 -"dump-loadable-structure" 2 "evaluation" 30735 3 -"sys:save" 2 "evaluation" 31607 3 -"lisp-implementation-type" 2 "evaluation" 34317 3 -"lisp-implementation-version" 2 "evaluation" 34386 3 +"sys:list-all-blocks" 2 "evaluation" 29529 3 +"sys:list-all-instances" 2 "evaluation" 29608 3 +"sys:list-all-bindings" 2 "evaluation" 29905 3 +"sys:list-all-special-bindings" 2 "evaluation" 30026 3 +"dump-object" 2 "evaluation" 30632 2 +"dump-structure" 2 "evaluation" 30680 3 +"dump-loadable-structure" 2 "evaluation" 30811 3 +"sys:save" 2 "evaluation" 31683 3 +"lisp-implementation-type" 2 "evaluation" 34393 3 +"lisp-implementation-version" 2 "evaluation" 34462 3 "sys:gc" 2 "sysfunc" 4802 3 "sys:*gc-hook*" 5 "sysfunc" 4933 2 "sys:gctime" 2 "sysfunc" 5021 3 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index a0588406d..3290feced 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -688,6 +688,9 @@ \subsection{Debugging Aid} \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-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 From a193cc1c8dd3112025bf0b047954fcf1ee8195fa Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 5 Oct 2021 16:54:14 +0900 Subject: [PATCH 165/387] Export sys:list-callstack --- lisp/l/exports.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/l/exports.l b/lisp/l/exports.l index 114cbe841..d8daa9087 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -171,7 +171,7 @@ OBJECT-SIZE MEMORY-REPORT CLEAR-MEMORY-REPORT ROOM LIST-ALL-CHUNKS LIST-ALL-INSTANCES ADDRESS PEEK POKE LIST-ALL-REFERENCES LIST-ALL-BLOCKS LIST-ALL-CATCHERS LIST-ALL-BINDINGS - LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES)) + LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) #| From 1b5b09a5a5b711cef117090ecb9fe827d6278ab2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 5 Oct 2021 16:56:52 +0900 Subject: [PATCH 166/387] Allow returns and tagbody on dolist, dotimes, do-symbols and do-external-symbols (#241) --- lisp/l/common.l | 130 ++++++++++++++++++++++++++++-------------------- 1 file changed, 76 insertions(+), 54 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index c58e24328..72e2a9ae3 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -149,67 +149,89 @@ (send ',sym :constant ,val ,doc) ',sym)) - (defmacro dotimes (vars &rest forms) - (let ((endvar (gensym "DOTIMES"))) - `(let ((,(car vars) 0) (,endvar ,(cadr vars))) - (declare (integer ,(car vars) ,endvar)) - (while (< ,(car vars) ,endvar) - ,@forms - (setq ,(car vars) (1+ ,(car vars)))) - ,(caddr vars)))) + (let ((endvar (gensym "DOTIMES")) + (loop-tag (gensym "DOTIMES"))) + `(block nil + (let ((,(car vars) 0) + (,endvar ,(cadr vars))) + (declare (integer ,(car vars) ,endvar)) + (tagbody ,loop-tag + (if (> ,endvar ,(car vars)) + (tagbody + ,@forms + (setq ,(car vars) (1+ ,(car vars))) + (go ,loop-tag)))) + ,(caddr vars))))) (defmacro dolist (vars &rest forms) - (let ((lists (gensym "DOLIST")) (decl (car forms))) - (if (and (consp decl) (eq (car decl) 'declare)) - (setq forms (cdr forms)) - (setq decl nil)) - `(let ((,(car vars) nil) (,lists ,(cadr vars))) - ,decl - (while ,lists - (setq ,(car vars) (pop ,lists)) - ,@forms) - ,(caddr vars)))) + (let ((lists (gensym "DOLIST")) + (loop-tag (gensym "DOLIST")) + (decl (car forms))) + (if (and (consp decl) (eq (car decl) 'declare)) + (setq forms (cdr forms)) + (setq decl nil)) + `(block nil + (let ((,(car vars) nil) + (,lists ,(cadr vars))) + ,decl + (tagbody ,loop-tag + (if (endp ,lists) + (setq ,(car vars) nil) + (progn + (setq ,(car vars) (pop ,lists)) + (tagbody + ,@forms + (go ,loop-tag))))) + ,(caddr vars))))) (defmacro do-symbols (vars &rest forms) - (let* ((symbols (gensym "DOSYM")) - (v (car vars)) - (pkg (if (cadr vars) (cadr vars) '*package*)) - (pkgv (gensym)) - (i (gensym)) - (size (gensym)) - (svec (gensym)) - ) - `(let* ((,v nil) - (,pkgv (find-package ,pkg)) - (,i 0) - (,svec (,pkgv . intsymvector)) - (,size (length ,svec))) - (while (< ,i ,size) - (setq ,v (elt ,svec ,i)) - (inc ,i) - (when (symbolp ,v) . ,forms)) - ,(caddr vars)))) + (let* ((symbols (gensym "DOSYM")) + (v (car vars)) + (pkg (if (cadr vars) (cadr vars) '*package*)) + (pkgv (gensym)) + (i (gensym)) + (size (gensym)) + (svec (gensym)) + (loop-tag (gensym "DO-SYMBOLS"))) + `(block nil + (let* ((,v nil) + (,pkgv (find-package ,pkg)) + (,i 0) + (,svec (,pkgv . intsymvector)) + (,size (length ,svec))) + (tagbody ,loop-tag + (if (< ,i ,size) + (tagbody + (setq ,v (elt ,svec ,i)) + (inc ,i) + (when (symbolp ,v) . ,forms) + (go ,loop-tag)))) + ,(caddr vars))))) (defmacro do-external-symbols (vars &rest forms) - (let* ((symbols (gensym "DOEXTSYM")) - (v (car vars)) - (pkg (if (cadr vars) (cadr vars) '*package*)) - (pkgv (gensym)) - (i (gensym)) - (size (gensym)) - (svec (gensym)) - ) - `(let* ((,v nil) - (,pkgv (find-package ,pkg)) - (,i 0) - (,svec (,pkgv . symvector)) - (,size (length ,svec))) - (while (< ,i ,size) - (setq ,v (elt ,svec ,i)) - (inc ,i) - (when (symbolp ,v) . ,forms)) - ,(caddr vars)))) + (let* ((symbols (gensym "DOEXTSYM")) + (v (car vars)) + (pkg (if (cadr vars) (cadr vars) '*package*)) + (pkgv (gensym)) + (i (gensym)) + (size (gensym)) + (svec (gensym)) + (loop-tag (gensym "DO-EXTERNAL-SYMBOLS"))) + `(block nil + (let* ((,v nil) + (,pkgv (find-package ,pkg)) + (,i 0) + (,svec (,pkgv . symvector)) + (,size (length ,svec))) + (tagbody ,loop-tag + (if (< ,i ,size) + (tagbody + (setq ,v (elt ,svec ,i)) + (inc ,i) + (when (symbolp ,v) . ,forms) + (go ,loop-tag)))) + ,(caddr vars))))) (defmacro do-all-symbols (var &rest forms) (let ((apackage (gensym "DOALLSYM"))) From d1a5382e8d5df12b8455cf4665097034798cc54f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 2 Apr 2019 22:55:38 +0900 Subject: [PATCH 167/387] Type check dimension in make-array --- lisp/l/array.l | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/l/array.l b/lisp/l/array.l index de7c8b15b..0a3d1b7f7 100644 --- a/lisp/l/array.l +++ b/lisp/l/array.l @@ -99,7 +99,7 @@ (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)) @@ -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 "integer or list expected"))) (when initial-element (fill entity initial-element)) (when initial-contents (fill-initial-contents entity 0 dim initial-contents)) From fbdb5a5b04220581f03139098200594bd7d57405 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 12 Oct 2021 19:56:02 +0900 Subject: [PATCH 168/387] Remove sys:*gc-hook* and add safer sys:*gc-debug* --- lisp/c/eus.c | 7 +++---- lisp/c/eus.h | 5 ++--- lisp/c/memory.c | 13 ++++++++++--- lisp/l/eusstart.l | 2 +- 4 files changed, 16 insertions(+), 11 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 7dc824d22..5326030bf 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -124,9 +124,8 @@ pointer SELF; pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; -pointer TOPLEVEL,QEVALHOOK,FATALERROR; -pointer QGCHOOK, QEXITHOOK; -pointer QUNBOUND,QDEBUG; +pointer TOPLEVEL,QEVALHOOK,QEXITHOOK,FATALERROR; +pointer QUNBOUND,QDEBUG,QGCDEBUG; pointer QTHREADS; /* system:*threads* */ pointer QPARAGC; pointer QVERSION; @@ -712,7 +711,7 @@ static void initsymbols() QLDENT=defvar(ctx,"*LOAD-ENTRIES*", NIL, syspkg); QTHREADS=defvar(ctx, "*THREADS*", NIL, syspkg); QPARAGC=defvar(ctx, "*PARALLEL-GC*", NIL, syspkg); - QGCHOOK=defvar(ctx,"*GC-HOOK*",NIL,syspkg); + QGCDEBUG=defvar(ctx,"*GC-DEBUG*",NIL,syspkg); QEXITHOOK=defvar(ctx,"*EXIT-HOOK*",NIL,syspkg); FATALERROR=defvar(ctx,"*EXIT-ON-FATAL-ERROR*",NIL,lisppkg); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 2632032df..5b00516b9 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -662,9 +662,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; -extern pointer QGCHOOK, QEXITHOOK; -extern pointer QUNBOUND,QDEBUG; +extern pointer TOPLEVEL,QEVALHOOK,QEXITHOOK; +extern pointer QUNBOUND,QDEBUG,QGCDEBUG; extern pointer QTHREADS; extern pointer QEQ,QEQUAL,QNOT; extern pointer QAND, QOR, QNOT; diff --git a/lisp/c/memory.c b/lisp/c/memory.c index 183e41b5d..54c14b251 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -784,7 +784,7 @@ void gc() int i, r; context *ctx=euscontexts[thr_self()]; - if (debug) fprintf(stderr,"\n;; gc: thread=%d ",thr_self()); + if (debug || speval(QGCDEBUG)!=NIL) fprintf(stderr,"\n;; gc: thread=%d ",thr_self()); // breakck; gccount++; times(&tbuf1); @@ -815,17 +815,24 @@ void gc() mutex_unlock(&mark_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)); } +/* 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. + 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; } #endif diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index a9326e812..4d77bb899 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -172,7 +172,7 @@ (export '( GC GCTIME RGCCOUNT RGCTIME RGCALLOCATED *GC-MERGE* *GC-MARGIN* - *GC-HOOK* *EXIT-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 From 978021606e7032ae7cf9cf1f445c6108dd98077f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 13 Oct 2021 11:16:19 +0900 Subject: [PATCH 169/387] Add sys:list-all-tags --- lisp/c/sysfunc.c | 21 +++++++++++++++++++-- lisp/l/eusstart.l | 4 ++-- lisp/l/exports.l | 4 ++-- 3 files changed, 23 insertions(+), 6 deletions(-) diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index fcdeba632..f6fca68b3 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -718,8 +718,7 @@ pointer LISTALLBLOCKS(ctx,n,argv) register context *ctx; int n; pointer *argv; -{ pointer blocks=NIL; - struct blockframe *bfp=ctx->blkfp; +{ struct blockframe *bfp=ctx->blkfp; int i=0; while (bfp) { if (bfp->kind==BLOCKFRAME) { @@ -728,6 +727,23 @@ pointer *argv; 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; @@ -842,6 +858,7 @@ pointer mod; 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-SPECIAL-BINDINGS",mod,LISTSPECIALBINDINGS,NULL); diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index 4d77bb899..aaf023b79 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -176,8 +176,8 @@ 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-BLOCKS LIST-ALL-CATCHERS LIST-ALL-BINDINGS - LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) + LIST-ALL-REFERENCES LIST-ALL-BLOCKS LIST-ALL-TAGS LIST-ALL-CATCHERS + LIST-ALL-BINDINGS LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) (export '*threads*) diff --git a/lisp/l/exports.l b/lisp/l/exports.l index d8daa9087..4576e7a47 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -170,8 +170,8 @@ 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-BLOCKS LIST-ALL-CATCHERS LIST-ALL-BINDINGS - LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) + LIST-ALL-REFERENCES LIST-ALL-BLOCKS LIST-ALL-TAGS LIST-ALL-CATCHERS + LIST-ALL-BINDINGS LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) #| From cca1de3d80d6200ac5b0a92e1cbcbf82e0e05c73 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 13 Oct 2021 11:20:19 +0900 Subject: [PATCH 170/387] Update sys:*gc-debug* and sys:list-all-tags documentation --- doc/jlatex/jevaluation.tex | 3 +++ doc/jlatex/jsysfunc.tex | 11 ++++++----- doc/latex/evaluation.tex | 3 +++ doc/latex/sysfunc.tex | 13 +++++-------- 4 files changed, 17 insertions(+), 13 deletions(-) diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 311a26f13..31a569f9b 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -633,6 +633,9 @@ \subsection{デバッグ補助} \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}で指定されるインスタンスをすべて 探し、集める。 diff --git a/doc/jlatex/jsysfunc.tex b/doc/jlatex/jsysfunc.tex index c3bf44b48..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によりマージされずに残すヒープメモリの比率を示す。 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index 3290feced..eb40fcb48 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -691,6 +691,9 @@ \subsection{Debugging Aid} \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 diff --git a/doc/latex/sysfunc.tex b/doc/latex/sysfunc.tex index 7f22267ba..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 From 6c604c9a139095766c5e5188a7d9341e1ea01595 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 13 Oct 2021 11:20:46 +0900 Subject: [PATCH 171/387] Update help files --- doc/jlatex/euslisp.hlp | 299 ++++++++++++++++++++-------------------- doc/latex/euslisp.hlp | 303 +++++++++++++++++++++-------------------- 2 files changed, 302 insertions(+), 300 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 820b04674..b8d0536c0 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -547,156 +547,157 @@ "sys:list-callstack" 2 "jevaluation" 33020 3 "sys:list-all-catchers" 2 "jevaluation" 33227 3 "sys:list-all-blocks" 2 "jevaluation" 33305 3 -"sys:list-all-instances" 2 "jevaluation" 33386 3 -"sys:list-all-bindings" 2 "jevaluation" 33775 3 -"sys:list-all-special-bindings" 2 "jevaluation" 33925 3 -"dump-object" 2 "jevaluation" 34726 2 -"dump-structure" 2 "jevaluation" 34774 3 -"dump-loadable-structure" 2 "jevaluation" 34929 3 -"sys:save" 2 "jevaluation" 35991 3 -"lisp-implementation-type" 2 "jevaluation" 39395 3 -"lisp-implementation-version" 2 "jevaluation" 39467 3 +"sys:list-all-tags" 2 "jevaluation" 33381 3 +"sys:list-all-instances" 2 "jevaluation" 33464 3 +"sys:list-all-bindings" 2 "jevaluation" 33853 3 +"sys:list-all-special-bindings" 2 "jevaluation" 34003 3 +"dump-object" 2 "jevaluation" 34804 2 +"dump-structure" 2 "jevaluation" 34852 3 +"dump-loadable-structure" 2 "jevaluation" 35007 3 +"sys:save" 2 "jevaluation" 36069 3 +"lisp-implementation-type" 2 "jevaluation" 39473 3 +"lisp-implementation-version" 2 "jevaluation" 39545 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" 25639 3 -"unix:pause" 2 "jsysfunc" 25749 3 -"unix:alarm" 2 "jsysfunc" 25861 3 -"unix:ualarm" 2 "jsysfunc" 26192 3 -"unix:getitimer" 2 "jsysfunc" 26480 3 -"unix:setitimer" 2 "jsysfunc" 26724 3 -"unix:select" 2 "jsysfunc" 27137 3 -"unix:select-read-fd" 2 "jsysfunc" 28261 3 -"unix:thr-self" 2 "jsysfunc" 28974 3 -"unix:thr-getprio" 2 "jsysfunc" 29072 3 -"unix:thr-setprio" 2 "jsysfunc" 29179 3 -"unix:thr-getconcurrency" 2 "jsysfunc" 29679 3 -"unix:thr-setconcurrency" 2 "jsysfunc" 29810 3 -"unix:thr-create" 2 "jsysfunc" 30575 3 -"unix:malloc" 2 "jsysfunc" 31045 3 -"unix:free" 2 "jsysfunc" 31140 3 -"unix:valloc" 2 "jsysfunc" 31249 2 -"unix:mmap" 2 "jsysfunc" 31279 2 -"unix:munmap" 2 "jsysfunc" 31349 2 -"unix:vadvise" 2 "jsysfunc" 31389 2 -"unix:tiocgetp" 2 "jsysfunc" 32371 3 -"unix:tiocsetp" 2 "jsysfunc" 32455 3 -"unix:tiocsetn" 2 "jsysfunc" 32533 2 -"unix:tiocgetd" 2 "jsysfunc" 32586 2 -"unix:tiocflush" 2 "jsysfunc" 32641 3 -"unix:tiocgpgrp" 2 "jsysfunc" 32718 3 -"unix:tiocspgrp" 2 "jsysfunc" 32805 3 -"unix:tiocoutq" 2 "jsysfunc" 32896 2 -"unix:fionread" 2 "jsysfunc" 32937 2 -"unix:tiocsetc" 2 "jsysfunc" 32978 2 -"unix:tioclbis" 2 "jsysfunc" 33015 2 -"unix:tioclbic" 2 "jsysfunc" 33052 2 -"unix:tioclset" 2 "jsysfunc" 33089 2 -"unix:tioclget" 2 "jsysfunc" 33126 2 -"unix:tcseta" 2 "jsysfunc" 33162 3 -"unix:tcsets" 2 "jsysfunc" 33261 3 -"unix:tcsetsw" 2 "jsysfunc" 33352 3 -"unix:tcsetsf" 2 "jsysfunc" 33506 3 -"unix:tiocsetc" 2 "jsysfunc" 33722 2 -"unix:tcsetaf" 2 "jsysfunc" 33761 2 -"unix:tcsetaw" 2 "jsysfunc" 33800 2 -"unix:tcgeta" 2 "jsysfunc" 33838 2 -"unix:tcgets" 2 "jsysfunc" 33876 2 -"unix:tcgetattr" 2 "jsysfunc" 33917 2 -"unix:tcsetattr" 2 "jsysfunc" 33958 2 -"dbm-open" 2 "jsysfunc" 34618 3 -"dbm-store" 2 "jsysfunc" 35729 3 -"dbm-fetch" 2 "jsysfunc" 36043 3 -"cd" 2 "jsysfunc" 37822 3 -"ez" 2 "jsysfunc" 37924 3 -"piped-fork" 2 "jsysfunc" 38060 3 -"rusage" 2 "jsysfunc" 38211 3 -"load-foreign" 3 "jsysfunc" 46015 3 -"defforeign" 3 "jsysfunc" 49246 3 -"defun-c-callable" 3 "jsysfunc" 51547 3 -"pod-address" 2 "jsysfunc" 52822 3 -"array-entity" 3 "jsysfunc" 53149 3 -"float2double" 2 "jsysfunc" 53453 3 -"double2float" 2 "jsysfunc" 53691 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 diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 1b48e5171..531a3ec09 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -552,157 +552,158 @@ "sys:list-callstack" 2 "evaluation" 29259 3 "sys:list-all-catchers" 2 "evaluation" 29453 3 "sys:list-all-blocks" 2 "evaluation" 29529 3 -"sys:list-all-instances" 2 "evaluation" 29608 3 -"sys:list-all-bindings" 2 "evaluation" 29905 3 -"sys:list-all-special-bindings" 2 "evaluation" 30026 3 -"dump-object" 2 "evaluation" 30632 2 -"dump-structure" 2 "evaluation" 30680 3 -"dump-loadable-structure" 2 "evaluation" 30811 3 -"sys:save" 2 "evaluation" 31683 3 -"lisp-implementation-type" 2 "evaluation" 34393 3 -"lisp-implementation-version" 2 "evaluation" 34462 3 -"sys:gc" 2 "sysfunc" 4802 3 -"sys:*gc-hook*" 5 "sysfunc" 4933 2 -"sys:gctime" 2 "sysfunc" 5021 3 -"sys:alloc" 2 "sysfunc" 5224 3 -"sys:newstack" 2 "sysfunc" 5366 3 -"sys:*gc-merge*" 5 "sysfunc" 5479 2 -"sys:*gc-margin*" 5 "sysfunc" 5927 2 -"sys:reclaim" 2 "sysfunc" 6229 3 -"sys:reclaim-tree" 2 "sysfunc" 6386 3 -"sys::bktrace" 2 "sysfunc" 6492 3 -"sys:memory-report" 2 "sysfunc" 6601 3 -"sys:room" 2 "sysfunc" 6726 3 -"sys:address" 2 "sysfunc" 6825 3 -"sys:peek" 2 "sysfunc" 6994 3 -"sys:poke" 2 "sysfunc" 7987 3 -"sys:list-all-chunks" 2 "sysfunc" 8362 3 -"sys:object-size" 2 "sysfunc" 8472 3 -"unix:ptimes" 2 "sysfunc" 9583 3 -"unix:runtime" 2 "sysfunc" 9848 3 -"unix:localtime" 2 "sysfunc" 9955 3 -"unix:asctime" 2 "sysfunc" 10512 3 -"unix:getpid" 2 "sysfunc" 10785 3 -"unix:getppid" 2 "sysfunc" 10870 3 -"unix:getpgrp" 2 "sysfunc" 10945 3 -"unix:setpgrp" 2 "sysfunc" 11004 3 -"unix:getuid" 2 "sysfunc" 11061 3 -"unix:geteuid" 2 "sysfunc" 11120 3 -"unix:getgid" 2 "sysfunc" 11195 3 -"unix:getegid" 2 "sysfunc" 11262 3 -"unix:setuid" 2 "sysfunc" 11338 3 -"unix:setgid" 2 "sysfunc" 11413 3 -"unix:fork" 2 "sysfunc" 11492 3 -"unix:vfork" 2 "sysfunc" 11751 3 -"unix:exec" 2 "sysfunc" 11889 3 -"unix:wait" 2 "sysfunc" 11968 3 -"unix::exit" 2 "sysfunc" 12044 3 -"sys:*exit-hook*" 5 "sysfunc" 12180 2 -"unix:getpriority" 2 "sysfunc" 12280 3 -"unix:setpriority" 2 "sysfunc" 12452 3 -"unix:getrusage" 2 "sysfunc" 13051 3 -"unix:system" 2 "sysfunc" 14145 3 -"unix:getenv" 2 "sysfunc" 14281 3 -"unix:putenv" 2 "sysfunc" 14375 3 -"unix:sleep" 2 "sysfunc" 14542 3 -"unix:usleep" 2 "sysfunc" 14633 3 -"unix:uread" 2 "sysfunc" 14896 3 -"unix:write" 2 "sysfunc" 15353 3 -"unix:fcntl" 2 "sysfunc" 15534 2 -"unix:ioctl" 2 "sysfunc" 15581 2 -"unix:ioctl_" 2 "sysfunc" 15628 2 -"unix:ioctl_r" 2 "sysfunc" 15679 2 -"unix:ioctl_w" 2 "sysfunc" 15753 2 -"unix:ioctl_wr" 2 "sysfunc" 15828 2 -"unix:uclose" 2 "sysfunc" 15901 3 -"unix:dup" 2 "sysfunc" 15982 3 -"unix:pipe" 2 "sysfunc" 16063 3 -"unix:lseek" 2 "sysfunc" 16146 3 -"unix:link" 2 "sysfunc" 16293 3 -"unix:unlink" 2 "sysfunc" 16351 3 -"unix:mknod" 2 "sysfunc" 16489 3 -"unix:mkdir" 2 "sysfunc" 16607 3 -"unix:access" 2 "sysfunc" 16730 3 -"unix:stat" 2 "sysfunc" 16805 3 -"unix:chdir" 2 "sysfunc" 17364 3 -"unix:getwd" 2 "sysfunc" 17448 3 -"unix:chmod" 2 "sysfunc" 17507 3 -"unix:chown" 2 "sysfunc" 17595 3 -"unix:isatty" 2 "sysfunc" 17677 3 -"unix:msgget" 2 "sysfunc" 17817 3 -"unix:msgsnd" 2 "sysfunc" 17922 2 -"unix:msgrcv" 2 "sysfunc" 17982 2 -"unix:socket" 2 "sysfunc" 18037 3 -"unix:bind" 2 "sysfunc" 18302 3 -"unix:connect" 2 "sysfunc" 18460 3 -"unix:listen" 2 "sysfunc" 18564 3 -"unix:accept" 2 "sysfunc" 18763 3 -"unix:recvfrom" 2 "sysfunc" 18928 3 -"unix:sendto" 2 "sysfunc" 19323 3 -"unix:getservbyname" 2 "sysfunc" 19689 3 -"unix:gethostbyname" 2 "sysfunc" 19848 3 -"unix:syserrlist" 2 "sysfunc" 19991 3 -"unix:signal" 2 "sysfunc" 20169 3 -"unix:kill" 2 "sysfunc" 20664 3 -"unix:pause" 2 "sysfunc" 20749 3 -"unix:alarm" 2 "sysfunc" 20835 3 -"unix:ualarm" 2 "sysfunc" 21131 3 -"unix:getitimer" 2 "sysfunc" 21370 3 -"unix:setitimer" 2 "sysfunc" 21911 3 -"unix:select" 2 "sysfunc" 22257 3 -"unix:select-read-fd" 2 "sysfunc" 23099 3 -"unix:thr-self" 2 "sysfunc" 23633 3 -"unix:thr-getprio" 2 "sysfunc" 23724 3 -"unix:thr-setprio" 2 "sysfunc" 23827 3 -"unix:thr-getconcurrency" 2 "sysfunc" 24222 3 -"unix:thr-setconcurrency" 2 "sysfunc" 24368 3 -"unix:thr-create" 2 "sysfunc" 24957 3 -"unix:malloc" 2 "sysfunc" 25326 3 -"unix:free" 2 "sysfunc" 25406 3 -"unix:valloc" 2 "sysfunc" 25500 2 -"unix:mmap" 2 "sysfunc" 25530 2 -"unix:munmap" 2 "sysfunc" 25600 2 -"unix:vadvise" 2 "sysfunc" 25640 2 -"unix:tiocgetp" 2 "sysfunc" 26359 3 -"unix:tiocsetp" 2 "sysfunc" 26432 3 -"unix:tiocsetn" 2 "sysfunc" 26493 2 -"unix:tiocgetd" 2 "sysfunc" 26546 2 -"unix:tiocflush" 2 "sysfunc" 26601 3 -"unix:tiocgpgrp" 2 "sysfunc" 26661 3 -"unix:tiocspgrp" 2 "sysfunc" 26729 3 -"unix:tiocoutq" 2 "sysfunc" 26795 2 -"unix:fionread" 2 "sysfunc" 26836 2 -"unix:tiocsetc" 2 "sysfunc" 26877 2 -"unix:tioclbis" 2 "sysfunc" 26914 2 -"unix:tioclbic" 2 "sysfunc" 26951 2 -"unix:tioclset" 2 "sysfunc" 26988 2 -"unix:tioclget" 2 "sysfunc" 27025 2 -"unix:tcseta" 2 "sysfunc" 27061 3 -"unix:tcsets" 2 "sysfunc" 27140 3 -"unix:tcsetsw" 2 "sysfunc" 27208 3 -"unix:tcsetsf" 2 "sysfunc" 27337 3 -"unix:tiocsetc" 2 "sysfunc" 27516 2 -"unix:tcsetaf" 2 "sysfunc" 27555 2 -"unix:tcsetaw" 2 "sysfunc" 27594 2 -"unix:tcgeta" 2 "sysfunc" 27632 2 -"unix:tcgets" 2 "sysfunc" 27670 2 -"unix:tcgetattr" 2 "sysfunc" 27711 2 -"unix:tcsetattr" 2 "sysfunc" 27752 2 -"dbm-open" 2 "sysfunc" 28257 3 -"dbm-store" 2 "sysfunc" 29047 3 -"dbm-fetch" 2 "sysfunc" 29262 3 -"cd" 2 "sysfunc" 30702 3 -"ez" 2 "sysfunc" 30797 3 -"piped-fork" 2 "sysfunc" 30914 3 -"xfork" 2 "sysfunc" 31338 3 -"rusage" 2 "sysfunc" 32009 3 -"load-foreign" 3 "sysfunc" 38822 3 -"defforeign" 3 "sysfunc" 41380 3 -"defun-c-callable" 3 "sysfunc" 43899 3 -"pod-address" 2 "sysfunc" 44914 3 -"array-entity" 3 "sysfunc" 45179 3 -"float2double" 2 "sysfunc" 45462 3 -"double2float" 2 "sysfunc" 45681 3 +"sys:list-all-tags" 2 "evaluation" 29603 3 +"sys:list-all-instances" 2 "evaluation" 29684 3 +"sys:list-all-bindings" 2 "evaluation" 29981 3 +"sys:list-all-special-bindings" 2 "evaluation" 30102 3 +"dump-object" 2 "evaluation" 30708 2 +"dump-structure" 2 "evaluation" 30756 3 +"dump-loadable-structure" 2 "evaluation" 30887 3 +"sys:save" 2 "evaluation" 31759 3 +"lisp-implementation-type" 2 "evaluation" 34469 3 +"lisp-implementation-version" 2 "evaluation" 34538 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 From 54ea2a011e30dee1293bc4f7ad975f761a3a4cdf Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 15 Oct 2021 20:37:20 +0900 Subject: [PATCH 172/387] Only generate accessors when in defcondition and remove redundant :init --- lisp/l/conditions.l | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 8d9e828d0..f9e801f0c 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -43,11 +43,14 @@ (defmacro defcondition (name &key slots (super 'condition)) `(progn (defclass ,name :slots ,slots :super ,super) - (defmethod ,name - (:init (&rest init-args) (send-super* :init init-args)) - ,@(mapcar #'(lambda (s) `(,(intern (send s :pname) *keyword-package*) (&optional (val nil supplied-p)) - (if supplied-p (send self :set-val ',s val) ,s))) - slots)))) + ,(if slots + `(defmethod ,name + ,@(mapcar + #'(lambda (s) + `(,(intern (send s :pname) *keyword-package*) (&optional (val nil supplied-p)) + (if supplied-p (send self :set-val ',s val) ,s))) + slots))) + ',name)) (defun install-handler-raw (label handler) ;; ensure condition class From ed4ae211e87d8fef935e9bc5b5c1c2c7aef71610 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 15 Oct 2021 20:50:44 +0900 Subject: [PATCH 173/387] Remove unused .new files --- lisp/c/makes.new.c | 925 ------------------------------------- lisp/c/reader.new.c | 1055 ------------------------------------------- 2 files changed, 1980 deletions(-) delete mode 100644 lisp/c/makes.new.c delete mode 100644 lisp/c/reader.new.c 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/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; - } - } From f960a04efb09944a59dce1cbf9d36b7b326513c8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 1 Mar 2022 19:36:57 +0900 Subject: [PATCH 174/387] Fix segfaults in get --- lisp/c/specials.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 4c509c210..c777eefa1 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -1242,9 +1242,11 @@ register pointer argv[]; printf( "\n" ); #endif p=argv[0]->c.sym.plist; - while (iscons(p)) + while (iscons(p)) { + if (!iscons(ccar(p))) error(E_NOLIST); if (ccar(ccar(p))==attr) return(ccdr(ccar(p))); else p=ccdr(p); + } if (n==3) return(argv[2]); else return(NIL);} pointer EXPORT (ctx,n,argv) /*further name conflict checks should be From 102d0baaa1670d6a137ab255a806d2b06c74dfe8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 1 Mar 2022 19:37:17 +0900 Subject: [PATCH 175/387] Fix segfaults in nbutlast --- lisp/c/lists.c | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/lisp/c/lists.c b/lisp/c/lists.c index f9d1e185e..765010756 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -366,15 +366,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_STARTEND); + 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); From 21950b0209cd2fc821493180e8fff56d6ffb87b9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 1 Mar 2022 21:26:04 +0900 Subject: [PATCH 176/387] Raise actual errors in object :error --- lisp/l/object.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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)) From e7ba36e258beaa9b25a54408ec8e0a044ea08cbd Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 1 Mar 2022 21:30:47 +0900 Subject: [PATCH 177/387] Check argument type in char compilation --- lisp/comp/trans.l | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 750e7822f..86597ba1e 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -377,6 +377,7 @@ (:char () (format cfile " { register eusinteger_t i=intval(~A);~%" (send self :pop)) (let ((vec (send self :pop))) + (format cfile " if (!isstring(~A)) error(E_NOSTRING);~%" vec) (format cfile " w=makeint(~A->c.str.chars[i]);}~%" vec)) (send self :push "w")) (:setchar () From c36ef070215ff73c40c1248ff9c9341b78b6a11a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 1 Mar 2022 23:28:31 +0900 Subject: [PATCH 178/387] Raise more compilation errors --- lisp/comp/comp.l | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 7a97f8e85..abec10819 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -106,7 +106,7 @@ (defun check-arg (req n &optional (fn "car/cdr")) (if (null (= req n)) - (warn "mismatch arg for " fn))) + (error "mismatch arg for ~A" fn))) (defun def-function-type (type funcs) (dolist (f funcs) (putprop f type 'function-result-type))) @@ -347,7 +347,7 @@ (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)))) @@ -845,7 +845,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))) @@ -955,7 +955,7 @@ (dolist (id (cdr decl)) (setq v (send self :enter-variable id)) (send v :type (car decl)))) - (t (send self :warning "unknown declaration" decl)))) + (t (send self :error "unknown declaration" decl)))) )))) (:lambda (param forms) (let ((labels nil) From 6f9613ca336a8aa87ca5e5d926a7c3b9f81ff8ec Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 2 Mar 2022 12:39:15 +0900 Subject: [PATCH 179/387] Fix SETELT for array values --- lisp/c/sequence.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/c/sequence.c b/lisp/c/sequence.c index 84403fdb3..1510a19e3 100644 --- a/lisp/c/sequence.c +++ b/lisp/c/sequence.c @@ -1069,7 +1069,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_USER,(pointer)"no sequence");} void sequence(ctx,mod) From 32911a3ad40fd77197c13995dc9278db2ade308a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 8 Mar 2022 14:58:41 +0900 Subject: [PATCH 180/387] Move isbitvector definition to eus.h --- lisp/c/eus.h | 1 + lisp/c/vectorarray.c | 2 -- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 5b00516b9..9bbe82a84 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -859,6 +859,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) 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; From c9400771353d5bada78ed917a6c9581481787d03 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 8 Mar 2022 17:33:13 +0900 Subject: [PATCH 181/387] Type-check compiled function declarations --- lisp/comp/comp.l | 31 +++++++++++++++++++++---------- lisp/comp/trans.l | 44 ++++++++++++++++++++++++++++++++++++++++++++ lisp/l/common.l | 4 ---- 3 files changed, 65 insertions(+), 14 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index abec10819..5c90f09cd 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -86,7 +86,6 @@ r)) (defun object-variable-type (klass var) - (declare (type metaclass klass)) (when (not (classp klass)) (if (class-symbolp klass) (setq klass (symbol-value klass)) @@ -720,14 +719,14 @@ (let ((local-list (pop bodies)) (unwind-save unwind-frames)) (send self :create-frame) (while (and bodies (consp (car bodies)) (eq (caar bodies) 'declare)) - (send self :declare (cdr (pop bodies)))) + (send self :declare (cdr (pop bodies)))) (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))) ) (send self :progn bodies) - (setq unwind-frames unwind-save) + (setq unwind-frames unwind-save) (send self :delete-frame t))) (:let (bodies) ;parallel let (let ((local-list (pop bodies)) var special-list offset @@ -928,7 +927,8 @@ (setq flets (nthcdr (length funcs) flets))) (:change-flets (newflets) (setq flets newflets)) (:declare (args) - (let (v) + ;; bind statements and return type declared variables + (let (v acc) (declare (type identifier v)) (dolist (decl args) (case (car decl) @@ -939,13 +939,15 @@ (type (dolist (id (cddr decl)) (setq v (send self :enter-variable id)) - (send v :type (cadr decl)))) + (send v :type (cadr decl)) + (push id 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 id acc))) (optimize (setq *optimize* (cadr decl))) (safety (setq *safety* (cadr decl))) (space (setq *space* (cadr decl))) @@ -954,9 +956,10 @@ (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 :error "unknown declaration" decl)))) - )))) + (send v :type (car decl)) + (push id acc))) + (t (send self :error "unknown declaration" decl)))))) + (nreverse acc))) (:lambda (param forms) (let ((labels nil) (i 0) @@ -975,6 +978,8 @@ (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)) @@ -1055,7 +1060,7 @@ ) ) ;; 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 @@ -1138,6 +1143,12 @@ (send self :bind (if (listp av) (car av) av) 'local (1- (send trans :offset-from-fp)))) +;;; type check declaration variables + (dolist (id decl-vars) + (let ((v (send self :variable id))) + (unless (eql (v . binding) 'unknown) + (send self :load-var id) + (send trans :type-check-declare (v . type))))) ;;; evaluate lambda body (send self :progn forms) (setq unwind-frames unwind-save) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 86597ba1e..d33736f55 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -441,6 +441,50 @@ (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 (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_USER, (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 (warn "unknown type declaration: ~A~%" type) nil)))) + (if (and ckfn errc) + (progn + (send self :store "w") + (case type + ((list array) + (format cfile " if (!(~A)) error(~A);~%" ckfn errc)) + (t + (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)) (:if-t (lab) diff --git a/lisp/l/common.l b/lisp/l/common.l index 72e2a9ae3..17713e123 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -924,11 +924,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) @@ -948,11 +946,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)) From 9be388ba4e38a596f52275bca816926e5bc16320 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 9 Mar 2022 11:10:05 +0900 Subject: [PATCH 182/387] Allow symbols in string-trim --- lisp/l/string.l | 2 -- 1 file changed, 2 deletions(-) diff --git a/lisp/l/string.l b/lisp/l/string.l index 8aa3a2554..1602a8a4f 100644 --- a/lisp/l/string.l +++ b/lisp/l/string.l @@ -67,7 +67,6 @@ (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)) @@ -75,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)) From 447d722262419cb5863884f4dba5719a3fc86e52 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 8 Mar 2022 19:08:26 +0900 Subject: [PATCH 183/387] Allow null lists at mapc --- lisp/c/specials.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index c777eefa1..4751fe463 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -215,7 +215,7 @@ register pointer *argv; } printf( "\n" ); #endif - if(!iscons(argv[1])) error(E_NOLIST); + if(!(iscons(argv[1]) || argv[1]==NIL)) error(E_NOLIST); while (islist(argv[1])) { i=1; while (i Date: Thu, 10 Mar 2022 14:46:27 +0900 Subject: [PATCH 184/387] Remove euserror variable initialization --- lisp/l/common.l | 1 - 1 file changed, 1 deletion(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index 17713e123..241809420 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -71,7 +71,6 @@ (cadr lisp-implementation-version) (caddr lisp-implementation-version) )) -(setq euserror nil) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; basic macros From c86e1dda7b9f1fc58da38c4147dfefebcc6cdec8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 21 Mar 2022 18:21:22 +0900 Subject: [PATCH 185/387] Search for :isatty method in unix:isatty for slime compability --- lisp/c/eus.c | 3 ++- lisp/c/unixcall.c | 4 +++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 5326030bf..1a1723c67 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -181,7 +181,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; pointer K_FUNCTION_DOCUMENTATION, K_VARIABLE_DOCUMENTATION, K_CLASS_DOCUMENTATION, K_METHOD_DOCUMENTATION, K_CLASS; pointer QLOADED_MODULES; @@ -671,6 +671,7 @@ 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_CLASS=defkeyword(ctx,"CLASS"); K_FUNCTION_DOCUMENTATION=defkeyword(ctx,"FUNCTION-DOCUMENTATION"); K_CLASS_DOCUMENTATION=defkeyword(ctx,"CLASS-DOCUMENTATION"); diff --git a/lisp/c/unixcall.c b/lisp/c/unixcall.c index 1756c0375..05971a838 100644 --- a/lisp/c/unixcall.c +++ b/lisp/c/unixcall.c @@ -91,6 +91,7 @@ extern time_t timezone, altzone; /*long*/ #endif extern int daylight; +extern pointer K_ISATTY; extern pointer eussigvec[NSIG]; extern eusinteger_t coerceintval(pointer); @@ -1448,7 +1449,8 @@ pointer argv[]; a=argv[0]; if (isiostream(a)) a=a->c.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); From cde489f0a19f4addf56ed32703f075cfa7495c2e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 21 Mar 2022 19:35:46 +0900 Subject: [PATCH 186/387] Reset *current-condition-handler* when entering a new repl level --- lisp/l/toplevel.l | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 6cad9a780..4e2f114eb 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -254,7 +254,8 @@ (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))) ) From 3ac03113b0fd6d3e12cc6b12d016fc2f83653b28 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 22 Mar 2022 19:42:02 +0900 Subject: [PATCH 187/387] Check only for numberp on type declarations --- lisp/comp/trans.l | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index d33736f55..dc3614f26 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -447,8 +447,8 @@ (cons "iscons") (list "islist(w) || w==NIL") (number "numberp") - (integer "isint") - (float "isflt") + (integer "numberp") ;; don't use `isint' for backward compability + (float "numberp") ;; don't use `isflt' for backward compability (string "isstring") (array "isarray(w) || isvector(w)") (vector "isvector") From a776f5681049c24084bdbf537271b0b0176699c6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 2 May 2022 13:45:06 +0900 Subject: [PATCH 188/387] Allow to use t as default condition in handler-bind and handler-case --- lisp/l/conditions.l | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index f9e801f0c..3f3e5fc2c 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -54,6 +54,7 @@ (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)) From d38a22df6b1dbe560d20e8966c7df4332395e6d6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 3 May 2022 00:07:36 +0900 Subject: [PATCH 189/387] Fix E_SLOT error message in ovafptr --- lisp/c/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 01815b8ba..1fac61eee 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -124,7 +124,7 @@ register pointer o,v; c=classof(o); vaddr=getobjv(v,c->c.cls.vars,o); if (vaddr) return(vaddr); - else error(E_NOSLOT,o,v);} + else error(E_NOSLOT,v);} /***** special variable binding *****/ From 703fe1f23306dba15e10dafaed0c3881518605b6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 5 May 2022 17:45:03 +0900 Subject: [PATCH 190/387] Update documentation make-hash-table default keyargument value --- doc/jlatex/jsequences.tex | 2 +- doc/latex/sequences.tex | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index 0b79cba1e..d967b28fb 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -735,7 +735,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を作り、返す。} diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex index 53a804a8d..b82f12231 100644 --- a/doc/latex/sequences.tex +++ b/doc/latex/sequences.tex @@ -722,7 +722,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.} From e1f6ac3a97ca7d02fe672f7485866ce1d4b759b3 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 23 Oct 2021 10:00:31 +0900 Subject: [PATCH 191/387] Implement bindframe class for proper closures --- lisp/c/eus.c | 14 ++++++-- lisp/c/eus.h | 36 +++++++++++--------- lisp/c/eus_proto.h | 13 +++---- lisp/c/eval.c | 85 +++++++++++++++++++++++----------------------- lisp/c/leo.c | 6 ++-- lisp/c/makes.c | 13 ++++++- lisp/c/specials.c | 20 ++++++----- lisp/c/sysfunc.c | 11 +++--- 8 files changed, 113 insertions(+), 85 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 1a1723c67..009fe3908 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -81,6 +81,7 @@ cixpair fcodecp; /*cixpair modulecp; */ cixpair ldmodulecp; cixpair closurecp; +cixpair bindframecp; cixpair labrefcp; cixpair threadcp; cixpair arraycp; @@ -146,7 +147,7 @@ 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_LABREF; pointer C_THREAD; pointer C_VCLASS, C_FLTVECTOR, C_INTVECTOR, C_STRING, C_BITVECTOR; pointer C_FOREIGNCODE,C_ARRAY,C_READTABLE; @@ -155,7 +156,8 @@ pointer C_CONDITION, C_ERROR; /*class names*/ pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL, - CODE,FCODE, LDMODULE, PKGCLASS,METACLASS,CLOSURE,LABREF; + CODE,FCODE, LDMODULE, PKGCLASS,METACLASS,CLOSURE,BINDFRAME; +pointer LABREF; pointer THREAD; pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE; pointer FOREIGNCODE,ARRAY,BITVECTOR; @@ -577,6 +579,8 @@ static void initclassid() fltvectorcp.cix=19; fltvectorcp.sub=19; intvectorcp.cix=20; intvectorcp.sub=20; stringcp.cix=21; stringcp.sub=21; + + bindframecp.cix=22; bindframecp.sub=22; } static void initpackage() @@ -840,6 +844,12 @@ static void initclasses() builtinclass[nextbclass].cls=C_STRING; builtinclass[nextbclass++].cp= &stringcp; +/*22*/ + BINDFRAME=basicclass("BIND-FRAME",C_OBJECT,&bindframecp,3, + "SYMBOL","VALUE","NEXT"); + C_BINDFRAME=speval(BINDFRAME); + +/* derived classes */ BITVECTOR=defvector(ctx,"BIT-VECTOR",C_VECTOR,ELM_BIT, 0); /* alpha */ C_BITVECTOR=speval(BITVECTOR); builtinclass[nextbclass].cls=C_BITVECTOR; diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 9bbe82a84..d6cc98802 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -294,6 +294,11 @@ struct iostream { pointer plist; pointer in,out;}; +struct bindframe { /*to achieve lexical binding in the interpreter*/ + pointer symbol; /*symbol*/ + pointer value; /*bound value*/ + pointer next; /*link to next frame*/}; + struct labref { /*used for reading labeled forms: #n#,#n=*/ pointer label; pointer value; @@ -413,6 +418,7 @@ typedef struct fcode fcode; struct ldmodule ldmod; struct closure clo; + struct bindframe bfp; struct labref lab; struct arrayheader ary; struct vector vec; @@ -480,11 +486,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)*/ @@ -499,7 +500,7 @@ 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; jmp_buf *jbp; @@ -532,7 +533,7 @@ typedef struct { #endif struct callframe *callfp; struct catchframe *catchfp; - struct bindframe *bindfp; + pointer bindfp; struct specialbindframe *sbindfp; struct blockframe *blkfp; struct protectframe *protfp; @@ -630,6 +631,7 @@ extern cixpair fcodecp; /*cixpair modulecp; */ extern cixpair ldmodulecp; extern cixpair closurecp; +extern cixpair bindframecp; extern cixpair labrefcp; extern cixpair threadcp; extern cixpair arraycp; @@ -868,6 +870,8 @@ 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 pislabref(p) (labrefcp.cix<=(p)->cix && (p)->cix<=labrefcp.sub) #define islabref(p) (ispointer(p) && pislabref(p)) /* extended numbers */ @@ -1034,24 +1038,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(); diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index d869a7e49..1730545e3 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -177,15 +177,15 @@ 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*/); @@ -338,6 +338,7 @@ extern pointer makemodule(context */*ctx*/, int /*size*/); extern pointer makeclosure(pointer /*code*/, pointer /*quote*/, pointer (*/*f*/)(), pointer /*e0*/, pointer */*e1*/, pointer */*e2*/); extern pointer makereadtable(context */*ctx*/); extern pointer makelabref(pointer /*n*/, pointer /*v*/, pointer /*nxt*/); +extern pointer makebindframe(pointer /*sym*/, pointer /*val*/, pointer /*nxt*/); extern pointer makeratio(int /*num*/, int /*denom*/); extern pointer makebig(int /*n*/); extern pointer makebig1(long /*x*/); diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 1fac61eee..332b5ff5e 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,16 @@ 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.symbol; + val=bf->c.bfp.value; 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 +68,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 +77,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.symbol; if (sym==var) { - if (bf->val==UNBOUND) goto setspecial; - pointer_update(bf->val,val); return(val);} + if (bf->c.bfp.value==UNBOUND) goto setspecial; + pointer_update(bf->c.bfp.value,val); return(val);} else if (var->cix==vectorcp.cix) { - vaddr=getobjv(sym,var,bf->val); + vaddr=getobjv(sym,var,bf->c.bfp.value); 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; @@ -177,34 +179,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(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_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,10 +215,10 @@ 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)) { @@ -267,12 +265,12 @@ 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 env,bf; { pointer fvar,initform,svar; register pointer fkeyvar,akeyvar; pointer keys[KEYWORDPARAMETERLIMIT], @@ -355,12 +353,12 @@ struct bindframe *env,*bf; pointer funlambda(ctx,fn,formal,body,argp,env,noarg) register context *ctx; pointer fn,formal,body,*argp; -struct bindframe *env; +pointer env; int noarg; { pointer ftype,fvar,result,decl,aval,initform,fkeyvar,akeyvar; pointer *vspsave= ctx->vsp; 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; @@ -1487,7 +1485,7 @@ 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); @@ -1599,11 +1597,12 @@ int noarg; 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; + if (ccar(func)==NULL || isbindframe(ccar(func))) + env=ccar(func); + else if (ckintval(ccar(func))==0) + env=NULL; + else error(E_USER,(pointer)"illegal bind-frame"); func=ccdr(func); - /* ctx->fletfp=(struct fletframe *)intval(ccar(func)); */ fenv=(struct fletframe *)intval(ccar(func)); func=ccdr(func);} else if (ftype!=LAMBDA && ftype!=MACRO) error(E_NOFUNCTION); @@ -1690,7 +1689,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) diff --git a/lisp/c/leo.c b/lisp/c/leo.c index 39d93937c..0276f6068 100644 --- a/lisp/c/leo.c +++ b/lisp/c/leo.c @@ -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); diff --git a/lisp/c/makes.c b/lisp/c/makes.c index da386840f..b164c2bf6 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -547,6 +547,17 @@ pointer n,v,nxt; l->c.lab.next=nxt; l->c.lab.unsolved=NIL; return(l);} + +pointer makebindframe(sym,val,nxt) +pointer sym,val,nxt; +{ pointer bf; + bf=alloc(wordsizeof(struct bindframe), ELM_FIXED, bindframecp.cix, + wordsizeof(struct bindframe)); + // if (nxt==NULL) nxt=NIL; + bf->c.bfp.symbol=sym; + bf->c.bfp.value=val; + bf->c.bfp.next=nxt; + return(bf);} /**************************************************************** /* extended numbers @@ -792,7 +803,7 @@ struct fletframe *scp,*link; vpush(makeint(0)); ffp->name=nm; p=cons(ctx,makeint(hide_ptr((pointer)scp)),def); - p=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),p); + p=cons(ctx,ctx->bindfp,p); p=cons(ctx,nm,p); ffp->fclosure=cons(ctx,LAMCLOSURE,p); ffp->scope=scp; diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 4751fe463..eeea826dd 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; @@ -146,7 +146,11 @@ pointer 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); + if (ctx->bindfp==NULL) + // don't pass *unbound* to the REPL + arg=cons(ctx,makeint(0),arg); + else + arg=cons(ctx,ctx->bindfp,arg); arg=cons(ctx,funcname,arg); return(cons(ctx,LAMCLOSURE,arg));} else error(E_NOFUNCTION);} @@ -368,7 +372,7 @@ register context *ctx; pointer arg; { pointer cond,body,*spsave=ctx->vsp,result; struct blockframe *myblock; - struct bindframe *bfp=ctx->bindfp; + pointer bfp=ctx->bindfp; jmp_buf whilejmp; int i; @@ -413,7 +417,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) @@ -468,7 +472,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 @@ -671,7 +675,7 @@ 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; jmp_buf blkjmp; #ifdef SPEC_DEBUG printf( "BLOCK:" ); hoge_print(arg); @@ -740,7 +744,7 @@ pointer 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->bindfp,cleaner); cleaner=cons(ctx,NIL,cleaner); cleaner=cons(ctx,LAMCLOSURE,cleaner); /*(LAMDA-CLOSURE bindfp fletfp () . body) */ @@ -762,7 +766,7 @@ pointer arg; jmp_buf tagjmp; struct blockframe *tagblock; pointer *spsave=ctx->vsp, *tagspsave; - struct bindframe *bfpsave=ctx->bindfp; + pointer bfpsave=ctx->bindfp; #ifdef SPEC_DEBUG printf( "TAGBODY:" ); hoge_print(arg); #endif diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index f6fca68b3..a26638500 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -761,14 +761,13 @@ pointer LISTBINDINGS(ctx,n,argv) register context *ctx; int n; pointer *argv; -{ struct bindframe *bfp=ctx->bindfp, *nextbfp; +{ pointer bf=ctx->bindfp; int i=0; - while (bfp) { - vpush(cons(ctx,bfp->sym,bfp->val)); + while (bf) { + vpush(cons(ctx,bf->c.bfp.symbol,bf->c.bfp.value)); i++; - nextbfp=bfp->dynblink; - if (nextbfp==NULL) nextbfp=bfp->lexblink; - bfp=nextbfp;} + if (bf==bf->c.bfp.next) break; + bf=bf->c.bfp.next;} return(stacknlist(ctx,i));} pointer LISTSPECIALBINDINGS(ctx,n,argv) From 77c980a61fded35adce3a8db9fbe998dfb956f13 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 25 Oct 2021 03:59:54 +0900 Subject: [PATCH 192/387] Use LAMCLOSURE in errhandler to ensure correct operation in uncompiled eus --- lisp/c/eus.c | 2 +- lisp/c/eus_proto.h | 1 + lisp/c/eval.c | 19 +++++++++++++++++++ lisp/c/specials.c | 16 +--------------- 4 files changed, 22 insertions(+), 16 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 009fe3908..c6518dc31 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -387,7 +387,7 @@ va_dcl if (ctx->callfp) form=ctx->callfp->form; else form=NIL; /* call user's error handler function */ - errhandler=getfunc(ctx, intern(ctx,"SIGNALS",7,lisppkg)); + errhandler=getfunc_closure(ctx, intern(ctx,"SIGNALS",7,lisppkg)); switch((unsigned int)ec) { // ARGUMENT ERROR diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 1730545e3..3de4ecf51 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -171,6 +171,7 @@ 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 getfunc_closure(context */*ctx*/, pointer /*f*/); extern pointer get_sym_func(pointer /*s*/); extern void setfunc(pointer /*sym*/, pointer /*func*/); extern pointer *ovafptr(pointer /*o*/, pointer /*v*/); diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 332b5ff5e..fbe615b99 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -107,6 +107,25 @@ register pointer f; /*must be a symbol*/ else { /*global function definition is taken, context changes*/ return(f->c.sym.spefunc);}} +pointer getfunc_closure(ctx,f) +register context *ctx; +register pointer f; +{ pointer funcname; + if (issymbol(f)) { funcname=f; f=getfunc(ctx,f);} + else funcname=NIL; + if (iscode(f)) return(f); + else if (ccar(f)==LAMCLOSURE) return(f); + else if (ccar(f)==LAMBDA) { + f=cons(ctx,makeint(hide_ptr((pointer)(ctx->fletfp))),ccdr(f)); + 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,funcname,f); + return(cons(ctx,LAMCLOSURE,f));} + else error(E_NOFUNCTION);} + /* called from compiled code*/ pointer get_sym_func(s) pointer s; diff --git a/lisp/c/specials.c b/lisp/c/specials.c index eeea826dd..816413d09 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -139,21 +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)); - if (ctx->bindfp==NULL) - // don't pass *unbound* to the REPL - arg=cons(ctx,makeint(0),arg); - else - arg=cons(ctx,ctx->bindfp,arg); - arg=cons(ctx,funcname,arg); - return(cons(ctx,LAMCLOSURE,arg));} - else error(E_NOFUNCTION);} + return getfunc_closure(ctx,ccar(arg));} pointer MACEXPAND2(ctx,n,argv) register context *ctx; From b2a5466b41db694d9b5543b6dcfc740e117cf715 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 25 Oct 2021 08:04:37 +0900 Subject: [PATCH 193/387] Implement flet-frame class --- lisp/c/eus.c | 15 ++++++++--- lisp/c/eus.h | 20 +++++++------- lisp/c/eus_proto.h | 4 +-- lisp/c/eval.c | 26 ++++++++++++++----- lisp/c/makes.c | 65 +++++++++++++++++++++------------------------- lisp/c/specials.c | 14 +++++----- 6 files changed, 80 insertions(+), 64 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index c6518dc31..7d63e7f96 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -82,6 +82,7 @@ cixpair fcodecp; cixpair ldmodulecp; cixpair closurecp; cixpair bindframecp; +cixpair fletframecp; cixpair labrefcp; cixpair threadcp; cixpair arraycp; @@ -147,7 +148,7 @@ 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_BINDFRAME, 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; @@ -156,7 +157,7 @@ pointer C_CONDITION, C_ERROR; /*class names*/ pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL, - CODE,FCODE, LDMODULE, PKGCLASS,METACLASS,CLOSURE,BINDFRAME; + CODE,FCODE, LDMODULE, PKGCLASS,METACLASS,CLOSURE,BINDFRAME,FLETFRAME; pointer LABREF; pointer THREAD; pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE; @@ -307,8 +308,8 @@ register pointer *p; 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 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; } @@ -581,6 +582,7 @@ static void initclassid() stringcp.cix=21; stringcp.sub=21; bindframecp.cix=22; bindframecp.sub=22; + fletframecp.cix=23; fletframecp.sub=23; } static void initpackage() @@ -849,6 +851,11 @@ static void initclasses() "SYMBOL","VALUE","NEXT"); C_BINDFRAME=speval(BINDFRAME); +/*23*/ + FLETFRAME=basicclass("FLET-FRAME",C_OBJECT,&fletframecp,3, + "NAME","FCLOSURE","NEXT"); + C_FLETFRAME=speval(FLETFRAME); + /* derived classes */ BITVECTOR=defvector(ctx,"BIT-VECTOR",C_VECTOR,ELM_BIT, 0); /* alpha */ C_BITVECTOR=speval(BITVECTOR); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index d6cc98802..87eb1fde8 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -299,6 +299,11 @@ struct bindframe { /*to achieve lexical binding in the interpreter*/ pointer value; /*bound value*/ pointer next; /*link to next frame*/}; +struct fletframe { + pointer name; + pointer fclosure; + pointer next;}; + struct labref { /*used for reading labeled forms: #n#,#n=*/ pointer label; pointer value; @@ -419,6 +424,7 @@ typedef struct ldmodule ldmod; struct closure clo; struct bindframe bfp; + struct fletframe ffp; struct labref lab; struct arrayheader ary; struct vector vec; @@ -502,7 +508,7 @@ struct catchframe { pointer label; pointer bf; /*bind frame save*/ struct callframe *cf; /*call frame save*/ - struct fletframe *ff; + pointer ff; /*fletframe*/ jmp_buf *jbp; }; @@ -511,13 +517,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 { @@ -537,7 +536,7 @@ typedef struct { struct specialbindframe *sbindfp; struct blockframe *blkfp; struct protectframe *protfp; - struct fletframe *fletfp, *newfletfp; + pointer fletfp, newfletfp; pointer lastalloc; pointer threadobj; struct methdef *methcache; @@ -632,6 +631,7 @@ extern cixpair fcodecp; extern cixpair ldmodulecp; extern cixpair closurecp; extern cixpair bindframecp; +extern cixpair fletframecp; extern cixpair labrefcp; extern cixpair threadcp; extern cixpair arraycp; @@ -872,6 +872,8 @@ extern eusinteger_t intval(pointer p); #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 pislabref(p) (labrefcp.cix<=(p)->cix && (p)->cix<=labrefcp.sub) #define islabref(p) (ispointer(p) && pislabref(p)) /* extended numbers */ diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 3de4ecf51..d4afe29ff 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -356,8 +356,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 struct fletframe *makemacrolet(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 /*scp*/, 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*/); diff --git a/lisp/c/eval.c b/lisp/c/eval.c index fbe615b99..9292712bf 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -99,10 +99,10 @@ register pointer sym,val; 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;} +{ 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;} if (f->c.sym.spefunc==UNBOUND) error(E_UNDEF,f); else { /*global function definition is taken, context changes*/ return(f->c.sym.spefunc);}} @@ -116,7 +116,13 @@ register pointer f; if (iscode(f)) return(f); else if (ccar(f)==LAMCLOSURE) return(f); else if (ccar(f)==LAMBDA) { - f=cons(ctx,makeint(hide_ptr((pointer)(ctx->fletfp))),ccdr(f)); + // 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); @@ -1511,7 +1517,7 @@ int noarg; 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) { @@ -1616,13 +1622,19 @@ int noarg; if (ftype->c.sym.homepkg==keywordpkg) fn=ftype; /*blockname=selector*/ else if (ftype==LAMCLOSURE) { fn=ccar(func); func=ccdr(func); + // bind-frame if (ccar(func)==NULL || isbindframe(ccar(func))) env=ccar(func); else if (ckintval(ccar(func))==0) env=NULL; else error(E_USER,(pointer)"illegal bind-frame"); func=ccdr(func); - fenv=(struct fletframe *)intval(ccar(func)); + // flet-frame + if (ccar(func)==NULL || isfletframe(ccar(func))) + fenv=ccar(func); + else if (ckintval(ccar(func))==0) + fenv=NULL; + else error(E_USER,(pointer)"illegal flet-frame"); func=ccdr(func);} else if (ftype!=LAMBDA && ftype!=MACRO) error(E_NOFUNCTION); else env=NULL /*0 ????*/; diff --git a/lisp/c/makes.c b/lisp/c/makes.c index b164c2bf6..d2b1a529d 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -558,6 +558,36 @@ pointer sym,val,nxt; bf->c.bfp.value=val; bf->c.bfp.next=nxt; return(bf);} + +pointer makeflet(ctx,nm,def,scp,nxt) +register context *ctx; +pointer nm,def,scp,nxt; +{ pointer p,ff; + ff=alloc(wordsizeof(struct fletframe), ELM_FIXED, fletframecp.cix, + wordsizeof(struct fletframe)); + p=cons(ctx,scp,def); // fletframe scope + p=cons(ctx,ctx->bindfp,p); // bindframe scope + p=cons(ctx,nm,p); // name + p=cons(ctx,LAMCLOSURE,p); + ff->c.ffp.name=nm; + ff->c.ffp.fclosure=p; + ff->c.ffp.next=nxt; + vpush(ff); + ctx->fletfp=ff; + return(ff);} + +pointer makemacrolet(ctx,nm,def,scp,nxt) +register context *ctx; +pointer nm,def,scp,nxt; +{ pointer ff; + ff=alloc(wordsizeof(struct fletframe), ELM_FIXED, fletframecp.cix, + wordsizeof(struct fletframe)); + ff->c.ffp.name=nm; + ff->c.ffp.fclosure=cons(ctx,MACRO,def); + ff->c.ffp.next=nxt; + vpush(ff); + ctx->fletfp=ff; + return(ff);} /**************************************************************** /* extended numbers @@ -792,41 +822,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,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);} - -struct fletframe *makemacrolet(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; - ffp->fclosure=cons(ctx,MACRO,def); - 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; diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 816413d09..7b5ab0b77 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -557,7 +557,7 @@ pointer MACROLET(ctx,arg) register context *ctx; register pointer arg; { register pointer macs, mac; - register struct fletframe *ffp=ctx->fletfp; + pointer ffp=ctx->fletfp; pointer result; #ifdef SPEC_DEBUG printf( "MACROLET:" ); hoge_print(arg); @@ -575,7 +575,7 @@ 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); @@ -593,7 +593,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); @@ -605,9 +605,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);} @@ -729,7 +729,7 @@ 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,ctx->fletfp,cleaner); cleaner=cons(ctx,ctx->bindfp,cleaner); cleaner=cons(ctx,NIL,cleaner); cleaner=cons(ctx,LAMCLOSURE,cleaner); From 9926ac37bbb682d76d1b6f782e413237198f67e8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 26 Oct 2021 18:37:45 +0900 Subject: [PATCH 194/387] Unwind fletfp --- lisp/c/compsub.c | 1 + lisp/c/eus.c | 7 ++++--- lisp/c/specials.c | 6 ++++++ 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/lisp/c/compsub.c b/lisp/c/compsub.c index aa24a727d..18f13617b 100644 --- a/lisp/c/compsub.c +++ b/lisp/c/compsub.c @@ -81,5 +81,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 7d63e7f96..a7cae2d95 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -302,14 +302,15 @@ 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; } diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 7b5ab0b77..41fcf5447 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -359,6 +359,7 @@ pointer arg; { pointer cond,body,*spsave=ctx->vsp,result; struct blockframe *myblock; pointer bfp=ctx->bindfp; + pointer ffp=ctx->fletfp; jmp_buf whilejmp; int i; @@ -379,6 +380,7 @@ pointer arg; ctx->blkfp=myblock->dynklink; ctx->vsp=spsave; ctx->bindfp=bfp; + ctx->fletfp=ffp; return(result);} pointer COND(ctx,arg) @@ -662,6 +664,7 @@ register pointer arg; /*must be called via ufuncall*/ { pointer name,result,*spsave=ctx->vsp; struct blockframe *myblock; pointer bfp=ctx->bindfp; + pointer ffp=ctx->fletfp; jmp_buf blkjmp; #ifdef SPEC_DEBUG printf( "BLOCK:" ); hoge_print(arg); @@ -676,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);} @@ -753,6 +757,7 @@ pointer arg; struct blockframe *tagblock; pointer *spsave=ctx->vsp, *tagspsave; pointer bfpsave=ctx->bindfp; + pointer ffpsave=ctx->fletfp; #ifdef SPEC_DEBUG printf( "TAGBODY:" ); hoge_print(arg); #endif @@ -769,6 +774,7 @@ pointer arg; { ctx->vsp=tagspsave; ctx->bindfp=bfpsave; + ctx->fletfp=ffpsave; while (iscons(forms)) { GC_POINT; p=ccar(forms); From e467f47707a1e8a46f1b960f854c732e8e368381 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 25 Oct 2021 08:08:34 +0900 Subject: [PATCH 195/387] Indent --- lisp/c/eus.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 87eb1fde8..63674d252 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -297,7 +297,7 @@ struct iostream { struct bindframe { /*to achieve lexical binding in the interpreter*/ pointer symbol; /*symbol*/ pointer value; /*bound value*/ - pointer next; /*link to next frame*/}; + pointer next;}; /*link to next frame*/ struct fletframe { pointer name; @@ -308,7 +308,7 @@ struct labref { /*used for reading labeled forms: #n#,#n=*/ pointer label; pointer value; pointer unsolved; - pointer next; }; + pointer next;}; struct vector { pointer size; From 5363d07921765e85a43fcae28dccf3b43a303ab5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 25 Oct 2021 08:34:37 +0900 Subject: [PATCH 196/387] Remove unused scope argument from makemacrolet --- lisp/c/eus_proto.h | 2 +- lisp/c/makes.c | 4 ++-- lisp/c/specials.c | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index d4afe29ff..e470c6497 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -357,7 +357,7 @@ extern pointer compfun(context */*ctx*/, pointer /*sym*/, pointer /*mod*/, point 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 pointer makeflet(context */*ctx*/, pointer /*nm*/, pointer /*def*/, pointer /*scp*/, pointer /*nxt*/); -extern pointer makemacrolet(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*/); diff --git a/lisp/c/makes.c b/lisp/c/makes.c index d2b1a529d..558306fe6 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -576,9 +576,9 @@ pointer nm,def,scp,nxt; ctx->fletfp=ff; return(ff);} -pointer makemacrolet(ctx,nm,def,scp,nxt) +pointer makemacrolet(ctx,nm,def,nxt) register context *ctx; -pointer nm,def,scp,nxt; +pointer nm,def,nxt; { pointer ff; ff=alloc(wordsizeof(struct fletframe), ELM_FIXED, fletframecp.cix, wordsizeof(struct fletframe)); diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 41fcf5447..4cf6fc0b0 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -568,7 +568,7 @@ register pointer arg; macs=ccar(arg); while (iscons(macs)) { mac=ccar(macs); macs=ccdr(macs); - makemacrolet(ctx,ccar(mac),ccdr(mac),ffp,ctx->fletfp);} + makemacrolet(ctx,ccar(mac),ccdr(mac),ctx->fletfp);} result=progn(ctx,ccdr(arg)); ctx->fletfp=ffp; return(result);} From b7ae811a7bd627b918fd09a73f73e24a8de4d863 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 26 Oct 2021 18:41:59 +0900 Subject: [PATCH 197/387] Remove obsolete hide_ptr, brkloop, and newfletfp --- lisp/c/eus.c | 23 ----------------------- lisp/c/eus.h | 3 +-- lisp/c/makes.c | 1 - 3 files changed, 1 insertion(+), 26 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index a7cae2d95..f46b681a5 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -288,8 +288,6 @@ char *errmsg[100]={ "E_END", }; -static pointer brkloop(); - void unwind(ctx,p) register context *ctx; register pointer *p; @@ -1101,24 +1099,6 @@ eusinteger_t addr; if (debug) { fprintf(stderr, ";; eusint exit: intsig=%d\n",ctx->intsig);} } -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()]; @@ -1137,7 +1117,6 @@ void sigbreak() ctx->vsp=vspsave; } else { fprintf(stderr,"signal=%d to thread %d, \n",is, thr_self()); - /* brkloop(ctx,"B: "); */ return; }} @@ -1465,5 +1444,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 63674d252..a2eb05604 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -536,7 +536,7 @@ typedef struct { struct specialbindframe *sbindfp; struct blockframe *blkfp; struct protectframe *protfp; - pointer fletfp, newfletfp; + pointer fletfp; pointer lastalloc; pointer threadobj; struct methdef *methcache; @@ -1143,5 +1143,4 @@ extern sema_t free_thread_sem; } #endif -extern eusinteger_t hide_ptr (pointer p); diff --git a/lisp/c/makes.c b/lisp/c/makes.c index 558306fe6..b02884f8d 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -883,7 +883,6 @@ int bs_size; cntx->blkfp=NULL; cntx->protfp=NULL; cntx->fletfp=NULL; - cntx->newfletfp=NULL; cntx->lastalloc=NULL; cntx->alloc_big_count=0; cntx->alloc_small_count=0; From 6cf2375e2f834ee096a2d5546197fbb987c7578a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 26 Oct 2021 18:56:30 +0900 Subject: [PATCH 198/387] Use 0 instead of NULL in fletframe-fclosure --- lisp/c/makes.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/lisp/c/makes.c b/lisp/c/makes.c index b02884f8d..53dbf8773 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -565,8 +565,16 @@ pointer nm,def,scp,nxt; { pointer p,ff; ff=alloc(wordsizeof(struct fletframe), ELM_FIXED, fletframecp.cix, wordsizeof(struct fletframe)); - p=cons(ctx,scp,def); // fletframe scope - p=cons(ctx,ctx->bindfp,p); // bindframe scope + // 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); ff->c.ffp.name=nm; From dd0e96006d74144117357dc70c0c5cfc9276f296 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 26 Oct 2021 20:12:28 +0900 Subject: [PATCH 199/387] Add E_NOBINDFRAME and E_NOFLETFRAME --- lisp/c/eus.c | 5 ++++- lisp/c/eus.h | 2 ++ lisp/c/eval.c | 8 ++++---- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index f46b681a5..9a8770067 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -257,7 +257,10 @@ char *errmsg[100]={ "float vector expected", "integer vector expected", "bit vector expected", + "bind-frame expected", + "flet-frame expected", "type mismatch", + /* VALUE ERROR */ "", "illegal rotation axis", @@ -408,7 +411,7 @@ va_dcl 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_TYPEMISMATCH: + 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: diff --git a/lisp/c/eus.h b/lisp/c/eus.h index a2eb05604..4ec36acae 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -991,6 +991,8 @@ enum errorcode { E_FLOATVECTOR, E_NOINTVECTOR, E_BITVECTOR, + E_NOBINDFRAME, + E_NOFLETFRAME, E_TYPEMISMATCH, /* VALUE ERROR */ diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 9292712bf..c13667411 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1625,16 +1625,16 @@ int noarg; // bind-frame if (ccar(func)==NULL || isbindframe(ccar(func))) env=ccar(func); - else if (ckintval(ccar(func))==0) + else if (isint(ccar(func)) && intval(ccar(func))==0) env=NULL; - else error(E_USER,(pointer)"illegal bind-frame"); + else error(E_NOBINDFRAME); func=ccdr(func); // flet-frame if (ccar(func)==NULL || isfletframe(ccar(func))) fenv=ccar(func); - else if (ckintval(ccar(func))==0) + else if (isint(ccar(func)) && intval(ccar(func))==0) fenv=NULL; - else error(E_USER,(pointer)"illegal flet-frame"); + else error(E_NOFLETFRAME); func=ccdr(func);} else if (ftype!=LAMBDA && ftype!=MACRO) error(E_NOFUNCTION); else env=NULL /*0 ????*/; From 746b036e258c9deb64bc3a2cb5de16707ebfba6f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 26 Oct 2021 21:10:18 +0900 Subject: [PATCH 200/387] Add sys:list-all-function-bindings and optional argument to sys:list-all-bindings --- lisp/c/eus_proto.h | 1 + lisp/c/sysfunc.c | 28 +++++++++++++++++++++++++++- lisp/comp/builtins.l | 1 + lisp/l/eusstart.l | 3 ++- lisp/l/exports.l | 3 ++- 5 files changed, 33 insertions(+), 3 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index e470c6497..99a6b7f25 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -630,6 +630,7 @@ 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/sysfunc.c b/lisp/c/sysfunc.c index a26638500..fb2faf382 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -761,8 +761,14 @@ pointer LISTBINDINGS(ctx,n,argv) register context *ctx; int n; pointer *argv; -{ pointer bf=ctx->bindfp; +{ pointer bf; int i=0; + 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.symbol,bf->c.bfp.value)); i++; @@ -770,6 +776,25 @@ pointer *argv; 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++; + if (ff==ff->c.ffp.next) break; + ff=ff->c.ffp.next;} + return(stacknlist(ctx,i));} + pointer LISTSPECIALBINDINGS(ctx,n,argv) register context *ctx; int n; @@ -860,6 +885,7 @@ pointer mod; 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/comp/builtins.l b/lisp/comp/builtins.l index c97e11de7..14cffe04a 100644 --- a/lisp/comp/builtins.l +++ b/lisp/comp/builtins.l @@ -368,6 +368,7 @@ (def-builtin-entry 'SYS:LIST-ALL-REFERENCES "LISTALLREFERENCES") (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/l/eusstart.l b/lisp/l/eusstart.l index aaf023b79..c1ebb02fb 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -177,7 +177,8 @@ OBJECT-SIZE MEMORY-REPORT CLEAR-MEMORY-REPORT ROOM LIST-ALL-CHUNKS LIST-ALL-INSTANCES ADDRESS PEEK POKE LIST-ALL-REFERENCES LIST-ALL-BLOCKS LIST-ALL-TAGS LIST-ALL-CATCHERS - LIST-ALL-BINDINGS LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) + LIST-ALL-BINDINGS LIST-ALL-FUNCTION-BINDINGS LIST-ALL-SPECIAL-BINDINGS + LIST-ALL-CLASSES LIST-CALLSTACK)) (export '*threads*) diff --git a/lisp/l/exports.l b/lisp/l/exports.l index 4576e7a47..22e773d71 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -171,7 +171,8 @@ OBJECT-SIZE MEMORY-REPORT CLEAR-MEMORY-REPORT ROOM LIST-ALL-CHUNKS LIST-ALL-INSTANCES ADDRESS PEEK POKE LIST-ALL-REFERENCES LIST-ALL-BLOCKS LIST-ALL-TAGS LIST-ALL-CATCHERS - LIST-ALL-BINDINGS LIST-ALL-SPECIAL-BINDINGS LIST-ALL-CLASSES LIST-CALLSTACK)) + LIST-ALL-BINDINGS LIST-ALL-FUNCTION-BINDINGS LIST-ALL-SPECIAL-BINDINGS + LIST-ALL-CLASSES LIST-CALLSTACK)) #| From 69d11484138dceec5f024396d0609894184b59ad Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 6 May 2022 15:38:45 +0900 Subject: [PATCH 201/387] Don't define bindframes as base classes --- lisp/c/eus.c | 22 +++++++--------------- lisp/c/eus.h | 12 ------------ lisp/c/eval.c | 25 +++++++++++++------------ lisp/c/makes.c | 28 +++++++++++++--------------- lisp/c/specials.c | 4 ++-- lisp/c/sysfunc.c | 12 ++++++------ 6 files changed, 41 insertions(+), 62 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 9a8770067..31c76e0b1 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -157,8 +157,7 @@ pointer C_CONDITION, C_ERROR; /*class names*/ pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL, - CODE,FCODE, LDMODULE, PKGCLASS,METACLASS,CLOSURE,BINDFRAME,FLETFRAME; -pointer LABREF; + CODE,FCODE, LDMODULE, PKGCLASS,METACLASS,CLOSURE,LABREF; pointer THREAD; pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE; pointer FOREIGNCODE,ARRAY,BITVECTOR; @@ -582,9 +581,6 @@ static void initclassid() fltvectorcp.cix=19; fltvectorcp.sub=19; intvectorcp.cix=20; intvectorcp.sub=20; stringcp.cix=21; stringcp.sub=21; - - bindframecp.cix=22; bindframecp.sub=22; - fletframecp.cix=23; fletframecp.sub=23; } static void initpackage() @@ -848,16 +844,6 @@ static void initclasses() builtinclass[nextbclass].cls=C_STRING; builtinclass[nextbclass++].cp= &stringcp; -/*22*/ - BINDFRAME=basicclass("BIND-FRAME",C_OBJECT,&bindframecp,3, - "SYMBOL","VALUE","NEXT"); - C_BINDFRAME=speval(BINDFRAME); - -/*23*/ - FLETFRAME=basicclass("FLET-FRAME",C_OBJECT,&fletframecp,3, - "NAME","FCLOSURE","NEXT"); - C_FLETFRAME=speval(FLETFRAME); - /* derived classes */ BITVECTOR=defvector(ctx,"BIT-VECTOR",C_VECTOR,ELM_BIT, 0); /* alpha */ C_BITVECTOR=speval(BITVECTOR); @@ -874,6 +860,12 @@ 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")); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 4ec36acae..db5536e9a 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -294,16 +294,6 @@ struct iostream { pointer plist; pointer in,out;}; -struct bindframe { /*to achieve lexical binding in the interpreter*/ - pointer symbol; /*symbol*/ - pointer value; /*bound value*/ - pointer next;}; /*link to next frame*/ - -struct fletframe { - pointer name; - pointer fclosure; - pointer next;}; - struct labref { /*used for reading labeled forms: #n#,#n=*/ pointer label; pointer value; @@ -423,8 +413,6 @@ typedef struct fcode fcode; struct ldmodule ldmod; struct closure clo; - struct bindframe bfp; - struct fletframe ffp; struct labref lab; struct arrayheader ary; struct vector vec; diff --git a/lisp/c/eval.c b/lisp/c/eval.c index c13667411..4d1859d71 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -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->c.bfp.symbol; - val=bf->c.bfp.value; + var=bf->c.obj.iv[0]; + val=bf->c.obj.iv[1]; 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->c.bfp.next) break; - bf=bf->c.bfp.next;} + if (bf==bf->c.obj.iv[2] /* next */) break; + bf=bf->c.obj.iv[2]; + } /*get special value from the symbol cell*/ /*if (sym->c.sym.vtype==V_GLOBAL) goto getspecial;*/ getspecial: @@ -77,15 +78,15 @@ register pointer sym,val; pointer_update(ctx->specials->c.vec.v[vt],val); return(val);} while (bf!=NULL) { - var=bf->c.bfp.symbol; + var=bf->c.obj.iv[0]; if (sym==var) { - if (bf->c.bfp.value==UNBOUND) goto setspecial; - pointer_update(bf->c.bfp.value,val); return(val);} + if (bf->c.obj.iv[1]==UNBOUND) goto setspecial; + pointer_update(bf->c.obj.iv[1],val); return(val);} else if (var->cix==vectorcp.cix) { - vaddr=getobjv(sym,var,bf->c.bfp.value); + vaddr=getobjv(sym,var,bf->c.obj.iv[1]); if (vaddr) {pointer_update(*vaddr,val); return(val);}} - if (bf==bf->c.bfp.next) break; - bf=bf->c.bfp.next; + if (bf==bf->c.obj.iv[2] /*next*/) break; + bf=bf->c.obj.iv[2]; GC_POINT;} /* no local var found. try global binding */ if (sym->c.sym.vtype==V_CONSTANT) error(E_SETCONST,sym); @@ -101,8 +102,8 @@ 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;} + if (ffp->c.obj.iv[0]==f) { return(ffp->c.obj.iv[1]);} + else ffp=ffp->c.obj.iv[2];} if (f->c.sym.spefunc==UNBOUND) error(E_UNDEF,f); else { /*global function definition is taken, context changes*/ return(f->c.sym.spefunc);}} diff --git a/lisp/c/makes.c b/lisp/c/makes.c index 53dbf8773..960e2d388 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -17,6 +17,7 @@ static char *rcsid="@(#)$Id$"; #endif extern pointer LAMCLOSURE, MACRO, K_FUNCTION_DOCUMENTATION; +extern pointer C_BINDFRAME, C_FLETFRAME; /****************************************************************/ /* boxing and unboxing @@ -551,20 +552,18 @@ pointer n,v,nxt; pointer makebindframe(sym,val,nxt) pointer sym,val,nxt; { pointer bf; - bf=alloc(wordsizeof(struct bindframe), ELM_FIXED, bindframecp.cix, - wordsizeof(struct bindframe)); + bf=makeobject(C_BINDFRAME); // if (nxt==NULL) nxt=NIL; - bf->c.bfp.symbol=sym; - bf->c.bfp.value=val; - bf->c.bfp.next=nxt; + bf->c.obj.iv[0]=sym; + bf->c.obj.iv[1]=val; + bf->c.obj.iv[2]=nxt; return(bf);} pointer makeflet(ctx,nm,def,scp,nxt) register context *ctx; pointer nm,def,scp,nxt; { pointer p,ff; - ff=alloc(wordsizeof(struct fletframe), ELM_FIXED, fletframecp.cix, - wordsizeof(struct fletframe)); + ff=makeobject(C_FLETFRAME); // fletframe scope if (scp==NULL) p=cons(ctx,makeint(0),def); @@ -577,9 +576,9 @@ pointer nm,def,scp,nxt; p=cons(ctx,ctx->bindfp,p); p=cons(ctx,nm,p); // name p=cons(ctx,LAMCLOSURE,p); - ff->c.ffp.name=nm; - ff->c.ffp.fclosure=p; - ff->c.ffp.next=nxt; + ff->c.obj.iv[0]=nm; + ff->c.obj.iv[1]=p; + ff->c.obj.iv[2]=nxt; vpush(ff); ctx->fletfp=ff; return(ff);} @@ -588,11 +587,10 @@ pointer makemacrolet(ctx,nm,def,nxt) register context *ctx; pointer nm,def,nxt; { pointer ff; - ff=alloc(wordsizeof(struct fletframe), ELM_FIXED, fletframecp.cix, - wordsizeof(struct fletframe)); - ff->c.ffp.name=nm; - ff->c.ffp.fclosure=cons(ctx,MACRO,def); - ff->c.ffp.next=nxt; + ff=makeobject(C_FLETFRAME); + ff->c.obj.iv[0]=nm; + ff->c.obj.iv[1]=cons(ctx,MACRO,def); + ff->c.obj.iv[2]=nxt; vpush(ff); ctx->fletfp=ff; return(ff);} diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 4cf6fc0b0..62985838d 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -607,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->c.ffp.fclosure; + fn=ffpp->c.obj.iv[1]; fn=ccdr(fn); fn=ccdr(fn); fn=ccdr(fn); ccar(fn)=ctx->fletfp; - fns=ccdr(fns); ffpp=ffpp->c.ffp.next;} + fns=ccdr(fns); ffpp=ffpp->c.obj.iv[2];} result=progn(ctx,ccdr(arg)); ctx->fletfp=ffp; return(result);} diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index fb2faf382..ac1cde21d 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -770,10 +770,10 @@ pointer *argv; else if (isint(argv[0]) && intval(argv[0])==0) return(NIL); else error(E_NOBINDFRAME);} while (bf) { - vpush(cons(ctx,bf->c.bfp.symbol,bf->c.bfp.value)); + vpush(cons(ctx,bf->c.obj.iv[0],bf->c.obj.iv[1])); i++; - if (bf==bf->c.bfp.next) break; - bf=bf->c.bfp.next;} + if (bf==bf->c.obj.iv[2]) break; + bf=bf->c.obj.iv[2];} return(stacknlist(ctx,i));} pointer LISTFUNCTIONBINDINGS(ctx,n,argv) @@ -789,10 +789,10 @@ pointer *argv; 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)); + vpush(cons(ctx,ff->c.obj.iv[0],ff->c.obj.iv[1])); i++; - if (ff==ff->c.ffp.next) break; - ff=ff->c.ffp.next;} + if (ff==ff->c.obj.iv[2]) break; + ff=ff->c.obj.iv[2];} return(stacknlist(ctx,i));} pointer LISTSPECIALBINDINGS(ctx,n,argv) From 28eaf0db4feb71377340c3310ea195d1adb3aa72 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 6 May 2022 16:26:26 +0900 Subject: [PATCH 202/387] Push fletframe before consing in makeflet --- lisp/c/makes.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/makes.c b/lisp/c/makes.c index 960e2d388..35f7867e3 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -564,6 +564,7 @@ register context *ctx; pointer nm,def,scp,nxt; { pointer p,ff; ff=makeobject(C_FLETFRAME); + vpush(ff); // fletframe scope if (scp==NULL) p=cons(ctx,makeint(0),def); @@ -579,7 +580,6 @@ pointer nm,def,scp,nxt; ff->c.obj.iv[0]=nm; ff->c.obj.iv[1]=p; ff->c.obj.iv[2]=nxt; - vpush(ff); ctx->fletfp=ff; return(ff);} From 661409bba08e66fb1f5a2528f591b7a6884ab176 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 6 May 2022 21:26:18 +0900 Subject: [PATCH 203/387] Unwind-protect :clear-external-functions on compilation errors --- lisp/comp/comp.l | 350 +++++++++++++++++++++++----------------------- lisp/comp/trans.l | 2 + 2 files changed, 178 insertions(+), 174 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 5c90f09cd..4cbbe2eb7 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1315,180 +1315,182 @@ (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.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" ) - (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" ) + (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*) + ) + (send trans :clear-external-functions))) (:specials () (mapcar 'car (send idtable :frame 0))) (:copy-compiler () (let ((newcomp) (initcode-save initcodes) (closure-save function-closures)) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index dc3614f26..cf6640e7b 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -743,6 +743,8 @@ register context *ctx; int n; pointer *argv; pointer env;~%" entry) (format cfile " register int i;~%") (format cfile " for (i=0; i<~d; i++) ftab[i]=fcallx;~%" ftab-next)) (format cfile "}~%") + (send self :clear-external-functions)) + (:clear-external-functions () (dolist (ef external-functions) (remprop ef :ftab-index)) ) (:close () From 3be99f0c4a6bc5e25750ee4fb8c21cccde779102 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 26 Oct 2021 21:10:18 +0900 Subject: [PATCH 204/387] Add sys:list-all-function-bindings and optional argument to sys:list-all-bindings --- lisp/c/sysfunc.c | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index ac1cde21d..784c0d102 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -795,6 +795,25 @@ pointer *argv; ff=ff->c.obj.iv[2];} 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++; + if (ff==ff->c.ffp.next) break; + ff=ff->c.ffp.next;} + return(stacknlist(ctx,i));} + pointer LISTSPECIALBINDINGS(ctx,n,argv) register context *ctx; int n; From d50be66752bb276800bb68243f1cdfcdf1e16ca8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 5 Nov 2021 08:10:34 +0900 Subject: [PATCH 205/387] Enable closure compilation --- lisp/c/collector.c | 8 -- lisp/c/eus.c | 12 +- lisp/c/eus.h | 5 +- lisp/c/eus_proto.h | 2 +- lisp/c/makes.c | 5 +- lisp/c/memory.c | 5 +- lisp/comp/comp.l | 267 ++++++++++++++++++++++++++++++++------------- lisp/comp/trans.l | 60 +++++++--- lisp/l/packsym.l | 11 +- 9 files changed, 253 insertions(+), 122 deletions(-) diff --git a/lisp/c/collector.c b/lisp/c/collector.c index 91c8f36fa..7c7f6308d 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 */ diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 31c76e0b1..e59028236 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -795,19 +795,19 @@ static void initclasses() #if (WORD_SIZE == 64) CLOSURE=basicclass("CLOSURE",C_CODE,&closurecp, #if ARM // ARM uses entry2 in struct closure in eus.h - 4,"ENTRY2", + 3,"ENTRY2", #else - 3, + 2, #endif - "ENV0","ENV1","ENV2"); + "ENV0","ENV1"); #else CLOSURE=basicclass("CLOSURE",C_CODE,&closurecp, #if ARM // ARM uses entry2 in struct closure in eus.h - 3,"ENTRY2", + 2,"ENTRY2", #else - 2, + 1, #endif - "ENV1","ENV2"); + "ENV1"); #endif C_CLOSURE=speval(CLOSURE); /* 16 ---new for Solaris */ diff --git a/lisp/c/eus.h b/lisp/c/eus.h index db5536e9a..cab07e90e 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -271,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; @@ -1109,7 +1108,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); diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 99a6b7f25..bd8723f93 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -336,7 +336,7 @@ 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 makebindframe(pointer /*sym*/, pointer /*val*/, pointer /*nxt*/); diff --git a/lisp/c/makes.c b/lisp/c/makes.c index 35f7867e3..82dc024c6 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -506,8 +506,8 @@ int size; mod->c.ldmod.handle=NIL; return(mod);} -pointer makeclosure(code,quote,f,e0,e1,e2) -pointer code,quote,e0,*e1,*e2; +pointer makeclosure(code,quote,f,e0,e1) +pointer code,quote,e0,e1; pointer (*f)(); { register pointer clo; clo=allocobj(CLOSURE, closure, closurecp.cix); @@ -520,7 +520,6 @@ 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) diff --git a/lisp/c/memory.c b/lisp/c/memory.c index 54c14b251..0b55b7972 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -469,7 +469,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*/ diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 4cbbe2eb7..dd86d9dda 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -130,7 +130,7 @@ ; (eval-when (load compile eval) (defclass identifier :super object - :slots (name type binding level offset)) + :slots (name type binding level offset bindframe)) ) ;; binding = (constant, local, global, special) @@ -187,7 +187,11 @@ (eval-when (load compile eval) (defclass stack-frame :super object - :slots (offset specials locals)) + :slots + (type ; 'arg, 'local, or 'flet + 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) @@ -195,7 +199,7 @@ (: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)) ) @@ -210,11 +214,13 @@ closure-level ;currunt closure level 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 ))) @@ -278,7 +284,7 @@ (: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 :load-local (third fdef) (- closure-level (fourth fdef)) (sixth fdef)) (send trans :call-closure (fifth fdef) (length args))) (:variable (var) ;var must be a symbol, ovaf is not allowed here. (let ((result (send idtable :get var scope))) @@ -317,39 +323,62 @@ (send v :binding 'special) )) v)) - (:bind (id binding offset &optional (keyvarp nil)) + (:bind (id frame binding offset &optional keyvarp) (unless (symbolp 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))) + (local (if keyvarp (send frame :local 1))) (arg (send trans :load-arg offset 0)) (t (send self :error "illegal binding"))) (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))) + (:create-frame (type &optional size comment) + (let ((frame (instance stack-frame :init type))) + (when size + (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" type)) + ) + (case type + ((arg local) + (send idtable :create-frame) + (setq scope (send idtable :level)))) + 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" type)))) + (nospecials (f . specials))) (declare (type stack-frame f)) (if (> nospecials 0) (if flag (send trans :unbind-special (f . specials)) (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))) @@ -367,13 +396,14 @@ (when (consp var) (send self :load-ovaf (car var) (cdr var)) (return-from :load-var t)) - (setq var (send self :variable var)) + (unless (derivedp var identifier) + (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)))) + (send trans :load-local (var . offset) (- closure-level (var . level)) (var . bindframe))) ((param arg) - (send trans :load-arg (var . offset) (- closure-level (var . level)))) + (send trans :load-arg (var . offset) (- closure-level (var . level)) (var . bindframe))) ((object) (send trans :load-obj (var . offset) (- closure-level (var . level)))) (unknown @@ -396,9 +426,9 @@ (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)))) + (send trans :store-local (var . offset) (- closure-level (var . level)) (var . bindframe))) + ((param arg) + (send trans :store-arg (var . offset) (- closure-level (var . level)) (var . bindframe))) ((object) (send trans :store-obj (var . offset) (- closure-level (var . level))))))) ) ;eval-when @@ -716,43 +746,78 @@ (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 ((local-list (pop bodies)) (unwind-save unwind-frames) + bindframe vlist) + (setq bindframe (send self :create-frame 'local (length local-list) "seqlet")) + ;; handle declarations (while (and bodies (consp (car bodies)) (eq (caar bodies) 'declare)) (send self :declare (cdr (pop bodies)))) + ;; eval to locals (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)) + offset) + (send self :eval (if (listp init-form) (cadr init-form) nil)) + (setq offset (1- (send trans :offset-from-fp))) + (push (send self :bind var bindframe 'local offset) vlist))) + (setq vlist (nreverse vlist)) + ;; bind frame vector + (dotimes (i (length vlist)) + (let ((v (nth i vlist))) + (send self :load-var v) + (send trans :clearpush-frame (bindframe . offset) i) + (setq (v . bindframe) (bindframe . offset) + (v . offset) i))) + (send trans :reset-vsp) + ;; eval body (send self :progn bodies) + ;; unwind/restore (setq unwind-frames unwind-save) - (send self :delete-frame t))) + (send self :delete-frame 'local t))) (: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) + (setq bindframe (send self :create-frame 'local (length local-list) "parlet")) + ;; handle declarations (while (and bodies (consp (car bodies)) (eq (caar bodies) 'declare)) (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))) + (cond + ((send self :special-variable-p var) + (send bindframe :local 1) ;a trick + (push (cons var offset) vlist)) + (t (push (send self :bind var bindframe 'local offset) vlist))))) + (setq vlist (nreverse vlist)) + ;; bind frame vector + (dotimes (i (length vlist)) + (let ((v (nth i vlist))) + (if (derivedp v identifier) + (progn + (send self :load-var v) + (send trans :clearpush-frame (bindframe . offset) i) + (setq (v . bindframe) (bindframe . offset) + (v . offset) i)) + (progn + (send trans :load-local (cdr v) 0) + (send trans :clearpush-frame (bindframe . offset) i) + (push (cons (car v) i) 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)) + (send trans :load-local (cdr spe) 0 (bindframe . offset)) + (push (send self :bind (car spe) bindframe 'local offset) vlist)) (setq scope (send idtable :level)) + (send trans :reset-vsp) + ;; 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 @@ -821,11 +886,31 @@ (send self :eval lab) (send self :eval val) (send trans :throw)) + (:closure (form &optional comment) + (let ((bindframes (remove-if #'(lambda (f) (not (f . offset))) frames)) + (argframes (remove-if #'(lambda (f) (not (f . offset))) argframes)) + (fletframes (remove-if #'(lambda (f) (not (f . offset))) fletframes)) + frame) + (when (or argframes bindframes fletframes) + ;; create a new vector which holds every and each of the + ;; argument, bind and flet frames + (let ((size (max (if argframes ((car argframes) . offset) 0) + (if bindframes ((car bindframes) . offset) 0) + (if fletframes ((car fletframes) . offset) 0)))) + + (setq frame (send self :create-frame nil (1+ size) comment)) + (dolist (framelist (list argframes bindframes fletframes)) + (dolist (f framelist) + (send trans :load-local (f . offset) 0) + (send trans :store-local (f . offset) 0 (frame . offset)))))) + + ;; makeclosure + (send trans :closure form (not (not frame))))) (: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 + (send self :closure cleaner "unwind protect") ;make cleanup closure (setq newcomp (send self :copy-compiler)) (send self :add-closure (list cleaner @@ -890,35 +975,52 @@ (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))) + (- closure-level (fourth flet-def)) + (sixth flet-def)) (send trans :getfunc fn))) (let ((entry (send self :genlabel "CLO")) ; #'(lambda (...) ...) (newcomp)) - (send trans :closure entry) + (send self :closure entry "lambda-closure") (setq newcomp (send self :copy-compiler)) (send self :add-closure (list entry fn newcomp)) ))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet - (let (entry newcomp newcomps flets-exchange) + (let (entry newcomp newcomps flets-exchange fletframe vlist) + (setq fletframe (send self :create-frame 'flet (length funcs) "flet")) (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) + (send self :closure entry "flet env") + (push (list + (car fn) ;func name + 'closure ;func bind type + (1- (send trans :offset-from-fp)) ;offset + closure-level + entry + nil) ;fletframe + flets) + (send fletframe :local 1) + (push (car flets) vlist) (setq newcomp (send self :copy-compiler)) (push newcomp newcomps) (send self :add-closure (list entry (cons 'lambda (cdr fn)) newcomp))) + (if recursive-scope (send-all newcomps :change-flets flets)) + (setq vlist (nreverse vlist)) + ;; bind fletframe vector + (dotimes (i (length vlist)) + (let ((f (nth i vlist))) + (send trans :load-local (third f) (fourth f)) + (send trans :store-local i 0 (fletframe . offset)) + (setf (third f) i + (sixth f) (fletframe . offset)))) + (send self :progn bodies) (setq flets (nthcdr (length funcs) flets)) - (send trans :del-frame 0 (length funcs)))) + (send self :delete-frame 'flet nil) + (send trans :del-frame (fletframe . specials) (fletframe . locals)))) (:macrolet (funcs bodies) (dolist (fn funcs) (push (list (car fn) 'macrolet `(lambda ,@(cdr fn))) @@ -982,7 +1084,8 @@ (decl-vars nil) (specially-bound nil) (allowotherkeys (memq '&allow-other-keys param)) - (unwind-save unwind-frames)) + (unwind-save unwind-frames) + argframe vlist) (setq req-vars (reverse (nthcdr (length (cond (opt-vars) @@ -1020,7 +1123,7 @@ (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) + (setq argframe (send self :create-frame 'arg)) ;; parse keyword variables (if key-forms (let (init key var svar) @@ -1068,13 +1171,13 @@ ;; (print "bind") (setq i 0) (dolist (v req-vars) ;for all required arguments - (send self :bind v 'arg i) + (push (send self :bind v argframe 'arg i) vlist) (inc i)) ;; initialize all supplied-p variables to t (dolist (svar opt-supplied-vars) (when svar (send trans :load-t) - (send self :bind svar 'local (1- (send trans :offset-from-fp))))) + (push (send self :bind svar argframe 'local (1- (send trans :offset-from-fp))) vlist))) (while (cdr labels) (send trans :check-opt-arg i (car labels)) ;; set supplied-p variables to nil @@ -1085,16 +1188,16 @@ ;; set init value (send self :eval (pop opt-forms)) (send trans :label (pop labels)) - (send self :bind (pop opt-vars) 'local - (1- (send trans :offset-from-fp))) + (push (send self :bind (pop opt-vars) argframe 'local + (1- (send trans :offset-from-fp))) 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)))) + (push (send self :bind rest-var argframe 'local + (1- (send trans :offset-from-fp))) vlist)) ((and (> optn 0) (null key-forms)) (send trans :check-rest-arg i))) (when key-forms (let* ((key-base (send trans :offset-from-fp)) @@ -1106,7 +1209,7 @@ (dolist (svar key-supplied-vars) (when svar (send trans :load-t) - (send self :bind svar 'local key-base) + (push (send self :bind svar argframe 'local key-base) vlist) (inc key-base))) (send trans :parse-key-params (coerce key-names vector) (+ reqn optn) @@ -1131,28 +1234,42 @@ (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) ) + (push (send self :bind vname argframe 'local (+ key-base i) t) vlist)) (t ;non-special - (send self :bind vname 'local (+ key-base i)) + (push (send self :bind vname argframe 'local (+ key-base i)) vlist) (send trans :store-local (+ key-base i) 0) (send trans :label labels)))) ) ) ;;; 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)))) + (push (send self :bind (if (listp av) (car av) av) + argframe 'local + (1- (send trans :offset-from-fp))) vlist)) ;;; type check declaration variables (dolist (id decl-vars) (let ((v (send self :variable id))) (unless (eql (v . binding) 'unknown) (send self :load-var id) (send trans :type-check-declare (v . type))))) +;; set argument frame + (when vlist + (let ((offset (send trans :create-frame (length vlist) "argument frame"))) + (setq (argframe . offset) offset) + (send argframe :local 1) + (setq vlist (nreverse vlist)) + ;; bind argument frame vector + (dotimes (i (length vlist)) + (let ((v (nth i vlist))) + (send self :load-var v) + (send trans :clearpush-frame offset i) + (setq (v . bindframe) offset + (v . binding) 'arg + (v . offset) i))))) ;;; evaluate lambda body (send self :progn forms) (setq unwind-frames unwind-save) - (send self :delete-frame t) + (send self :delete-frame 'arg t) )) (:lambda-block (name arglist bodies cname) (let ((ctime (unix:runtime)) @@ -1200,7 +1317,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 @@ -1223,7 +1340,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 diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index cf6640e7b..b2b3ce0d5 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -72,7 +72,21 @@ (when push (format cfile " local[~d]= ~A;~%" pushcount push) (inc pushcount)) - (setq push nil)) ) + (setq push nil)) + (:create-frame (size &optional comment) + (send self :clearpush) + (prog1 pushcount + (format cfile " local[~d]= makevector(C_VECTOR,~d);" pushcount size) + (if comment (format cfile " /*~A*/" comment)) + (terpri cfile) + (inc pushcount) + (send self :reset-vsp))) + (:clearpush-frame (bindframe count) + (when push + (format cfile " local[~d]->c.vec.v[~d]= ~A;~%" + bindframe count push)) + (setq push nil)) +) (defmethod translator (:quote-entry (q) @@ -153,17 +167,24 @@ (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")) + (:getbase (n argp &optional bindframe) + (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)) + (unless bindframe + (warn "; 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")) @@ -183,12 +204,12 @@ ) (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))) + (format nil "~A[~d]" (send self :getbase level nil bindframe) n))) (:load-obj (n level) (send self :push (format nil "~A[0]->c.obj.iv[~d]" @@ -196,10 +217,10 @@ (: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-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) #+:rgc (let ((p1 (send self :getbase level 'arg)) @@ -573,7 +594,9 @@ (:return () (send self :clearpush) (format cfile " ctx->vsp=local; return(local[0]);}~%") - (if (not (= (dec pushcount) 0)) (warn ":return pushcount is ~d " pushcount))) + (when (not (= (dec pushcount) 0)) + (warn ":return pushcount is ~d~%" pushcount) + (setq pushcount 0))) (:del-frame (spe loc) ;number of special bindings and local variables (send self :store "w") (send self :discard (+ (* 3 spe) loc)) @@ -628,11 +651,14 @@ (if need-unwind (format cfile " unwind(ctx,local+~d);~%" k)) (inc pushcount)) - (:closure (lab) - (send self :clearpush) + (:closure (lab env) + (if env + (send self :store "w") ; store to w before increasing the pushcount + (send self :clearpush)) ; clear other pending values (send self :reset-vsp) (send self :push - (format nil "makeclosure(codevec,quotevec,~A,env,argv,local)" lab))) + (format nil "makeclosure(codevec,quotevec,~A,env,~A)" + lab (if env "w" "NULL")))) (:defun (sym cname doc) (send self :clearpush) (send self :reset-vsp) diff --git a/lisp/l/packsym.l b/lisp/l/packsym.l index f1d429b07..4d6a7a4c3 100644 --- a/lisp/l/packsym.l +++ b/lisp/l/packsym.l @@ -28,14 +28,9 @@ (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) From dd607087d2991bf0480fc577266997f2526f4396 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 21 Dec 2021 15:49:52 +0900 Subject: [PATCH 206/387] Track closure level on nested closures --- lisp/comp/comp.l | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index dd86d9dda..1f4561c09 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -189,6 +189,7 @@ (defclass stack-frame :super object :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 @@ -196,6 +197,7 @@ (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))) @@ -211,7 +213,7 @@ (defclass compiler :super object :slots (idtable ;identifier-table - closure-level ;currunt closure level + closure-level ;current closure level scope ;current variable scope (for sequential let) frames ;list of the number of special bindings fletframes ;list of function frames @@ -344,6 +346,7 @@ v)) (:create-frame (type &optional size comment) (let ((frame (instance stack-frame :init type))) + (setq (frame . level) closure-level) (when size (setq (frame . offset) (send trans :create-frame size comment)) (send frame :local 1)) @@ -887,10 +890,11 @@ (send self :eval val) (send trans :throw)) (:closure (form &optional comment) - (let ((bindframes (remove-if #'(lambda (f) (not (f . offset))) frames)) - (argframes (remove-if #'(lambda (f) (not (f . offset))) argframes)) - (fletframes (remove-if #'(lambda (f) (not (f . offset))) fletframes)) - frame) + (let* ((fn #'(lambda (f) (and (f . offset) (= (f . level) closure-level)))) + (bindframes (remove-if-not fn frames)) + (argframes (remove-if-not fn argframes)) + (fletframes (remove-if-not fn fletframes)) + frame) (when (or argframes bindframes fletframes) ;; create a new vector which holds every and each of the ;; argument, bind and flet frames From ec76c2699db936bf1aa1440aa3980586ef7bca67 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 21 Dec 2021 20:04:44 +0900 Subject: [PATCH 207/387] Add :var-bindframe and support for object-variable closures --- lisp/comp/comp.l | 43 ++++++++++++++++++++++++++++++++----------- lisp/comp/trans.l | 10 +++++----- 2 files changed, 37 insertions(+), 16 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 1f4561c09..49b2d8434 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -308,6 +308,19 @@ (if (consp var) 'ovaf (send (send self :variable var) :binding))) + (:var-bindframe (var) + (if (= closure-level (var . level)) + (var . bindframe) + (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 lambda) + (find-offset frames)) + ((param arg object) + (find-offset argframes)))))) (:special-variable-p (id) (let ((v (send idtable :find id))) (if (null v) @@ -404,11 +417,14 @@ (case (var . binding) ((special) (send trans :load-global (var . name))) ((local let lambda) - (send trans :load-local (var . offset) (- closure-level (var . level)) (var . bindframe))) + (send trans :load-local (var . offset) (- closure-level (var . level)) + (send self :var-bindframe var))) ((param arg) - (send trans :load-arg (var . offset) (- closure-level (var . level)) (var . bindframe))) + (send trans :load-arg (var . offset) (- closure-level (var . level)) + (send self :var-bindframe var))) ((object) - (send trans :load-obj (var . offset) (- closure-level (var . level)))) + (send trans :load-obj (var . offset) (- closure-level (var . level)) + (send self :var-bindframe var))) (unknown (send self :error "declared but unknown variable" (var . name))) ) @@ -425,15 +441,20 @@ 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)) (var . bindframe))) + (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)) (var . bindframe))) - ((object) (send trans :store-obj (var . offset) - (- closure-level (var . level))))))) + (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) @@ -983,10 +1004,10 @@ (sixth flet-def)) (send trans :getfunc fn))) (let ((entry (send self :genlabel "CLO")) ; #'(lambda (...) ...) - (newcomp)) + (newcomp)) (send self :closure entry "lambda-closure") - (setq newcomp (send self :copy-compiler)) - (send self :add-closure (list entry fn newcomp)) + (setq newcomp (send self :copy-compiler)) + (send self :add-closure (list entry fn newcomp)) ))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index b2b3ce0d5..3ca32a614 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -210,10 +210,10 @@ (:load-local (n level &optional bindframe) (send self :push (format nil "~A[~d]" (send self :getbase level nil bindframe) n))) - (:load-obj (n level) + (: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)))) @@ -221,15 +221,15 @@ (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) + (: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);~%" (send self :quote-entry var) (send self :pop))) From f6a2e917131fdcdb29eaa044c0069c6f1aac2222 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 21 Dec 2021 21:28:31 +0900 Subject: [PATCH 208/387] Bind seqlet variables on spot to ensure accurate :copy-compiler results --- lisp/comp/comp.l | 27 +++++++++++---------------- 1 file changed, 11 insertions(+), 16 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 49b2d8434..c8d3d301e 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -347,7 +347,7 @@ ((eq (v . binding) 'special) (send frame :special 1) (case binding - (local (if keyvarp (send frame :local 1))) + ((local let) (if keyvarp (send frame :local 1))) (arg (send trans :load-arg offset 0)) (t (send self :error "illegal binding"))) (push offset unwind-frames) @@ -771,27 +771,22 @@ result-type)) (:let* (bodies) ;sequential let (let ((local-list (pop bodies)) (unwind-save unwind-frames) - bindframe vlist) + bindframe (i 0)) (setq bindframe (send self :create-frame 'local (length local-list) "seqlet")) ;; handle declarations (while (and bodies (consp (car bodies)) (eq (caar bodies) 'declare)) (send self :declare (cdr (pop bodies)))) - ;; eval to locals + ;; eval & bind (dolist (init-form local-list) - (let ((var (if (listp init-form) (car init-form) init-form)) - offset) + (let ((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))) - (push (send self :bind var bindframe 'local offset) vlist))) - (setq vlist (nreverse vlist)) - ;; bind frame vector - (dotimes (i (length vlist)) - (let ((v (nth i vlist))) - (send self :load-var v) - (send trans :clearpush-frame (bindframe . offset) i) - (setq (v . bindframe) (bindframe . offset) - (v . offset) i))) - (send trans :reset-vsp) + (if (send self :special-variable-p var) + (let ((offset (1- (send trans :offset-from-fp)))) + (send self :bind var bindframe 'local offset)) + (let ((v (send self :bind var bindframe 'let i))) + (setq (v . bindframe) (bindframe . offset)) + (send self :store-var v))) + (incf i))) ;; eval body (send self :progn bodies) ;; unwind/restore From 98464235337c21fbc76cd493eb860a37631e381d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 21 Dec 2021 23:06:16 +0900 Subject: [PATCH 209/387] Don't bind special variables to bindframes --- lisp/comp/comp.l | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index c8d3d301e..423d7d03e 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -806,11 +806,9 @@ (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))) - (cond - ((send self :special-variable-p var) - (send bindframe :local 1) ;a trick - (push (cons var offset) vlist)) - (t (push (send self :bind var bindframe 'local offset) vlist))))) + (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)) ;; bind frame vector (dotimes (i (length vlist)) @@ -822,14 +820,13 @@ (setq (v . bindframe) (bindframe . offset) (v . offset) i)) (progn - (send trans :load-local (cdr v) 0) - (send trans :clearpush-frame (bindframe . offset) i) - (push (cons (car v) i) special-list))))) + (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 (cdr spe) 0 (bindframe . offset)) - (push (send self :bind (car spe) bindframe 'local offset) vlist)) + (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)) (send trans :reset-vsp) ;; eval body From 8bef0b886202bada9d4cb9b6693aba40aff8d59e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 22 Dec 2021 00:45:35 +0900 Subject: [PATCH 210/387] Fix flet scope on compiled code --- lisp/comp/comp.l | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 423d7d03e..0e9732718 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1005,6 +1005,8 @@ ;recursive-scope==T for labels, NIL for flet (let (entry newcomp newcomps flets-exchange fletframe vlist) (setq fletframe (send self :create-frame 'flet (length funcs) "flet")) + (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 self :closure entry "flet env") @@ -1018,8 +1020,9 @@ flets) (send fletframe :local 1) (push (car flets) vlist) - (setq newcomp (send self :copy-compiler)) - (push newcomp newcomps) + (when recursive-scope + (setq newcomp (send self :copy-compiler)) + (push newcomp newcomps)) (send self :add-closure (list entry (cons 'lambda (cdr fn)) newcomp))) From 4fffed616e7f8e76374603f97ee380f50f8fcb0c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 22 Dec 2021 00:57:32 +0900 Subject: [PATCH 211/387] Avoid assigning *unbound* to closure slot variables --- lisp/comp/comp.l | 2 +- lisp/comp/trans.l | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 0e9732718..9a44c2e71 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -922,7 +922,7 @@ (send trans :store-local (f . offset) 0 (frame . offset)))))) ;; makeclosure - (send trans :closure form (not (not frame))))) + (send trans :closure form (plusp closure-level) (not (not frame))))) (:unwind-protect (prot cleanup) (let ((cleaner (send self :genlabel "UWP")) (newcomp)) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 3ca32a614..42d574d1c 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -651,14 +651,14 @@ (if need-unwind (format cfile " unwind(ctx,local+~d);~%" k)) (inc pushcount)) - (:closure (lab env) - (if env + (:closure (lab env0 env1) + (if env1 (send self :store "w") ; store to w before increasing the pushcount (send self :clearpush)) ; clear other pending values (send self :reset-vsp) (send self :push - (format nil "makeclosure(codevec,quotevec,~A,env,~A)" - lab (if env "w" "NULL")))) + (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) From d29ab02287dee62cf59c67146ffb1aef8d7a768b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 23 Dec 2021 10:31:46 +0900 Subject: [PATCH 212/387] Fix &aux compilation when there is &allow-other-keys --- lisp/comp/comp.l | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 9a44c2e71..193a48843 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1088,6 +1088,7 @@ (reqn 0) (optn 0) (keyn 0) + (auxn 0) (svar-base 0) (opt-supplied-vars) (opt-vars (memq '&optional param)) @@ -1124,8 +1125,14 @@ 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 @@ -1140,7 +1147,7 @@ (unless (and (symbolp (caddr opt)) (not (constantp svar))) (send self :error "optional supplied variable"))) (push svar opt-supplied-vars))) - (nreverse 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)) (setq argframe (send self :create-frame 'arg)) @@ -1173,10 +1180,10 @@ 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) - (nreverse key-supplied-vars) + (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)) From f7bbcdd23b01251b319b87461caf7d8f8bb07273 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 28 Feb 2022 12:17:49 +0900 Subject: [PATCH 213/387] More fixes to closure compilation --- lisp/comp/comp.l | 180 +++++++++++++++++++++++++--------------------- lisp/comp/trans.l | 17 +++-- 2 files changed, 107 insertions(+), 90 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 193a48843..e10f43088 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -317,9 +317,9 @@ (let ((fr (find-frame frame-list))) (if fr (fr . offset))))) (case (var . binding) - ((local let lambda) + ((local let) (find-offset frames)) - ((param arg object) + ((param arg object lambda) (find-offset argframes)))))) (:special-variable-p (id) (let ((v (send idtable :find id))) @@ -338,7 +338,7 @@ (send v :binding 'special) )) v)) - (:bind (id frame binding offset &optional keyvarp) + (:bind (id frame binding offset &key store keyvarp) (unless (symbolp id) (error type-error "symbol expected for function argument" id)) (let ((v (send self :enter-variable id))) @@ -347,15 +347,17 @@ ((eq (v . binding) 'special) (send frame :special 1) (case binding - ((local let) (if keyvarp (send frame :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 frame :local 1)) (setq (v . binding) binding - (v . offset) offset))) + (v . offset) offset) + (when store + (setq (v . bindframe) (frame . offset)) + (send self :store-var v)))) v)) (:create-frame (type &optional size comment) (let ((frame (instance stack-frame :init type))) @@ -783,9 +785,7 @@ (if (send self :special-variable-p var) (let ((offset (1- (send trans :offset-from-fp)))) (send self :bind var bindframe 'local offset)) - (let ((v (send self :bind var bindframe 'let i))) - (setq (v . bindframe) (bindframe . offset)) - (send self :store-var v))) + (send self :bind var bindframe 'let i :store t)) (incf i))) ;; eval body (send self :progn bodies) @@ -1106,7 +1106,7 @@ (specially-bound nil) (allowotherkeys (memq '&allow-other-keys param)) (unwind-save unwind-frames) - argframe vlist) + argframe) (setq req-vars (reverse (nthcdr (length (cond (opt-vars) @@ -1150,7 +1150,6 @@ (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)) - (setq argframe (send self :create-frame 'arg)) ;; parse keyword variables (if key-forms (let (init key var svar) @@ -1174,6 +1173,7 @@ *keyword-package*))) )) (t (setq init nil var k + svar nil key (intern (symbol-name var) *keyword-package*)))) (setq key-names (cons key key-names) @@ -1195,104 +1195,122 @@ (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 + (+ reqn optn keyn auxn + (if rest-var 1 0) + (count-if #'identity opt-supplied-vars) + (count-if #'identity key-supplied-vars)))) ;; (print "bind") (setq i 0) (dolist (v req-vars) ;for all required arguments - (push (send self :bind v argframe 'arg i) vlist) + (send trans :load-arg i 0) + (if (send self :special-variable-p v) + (let ((offset (1- (send trans :offset-from-fp)))) + (send self :bind v argframe 'local offset)) + (send self :bind v argframe 'arg i :store t)) (inc i)) - ;; initialize all supplied-p variables to t - (dolist (svar opt-supplied-vars) - (when svar - (send trans :load-t) - (push (send self :bind svar argframe 'local (1- (send trans :offset-from-fp))) vlist))) (while (cdr labels) - (send trans :check-opt-arg i (car labels)) - ;; set supplied-p variables to nil - (when (pop opt-supplied-vars) - (send trans :load-nil) - (send trans :store-local svar-base 0) - (inc svar-base)) - ;; set init value - (send self :eval (pop opt-forms)) - (send trans :label (pop labels)) - (push (send self :bind (pop opt-vars) argframe 'local - (1- (send trans :offset-from-fp))) vlist) - (inc i)) + (let ((var (pop opt-vars)) + (svar (pop opt-supplied-vars)) + var-spebase svar-spebase) + (when svar ; initialize supplied-p to t + (send trans :load-t) + (if (send self :special-variable-p svar) + (progn + (setq svar-spebase (1- (send trans :offset-from-fp))) + (send argframe :local 1)) + (setq svar (send self :bind svar argframe 'lambda (+ i svar-base) :store t))) + (inc svar-base)) + (if (send self :special-variable-p var) + (let ((offset (send trans :offset-from-fp))) + (send trans :load-local offset 0) + (setq var-spebase offset) + (send argframe :local 1)) + (progn + (setq var (send self :bind var argframe 'lambda (+ i svar-base))) + (setq (var . bindframe) (argframe . offset)) + (send self :load-var var))) + (send trans :check-opt-arg i (car labels)) + (when svar ; set supplied-p to nil + (send trans :load-nil) + (if svar-spebase + (send trans :store-local svar-base 0) + (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)) + (when var-spebase + (send trans :load-local var-spebase 0) + (send self :bind var argframe 'local var-spebase)) + (when svar-spebase + (send trans :load-local svar-spebase 0) + (send self :bind svar argframe 'local svar-spebase)) + (inc i))) (when labels (send trans :label (pop labels))) (cond (rest-var (send trans :rest (+ reqn optn)) - (push (send self :bind rest-var argframe 'local - (1- (send trans :offset-from-fp))) vlist)) + (send self :bind rest-var argframe 'lambda (+ i svar-base) :store t) + (inc i)) ((and (> optn 0) (null key-forms)) (send trans :check-rest-arg i))) (when key-forms - (let* ((key-base (send trans :offset-from-fp)) - (svar-key-base key-base) - vname svar label2) - ;; reset vsp + (let ((key-base (+ i svar-base)) + svar-spebase) (send trans :reset-vsp) - ;; initialize all supplied-p variables to t - (dolist (svar key-supplied-vars) - (when svar - (send trans :load-t) - (push (send self :bind svar argframe 'local key-base) vlist) - (inc key-base))) + ;; bind given arguments (send trans :parse-key-params (coerce key-names vector) (+ reqn optn) - keyn allowotherkeys) - (dotimes (i keyn) + (argframe . offset) (+ i svar-base) allowotherkeys) + (inc i keyn) + ;; 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 - (setq vname (pop key-vars)) - (setq svar (pop key-supplied-vars)) - ;; set supplied-p variables to nil - (when svar + (when svar ; set supplied-p variables to t + (send trans :load-t) + (if (send self :special-variable-p svar) + (progn + (setq svar-spebase (1- (send trans :offset-from-fp))) + (send argframe :local 1)) + (setq svar (send self :bind svar argframe 'lambda (+ i svar-base) :store t))) + (inc svar-base)) + (send trans :check-key-arg j labels) + (when svar ; set supplied-p variables to nil (send trans :load-nil) - (send trans :store-local svar-key-base 0) - (inc svar-key-base)) - (send self :eval (pop key-inits)) + (if svar-spebase + (send trans :store-local svar-base 0) + (send self :store-var svar))) ;; set default values - (cond ((send self :special-variable-p vname) - (setq label2 (send self :genlabel "KEY")) - (send trans :jump label2) + (send self :eval (pop key-inits)) + (cond ((send self :special-variable-p var) + (send trans :store-local (+ key-base j) 0 (argframe . offset)) (send trans :label labels) - (send trans :adjust 1) - (send trans :load-local (+ i key-base) 0) - (send trans :label label2) - (push (send self :bind vname argframe 'local (+ key-base i) t) vlist)) + (send trans :load-local (+ key-base j) 0 (argframe . offset)) + (send self :bind var argframe 'local (+ key-base j))) (t ;non-special - (push (send self :bind vname argframe 'local (+ key-base i)) vlist) - (send trans :store-local (+ key-base i) 0) - (send trans :label labels)))) + (send self :bind var argframe 'lambda (+ key-base j) :store t) + (send trans :label labels))) + (when svar-spebase + (send trans :load-local svar-spebase 0) + (send self :bind svar argframe 'local svar-spebase)))) ) ) ;;; bind aux variables (dolist (av aux-vars) - (if (consp av) (send self :eval (cadr av)) (send self :eval nil)) - (push (send self :bind (if (listp av) (car av) av) - argframe 'local - (1- (send trans :offset-from-fp))) vlist)) + (if (consp av) (send self :eval (cadr av)) (send trans :load-nil)) + (send self :bind (if (listp av) (car av) av) argframe 'lambda + (+ i svar-base) + :store t) + (inc i)) ;;; type check declaration variables (dolist (id decl-vars) (let ((v (send self :variable id))) (unless (eql (v . binding) 'unknown) (send self :load-var id) (send trans :type-check-declare (v . type))))) -;; set argument frame - (when vlist - (let ((offset (send trans :create-frame (length vlist) "argument frame"))) - (setq (argframe . offset) offset) - (send argframe :local 1) - (setq vlist (nreverse vlist)) - ;; bind argument frame vector - (dotimes (i (length vlist)) - (let ((v (nth i vlist))) - (send self :load-var v) - (send trans :clearpush-frame offset i) - (setq (v . bindframe) offset - (v . binding) 'arg - (v . offset) i))))) ;;; evaluate lambda body (send self :progn forms) (setq unwind-frames unwind-save) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 42d574d1c..6c05e9e55 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -148,8 +148,8 @@ (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)) + (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)) ) @@ -157,14 +157,13 @@ (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) + (:parse-key-params (keyvec req+opt bindframe offset allowotherkeys) (send self :clearpush) (format cfile - " n=parsekeyparams(fqv[~d], &argv[~d], n-~d, local+~d, ~A);~%" + " n=parsekeyparams(fqv[~d], &argv[~d], n-~d, ~A+~d, ~A);~%" (send self :quote-entry keyvec) req+opt req+opt - pushcount - (if allowotherkeys 1 0)) - (inc pushcount keyn)) + (send self :getbase 0 nil bindframe) offset + (if allowotherkeys 1 0))) (:check-key-arg (n lab) (format cfile " if (n & (1<<~A)) goto ~A;~%" n lab)) (:getbase (n argp &optional bindframe) @@ -181,7 +180,7 @@ "c.clo.env0->")) (dec n)) (unless bindframe - (warn "; empty bindframe in closure reference!~%")) + (error value-error "; empty bindframe in closure reference!~%")) (setq f (concatenate string f (format nil "c.clo.env1->c.vec.v[~d]->c.vec.v" (or bindframe -1)))) @@ -595,7 +594,7 @@ (send self :clearpush) (format cfile " ctx->vsp=local; return(local[0]);}~%") (when (not (= (dec pushcount) 0)) - (warn ":return pushcount is ~d~%" pushcount) + (error value-error ":return pushcount is ~d~%" pushcount) (setq pushcount 0))) (:del-frame (spe loc) ;number of special bindings and local variables (send self :store "w") From a1d3afc014b7a98a20bb073f1986f3a07b84d877 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 28 Feb 2022 12:18:29 +0900 Subject: [PATCH 214/387] Fix compilation notes when already installed from apt --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 1d31d267d..68cd112ee 100644 --- a/README.md +++ b/README.md @@ -27,8 +27,8 @@ $ 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 From 642c2bdf1a7b1a8d5ee489bfae0f05eb4dc5bd43 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 28 Feb 2022 20:47:13 +0900 Subject: [PATCH 215/387] Add argument frame comment --- lisp/comp/comp.l | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index e10f43088..c216fbb62 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1200,7 +1200,8 @@ (+ reqn optn keyn auxn (if rest-var 1 0) (count-if #'identity opt-supplied-vars) - (count-if #'identity key-supplied-vars)))) + (count-if #'identity key-supplied-vars)) + "argv")) ;; (print "bind") (setq i 0) (dolist (v req-vars) ;for all required arguments From e4691fe047c69b31565dd96d199b71ae781c59c8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 1 Mar 2022 12:30:40 +0900 Subject: [PATCH 216/387] Use pre-assigned bindframe when available --- lisp/comp/comp.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index c216fbb62..d3501afd5 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -309,7 +309,7 @@ 'ovaf (send (send self :variable var) :binding))) (:var-bindframe (var) - (if (= closure-level (var . level)) + (if (or (var . bindframe) (= closure-level (var . level))) (var . bindframe) (labels ((find-frame (frame-list) (find-if #'(lambda (frame) (= (frame . level) (var . level))) frame-list)) From deded449b5eac362d1807010ed78f8cad99303c2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 1 Mar 2022 14:41:06 +0900 Subject: [PATCH 217/387] Consider closure-level in flet binding --- lisp/comp/comp.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index d3501afd5..8b7c9d81e 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1032,7 +1032,7 @@ ;; bind fletframe vector (dotimes (i (length vlist)) (let ((f (nth i vlist))) - (send trans :load-local (third f) (fourth f)) + (send trans :load-local (third f) (- closure-level (fourth f))) (send trans :store-local i 0 (fletframe . offset)) (setf (third f) i (sixth f) (fletframe . offset)))) From 345c152f38872fe9df59bd145b7adc7f99d6ee4d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 8 May 2022 18:04:13 +0900 Subject: [PATCH 218/387] Skip zero-size frames --- lisp/comp/comp.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 8b7c9d81e..78626d703 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -362,7 +362,7 @@ (:create-frame (type &optional size comment) (let ((frame (instance stack-frame :init type))) (setq (frame . level) closure-level) - (when size + (when (and size (> size 0)) (setq (frame . offset) (send trans :create-frame size comment)) (send frame :local 1)) (case type From 30e483c836c3d53d16568811b0984ebb15dfc0b8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 8 May 2022 23:42:10 +0900 Subject: [PATCH 219/387] Default to not using bind frames --- lisp/comp/comp.l | 54 ++++++++++++++---------------------------------- 1 file changed, 15 insertions(+), 39 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 78626d703..3bbbf330f 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -773,20 +773,18 @@ result-type)) (:let* (bodies) ;sequential let (let ((local-list (pop bodies)) (unwind-save unwind-frames) - bindframe (i 0)) - (setq bindframe (send self :create-frame 'local (length local-list) "seqlet")) + bindframe) + (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)))) ;; eval & bind (dolist (init-form local-list) - (let ((var (if (listp init-form) (car init-form) init-form))) + (let ((var (if (listp init-form) (car init-form) init-form)) + offset) (send self :eval (if (listp init-form) (cadr init-form) nil)) - (if (send self :special-variable-p var) - (let ((offset (1- (send trans :offset-from-fp)))) - (send self :bind var bindframe 'local offset)) - (send self :bind var bindframe 'let i :store t)) - (incf i))) + (setq offset (1- (send trans :offset-from-fp))) + (send self :bind var bindframe 'local offset))) ;; eval body (send self :progn bodies) ;; unwind/restore @@ -795,7 +793,7 @@ (:let (bodies) ;parallel let (let ((local-list (pop bodies)) (unwind-save unwind-frames) bindframe special-list vlist) - (setq bindframe (send self :create-frame 'local (length local-list) "parlet")) + (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)))) @@ -810,25 +808,17 @@ (push (list var offset) vlist) (push (send self :bind var bindframe 'local offset) vlist)))) (setq vlist (nreverse vlist)) - ;; bind frame vector - (dotimes (i (length vlist)) - (let ((v (nth i vlist))) - (if (derivedp v identifier) - (progn - (send self :load-var v) - (send trans :clearpush-frame (bindframe . offset) i) - (setq (v . bindframe) (bindframe . offset) - (v . offset) i)) - (progn - (send bindframe :local 1) ;a trick - (push v special-list))))) + ;; 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) (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)) - (send trans :reset-vsp) ;; eval body (send self :progn bodies) ;; unwind/restore @@ -1003,8 +993,8 @@ ))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet - (let (entry newcomp newcomps flets-exchange fletframe vlist) - (setq fletframe (send self :create-frame 'flet (length funcs) "flet")) + (let (entry newcomp newcomps flets-exchange fletframe) + (setq fletframe (send self :create-frame 'flet)) (if (not recursive-scope) ; copy compiler before binding the functions (setq newcomp (send self :copy-compiler))) (dolist (fn funcs) @@ -1019,7 +1009,6 @@ nil) ;fletframe flets) (send fletframe :local 1) - (push (car flets) vlist) (when recursive-scope (setq newcomp (send self :copy-compiler)) (push newcomp newcomps)) @@ -1028,14 +1017,6 @@ (if recursive-scope (send-all newcomps :change-flets flets)) - (setq vlist (nreverse vlist)) - ;; bind fletframe vector - (dotimes (i (length vlist)) - (let ((f (nth i vlist))) - (send trans :load-local (third f) (- closure-level (fourth f))) - (send trans :store-local i 0 (fletframe . offset)) - (setf (third f) i - (sixth f) (fletframe . offset)))) (send self :progn bodies) (setq flets (nthcdr (length funcs) flets)) @@ -1196,12 +1177,7 @@ (if rest-var 1 (if key-forms keyn 0)))) ;; create argument frame - (setq argframe (send self :create-frame 'arg - (+ reqn optn keyn auxn - (if rest-var 1 0) - (count-if #'identity opt-supplied-vars) - (count-if #'identity key-supplied-vars)) - "argv")) + (setq argframe (send self :create-frame 'arg)) ;; (print "bind") (setq i 0) (dolist (v req-vars) ;for all required arguments From 218d030044397871c78ca3235e9dc9cbabbfd6b9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 09:29:53 +0900 Subject: [PATCH 220/387] Enable on-demand bind frames in :let --- lisp/comp/comp.l | 51 ++++++++++++++++++++++++++++++++++++++++------- lisp/comp/trans.l | 5 +++-- 2 files changed, 47 insertions(+), 9 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 3bbbf330f..3d4b3cba5 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -214,6 +214,7 @@ :slots (idtable ;identifier-table closure-level ;current closure level + closure-vars ;closure variable counter scope ;current variable scope (for sequential let) frames ;list of the number of special bindings fletframes ;list of function frames @@ -224,6 +225,7 @@ initcodes ;initialize codes in "eusmain" flets ;list of flet frames unwind-frames ;frames need to unwound when jumps + avant-mode ;pre-evaluation mode flag symstr ))) (defvar *compiler-symid* 0) @@ -419,6 +421,8 @@ (case (var . binding) ((special) (send trans :load-global (var . name))) ((local let lambda) + (if (and avant-mode (not (var . bindframe)) (> closure-level (var . level))) + (setq (var . bindframe) t)) (send trans :load-local (var . offset) (- closure-level (var . level)) (send self :var-bindframe var))) ((param arg) @@ -791,7 +795,7 @@ (setq unwind-frames unwind-save) (send self :delete-frame 'local t))) (:let (bodies) ;parallel let - (let ((local-list (pop bodies)) (unwind-save unwind-frames) + (let ((local-list (pop bodies)) (unwind-save unwind-frames) (closure-save closure-vars) bindframe special-list vlist) (setq bindframe (send self :create-frame 'local)) ;; handle declarations @@ -819,10 +823,35 @@ (send trans :load-local (cadr spe) 0) (send self :bind (car spe) bindframe 'local offset))) (setq scope (send idtable :level)) + ;; pre-evaluate body + (let ((cfile (trans . cfile)) + (push (trans . push)) + (pushcount (trans . pushcount))) + (setq avant-mode t) + (setq (trans . cfile) nil) + (send self :progn bodies) + (setq (trans . cfile) cfile) + (setq (trans . push) push) + (setq (trans . pushcount) pushcount) + (setq avant-mode nil)) + ;; bind frame vector + (setq vlist + (remove-if-not #'(lambda (v) (and (derivedp v identifier) (v . bindframe))) vlist)) + (when vlist + (send trans :reset-vsp) + (setq (bindframe . offset) (send trans :create-frame (length vlist) "parlet")) + (send bindframe :local 1)) + (dolist (v vlist) + (send self :load-var v) + (send trans :clearpush-frame (bindframe . offset) closure-vars) + (setq (v . bindframe) (bindframe . offset) + (v . offset) closure-vars) + (inc closure-vars)) ;; eval body (send self :progn bodies) ;; unwind/restore (setq unwind-frames unwind-save) + (setq closure-vars closure-save) (send self :delete-frame 'local t))) (:cond (clauses) (let (clause pred next t-found (exit (send self :genlabel "CON"))) @@ -985,12 +1014,19 @@ (- closure-level (fourth flet-def)) (sixth flet-def)) (send trans :getfunc fn))) - (let ((entry (send self :genlabel "CLO")) ; #'(lambda (...) ...) - (newcomp)) - (send self :closure entry "lambda-closure") - (setq newcomp (send self :copy-compiler)) - (send self :add-closure (list entry fn newcomp)) - ))) + (let (entry newcomp) ; #'(lambda (...) ...) + (if avant-mode + (progn + (when avant-mode + (setq newcomp (send self :copy-compiler)) + (setq (newcomp . idtable) idtable) + (send newcomp :lambda (cadr fn) (cddr fn)) + (send trans :discard 1))) + (progn + (setq entry (send self :genlabel "CLO")) + (send self :closure entry "lambda-closure") + (setq newcomp (send self :copy-compiler)) + (send self :add-closure (list entry fn newcomp))))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet (let (entry newcomp newcomps flets-exchange fletframe) @@ -1645,6 +1681,7 @@ idtable (instance identifier-table :init) scope 0 closure-level 0 + closure-vars 0 symstr "") self) ) ; defmethod diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 6c05e9e55..39ca8764a 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -167,6 +167,7 @@ (:check-key-arg (n lab) (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 @@ -180,7 +181,7 @@ "c.clo.env0->")) (dec n)) (unless bindframe - (error value-error "; empty bindframe in closure reference!~%")) + (warn "; empty bindframe in closure reference!~%")) (setq f (concatenate string f (format nil "c.clo.env1->c.vec.v[~d]->c.vec.v" (or bindframe -1)))) @@ -594,7 +595,7 @@ (send self :clearpush) (format cfile " ctx->vsp=local; return(local[0]);}~%") (when (not (= (dec pushcount) 0)) - (error value-error ":return pushcount is ~d~%" pushcount) + (warn ":return pushcount is ~d~%" pushcount) (setq pushcount 0))) (:del-frame (spe loc) ;number of special bindings and local variables (send self :store "w") From 8ddf411936fe00e2bcd54c526b97952f788518ab Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 09:41:32 +0900 Subject: [PATCH 221/387] Add :copy-translator --- lisp/comp/comp.l | 12 +++--------- lisp/comp/trans.l | 18 ++++++++++++------ 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 3d4b3cba5..3f32daa73 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -824,16 +824,10 @@ (send self :bind (car spe) bindframe 'local offset))) (setq scope (send idtable :level)) ;; pre-evaluate body - (let ((cfile (trans . cfile)) - (push (trans . push)) - (pushcount (trans . pushcount))) + (let ((trans (send trans :copy-translator))) (setq avant-mode t) - (setq (trans . cfile) nil) - (send self :progn bodies) - (setq (trans . cfile) cfile) - (setq (trans . push) push) - (setq (trans . pushcount) pushcount) - (setq avant-mode nil)) + (unwind-protect (send self :progn bodies) + (setq avant-mode nil))) ;; bind frame vector (setq vlist (remove-if-not #'(lambda (v) (and (derivedp v identifier) (v . bindframe))) vlist)) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 39ca8764a..13403776b 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -30,7 +30,7 @@ (t s)))) (defclass translator :super object - :slots (cfile hfile push pushcount quotev)) + :slots (cfile hfile push pushcount quotev avant-mode)) (eval-when (load eval) @@ -180,8 +180,8 @@ (setq f (concatenate string f "c.clo.env0->")) (dec n)) - (unless bindframe - (warn "; empty bindframe in closure reference!~%")) + (when (and (not bindframe) (not avant-mode)) + (error value-error "; empty bindframe in closure reference!~%")) (setq f (concatenate string f (format nil "c.clo.env1->c.vec.v[~d]->c.vec.v" (or bindframe -1)))) @@ -594,9 +594,8 @@ (:return () (send self :clearpush) (format cfile " ctx->vsp=local; return(local[0]);}~%") - (when (not (= (dec pushcount) 0)) - (warn ":return pushcount is ~d~%" pushcount) - (setq pushcount 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)) @@ -690,6 +689,13 @@ (:declare-forward-function (name) (format hfile "static pointer ~A();~%" name)) (:quote () quotev) + (:copy-translator () + (let ((newtrans)) + (setq newtrans (copy-object self)) + (setq (newtrans . cfile) nil) + (setq (newtrans . hfile) nil) + (setq (newtrans . avant-mode) t) + newtrans)) (:init () (setq push nil pushcount 0 )) From a1cd3237de55408fba43f72b67ee37b777411f07 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 09:57:40 +0900 Subject: [PATCH 222/387] Enable on-demand bind frames in :let* --- lisp/comp/comp.l | 31 +++++++++++++++++++++++++------ 1 file changed, 25 insertions(+), 6 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 3f32daa73..b33b13f07 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -776,23 +776,42 @@ (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) - bindframe) + (let ((local-list (pop bodies)) (unwind-save unwind-frames) (closure-save closure-vars) + bindframe vlist) (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)))) - ;; eval & bind + ;; eval to locals (dolist (init-form local-list) (let ((var (if (listp init-form) (car init-form) init-form)) offset) (send self :eval (if (listp init-form) (cadr init-form) nil)) (setq offset (1- (send trans :offset-from-fp))) - (send self :bind var bindframe 'local offset))) + (push (send self :bind var bindframe 'local offset) vlist))) + ;; pre-evaluate body + (let ((trans (send trans :copy-translator))) + (setq avant-mode t) + (unwind-protect (send self :progn bodies) + (setq avant-mode nil))) + ;; bind frame vector + (setq vlist + (remove-if-not #'(lambda (v) (v . bindframe)) vlist)) + (when vlist + (send trans :reset-vsp) + (setq (bindframe . offset) (send trans :create-frame (length vlist) "seqlet")) + (send bindframe :local 1)) + (dolist (v vlist) + (send self :load-var v) + (send trans :clearpush-frame (bindframe . offset) closure-vars) + (setq (v . bindframe) (bindframe . offset) + (v . offset) closure-vars) + (inc closure-vars)) ;; eval body (send self :progn bodies) - ;; unwind/restore - (setq unwind-frames unwind-save) + ;; unwind/restore + (setq unwind-frames unwind-save) + (setq closure-vars closure-save) (send self :delete-frame 'local t))) (:let (bodies) ;parallel let (let ((local-list (pop bodies)) (unwind-save unwind-frames) (closure-save closure-vars) From b66d7031f830c49daa1c8c111cd101fb731ce04e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 10:21:24 +0900 Subject: [PATCH 223/387] Use local counts on let binding and set avant-mode as a global parameter --- lisp/comp/comp.l | 56 ++++++++++++++++++++--------------------------- lisp/comp/trans.l | 4 ++-- 2 files changed, 26 insertions(+), 34 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index b33b13f07..84ba667b7 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -214,7 +214,6 @@ :slots (idtable ;identifier-table closure-level ;current closure level - closure-vars ;closure variable counter scope ;current variable scope (for sequential let) frames ;list of the number of special bindings fletframes ;list of function frames @@ -225,7 +224,6 @@ initcodes ;initialize codes in "eusmain" flets ;list of flet frames unwind-frames ;frames need to unwound when jumps - avant-mode ;pre-evaluation mode flag symstr ))) (defvar *compiler-symid* 0) @@ -776,7 +774,7 @@ (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) (closure-save closure-vars) + (let ((local-list (pop bodies)) (unwind-save unwind-frames) bindframe vlist) (setq bindframe (send self :create-frame 'local)) ;; handle declarations @@ -790,10 +788,9 @@ (setq offset (1- (send trans :offset-from-fp))) (push (send self :bind var bindframe 'local offset) vlist))) ;; pre-evaluate body - (let ((trans (send trans :copy-translator))) - (setq avant-mode t) - (unwind-protect (send self :progn bodies) - (setq avant-mode nil))) + (let ((trans (send trans :copy-translator)) + (avant-mode t)) + (send self :progn bodies)) ;; bind frame vector (setq vlist (remove-if-not #'(lambda (v) (v . bindframe)) vlist)) @@ -801,20 +798,19 @@ (send trans :reset-vsp) (setq (bindframe . offset) (send trans :create-frame (length vlist) "seqlet")) (send bindframe :local 1)) - (dolist (v vlist) - (send self :load-var v) - (send trans :clearpush-frame (bindframe . offset) closure-vars) - (setq (v . bindframe) (bindframe . offset) - (v . offset) closure-vars) - (inc closure-vars)) + (dotimes (i (length vlist)) + (let ((v (nth i vlist))) + (send self :load-var v) + (send trans :clearpush-frame (bindframe . offset) i) + (setq (v . bindframe) (bindframe . offset) + (v . offset) i))) ;; eval body (send self :progn bodies) ;; unwind/restore (setq unwind-frames unwind-save) - (setq closure-vars closure-save) (send self :delete-frame 'local t))) (:let (bodies) ;parallel let - (let ((local-list (pop bodies)) (unwind-save unwind-frames) (closure-save closure-vars) + (let ((local-list (pop bodies)) (unwind-save unwind-frames) bindframe special-list vlist) (setq bindframe (send self :create-frame 'local)) ;; handle declarations @@ -843,10 +839,9 @@ (send self :bind (car spe) bindframe 'local offset))) (setq scope (send idtable :level)) ;; pre-evaluate body - (let ((trans (send trans :copy-translator))) - (setq avant-mode t) - (unwind-protect (send self :progn bodies) - (setq avant-mode nil))) + (let ((trans (send trans :copy-translator)) + (avant-mode t)) + (send self :progn bodies)) ;; bind frame vector (setq vlist (remove-if-not #'(lambda (v) (and (derivedp v identifier) (v . bindframe))) vlist)) @@ -854,17 +849,16 @@ (send trans :reset-vsp) (setq (bindframe . offset) (send trans :create-frame (length vlist) "parlet")) (send bindframe :local 1)) - (dolist (v vlist) - (send self :load-var v) - (send trans :clearpush-frame (bindframe . offset) closure-vars) - (setq (v . bindframe) (bindframe . offset) - (v . offset) closure-vars) - (inc closure-vars)) + (dotimes (i (length vlist)) + (let ((v (nth i vlist))) + (send self :load-var v) + (send trans :clearpush-frame (bindframe . offset) i) + (setq (v . bindframe) (bindframe . offset) + (v . offset) i))) ;; eval body (send self :progn bodies) ;; unwind/restore (setq unwind-frames unwind-save) - (setq closure-vars closure-save) (send self :delete-frame 'local t))) (:cond (clauses) (let (clause pred next t-found (exit (send self :genlabel "CON"))) @@ -1030,11 +1024,10 @@ (let (entry newcomp) ; #'(lambda (...) ...) (if avant-mode (progn - (when avant-mode - (setq newcomp (send self :copy-compiler)) - (setq (newcomp . idtable) idtable) - (send newcomp :lambda (cadr fn) (cddr fn)) - (send trans :discard 1))) + (setq newcomp (send self :copy-compiler)) + (setq (newcomp . idtable) idtable) + (send newcomp :lambda (cadr fn) (cddr fn)) + (send trans :discard 1)) (progn (setq entry (send self :genlabel "CLO")) (send self :closure entry "lambda-closure") @@ -1694,7 +1687,6 @@ idtable (instance identifier-table :init) scope 0 closure-level 0 - closure-vars 0 symstr "") self) ) ; defmethod diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 13403776b..7f04dcc2d 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -30,12 +30,13 @@ (t s)))) (defclass translator :super object - :slots (cfile hfile push pushcount quotev avant-mode)) + :slots (cfile hfile push pushcount quotev)) (eval-when (load eval) (defparameter ftab-next 0) (defparameter external-functions nil) +(defparameter avant-mode nil) (defun ftab-index (sym) (let ((index (get sym :ftab-index))) @@ -694,7 +695,6 @@ (setq newtrans (copy-object self)) (setq (newtrans . cfile) nil) (setq (newtrans . hfile) nil) - (setq (newtrans . avant-mode) t) newtrans)) (:init () (setq push nil From c74a06ee843db579d07ab0c74d6d46d401db58ff Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 15:17:18 +0900 Subject: [PATCH 224/387] Default to not using bind frames in argument frames --- lisp/comp/comp.l | 79 +++++++++++------------------------------------ lisp/comp/trans.l | 13 ++++---- 2 files changed, 25 insertions(+), 67 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 84ba667b7..bfe34b087 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1112,7 +1112,6 @@ (optn 0) (keyn 0) (auxn 0) - (svar-base 0) (opt-supplied-vars) (opt-vars (memq '&optional param)) (rest-var (memq '&rest param)) @@ -1223,67 +1222,37 @@ ;; (print "bind") (setq i 0) (dolist (v req-vars) ;for all required arguments - (send trans :load-arg i 0) - (if (send self :special-variable-p v) - (let ((offset (1- (send trans :offset-from-fp)))) - (send self :bind v argframe 'local offset)) - (send self :bind v argframe 'arg i :store t)) - (inc i)) + (send self :bind v argframe 'arg i) + (inc i)) (while (cdr labels) (let ((var (pop opt-vars)) - (svar (pop opt-supplied-vars)) - var-spebase svar-spebase) + (svar (pop opt-supplied-vars))) (when svar ; initialize supplied-p to t (send trans :load-t) - (if (send self :special-variable-p svar) - (progn - (setq svar-spebase (1- (send trans :offset-from-fp))) - (send argframe :local 1)) - (setq svar (send self :bind svar argframe 'lambda (+ i svar-base) :store t))) - (inc svar-base)) - (if (send self :special-variable-p var) - (let ((offset (send trans :offset-from-fp))) - (send trans :load-local offset 0) - (setq var-spebase offset) - (send argframe :local 1)) - (progn - (setq var (send self :bind var argframe 'lambda (+ i svar-base))) - (setq (var . bindframe) (argframe . offset)) - (send self :load-var var))) + (setq svar (send self :bind svar argframe 'local (1- (send trans :offset-from-fp))))) (send trans :check-opt-arg i (car labels)) (when svar ; set supplied-p to nil (send trans :load-nil) - (if svar-spebase - (send trans :store-local svar-base 0) - (send self :store-var svar))) + (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)) - (when var-spebase - (send trans :load-local var-spebase 0) - (send self :bind var argframe 'local var-spebase)) - (when svar-spebase - (send trans :load-local svar-spebase 0) - (send self :bind svar argframe 'local svar-spebase)) + (send self :bind var argframe 'local (1- (send trans :offset-from-fp))) (inc i))) (when labels (send trans :label (pop labels))) (cond (rest-var (send trans :rest (+ reqn optn)) - (send self :bind rest-var argframe 'lambda (+ i svar-base) :store t) - (inc i)) + (send self :bind rest-var argframe 'local (1- (send trans :offset-from-fp)))) ((and (> optn 0) (null key-forms)) (send trans :check-rest-arg i))) (when key-forms - (let ((key-base (+ i svar-base)) - svar-spebase) + (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) - (argframe . offset) (+ i svar-base) allowotherkeys) - (inc i keyn) + keyn allowotherkeys) ;; bind defaults / supplied arguments (dotimes (j keyn) (let ((var (pop key-vars)) @@ -1291,39 +1260,27 @@ (setq labels (send self :genlabel "KEY")) (when svar ; set supplied-p variables to t (send trans :load-t) - (if (send self :special-variable-p svar) - (progn - (setq svar-spebase (1- (send trans :offset-from-fp))) - (send argframe :local 1)) - (setq svar (send self :bind svar argframe 'lambda (+ i svar-base) :store t))) - (inc svar-base)) + (setq svar (send self :bind svar argframe 'local (1- (send trans :offset-from-fp))))) (send trans :check-key-arg j labels) (when svar ; set supplied-p variables to nil (send trans :load-nil) - (if svar-spebase - (send trans :store-local svar-base 0) - (send self :store-var svar))) + (send self :store-var svar)) ;; set default values (send self :eval (pop key-inits)) (cond ((send self :special-variable-p var) - (send trans :store-local (+ key-base j) 0 (argframe . offset)) + (send trans :store-local (+ key-base j) 0) (send trans :label labels) - (send trans :load-local (+ key-base j) 0 (argframe . offset)) - (send self :bind var argframe 'local (+ key-base j))) + (send trans :load-local (+ key-base j) 0) + (send self :bind var argframe 'local (+ key-base j) :keyvarp t)) (t ;non-special - (send self :bind var argframe 'lambda (+ key-base j) :store t) - (send trans :label labels))) - (when svar-spebase - (send trans :load-local svar-spebase 0) - (send self :bind svar argframe 'local svar-spebase)))) + (send self :bind var argframe 'local (+ key-base j) :store t) + (send trans :label labels))))) ) ) ;;; bind aux variables (dolist (av aux-vars) (if (consp av) (send self :eval (cadr av)) (send trans :load-nil)) - (send self :bind (if (listp av) (car av) av) argframe 'lambda - (+ i svar-base) - :store t) - (inc i)) + (send self :bind (if (listp av) (car av) av) argframe 'local + (1- (send trans :offset-from-fp)))) ;;; type check declaration variables (dolist (id decl-vars) (let ((v (send self :variable id))) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 7f04dcc2d..bc482d79c 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -149,8 +149,8 @@ (format cfile " if (n~A~d) maerror();~%" (if (= opt 0) "!=" "<") req))) ) (:check-opt-arg (m lab) - (format cfile " if (n>=~d) { ~A=(argv[~d]); goto ~A;}~%" - (1+ m) (send self :pop) m lab)) + (format cfile " if (n>=~d) { local[~d]=(argv[~d]); goto ~A;}~%" + (1+ m) pushcount m lab)) (:check-rest-arg (m) (if (> *safety* 0) (format cfile " if (n>~d) maerror();~%" m)) ) @@ -158,13 +158,14 @@ (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 bindframe offset allowotherkeys) + (:parse-key-params (keyvec req+opt keyn allowotherkeys) (send self :clearpush) (format cfile - " n=parsekeyparams(fqv[~d], &argv[~d], n-~d, ~A+~d, ~A);~%" + " n=parsekeyparams(fqv[~d], &argv[~d], n-~d, local+~d, ~A);~%" (send self :quote-entry keyvec) req+opt req+opt - (send self :getbase 0 nil bindframe) offset - (if allowotherkeys 1 0))) + 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 &optional bindframe) From d52d21508ba3b82ab913cb446195752c6a7ee0b9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 15:39:15 +0900 Subject: [PATCH 225/387] Enable on-demand bind frames on :lambda --- lisp/comp/comp.l | 48 ++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 38 insertions(+), 10 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index bfe34b087..8dacadd8f 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -424,6 +424,8 @@ (send trans :load-local (var . offset) (- closure-level (var . level)) (send self :var-bindframe var))) ((param arg) + (if (and avant-mode (not (var . bindframe)) (> closure-level (var . level))) + (setq (var . bindframe) t)) (send trans :load-arg (var . offset) (- closure-level (var . level)) (send self :var-bindframe var))) ((object) @@ -1128,7 +1130,7 @@ (specially-bound nil) (allowotherkeys (memq '&allow-other-keys param)) (unwind-save unwind-frames) - argframe) + argframe vlist) (setq req-vars (reverse (nthcdr (length (cond (opt-vars) @@ -1222,14 +1224,15 @@ ;; (print "bind") (setq i 0) (dolist (v req-vars) ;for all required arguments - (send self :bind v argframe 'arg i) + (push (send self :bind v argframe 'arg i) vlist) (inc i)) (while (cdr labels) (let ((var (pop opt-vars)) (svar (pop opt-supplied-vars))) (when svar ; initialize supplied-p to t (send trans :load-t) - (setq svar (send self :bind svar argframe 'local (1- (send trans :offset-from-fp))))) + (setq svar (send self :bind svar argframe 'local (1- (send trans :offset-from-fp)))) + (push svar vlist)) (send trans :check-opt-arg i (car labels)) (when svar ; set supplied-p to nil (send trans :load-nil) @@ -1237,14 +1240,16 @@ ;; set init value (send self :eval (pop opt-forms)) (send trans :label (pop labels)) - (send self :bind var argframe 'local (1- (send trans :offset-from-fp))) + (push (send self :bind var argframe 'local (1- (send trans :offset-from-fp))) + vlist) (inc i))) (when labels (send trans :label (pop labels))) (cond (rest-var (send trans :rest (+ reqn optn)) - (send self :bind rest-var argframe 'local (1- (send trans :offset-from-fp)))) + (push (send self :bind rest-var argframe 'local (1- (send trans :offset-from-fp))) + vlist)) ((and (> optn 0) (null key-forms)) (send trans :check-rest-arg i))) (when key-forms (let ((key-base (send trans :offset-from-fp))) @@ -1260,7 +1265,8 @@ (setq labels (send self :genlabel "KEY")) (when svar ; set supplied-p variables to t (send trans :load-t) - (setq svar (send self :bind svar argframe 'local (1- (send trans :offset-from-fp))))) + (setq svar (send self :bind svar argframe 'local (1- (send trans :offset-from-fp)))) + (push svar vlist)) (send trans :check-key-arg j labels) (when svar ; set supplied-p variables to nil (send trans :load-nil) @@ -1271,24 +1277,46 @@ (send trans :store-local (+ key-base j) 0) (send trans :label labels) (send trans :load-local (+ key-base j) 0) - (send self :bind var argframe 'local (+ key-base j) :keyvarp t)) + (push (send self :bind var argframe 'local (+ key-base j) :keyvarp t) + vlist)) (t ;non-special - (send self :bind var argframe 'local (+ key-base j) :store t) + (push (send self :bind var argframe 'local (+ key-base j) :store t) + vlist) (send trans :label labels))))) ) ) ;;; bind aux variables (dolist (av aux-vars) (if (consp av) (send self :eval (cadr av)) (send trans :load-nil)) - (send self :bind (if (listp av) (car av) av) argframe 'local - (1- (send trans :offset-from-fp)))) + (let ((offset (1- (send trans :offset-from-fp)))) + (push + (send self :bind (if (listp av) (car av) av) argframe 'local offset) + vlist))) ;;; type check declaration variables (dolist (id decl-vars) (let ((v (send self :variable id))) (unless (eql (v . binding) 'unknown) (send self :load-var id) (send trans :type-check-declare (v . type))))) +;;; pre-evaluate lambda body + (let ((trans (send trans :copy-translator)) + (avant-mode t)) + (send self :progn forms)) +;;; bind frame vector + (setq vlist + (remove-if-not #'(lambda (v) (v . bindframe)) vlist)) + (when vlist + (send trans :reset-vsp) + (setq (argframe . offset) (send trans :create-frame (length vlist) "argv")) + (send argframe :local 1)) + (dotimes (i (length vlist)) + (let ((v (nth i vlist))) + (send self :load-var v) + (send trans :clearpush-frame (argframe . offset) i) + (setq (v . bindframe) (argframe . offset) + (v . offset) i))) ;;; evaluate lambda body (send self :progn forms) +;;; unwind/restore (setq unwind-frames unwind-save) (send self :delete-frame 'arg t) )) From f87375f530858daa909bd806542e0d4134c4e1d3 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 16:18:45 +0900 Subject: [PATCH 226/387] Add :bind-frame method --- lisp/comp/comp.l | 76 ++++++++++++++++-------------------------------- 1 file changed, 25 insertions(+), 51 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 8dacadd8f..4ce33e927 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -379,6 +379,25 @@ (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 @@ -789,23 +808,8 @@ (send self :eval (if (listp init-form) (cadr init-form) nil)) (setq offset (1- (send trans :offset-from-fp))) (push (send self :bind var bindframe 'local offset) vlist))) - ;; pre-evaluate body - (let ((trans (send trans :copy-translator)) - (avant-mode t)) - (send self :progn bodies)) - ;; bind frame vector - (setq vlist - (remove-if-not #'(lambda (v) (v . bindframe)) vlist)) - (when vlist - (send trans :reset-vsp) - (setq (bindframe . offset) (send trans :create-frame (length vlist) "seqlet")) - (send bindframe :local 1)) - (dotimes (i (length vlist)) - (let ((v (nth i vlist))) - (send self :load-var v) - (send trans :clearpush-frame (bindframe . offset) i) - (setq (v . bindframe) (bindframe . offset) - (v . offset) i))) + ;; bind closure variables + (send self :bind-frame bindframe bodies (nreverse vlist) "seqlet") ;; eval body (send self :progn bodies) ;; unwind/restore @@ -840,23 +844,8 @@ (send trans :load-local (cadr spe) 0) (send self :bind (car spe) bindframe 'local offset))) (setq scope (send idtable :level)) - ;; pre-evaluate body - (let ((trans (send trans :copy-translator)) - (avant-mode t)) - (send self :progn bodies)) - ;; bind frame vector - (setq vlist - (remove-if-not #'(lambda (v) (and (derivedp v identifier) (v . bindframe))) vlist)) - (when vlist - (send trans :reset-vsp) - (setq (bindframe . offset) (send trans :create-frame (length vlist) "parlet")) - (send bindframe :local 1)) - (dotimes (i (length vlist)) - (let ((v (nth i vlist))) - (send self :load-var v) - (send trans :clearpush-frame (bindframe . offset) i) - (setq (v . bindframe) (bindframe . offset) - (v . offset) i))) + ;; bind closure variables + (send self :bind-frame bindframe bodies vlist "parlet") ;; eval body (send self :progn bodies) ;; unwind/restore @@ -1297,23 +1286,8 @@ (unless (eql (v . binding) 'unknown) (send self :load-var id) (send trans :type-check-declare (v . type))))) -;;; pre-evaluate lambda body - (let ((trans (send trans :copy-translator)) - (avant-mode t)) - (send self :progn forms)) -;;; bind frame vector - (setq vlist - (remove-if-not #'(lambda (v) (v . bindframe)) vlist)) - (when vlist - (send trans :reset-vsp) - (setq (argframe . offset) (send trans :create-frame (length vlist) "argv")) - (send argframe :local 1)) - (dotimes (i (length vlist)) - (let ((v (nth i vlist))) - (send self :load-var v) - (send trans :clearpush-frame (argframe . offset) i) - (setq (v . bindframe) (argframe . offset) - (v . offset) i))) +;;; bind closure variables + (send self :bind-frame argframe forms (nreverse vlist) "argv") ;;; evaluate lambda body (send self :progn forms) ;;; unwind/restore From e519c194ac46987c871369c5e807da88dad5f2fc Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 16:22:42 +0900 Subject: [PATCH 227/387] Define and use maybe-format in trans.l --- lisp/comp/trans.l | 286 +++++++++++++++++++++++----------------------- 1 file changed, 145 insertions(+), 141 deletions(-) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index bc482d79c..07b929af2 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -46,15 +46,19 @@ (incf ftab-next)) index))) +(defun maybe-format (fstream format-string &rest args) + (unless avant-mode + (apply #'format fstream format-string args))) + (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 @@ -64,27 +68,27 @@ (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)) (:create-frame (size &optional comment) (send self :clearpush) (prog1 pushcount - (format cfile " local[~d]= makevector(C_VECTOR,~d);" pushcount size) - (if comment (format cfile " /*~A*/" comment)) - (terpri cfile) + (maybe-format cfile " local[~d]= makevector(C_VECTOR,~d);" pushcount size) + (if comment (maybe-format cfile " /*~A*/" comment)) + (if cfile (terpri cfile)) (inc pushcount) (send self :reset-vsp))) (:clearpush-frame (bindframe count) (when push - (format cfile " local[~d]->c.vec.v[~d]= ~A;~%" + (maybe-format cfile " local[~d]->c.vec.v[~d]= ~A;~%" bindframe count push)) (setq push nil)) ) @@ -112,11 +116,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 @@ -124,7 +128,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 () @@ -132,42 +136,42 @@ (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;}~%" + (maybe-format cfile " if (n>=~d) { local[~d]=(argv[~d]); goto ~A;}~%" (1+ m) pushcount 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) - (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 (if allowotherkeys 1 0)) (inc pushcount keyn)) (:check-key-arg (n lab) - (format cfile " if (n & (1<<~A)) goto ~A;~%" n lab)) + (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) @@ -233,7 +237,7 @@ (send self :store (format nil "~A[0]->c.obj.iv[~d]" (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 @@ -273,9 +277,9 @@ (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) @@ -287,7 +291,7 @@ ;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) @@ -305,8 +309,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) @@ -384,68 +388,68 @@ (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 " if (!isstring(~A)) error(E_NOSTRING);~%" vec) - (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)) + (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"))) (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;}~%")) + (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"))) (send self :push "w")) (:nullx () @@ -504,26 +508,26 @@ (send self :store "w") (case type ((list array) - (format cfile " if (!(~A)) error(~A);~%" ckfn errc)) + (maybe-format cfile " if (!(~A)) error(~A);~%" ckfn errc)) (t - (format cfile " if (!~A(w)) error(~A);~%" ckfn errc)))) + (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)" @@ -531,11 +535,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 . "&") @@ -553,22 +557,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)) + (maybe-format cfile " if (left ~A right) goto ~A;}~%" comparator lab)) (t (send self :error "illegal compare")))) ;;; 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 '((+ . +) (- . -) (* . *) (/ . /))))) @@ -583,19 +587,19 @@ (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]);}~%") + (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 @@ -603,12 +607,12 @@ (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) @@ -616,19 +620,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) @@ -636,21 +640,21 @@ (: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) + (maybe-format cfile " unwind(ctx,local+~d);~%" 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)) + (maybe-format cfile " unwind(ctx,local+~d);~%" k)) (inc pushcount)) (:closure (lab env0 env1) (if env1 @@ -663,7 +667,7 @@ (: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 @@ -671,7 +675,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 @@ -682,14 +686,14 @@ ; 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)) @@ -706,76 +710,76 @@ 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 " 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) From 62a492db0dcfc132ca96429c94aed01ae2e980a2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 18:52:21 +0900 Subject: [PATCH 228/387] Add function-identifier to better organize flet entries --- lisp/comp/comp.l | 73 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 49 insertions(+), 24 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 4ce33e927..6b44b9ebf 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -148,6 +148,31 @@ self)) ) +; function identifier +; +(eval-when (load compile eval) +(defclass function-identifier :super object + :slots (name entry binding level offset bindframe body)) +) +;; binding = (constant, local, global, special) + +(eval-when (load eval) +(defmethod function-identifier + (:init (sym bin off &optional lev ent frame) + (setq name sym + binding bin + offset off + level lev + entry ent + bindframe frame) + self) + (:init-body (sym bin &optional bd) + (setq name sym + binding bin + body bd) + self)) +) + ; identifier table ; (eval-when (load compile eval) @@ -262,32 +287,34 @@ (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 `(,(third fdef) ,@(cdr 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))) )))) (: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 (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 (compiled-code-type fdef) '((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)) (sixth fdef)) - (send trans :call-closure (fifth fdef) (length args))) + (send trans :load-local (fdef . offset) (- closure-level (fdef . level)) (fdef . bindframe)) + (send trans :call-closure (fdef . entry) (length args))) (: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)) @@ -1007,10 +1034,10 @@ (: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)) - (sixth flet-def)) + (if (eq (flet-def . binding) 'closure) + (send trans :load-local (flet-def . offset) + (- closure-level (flet-def . level)) + (flet-def . bindframe)) (send trans :getfunc fn))) (let (entry newcomp) ; #'(lambda (...) ...) (if avant-mode @@ -1026,27 +1053,24 @@ (send self :add-closure (list entry fn newcomp))))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet - (let (entry newcomp newcomps flets-exchange fletframe) + (let (newcomp newcomps fletframe) (setq fletframe (send self :create-frame 'flet)) (if (not recursive-scope) ; copy compiler before binding the functions (setq newcomp (send self :copy-compiler))) (dolist (fn funcs) + (let (entry offset) (setq entry (send self :genlabel "FLET")) (send self :closure entry "flet env") - (push (list - (car fn) ;func name - 'closure ;func bind type - (1- (send trans :offset-from-fp)) ;offset - closure-level - entry - nil) ;fletframe + (setq offset (1- (send trans :offset-from-fp))) + (push (instance function-identifier :init + (car fn) 'closure offset closure-level entry) flets) (send fletframe :local 1) (when recursive-scope (setq newcomp (send self :copy-compiler)) (push newcomp newcomps)) (send self :add-closure (list entry (cons 'lambda (cdr fn)) - newcomp))) + newcomp)))) (if recursive-scope (send-all newcomps :change-flets flets)) @@ -1057,7 +1081,8 @@ (send trans :del-frame (fletframe . specials) (fletframe . locals)))) (:macrolet (funcs bodies) (dolist (fn funcs) - (push (list (car fn) 'macrolet `(lambda ,@(cdr fn))) + (push (instance function-identifier :init-body + (car fn) 'macrolet `(lambda ,@(cdr fn))) flets)) (send self :progn bodies) (setq flets (nthcdr (length funcs) flets))) From 8e5758153d9ebc6e18f8c06b71e67291c591b0cb Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 22:24:13 +0900 Subject: [PATCH 229/387] Enable on-demand bind-frames on :flet --- lisp/comp/comp.l | 78 ++++++++++++++++++++++++++++++++++------------- lisp/comp/trans.l | 2 +- 2 files changed, 57 insertions(+), 23 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 6b44b9ebf..2bcb81114 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -152,19 +152,21 @@ ; (eval-when (load compile eval) (defclass function-identifier :super object - :slots (name entry binding level offset bindframe body)) + :slots (name entry binding level offset bindframe body comp)) ) ;; binding = (constant, local, global, special) (eval-when (load eval) (defmethod function-identifier - (:init (sym bin off &optional lev ent frame) + (:init (sym bin off &optional lev ent bd cmp) (setq name sym binding bin offset off level lev entry ent - bindframe frame) + body bd + comp cmp + bindframe nil) self) (:init-body (sym bin &optional bd) (setq name sym @@ -299,7 +301,11 @@ (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 + (if (and avant-mode (not (fdef . bindframe)) (fdef . level) + (> closure-level (fdef . level))) + (setq (fdef . bindframe) t)) + fdef) (cond ((fboundp fn) (setq fdef (symbol-function fn)) (if (compiled-function-p fdef) @@ -1053,30 +1059,58 @@ (send self :add-closure (list entry fn newcomp))))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet - (let (newcomp newcomps fletframe) - (setq fletframe (send self :create-frame 'flet)) - (if (not recursive-scope) ; copy compiler before binding the functions + (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) - (let (entry offset) - (setq entry (send self :genlabel "FLET")) - (send self :closure entry "flet env") - (setq offset (1- (send trans :offset-from-fp))) - (push (instance function-identifier :init - (car fn) 'closure offset closure-level entry) - flets) - (send fletframe :local 1) - (when recursive-scope - (setq newcomp (send self :copy-compiler)) - (push newcomp newcomps)) - (send self :add-closure (list entry (cons 'lambda (cdr fn)) - newcomp)))) + (if avant-mode + (progn + (setq newcomp (send self :copy-compiler)) + (setq (newcomp . idtable) idtable) + (send newcomp :lambda (cadr fn) (cddr fn)) + (send trans :discard 1)) + (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)))) + + (when recursive-scope + ;; pre-evaluate closures + (dolist (fn flets-tmp) + (let ((trans (send trans :copy-translator)) + (newcomp (send self :copy-compiler)) + (avant-mode t)) + (setq (newcomp . flets) flets-tmp) + (send newcomp :lambda (cadr (fn . body)) (cddr (fn . body))))) + (setq flist (remove-if-not #'(lambda (v) (v . bindframe)) (reverse flets-tmp)))) (if recursive-scope - (send-all newcomps :change-flets flets)) + (setq fletframe (send self :create-frame 'flet (length flist) "flet")) + (setq fletframe (send self :create-frame 'flet))) + + (dolist (fn (reverse flets-tmp)) + (send self :closure (fn . entry) "flet env") + (setq (fn . offset) (1- (send trans :offset-from-fp))) + (send fletframe :local 1) + (send self :add-closure (list (fn . entry) (fn . body) (fn . comp)))) + + (when recursive-scope + (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)))) + (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)) + (setq flets (nthcdr (length flets-tmp) flets)) (send self :delete-frame 'flet nil) (send trans :del-frame (fletframe . specials) (fletframe . locals)))) (:macrolet (funcs bodies) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 07b929af2..ae7151b1c 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -273,7 +273,7 @@ (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 From ef7fa07b1dad4a1f5e391f0114a72f123fff63ae Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 22:24:23 +0900 Subject: [PATCH 230/387] Solve close issues on :copy-translator --- lisp/comp/trans.l | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index ae7151b1c..cb67210b8 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -696,10 +696,14 @@ (maybe-format hfile "static pointer ~A();~%" name)) (:quote () quotev) (:copy-translator () - (let ((newtrans)) - (setq newtrans (copy-object self)) - (setq (newtrans . cfile) nil) - (setq (newtrans . hfile) nil) + (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 From 8e9aa304bd57e6b3f430eff07b81d69616471f09 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 9 May 2022 22:47:37 +0900 Subject: [PATCH 231/387] Suppress more warnings at avant-mode --- lisp/comp/comp.l | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 2bcb81114..686f082c7 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -333,8 +333,9 @@ ((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) @@ -1687,7 +1688,7 @@ (warn "~A" cccom) (unix:system cccom)) (dolist (f *defun-list*) (remprop f 'user-function-entry)) - (terpri *error-output*) + (unless avant-mode (terpri *error-output*)) ) (send trans :clear-external-functions))) (:specials () (mapcar 'car (send idtable :frame 0))) From 385778377db235a665575ff2712d9b6d85eff188 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 10 May 2022 14:24:43 +0900 Subject: [PATCH 232/387] Add defmethod and slot variable closure support --- lisp/comp/comp.l | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 686f082c7..3c614d72e 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -482,6 +482,8 @@ (send trans :load-arg (var . offset) (- closure-level (var . level)) (send self :var-bindframe var))) ((object) + (if (and avant-mode (not (var . bindframe)) (> closure-level (var . level))) + (setq ((send idtable :get 'self) . bindframe) t)) (send trans :load-obj (var . offset) (- closure-level (var . level)) (send self :var-bindframe var))) (unknown From ddad6e9dbc866cd13e1c6dff4676c069e41e6db5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 10 May 2022 14:54:19 +0900 Subject: [PATCH 233/387] Enable on-demand bind-frames in :unwind-protect --- lisp/comp/comp.l | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 3c614d72e..632abc712 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -977,15 +977,22 @@ ;; makeclosure (send trans :closure form (plusp closure-level) (not (not frame))))) (:unwind-protect (prot cleanup) - (let ((cleaner (send self :genlabel "UWP")) - (newcomp)) - (push (send trans :offset-from-fp) unwind-frames) - (send self :closure cleaner "unwind protect") ;make cleanup closure - (setq newcomp (send self :copy-compiler)) - (send self :add-closure - (list cleaner - (cons 'lambda (cons nil cleanup)) - newcomp)) + (let (cleaner newcomp) + (if avant-mode + (progn + (setq newcomp (send self :copy-compiler)) + (setq (newcomp . idtable) idtable) + (send newcomp :lambda nil cleanup) + (send trans :discard 1)) + (progn + (setq cleaner (send self :genlabel "UWP")) + (push (send trans :offset-from-fp) unwind-frames) + (send self :closure cleaner "unwind protect") ;make cleanup closure + (setq newcomp (send self :copy-compiler)) + (send self :add-closure + (list cleaner + (cons 'lambda (cons nil cleanup)) + newcomp)))) (send trans :bind-cleaner) (send self :eval prot) (send trans :call-cleaner cleaner) From 46b8585374d2e7bc3465634346cb8a3626d6e4a3 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 10 May 2022 16:02:02 +0900 Subject: [PATCH 234/387] Adapt :flet to cover closures on the evaluation body --- lisp/comp/comp.l | 40 ++++++++++++++++++++++++++++------------ 1 file changed, 28 insertions(+), 12 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 632abc712..4aa08d211 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1060,6 +1060,7 @@ (progn (setq newcomp (send self :copy-compiler)) (setq (newcomp . idtable) idtable) + (setq (newcomp . flets) flets) (send newcomp :lambda (cadr fn) (cddr fn)) (send trans :discard 1)) (progn @@ -1096,30 +1097,45 @@ (newcomp (send self :copy-compiler)) (avant-mode t)) (setq (newcomp . flets) flets-tmp) - (send newcomp :lambda (cadr (fn . body)) (cddr (fn . body))))) - (setq flist (remove-if-not #'(lambda (v) (v . bindframe)) (reverse flets-tmp)))) + (send newcomp :lambda (cadr (fn . body)) (cddr (fn . body)))))) + ;; pre-evaluate body + (let ((trans (send trans :copy-translator)) + (flets-save flets) + (avant-mode t)) + (setq flets flets-tmp) + (unwind-protect (send self :progn bodies) + (setq flets flets-save))) + + ;; bind frames + (setq flist (remove-if-not #'(lambda (v) (v . bindframe)) (reverse flets-tmp))) (if recursive-scope - (setq fletframe (send self :create-frame 'flet (length flist) "flet")) - (setq fletframe (send self :create-frame 'flet))) + ;; when recursive setup the bindframe beforehand + (setq fletframe (send self :create-frame 'flet (length flist) "flet"))) (dolist (fn (reverse flets-tmp)) (send self :closure (fn . entry) "flet env") (setq (fn . offset) (1- (send trans :offset-from-fp))) - (send fletframe :local 1) (send self :add-closure (list (fn . entry) (fn . body) (fn . comp)))) - (when recursive-scope - (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)))) + (unless 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))) + + ;; evaluate body (setq flets (append flets-tmp flets)) (if recursive-scope (send-all newcomps :change-flets flets)) (send self :progn bodies) + ;; unwind/restore (setq flets (nthcdr (length flets-tmp) flets)) (send self :delete-frame 'flet nil) (send trans :del-frame (fletframe . specials) (fletframe . locals)))) From 68162aec03d14e848dac794f91a25c7dd2923afa Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 10 May 2022 21:59:07 +0900 Subject: [PATCH 235/387] Sequentially bind closure variables in let* to enable using closures at definition --- lisp/comp/comp.l | 57 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 43 insertions(+), 14 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 4aa08d211..b20c11a9e 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -393,6 +393,13 @@ (setq (v . bindframe) (frame . offset)) (send self :store-var v)))) v)) + (:bind-identifier (v frame &key store 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) + :store store :keyvarp keyvarp)) (:create-frame (type &optional size comment) (let ((frame (instance stack-frame :init type))) (setq (frame . level) closure-level) @@ -830,27 +837,49 @@ (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) - bindframe vlist) - (setq bindframe (send self :create-frame 'local)) + (:let* (bodies &optional (rec t)) ;sequential let + (let ((unwind-save unwind-frames) (i 0) + local-list bindframe vlist) + (when rec + (let ((trans (send trans :copy-translator)) + (newcomp (send self :copy-compiler nil)) + (avant-mode t)) + (setq vlist (send newcomp :let* bodies nil)))) + (setq local-list (pop bodies)) + (setq bindframe (send self :create-frame 'local + (count-if #'(lambda (x) (x . bindframe)) vlist) + "seqlet")) ;; handle declarations (while (and bodies (consp (car bodies)) (eq (caar bodies) 'declare)) (send self :declare (cdr (pop bodies)))) - ;; eval to locals + ;; eval and bind (dolist (init-form local-list) - (let ((var (if (listp init-form) (car init-form) init-form)) - offset) + (let ((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))) - (push (send self :bind var bindframe 'local offset) vlist))) - ;; bind closure variables - (send self :bind-frame bindframe bodies (nreverse vlist) "seqlet") + (if rec + ;; in recursive mode: bind frame variables + (let ((v (find var vlist :key #'(lambda (x) (x . name))))) + (if (not v) (send self :error "variable not found")) + (if (v . bindframe) + (progn + (send trans :clearpush-frame (bindframe . offset) i) + (setq (v . binding) 'let + (v . bindframe) (bindframe . offset) + (v . offset) i) + (inc i)) + (let ((offset (1- (send trans :offset-from-fp)))) + (setq (v . offset) offset))) + (send self :bind-identifier v bindframe)) + ;; in avant mode: collect variables + (let ((offset (1- (send trans :offset-from-fp)))) + (push (send self :bind var bindframe 'local offset) vlist))))) ;; eval body (send self :progn bodies) ;; unwind/restore (setq unwind-frames unwind-save) - (send self :delete-frame 'local t))) + (send self :delete-frame 'local t) + ;; return value + vlist)) (:let (bodies) ;parallel let (let ((local-list (pop bodies)) (unwind-save unwind-frames) bindframe special-list vlist) @@ -1717,12 +1746,12 @@ ) (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)) From 252cf554b8e5b7b114c539240831ca16d0244fc5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 10 May 2022 23:03:11 +0900 Subject: [PATCH 236/387] Try global symbols on imcomplete bindframe reference --- lisp/comp/comp.l | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index b20c11a9e..108fc1879 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -323,7 +323,9 @@ (send trans :call-closure (fdef . entry) (length args))) (: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 + (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) From 401658bb75baf30322095a4ba6d99d43538d0b93 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 May 2022 12:39:37 +0900 Subject: [PATCH 237/387] Add :bind-closure-variable and sequentially bind closure variables in :lambda --- lisp/comp/comp.l | 147 ++++++++++++++++++++++++++++++---------------- lisp/comp/trans.l | 3 + 2 files changed, 98 insertions(+), 52 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 108fc1879..a81598a89 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -374,7 +374,7 @@ (send v :binding 'special) )) v)) - (:bind (id frame binding offset &key store keyvarp) + (:bind (id frame binding offset &key keyvarp) (unless (symbolp id) (error type-error "symbol expected for function argument" id)) (let ((v (send self :enter-variable id))) @@ -390,18 +390,21 @@ (t (if (eq binding 'local) (send frame :local 1)) (setq (v . binding) binding - (v . offset) offset) - (when store - (setq (v . bindframe) (frame . offset)) - (send self :store-var v)))) + (v . offset) offset))) v)) - (:bind-identifier (v frame &key store keyvarp) + (: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) - :store store :keyvarp keyvarp)) + (send self :bind (v . name) frame (v . binding) (v . offset) :keyvarp keyvarp)) + (:bind-closure-variable (v binding frame i &key (store t)) + (if store + (send trans :clearpush-frame (frame . offset) i)) + (setq (v . binding) binding + (v . bindframe) (frame . offset) + (v . offset) i) + (send self :bind-identifier v frame)) (:create-frame (type &optional size comment) (let ((frame (instance stack-frame :init type))) (setq (frame . level) closure-level) @@ -841,38 +844,26 @@ result-type)) (:let* (bodies &optional (rec t)) ;sequential let (let ((unwind-save unwind-frames) (i 0) - local-list bindframe vlist) + local-list bindframe vlist closure-vlist) (when rec (let ((trans (send trans :copy-translator)) (newcomp (send self :copy-compiler nil)) (avant-mode t)) - (setq vlist (send newcomp :let* bodies nil)))) + (setq closure-vlist (send newcomp :let* bodies nil)))) (setq local-list (pop bodies)) - (setq bindframe (send self :create-frame 'local - (count-if #'(lambda (x) (x . bindframe)) vlist) - "seqlet")) + (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)))) ;; eval and bind (dolist (init-form local-list) - (let ((var (if (listp init-form) (car init-form) init-form))) + (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 rec - ;; in recursive mode: bind frame variables - (let ((v (find var vlist :key #'(lambda (x) (x . name))))) - (if (not v) (send self :error "variable not found")) - (if (v . bindframe) - (progn - (send trans :clearpush-frame (bindframe . offset) i) - (setq (v . binding) 'let - (v . bindframe) (bindframe . offset) - (v . offset) i) - (inc i)) - (let ((offset (1- (send trans :offset-from-fp)))) - (setq (v . offset) offset))) - (send self :bind-identifier v bindframe)) - ;; in avant mode: collect variables + (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))))) ;; eval body @@ -881,7 +872,7 @@ (setq unwind-frames unwind-save) (send self :delete-frame 'local t) ;; return value - vlist)) + (remove-if-not #'(lambda (v) (v . bindframe)) (nreverse vlist)))) (:let (bodies) ;parallel let (let ((local-list (pop bodies)) (unwind-save unwind-frames) bindframe special-list vlist) @@ -1212,7 +1203,7 @@ (push id acc))) (t (send self :error "unknown declaration" decl)))))) (nreverse acc))) - (:lambda (param forms) + (:lambda (param forms &optional (rec t)) (let ((labels nil) (i 0) (reqn 0) @@ -1235,7 +1226,12 @@ (specially-bound nil) (allowotherkeys (memq '&allow-other-keys param)) (unwind-save unwind-frames) - argframe vlist) + (cvar-i 0) argframe vlist closure-vlist) + (when rec + (let ((trans (send trans :copy-translator)) + (newcomp (send self :copy-compiler nil)) + (avant-mode t)) + (setq closure-vlist (send newcomp :lambda param forms nil)))) (setq req-vars (reverse (nthcdr (length (cond (opt-vars) @@ -1325,36 +1321,66 @@ (if rest-var 1 (if key-forms keyn 0)))) ;; create argument frame - (setq argframe (send self :create-frame 'arg)) + (setq argframe (send self :create-frame 'arg (length closure-vlist) "argv")) ;; (print "bind") (setq i 0) - (dolist (v req-vars) ;for all required arguments - (push (send self :bind v argframe 'arg i) vlist) + (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) (let ((var (pop opt-vars)) (svar (pop opt-supplied-vars))) (when svar ; initialize supplied-p to t (send trans :load-t) - (setq svar (send self :bind svar argframe 'local (1- (send trans :offset-from-fp)))) + (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-opt-arg i (car labels)) + (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)) - (push (send self :bind var argframe 'local (1- (send trans :offset-from-fp))) - vlist) + (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)) - (push (send self :bind rest-var argframe 'local (1- (send trans :offset-from-fp))) - vlist)) + (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 (let ((key-base (send trans :offset-from-fp))) @@ -1370,7 +1396,14 @@ (setq labels (send self :genlabel "KEY")) (when svar ; set supplied-p variables to t (send trans :load-t) - (setq svar (send self :bind svar argframe 'local (1- (send trans :offset-from-fp)))) + (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 @@ -1385,31 +1418,41 @@ (push (send self :bind var argframe 'local (+ key-base j) :keyvarp t) vlist)) (t ;non-special - (push (send self :bind var argframe 'local (+ key-base j) :store t) - vlist) - (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 + (send self :load-var var) + (send self :bind-closure-variable cvar 'lambda argframe cvar-i) + (inc cvar-i))))))) ) ) ;;; bind aux variables (dolist (av aux-vars) (if (consp av) (send self :eval (cadr av)) (send trans :load-nil)) - (let ((offset (1- (send trans :offset-from-fp)))) - (push - (send self :bind (if (listp av) (car av) av) argframe 'local offset) - vlist))) + (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))))) ;;; type check declaration variables (dolist (id decl-vars) (let ((v (send self :variable id))) (unless (eql (v . binding) 'unknown) (send self :load-var id) (send trans :type-check-declare (v . type))))) -;;; bind closure variables - (send self :bind-frame argframe forms (nreverse vlist) "argv") ;;; evaluate lambda body (send self :progn forms) ;;; unwind/restore (setq unwind-frames unwind-save) (send self :delete-frame 'arg t) - )) +;;; return value + (remove-if-not #'(lambda (v) (v . bindframe)) (nreverse vlist)))) (:lambda-block (name arglist bodies cname) (let ((ctime (unix:runtime)) blklabel) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index cb67210b8..e0a23791c 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -155,6 +155,9 @@ (:check-opt-arg (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) (maybe-format cfile " if (n>~d) maerror();~%" m)) ) From ec9496c8adddaa69f6b390bedde5edcdbef3d13d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 May 2022 12:48:02 +0900 Subject: [PATCH 238/387] Reset vsp before binding frames --- lisp/comp/trans.l | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index e0a23791c..ec94f2cf3 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -80,12 +80,12 @@ (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) - (send self :reset-vsp))) + (inc pushcount))) (:clearpush-frame (bindframe count) (when push (maybe-format cfile " local[~d]->c.vec.v[~d]= ~A;~%" From f150ef2f598f91900f8ef794cafde2e93613f0e2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 May 2022 12:53:58 +0900 Subject: [PATCH 239/387] Suppress warnings for the default declaration type: t --- lisp/comp/trans.l | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index ec94f2cf3..48b342e41 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -488,7 +488,9 @@ (stream "isstream") (metaclass "isclass") (package "ispackage") - (t (warn "unknown type declaration: ~A~%" type) nil))) + (t + (unless (eq type t) (warn "unknown type declaration: ~A~%" type)) + nil))) (errc (case type (symbol "E_NOSYMBOL") (cons "E_NOLIST") @@ -505,7 +507,9 @@ (stream "E_STREAM") (metaclass "E_NOCLASS, w") (package "E_NOPACKAGE, w") - (t (warn "unknown type declaration: ~A~%" type) nil)))) + (t + (unless (eq type t) (warn "unknown type declaration: ~A~%" type)) + nil)))) (if (and ckfn errc) (progn (send self :store "w") From 8afb60ff9a9e5e7c6d662d21775765550187bf05 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 May 2022 12:58:41 +0900 Subject: [PATCH 240/387] Improve compilation error formatting --- lisp/comp/comp.l | 24 ++++++++++++------------ lisp/comp/trans.l | 6 +++--- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index a81598a89..dc1e97c85 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -94,7 +94,7 @@ (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)) @@ -296,7 +296,7 @@ (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 function name")) (let ((fdef (find-if #'(lambda (x) (eql (x . name) fn)) flets))) @@ -370,7 +370,7 @@ 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)) @@ -418,7 +418,7 @@ (push frame frames)) (flet (push frame fletframes)) - ;; (t (send self :error "unknow frame type" type)) + ;; (t (send self :error "unknow frame type ~S" type)) ) (case type ((arg local) @@ -450,7 +450,7 @@ (arg (pop argframes)) (local (pop frames)) (flet (pop fletframes)) - (t (send self :error "unknown frame type" type)))) + (t (send self :error "unknown frame type ~S" type)))) (nospecials (f . specials))) (declare (type stack-frame f)) (if (> nospecials 0) @@ -471,7 +471,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)) )) @@ -499,7 +499,7 @@ (send trans :load-obj (var . offset) (- closure-level (var . level)) (send self :var-bindframe var))) (unknown - (send self :error "declared but unknown variable" (var . name))) + (send self :error "declared but unknown variable ~S" (var . name))) ) (send var :type)) (:store-ovaf (form varname) @@ -734,7 +734,7 @@ ((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)))) + (t (send self :error "Compiling method is not yet implemented for ~S" fn)))) ) ;defmethod ) ;eval-when @@ -838,7 +838,7 @@ (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)) @@ -1039,7 +1039,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")) @@ -1064,7 +1064,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) @@ -1201,7 +1201,7 @@ (setq v (send self :enter-variable id)) (send v :type (car decl)) (push id acc))) - (t (send self :error "unknown declaration" decl)))))) + (t (send self :error "unknown declaration ~S" decl)))))) (nreverse acc))) (:lambda (param forms &optional (rec t)) (let ((labels nil) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 48b342e41..7fbfe7418 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -438,7 +438,7 @@ (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"))) + (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 @@ -453,7 +453,7 @@ #+:rgc (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"))) + (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)))) @@ -572,7 +572,7 @@ " right=fltval(~A); left=fltval(~A);~%" (send self :pop) (send self :pop)) (maybe-format cfile " if (left ~A right) goto ~A;}~%" comparator lab)) - (t (send self :error "illegal compare")))) + (t (send self :error "illegal compare ~S" type)))) ;;; floating arithemtics (:flt-op2 (op) (maybe-format cfile " { double x,y;~%") From 92f78f6db731993d24ffcb44a74737595512e5d7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 May 2022 14:49:36 +0900 Subject: [PATCH 241/387] Fix key variable reassignment in :lambda --- lisp/comp/comp.l | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index dc1e97c85..f5832e101 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1425,8 +1425,13 @@ (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 self :bind-closure-variable cvar 'lambda argframe cvar-i) + (send trans :clearpush-frame (argframe . offset) cvar-i) + (setq (var . binding) 'lambda + (var . bindframe) (argframe . offset) + (var . offset) cvar-i) (inc cvar-i))))))) ) ) ;;; bind aux variables From c7beb409bdc982022019537d435ef9af7b70cc15 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 May 2022 20:37:35 +0900 Subject: [PATCH 242/387] Properly pre-evaluate closure definitions in :flet --- lisp/comp/comp.l | 57 +++++++++++++++++++++--------------------------- 1 file changed, 25 insertions(+), 32 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index f5832e101..49f96bb7d 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -48,7 +48,6 @@ (defvar trans) (defvar *multipass-optimize* t) - (defun ovafp (form) (and (cdr form) (symbolp (cdr form)))) (defun class-symbolp (x) @@ -1096,38 +1095,31 @@ (if (not recursive-scope) ; copy compiler before binding the functions (setq newcomp (send self :copy-compiler))) (dolist (fn funcs) - (if avant-mode - (progn - (setq newcomp (send self :copy-compiler)) - (setq (newcomp . idtable) idtable) - (send newcomp :lambda (cadr fn) (cddr fn)) - (send trans :discard 1)) - (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)))) + (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))) - (when recursive-scope - ;; pre-evaluate closures + ;; 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) - (let ((trans (send trans :copy-translator)) - (newcomp (send self :copy-compiler)) - (avant-mode t)) - (setq (newcomp . flets) flets-tmp) - (send newcomp :lambda (cadr (fn . body)) (cddr (fn . body)))))) + (send newcomp :lambda (cadr (fn . body)) (cddr (fn . body))))) ;; pre-evaluate body (let ((trans (send trans :copy-translator)) - (flets-save flets) + (newcomp (send self :copy-compiler nil)) (avant-mode t)) - (setq flets flets-tmp) - (unwind-protect (send self :progn bodies) - (setq flets flets-save))) + (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))) @@ -1135,12 +1127,13 @@ ;; when recursive setup the bindframe beforehand (setq fletframe (send self :create-frame 'flet (length flist) "flet"))) - (dolist (fn (reverse flets-tmp)) - (send self :closure (fn . entry) "flet env") - (setq (fn . offset) (1- (send trans :offset-from-fp))) - (send self :add-closure (list (fn . entry) (fn . body) (fn . comp)))) + (if (not avant-mode) + (dolist (fn (reverse flets-tmp)) + (send self :closure (fn . entry) "flet env") + (setq (fn . offset) (1- (send trans :offset-from-fp))) + (send self :add-closure (list (fn . entry) (fn . body) (fn . comp))))) - (unless recursive-scope + (if (not recursive-scope) ;; when not recursive setup the bindframe after the closure declaration (setq fletframe (send self :create-frame 'flet (length flist) "flet"))) From 31affeea79788f718f56f2d7ca4c64d51f210bc1 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 May 2022 20:39:04 +0900 Subject: [PATCH 243/387] Don't double set self variable bindframe in :load-var --- lisp/comp/comp.l | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 49f96bb7d..003a21c8f 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -493,8 +493,9 @@ (send trans :load-arg (var . offset) (- closure-level (var . level)) (send self :var-bindframe var))) ((object) - (if (and avant-mode (not (var . bindframe)) (> closure-level (var . level))) - (setq ((send idtable :get 'self) . bindframe) t)) + (let ((self-var (send idtable :get 'self))) + (if (and avant-mode (not (self-var . bindframe)) (> closure-level (var . level))) + (setq (self-var . bindframe) t))) (send trans :load-obj (var . offset) (- closure-level (var . level)) (send self :var-bindframe var))) (unknown From a0b41d500ba18ab12a2be1cda7af40b4391fb1aa Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 11 May 2022 21:58:40 +0900 Subject: [PATCH 244/387] Use :store-var in :bind-closure-var to ensure binding even when push is null --- lisp/comp/comp.l | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 003a21c8f..0cbf22533 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -398,12 +398,11 @@ (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)) - (if store - (send trans :clearpush-frame (frame . offset) i)) (setq (v . binding) binding (v . bindframe) (frame . offset) (v . offset) i) - (send self :bind-identifier v frame)) + (send self :bind-identifier v frame) + (if store (send self :store-var v))) (:create-frame (type &optional size comment) (let ((frame (instance stack-frame :init type))) (setq (frame . level) closure-level) From 3d040453f268f7609e7e67d488b9af5b3428fc55 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 5 May 2022 19:52:34 +0900 Subject: [PATCH 245/387] Add hashtable and package symvector tests --- test/hashtable.l | 105 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 105 insertions(+) create mode 100644 test/hashtable.l 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)) From b1f5d40ad9660e7f087381f3c6cb91d56b4f6a9c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 5 May 2022 19:54:12 +0900 Subject: [PATCH 246/387] Add fill-count to count deleted members in hash-tables (fixes #405) --- lisp/l/hashtab.l | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/lisp/l/hashtab.l b/lisp/l/hashtab.l index da1807331..ef3d049fc 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)) @@ -133,6 +137,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)) From 20ee02038206e50ca4cfe1911fcd4313f26f2ee2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 5 May 2022 19:54:44 +0900 Subject: [PATCH 247/387] Count deleted members in package intsymcount and symcount --- lisp/c/intern.c | 25 ++++++++++++++++--------- lisp/l/packsym.l | 10 +++++----- 2 files changed, 21 insertions(+), 14 deletions(-) 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/l/packsym.l b/lisp/l/packsym.l index 4d6a7a4c3..123936c15 100644 --- a/lisp/l/packsym.l +++ b/lisp/l/packsym.l @@ -145,8 +145,10 @@ (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)) @@ -174,12 +176,10 @@ (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)) From 5c6e4517dfa30c4c053e39189ef25a75dd1a681e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 5 May 2022 19:56:09 +0900 Subject: [PATCH 248/387] Reset hash-table count and fill-count in :clear --- lisp/l/hashtab.l | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/l/hashtab.l b/lisp/l/hashtab.l index ef3d049fc..fa3cf69e9 100644 --- a/lisp/l/hashtab.l +++ b/lisp/l/hashtab.l @@ -122,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 From bb50289672a52b4d95c89b2e15252d95a04ee43b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 00:24:34 +0900 Subject: [PATCH 249/387] Allow to use flets in unwind-protect cleaner --- lisp/comp/comp.l | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 0cbf22533..f7c5351f1 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1003,6 +1003,7 @@ (progn (setq newcomp (send self :copy-compiler)) (setq (newcomp . idtable) idtable) + (setq (newcomp . flets) flets) (send newcomp :lambda nil cleanup) (send trans :discard 1)) (progn From 2f6e8b166c28c2bccdca006e54d7289c63c02d29 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 14 May 2022 09:51:47 +0900 Subject: [PATCH 250/387] Use recursive nil when calling :lambda from avant-mode --- lisp/comp/comp.l | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index f7c5351f1..3f7c98121 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1004,7 +1004,7 @@ (setq newcomp (send self :copy-compiler)) (setq (newcomp . idtable) idtable) (setq (newcomp . flets) flets) - (send newcomp :lambda nil cleanup) + (send newcomp :lambda nil cleanup nil) (send trans :discard 1)) (progn (setq cleaner (send self :genlabel "UWP")) @@ -1083,7 +1083,7 @@ (setq newcomp (send self :copy-compiler)) (setq (newcomp . idtable) idtable) (setq (newcomp . flets) flets) - (send newcomp :lambda (cadr fn) (cddr fn)) + (send newcomp :lambda (cadr fn) (cddr fn) nil) (send trans :discard 1)) (progn (setq entry (send self :genlabel "CLO")) @@ -1113,7 +1113,7 @@ (setq (newcomp . flets) (append flets-tmp flets)) (setq (newcomp . idtable) idtable) (dolist (fn flets-tmp) - (send newcomp :lambda (cadr (fn . body)) (cddr (fn . body))))) + (send newcomp :lambda (cadr (fn . body)) (cddr (fn . body)) nil))) ;; pre-evaluate body (let ((trans (send trans :copy-translator)) From e90e68ea3b4386f8bf40a8c7fd5eb13fcaff884d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 00:01:13 +0900 Subject: [PATCH 251/387] Only bind required argframes and bindframes on closures --- lisp/comp/comp.l | 97 +++++++++++++++++++++++++++++------------------- 1 file changed, 58 insertions(+), 39 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 3f7c98121..8f50632c9 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -47,6 +47,7 @@ (defvar comp nil "$Id$") (defvar trans) (defvar *multipass-optimize* t) +(defvar closure-frames nil) (defun ovafp (form) (and (cdr form) (symbolp (cdr form)))) @@ -129,7 +130,7 @@ ; (eval-when (load compile eval) (defclass identifier :super object - :slots (name type binding level offset bindframe)) + :slots (name type binding level offset bindframe clist)) ) ;; binding = (constant, local, global, special) @@ -190,6 +191,16 @@ (while (>= lev 0) (setq r (assq id (svref frames lev))) (if r (return-from :get (cdr r)) (dec lev))))) + (:get-cframes (fn &optional (lev level)) + (let (acc) + (while (>= lev 0) + (dolist (var (svref frames lev)) + (setq var (cdr var)) + (when (and var (= (var . level) closure-level) + (find fn (var . clist) :test #'equal)) + (pushnew (var . bindframe) acc))) + (dec lev)) + acc)) (:enter (id &optional (lev level)) (svset frames lev (cons (cons (id . name) id) (svref frames lev))) id) @@ -323,7 +334,8 @@ (:variable (var) ;var must be a symbol, ovaf is not allowed here. (let ((result (send idtable :get var scope))) (if (and result - (not (and (> closure-level (result . level)) (eq (result . bindframe) t)))) + (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 @@ -479,27 +491,27 @@ (return-from :load-var t)) (unless (derivedp var identifier) (setq var (send self :variable var))) - (case (var . binding) - ((special) (send trans :load-global (var . name))) - ((local let lambda) - (if (and avant-mode (not (var . bindframe)) (> closure-level (var . level))) - (setq (var . bindframe) t)) - (send trans :load-local (var . offset) (- closure-level (var . level)) - (send self :var-bindframe var))) - ((param arg) - (if (and avant-mode (not (var . bindframe)) (> closure-level (var . level))) - (setq (var . bindframe) t)) - (send trans :load-arg (var . offset) (- closure-level (var . level)) - (send self :var-bindframe var))) - ((object) - (let ((self-var (send idtable :get 'self))) - (if (and avant-mode (not (self-var . bindframe)) (> closure-level (var . level))) - (setq (self-var . bindframe) t))) - (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))) - ) + (flet ((push-cframe (&optional (pushvar var)) + (when (and avant-mode (> closure-level (var . level))) + (unless (listp closure-frames) (setq closure-frames nil)) + (pushnew pushvar closure-frames) + (unless (pushvar . bindframe) (setq (pushvar . bindframe) t))))) + (case (var . binding) + ((special) (send trans :load-global (var . name))) + ((local let lambda) + (push-cframe) + (send trans :load-local (var . offset) (- closure-level (var . level)) + (send self :var-bindframe var))) + ((param arg) + (push-cframe) + (send trans :load-arg (var . offset) (- closure-level (var . level)) + (send self :var-bindframe var))) + ((object) + (push-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))) @@ -976,25 +988,21 @@ (send self :eval lab) (send self :eval val) (send trans :throw)) - (:closure (form &optional comment) + (:closure (form &optional comment cframes) (let* ((fn #'(lambda (f) (and (f . offset) (= (f . level) closure-level)))) - (bindframes (remove-if-not fn frames)) - (argframes (remove-if-not fn argframes)) (fletframes (remove-if-not fn fletframes)) frame) - (when (or argframes bindframes fletframes) - ;; create a new vector which holds every and each of the - ;; argument, bind and flet frames - (let ((size (max (if argframes ((car argframes) . offset) 0) - (if bindframes ((car bindframes) . offset) 0) + (when (or cframes fletframes) + ;; create a new vector which holds all necessary frames + (let ((size (max (if cframes (apply #'max cframes) 0) (if fletframes ((car fletframes) . offset) 0)))) - (setq frame (send self :create-frame nil (1+ size) comment)) - (dolist (framelist (list argframes bindframes fletframes)) - (dolist (f framelist) - (send trans :load-local (f . offset) 0) - (send trans :store-local (f . offset) 0 (frame . offset)))))) - + (dolist (f cframes) + (send trans :load-local f 0) + (send trans :store-local f 0 (frame . offset))) + (dolist (f fletframes) + (send trans :load-local (f . offset) 0) + (send trans :store-local (f . offset) 0 (frame . offset))))) ;; makeclosure (send trans :closure form (plusp closure-level) (not (not frame))))) (:unwind-protect (prot cleanup) @@ -1083,11 +1091,22 @@ (setq newcomp (send self :copy-compiler)) (setq (newcomp . idtable) idtable) (setq (newcomp . flets) flets) - (send newcomp :lambda (cadr fn) (cddr fn) nil) + (if closure-frames + (progn + (send newcomp :lambda (cadr fn) (cddr fn) nil) + (when (listp closure-frames) + (dolist (v closure-frames) + (pushnew fn (identifier-clist v))))) + (progn + (let ((closure-frames t)) + (send newcomp :lambda (cadr fn) (cddr fn) nil) + (when (listp closure-frames) + (dolist (v closure-frames) + (pushnew fn (identifier-clist v))))))) (send trans :discard 1)) (progn (setq entry (send self :genlabel "CLO")) - (send self :closure entry "lambda-closure") + (send self :closure entry "lambda-closure" (send idtable :get-cframes fn)) (setq newcomp (send self :copy-compiler)) (send self :add-closure (list entry fn newcomp))))))) (:flet (funcs bodies recursive-scope) From e7711c30cb02a4273dcde5d2b158340679c2745b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 00:27:48 +0900 Subject: [PATCH 252/387] Also bind required frames in :unwind-protect --- lisp/comp/comp.l | 51 +++++++++++++++++++++--------------------------- 1 file changed, 22 insertions(+), 29 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 8f50632c9..883b032ef 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1005,24 +1005,33 @@ (send trans :store-local (f . offset) 0 (frame . offset))))) ;; makeclosure (send trans :closure form (plusp closure-level) (not (not frame))))) + (:lambda-preevaluation (fn) + (let* ((param (cadr fn)) + (forms (cddr fn)) + (newcomp (send self :copy-compiler))) + (setq (newcomp . idtable) idtable) + (setq (newcomp . flets) flets) + (flet ((lambda-closure-frames () + (send newcomp :lambda param forms nil) + (when (listp closure-frames) + (dolist (v closure-frames) + (pushnew fn (identifier-clist v)))))) + (if closure-frames + (lambda-closure-frames) + (let ((closure-frames t)) + (lambda-closure-frames))) + (send trans :discard 1)))) (:unwind-protect (prot cleanup) - (let (cleaner newcomp) + (let ((fn (cons 'lambda (cons nil cleanup))) + cleaner newcomp) (if avant-mode - (progn - (setq newcomp (send self :copy-compiler)) - (setq (newcomp . idtable) idtable) - (setq (newcomp . flets) flets) - (send newcomp :lambda nil cleanup nil) - (send trans :discard 1)) + (send self :lambda-preevaluation fn) (progn (setq cleaner (send self :genlabel "UWP")) (push (send trans :offset-from-fp) unwind-frames) - (send self :closure cleaner "unwind protect") ;make cleanup closure + (send self :closure cleaner "unwind protect" (send idtable :get-cframes fn)) ;make cleanup closure (setq newcomp (send self :copy-compiler)) - (send self :add-closure - (list cleaner - (cons 'lambda (cons nil cleanup)) - newcomp)))) + (send self :add-closure (list cleaner fn newcomp)))) (send trans :bind-cleaner) (send self :eval prot) (send trans :call-cleaner cleaner) @@ -1087,23 +1096,7 @@ (send trans :getfunc fn))) (let (entry newcomp) ; #'(lambda (...) ...) (if avant-mode - (progn - (setq newcomp (send self :copy-compiler)) - (setq (newcomp . idtable) idtable) - (setq (newcomp . flets) flets) - (if closure-frames - (progn - (send newcomp :lambda (cadr fn) (cddr fn) nil) - (when (listp closure-frames) - (dolist (v closure-frames) - (pushnew fn (identifier-clist v))))) - (progn - (let ((closure-frames t)) - (send newcomp :lambda (cadr fn) (cddr fn) nil) - (when (listp closure-frames) - (dolist (v closure-frames) - (pushnew fn (identifier-clist v))))))) - (send trans :discard 1)) + (send self :lambda-preevaluation fn) (progn (setq entry (send self :genlabel "CLO")) (send self :closure entry "lambda-closure" (send idtable :get-cframes fn)) From 1b4747556c04c558bbae7f5b0465478d491abaaa Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 17:45:12 +0900 Subject: [PATCH 253/387] Raise errors when a variable frame is not included in the closure --- lisp/comp/comp.l | 38 +++++++++++++++++++++++++++----------- 1 file changed, 27 insertions(+), 11 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 883b032ef..bca75683d 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -251,6 +251,7 @@ :slots (idtable ;identifier-table closure-level ;current closure level + current-cframes ;current closure bind frames scope ;current variable scope (for sequential let) frames ;list of the number of special bindings fletframes ;list of function frames @@ -495,19 +496,28 @@ (when (and avant-mode (> closure-level (var . level))) (unless (listp closure-frames) (setq closure-frames nil)) (pushnew pushvar closure-frames) - (unless (pushvar . bindframe) (setq (pushvar . bindframe) t))))) + (unless (pushvar . bindframe) (setq (pushvar . bindframe) t)))) + (check-cframe (&optional (pushvar var)) + (when (and (not avant-mode) (= (- closure-level (var . level)) 1) + (numberp (pushvar . bindframe))) + (unless (find (pushvar . bindframe) current-cframes) + (send self :error ";; unbound bindframe detected when loading variable ~S" + (var . name)))))) (case (var . binding) ((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) (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 @@ -1026,12 +1036,12 @@ cleaner newcomp) (if avant-mode (send self :lambda-preevaluation fn) - (progn + (let ((cframes (send idtable :get-cframes fn))) (setq cleaner (send self :genlabel "UWP")) (push (send trans :offset-from-fp) unwind-frames) - (send self :closure cleaner "unwind protect" (send idtable :get-cframes fn)) ;make cleanup closure + (send self :closure cleaner "unwind protect" cframes) ;make cleanup closure (setq newcomp (send self :copy-compiler)) - (send self :add-closure (list cleaner fn newcomp)))) + (send self :add-closure (list cleaner fn newcomp cframes)))) (send trans :bind-cleaner) (send self :eval prot) (send trans :call-cleaner cleaner) @@ -1097,11 +1107,11 @@ (let (entry newcomp) ; #'(lambda (...) ...) (if avant-mode (send self :lambda-preevaluation fn) - (progn + (let ((cframes (send idtable :get-cframes fn))) (setq entry (send self :genlabel "CLO")) - (send self :closure entry "lambda-closure" (send idtable :get-cframes fn)) + (send self :closure entry "lambda-closure" cframes) (setq newcomp (send self :copy-compiler)) - (send self :add-closure (list entry fn newcomp))))))) + (send self :add-closure (list entry fn newcomp cframes))))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet (let (newcomp newcomps flets-tmp flist fletframe) @@ -1142,9 +1152,10 @@ (if (not avant-mode) (dolist (fn (reverse flets-tmp)) - (send self :closure (fn . entry) "flet env") - (setq (fn . offset) (1- (send trans :offset-from-fp))) - (send self :add-closure (list (fn . entry) (fn . body) (fn . comp))))) + (let ((cframes (send idtable :get-cframes (fn . body)))) + (send self :closure (fn . entry) "flet env" cframes) + (setq (fn . offset) (1- (send trans :offset-from-fp))) + (send self :add-closure (list (fn . entry) (fn . body) (fn . comp) cframes))))) (if (not recursive-scope) ;; when not recursive setup the bindframe after the closure declaration @@ -1557,7 +1568,12 @@ ) (:compile-closures () (dolist (aclosure (reverse function-closures)) - (send (caddr aclosure) :compile-a-closure (car aclosure) (cadr aclosure))) + (let ((entry (first aclosure)) + (def (second aclosure)) + (newcomp (third aclosure)) + (cframes (fourth aclosure))) + (setq (newcomp . current-cframes) cframes) + (send newcomp :compile-a-closure entry def))) (setq function-closures nil)) (:toplevel-eval (form) (setq function-closures nil) From f48ce6d4ab6441b3e79f272f5898df95009ad7f6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 18:13:34 +0900 Subject: [PATCH 254/387] Also bind required frames in :flet --- lisp/comp/comp.l | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index bca75683d..ff8eec301 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1015,12 +1015,13 @@ (send trans :store-local (f . offset) 0 (frame . offset))))) ;; makeclosure (send trans :closure form (plusp closure-level) (not (not frame))))) - (:lambda-preevaluation (fn) - (let* ((param (cadr fn)) - (forms (cddr fn)) - (newcomp (send self :copy-compiler))) - (setq (newcomp . idtable) idtable) - (setq (newcomp . flets) flets) + (:lambda-preevaluation (fn &optional newcomp) + (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 :lambda param forms nil) (when (listp closure-frames) @@ -1135,7 +1136,7 @@ (setq (newcomp . flets) (append flets-tmp flets)) (setq (newcomp . idtable) idtable) (dolist (fn flets-tmp) - (send newcomp :lambda (cadr (fn . body)) (cddr (fn . body)) nil))) + (send self :lambda-preevaluation (fn . body) newcomp))) ;; pre-evaluate body (let ((trans (send trans :copy-translator)) From c871d77ffcd7e32da84a47f6899d5e0ae27be177 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 18:27:12 +0900 Subject: [PATCH 255/387] Pass closure-level as a variable in :get-cframes --- lisp/comp/comp.l | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index ff8eec301..f7cf4a571 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -191,12 +191,12 @@ (while (>= lev 0) (setq r (assq id (svref frames lev))) (if r (return-from :get (cdr r)) (dec lev))))) - (:get-cframes (fn &optional (lev level)) + (:get-cframes (fn clevel &optional (lev level)) (let (acc) (while (>= lev 0) (dolist (var (svref frames lev)) (setq var (cdr var)) - (when (and var (= (var . level) closure-level) + (when (and var (= (var . level) clevel) (find fn (var . clist) :test #'equal)) (pushnew (var . bindframe) acc))) (dec lev)) @@ -501,7 +501,7 @@ (when (and (not avant-mode) (= (- closure-level (var . level)) 1) (numberp (pushvar . bindframe))) (unless (find (pushvar . bindframe) current-cframes) - (send self :error ";; unbound bindframe detected when loading variable ~S" + (warn ";; unbound bindframe detected when loading variable ~S~%" (var . name)))))) (case (var . binding) ((special) (send trans :load-global (var . name))) @@ -1037,7 +1037,7 @@ cleaner newcomp) (if avant-mode (send self :lambda-preevaluation fn) - (let ((cframes (send idtable :get-cframes fn))) + (let ((cframes (send idtable :get-cframes fn closure-level))) (setq cleaner (send self :genlabel "UWP")) (push (send trans :offset-from-fp) unwind-frames) (send self :closure cleaner "unwind protect" cframes) ;make cleanup closure @@ -1108,7 +1108,7 @@ (let (entry newcomp) ; #'(lambda (...) ...) (if avant-mode (send self :lambda-preevaluation fn) - (let ((cframes (send idtable :get-cframes fn))) + (let ((cframes (send idtable :get-cframes fn closure-level))) (setq entry (send self :genlabel "CLO")) (send self :closure entry "lambda-closure" cframes) (setq newcomp (send self :copy-compiler)) @@ -1153,7 +1153,7 @@ (if (not avant-mode) (dolist (fn (reverse flets-tmp)) - (let ((cframes (send idtable :get-cframes (fn . body)))) + (let ((cframes (send idtable :get-cframes (fn . body) closure-level))) (send self :closure (fn . entry) "flet env" cframes) (setq (fn . offset) (1- (send trans :offset-from-fp))) (send self :add-closure (list (fn . entry) (fn . body) (fn . comp) cframes))))) From 49d5e2d831d2a1fff8106e4f9ab0d59cc5e61045 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 19:04:06 +0900 Subject: [PATCH 256/387] Update keyvar clist in :lambda --- lisp/comp/comp.l | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index f7cf4a571..ac0f617c1 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1449,6 +1449,7 @@ (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))))))) ) ) From 77e10aeb2484fafbe063d556fe35919a7e4cbe20 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 21:12:03 +0900 Subject: [PATCH 257/387] Add comments in comp.l code --- lisp/comp/comp.l | 38 +++++++++++++++++++++++++++++++++++++- lisp/comp/trans.l | 1 + 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index ac0f617c1..5e574f68f 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -47,6 +47,7 @@ (defvar comp nil "$Id$") (defvar trans) (defvar *multipass-optimize* t) +;; define as a variable so we can `(let ((closure-frames ...)))' it (defvar closure-frames nil) (defun ovafp (form) (and (cdr form) (symbolp (cdr form)))) @@ -154,7 +155,6 @@ (defclass function-identifier :super object :slots (name entry binding level offset bindframe body comp)) ) -;; binding = (constant, local, global, special) (eval-when (load eval) (defmethod function-identifier @@ -192,6 +192,9 @@ (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) (dolist (var (svref frames lev)) @@ -411,12 +414,14 @@ (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)) @@ -493,17 +498,21 @@ (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-level (var . level))) (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)) 1) (numberp (pushvar . bindframe))) (unless (find (pushvar . bindframe) current-cframes) (warn ";; unbound bindframe detected when loading variable ~S~%" (var . name)))))) (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) @@ -516,6 +525,8 @@ (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)) @@ -867,6 +878,13 @@ (let ((unwind-save unwind-frames) (i 0) local-list bindframe vlist closure-vlist) (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)) @@ -999,6 +1017,15 @@ (send self :eval val) (send trans :throw)) (:closure (form &optional comment cframes) + ;; 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. + ;; TODO: fletframes currently only have scope based evaluation: + ;; if one closure in a given scope has a reference to a fletframe, all of the closures + ;; in that scope will bear that reference as well. + (let* ((fn #'(lambda (f) (and (f . offset) (= (f . level) closure-level)))) (fletframes (remove-if-not fn fletframes)) frame) @@ -1006,6 +1033,8 @@ ;; create a new vector which holds all necessary frames (let ((size (max (if cframes (apply #'max cframes) 0) (if fletframes ((car fletframes) . offset) 0)))) + ;; TODO: in order to avoid having to remap the variables bindframe, we create a + ;; vector which simulates the local stack, but only populates the required fields. (setq frame (send self :create-frame nil (1+ size) comment)) (dolist (f cframes) (send trans :load-local f 0) @@ -1016,6 +1045,8 @@ ;; makeclosure (send trans :closure form (plusp closure-level) (not (not frame))))) (:lambda-preevaluation (fn &optional 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 @@ -1027,6 +1058,9 @@ (when (listp closure-frames) (dolist (v closure-frames) (pushnew fn (identifier-clist v)))))) + ;; 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 (if closure-frames (lambda-closure-frames) (let ((closure-frames t)) @@ -1246,6 +1280,8 @@ (unwind-save unwind-frames) (cvar-i 0) argframe vlist closure-vlist) (when rec + ;; an 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)) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 7fbfe7418..4fb51de1d 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -47,6 +47,7 @@ index))) (defun maybe-format (fstream format-string &rest args) + ;; suppress all output in pre-evaluation mode (unless avant-mode (apply #'format fstream format-string args))) From d8404d02d17bf836f1dcb8597c33f50cbf26992c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 16 May 2022 21:42:15 +0900 Subject: [PATCH 258/387] Upgrade unbound frame detection warning to error --- lisp/comp/comp.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 5e574f68f..1218993ae 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -508,7 +508,7 @@ (when (and (not avant-mode) (= (- closure-level (var . level)) 1) (numberp (pushvar . bindframe))) (unless (find (pushvar . bindframe) current-cframes) - (warn ";; unbound bindframe detected when loading variable ~S~%" + (send self :error ";; unbound bindframe detected when loading variable ~S" (var . name)))))) (case (var . binding) ;; special variables are accessed through :load-global, so we don't need From 4bd5dd8477a8c46bdd0312e7f598d99372246d03 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 23 May 2022 15:17:22 +0900 Subject: [PATCH 259/387] Add newline after compilation warnings --- lisp/comp/comp.l | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 1218993ae..a2f302289 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -761,11 +761,11 @@ ((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) + "eval-when must appear at toplevel, ignored~%") t) (t (send self :error "Compiling method is not yet implemented for ~S" fn)))) ) ;defmethod ) ;eval-when From 0ba3c52dff869ec09bc6e77d9ac0b5f19684d5ef Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 25 May 2022 10:42:08 +0900 Subject: [PATCH 260/387] Fix: (instance object) is considered as list --- lisp/c/eus.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index cab07e90e..ba3e58903 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -817,8 +817,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) From 6624c15ede8b55e1e570aedaad7d115de9fbd231 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 26 May 2022 19:31:21 +0900 Subject: [PATCH 261/387] Avoid segmentation faults when copying objects with less than two slots --- lisp/c/leo.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/leo.c b/lisp/c/leo.c index 0276f6068..343b58ffb 100644 --- a/lisp/c/leo.c +++ b/lisp/c/leo.c @@ -592,7 +592,7 @@ register pointer org; cpx += 2; switch (etype) { case ELM_FIXED: - clone->c.obj.iv[1]=copyobj(ctx,x); + if (s>1) 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]); break; From 601e1a1771baef420c2c451631a142fdcc5cc5a4 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 7 Jun 2022 10:26:48 +0900 Subject: [PATCH 262/387] Add beta warning message at startup --- lisp/l/toplevel.l | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 4e2f114eb..35dd59984 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -298,6 +298,8 @@ (exit 1)) ; (format t "argv=~a~%" argv) (if *eustop-hook* (funcall *eustop-hook* *eustop-argument*)) + ;; print temporary eus10 warning + (warning-message 3 "Welcome to eus10 beta. Please report any bugs at https://github.com/Affonso-Gui/EusLisp/issues or directly to affonso@jsk.imi.i.u-tokyo.ac.jp~%") ;; enter read-eval-loop session (catch :eusexit ;; load files given in arguments From 0c4f43766ca676db90e823a07988ccb7804f1ce9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 7 Jun 2022 15:19:47 +0900 Subject: [PATCH 263/387] Remove lambda-closure hacks in conditions.l --- lisp/l/conditions.l | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 3f3e5fc2c..807007f5b 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -52,7 +52,7 @@ slots))) ',name)) -(defun install-handler-raw (label handler) +(defun install-handler (label handler) ;; ensure condition class (if (eq label t) (setq label condition)) (unless (and (classp label) (derivedp (instantiate label) condition)) @@ -61,12 +61,6 @@ *condition-handler*) t) -(defun install-handler (label handler) - ;; ensure global scope - (when (and (consp handler) (eql (car handler) 'lambda-closure)) - (setq handler `(lambda-closure ,(second handler) 0 0 ,@(nthcdr 4 handler)))) - (install-handler-raw label handler)) - (defun remove-handler (label &optional handler) (let ((item (if handler @@ -82,7 +76,7 @@ (defmacro handler-bind (bindings &rest forms) `(let ((*condition-handler* (copy-list *condition-handler*))) - ,@(mapcar #'(lambda (bind) `(install-handler-raw ,@bind)) bindings) + ,@(mapcar #'(lambda (bind) `(install-handler ,@bind)) bindings) ,@forms)) (defun get-handler-frame (&optional (name "HANDLER-CASE-")) @@ -184,8 +178,7 @@ `(progn (defcondition ,obj :super unix::signal-received) (unix:signal ,sig - ;; ensure global scope - ',`(lambda-closure nil 0 0 (sig code) (signals ,obj :sig sig :code code ,@init-args))))) + #'(lambda (sig code) (signals ,obj :sig sig :code code ,@init-args))))) (defmacro unix::with-alarm-interrupt (&rest body) (let ((interval (gensym)) (value (gensym))) From 57b06cf128a65cc0a5cadfd1e94df2e61aa8da80 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 23 Jun 2022 18:23:19 +0900 Subject: [PATCH 264/387] Add eussigobj to shield eussigvec handlers from gc --- lisp/c/collector.c | 1 + lisp/c/eus.c | 2 ++ lisp/c/eus.h | 1 + lisp/c/memory.c | 1 + lisp/c/memory.mutex.c | 1 + lisp/c/memory.safe.c | 1 + lisp/c/paragc.c | 1 + lisp/c/unixcall.c | 10 ++++++++++ 8 files changed, 18 insertions(+) diff --git a/lisp/c/collector.c b/lisp/c/collector.c index 7c7f6308d..107f71133 100644 --- a/lisp/c/collector.c +++ b/lisp/c/collector.c @@ -525,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/eus.c b/lisp/c/eus.c index e59028236..8d453738d 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; @@ -601,6 +602,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; diff --git a/lisp/c/eus.h b/lisp/c/eus.h index ba3e58903..6e59ef50b 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -591,6 +591,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 */ diff --git a/lisp/c/memory.c b/lisp/c/memory.c index 0b55b7972..f34f2d2b1 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -536,6 +536,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 ); diff --git a/lisp/c/memory.mutex.c b/lisp/c/memory.mutex.c index 2da4b48d7..57bd3bf88 100644 --- a/lisp/c/memory.mutex.c +++ b/lisp/c/memory.mutex.c @@ -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 Date: Wed, 6 Jul 2022 21:11:21 +0900 Subject: [PATCH 265/387] Add lisp::atomic to postpone handler evaluation --- lisp/l/conditions.l | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 807007f5b..f153777fd 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -101,6 +101,24 @@ ,form)) (send *keyword-package* :unintern ,handler-frame))))) +(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")) From 4f4d046452eae96af3f4d754253b2b64b142d82b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 21 Jul 2022 18:03:00 +0900 Subject: [PATCH 266/387] Supress external symbol errors in read_opt --- lisp/c/reader.c | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/c/reader.c b/lisp/c/reader.c index 5b1d54a24..6760e8556 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -726,6 +726,7 @@ 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); vpush(pkgstr); From bc95c18ed3ee7bf8f5e4d6d6f7a996e5103e5d0a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 9 Aug 2022 22:09:04 +0900 Subject: [PATCH 267/387] Add lisp::install-error-handler for backward compability --- lisp/l/conditions.l | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index f153777fd..0301d5aef 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -61,6 +61,15 @@ *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 ((item (if handler From d903d781579eb8e16e1405eab22af16223b5fbc5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 09:37:52 +0900 Subject: [PATCH 268/387] Add limited sys:*gc-hook* for backward compability --- lisp/c/eus.c | 3 ++- lisp/c/eus.h | 2 +- lisp/c/memory.c | 14 ++++++-------- lisp/l/eusstart.l | 2 +- 4 files changed, 10 insertions(+), 11 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 8d453738d..9c93fe9f8 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -128,7 +128,7 @@ pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; pointer TOPLEVEL,QEVALHOOK,QEXITHOOK,FATALERROR; -pointer QUNBOUND,QDEBUG,QGCDEBUG; +pointer QUNBOUND,QDEBUG,QGCHOOK,QGCDEBUG; pointer QTHREADS; /* system:*threads* */ pointer QPARAGC; pointer QVERSION; @@ -719,6 +719,7 @@ static void initsymbols() 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); diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 6e59ef50b..77c052d9a 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -653,7 +653,7 @@ extern pointer CLASS; extern pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; extern pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; extern pointer TOPLEVEL,QEVALHOOK,QEXITHOOK; -extern pointer QUNBOUND,QDEBUG,QGCDEBUG; +extern pointer QUNBOUND,QDEBUG,QGCHOOK,QGCDEBUG; extern pointer QTHREADS; extern pointer QEQ,QEQUAL,QNOT; extern pointer QAND, QOR, QNOT; diff --git a/lisp/c/memory.c b/lisp/c/memory.c index f34f2d2b1..e52dfd4ab 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -788,7 +788,12 @@ void gc() int i, r; context *ctx=euscontexts[thr_self()]; - if (debug || speval(QGCDEBUG)!=NIL) fprintf(stderr,"\n;; gc: thread=%d ",thr_self()); + 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++; times(&tbuf1); @@ -829,13 +834,6 @@ void gc() /* 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. - - 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; } diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index c1ebb02fb..5599f1864 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -172,7 +172,7 @@ (export '( GC GCTIME RGCCOUNT RGCTIME RGCALLOCATED *GC-MERGE* *GC-MARGIN* - *GC-DEBUG* *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 From 929f6c72b88e7fcd854ef13ec8ea24d4f102cdd5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 18:27:01 +0900 Subject: [PATCH 269/387] Check compiler version when loading binary files --- lisp/Makefile.Alpha | 1 + lisp/Makefile.Cygwin | 1 + lisp/Makefile.Cygwin32 | 1 + lisp/Makefile.Cygwin64 | 1 + lisp/Makefile.Darwin | 1 + lisp/Makefile.IRIX | 1 + lisp/Makefile.IRIX5 | 2 +- lisp/Makefile.IRIX6 | 1 + lisp/Makefile.Linux | 1 + lisp/Makefile.Linux.ppc | 1 + lisp/Makefile.Linux.thread | 1 + lisp/Makefile.Linux64 | 1 + lisp/Makefile.LinuxARM | 1 + lisp/Makefile.LinuxSH4.2 | 1 + lisp/Makefile.SunOS4 | 1 + lisp/Makefile.SunOS5 | 1 + lisp/Makefile.SunOS5.X11R6.1 | 1 + lisp/Makefile.SunOS5.i386 | 1 + lisp/Makefile.generic1 | 1 + lisp/c/compsub.c | 26 ++++++++++++++++++++++++++ lisp/c/eus.c | 9 ++++++--- lisp/c/eus_proto.h | 1 + lisp/comp/comp.l | 5 ++++- lisp/comp/trans.l | 3 +++ lisp/l/constants.l | 1 + lisp/l/eusstart.l | 1 - 26 files changed, 60 insertions(+), 6 deletions(-) diff --git a/lisp/Makefile.Alpha b/lisp/Makefile.Alpha index bcb6c222c..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)\" \ 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.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..e17152bd8 100644 --- a/lisp/Makefile.generic1 +++ b/lisp/Makefile.generic1 @@ -29,5 +29,6 @@ XWINDOWDIR=xwindow GLDIR=opengl/src GLINCLUDE=-I/usr/local/Mesa/include/ VERSION=9.29 +COMPILERVERSION=1.54 XVERSION=X_V11R6 diff --git a/lisp/c/compsub.c b/lisp/c/compsub.c index 18f13617b..d025f6a34 100644 --- a/lisp/c/compsub.c +++ b/lisp/c/compsub.c @@ -11,6 +11,32 @@ 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 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_USER, (pointer)"compiler version mismatch"); + } +#endif +} + int maerror() { error(E_MISMATCHARG);} diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 9c93fe9f8..b13e23cec 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -115,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; @@ -131,7 +131,7 @@ pointer TOPLEVEL,QEVALHOOK,QEXITHOOK,FATALERROR; pointer QUNBOUND,QDEBUG,QGCHOOK,QGCDEBUG; pointer QTHREADS; /* system:*threads* */ pointer QPARAGC; -pointer QVERSION; +pointer QVERSION,QCOMPILERVERSION; pointer QEQ,QEQUAL,QNOT, QAND, QOR; /* keywords */ @@ -614,6 +614,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)); @@ -904,8 +905,10 @@ static void initfeatures() p=stacknlist(ctx,4); QVERSION=defvar(ctx, "LISP-IMPLEMENTATION-VERSION", p,lisppkg); - /*make features*/ + p=makestring(COMPILERVERSION,strlen(COMPILERVERSION)); + QCOMPILERVERSION=defvar(ctx, "COMPILER-IMPLEMENTATION-VERSION", p, compilerpkg); + /*make features*/ p=NIL; #if vax p=cons(ctx,intern(ctx,"VAX",3,keywordpkg),p); diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index bd8723f93..9b6dc55e8 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -116,6 +116,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*/); diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index a2f302289..84bcc8299 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1782,6 +1782,7 @@ (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*) "") @@ -1932,9 +1933,11 @@ ) 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$ ") diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 4fb51de1d..151192b3d 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -758,6 +758,9 @@ register context *ctx; int n; pointer *argv; pointer env;~%" entry) (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 "#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;~%") diff --git a/lisp/l/constants.l b/lisp/l/constants.l index 9a51f876c..7648a3353 100644 --- a/lisp/l/constants.l +++ b/lisp/l/constants.l @@ -95,6 +95,7 @@ (setq (tio . outstream) *standard-output*)) (send *system-package* :nicknames '("SI" "SYS")) +(send (find-package "COMPILER") :nicknames '("COMP")) #+:ustation diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index 5599f1864..7dcdbc2b7 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -327,7 +327,6 @@ (symbol-function '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") From 97c5339836795055a76d6a1a7076fdb1eeeb9f22 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 18:46:37 +0900 Subject: [PATCH 270/387] E_USER only accepts one parameter --- lisp/c/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 4d1859d71..25322d994 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -348,7 +348,7 @@ pointer env,bf; supplied[nokeys]=svar; nokeys++; if (nokeys>=KEYWORDPARAMETERLIMIT) { - error(E_USER, "Too many keyword parameters >%d",KEYWORDPARAMETERLIMIT); + error(E_USER, (pointer)"too many keyword parameters >=128"); } } n=0; From f615ae7be329bda4b62bcdcfdf0ece702afecd84 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 19:29:40 +0900 Subject: [PATCH 271/387] Add supermember and superassoc for backward compability --- lisp/l/common.l | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/l/common.l b/lisp/l/common.l index 241809420..b0a36efb7 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -27,6 +27,7 @@ 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 + supermember superassoc copy-list nreconc acons member assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subsetp maplist mapcon)) @@ -474,6 +475,9 @@ 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 &optional (n 1)) (unless (and (integerp n) (>= n 0)) From 6dc8651823b90035799909767d4be02264a3a402 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 20:07:32 +0900 Subject: [PATCH 272/387] Fix type-check declarations on compilation --- lisp/comp/comp.l | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 84bcc8299..482212f14 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1235,14 +1235,14 @@ (dolist (id (cddr decl)) (setq v (send self :enter-variable id)) (send v :type (cadr decl)) - (push id acc))) + (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)) - (push id acc))) + (push (cons id (v . type)) acc))) (optimize (setq *optimize* (cadr decl))) (safety (setq *safety* (cadr decl))) (space (setq *space* (cadr decl))) @@ -1252,7 +1252,7 @@ (dolist (id (cdr decl)) (setq v (send self :enter-variable id)) (send v :type (car decl)) - (push id acc))) + (push (cons id (v . type)) acc))) (t (send self :error "unknown declaration ~S" decl)))))) (nreverse acc))) (:lambda (param forms &optional (rec t)) @@ -1501,11 +1501,13 @@ (let ((offset (1- (send trans :offset-from-fp)))) (push (send self :bind var argframe 'local offset) vlist))))) ;;; type check declaration variables - (dolist (id decl-vars) - (let ((v (send self :variable id))) + (dolist (dvar decl-vars) + (let* ((id (car dvar)) + (tp (cdr dvar)) + (v (send self :variable id))) (unless (eql (v . binding) 'unknown) (send self :load-var id) - (send trans :type-check-declare (v . type))))) + (send trans :type-check-declare tp)))) ;;; evaluate lambda body (send self :progn forms) ;;; unwind/restore From cb10f829c36560f59426b317b020485b81033629 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 20:19:49 +0900 Subject: [PATCH 273/387] Add *type-check-declare* option on compiler and default it to nil --- lisp/comp/comp.l | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 482212f14..ea3ea1441 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -17,12 +17,14 @@ (eval-when (load eval) (export '(compile 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) @@ -1501,13 +1503,14 @@ (let ((offset (1- (send trans :offset-from-fp)))) (push (send self :bind var argframe 'local offset) vlist))))) ;;; type check declaration variables - (dolist (dvar decl-vars) - (let* ((id (car dvar)) - (tp (cdr dvar)) - (v (send self :variable id))) - (unless (eql (v . binding) 'unknown) - (send self :load-var id) - (send trans :type-check-declare tp)))) + (when *type-check-declare* + (dolist (dvar decl-vars) + (let* ((id (car dvar)) + (tp (cdr dvar)) + (v (send self :variable id))) + (unless (eql (v . binding) 'unknown) + (send self :load-var id) + (send trans :type-check-declare tp))))) ;;; evaluate lambda body (send self :progn forms) ;;; unwind/restore From 65bb832aa953d8d12bcb40e5ecdae9ed73e91c20 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 21:25:40 +0900 Subject: [PATCH 274/387] Type c errors --- lisp/c/arith.c | 18 +++++++-------- lisp/c/big.c | 4 ++-- lisp/c/calleus.c | 12 +++++----- lisp/c/compsub.c | 2 +- lisp/c/eus.c | 2 +- lisp/c/eval.c | 58 ++++++++++++++++++++++++----------------------- lisp/c/leo.c | 8 +++---- lisp/c/lispio.c | 14 ++++++------ lisp/c/lists.c | 2 +- lisp/c/loadelf.c | 16 +++++++------ lisp/c/makes.c | 4 ++-- lisp/c/matrix.c | 2 +- lisp/c/mthread.c | 8 +++---- lisp/c/reader.c | 10 ++++---- lisp/c/sequence.c | 6 ++--- lisp/c/specials.c | 4 ++-- lisp/c/sysfunc.c | 12 +++++----- lisp/c/unixcall.c | 12 +++++----- lisp/comp/trans.l | 2 +- 19 files changed, 100 insertions(+), 96 deletions(-) diff --git a/lisp/c/arith.c b/lisp/c/arith.c index 2f43e0b20..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) @@ -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);} @@ -786,7 +786,7 @@ register pointer argv[]; if (isint(b)) { is=intval(b); vpop(); goto ITIMES;} } else if (pisratio(a)) { - error(E_USER,(pointer)"sorry, big * ratio is not yet implemented.");} + error(E_TYPE_ERROR,(pointer)"big ratio multiplication is not implemented");} else error(E_NONUMBER); } ctx->lastalloc= vpop(); @@ -1404,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/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/compsub.c b/lisp/c/compsub.c index d025f6a34..07397b6bd 100644 --- a/lisp/c/compsub.c +++ b/lisp/c/compsub.c @@ -32,7 +32,7 @@ const char* compver; if (!checkversion(compver, loadver)) { fprintf(stderr, ";; compile time version: %s\n", compver); fprintf(stderr, ";; load time version: %s\n", loadver); - error(E_USER, (pointer)"compiler version mismatch"); + error(E_PROGRAM_ERROR, (pointer)"compiler version mismatch"); } #endif } diff --git a/lisp/c/eus.c b/lisp/c/eus.c index b13e23cec..02827177d 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -221,7 +221,7 @@ char *errmsg[100]={ "keyword expected for arguments", "no such keyword", "multiple variable declaration", -/* ARGUMENT ERROR */ +/* PROGRAM ERROR */ "", "string is too long", "class table overflow", diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 25322d994..f28135c29 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -180,7 +180,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; @@ -331,7 +333,7 @@ pointer 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 { @@ -348,7 +350,7 @@ pointer env,bf; supplied[nokeys]=svar; nokeys++; if (nokeys>=KEYWORDPARAMETERLIMIT) { - error(E_USER, (pointer)"too many keyword parameters >=128"); + error(E_PROGRAM_ERROR, (pointer)"too many keyword parameters >=128"); } } n=0; @@ -518,7 +520,7 @@ pointer args[]; if (elmtypeof(lisparg)==ELM_FOREIGN) cargv[i++].ival=lisparg->c.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? */ @@ -985,7 +987,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"); } } /**/ @@ -1004,7 +1006,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 */ @@ -1017,8 +1019,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"); } } @@ -1202,9 +1204,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); @@ -1235,7 +1237,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"); } } /**/ @@ -1250,7 +1252,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 */ @@ -1263,8 +1265,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"); } } @@ -1311,7 +1313,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 (jmaxmemory) { 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)) { diff --git a/lisp/c/leo.c b/lisp/c/leo.c index 343b58ffb..e424a79ba 100644 --- a/lisp/c/leo.c +++ b/lisp/c/leo.c @@ -648,7 +648,7 @@ pointer argv[]; mutex_unlock(&mark_lock); #endif ctx->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); } @@ -661,8 +661,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) { @@ -696,7 +696,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 6feca4655..8a3b257c1 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,7 +545,7 @@ 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; diff --git a/lisp/c/lists.c b/lisp/c/lists.c index 765010756..fa3b03e1e 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -356,7 +356,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)"The second argument must be non-negative number"); while (iscons(a)) { ckpush(ccar(a)); a=ccdr(a); count++;} n=min(count,n); ctx->vsp -= n; 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 82dc024c6..67c9c226f 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -713,7 +713,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; @@ -722,7 +722,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 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/mthread.c b/lisp/c/mthread.c index e71db2b3c..00f231da2 100644 --- a/lisp/c/mthread.c +++ b/lisp/c/mthread.c @@ -30,7 +30,7 @@ int mark_lock_thread; pointer get_free_thread() { register pointer port; if (speval(QTHREADS)==NIL) { - error(E_USER,"No threads found. Please create with 'sys:make-thread'");} + error(E_PROGRAM_ERROR,"No threads found. Please create with 'sys:make-thread'");} GC_REGION(sema_wait(&free_thread_sem);); mutex_lock(&free_thread_lock); port=ccar(free_threads); @@ -131,7 +131,7 @@ pointer argv[]; #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)"); + error(E_PROGRAM_ERROR,(pointer)"Number of threads reached limit (64)"); } newport->c.thrp.id=makeint(tid); /* ???? critical region problem */ #else @@ -139,7 +139,7 @@ pointer argv[]; newport, THR_SUSPENDED, &tid); if (tid>=MAXTHREAD) { deletecontext(tid, ctx); - error(E_USER,(pointer)"Number of threads reached limit (64)"); + error(E_PROGRAM_ERROR,(pointer)"Number of threads reached limit (64)"); } newport->c.thrp.id=makeint(tid); thr_continue(tid); @@ -205,7 +205,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; diff --git a/lisp/c/reader.c b/lisp/c/reader.c index 6760e8556..58b7c3834 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -593,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; @@ -658,7 +658,7 @@ char token[]; macrofunc=Spevalof(QREADTABLE)->c.rdtab.dispatch->c.vec.v[subchar]; if (macrofunc==NIL) { if (read_suppress) return(read1(ctx,f)); - error(E_USER,(pointer)"no # macro defined");} + error(E_NAME_ERROR,(pointer)"no # macro defined");} if (isint(macrofunc)) { /*internal macro*/ intmac=(pointer (*)())(intval(macrofunc)); result=(*intmac)(ctx,f,val,subchar,token);} @@ -779,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); @@ -924,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); @@ -1011,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);} diff --git a/lisp/c/sequence.c b/lisp/c/sequence.c index 1510a19e3..e260cea3f 100644 --- a/lisp/c/sequence.c +++ b/lisp/c/sequence.c @@ -385,7 +385,7 @@ pointer resulttype; r->c.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; @@ -1055,7 +1055,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; @@ -1073,7 +1073,7 @@ register pointer argv[]; else if (isarray(a) && a->c.ary.rank==makeint(1)) { vset(a->c.ary.entity,i,argv[2]); return(argv[2]);} - else error(E_USER,(pointer)"no sequence");} + else error(E_NOSEQ);} void sequence(ctx,mod) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 62985838d..6306fbab3 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -628,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; @@ -800,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; diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index 784c0d102..82928fd06 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -72,7 +72,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 +516,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 +565,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 +634,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,7 +680,7 @@ 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);} /****************************************************************/ @@ -860,7 +860,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; diff --git a/lisp/c/unixcall.c b/lisp/c/unixcall.c index 7b3a2daae..63ca12c0d 100644 --- a/lisp/c/unixcall.c +++ b/lisp/c/unixcall.c @@ -315,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) @@ -331,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) @@ -352,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) @@ -1498,7 +1498,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); @@ -1513,7 +1513,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); @@ -1631,7 +1631,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); } } diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 151192b3d..7f52f14ac 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -498,7 +498,7 @@ (list "E_NOLIST") (number "E_NONUMBER") (integer "E_NOINT") - (float "E_USER, (pointer)\"float expected\"") + (float "E_TYPE_ERROR, (pointer)\"float expected\"") (string "E_NOSTRING") (array "E_NOARRAY") (vector "E_NOVECTOR") From a621749c2dbd9e90ae1536ad625f7bb0faa776a1 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 21:34:10 +0900 Subject: [PATCH 275/387] Type l errors --- lisp/comp/comp.l | 2 +- lisp/l/array.l | 2 +- lisp/l/async.l | 4 ++-- lisp/l/common.l | 10 +++++----- lisp/l/constants.l | 2 +- lisp/l/process.l | 2 +- 6 files changed, 11 insertions(+), 11 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index ea3ea1441..47ffad620 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -108,7 +108,7 @@ (defun check-arg (req n &optional (fn "car/cdr")) (if (null (= req n)) - (error "mismatch arg for ~A" fn))) + (error argument-error "mismatch arg for ~A" fn))) (defun def-function-type (type funcs) (dolist (f funcs) (putprop f type 'function-result-type))) diff --git a/lisp/l/array.l b/lisp/l/array.l index 0a3d1b7f7..fbc018509 100644 --- a/lisp/l/array.l +++ b/lisp/l/array.l @@ -121,7 +121,7 @@ (do ((i 0 (1+ i))) ((>= i rank)) (setslot a array (+ i 5) (elt dim i))))) - (t (error "integer or list expected"))) + (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)) diff --git a/lisp/l/async.l b/lisp/l/async.l index 6adbe2037..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)) diff --git a/lisp/l/common.l b/lisp/l/common.l index b0a36efb7..8f7859cfa 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -481,7 +481,7 @@ if pos is bigger than the length of list, item is nconc'ed at the tail" (defun rotate-list (l) (append (cdr l) (list (car l)))) (defun last (x &optional (n 1)) (unless (and (integerp n) (>= n 0)) - (error "last &optional n must be a non negative integer")) + (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))) @@ -1103,7 +1103,7 @@ if pos is bigger than the length of list, item is nconc'ed at the tail" ',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) @@ -1145,11 +1145,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)))))) @@ -1158,7 +1158,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/constants.l b/lisp/l/constants.l index 7648a3353..975ced1d6 100644 --- a/lisp/l/constants.l +++ b/lisp/l/constants.l @@ -306,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)) diff --git a/lisp/l/process.l b/lisp/l/process.l index 7bbcb78ab..4f485e0a7 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))) From 8791ad4d09d225b5b90396d3efeced6266a45bed Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 22:09:58 +0900 Subject: [PATCH 276/387] Add sys:list-all-function-bindings documentation and update sys:list-al-bindings parameters --- doc/jlatex/jevaluation.tex | 13 +++++++++---- doc/latex/evaluation.tex | 13 ++++++++++--- 2 files changed, 19 insertions(+), 7 deletions(-) diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 31a569f9b..5c6111217 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -643,12 +643,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/latex/evaluation.tex b/doc/latex/evaluation.tex index eb40fcb48..b0d503119 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -699,11 +699,18 @@ \subsection{Debugging Aid} 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} From 59badb955ba6906c4f971fbcc9c4f5a4446de117 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 22:28:05 +0900 Subject: [PATCH 277/387] Add assoc-if-not and rassoc-if-not documentation --- doc/jlatex/jsequences.tex | 9 ++++++++- doc/latex/sequences.tex | 14 ++++++++++---- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index d967b28fb..04730efc5 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -323,7 +323,11 @@ \subsection{リスト} \funcdesc{assoc-if}{pred alist \&key key}{ {\em alist}の要素の{\bf car}が{\em pred}の条件にあった最初のものを返す。 -合わなければ、NILを返す。} +なければ、NILを返す。} + +\funcdesc{assoc-if-not}{pred alist \&key key}{ +{\em alist}の要素の{\bf car}が{\em pred}の条件に{\bfあわない}最初のものを返す。 +なければ、NILを返す。} \funcdesc{rassoc}{item alist \&key key (test \#'eq) test-not}{ {\bf cdr}が{\em item}に等しい{\em alist}のなかの最初の組を返す。} @@ -331,6 +335,9 @@ \subsection{リスト} \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}が与えられたとき、 diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex index b82f12231..2ba450710 100644 --- a/doc/latex/sequences.tex +++ b/doc/latex/sequences.tex @@ -321,15 +321,21 @@ \subsection{Lists} the {\em test}, or NIL if there is no such pair in the {\em alist}.} \funcdesc{assoc-if}{pred alist \&key key}{ -searches the association list {\em alist}. The value returned is the -first pair in the {\em alist} such that the {\em car} of the pair satisfies -the {\em pred}, or NIL if there is no such pair in the {\em alist}.} +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 \#'eq) 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 is satisfies {\em pred}.} +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}. From f205b2b8cf9ea964f8922a61290b9f36b3f63e5c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 22:44:11 +0900 Subject: [PATCH 278/387] Add cxr and other ordinal function documentations --- doc/jlatex/jsequences.tex | 81 ++++++++++++++++++++++++++++++++++++--- doc/latex/sequences.tex | 79 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 151 insertions(+), 9 deletions(-) diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index 04730efc5..428a97271 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{seventh}{list}{ +{\em list}の7番目の要素を取り出す。} + +\funcdesc{eighth}{list}{ +{\em list}の8番目の要素を取り出す。} + +\funcdesc{ninth}{list}{ +{\em list}の9番目の要素を取り出す。} -%\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{tenth}{list}{ +{\em list}の10番目の要素を取り出す。} \funcdesc{nth}{count list}{ {\em list}内の{\em count}番目の要素を返す。 diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex index 2ba450710..35de213e1 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}. From 7ea740be2a09eb6db20a8bec4937791ba2d10c29 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 10 Aug 2022 23:19:58 +0900 Subject: [PATCH 279/387] Add more char and string documentation --- doc/jlatex/jsequences.tex | 46 +++++++++++++++++++++++++++++------ doc/latex/sequences.tex | 50 ++++++++++++++++++++++++++++++++------- 2 files changed, 81 insertions(+), 15 deletions(-) diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index 428a97271..9ae2d754e 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -351,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}は、環状リストでも良い。} @@ -656,6 +659,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}番目の文字を返す。} @@ -664,6 +685,9 @@ \subsection{文字と文字列} {\em string}の型が明確に解っていて、型チェックを要しないときのみ、{\bf schar} を使うこと。} +\funcdesc{setchar}{string index ch}{ +{\em string}の{\em index}番目の文字を{\em ch}にする。} + \funcdesc{stringp}{object}{ {\em object}がバイト(256より小さい正の整数)のベクトルなら、Tを返す。} @@ -698,18 +722,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}の残りが返される。} diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex index 35de213e1..3af3f201d 100644 --- a/doc/latex/sequences.tex +++ b/doc/latex/sequences.tex @@ -363,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.} @@ -660,6 +663,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}.} @@ -667,6 +688,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).} @@ -700,18 +724,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, @@ -719,9 +753,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. From 8363f88aaefb57b857cb047421722fe12410cb2a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 09:57:26 +0900 Subject: [PATCH 280/387] Add assertion-error entry and fix typos in documentation --- doc/jlatex/jevaluation.tex | 1 + doc/jlatex/jsequences.tex | 4 ++-- doc/latex/evaluation.tex | 1 + 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 5c6111217..1b5e80e2f 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -130,6 +130,7 @@ \subsection{エラーとUnixシグナルをハンドリングする} \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}に出力する。} diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index 9ae2d754e..4847f8e0a 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -398,7 +398,7 @@ \subsection{リスト} なければ、NILを返す。} \funcdesc{assoc-if-not}{pred alist \&key key}{ -{\em alist}の要素の{\bf car}が{\em pred}の条件に{\bfあわない}最初のものを返す。 +{\em alist}の要素の{\bf car}が{\em pred}の条件に{\bf あわない}最初のものを返す。 なければ、NILを返す。} \funcdesc{rassoc}{item alist \&key key (test \#'eq) test-not}{ @@ -408,7 +408,7 @@ \subsection{リスト} {\bf cdr}が{\em pred}にあった{\em alist}のなかの最初の組を返す。} \funcdesc{rassoc-if-not}{pred alist \&key key}{ -{\bf cdr}が{\em pred}に{\bfあわない}{\em alist}のなかの最初の組を返す。} +{\bf cdr}が{\em pred}に{\bf あわない}{\em alist}のなかの最初の組を返す。} \funcdesc{pairlis}{l1 l2 \&optional alist}{ {\em l1}と{\em l2}の中の一致する要素を対にしたリストを作る。 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index b0d503119..b95aac15d 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -130,6 +130,7 @@ \subsection{Handling Errors and Unix Signals} \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}.} From 185ec9c499b597f93d0eeed304cc378a0a2ed0f1 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 12:16:13 +0900 Subject: [PATCH 281/387] Update closure documentation --- doc/jlatex/jgenerals.tex | 35 ++++++++++++++++++++++++++--------- doc/jlatex/jintro.tex | 11 ++--------- doc/latex/generals.tex | 36 +++++++++++++++++++++++++++--------- doc/latex/intro.tex | 14 ++++---------- 4 files changed, 59 insertions(+), 37 deletions(-) diff --git a/doc/jlatex/jgenerals.tex b/doc/jlatex/jgenerals.tex index 80fc52598..3191102e7 100644 --- a/doc/jlatex/jgenerals.tex +++ b/doc/jlatex/jgenerals.tex @@ -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 7f201ae63..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, symbol-macrolet -\end{enumerate} - -次の特徴は、まだ完全でない。： -\begin{enumerate} -\setcounter{enumi}{3} -\item closure -- 動的範囲のみ有効である。 -%\item package -- no shadowing-list -\item declare,proclaim -- inlineとignoreは認識されない。 +\item inline, ignore, declare, and proclaim (最後の二つは部分的に実装) \end{enumerate} \subsection{開発履歴} diff --git a/doc/latex/generals.tex b/doc/latex/generals.tex index a2dc2e9b3..0338662df 100644 --- a/doc/latex/generals.tex +++ b/doc/latex/generals.tex @@ -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 f7a56d38d..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, symbol-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 +\item inline, ignore, declare, and proclaim (the last + two are present only in a limited way); \end{enumerate} \subsection{Revision History} From e1b0956c63b6391743751bc6ab6a773ae7245e54 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 17:18:55 +0900 Subject: [PATCH 282/387] Fix typo in jevaluation.tex --- doc/jlatex/jevaluation.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 1b5e80e2f..822b7c037 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -7,7 +7,7 @@ \subsection{評価関数} \funcdesc{identity}{obj}{ {\em obj}自身を返す。 -{\bf idnetity}と{\bf quote}との違いに注意すること。 +{\bf identity}と{\bf quote}との違いに注意すること。 {\bf identity}が関数であるのに対して{\bf quote}は、特殊書式(special form) である。 したがって、{\tt (identity 'abc)}は{\tt abc}と評価されるが、 From d1b45daca6f9fbea2cbf31a78a6ec1aa9633ae66 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 17:37:13 +0900 Subject: [PATCH 283/387] Update conditions documentation --- doc/jlatex/jcontrols.tex | 62 +++++++++++++++++++++++++++++++++++++- doc/latex/controls.tex | 64 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 124 insertions(+), 2 deletions(-) diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index c7743cd7b..5e88766ab 100644 --- a/doc/jlatex/jcontrols.tex +++ b/doc/jlatex/jcontrols.tex @@ -276,7 +276,63 @@ \subsection{述語} \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} @@ -317,6 +373,10 @@ \subsection{コンディション} \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/latex/controls.tex b/doc/latex/controls.tex index 4c8d724e8..0440437cc 100644 --- a/doc/latex/controls.tex +++ b/doc/latex/controls.tex @@ -276,6 +276,64 @@ \subsection{Predicates} \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} @@ -314,7 +372,11 @@ \subsection{Conditions} {\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 the {\it obj} condition. {\it obj} must be an initialized condition instance. Returns the result of the matching handler or {\it nil} if unhandled.} + 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} From 4cd03ba97cafc37bbe4c5042f2b8944f56d81d03 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 19:05:38 +0900 Subject: [PATCH 284/387] Add documentation section on closure compilation --- doc/jlatex/jevaluation.tex | 43 +++++++++++++++++++++++++++++++-- doc/latex/evaluation.tex | 49 ++++++++++++++++++++++++++++++++++---- 2 files changed, 85 insertions(+), 7 deletions(-) diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 822b7c037..45b141b48 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -388,6 +388,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コマンド}{ @@ -421,13 +455,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 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index b95aac15d..644b5f243 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -335,12 +335,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 @@ -428,6 +428,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}{ @@ -461,13 +495,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 From 7502674bec5d46d3e9a67d4fd36ca8c2c298a4f3 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 19:06:08 +0900 Subject: [PATCH 285/387] Update hash-table class documentation --- doc/jlatex/jsequences.tex | 4 ++-- doc/latex/sequences.tex | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index 4847f8e0a..79828cb49 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -863,12 +863,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/latex/sequences.tex b/doc/latex/sequences.tex index 3af3f201d..06bee733c 100644 --- a/doc/latex/sequences.tex +++ b/doc/latex/sequences.tex @@ -855,12 +855,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 From 2c404d2f0ff9502d5887613109fa67435ece50a6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 19:06:49 +0900 Subject: [PATCH 286/387] Update help files --- doc/jlatex/euslisp.hlp | 400 ++++++++++++++++++++++------------------- doc/latex/euslisp.hlp | 400 ++++++++++++++++++++++------------------- 2 files changed, 440 insertions(+), 360 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index b8d0536c0..b4aa63498 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -43,17 +43,18 @@ "some" 2 "jcontrols" 11921 3 "functionp" 2 "jcontrols" 12197 3 "compiled-function-p" 2 "jcontrols" 12686 3 -"condition" 0 "jcontrols" 13307 4 -":init" 1 "jcontrols" 13400 3 -"lisp::*condition-handler*" 5 "jcontrols" 13730 2 -"lisp::*current-condition*" 5 "jcontrols" 13848 2 -"defcondition" 3 "jcontrols" 13943 3 -"install-handler" 2 "jcontrols" 14181 3 -"remove-handler" 2 "jcontrols" 14558 3 -"handler-bind" 2 "jcontrols" 14823 3 -"handler-case" 3 "jcontrols" 15188 3 -"signals" 2 "jcontrols" 15583 3 -"invoke-next-handler" 2 "jcontrols" 16007 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" 16397 3 +"handler-case" 3 "jcontrols" 16762 3 +"signals" 2 "jcontrols" 17157 3 +"invoke-next-handler" 2 "jcontrols" 17581 3 +"lisp::atomic" 3 "jcontrols" 17877 3 "defclass" 3 "jobjects" 4063 3 "defmethod" 6 "jobjects" 4582 3 "defclassmethod" 3 "jobjects" 4812 2 @@ -290,113 +291,148 @@ "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" 12629 3 -"cons" 2 "jsequences" 12752 3 -"list" 2 "jsequences" 12869 3 -"list*" 2 "jsequences" 12938 3 -"list-length" 2 "jsequences" 13192 3 -"make-list" 2 "jsequences" 13300 3 -"rplaca" 2 "jsequences" 13430 3 -"rplacd" 2 "jsequences" 13607 3 -"memq" 2 "jsequences" 13782 3 -"member" 2 "jsequences" 13895 3 -"assq" 2 "jsequences" 14383 2 -"assoc" 2 "jsequences" 14413 3 -"assoc-if" 2 "jsequences" 14612 3 -"rassoc" 2 "jsequences" 14786 3 -"rassoc-if" 2 "jsequences" 14936 3 -"pairlis" 2 "jsequences" 15062 3 -"acons" 2 "jsequences" 15314 3 -"append" 2 "jsequences" 15460 3 -"nconc" 2 "jsequences" 15662 3 -"subst" 2 "jsequences" 15834 3 -"flatten" 2 "jsequences" 15944 3 -"push" 3 "jsequences" 16239 3 -"pop" 3 "jsequences" 16354 3 -"pushnew" 3 "jsequences" 16506 3 -"adjoin" 2 "jsequences" 16764 3 -"union" 2 "jsequences" 16895 3 -"subsetp" 2 "jsequences" 17017 3 -"intersection" 2 "jsequences" 17278 3 -"set-difference" 2 "jsequences" 17432 3 -"set-exclusive-or" 2 "jsequences" 17636 3 -"list-insert" 2 "jsequences" 17810 3 -"copy-tree" 2 "jsequences" 18122 3 -"mapc" 2 "jsequences" 18398 3 -"mapcar" 2 "jsequences" 18657 3 -"mapcan" 2 "jsequences" 18957 3 -"array-rank-limit" 4 "jsequences" 21140 2 -"array-dimension-limit" 4 "jsequences" 21215 2 -"vectorp" 2 "jsequences" 21422 3 -"vector" 2 "jsequences" 21661 3 -"make-array" 2 "jsequences" 21777 3 -"svref" 2 "jsequences" 22123 3 -"aref" 2 "jsequences" 22282 3 -"vector-push" 2 "jsequences" 22756 3 -"vector-push-extend" 2 "jsequences" 23146 3 -"arrayp" 2 "jsequences" 23354 3 -"array-total-size" 2 "jsequences" 23485 3 -"fill-pointer" 2 "jsequences" 23564 3 -"array-rank" 2 "jsequences" 23690 3 -"array-dimensions" 2 "jsequences" 23764 3 -"array-dimension" 2 "jsequences" 23861 3 -"bit" 2 "jsequences" 24008 3 -"bit-and" 2 "jsequences" 24198 2 -"bit-ior" 2 "jsequences" 24248 2 -"bit-xor" 2 "jsequences" 24298 2 -"bit-eqv" 2 "jsequences" 24348 2 -"bit-nand" 2 "jsequences" 24399 2 -"bit-nor" 2 "jsequences" 24449 2 -"bit-not" 2 "jsequences" 24500 3 -"digit-char-p" 2 "jsequences" 25052 3 -"alpha-char-p" 2 "jsequences" 25165 3 -"upper-case-p" 2 "jsequences" 25336 3 -"lower-case-p" 2 "jsequences" 25452 3 -"alphanumericp" 2 "jsequences" 25569 3 -"char-upcase" 2 "jsequences" 25788 3 -"char-downcase" 2 "jsequences" 25859 3 -"char" 2 "jsequences" 25921 3 -"schar" 2 "jsequences" 26009 3 -"stringp" 2 "jsequences" 26212 3 -"string-upcase" 2 "jsequences" 26342 3 -"string-downcase" 2 "jsequences" 26475 3 -"nstring-upcase" 2 "jsequences" 26607 3 -"nstring-downcase" 2 "jsequences" 26716 3 -"string=" 2 "jsequences" 26832 3 -"string-equal" 2 "jsequences" 27023 3 -"string" 2 "jsequences" 27209 3 -"string<" 2 "jsequences" 27847 2 -"string<=" 2 "jsequences" 27880 2 -"string>" 2 "jsequences" 27912 2 -"string>=" 2 "jsequences" 27945 2 -"string-left-trim" 2 "jsequences" 27984 2 -"string-right-trim" 2 "jsequences" 28023 3 -"string-trim" 2 "jsequences" 28335 3 -"substringp" 2 "jsequences" 28524 3 -"make-foreign-string" 2 "jsequences" 30813 3 -"sxhash" 2 "jsequences" 32848 3 -"make-hash-table" 2 "jsequences" 33511 3 -"gethash" 2 "jsequences" 33614 3 -"remhash" 2 "jsequences" 34027 3 -"maphash" 2 "jsequences" 34145 3 -"hash-table-p" 2 "jsequences" 34251 3 -"hash-table" 0 "jsequences" 34359 4 -":hash-function" 1 "jsequences" 34967 3 -"queue" 0 "jsequences" 35618 4 -":init" 1 "jsequences" 35687 3 -":enqueue" 1 "jsequences" 35741 3 -":dequeue" 1 "jsequences" 35829 3 -":empty?" 1 "jsequences" 36087 3 -":length" 1 "jsequences" 36156 3 -":trim" 1 "jsequences" 36213 3 -":search" 1 "jsequences" 36327 3 -":delete" 1 "jsequences" 36466 3 -":first" 1 "jsequences" 36629 3 -":last" 1 "jsequences" 36737 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" 16704 3 +"rassoc-if-not" 2 "jsequences" 16836 3 +"pairlis" 2 "jsequences" 16971 3 +"acons" 2 "jsequences" 17223 3 +"append" 2 "jsequences" 17369 3 +"nconc" 2 "jsequences" 17571 3 +"subst" 2 "jsequences" 17743 3 +"flatten" 2 "jsequences" 17853 3 +"push" 3 "jsequences" 18148 3 +"pop" 3 "jsequences" 18263 3 +"pushnew" 3 "jsequences" 18415 3 +"adjoin" 2 "jsequences" 18673 3 +"union" 2 "jsequences" 18804 3 +"subsetp" 2 "jsequences" 18926 3 +"intersection" 2 "jsequences" 19187 3 +"set-difference" 2 "jsequences" 19341 3 +"set-exclusive-or" 2 "jsequences" 19545 3 +"list-insert" 2 "jsequences" 19719 3 +"copy-tree" 2 "jsequences" 20031 3 +"mapc" 2 "jsequences" 20307 3 +"mapcar" 2 "jsequences" 20566 3 +"mapcan" 2 "jsequences" 20866 3 +"array-rank-limit" 4 "jsequences" 23049 2 +"array-dimension-limit" 4 "jsequences" 23124 2 +"vectorp" 2 "jsequences" 23331 3 +"vector" 2 "jsequences" 23570 3 +"make-array" 2 "jsequences" 23686 3 +"svref" 2 "jsequences" 24032 3 +"aref" 2 "jsequences" 24191 3 +"vector-push" 2 "jsequences" 24665 3 +"vector-push-extend" 2 "jsequences" 25055 3 +"arrayp" 2 "jsequences" 25263 3 +"array-total-size" 2 "jsequences" 25394 3 +"fill-pointer" 2 "jsequences" 25473 3 +"array-rank" 2 "jsequences" 25599 3 +"array-dimensions" 2 "jsequences" 25673 3 +"array-dimension" 2 "jsequences" 25770 3 +"bit" 2 "jsequences" 25917 3 +"bit-and" 2 "jsequences" 26107 2 +"bit-ior" 2 "jsequences" 26157 2 +"bit-xor" 2 "jsequences" 26207 2 +"bit-eqv" 2 "jsequences" 26257 2 +"bit-nand" 2 "jsequences" 26308 2 +"bit-nor" 2 "jsequences" 26358 2 +"bit-not" 2 "jsequences" 26409 3 +"digit-char-p" 2 "jsequences" 26961 3 +"alpha-char-p" 2 "jsequences" 27074 3 +"upper-case-p" 2 "jsequences" 27245 3 +"lower-case-p" 2 "jsequences" 27361 3 +"alphanumericp" 2 "jsequences" 27478 3 +"char-upcase" 2 "jsequences" 27697 3 +"char-downcase" 2 "jsequences" 27768 3 +"char=" 2 "jsequences" 27831 3 +"char/=" 2 "jsequences" 27901 3 +"char>" 2 "jsequences" 27973 3 +"char<" 2 "jsequences" 28046 3 +"char>=" 2 "jsequences" 28120 3 +"char<=" 2 "jsequences" 28195 3 +"char" 2 "jsequences" 28266 3 +"schar" 2 "jsequences" 28354 3 +"setchar" 2 "jsequences" 28557 3 +"stringp" 2 "jsequences" 28661 3 +"string-upcase" 2 "jsequences" 28791 3 +"string-downcase" 2 "jsequences" 28924 3 +"nstring-upcase" 2 "jsequences" 29056 3 +"nstring-downcase" 2 "jsequences" 29165 3 +"string=" 2 "jsequences" 29281 3 +"string-equal" 2 "jsequences" 29472 3 +"string" 2 "jsequences" 29658 3 +"string<" 2 "jsequences" 30296 2 +"string<=" 2 "jsequences" 30407 2 +"string>" 2 "jsequences" 30541 2 +"string>=" 2 "jsequences" 30652 2 +"string-left-trim" 2 "jsequences" 30793 2 +"string-right-trim" 2 "jsequences" 31102 3 +"string-trim" 2 "jsequences" 31405 3 +"substringp" 2 "jsequences" 31594 3 +"make-foreign-string" 2 "jsequences" 33883 3 +"sxhash" 2 "jsequences" 35918 3 +"make-hash-table" 2 "jsequences" 36581 3 +"gethash" 2 "jsequences" 36684 3 +"remhash" 2 "jsequences" 37097 3 +"maphash" 2 "jsequences" 37215 3 +"hash-table-p" 2 "jsequences" 37321 3 +"hash-table" 0 "jsequences" 37429 4 +":hash-function" 1 "jsequences" 38088 3 +"queue" 0 "jsequences" 38739 4 +":init" 1 "jsequences" 38808 3 +":enqueue" 1 "jsequences" 38862 3 +":dequeue" 1 "jsequences" 38950 3 +":empty?" 1 "jsequences" 39208 3 +":length" 1 "jsequences" 39277 3 +":trim" 1 "jsequences" 39334 3 +":search" 1 "jsequences" 39448 3 +":delete" 1 "jsequences" 39587 3 +":first" 1 "jsequences" 39750 3 +":last" 1 "jsequences" 39858 3 "streamp" 2 "jio" 591 3 "input-stream-p" 2 "jio" 741 3 "output-stream-p" 2 "jio" 859 3 @@ -495,68 +531,72 @@ "value-error" 0 "jevaluation" 6895 4 "index-error" 0 "jevaluation" 6930 4 "io-error" 0 "jevaluation" 6962 4 -"lisp::print-error-message" 2 "jevaluation" 7011 3 -"interruption" 0 "jevaluation" 7138 4 -"unix::signal-received" 0 "jevaluation" 7188 4 -"unix::sigint-received" 0 "jevaluation" 7237 4 -"unix::sigcont-received" 0 "jevaluation" 7299 4 -"unix:install-signal-handler" 3 "jevaluation" 7367 3 -"*prompt-string*" 5 "jevaluation" 11584 2 -"*program-name*" 5 "jevaluation" 11667 2 -"eustop" 2 "jevaluation" 11811 3 -"sigint-handler" 2 "jevaluation" 11890 3 -"euserror" 2 "jevaluation" 12061 3 -"reset" 2 "jevaluation" 12226 3 -"exit" 2 "jevaluation" 12358 3 -"*top-selector*" 5 "jevaluation" 12532 2 -"h" 2 "jevaluation" 12658 3 -"!" 2 "jevaluation" 12786 3 -"new-history" 2 "jevaluation" 13767 3 -"compile-file" 2 "jevaluation" 21290 3 -"compile" 2 "jevaluation" 22088 3 -"compile-file-if-src-newer" 2 "jevaluation" 22444 3 -"compiler:*optimize*" 5 "jevaluation" 22745 2 -"compiler:*verbose*" 5 "jevaluation" 22832 2 -"compiler:*safety*" 5 "jevaluation" 23016 2 -"load" 2 "jevaluation" 23166 3 -"load-files" 2 "jevaluation" 27087 3 -"*modules*" 5 "jevaluation" 27202 2 -"provide" 2 "jevaluation" 27306 3 -"require" 2 "jevaluation" 27723 3 -"system:binload" 2 "jevaluation" 28965 3 -"system::txtload" 2 "jevaluation" 29188 2 -"describe" 2 "jevaluation" 29291 3 -"describe-list" 2 "jevaluation" 29438 3 -"inspect" 3 "jevaluation" 29578 3 -"more" 2 "jevaluation" 29915 3 -"break" 2 "jevaluation" 30288 3 -"help" 2 "jevaluation" 30585 3 -"apropos" 2 "jevaluation" 30876 3 -"apropos-list" 2 "jevaluation" 31287 3 -"constants" 2 "jevaluation" 31432 3 -"variables" 2 "jevaluation" 31607 3 -"functions" 2 "jevaluation" 31800 3 -"btrace" 2 "jevaluation" 31987 3 -"step-hook" 2 "jevaluation" 32093 2 -"step" 2 "jevaluation" 32120 3 -"trace" 2 "jevaluation" 32259 3 -"untrace" 2 "jevaluation" 32448 3 -"timing" 3 "jevaluation" 32519 3 -"time" 3 "jevaluation" 32664 3 -"lisp::print-callstack" 2 "jevaluation" 32779 3 -"sys:list-callstack" 2 "jevaluation" 33020 3 -"sys:list-all-catchers" 2 "jevaluation" 33227 3 -"sys:list-all-blocks" 2 "jevaluation" 33305 3 -"sys:list-all-tags" 2 "jevaluation" 33381 3 -"sys:list-all-instances" 2 "jevaluation" 33464 3 -"sys:list-all-bindings" 2 "jevaluation" 33853 3 -"sys:list-all-special-bindings" 2 "jevaluation" 34003 3 -"dump-object" 2 "jevaluation" 34804 2 -"dump-structure" 2 "jevaluation" 34852 3 -"dump-loadable-structure" 2 "jevaluation" 35007 3 -"sys:save" 2 "jevaluation" 36069 3 -"lisp-implementation-type" 2 "jevaluation" 39473 3 -"lisp-implementation-version" 2 "jevaluation" 39545 3 +"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 +"*prompt-string*" 5 "jevaluation" 11623 2 +"*program-name*" 5 "jevaluation" 11706 2 +"eustop" 2 "jevaluation" 11850 3 +"sigint-handler" 2 "jevaluation" 11929 3 +"euserror" 2 "jevaluation" 12100 3 +"reset" 2 "jevaluation" 12265 3 +"exit" 2 "jevaluation" 12397 3 +"*top-selector*" 5 "jevaluation" 12571 2 +"h" 2 "jevaluation" 12697 3 +"!" 2 "jevaluation" 12825 3 +"new-history" 2 "jevaluation" 13806 3 +"compile-file" 2 "jevaluation" 23323 3 +"compile" 2 "jevaluation" 24121 3 +"compile-file-if-src-newer" 2 "jevaluation" 24477 3 +"compiler:*optimize*" 5 "jevaluation" 24778 2 +"compiler:*safety*" 5 "jevaluation" 24864 2 +"compiler:*verbose*" 5 "jevaluation" 24933 2 +"compiler:*type-check-declare*" 5 "jevaluation" 25129 2 +"compiler::compiler-implementation-version" 2 "jevaluation" 25329 3 +"load" 2 "jevaluation" 25546 3 +"load-files" 2 "jevaluation" 29467 3 +"*modules*" 5 "jevaluation" 29582 2 +"provide" 2 "jevaluation" 29686 3 +"require" 2 "jevaluation" 30103 3 +"system:binload" 2 "jevaluation" 31345 3 +"system::txtload" 2 "jevaluation" 31568 2 +"describe" 2 "jevaluation" 31671 3 +"describe-list" 2 "jevaluation" 31818 3 +"inspect" 3 "jevaluation" 31958 3 +"more" 2 "jevaluation" 32295 3 +"break" 2 "jevaluation" 32668 3 +"help" 2 "jevaluation" 32965 3 +"apropos" 2 "jevaluation" 33256 3 +"apropos-list" 2 "jevaluation" 33667 3 +"constants" 2 "jevaluation" 33812 3 +"variables" 2 "jevaluation" 33987 3 +"functions" 2 "jevaluation" 34180 3 +"btrace" 2 "jevaluation" 34367 3 +"step-hook" 2 "jevaluation" 34473 2 +"step" 2 "jevaluation" 34500 3 +"trace" 2 "jevaluation" 34639 3 +"untrace" 2 "jevaluation" 34828 3 +"timing" 3 "jevaluation" 34899 3 +"time" 3 "jevaluation" 35044 3 +"lisp::print-callstack" 2 "jevaluation" 35159 3 +"sys:list-callstack" 2 "jevaluation" 35400 3 +"sys:list-all-catchers" 2 "jevaluation" 35607 3 +"sys:list-all-blocks" 2 "jevaluation" 35685 3 +"sys:list-all-tags" 2 "jevaluation" 35761 3 +"sys:list-all-instances" 2 "jevaluation" 35844 3 +"sys:list-all-bindings" 2 "jevaluation" 36233 3 +"sys:list-all-special-bindings" 2 "jevaluation" 36580 3 +"sys:list-all-function-bindings" 2 "jevaluation" 36739 3 +"dump-object" 2 "jevaluation" 37745 2 +"dump-structure" 2 "jevaluation" 37793 3 +"dump-loadable-structure" 2 "jevaluation" 37948 3 +"sys:save" 2 "jevaluation" 39010 3 +"lisp-implementation-type" 2 "jevaluation" 42414 3 +"lisp-implementation-version" 2 "jevaluation" 42486 3 "sys:gc" 2 "jsysfunc" 6326 3 "sys:gctime" 2 "jsysfunc" 6520 3 "sys:alloc" 2 "jsysfunc" 6837 3 diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 531a3ec09..0db4142ff 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -43,17 +43,18 @@ "some" 2 "controls" 9861 3 "functionp" 2 "controls" 10056 3 "compiled-function-p" 2 "controls" 10463 3 -"condition" 0 "controls" 10870 4 -":init" 1 "controls" 10957 3 -"lisp::*condition-handler*" 5 "controls" 11249 2 -"lisp::*current-condition*" 5 "controls" 11334 2 -"defcondition" 3 "controls" 11409 3 -"install-handler" 2 "controls" 11611 3 -"remove-handler" 2 "controls" 11912 3 -"handler-bind" 2 "controls" 12128 3 -"handler-case" 3 "controls" 12396 3 -"signals" 2 "controls" 12694 3 -"invoke-next-handler" 2 "controls" 12946 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" 13531 3 +"handler-case" 3 "controls" 13799 3 +"signals" 2 "controls" 14097 3 +"invoke-next-handler" 2 "controls" 14349 3 +"lisp::atomic" 3 "controls" 14610 3 "defclass" 3 "objects" 3223 3 "defmethod" 6 "objects" 3684 3 "defclassmethod" 3 "objects" 3859 2 @@ -290,113 +291,148 @@ "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" 10693 3 -"cons" 2 "sequences" 10800 3 -"list" 2 "sequences" 10890 3 -"list*" 2 "sequences" 10959 3 -"list-length" 2 "sequences" 11128 3 -"make-list" 2 "sequences" 11224 3 -"rplaca" 2 "sequences" 11353 3 -"rplacd" 2 "sequences" 11467 3 -"memq" 2 "sequences" 11579 3 -"member" 2 "sequences" 11672 3 -"assq" 2 "sequences" 11995 2 -"assoc" 2 "sequences" 12025 3 -"assoc-if" 2 "sequences" 12305 3 -"rassoc" 2 "sequences" 12561 3 -"rassoc-if" 2 "sequences" 12701 3 -"pairlis" 2 "sequences" 12818 3 -"acons" 2 "sequences" 13047 3 -"append" 2 "sequences" 13170 3 -"nconc" 2 "sequences" 13308 3 -"subst" 2 "sequences" 13425 3 -"flatten" 2 "sequences" 13519 3 -"push" 3 "sequences" 13788 3 -"pop" 3 "sequences" 13873 3 -"pushnew" 3 "sequences" 14007 3 -"adjoin" 2 "sequences" 14242 3 -"union" 2 "sequences" 14350 3 -"subsetp" 2 "sequences" 14463 3 -"intersection" 2 "sequences" 14662 3 -"set-difference" 2 "sequences" 14817 3 -"set-exclusive-or" 2 "sequences" 14997 3 -"list-insert" 2 "sequences" 15166 3 -"copy-tree" 2 "sequences" 15433 3 -"mapc" 2 "sequences" 15672 3 -"mapcar" 2 "sequences" 15899 3 -"mapcan" 2 "sequences" 16165 3 -"array-rank-limit" 4 "sequences" 17820 2 -"array-dimension-limit" 4 "sequences" 17897 2 -"vectorp" 2 "sequences" 18027 3 -"vector" 2 "sequences" 18223 3 -"make-array" 2 "sequences" 18325 3 -"svref" 2 "sequences" 18643 3 -"aref" 2 "sequences" 18765 3 -"vector-push" 2 "sequences" 19052 3 -"vector-push-extend" 2 "sequences" 19349 3 -"arrayp" 2 "sequences" 19521 3 -"array-total-size" 2 "sequences" 19607 3 -"fill-pointer" 2 "sequences" 19694 3 -"array-rank" 2 "sequences" 19826 3 -"array-dimensions" 2 "sequences" 19897 3 -"array-dimension" 2 "sequences" 19970 3 -"bit" 2 "sequences" 20093 3 -"bit-and" 2 "sequences" 20246 2 -"bit-ior" 2 "sequences" 20296 2 -"bit-xor" 2 "sequences" 20346 2 -"bit-eqv" 2 "sequences" 20396 2 -"bit-nand" 2 "sequences" 20447 2 -"bit-nor" 2 "sequences" 20497 2 -"bit-not" 2 "sequences" 20548 3 -"digit-char-p" 2 "sequences" 21039 3 -"alpha-char-p" 2 "sequences" 21128 3 -"upper-case-p" 2 "sequences" 21260 3 -"lower-case-p" 2 "sequences" 21349 3 -"alphanumericp" 2 "sequences" 21440 3 -"char-upcase" 2 "sequences" 21613 3 -"char-downcase" 2 "sequences" 21684 3 -"char" 2 "sequences" 21746 3 -"schar" 2 "sequences" 21829 3 -"stringp" 2 "sequences" 22005 3 -"string-upcase" 2 "sequences" 22114 3 -"string-downcase" 2 "sequences" 22231 3 -"nstring-upcase" 2 "sequences" 22347 3 -"nstring-downcase" 2 "sequences" 22438 3 -"string=" 2 "sequences" 22536 3 -"string-equal" 2 "sequences" 22677 3 -"string" 2 "sequences" 22826 3 -"string<" 2 "sequences" 23326 2 -"string<=" 2 "sequences" 23359 2 -"string>" 2 "sequences" 23391 2 -"string>=" 2 "sequences" 23424 2 -"string-left-trim" 2 "sequences" 23463 2 -"string-right-trim" 2 "sequences" 23502 3 -"string-trim" 2 "sequences" 23780 3 -"substringp" 2 "sequences" 23977 3 -"make-foreign-string" 2 "sequences" 25012 3 -"sxhash" 2 "sequences" 26622 3 -"make-hash-table" 2 "sequences" 27146 3 -"gethash" 2 "sequences" 27254 3 -"remhash" 2 "sequences" 27605 3 -"maphash" 2 "sequences" 27697 3 -"hash-table-p" 2 "sequences" 27794 3 -"hash-table" 0 "sequences" 27872 4 -":hash-function" 1 "sequences" 28360 3 -"queue" 0 "sequences" 28999 4 -":init" 1 "sequences" 29068 3 -":enqueue" 1 "sequences" 29138 3 -":dequeue" 1 "sequences" 29218 3 -":empty?" 1 "sequences" 29432 3 -":length" 1 "sequences" 29491 3 -":trim" 1 "sequences" 29548 3 -":search" 1 "sequences" 29632 3 -":delete" 1 "sequences" 29789 3 -":first" 1 "sequences" 29906 3 -":last" 1 "sequences" 29984 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" 14601 3 +"rassoc-if-not" 2 "sequences" 14721 3 +"pairlis" 2 "sequences" 14844 3 +"acons" 2 "sequences" 15073 3 +"append" 2 "sequences" 15196 3 +"nconc" 2 "sequences" 15334 3 +"subst" 2 "sequences" 15451 3 +"flatten" 2 "sequences" 15545 3 +"push" 3 "sequences" 15814 3 +"pop" 3 "sequences" 15899 3 +"pushnew" 3 "sequences" 16033 3 +"adjoin" 2 "sequences" 16268 3 +"union" 2 "sequences" 16376 3 +"subsetp" 2 "sequences" 16489 3 +"intersection" 2 "sequences" 16688 3 +"set-difference" 2 "sequences" 16843 3 +"set-exclusive-or" 2 "sequences" 17023 3 +"list-insert" 2 "sequences" 17192 3 +"copy-tree" 2 "sequences" 17459 3 +"mapc" 2 "sequences" 17698 3 +"mapcar" 2 "sequences" 17925 3 +"mapcan" 2 "sequences" 18191 3 +"array-rank-limit" 4 "sequences" 19846 2 +"array-dimension-limit" 4 "sequences" 19923 2 +"vectorp" 2 "sequences" 20053 3 +"vector" 2 "sequences" 20249 3 +"make-array" 2 "sequences" 20351 3 +"svref" 2 "sequences" 20669 3 +"aref" 2 "sequences" 20791 3 +"vector-push" 2 "sequences" 21078 3 +"vector-push-extend" 2 "sequences" 21375 3 +"arrayp" 2 "sequences" 21547 3 +"array-total-size" 2 "sequences" 21633 3 +"fill-pointer" 2 "sequences" 21720 3 +"array-rank" 2 "sequences" 21852 3 +"array-dimensions" 2 "sequences" 21923 3 +"array-dimension" 2 "sequences" 21996 3 +"bit" 2 "sequences" 22119 3 +"bit-and" 2 "sequences" 22272 2 +"bit-ior" 2 "sequences" 22322 2 +"bit-xor" 2 "sequences" 22372 2 +"bit-eqv" 2 "sequences" 22422 2 +"bit-nand" 2 "sequences" 22473 2 +"bit-nor" 2 "sequences" 22523 2 +"bit-not" 2 "sequences" 22574 3 +"digit-char-p" 2 "sequences" 23065 3 +"alpha-char-p" 2 "sequences" 23154 3 +"upper-case-p" 2 "sequences" 23286 3 +"lower-case-p" 2 "sequences" 23375 3 +"alphanumericp" 2 "sequences" 23466 3 +"char-upcase" 2 "sequences" 23639 3 +"char-downcase" 2 "sequences" 23710 3 +"char=" 2 "sequences" 23773 3 +"char/=" 2 "sequences" 23845 3 +"char>" 2 "sequences" 23919 3 +"char<" 2 "sequences" 23994 3 +"char>=" 2 "sequences" 24070 3 +"char<=" 2 "sequences" 24147 3 +"char" 2 "sequences" 24220 3 +"schar" 2 "sequences" 24303 3 +"setchar" 2 "sequences" 24479 3 +"stringp" 2 "sequences" 24575 3 +"string-upcase" 2 "sequences" 24684 3 +"string-downcase" 2 "sequences" 24801 3 +"nstring-upcase" 2 "sequences" 24917 3 +"nstring-downcase" 2 "sequences" 25008 3 +"string=" 2 "sequences" 25106 3 +"string-equal" 2 "sequences" 25247 3 +"string" 2 "sequences" 25396 3 +"string<" 2 "sequences" 25897 3 +"string<=" 2 "sequences" 25994 3 +"string>" 2 "sequences" 26102 3 +"string>=" 2 "sequences" 26202 3 +"string-left-trim" 2 "sequences" 26319 2 +"string-right-trim" 2 "sequences" 26593 3 +"string-trim" 2 "sequences" 26862 3 +"substringp" 2 "sequences" 27060 3 +"make-foreign-string" 2 "sequences" 28095 3 +"sxhash" 2 "sequences" 29705 3 +"make-hash-table" 2 "sequences" 30229 3 +"gethash" 2 "sequences" 30337 3 +"remhash" 2 "sequences" 30688 3 +"maphash" 2 "sequences" 30780 3 +"hash-table-p" 2 "sequences" 30877 3 +"hash-table" 0 "sequences" 30955 4 +":hash-function" 1 "sequences" 31466 3 +"queue" 0 "sequences" 32105 4 +":init" 1 "sequences" 32174 3 +":enqueue" 1 "sequences" 32244 3 +":dequeue" 1 "sequences" 32324 3 +":empty?" 1 "sequences" 32538 3 +":length" 1 "sequences" 32597 3 +":trim" 1 "sequences" 32654 3 +":search" 1 "sequences" 32738 3 +":delete" 1 "sequences" 32895 3 +":first" 1 "sequences" 33012 3 +":last" 1 "sequences" 33090 3 "streamp" 2 "io" 483 3 "input-stream-p" 2 "io" 606 3 "output-stream-p" 2 "io" 698 3 @@ -500,68 +536,72 @@ "value-error" 0 "evaluation" 5581 4 "index-error" 0 "evaluation" 5616 4 "io-error" 0 "evaluation" 5648 4 -"lisp::print-error-message" 2 "evaluation" 5697 3 -"interruption" 0 "evaluation" 5832 4 -"unix::signal-received" 0 "evaluation" 5882 4 -"unix::sigint-received" 0 "evaluation" 5931 4 -"unix::sigcont-received" 0 "evaluation" 5993 4 -"unix:install-signal-handler" 3 "evaluation" 6061 3 -"*prompt-string*" 5 "evaluation" 11489 2 -"*program-name*" 5 "evaluation" 11553 2 -"eustop" 2 "evaluation" 11665 3 -"sigint-handler" 2 "evaluation" 11737 3 -"euserror" 2 "evaluation" 11913 3 -"reset" 2 "evaluation" 12037 3 -"exit" 2 "evaluation" 12156 3 -"*top-selector*" 5 "evaluation" 12321 2 -"h" 2 "evaluation" 12448 3 -"!" 2 "evaluation" 12560 3 -"new-history" 2 "evaluation" 13418 3 -"compile-file" 2 "evaluation" 19090 3 -"compile" 2 "evaluation" 19771 3 -"compile-file-if-src-newer" 2 "evaluation" 20022 3 -"compiler:*optimize*" 5 "evaluation" 20243 2 -"compiler:*verbose*" 5 "evaluation" 20304 2 -"compiler:*safety*" 5 "evaluation" 20464 2 -"load" 2 "evaluation" 20592 3 -"load-files" 2 "evaluation" 24019 3 -"*modules*" 5 "evaluation" 24121 2 -"provide" 2 "evaluation" 24210 3 -"require" 2 "evaluation" 24537 3 -"system:binload" 2 "evaluation" 25504 3 -"system::txtload" 2 "evaluation" 25696 2 -"describe" 2 "evaluation" 25793 3 -"describe-list" 2 "evaluation" 25926 3 -"inspect" 3 "evaluation" 26037 3 -"more" 2 "evaluation" 26282 3 -"break" 2 "evaluation" 26562 3 -"help" 2 "evaluation" 26766 3 -"apropos" 2 "evaluation" 27377 3 -"apropos-list" 2 "evaluation" 27746 3 -"constants" 2 "evaluation" 27876 3 -"variables" 2 "evaluation" 28025 3 -"functions" 2 "evaluation" 28179 3 -"btrace" 2 "evaluation" 28332 3 -"step-hook" 2 "evaluation" 28421 2 -"step" 2 "evaluation" 28448 3 -"trace" 2 "evaluation" 28572 3 -"untrace" 2 "evaluation" 28719 3 -"timing" 3 "evaluation" 28774 3 -"time" 3 "evaluation" 28905 3 -"lisp::print-callstack" 2 "evaluation" 29005 3 -"sys:list-callstack" 2 "evaluation" 29259 3 -"sys:list-all-catchers" 2 "evaluation" 29453 3 -"sys:list-all-blocks" 2 "evaluation" 29529 3 -"sys:list-all-tags" 2 "evaluation" 29603 3 -"sys:list-all-instances" 2 "evaluation" 29684 3 -"sys:list-all-bindings" 2 "evaluation" 29981 3 -"sys:list-all-special-bindings" 2 "evaluation" 30102 3 -"dump-object" 2 "evaluation" 30708 2 -"dump-structure" 2 "evaluation" 30756 3 -"dump-loadable-structure" 2 "evaluation" 30887 3 -"sys:save" 2 "evaluation" 31759 3 -"lisp-implementation-type" 2 "evaluation" 34469 3 -"lisp-implementation-version" 2 "evaluation" 34538 3 +"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 +"*prompt-string*" 5 "evaluation" 11528 2 +"*program-name*" 5 "evaluation" 11592 2 +"eustop" 2 "evaluation" 11704 3 +"sigint-handler" 2 "evaluation" 11776 3 +"euserror" 2 "evaluation" 11952 3 +"reset" 2 "evaluation" 12076 3 +"exit" 2 "evaluation" 12195 3 +"*top-selector*" 5 "evaluation" 12360 2 +"h" 2 "evaluation" 12487 3 +"!" 2 "evaluation" 12599 3 +"new-history" 2 "evaluation" 13457 3 +"compile-file" 2 "evaluation" 20978 3 +"compile" 2 "evaluation" 21659 3 +"compile-file-if-src-newer" 2 "evaluation" 21910 3 +"compiler:*optimize*" 5 "evaluation" 22131 2 +"compiler:*safety*" 5 "evaluation" 22191 2 +"compiler:*verbose*" 5 "evaluation" 22246 2 +"compiler:*type-check-declare*" 5 "evaluation" 22418 2 +"compiler::compiler-implementation-version" 2 "evaluation" 22561 3 +"load" 2 "evaluation" 22750 3 +"load-files" 2 "evaluation" 26177 3 +"*modules*" 5 "evaluation" 26279 2 +"provide" 2 "evaluation" 26368 3 +"require" 2 "evaluation" 26695 3 +"system:binload" 2 "evaluation" 27662 3 +"system::txtload" 2 "evaluation" 27854 2 +"describe" 2 "evaluation" 27951 3 +"describe-list" 2 "evaluation" 28084 3 +"inspect" 3 "evaluation" 28195 3 +"more" 2 "evaluation" 28440 3 +"break" 2 "evaluation" 28720 3 +"help" 2 "evaluation" 28924 3 +"apropos" 2 "evaluation" 29535 3 +"apropos-list" 2 "evaluation" 29904 3 +"constants" 2 "evaluation" 30034 3 +"variables" 2 "evaluation" 30183 3 +"functions" 2 "evaluation" 30337 3 +"btrace" 2 "evaluation" 30490 3 +"step-hook" 2 "evaluation" 30579 2 +"step" 2 "evaluation" 30606 3 +"trace" 2 "evaluation" 30730 3 +"untrace" 2 "evaluation" 30877 3 +"timing" 3 "evaluation" 30932 3 +"time" 3 "evaluation" 31063 3 +"lisp::print-callstack" 2 "evaluation" 31163 3 +"sys:list-callstack" 2 "evaluation" 31417 3 +"sys:list-all-catchers" 2 "evaluation" 31611 3 +"sys:list-all-blocks" 2 "evaluation" 31687 3 +"sys:list-all-tags" 2 "evaluation" 31761 3 +"sys:list-all-instances" 2 "evaluation" 31842 3 +"sys:list-all-bindings" 2 "evaluation" 32139 3 +"sys:list-all-special-bindings" 2 "evaluation" 32357 3 +"sys:list-all-function-bindings" 2 "evaluation" 32474 3 +"dump-object" 2 "evaluation" 33210 2 +"dump-structure" 2 "evaluation" 33258 3 +"dump-loadable-structure" 2 "evaluation" 33389 3 +"sys:save" 2 "evaluation" 34261 3 +"lisp-implementation-type" 2 "evaluation" 36971 3 +"lisp-implementation-version" 2 "evaluation" 37040 3 "sys:gc" 2 "sysfunc" 4597 3 "sys:gctime" 2 "sysfunc" 4726 3 "sys:alloc" 2 "sysfunc" 4943 3 From 98cc4c19a16e65e5db186e15821cbe39c364fbc9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 19:33:13 +0900 Subject: [PATCH 287/387] Update version and add :condition :closure to *features* --- lisp/Makefile.generic1 | 4 ++-- lisp/l/constants.l | 2 +- lisp/l/toplevel.l | 2 -- 3 files changed, 3 insertions(+), 5 deletions(-) diff --git a/lisp/Makefile.generic1 b/lisp/Makefile.generic1 index e17152bd8..ed2381be5 100644 --- a/lisp/Makefile.generic1 +++ b/lisp/Makefile.generic1 @@ -28,7 +28,7 @@ TOOLDIR=tool XWINDOWDIR=xwindow GLDIR=opengl/src GLINCLUDE=-I/usr/local/Mesa/include/ -VERSION=9.29 -COMPILERVERSION=1.54 +VERSION=10.0 +COMPILERVERSION=2.0 XVERSION=X_V11R6 diff --git a/lisp/l/constants.l b/lisp/l/constants.l index 975ced1d6..ffd5e10a3 100644 --- a/lisp/l/constants.l +++ b/lisp/l/constants.l @@ -23,7 +23,7 @@ ;; (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 diff --git a/lisp/l/toplevel.l b/lisp/l/toplevel.l index 35dd59984..4e2f114eb 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -298,8 +298,6 @@ (exit 1)) ; (format t "argv=~a~%" argv) (if *eustop-hook* (funcall *eustop-hook* *eustop-argument*)) - ;; print temporary eus10 warning - (warning-message 3 "Welcome to eus10 beta. Please report any bugs at https://github.com/Affonso-Gui/EusLisp/issues or directly to affonso@jsk.imi.i.u-tokyo.ac.jp~%") ;; enter read-eval-loop session (catch :eusexit ;; load files given in arguments From c7dfc4675518f69c9b7747d91b7c9b52444941e7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 11 Aug 2022 20:59:53 +0900 Subject: [PATCH 288/387] Raise errors on checkcompversion if either COMPILERVERSION or COMPTIMEVERSION are undefined --- lisp/c/compsub.c | 8 ++++++++ lisp/comp/trans.l | 2 ++ 2 files changed, 10 insertions(+) diff --git a/lisp/c/compsub.c b/lisp/c/compsub.c index 07397b6bd..db4679916 100644 --- a/lisp/c/compsub.c +++ b/lisp/c/compsub.c @@ -27,6 +27,11 @@ const char* loadver; 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)) { @@ -34,6 +39,9 @@ const char* 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 } diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 7f52f14ac..9f0f2340e 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -760,6 +760,8 @@ register context *ctx; int n; pointer *argv; pointer env;~%" entry) (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);~%") From e361105f4ecf3ad58d5da40c0b254be1d140251a Mon Sep 17 00:00:00 2001 From: Takayuki Murooka Date: Mon, 17 Dec 2018 17:32:16 +0900 Subject: [PATCH 289/387] add .gitignore --- .gitignore | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..ce84d5bc4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +*.aux +*.idx +*.ilg +*.ind +*.log +*.out +*.toc + \ No newline at end of file From 6772bf76edb82e625d36b1bb9cadd1b844750cdd Mon Sep 17 00:00:00 2001 From: Takayuki Murooka Date: Sun, 22 Dec 2019 20:47:08 +0900 Subject: [PATCH 290/387] update .gitignore --- .gitignore | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index ce84d5bc4..17d5ca2c8 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,22 @@ +Linux64 +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 @@ -5,4 +24,5 @@ *.log *.out *.toc - \ No newline at end of file +*.hlp +*.dvi \ No newline at end of file From 8a24549aed2806a9b39360757b8980396f221ded Mon Sep 17 00:00:00 2001 From: Takayuki Murooka Date: Sun, 22 Dec 2019 23:27:33 +0900 Subject: [PATCH 291/387] add other architecture in .gitignore --- .gitignore | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/.gitignore b/.gitignore index 17d5ca2c8..4241c6ad9 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,15 @@ Linux64 +Darwin +Linux +IRIX +Alpha +Cygwin +LinuxARM +LinuxSH4 +SunOS4 +SunOS5 +IRIX6 + include lisp/Makefile From 21c6a84fbd3ad04a147a208fc85d988f9fba6edd Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 12 Aug 2022 09:57:51 +0900 Subject: [PATCH 292/387] Update some handler-case tests --- test/conditions.l | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/test/conditions.l b/test/conditions.l index c458e43d9..39e611052 100644 --- a/test/conditions.l +++ b/test/conditions.l @@ -325,25 +325,26 @@ (error () 'bad)) good) -(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) +;; 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 From 9e3b802d8eec2b345638afb7df89b38de5069e29 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 00:32:00 +0900 Subject: [PATCH 293/387] Use destructive operations in list-insert and list-delete for 0 index too (#361) --- lisp/l/common.l | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index 8f7859cfa..00bb7cf08 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -417,15 +417,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)) From 69b5041373f2f9287ee28255852908eb56248a01 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 00:42:33 +0900 Subject: [PATCH 294/387] Add list-delete documentation --- doc/jlatex/jsequences.tex | 6 ++++++ doc/latex/sequences.tex | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index 79828cb49..2bb4f0d7b 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -476,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}のコピーを返す。 しかし、環状参照はできない。環状リストは、 diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex index 06bee733c..17ca9bef6 100644 --- a/doc/latex/sequences.tex +++ b/doc/latex/sequences.tex @@ -479,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 From e41b4e0577820ee0929779b4d098ea8e87603988 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 00:59:08 +0900 Subject: [PATCH 295/387] Always perform remove-handler on the global value --- lisp/l/conditions.l | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 0301d5aef..cd94dac9e 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -71,16 +71,20 @@ (funcall handler 0 (send err :message) (send err :form))))) (defun remove-handler (label &optional handler) - (let ((item + (let* ((*condition-handler* + ;; always use global scope value + (or + (cdr (assoc '*condition-handler* (sys:list-all-special-bindings))) + *condition-handler*)) + (pos (if handler - (find-if #'(lambda (val) (and (eql (car val) label) - (derivedp (cdr val) condition-handler) - (eql (send (cdr val) :function) handler))) - *condition-handler*) - (find label *condition-handler* :key #'car)))) - (when item - (setq *condition-handler* - (remove item *condition-handler* :test #'equal :count 1)) + (position-if #'(lambda (val) (and (eql (car val) label) + (derivedp (cdr val) condition-handler) + (eql (send (cdr val) :function) handler))) + *condition-handler*) + (position label *condition-handler* :key #'car)))) + (when pos + (list-delete *condition-handler* pos) t))) (defmacro handler-bind (bindings &rest forms) From e0a6f9eb05984a56fdc0c8c475265ae7e2a9f6bc Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 02:46:30 +0900 Subject: [PATCH 296/387] Also remove the same global handler from the local scope in remove-handler --- lisp/l/conditions.l | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index cd94dac9e..14d52ca8e 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -71,20 +71,23 @@ (funcall handler 0 (send err :message) (send err :form))))) (defun remove-handler (label &optional handler) - (let* ((*condition-handler* + (let* ((handler-list ;; always use global scope value - (or - (cdr (assoc '*condition-handler* (sys:list-all-special-bindings))) - *condition-handler*)) + (cdr (assoc '*condition-handler* (sys:list-all-special-bindings)))) (pos (if handler (position-if #'(lambda (val) (and (eql (car val) label) (derivedp (cdr val) condition-handler) (eql (send (cdr val) :function) handler))) - *condition-handler*) - (position label *condition-handler* :key #'car)))) + (or handler-list *condition-handler*)) + (position label (or handler-list *condition-handler*) :key #'car)))) + (when (and handler-list pos) + (let ((local-pos + (position (nth pos handler-list) *condition-handler* :test #'eq))) + (when local-pos + (list-delete *condition-handler* local-pos)))) (when pos - (list-delete *condition-handler* pos) + (list-delete (or handler-list *condition-handler*) pos) t))) (defmacro handler-bind (bindings &rest forms) From c10ae29a51c0f3feb8865a3f6c76abe95d1b1aeb Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 03:03:04 +0900 Subject: [PATCH 297/387] Always perform install-handler on the global scope --- lisp/l/conditions.l | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 14d52ca8e..2f3735775 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -52,7 +52,7 @@ slots))) ',name)) -(defun install-handler (label handler) +(defun install-handler-raw (label handler) ;; ensure condition class (if (eq label t) (setq label condition)) (unless (and (classp label) (derivedp (instantiate label) condition)) @@ -61,6 +61,20 @@ *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")) + ;; force registration on global scope + (let ((handler-list + (cdr (assoc '*condition-handler* (sys:list-all-special-bindings)))) + (item + (cons label (instance condition-handler :init handler)))) + (when handler-list + (list-insert item 0 handler-list)) + (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.~%") @@ -92,7 +106,7 @@ (defmacro handler-bind (bindings &rest forms) `(let ((*condition-handler* (copy-list *condition-handler*))) - ,@(mapcar #'(lambda (bind) `(install-handler ,@bind)) bindings) + ,@(mapcar #'(lambda (bind) `(install-handler-raw ,@bind)) bindings) ,@forms)) (defun get-handler-frame (&optional (name "HANDLER-CASE-")) From 13fc3a524b94b8ef0649a7a2d4a4d19d15eb0be7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 10:42:18 +0900 Subject: [PATCH 298/387] Change all previous scopes recursively in install-handler and remove-handler --- lisp/l/conditions.l | 54 ++++++++++++++++++++++++++++----------------- 1 file changed, 34 insertions(+), 20 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 2f3735775..14036036c 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -65,13 +65,16 @@ (if (eq label t) (setq label condition)) (unless (and (classp label) (derivedp (instantiate label) condition)) (error type-error "condition class expected")) - ;; force registration on global scope + ;; recursively force registration on all previous scopes (let ((handler-list - (cdr (assoc '*condition-handler* (sys:list-all-special-bindings)))) + (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 - (list-insert item 0 handler-list)) + (dolist (val handler-list) + (list-insert item 0 (cdr val)))) (push item *condition-handler*)) t) @@ -85,24 +88,35 @@ (funcall handler 0 (send err :message) (send err :form))))) (defun remove-handler (label &optional handler) - (let* ((handler-list - ;; always use global scope value - (cdr (assoc '*condition-handler* (sys:list-all-special-bindings)))) - (pos - (if handler - (position-if #'(lambda (val) (and (eql (car val) label) - (derivedp (cdr val) condition-handler) - (eql (send (cdr val) :function) handler))) - (or handler-list *condition-handler*)) - (position label (or handler-list *condition-handler*) :key #'car)))) - (when (and handler-list pos) - (let ((local-pos - (position (nth pos handler-list) *condition-handler* :test #'eq))) - (when local-pos - (list-delete *condition-handler* local-pos)))) + (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 - (list-delete (or handler-list *condition-handler*) pos) - t))) + (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*))) From 6babc6807b2afcc803e1c9c3b2f2037e528a7672 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 11:00:42 +0900 Subject: [PATCH 299/387] Add more condition tests --- test/conditions.l | 103 +++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 93 insertions(+), 10 deletions(-) diff --git a/test/conditions.l b/test/conditions.l index 39e611052..d97e0e637 100644 --- a/test/conditions.l +++ b/test/conditions.l @@ -76,11 +76,94 @@ (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) expected-fmt))) + (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) @@ -109,12 +192,12 @@ (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.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 @@ -281,9 +364,9 @@ (handler-case 'foo (condition () 'bar)) foo) -;; (define-ansi-test handler-case.8 -;; (handler-case 'foo (t () '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)) From eb8ede8a123731a2ba91caa99ce30fba7f13d1f1 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 11:02:40 +0900 Subject: [PATCH 300/387] Update remove-handler documentation --- doc/jlatex/jcontrols.tex | 2 +- doc/latex/controls.tex | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/jlatex/jcontrols.tex b/doc/jlatex/jcontrols.tex index 5e88766ab..6ea8d81a6 100644 --- a/doc/jlatex/jcontrols.tex +++ b/doc/jlatex/jcontrols.tex @@ -355,7 +355,7 @@ \subsection{コンディション} {\em label}はconditionを親とするクラスであり、{\em handler}は一個のパラメータ(コンディションのインスタンス)を受け付ける関数である。} \funcdesc{remove-handler}{label \&optional handler}{ -コンディション{\em label}で登録された最後のhandlerを登録解除する。 +\textit{install-handler}によってコンディション{\em label}で登録された最後のhandlerを登録解除する。 {\em handler}が与えられた場合、最後に登録された({\em label . handler})のペアを登録解除する。} \funcdesc{handler-bind}{(\&rest (label handler)) \&rest forms}{ diff --git a/doc/latex/controls.tex b/doc/latex/controls.tex index 0440437cc..a31d416ae 100644 --- a/doc/latex/controls.tex +++ b/doc/latex/controls.tex @@ -357,7 +357,7 @@ \subsection{Conditions} {\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 registered for condition {\em label}. + 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}{ From 5c30e7cdce8a9bd0169f2e6ba0ba751763c6550d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 11:03:46 +0900 Subject: [PATCH 301/387] Update help files --- doc/jlatex/euslisp.hlp | 169 +++++++++++++++++++++-------------------- doc/latex/euslisp.hlp | 169 +++++++++++++++++++++-------------------- 2 files changed, 170 insertions(+), 168 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index b4aa63498..75c34972b 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -50,11 +50,11 @@ "defcondition" 3 "jcontrols" 15517 3 "install-handler" 2 "jcontrols" 15755 3 "remove-handler" 2 "jcontrols" 16132 3 -"handler-bind" 2 "jcontrols" 16397 3 -"handler-case" 3 "jcontrols" 16762 3 -"signals" 2 "jcontrols" 17157 3 -"invoke-next-handler" 2 "jcontrols" 17581 3 -"lisp::atomic" 3 "jcontrols" 17877 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 @@ -354,85 +354,86 @@ "set-difference" 2 "jsequences" 19341 3 "set-exclusive-or" 2 "jsequences" 19545 3 "list-insert" 2 "jsequences" 19719 3 -"copy-tree" 2 "jsequences" 20031 3 -"mapc" 2 "jsequences" 20307 3 -"mapcar" 2 "jsequences" 20566 3 -"mapcan" 2 "jsequences" 20866 3 -"array-rank-limit" 4 "jsequences" 23049 2 -"array-dimension-limit" 4 "jsequences" 23124 2 -"vectorp" 2 "jsequences" 23331 3 -"vector" 2 "jsequences" 23570 3 -"make-array" 2 "jsequences" 23686 3 -"svref" 2 "jsequences" 24032 3 -"aref" 2 "jsequences" 24191 3 -"vector-push" 2 "jsequences" 24665 3 -"vector-push-extend" 2 "jsequences" 25055 3 -"arrayp" 2 "jsequences" 25263 3 -"array-total-size" 2 "jsequences" 25394 3 -"fill-pointer" 2 "jsequences" 25473 3 -"array-rank" 2 "jsequences" 25599 3 -"array-dimensions" 2 "jsequences" 25673 3 -"array-dimension" 2 "jsequences" 25770 3 -"bit" 2 "jsequences" 25917 3 -"bit-and" 2 "jsequences" 26107 2 -"bit-ior" 2 "jsequences" 26157 2 -"bit-xor" 2 "jsequences" 26207 2 -"bit-eqv" 2 "jsequences" 26257 2 -"bit-nand" 2 "jsequences" 26308 2 -"bit-nor" 2 "jsequences" 26358 2 -"bit-not" 2 "jsequences" 26409 3 -"digit-char-p" 2 "jsequences" 26961 3 -"alpha-char-p" 2 "jsequences" 27074 3 -"upper-case-p" 2 "jsequences" 27245 3 -"lower-case-p" 2 "jsequences" 27361 3 -"alphanumericp" 2 "jsequences" 27478 3 -"char-upcase" 2 "jsequences" 27697 3 -"char-downcase" 2 "jsequences" 27768 3 -"char=" 2 "jsequences" 27831 3 -"char/=" 2 "jsequences" 27901 3 -"char>" 2 "jsequences" 27973 3 -"char<" 2 "jsequences" 28046 3 -"char>=" 2 "jsequences" 28120 3 -"char<=" 2 "jsequences" 28195 3 -"char" 2 "jsequences" 28266 3 -"schar" 2 "jsequences" 28354 3 -"setchar" 2 "jsequences" 28557 3 -"stringp" 2 "jsequences" 28661 3 -"string-upcase" 2 "jsequences" 28791 3 -"string-downcase" 2 "jsequences" 28924 3 -"nstring-upcase" 2 "jsequences" 29056 3 -"nstring-downcase" 2 "jsequences" 29165 3 -"string=" 2 "jsequences" 29281 3 -"string-equal" 2 "jsequences" 29472 3 -"string" 2 "jsequences" 29658 3 -"string<" 2 "jsequences" 30296 2 -"string<=" 2 "jsequences" 30407 2 -"string>" 2 "jsequences" 30541 2 -"string>=" 2 "jsequences" 30652 2 -"string-left-trim" 2 "jsequences" 30793 2 -"string-right-trim" 2 "jsequences" 31102 3 -"string-trim" 2 "jsequences" 31405 3 -"substringp" 2 "jsequences" 31594 3 -"make-foreign-string" 2 "jsequences" 33883 3 -"sxhash" 2 "jsequences" 35918 3 -"make-hash-table" 2 "jsequences" 36581 3 -"gethash" 2 "jsequences" 36684 3 -"remhash" 2 "jsequences" 37097 3 -"maphash" 2 "jsequences" 37215 3 -"hash-table-p" 2 "jsequences" 37321 3 -"hash-table" 0 "jsequences" 37429 4 -":hash-function" 1 "jsequences" 38088 3 -"queue" 0 "jsequences" 38739 4 -":init" 1 "jsequences" 38808 3 -":enqueue" 1 "jsequences" 38862 3 -":dequeue" 1 "jsequences" 38950 3 -":empty?" 1 "jsequences" 39208 3 -":length" 1 "jsequences" 39277 3 -":trim" 1 "jsequences" 39334 3 -":search" 1 "jsequences" 39448 3 -":delete" 1 "jsequences" 39587 3 -":first" 1 "jsequences" 39750 3 -":last" 1 "jsequences" 39858 3 +"list-delete" 2 "jsequences" 20033 3 +"copy-tree" 2 "jsequences" 20295 3 +"mapc" 2 "jsequences" 20571 3 +"mapcar" 2 "jsequences" 20830 3 +"mapcan" 2 "jsequences" 21130 3 +"array-rank-limit" 4 "jsequences" 23313 2 +"array-dimension-limit" 4 "jsequences" 23388 2 +"vectorp" 2 "jsequences" 23595 3 +"vector" 2 "jsequences" 23834 3 +"make-array" 2 "jsequences" 23950 3 +"svref" 2 "jsequences" 24296 3 +"aref" 2 "jsequences" 24455 3 +"vector-push" 2 "jsequences" 24929 3 +"vector-push-extend" 2 "jsequences" 25319 3 +"arrayp" 2 "jsequences" 25527 3 +"array-total-size" 2 "jsequences" 25658 3 +"fill-pointer" 2 "jsequences" 25737 3 +"array-rank" 2 "jsequences" 25863 3 +"array-dimensions" 2 "jsequences" 25937 3 +"array-dimension" 2 "jsequences" 26034 3 +"bit" 2 "jsequences" 26181 3 +"bit-and" 2 "jsequences" 26371 2 +"bit-ior" 2 "jsequences" 26421 2 +"bit-xor" 2 "jsequences" 26471 2 +"bit-eqv" 2 "jsequences" 26521 2 +"bit-nand" 2 "jsequences" 26572 2 +"bit-nor" 2 "jsequences" 26622 2 +"bit-not" 2 "jsequences" 26673 3 +"digit-char-p" 2 "jsequences" 27225 3 +"alpha-char-p" 2 "jsequences" 27338 3 +"upper-case-p" 2 "jsequences" 27509 3 +"lower-case-p" 2 "jsequences" 27625 3 +"alphanumericp" 2 "jsequences" 27742 3 +"char-upcase" 2 "jsequences" 27961 3 +"char-downcase" 2 "jsequences" 28032 3 +"char=" 2 "jsequences" 28095 3 +"char/=" 2 "jsequences" 28165 3 +"char>" 2 "jsequences" 28237 3 +"char<" 2 "jsequences" 28310 3 +"char>=" 2 "jsequences" 28384 3 +"char<=" 2 "jsequences" 28459 3 +"char" 2 "jsequences" 28530 3 +"schar" 2 "jsequences" 28618 3 +"setchar" 2 "jsequences" 28821 3 +"stringp" 2 "jsequences" 28925 3 +"string-upcase" 2 "jsequences" 29055 3 +"string-downcase" 2 "jsequences" 29188 3 +"nstring-upcase" 2 "jsequences" 29320 3 +"nstring-downcase" 2 "jsequences" 29429 3 +"string=" 2 "jsequences" 29545 3 +"string-equal" 2 "jsequences" 29736 3 +"string" 2 "jsequences" 29922 3 +"string<" 2 "jsequences" 30560 2 +"string<=" 2 "jsequences" 30671 2 +"string>" 2 "jsequences" 30805 2 +"string>=" 2 "jsequences" 30916 2 +"string-left-trim" 2 "jsequences" 31057 2 +"string-right-trim" 2 "jsequences" 31366 3 +"string-trim" 2 "jsequences" 31669 3 +"substringp" 2 "jsequences" 31858 3 +"make-foreign-string" 2 "jsequences" 34147 3 +"sxhash" 2 "jsequences" 36182 3 +"make-hash-table" 2 "jsequences" 36845 3 +"gethash" 2 "jsequences" 36948 3 +"remhash" 2 "jsequences" 37361 3 +"maphash" 2 "jsequences" 37479 3 +"hash-table-p" 2 "jsequences" 37585 3 +"hash-table" 0 "jsequences" 37693 4 +":hash-function" 1 "jsequences" 38352 3 +"queue" 0 "jsequences" 39003 4 +":init" 1 "jsequences" 39072 3 +":enqueue" 1 "jsequences" 39126 3 +":dequeue" 1 "jsequences" 39214 3 +":empty?" 1 "jsequences" 39472 3 +":length" 1 "jsequences" 39541 3 +":trim" 1 "jsequences" 39598 3 +":search" 1 "jsequences" 39712 3 +":delete" 1 "jsequences" 39851 3 +":first" 1 "jsequences" 40014 3 +":last" 1 "jsequences" 40122 3 "streamp" 2 "jio" 591 3 "input-stream-p" 2 "jio" 741 3 "output-stream-p" 2 "jio" 859 3 diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 0db4142ff..dabd5e2b5 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -50,11 +50,11 @@ "defcondition" 3 "controls" 12812 3 "install-handler" 2 "controls" 13014 3 "remove-handler" 2 "controls" 13315 3 -"handler-bind" 2 "controls" 13531 3 -"handler-case" 3 "controls" 13799 3 -"signals" 2 "controls" 14097 3 -"invoke-next-handler" 2 "controls" 14349 3 -"lisp::atomic" 3 "controls" 14610 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 @@ -354,85 +354,86 @@ "set-difference" 2 "sequences" 16843 3 "set-exclusive-or" 2 "sequences" 17023 3 "list-insert" 2 "sequences" 17192 3 -"copy-tree" 2 "sequences" 17459 3 -"mapc" 2 "sequences" 17698 3 -"mapcar" 2 "sequences" 17925 3 -"mapcan" 2 "sequences" 18191 3 -"array-rank-limit" 4 "sequences" 19846 2 -"array-dimension-limit" 4 "sequences" 19923 2 -"vectorp" 2 "sequences" 20053 3 -"vector" 2 "sequences" 20249 3 -"make-array" 2 "sequences" 20351 3 -"svref" 2 "sequences" 20669 3 -"aref" 2 "sequences" 20791 3 -"vector-push" 2 "sequences" 21078 3 -"vector-push-extend" 2 "sequences" 21375 3 -"arrayp" 2 "sequences" 21547 3 -"array-total-size" 2 "sequences" 21633 3 -"fill-pointer" 2 "sequences" 21720 3 -"array-rank" 2 "sequences" 21852 3 -"array-dimensions" 2 "sequences" 21923 3 -"array-dimension" 2 "sequences" 21996 3 -"bit" 2 "sequences" 22119 3 -"bit-and" 2 "sequences" 22272 2 -"bit-ior" 2 "sequences" 22322 2 -"bit-xor" 2 "sequences" 22372 2 -"bit-eqv" 2 "sequences" 22422 2 -"bit-nand" 2 "sequences" 22473 2 -"bit-nor" 2 "sequences" 22523 2 -"bit-not" 2 "sequences" 22574 3 -"digit-char-p" 2 "sequences" 23065 3 -"alpha-char-p" 2 "sequences" 23154 3 -"upper-case-p" 2 "sequences" 23286 3 -"lower-case-p" 2 "sequences" 23375 3 -"alphanumericp" 2 "sequences" 23466 3 -"char-upcase" 2 "sequences" 23639 3 -"char-downcase" 2 "sequences" 23710 3 -"char=" 2 "sequences" 23773 3 -"char/=" 2 "sequences" 23845 3 -"char>" 2 "sequences" 23919 3 -"char<" 2 "sequences" 23994 3 -"char>=" 2 "sequences" 24070 3 -"char<=" 2 "sequences" 24147 3 -"char" 2 "sequences" 24220 3 -"schar" 2 "sequences" 24303 3 -"setchar" 2 "sequences" 24479 3 -"stringp" 2 "sequences" 24575 3 -"string-upcase" 2 "sequences" 24684 3 -"string-downcase" 2 "sequences" 24801 3 -"nstring-upcase" 2 "sequences" 24917 3 -"nstring-downcase" 2 "sequences" 25008 3 -"string=" 2 "sequences" 25106 3 -"string-equal" 2 "sequences" 25247 3 -"string" 2 "sequences" 25396 3 -"string<" 2 "sequences" 25897 3 -"string<=" 2 "sequences" 25994 3 -"string>" 2 "sequences" 26102 3 -"string>=" 2 "sequences" 26202 3 -"string-left-trim" 2 "sequences" 26319 2 -"string-right-trim" 2 "sequences" 26593 3 -"string-trim" 2 "sequences" 26862 3 -"substringp" 2 "sequences" 27060 3 -"make-foreign-string" 2 "sequences" 28095 3 -"sxhash" 2 "sequences" 29705 3 -"make-hash-table" 2 "sequences" 30229 3 -"gethash" 2 "sequences" 30337 3 -"remhash" 2 "sequences" 30688 3 -"maphash" 2 "sequences" 30780 3 -"hash-table-p" 2 "sequences" 30877 3 -"hash-table" 0 "sequences" 30955 4 -":hash-function" 1 "sequences" 31466 3 -"queue" 0 "sequences" 32105 4 -":init" 1 "sequences" 32174 3 -":enqueue" 1 "sequences" 32244 3 -":dequeue" 1 "sequences" 32324 3 -":empty?" 1 "sequences" 32538 3 -":length" 1 "sequences" 32597 3 -":trim" 1 "sequences" 32654 3 -":search" 1 "sequences" 32738 3 -":delete" 1 "sequences" 32895 3 -":first" 1 "sequences" 33012 3 -":last" 1 "sequences" 33090 3 +"list-delete" 2 "sequences" 17461 3 +"copy-tree" 2 "sequences" 17693 3 +"mapc" 2 "sequences" 17932 3 +"mapcar" 2 "sequences" 18159 3 +"mapcan" 2 "sequences" 18425 3 +"array-rank-limit" 4 "sequences" 20080 2 +"array-dimension-limit" 4 "sequences" 20157 2 +"vectorp" 2 "sequences" 20287 3 +"vector" 2 "sequences" 20483 3 +"make-array" 2 "sequences" 20585 3 +"svref" 2 "sequences" 20903 3 +"aref" 2 "sequences" 21025 3 +"vector-push" 2 "sequences" 21312 3 +"vector-push-extend" 2 "sequences" 21609 3 +"arrayp" 2 "sequences" 21781 3 +"array-total-size" 2 "sequences" 21867 3 +"fill-pointer" 2 "sequences" 21954 3 +"array-rank" 2 "sequences" 22086 3 +"array-dimensions" 2 "sequences" 22157 3 +"array-dimension" 2 "sequences" 22230 3 +"bit" 2 "sequences" 22353 3 +"bit-and" 2 "sequences" 22506 2 +"bit-ior" 2 "sequences" 22556 2 +"bit-xor" 2 "sequences" 22606 2 +"bit-eqv" 2 "sequences" 22656 2 +"bit-nand" 2 "sequences" 22707 2 +"bit-nor" 2 "sequences" 22757 2 +"bit-not" 2 "sequences" 22808 3 +"digit-char-p" 2 "sequences" 23299 3 +"alpha-char-p" 2 "sequences" 23388 3 +"upper-case-p" 2 "sequences" 23520 3 +"lower-case-p" 2 "sequences" 23609 3 +"alphanumericp" 2 "sequences" 23700 3 +"char-upcase" 2 "sequences" 23873 3 +"char-downcase" 2 "sequences" 23944 3 +"char=" 2 "sequences" 24007 3 +"char/=" 2 "sequences" 24079 3 +"char>" 2 "sequences" 24153 3 +"char<" 2 "sequences" 24228 3 +"char>=" 2 "sequences" 24304 3 +"char<=" 2 "sequences" 24381 3 +"char" 2 "sequences" 24454 3 +"schar" 2 "sequences" 24537 3 +"setchar" 2 "sequences" 24713 3 +"stringp" 2 "sequences" 24809 3 +"string-upcase" 2 "sequences" 24918 3 +"string-downcase" 2 "sequences" 25035 3 +"nstring-upcase" 2 "sequences" 25151 3 +"nstring-downcase" 2 "sequences" 25242 3 +"string=" 2 "sequences" 25340 3 +"string-equal" 2 "sequences" 25481 3 +"string" 2 "sequences" 25630 3 +"string<" 2 "sequences" 26131 3 +"string<=" 2 "sequences" 26228 3 +"string>" 2 "sequences" 26336 3 +"string>=" 2 "sequences" 26436 3 +"string-left-trim" 2 "sequences" 26553 2 +"string-right-trim" 2 "sequences" 26827 3 +"string-trim" 2 "sequences" 27096 3 +"substringp" 2 "sequences" 27294 3 +"make-foreign-string" 2 "sequences" 28329 3 +"sxhash" 2 "sequences" 29939 3 +"make-hash-table" 2 "sequences" 30463 3 +"gethash" 2 "sequences" 30571 3 +"remhash" 2 "sequences" 30922 3 +"maphash" 2 "sequences" 31014 3 +"hash-table-p" 2 "sequences" 31111 3 +"hash-table" 0 "sequences" 31189 4 +":hash-function" 1 "sequences" 31700 3 +"queue" 0 "sequences" 32339 4 +":init" 1 "sequences" 32408 3 +":enqueue" 1 "sequences" 32478 3 +":dequeue" 1 "sequences" 32558 3 +":empty?" 1 "sequences" 32772 3 +":length" 1 "sequences" 32831 3 +":trim" 1 "sequences" 32888 3 +":search" 1 "sequences" 32972 3 +":delete" 1 "sequences" 33129 3 +":first" 1 "sequences" 33246 3 +":last" 1 "sequences" 33324 3 "streamp" 2 "io" 483 3 "input-stream-p" 2 "io" 606 3 "output-stream-p" 2 "io" 698 3 From 57ddf3787a61c0d21c426f41b5e9a7a105bf34cd Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 12:32:12 +0900 Subject: [PATCH 302/387] Use plain gensyms instead of get-handler-frame in handler-frame expansion --- lisp/l/conditions.l | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 14036036c..b88283119 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -123,27 +123,19 @@ ,@(mapcar #'(lambda (bind) `(install-handler-raw ,@bind)) bindings) ,@forms)) -(defun get-handler-frame (&optional (name "HANDLER-CASE-")) - (let ((handler-frame (symbol-pname (gensym name)))) - (while (find-symbol handler-frame *keyword-package*) - (setq handler-frame (symbol-pname (gensym name)))) - (intern handler-frame *keyword-package*))) - (defmacro handler-case (form &rest cases) - (let ((handler-frame (get-handler-frame))) + (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 + (throw ',handler-frame (progn ,@body)))))) - `(prog1 - (catch ,handler-frame - (handler-bind - ,(mapcar #'(lambda (cs) (apply #'expand-case cs)) (reverse cases)) - ,form)) - (send *keyword-package* :unintern ,handler-frame))))) + `(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) From 906ffdc72972fb569fd692f6accb3c1f44bc44d4 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 18 Sep 2022 13:37:44 +0900 Subject: [PATCH 303/387] Raise index errors on negative index and replace confusing E_STARTEND --- lisp/c/eus.c | 3 +-- lisp/c/eus.h | 1 - lisp/c/lists.c | 8 ++++---- lisp/c/sequence.c | 4 ++-- 4 files changed, 7 insertions(+), 9 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 02827177d..765502a1e 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -268,7 +268,6 @@ char *errmsg[100]={ "searching a circular list", /* INDEX ERROR */ "", - "illegal start/end index", "array dimension mismatch", "array index out of range", "vector dimension mismatch", @@ -417,7 +416,7 @@ va_dcl 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_STARTEND: case E_ARRAYDIMENSION: case E_ARRAYINDEX: + 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 diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 77c052d9a..00067fffb 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -991,7 +991,6 @@ enum errorcode { /* INDEX ERROR */ E_INDEX_ERROR, - E_STARTEND, E_ARRAYDIMENSION, E_ARRAYINDEX, E_VECSIZE, diff --git a/lisp/c/lists.c b/lisp/c/lists.c index fa3b03e1e..fa637cd8a 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -110,7 +110,7 @@ register pointer *argv; register pointer a=argv[1]; ckarg(2); i=ckintval(argv[0]); - if (i<0) error(E_NOINT); + if (i<0) error(E_SEQINDEX); while (i-->0 && 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); @@ -356,7 +356,7 @@ pointer argv[]; if (!iscons(a)) { if (a==NIL) return(NIL); else error(E_NOLIST); } - if (n<0) error(E_VALUE_ERROR,(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; @@ -375,7 +375,7 @@ pointer argv[]; if (!iscons(a)) { if (a==NIL) return(NIL); else error(E_NOLIST); } - if (n<0) error(E_STARTEND); + if (n<0) error(E_SEQINDEX); while (islist(a)) { l++; a=ccdr(a);} a=argv[0]; if (n>=l) return(NIL); diff --git a/lisp/c/sequence.c b/lisp/c/sequence.c index e260cea3f..3ffc7e01d 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 (e Date: Mon, 19 Sep 2022 10:57:19 +0900 Subject: [PATCH 304/387] Wrap each compiled code evaluation in a catchframe for safe resumable error handling --- lisp/c/eus.c | 9 ++++++++- lisp/c/eval.c | 24 +++++++++++++++++++++++- lisp/c/sysfunc.c | 5 +++-- 3 files changed, 34 insertions(+), 4 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 765502a1e..500169536 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -329,6 +329,7 @@ va_dcl register struct callframe *vf; pointer msg,form,callstack; pointer errobj; + pointer result; #ifdef USE_STDARG va_start(args,ec); @@ -435,7 +436,13 @@ va_dcl Spevalof(QEVALHOOK)=NIL; /* reset eval hook */ if (errhandler!=NIL) { vpush(errobj); - ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-1),ctx->bindfp,1);} + result=ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-1),ctx->bindfp,1);} + else { + result=NIL; + } + // the NULL catcher is introduced by catchfuncode, in order to ensure + // that errors follow the termination semantics in the C lang level + throw(ctx,NULL,result); } #ifdef USE_STDARG diff --git a/lisp/c/eval.c b/lisp/c/eval.c index f28135c29..fdd0ac3bc 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1450,6 +1450,28 @@ pointer args[]; #endif /* IRIX */ #endif /* IRIX6 */ +pointer catchfuncode(ctx,func,args,noarg) +register context *ctx; +register pointer func,args; +register int noarg; +{ + // create a NULL catcher around each evaluation of compiled code + // this ensures that no continuations are allowed in the C lang level, + // even if the user locally overwrites the error handler + pointer tag,val; + jmp_buf catchbuf; + mkcatchframe(ctx,NULL,&catchbuf); + if ((val=(pointer)eussetjmp(catchbuf))==0) { + val=funcode(ctx,func,args,noarg);} + else if ((eusinteger_t)val==1) { + val=NIL; + } + + ctx->vsp=(pointer *)ctx->catchfp; + ctx->catchfp=(struct catchframe *)*ctx->vsp; + return(val); +} + pointer funcode(ctx,func,args,noarg) register context *ctx; register pointer func,args; @@ -1610,7 +1632,7 @@ int noarg; else if (piscode(func)) { /*call subr*/ GC_POINT; - result=funcode(ctx,func,args,noarg); + result=catchfuncode(ctx,func,args,noarg); ctx->vsp=(pointer *)vf; ctx->callfp= vf->vlink; ctx->fletfp=oldfletfp; diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index 82928fd06..adedc9bc9 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -752,8 +752,9 @@ pointer *argv; struct catchframe *cfp=ctx->catchfp; int i=0; while (cfp) { - vpush(cfp->label); - i++; + if (cfp->label) { + vpush(cfp->label); + i++;} cfp=cfp->nextcatch;} return(stacknlist(ctx,i));} From f0cea889ffe05f19d3d9b6038765d5c465f66adc Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 21 Sep 2022 17:16:50 +0900 Subject: [PATCH 305/387] Fix unwind offset value in return-from and go compilation (#494) --- lisp/comp/trans.l | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 9f0f2340e..3950a746a 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -656,13 +656,17 @@ (send self :store "w") ;save result (send self :reset-vsp) (if need-unwind - (maybe-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)))) (maybe-format cfile " local[~d]=w;~%" k) (inc pushcount)) (:go-tag (k need-unwind) (send self :reset-vsp) (if need-unwind - (maybe-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 env0 env1) (if env1 From b88b5213ba0f0a04a71a3d281c277760c0de5086 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 21 Sep 2022 17:27:13 +0900 Subject: [PATCH 306/387] Use slot accessor to avoid clashing with argument variables in defcondition expansion --- lisp/l/conditions.l | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index b88283119..1658b23e4 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -29,7 +29,7 @@ (:init (fn) (unless (functionp fn) (error type-error "function expected")) ;; set slots - (send self :set-val "FN" fn) + (setq (self . fn) fn) ;; set name (let ((name (cond @@ -48,7 +48,7 @@ ,@(mapcar #'(lambda (s) `(,(intern (send s :pname) *keyword-package*) (&optional (val nil supplied-p)) - (if supplied-p (send self :set-val ',s val) ,s))) + (if supplied-p (setq (self . ,s) val) (self . ,s)))) slots))) ',name)) From 9652b9883da14c5f100a8e5291290a7bb618213f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Sep 2022 13:58:31 +0900 Subject: [PATCH 307/387] Only allocate flet-frames vector when needed in compiled code --- lisp/comp/comp.l | 78 +++++++++++++++++++++++++++++++----------------- 1 file changed, 51 insertions(+), 27 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 47ffad620..eb93bc346 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -51,6 +51,7 @@ (defvar *multipass-optimize* t) ;; define as a variable so we can `(let ((closure-frames ...)))' it (defvar closure-frames nil) +(defvar closure-function-frames nil) (defun ovafp (form) (and (cdr form) (symbolp (cdr form)))) @@ -155,7 +156,7 @@ ; (eval-when (load compile eval) (defclass function-identifier :super object - :slots (name entry binding level offset bindframe body comp)) + :slots (name entry binding level offset bindframe body comp clist)) ) (eval-when (load eval) @@ -318,9 +319,13 @@ (let ((fdef (find-if #'(lambda (x) (eql (x . name) fn)) flets))) (if fdef (progn - (if (and avant-mode (not (fdef . bindframe)) (fdef . level) - (> closure-level (fdef . level))) - (setq (fdef . bindframe) t)) + (when (and avant-mode (fdef . level) + (> closure-level (fdef . level))) + (unless (listp closure-function-frames) + (setq closure-function-frames nil)) + (pushnew fdef closure-function-frames) + (unless (fdef . bindframe) + (setq (fdef . bindframe) t))) fdef) (cond ((fboundp fn) (setq fdef (symbol-function fn)) @@ -337,6 +342,14 @@ (dolist (a args) (send self :eval a)) (send trans :load-local (fdef . offset) (- closure-level (fdef . level)) (fdef . bindframe)) (send trans :call-closure (fdef . entry) (length args))) + (:get-flet-cframes (fn clevel &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))) + acc)) (:variable (var) ;var must be a symbol, ovaf is not allowed here. (let ((result (send idtable :get var scope))) (if (and result @@ -1018,32 +1031,27 @@ (send self :eval lab) (send self :eval val) (send trans :throw)) - (:closure (form &optional comment cframes) + (: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. - ;; TODO: fletframes currently only have scope based evaluation: - ;; if one closure in a given scope has a reference to a fletframe, all of the closures - ;; in that scope will bear that reference as well. - (let* ((fn #'(lambda (f) (and (f . offset) (= (f . level) closure-level)))) - (fletframes (remove-if-not fn fletframes)) - frame) - (when (or cframes fletframes) + (let (frame) + (when (or cframes fframes) ;; create a new vector which holds all necessary frames (let ((size (max (if cframes (apply #'max cframes) 0) - (if fletframes ((car fletframes) . offset) 0)))) + (if fframes (apply #'max fframes) 0)))) ;; TODO: in order to avoid having to remap the variables bindframe, we create a ;; vector which simulates the local stack, but only populates the required fields. (setq frame (send self :create-frame nil (1+ size) comment)) (dolist (f cframes) (send trans :load-local f 0) (send trans :store-local f 0 (frame . offset))) - (dolist (f fletframes) - (send trans :load-local (f . offset) 0) - (send trans :store-local (f . offset) 0 (frame . offset))))) + (dolist (f fframes) + (send trans :load-local f 0) + (send trans :store-local f 0 (frame . offset))))) ;; makeclosure (send trans :closure form (plusp closure-level) (not (not frame))))) (:lambda-preevaluation (fn &optional newcomp) @@ -1059,24 +1067,38 @@ (send newcomp :lambda param forms nil) (when (listp closure-frames) (dolist (v closure-frames) - (pushnew fn (identifier-clist v)))))) + (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 - (if closure-frames - (lambda-closure-frames) - (let ((closure-frames t)) - (lambda-closure-frames))) + (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 ((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))) + (let ((cframes (send idtable :get-cframes fn closure-level)) + (fframes (send self :get-flet-cframes fn closure-level))) (setq cleaner (send self :genlabel "UWP")) (push (send trans :offset-from-fp) unwind-frames) - (send self :closure cleaner "unwind protect" cframes) ;make cleanup closure + ;; make cleanup closure + (send self :closure cleaner "unwind protect" cframes fframes) (setq newcomp (send self :copy-compiler)) (send self :add-closure (list cleaner fn newcomp cframes)))) (send trans :bind-cleaner) @@ -1144,9 +1166,10 @@ (let (entry newcomp) ; #'(lambda (...) ...) (if avant-mode (send self :lambda-preevaluation fn) - (let ((cframes (send idtable :get-cframes fn closure-level))) + (let ((cframes (send idtable :get-cframes fn closure-level)) + (fframes (send self :get-flet-cframes fn closure-level))) (setq entry (send self :genlabel "CLO")) - (send self :closure entry "lambda-closure" cframes) + (send self :closure entry "lambda-closure" cframes fframes) (setq newcomp (send self :copy-compiler)) (send self :add-closure (list entry fn newcomp cframes))))))) (:flet (funcs bodies recursive-scope) @@ -1189,8 +1212,9 @@ (if (not avant-mode) (dolist (fn (reverse flets-tmp)) - (let ((cframes (send idtable :get-cframes (fn . body) closure-level))) - (send self :closure (fn . entry) "flet env" cframes) + (let ((cframes (send idtable :get-cframes (fn . body) closure-level)) + (fframes (send self :get-flet-cframes (fn . body) closure-level))) + (send self :closure (fn . entry) "flet env" cframes fframes) (setq (fn . offset) (1- (send trans :offset-from-fp))) (send self :add-closure (list (fn . entry) (fn . body) (fn . comp) cframes))))) From 23fc22bf287ab71a7e201b14a9ea2f91b493b966 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Sep 2022 14:10:33 +0900 Subject: [PATCH 308/387] Add compile-time check for fletframes --- lisp/comp/comp.l | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index eb93bc346..48daf3a5b 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -258,6 +258,7 @@ (idtable ;identifier-table closure-level ;current closure level current-cframes ;current closure bind frames + current-fframes ;current closure flet frames scope ;current variable scope (for sequential let) frames ;list of the number of special bindings fletframes ;list of function frames @@ -326,6 +327,13 @@ (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) (= (- closure-level (fdef . level)) 1) + (numberp (fdef . bindframe))) + (unless (find (fdef . bindframe) current-fframes) + (send self :error ";; unbound fletframe detected when loading function ~S" + (fdef . name)))) fdef) (cond ((fboundp fn) (setq fdef (symbol-function fn)) @@ -1100,7 +1108,7 @@ ;; make cleanup closure (send self :closure cleaner "unwind protect" cframes fframes) (setq newcomp (send self :copy-compiler)) - (send self :add-closure (list cleaner fn newcomp cframes)))) + (send self :add-closure (list cleaner fn newcomp cframes fframes)))) (send trans :bind-cleaner) (send self :eval prot) (send trans :call-cleaner cleaner) @@ -1171,7 +1179,7 @@ (setq entry (send self :genlabel "CLO")) (send self :closure entry "lambda-closure" cframes fframes) (setq newcomp (send self :copy-compiler)) - (send self :add-closure (list entry fn newcomp cframes))))))) + (send self :add-closure (list entry fn newcomp cframes fframes))))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet (let (newcomp newcomps flets-tmp flist fletframe) @@ -1216,7 +1224,8 @@ (fframes (send self :get-flet-cframes (fn . body) closure-level))) (send self :closure (fn . entry) "flet env" cframes fframes) (setq (fn . offset) (1- (send trans :offset-from-fp))) - (send self :add-closure (list (fn . entry) (fn . body) (fn . comp) cframes))))) + (send self :add-closure + (list (fn . entry) (fn . body) (fn . comp) cframes fframes))))) (if (not recursive-scope) ;; when not recursive setup the bindframe after the closure declaration @@ -1638,8 +1647,10 @@ (let ((entry (first aclosure)) (def (second aclosure)) (newcomp (third aclosure)) - (cframes (fourth aclosure))) + (cframes (fourth aclosure)) + (fframes (fifth aclosure))) (setq (newcomp . current-cframes) cframes) + (setq (newcomp . current-fframes) fframes) (send newcomp :compile-a-closure entry def))) (setq function-closures nil)) (:toplevel-eval (form) From 14fa6e228fcf22efdda988a61e3da35a9659b9a2 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Sep 2022 15:36:53 +0900 Subject: [PATCH 309/387] Also consider current fletframe on recursive-scope (labels) --- lisp/comp/comp.l | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 48daf3a5b..f95199aeb 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1222,6 +1222,11 @@ (dolist (fn (reverse flets-tmp)) (let ((cframes (send idtable :get-cframes (fn . body) closure-level)) (fframes (send self :get-flet-cframes (fn . body) closure-level))) + (when recursive-scope + ;; append the current frame if any references are found + (when (send self :get-flet-cframes + (fn . body) closure-level 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 From 9ebcabc5c4eaaacf61f71bc4788012c7b7e5bee9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Sep 2022 16:49:51 +0900 Subject: [PATCH 310/387] Enable minimal closure frame size by reassigning indexes with cbindframe --- lisp/comp/comp.l | 70 +++++++++++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 27 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index f95199aeb..8caec55f8 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -134,7 +134,7 @@ ; (eval-when (load compile eval) (defclass identifier :super object - :slots (name type binding level offset bindframe clist)) + :slots (name type binding level offset bindframe cbindframe clist)) ) ;; binding = (constant, local, global, special) @@ -156,7 +156,7 @@ ; (eval-when (load compile eval) (defclass function-identifier :super object - :slots (name entry binding level offset bindframe body comp clist)) + :slots (name entry binding level offset bindframe cbindframe body comp clist)) ) (eval-when (load eval) @@ -200,12 +200,18 @@ ;; 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 + (dolist (var (svref frames level)) + (setq var (cdr var)) + ;; force nil when not found + (setq (var . cbindframe) (position (var . bindframe) acc))) acc)) (:enter (id &optional (lev level)) (svset frames lev (cons (cons (id . name) id) (svref frames lev))) @@ -348,7 +354,10 @@ (:call-closure (fdef args) (if *debug* (print (list :call-closure fdef args))) (dolist (a args) (send self :eval a)) - (send trans :load-local (fdef . offset) (- closure-level (fdef . level)) (fdef . bindframe)) + (send trans :load-local (fdef . offset) (- closure-level (fdef . level)) + (if (and (fdef . cbindframe) (> closure-level (fdef . level))) + (fdef . cbindframe) + (fdef . bindframe))) (send trans :call-closure (fdef . entry) (length args))) (:get-flet-cframes (fn clevel &optional (function-table flets)) ;; collect the binding offset of all flets used inside a function @@ -383,18 +392,22 @@ 'ovaf (send (send self :variable var) :binding))) (:var-bindframe (var) - (if (or (var . bindframe) (= closure-level (var . level))) - (var . bindframe) - (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)))))) + (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) @@ -1049,17 +1062,18 @@ (let (frame) (when (or cframes fframes) ;; create a new vector which holds all necessary frames - (let ((size (max (if cframes (apply #'max cframes) 0) - (if fframes (apply #'max fframes) 0)))) - ;; TODO: in order to avoid having to remap the variables bindframe, we create a - ;; vector which simulates the local stack, but only populates the required fields. - (setq frame (send self :create-frame nil (1+ size) comment)) - (dolist (f cframes) - (send trans :load-local f 0) - (send trans :store-local f 0 (frame . offset))) - (dolist (f fframes) - (send trans :load-local f 0) - (send trans :store-local f 0 (frame . offset))))) + (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 newcomp) @@ -1182,7 +1196,7 @@ (send self :add-closure (list entry fn newcomp cframes fframes))))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet - (let (newcomp newcomps flets-tmp flist fletframe) + (let (newcomp newcomps flets-tmp flist fletframe (cframe-length 0)) (if (not recursive-scope) ; copy compiler before binding the functions (setq newcomp (send self :copy-compiler))) (dolist (fn funcs) @@ -1222,6 +1236,7 @@ (dolist (fn (reverse flets-tmp)) (let ((cframes (send idtable :get-cframes (fn . body) closure-level)) (fframes (send self :get-flet-cframes (fn . body) closure-level))) + (setq cframe-length (length cframes)) (when recursive-scope ;; append the current frame if any references are found (when (send self :get-flet-cframes @@ -1243,6 +1258,7 @@ (send trans :load-local (fn . offset) (- closure-level (fn . level))) (send trans :store-local i 0 (fletframe . offset)) (setq (fn . bindframe) (fletframe . offset) + (fn . cbindframe) (+ cframe-length i) (fn . offset) i))) ;; evaluate body From 158b411e3fbb521b92f1244ee9d422213baaa200 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Sep 2022 18:55:08 +0900 Subject: [PATCH 311/387] Reset function identifier cbindframe counter at each frame --- lisp/comp/comp.l | 37 ++++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 8caec55f8..d54e276bb 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -208,10 +208,12 @@ (pushnew (var . bindframe) acc))) (dec lev)) ;; update cbindframe offset value on the current level - (dolist (var (svref frames level)) - (setq var (cdr var)) - ;; force nil when not found - (setq (var . cbindframe) (position (var . bindframe) acc))) + (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))) @@ -359,13 +361,15 @@ (fdef . cbindframe) (fdef . bindframe))) (send trans :call-closure (fdef . entry) (length args))) - (:get-flet-cframes (fn clevel &optional (function-table flets)) + (:get-flet-cframes (fn clevel cstart &optional (function-table flets)) ;; collect the binding offset of all flets used inside a function - (let (acc) + (let ((i 0) acc) (dolist (f function-table) (when (and f (= (f . level) clevel) (find fn (f . clist) :test #'equal)) - (pushnew (f . bindframe) acc))) + (pushnew (f . bindframe) acc) + (setq (f . cbindframe) (+ i cstart)) + (inc i))) acc)) (:variable (var) ;var must be a symbol, ovaf is not allowed here. (let ((result (send idtable :get var scope))) @@ -1115,8 +1119,8 @@ 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))) + (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 @@ -1188,15 +1192,15 @@ (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))) + (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 (list entry fn newcomp cframes fframes))))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet - (let (newcomp newcomps flets-tmp flist fletframe (cframe-length 0)) + (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) @@ -1234,13 +1238,13 @@ (if (not avant-mode) (dolist (fn (reverse flets-tmp)) - (let ((cframes (send idtable :get-cframes (fn . body) closure-level)) - (fframes (send self :get-flet-cframes (fn . body) closure-level))) - (setq cframe-length (length cframes)) + (let* ((cframes (send 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 flist) + (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))) @@ -1258,7 +1262,6 @@ (send trans :load-local (fn . offset) (- closure-level (fn . level))) (send trans :store-local i 0 (fletframe . offset)) (setq (fn . bindframe) (fletframe . offset) - (fn . cbindframe) (+ cframe-length i) (fn . offset) i))) ;; evaluate body From ea4542a1b8760a44b5e74918cfcf6c74686d3194 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Sep 2022 19:06:54 +0900 Subject: [PATCH 312/387] Add compile checks for frame size --- lisp/comp/comp.l | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index d54e276bb..059e1240a 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -267,6 +267,7 @@ 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 @@ -341,6 +342,9 @@ (numberp (fdef . bindframe))) (unless (find (fdef . bindframe) current-fframes) (send self :error ";; unbound fletframe detected when loading function ~S" + (fdef . name))) + (unless (< (fdef . cbindframe) current-csize) + (send self :error ";; invalid fletframe index detected when loading function ~S" (fdef . name)))) fdef) (cond ((fboundp fn) @@ -549,6 +553,9 @@ (numberp (pushvar . bindframe))) (unless (find (pushvar . bindframe) current-cframes) (send self :error ";; unbound bindframe detected when loading variable ~S" + (var . name))) + (unless (< (send self :var-bindframe pushvar) current-csize) + (send self :error ";; invalid bindframe index detected when loading variable ~S" (var . name)))))) (case (var . binding) ;; special variables are accessed through :load-global, so we don't need @@ -1675,6 +1682,7 @@ (fframes (fifth aclosure))) (setq (newcomp . current-cframes) cframes) (setq (newcomp . current-fframes) fframes) + (setq (newcomp . current-csize) (+ (length cframes) (length fframes))) (send newcomp :compile-a-closure entry def))) (setq function-closures nil)) (:toplevel-eval (form) From 29bd502bbfa45fc57f75008e4b56da8ac7734c0c Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Sep 2022 19:19:49 +0900 Subject: [PATCH 313/387] Print invalid value at compile error messages --- lisp/comp/comp.l | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 059e1240a..4d6710bdb 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -341,11 +341,11 @@ (when (and (not avant-mode) (= (- closure-level (fdef . level)) 1) (numberp (fdef . bindframe))) (unless (find (fdef . bindframe) current-fframes) - (send self :error ";; unbound fletframe detected when loading function ~S" - (fdef . name))) + (send self :error ";; unbound fletframe detected when loading function ~S: ~A" + (fdef . name) (fdef . bindframe))) (unless (< (fdef . cbindframe) current-csize) - (send self :error ";; invalid fletframe index detected when loading function ~S" - (fdef . name)))) + (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)) @@ -552,11 +552,11 @@ (when (and (not avant-mode) (= (- closure-level (var . level)) 1) (numberp (pushvar . bindframe))) (unless (find (pushvar . bindframe) current-cframes) - (send self :error ";; unbound bindframe detected when loading variable ~S" - (var . name))) + (send self :error ";; unbound bindframe detected when loading variable ~S: ~A" + (var . name) (pushvar . bindframe))) (unless (< (send self :var-bindframe pushvar) current-csize) - (send self :error ";; invalid bindframe index detected when loading variable ~S" - (var . name)))))) + (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 From 5d31b9eb522b717a7d4f8b8875e9dd1c9c30b8b0 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 23 Sep 2022 11:34:22 +0900 Subject: [PATCH 314/387] Allow functions to have different cbindframe values --- lisp/comp/comp.l | 59 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 40 insertions(+), 19 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 4d6710bdb..d0ec85c5f 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -339,12 +339,12 @@ ;; compile-time check to see if we are not missing any frame references (when (and (not avant-mode) (= (- closure-level (fdef . level)) 1) - (numberp (fdef . bindframe))) + (fdef . bindframe)) (unless (find (fdef . bindframe) current-fframes) - (send self :error ";; unbound fletframe detected when loading function ~S: ~A" + (send self :error "unbound fletframe detected when loading function ~S: ~A" (fdef . name) (fdef . bindframe))) - (unless (< (fdef . cbindframe) current-csize) - (send self :error ";; invalid fletframe index detected when loading function ~S: ~A" + (unless (< (send self :flet-bindframe fdef) current-csize) + (send self :error "invalid fletframe index detected when loading function ~S: ~A" (fdef . name) (fdef . cbindframe)))) fdef) (cond ((fboundp fn) @@ -361,20 +361,27 @@ (if *debug* (print (list :call-closure fdef args))) (dolist (a args) (send self :eval a)) (send trans :load-local (fdef . offset) (- closure-level (fdef . level)) - (if (and (fdef . cbindframe) (> closure-level (fdef . level))) - (fdef . cbindframe) - (fdef . bindframe))) + (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 ((i 0) acc) + (let (acc) (dolist (f function-table) (when (and f (= (f . level) clevel) (find fn (f . clist) :test #'equal)) - (pushnew (f . bindframe) acc) - (setq (f . cbindframe) (+ i cstart)) - (inc i))) + (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 (and result @@ -1194,7 +1201,7 @@ (if (eq (flet-def . binding) 'closure) (send trans :load-local (flet-def . offset) (- closure-level (flet-def . level)) - (flet-def . bindframe)) + (send self :flet-bindframe flet-def)) (send trans :getfunc fn))) (let (entry newcomp) ; #'(lambda (...) ...) (if avant-mode @@ -1245,7 +1252,7 @@ (if (not avant-mode) (dolist (fn (reverse flets-tmp)) - (let* ((cframes (send idtable :get-cframes (fn . body) closure-level)) + (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 @@ -1271,6 +1278,13 @@ (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 + (dolist (fdef flets-tmp) + (when (fdef . cbindframe) + (setq (fdef . cbindframe) t))) + ;; evaluate body (setq flets (append flets-tmp flets)) (if recursive-scope (send-all newcomps :change-flets flets)) @@ -1675,14 +1689,21 @@ ) (:compile-closures () (dolist (aclosure (reverse function-closures)) - (let ((entry (first aclosure)) - (def (second aclosure)) - (newcomp (third aclosure)) - (cframes (fourth aclosure)) - (fframes (fifth aclosure))) + (let* ((entry (first aclosure)) + (def (second aclosure)) + (newcomp (third aclosure)) + (cframes (fourth aclosure)) + (fframes (fifth aclosure)) + (cbind (append cframes fframes))) (setq (newcomp . current-cframes) cframes) (setq (newcomp . current-fframes) fframes) - (setq (newcomp . current-csize) (+ (length cframes) (length fframes))) + (setq (newcomp . current-csize) (length cbind)) + ;; 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 entry def))) (setq function-closures nil)) (:toplevel-eval (form) From ee5a24f7735c471c9c223c1eade35bf94649a617 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 27 Sep 2022 14:50:30 +0900 Subject: [PATCH 315/387] Add sys::unwind function --- lisp/c/eus_proto.h | 1 + lisp/c/sysfunc.c | 21 +++++++++++++++++++++ lisp/comp/builtins.l | 1 + 3 files changed, 23 insertions(+) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 9b6dc55e8..117771dee 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -636,6 +636,7 @@ 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*/*); extern pointer NEXT_SPECIAL_INDEX(context */*ctx*/, int /*n*/, pointer /*argv*/*); +extern pointer UNWIND(context* /*ctx*/, int /*n*/, pointer /*argv*/*); extern pointer THREAD_SPECIALS(context */*ctx*/, int /*n*/, pointer /*argv*/*); extern void sysfunc(context */*ctx*/, pointer /*mod*/); /* unixcall.c */ diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index adedc9bc9..22d62b24f 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -850,6 +850,26 @@ pointer argv[]; x=special_index(); /*generate a new special value index*/ return(makeint(x));} +pointer UNWIND(ctx,n,argv) +register context *ctx; +int n; +pointer *argv; +{ ckarg2(1,2); + int i=0; + int j=ckintval(argv[0]); + pointer val=NIL; + if (n>1) val=argv[1]; + struct catchframe *cfp=ctx->catchfp; + while (cfp) { + if (!(cfp->label)) { + i++; + if (i > j) { + unwind(ctx,(pointer *)cfp); + euslongjmp(*(cfp->jbp),val);}} + cfp=cfp->nextcatch;} + error(E_NOCATCHER); +} + pointer THREAD_SPECIALS(ctx,n,argv) context *ctx; int n; @@ -910,6 +930,7 @@ pointer mod; defun(ctx,"LIST-ALL-CLASSES",mod,LISTALLCLASSES,NULL); defun(ctx,"EXPORT-ALL-SYMBOLS", mod, EXPORTALL,NULL); defun(ctx,"NEXT-SPECIAL-INDEX", mod, NEXT_SPECIAL_INDEX,NULL); + defun(ctx,"UNWIND", mod, UNWIND,NULL); defun(ctx,"THREAD-SPECIALS", mod, THREAD_SPECIALS,NULL); defun(ctx,"DISPOSE-HOOK", mod, DISPOSE_HOOK,NULL); diff --git a/lisp/comp/builtins.l b/lisp/comp/builtins.l index 14cffe04a..85250fdc3 100644 --- a/lisp/comp/builtins.l +++ b/lisp/comp/builtins.l @@ -373,6 +373,7 @@ (def-builtin-entry 'SYS:LIST-ALL-CLASSES "LISTALLCLASSES") (def-builtin-entry 'SYS::EXPORT-ALL-SYMBOLS "EXPORTALL") (def-builtin-entry 'SYS::NEXT-SPECIAL-INDEX "NEXT_SPECIAL_INDEX") +(def-builtin-entry 'SYS::UNWIND "UNWIND") (def-builtin-entry 'SYS::THREAD-SPECIALS "THREAD_SPECIALS") (def-builtin-entry 'SYS::DISPOSE-HOOK "DISPOSE_HOOK") From aefef04ed7338abf79aadff7dff922b574171e49 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 27 Sep 2022 16:11:54 +0900 Subject: [PATCH 316/387] Eval form after unwinding in sys::unwind --- lisp/c/eus_proto.h | 2 +- lisp/c/eval.c | 1 + lisp/c/sysfunc.c | 20 +++++++++++--------- 3 files changed, 13 insertions(+), 10 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 117771dee..f233abdcd 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -636,7 +636,7 @@ 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*/*); extern pointer NEXT_SPECIAL_INDEX(context */*ctx*/, int /*n*/, pointer /*argv*/*); -extern pointer UNWIND(context* /*ctx*/, int /*n*/, pointer /*argv*/*); +extern pointer UNWIND(context */*ctx*/, pointer /*arg*/); extern pointer THREAD_SPECIALS(context */*ctx*/, int /*n*/, pointer /*argv*/*); extern void sysfunc(context */*ctx*/, pointer /*mod*/); /* unixcall.c */ diff --git a/lisp/c/eval.c b/lisp/c/eval.c index fdd0ac3bc..8c1d6af84 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1467,6 +1467,7 @@ register int noarg; val=NIL; } + // callframes and fletframes are unwinded in funcall ctx->vsp=(pointer *)ctx->catchfp; ctx->catchfp=(struct catchframe *)*ctx->vsp; return(val); diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index 22d62b24f..c9a0c383d 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -850,22 +850,24 @@ pointer argv[]; x=special_index(); /*generate a new special value index*/ return(makeint(x));} -pointer UNWIND(ctx,n,argv) +pointer UNWIND(ctx,arg) register context *ctx; -int n; -pointer *argv; -{ ckarg2(1,2); +pointer arg; +{ if (!islist(arg)) error(E_MISMATCHARG); + if (ccdr(ccdr(arg))!=NIL) error(E_MISMATCHARG); int i=0; - int j=ckintval(argv[0]); - pointer val=NIL; - if (n>1) val=argv[1]; + int j=ckintval(ccar(arg)); + pointer val=ccar(ccdr(arg)); struct catchframe *cfp=ctx->catchfp; while (cfp) { if (!(cfp->label)) { i++; if (i > j) { unwind(ctx,(pointer *)cfp); - euslongjmp(*(cfp->jbp),val);}} + ctx->callfp = cfp->cf; + ctx->bindfp = cfp->bf; + ctx->fletfp = cfp->ff; + euslongjmp(*(cfp->jbp), eval(ctx,val));}} cfp=cfp->nextcatch;} error(E_NOCATCHER); } @@ -930,7 +932,7 @@ pointer mod; defun(ctx,"LIST-ALL-CLASSES",mod,LISTALLCLASSES,NULL); defun(ctx,"EXPORT-ALL-SYMBOLS", mod, EXPORTALL,NULL); defun(ctx,"NEXT-SPECIAL-INDEX", mod, NEXT_SPECIAL_INDEX,NULL); - defun(ctx,"UNWIND", mod, UNWIND,NULL); + defspecial(ctx,"UNWIND",mod, UNWIND); defun(ctx,"THREAD-SPECIALS", mod, THREAD_SPECIALS,NULL); defun(ctx,"DISPOSE-HOOK", mod, DISPOSE_HOOK,NULL); From dd4b4b2d5b522a55aa995f86cd7addae6c72b14d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 27 Sep 2022 16:18:39 +0900 Subject: [PATCH 317/387] Add sys::unwind documentation --- doc/jlatex/euslisp.hlp | 27 ++++++++++++++------------- doc/jlatex/jevaluation.tex | 3 +++ doc/latex/euslisp.hlp | 27 ++++++++++++++------------- doc/latex/evaluation.tex | 3 +++ 4 files changed, 34 insertions(+), 26 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 75c34972b..486439b6b 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -585,19 +585,20 @@ "time" 3 "jevaluation" 35044 3 "lisp::print-callstack" 2 "jevaluation" 35159 3 "sys:list-callstack" 2 "jevaluation" 35400 3 -"sys:list-all-catchers" 2 "jevaluation" 35607 3 -"sys:list-all-blocks" 2 "jevaluation" 35685 3 -"sys:list-all-tags" 2 "jevaluation" 35761 3 -"sys:list-all-instances" 2 "jevaluation" 35844 3 -"sys:list-all-bindings" 2 "jevaluation" 36233 3 -"sys:list-all-special-bindings" 2 "jevaluation" 36580 3 -"sys:list-all-function-bindings" 2 "jevaluation" 36739 3 -"dump-object" 2 "jevaluation" 37745 2 -"dump-structure" 2 "jevaluation" 37793 3 -"dump-loadable-structure" 2 "jevaluation" 37948 3 -"sys:save" 2 "jevaluation" 39010 3 -"lisp-implementation-type" 2 "jevaluation" 42414 3 -"lisp-implementation-version" 2 "jevaluation" 42486 3 +"sys::unwind" 2 "jevaluation" 35597 3 +"sys:list-all-catchers" 2 "jevaluation" 35798 3 +"sys:list-all-blocks" 2 "jevaluation" 35876 3 +"sys:list-all-tags" 2 "jevaluation" 35952 3 +"sys:list-all-instances" 2 "jevaluation" 36035 3 +"sys:list-all-bindings" 2 "jevaluation" 36424 3 +"sys:list-all-special-bindings" 2 "jevaluation" 36771 3 +"sys:list-all-function-bindings" 2 "jevaluation" 36930 3 +"dump-object" 2 "jevaluation" 37936 2 +"dump-structure" 2 "jevaluation" 37984 3 +"dump-loadable-structure" 2 "jevaluation" 38139 3 +"sys:save" 2 "jevaluation" 39201 3 +"lisp-implementation-type" 2 "jevaluation" 42605 3 +"lisp-implementation-version" 2 "jevaluation" 42677 3 "sys:gc" 2 "jsysfunc" 6326 3 "sys:gctime" 2 "jsysfunc" 6520 3 "sys:alloc" 2 "jsysfunc" 6837 3 diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 45b141b48..6330821bf 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -667,6 +667,9 @@ \subsection{デバッグ補助} 現在のcallstackの最高{\em max}個のリストを返す。 {\em max}が与えられない場合には現在のcallstackのすべてを出力する。} +\funcdesc{sys::unwind}{num \&optional form}{ +現在のcallstackを{\em num}個戻し、{\em form}の値を代わりに返す。{\em form}はcallstackを戻したあとに評価される。} + \funcdesc{sys:list-all-catchers}{}{ すべての{\bf catch}タグを返す。} diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index dabd5e2b5..a281f52a3 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -590,19 +590,20 @@ "time" 3 "evaluation" 31063 3 "lisp::print-callstack" 2 "evaluation" 31163 3 "sys:list-callstack" 2 "evaluation" 31417 3 -"sys:list-all-catchers" 2 "evaluation" 31611 3 -"sys:list-all-blocks" 2 "evaluation" 31687 3 -"sys:list-all-tags" 2 "evaluation" 31761 3 -"sys:list-all-instances" 2 "evaluation" 31842 3 -"sys:list-all-bindings" 2 "evaluation" 32139 3 -"sys:list-all-special-bindings" 2 "evaluation" 32357 3 -"sys:list-all-function-bindings" 2 "evaluation" 32474 3 -"dump-object" 2 "evaluation" 33210 2 -"dump-structure" 2 "evaluation" 33258 3 -"dump-loadable-structure" 2 "evaluation" 33389 3 -"sys:save" 2 "evaluation" 34261 3 -"lisp-implementation-type" 2 "evaluation" 36971 3 -"lisp-implementation-version" 2 "evaluation" 37040 3 +"sys::unwind" 2 "evaluation" 31601 3 +"sys:list-all-catchers" 2 "evaluation" 31799 3 +"sys:list-all-blocks" 2 "evaluation" 31875 3 +"sys:list-all-tags" 2 "evaluation" 31949 3 +"sys:list-all-instances" 2 "evaluation" 32030 3 +"sys:list-all-bindings" 2 "evaluation" 32327 3 +"sys:list-all-special-bindings" 2 "evaluation" 32545 3 +"sys:list-all-function-bindings" 2 "evaluation" 32662 3 +"dump-object" 2 "evaluation" 33398 2 +"dump-structure" 2 "evaluation" 33446 3 +"dump-loadable-structure" 2 "evaluation" 33577 3 +"sys:save" 2 "evaluation" 34449 3 +"lisp-implementation-type" 2 "evaluation" 37159 3 +"lisp-implementation-version" 2 "evaluation" 37228 3 "sys:gc" 2 "sysfunc" 4597 3 "sys:gctime" 2 "sysfunc" 4726 3 "sys:alloc" 2 "sysfunc" 4943 3 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index 644b5f243..9e00c0356 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -725,6 +725,9 @@ \subsection{Debugging Aid} 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::unwind}{num \&optional form}{ +Unwinds the callstack {\em num} frames and returns {\em form} instead. The {\em form} expression is evaluated after unwinding the callstack.} + \funcdesc{sys:list-all-catchers}{}{ returns a list of all {\bf catch} tags.} From fb3e3825493d31d16142a576d3cbec4232de4ba5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 15 Oct 2022 01:17:49 +0900 Subject: [PATCH 318/387] Fix type declarations --- lisp/comp/comp.l | 49 +++++++++++++++++++++++++++++------------------- 1 file changed, 30 insertions(+), 19 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index d0ec85c5f..b9f664b27 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -930,7 +930,7 @@ result-type)) (:let* (bodies &optional (rec t)) ;sequential let (let ((unwind-save unwind-frames) (i 0) - local-list bindframe vlist closure-vlist) + 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, @@ -947,7 +947,7 @@ (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) (let* ((var (if (listp init-form) (car init-form) init-form)) @@ -959,6 +959,8 @@ (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 @@ -968,11 +970,11 @@ (remove-if-not #'(lambda (v) (v . bindframe)) (nreverse vlist)))) (:let (bodies) ;parallel let (let ((local-list (pop bodies)) (unwind-save unwind-frames) - bindframe special-list vlist) + 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) (let (var offset) @@ -997,6 +999,8 @@ (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 @@ -1335,6 +1339,16 @@ (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) @@ -1360,12 +1374,14 @@ (unwind-save unwind-frames) (cvar-i 0) argframe vlist closure-vlist) (when rec - ;; an in let*, we need to sequentially bind variables directly to the frame + ;; 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)) - (setq closure-vlist (send newcomp :lambda param forms nil)))) + (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) @@ -1580,22 +1596,17 @@ (inc cvar-i)) (let ((offset (1- (send trans :offset-from-fp)))) (push (send self :bind var argframe 'local offset) vlist))))) -;;; type check declaration variables - (when *type-check-declare* - (dolist (dvar decl-vars) - (let* ((id (car dvar)) - (tp (cdr dvar)) - (v (send self :variable id))) - (unless (eql (v . binding) 'unknown) - (send self :load-var id) - (send trans :type-check-declare tp))))) +;;; 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 'arg t) ;;; return value - (remove-if-not #'(lambda (v) (v . bindframe)) (nreverse vlist)))) + (list + (remove-if-not #'(lambda (v) (v . bindframe)) (nreverse vlist)) + decl-vars))) (:lambda-block (name arglist bodies cname) (let ((ctime (unix:runtime)) blklabel) From ff80c4f269b80f247ab3198ba352807b181bf9f9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 15 Oct 2022 01:38:45 +0900 Subject: [PATCH 319/387] Avoid unchecked declarations in nstring-upcase/downcase --- lisp/l/string.l | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/l/string.l b/lisp/l/string.l index 1602a8a4f..4af38f5e3 100644 --- a/lisp/l/string.l +++ b/lisp/l/string.l @@ -83,7 +83,7 @@ (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)) + (declare (string str)) (if (not (stringp str)) (error type-error "string expected")) (while (< start end) (setchar str start (char-downcase (char str start))) @@ -91,7 +91,7 @@ str) (defun nstring-upcase (str &key (start 0) (end (length str))) - (declare (type integer start end)) + (declare (string str)) (if (not (stringp str)) (error type-error "string expected")) (while (< start end) (setchar str start (char-upcase (char str start))) From 3a3a55c7d637d014243a906a3ab7fc1b226cd820 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 15 Oct 2022 01:49:23 +0900 Subject: [PATCH 320/387] Use strict number checking when *type-check-declare* is true --- lisp/comp/trans.l | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 3950a746a..d431a34ee 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -478,8 +478,8 @@ (cons "iscons") (list "islist(w) || w==NIL") (number "numberp") - (integer "numberp") ;; don't use `isint' for backward compability - (float "numberp") ;; don't use `isflt' for backward compability + (integer "isint") + (float "isflt") (string "isstring") (array "isarray(w) || isvector(w)") (vector "isvector") From 4f088fed256586686d5606d518312f2e16a13451 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 15 Oct 2022 10:31:13 +0900 Subject: [PATCH 321/387] Revert error resumption and unwind capabilities --- doc/jlatex/euslisp.hlp | 27 +++++++++++++-------------- doc/jlatex/jevaluation.tex | 3 --- doc/latex/euslisp.hlp | 27 +++++++++++++-------------- doc/latex/evaluation.tex | 3 --- lisp/c/eus.c | 9 +-------- lisp/c/eus_proto.h | 1 - lisp/c/eval.c | 25 +------------------------ lisp/c/sysfunc.c | 28 ++-------------------------- lisp/comp/builtins.l | 1 - 9 files changed, 30 insertions(+), 94 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 486439b6b..75c34972b 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -585,20 +585,19 @@ "time" 3 "jevaluation" 35044 3 "lisp::print-callstack" 2 "jevaluation" 35159 3 "sys:list-callstack" 2 "jevaluation" 35400 3 -"sys::unwind" 2 "jevaluation" 35597 3 -"sys:list-all-catchers" 2 "jevaluation" 35798 3 -"sys:list-all-blocks" 2 "jevaluation" 35876 3 -"sys:list-all-tags" 2 "jevaluation" 35952 3 -"sys:list-all-instances" 2 "jevaluation" 36035 3 -"sys:list-all-bindings" 2 "jevaluation" 36424 3 -"sys:list-all-special-bindings" 2 "jevaluation" 36771 3 -"sys:list-all-function-bindings" 2 "jevaluation" 36930 3 -"dump-object" 2 "jevaluation" 37936 2 -"dump-structure" 2 "jevaluation" 37984 3 -"dump-loadable-structure" 2 "jevaluation" 38139 3 -"sys:save" 2 "jevaluation" 39201 3 -"lisp-implementation-type" 2 "jevaluation" 42605 3 -"lisp-implementation-version" 2 "jevaluation" 42677 3 +"sys:list-all-catchers" 2 "jevaluation" 35607 3 +"sys:list-all-blocks" 2 "jevaluation" 35685 3 +"sys:list-all-tags" 2 "jevaluation" 35761 3 +"sys:list-all-instances" 2 "jevaluation" 35844 3 +"sys:list-all-bindings" 2 "jevaluation" 36233 3 +"sys:list-all-special-bindings" 2 "jevaluation" 36580 3 +"sys:list-all-function-bindings" 2 "jevaluation" 36739 3 +"dump-object" 2 "jevaluation" 37745 2 +"dump-structure" 2 "jevaluation" 37793 3 +"dump-loadable-structure" 2 "jevaluation" 37948 3 +"sys:save" 2 "jevaluation" 39010 3 +"lisp-implementation-type" 2 "jevaluation" 42414 3 +"lisp-implementation-version" 2 "jevaluation" 42486 3 "sys:gc" 2 "jsysfunc" 6326 3 "sys:gctime" 2 "jsysfunc" 6520 3 "sys:alloc" 2 "jsysfunc" 6837 3 diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 6330821bf..45b141b48 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -667,9 +667,6 @@ \subsection{デバッグ補助} 現在のcallstackの最高{\em max}個のリストを返す。 {\em max}が与えられない場合には現在のcallstackのすべてを出力する。} -\funcdesc{sys::unwind}{num \&optional form}{ -現在のcallstackを{\em num}個戻し、{\em form}の値を代わりに返す。{\em form}はcallstackを戻したあとに評価される。} - \funcdesc{sys:list-all-catchers}{}{ すべての{\bf catch}タグを返す。} diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index a281f52a3..dabd5e2b5 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -590,20 +590,19 @@ "time" 3 "evaluation" 31063 3 "lisp::print-callstack" 2 "evaluation" 31163 3 "sys:list-callstack" 2 "evaluation" 31417 3 -"sys::unwind" 2 "evaluation" 31601 3 -"sys:list-all-catchers" 2 "evaluation" 31799 3 -"sys:list-all-blocks" 2 "evaluation" 31875 3 -"sys:list-all-tags" 2 "evaluation" 31949 3 -"sys:list-all-instances" 2 "evaluation" 32030 3 -"sys:list-all-bindings" 2 "evaluation" 32327 3 -"sys:list-all-special-bindings" 2 "evaluation" 32545 3 -"sys:list-all-function-bindings" 2 "evaluation" 32662 3 -"dump-object" 2 "evaluation" 33398 2 -"dump-structure" 2 "evaluation" 33446 3 -"dump-loadable-structure" 2 "evaluation" 33577 3 -"sys:save" 2 "evaluation" 34449 3 -"lisp-implementation-type" 2 "evaluation" 37159 3 -"lisp-implementation-version" 2 "evaluation" 37228 3 +"sys:list-all-catchers" 2 "evaluation" 31611 3 +"sys:list-all-blocks" 2 "evaluation" 31687 3 +"sys:list-all-tags" 2 "evaluation" 31761 3 +"sys:list-all-instances" 2 "evaluation" 31842 3 +"sys:list-all-bindings" 2 "evaluation" 32139 3 +"sys:list-all-special-bindings" 2 "evaluation" 32357 3 +"sys:list-all-function-bindings" 2 "evaluation" 32474 3 +"dump-object" 2 "evaluation" 33210 2 +"dump-structure" 2 "evaluation" 33258 3 +"dump-loadable-structure" 2 "evaluation" 33389 3 +"sys:save" 2 "evaluation" 34261 3 +"lisp-implementation-type" 2 "evaluation" 36971 3 +"lisp-implementation-version" 2 "evaluation" 37040 3 "sys:gc" 2 "sysfunc" 4597 3 "sys:gctime" 2 "sysfunc" 4726 3 "sys:alloc" 2 "sysfunc" 4943 3 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index 9e00c0356..644b5f243 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -725,9 +725,6 @@ \subsection{Debugging Aid} 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::unwind}{num \&optional form}{ -Unwinds the callstack {\em num} frames and returns {\em form} instead. The {\em form} expression is evaluated after unwinding the callstack.} - \funcdesc{sys:list-all-catchers}{}{ returns a list of all {\bf catch} tags.} diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 500169536..765502a1e 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -329,7 +329,6 @@ va_dcl register struct callframe *vf; pointer msg,form,callstack; pointer errobj; - pointer result; #ifdef USE_STDARG va_start(args,ec); @@ -436,13 +435,7 @@ va_dcl Spevalof(QEVALHOOK)=NIL; /* reset eval hook */ if (errhandler!=NIL) { vpush(errobj); - result=ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-1),ctx->bindfp,1);} - else { - result=NIL; - } - // the NULL catcher is introduced by catchfuncode, in order to ensure - // that errors follow the termination semantics in the C lang level - throw(ctx,NULL,result); + ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-1),ctx->bindfp,1);} } #ifdef USE_STDARG diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index f233abdcd..9b6dc55e8 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -636,7 +636,6 @@ 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*/*); extern pointer NEXT_SPECIAL_INDEX(context */*ctx*/, int /*n*/, pointer /*argv*/*); -extern pointer UNWIND(context */*ctx*/, pointer /*arg*/); extern pointer THREAD_SPECIALS(context */*ctx*/, int /*n*/, pointer /*argv*/*); extern void sysfunc(context */*ctx*/, pointer /*mod*/); /* unixcall.c */ diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 8c1d6af84..f28135c29 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1450,29 +1450,6 @@ pointer args[]; #endif /* IRIX */ #endif /* IRIX6 */ -pointer catchfuncode(ctx,func,args,noarg) -register context *ctx; -register pointer func,args; -register int noarg; -{ - // create a NULL catcher around each evaluation of compiled code - // this ensures that no continuations are allowed in the C lang level, - // even if the user locally overwrites the error handler - pointer tag,val; - jmp_buf catchbuf; - mkcatchframe(ctx,NULL,&catchbuf); - if ((val=(pointer)eussetjmp(catchbuf))==0) { - val=funcode(ctx,func,args,noarg);} - else if ((eusinteger_t)val==1) { - val=NIL; - } - - // callframes and fletframes are unwinded in funcall - ctx->vsp=(pointer *)ctx->catchfp; - ctx->catchfp=(struct catchframe *)*ctx->vsp; - return(val); -} - pointer funcode(ctx,func,args,noarg) register context *ctx; register pointer func,args; @@ -1633,7 +1610,7 @@ int noarg; else if (piscode(func)) { /*call subr*/ GC_POINT; - result=catchfuncode(ctx,func,args,noarg); + result=funcode(ctx,func,args,noarg); ctx->vsp=(pointer *)vf; ctx->callfp= vf->vlink; ctx->fletfp=oldfletfp; diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index c9a0c383d..82928fd06 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -752,9 +752,8 @@ pointer *argv; struct catchframe *cfp=ctx->catchfp; int i=0; while (cfp) { - if (cfp->label) { - vpush(cfp->label); - i++;} + vpush(cfp->label); + i++; cfp=cfp->nextcatch;} return(stacknlist(ctx,i));} @@ -850,28 +849,6 @@ pointer argv[]; x=special_index(); /*generate a new special value index*/ return(makeint(x));} -pointer UNWIND(ctx,arg) -register context *ctx; -pointer arg; -{ if (!islist(arg)) error(E_MISMATCHARG); - if (ccdr(ccdr(arg))!=NIL) error(E_MISMATCHARG); - int i=0; - int j=ckintval(ccar(arg)); - pointer val=ccar(ccdr(arg)); - struct catchframe *cfp=ctx->catchfp; - while (cfp) { - if (!(cfp->label)) { - i++; - if (i > j) { - unwind(ctx,(pointer *)cfp); - ctx->callfp = cfp->cf; - ctx->bindfp = cfp->bf; - ctx->fletfp = cfp->ff; - euslongjmp(*(cfp->jbp), eval(ctx,val));}} - cfp=cfp->nextcatch;} - error(E_NOCATCHER); -} - pointer THREAD_SPECIALS(ctx,n,argv) context *ctx; int n; @@ -932,7 +909,6 @@ pointer mod; defun(ctx,"LIST-ALL-CLASSES",mod,LISTALLCLASSES,NULL); defun(ctx,"EXPORT-ALL-SYMBOLS", mod, EXPORTALL,NULL); defun(ctx,"NEXT-SPECIAL-INDEX", mod, NEXT_SPECIAL_INDEX,NULL); - defspecial(ctx,"UNWIND",mod, UNWIND); defun(ctx,"THREAD-SPECIALS", mod, THREAD_SPECIALS,NULL); defun(ctx,"DISPOSE-HOOK", mod, DISPOSE_HOOK,NULL); diff --git a/lisp/comp/builtins.l b/lisp/comp/builtins.l index 85250fdc3..14cffe04a 100644 --- a/lisp/comp/builtins.l +++ b/lisp/comp/builtins.l @@ -373,7 +373,6 @@ (def-builtin-entry 'SYS:LIST-ALL-CLASSES "LISTALLCLASSES") (def-builtin-entry 'SYS::EXPORT-ALL-SYMBOLS "EXPORTALL") (def-builtin-entry 'SYS::NEXT-SPECIAL-INDEX "NEXT_SPECIAL_INDEX") -(def-builtin-entry 'SYS::UNWIND "UNWIND") (def-builtin-entry 'SYS::THREAD-SPECIALS "THREAD_SPECIALS") (def-builtin-entry 'SYS::DISPOSE-HOOK "DISPOSE_HOOK") From 4d275bf9fddc6d2450dec55b7e919bb8adf4330d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 17 Oct 2022 13:18:46 +0900 Subject: [PATCH 322/387] Guard va_list from gc in error() --- lisp/c/eus.c | 20 +++++++++++++++----- lisp/c/lispio.c | 2 +- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 765502a1e..3af2aeff3 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -341,8 +341,8 @@ va_dcl ctx=euscontexts[thr_self()]; - /* get call stack */ - callstack=list_callstack(ctx,-1); + // 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]; @@ -367,8 +367,9 @@ va_dcl case E_NOSLOT: case E_NOPACKAGE: case E_NOMETHOD: case E_NOKEYPARAM: case E_READLABEL: case E_ILLCH: case E_NOCATCHER: case E_EXTSYMBOL: case E_SYMBOLCONFLICT: + vpush(va_arg(args,pointer)); dest=(pointer)mkstream(ctx,K_OUT,makebuffer(64)); - prinx(ctx,va_arg(args,pointer),dest); + prinx(ctx,vpop(),dest); msgstr=(char*)malloc(2+ strlen(errstr) + intval(dest->c.stream.count)); strcpy(msgstr,errstr); strcat(msgstr,(char*)" "); @@ -379,18 +380,27 @@ va_dcl 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));} - /* get form */ - if (ctx->callfp) form=ctx->callfp->form; else form=NIL; + vpush(msg); + va_end(args); /* call user's error handler function */ errhandler=getfunc_closure(ctx, intern(ctx,"SIGNALS",7,lisppkg)); + /* 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: diff --git a/lisp/c/lispio.c b/lisp/c/lispio.c index 8a3b257c1..cb1614c06 100644 --- a/lisp/c/lispio.c +++ b/lisp/c/lispio.c @@ -588,7 +588,7 @@ register pointer *argv; for (; ic.str.chars));} + error(E_REPL,errobj,msg);} void lispio(ctx,mod) From 24b3c37c0663e83df6afb75246a6054b6fea5d6b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 25 Oct 2022 09:14:32 +0900 Subject: [PATCH 323/387] Default rassoc :test to #'equal for backward compability --- doc/jlatex/euslisp.hlp | 196 +++++++++++++++++++------------------- doc/jlatex/jsequences.tex | 2 +- doc/latex/euslisp.hlp | 196 +++++++++++++++++++------------------- doc/latex/sequences.tex | 2 +- lisp/l/common.l | 4 +- 5 files changed, 201 insertions(+), 199 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 75c34972b..54e311195 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -336,104 +336,104 @@ "assoc-if" 2 "jsequences" 16203 3 "assoc-if-not" 2 "jsequences" 16377 3 "rassoc" 2 "jsequences" 16554 3 -"rassoc-if" 2 "jsequences" 16704 3 -"rassoc-if-not" 2 "jsequences" 16836 3 -"pairlis" 2 "jsequences" 16971 3 -"acons" 2 "jsequences" 17223 3 -"append" 2 "jsequences" 17369 3 -"nconc" 2 "jsequences" 17571 3 -"subst" 2 "jsequences" 17743 3 -"flatten" 2 "jsequences" 17853 3 -"push" 3 "jsequences" 18148 3 -"pop" 3 "jsequences" 18263 3 -"pushnew" 3 "jsequences" 18415 3 -"adjoin" 2 "jsequences" 18673 3 -"union" 2 "jsequences" 18804 3 -"subsetp" 2 "jsequences" 18926 3 -"intersection" 2 "jsequences" 19187 3 -"set-difference" 2 "jsequences" 19341 3 -"set-exclusive-or" 2 "jsequences" 19545 3 -"list-insert" 2 "jsequences" 19719 3 -"list-delete" 2 "jsequences" 20033 3 -"copy-tree" 2 "jsequences" 20295 3 -"mapc" 2 "jsequences" 20571 3 -"mapcar" 2 "jsequences" 20830 3 -"mapcan" 2 "jsequences" 21130 3 -"array-rank-limit" 4 "jsequences" 23313 2 -"array-dimension-limit" 4 "jsequences" 23388 2 -"vectorp" 2 "jsequences" 23595 3 -"vector" 2 "jsequences" 23834 3 -"make-array" 2 "jsequences" 23950 3 -"svref" 2 "jsequences" 24296 3 -"aref" 2 "jsequences" 24455 3 -"vector-push" 2 "jsequences" 24929 3 -"vector-push-extend" 2 "jsequences" 25319 3 -"arrayp" 2 "jsequences" 25527 3 -"array-total-size" 2 "jsequences" 25658 3 -"fill-pointer" 2 "jsequences" 25737 3 -"array-rank" 2 "jsequences" 25863 3 -"array-dimensions" 2 "jsequences" 25937 3 -"array-dimension" 2 "jsequences" 26034 3 -"bit" 2 "jsequences" 26181 3 -"bit-and" 2 "jsequences" 26371 2 -"bit-ior" 2 "jsequences" 26421 2 -"bit-xor" 2 "jsequences" 26471 2 -"bit-eqv" 2 "jsequences" 26521 2 -"bit-nand" 2 "jsequences" 26572 2 -"bit-nor" 2 "jsequences" 26622 2 -"bit-not" 2 "jsequences" 26673 3 -"digit-char-p" 2 "jsequences" 27225 3 -"alpha-char-p" 2 "jsequences" 27338 3 -"upper-case-p" 2 "jsequences" 27509 3 -"lower-case-p" 2 "jsequences" 27625 3 -"alphanumericp" 2 "jsequences" 27742 3 -"char-upcase" 2 "jsequences" 27961 3 -"char-downcase" 2 "jsequences" 28032 3 -"char=" 2 "jsequences" 28095 3 -"char/=" 2 "jsequences" 28165 3 -"char>" 2 "jsequences" 28237 3 -"char<" 2 "jsequences" 28310 3 -"char>=" 2 "jsequences" 28384 3 -"char<=" 2 "jsequences" 28459 3 -"char" 2 "jsequences" 28530 3 -"schar" 2 "jsequences" 28618 3 -"setchar" 2 "jsequences" 28821 3 -"stringp" 2 "jsequences" 28925 3 -"string-upcase" 2 "jsequences" 29055 3 -"string-downcase" 2 "jsequences" 29188 3 -"nstring-upcase" 2 "jsequences" 29320 3 -"nstring-downcase" 2 "jsequences" 29429 3 -"string=" 2 "jsequences" 29545 3 -"string-equal" 2 "jsequences" 29736 3 -"string" 2 "jsequences" 29922 3 -"string<" 2 "jsequences" 30560 2 -"string<=" 2 "jsequences" 30671 2 -"string>" 2 "jsequences" 30805 2 -"string>=" 2 "jsequences" 30916 2 -"string-left-trim" 2 "jsequences" 31057 2 -"string-right-trim" 2 "jsequences" 31366 3 -"string-trim" 2 "jsequences" 31669 3 -"substringp" 2 "jsequences" 31858 3 -"make-foreign-string" 2 "jsequences" 34147 3 -"sxhash" 2 "jsequences" 36182 3 -"make-hash-table" 2 "jsequences" 36845 3 -"gethash" 2 "jsequences" 36948 3 -"remhash" 2 "jsequences" 37361 3 -"maphash" 2 "jsequences" 37479 3 -"hash-table-p" 2 "jsequences" 37585 3 -"hash-table" 0 "jsequences" 37693 4 -":hash-function" 1 "jsequences" 38352 3 -"queue" 0 "jsequences" 39003 4 -":init" 1 "jsequences" 39072 3 -":enqueue" 1 "jsequences" 39126 3 -":dequeue" 1 "jsequences" 39214 3 -":empty?" 1 "jsequences" 39472 3 -":length" 1 "jsequences" 39541 3 -":trim" 1 "jsequences" 39598 3 -":search" 1 "jsequences" 39712 3 -":delete" 1 "jsequences" 39851 3 -":first" 1 "jsequences" 40014 3 -":last" 1 "jsequences" 40122 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 diff --git a/doc/jlatex/jsequences.tex b/doc/jlatex/jsequences.tex index 2bb4f0d7b..ee6502641 100644 --- a/doc/jlatex/jsequences.tex +++ b/doc/jlatex/jsequences.tex @@ -401,7 +401,7 @@ \subsection{リスト} {\em alist}の要素の{\bf car}が{\em pred}の条件に{\bf あわない}最初のものを返す。 なければ、NILを返す。} -\funcdesc{rassoc}{item alist \&key key (test \#'eq) test-not}{ +\funcdesc{rassoc}{item alist \&key key (test \#'equal) test-not}{ {\bf cdr}が{\em item}に等しい{\em alist}のなかの最初の組を返す。} \funcdesc{rassoc-if}{pred alist \&key key}{ diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index dabd5e2b5..eab12ceeb 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -336,104 +336,104 @@ "assoc-if" 2 "sequences" 14134 3 "assoc-if-not" 2 "sequences" 14296 3 "rassoc" 2 "sequences" 14461 3 -"rassoc-if" 2 "sequences" 14601 3 -"rassoc-if-not" 2 "sequences" 14721 3 -"pairlis" 2 "sequences" 14844 3 -"acons" 2 "sequences" 15073 3 -"append" 2 "sequences" 15196 3 -"nconc" 2 "sequences" 15334 3 -"subst" 2 "sequences" 15451 3 -"flatten" 2 "sequences" 15545 3 -"push" 3 "sequences" 15814 3 -"pop" 3 "sequences" 15899 3 -"pushnew" 3 "sequences" 16033 3 -"adjoin" 2 "sequences" 16268 3 -"union" 2 "sequences" 16376 3 -"subsetp" 2 "sequences" 16489 3 -"intersection" 2 "sequences" 16688 3 -"set-difference" 2 "sequences" 16843 3 -"set-exclusive-or" 2 "sequences" 17023 3 -"list-insert" 2 "sequences" 17192 3 -"list-delete" 2 "sequences" 17461 3 -"copy-tree" 2 "sequences" 17693 3 -"mapc" 2 "sequences" 17932 3 -"mapcar" 2 "sequences" 18159 3 -"mapcan" 2 "sequences" 18425 3 -"array-rank-limit" 4 "sequences" 20080 2 -"array-dimension-limit" 4 "sequences" 20157 2 -"vectorp" 2 "sequences" 20287 3 -"vector" 2 "sequences" 20483 3 -"make-array" 2 "sequences" 20585 3 -"svref" 2 "sequences" 20903 3 -"aref" 2 "sequences" 21025 3 -"vector-push" 2 "sequences" 21312 3 -"vector-push-extend" 2 "sequences" 21609 3 -"arrayp" 2 "sequences" 21781 3 -"array-total-size" 2 "sequences" 21867 3 -"fill-pointer" 2 "sequences" 21954 3 -"array-rank" 2 "sequences" 22086 3 -"array-dimensions" 2 "sequences" 22157 3 -"array-dimension" 2 "sequences" 22230 3 -"bit" 2 "sequences" 22353 3 -"bit-and" 2 "sequences" 22506 2 -"bit-ior" 2 "sequences" 22556 2 -"bit-xor" 2 "sequences" 22606 2 -"bit-eqv" 2 "sequences" 22656 2 -"bit-nand" 2 "sequences" 22707 2 -"bit-nor" 2 "sequences" 22757 2 -"bit-not" 2 "sequences" 22808 3 -"digit-char-p" 2 "sequences" 23299 3 -"alpha-char-p" 2 "sequences" 23388 3 -"upper-case-p" 2 "sequences" 23520 3 -"lower-case-p" 2 "sequences" 23609 3 -"alphanumericp" 2 "sequences" 23700 3 -"char-upcase" 2 "sequences" 23873 3 -"char-downcase" 2 "sequences" 23944 3 -"char=" 2 "sequences" 24007 3 -"char/=" 2 "sequences" 24079 3 -"char>" 2 "sequences" 24153 3 -"char<" 2 "sequences" 24228 3 -"char>=" 2 "sequences" 24304 3 -"char<=" 2 "sequences" 24381 3 -"char" 2 "sequences" 24454 3 -"schar" 2 "sequences" 24537 3 -"setchar" 2 "sequences" 24713 3 -"stringp" 2 "sequences" 24809 3 -"string-upcase" 2 "sequences" 24918 3 -"string-downcase" 2 "sequences" 25035 3 -"nstring-upcase" 2 "sequences" 25151 3 -"nstring-downcase" 2 "sequences" 25242 3 -"string=" 2 "sequences" 25340 3 -"string-equal" 2 "sequences" 25481 3 -"string" 2 "sequences" 25630 3 -"string<" 2 "sequences" 26131 3 -"string<=" 2 "sequences" 26228 3 -"string>" 2 "sequences" 26336 3 -"string>=" 2 "sequences" 26436 3 -"string-left-trim" 2 "sequences" 26553 2 -"string-right-trim" 2 "sequences" 26827 3 -"string-trim" 2 "sequences" 27096 3 -"substringp" 2 "sequences" 27294 3 -"make-foreign-string" 2 "sequences" 28329 3 -"sxhash" 2 "sequences" 29939 3 -"make-hash-table" 2 "sequences" 30463 3 -"gethash" 2 "sequences" 30571 3 -"remhash" 2 "sequences" 30922 3 -"maphash" 2 "sequences" 31014 3 -"hash-table-p" 2 "sequences" 31111 3 -"hash-table" 0 "sequences" 31189 4 -":hash-function" 1 "sequences" 31700 3 -"queue" 0 "sequences" 32339 4 -":init" 1 "sequences" 32408 3 -":enqueue" 1 "sequences" 32478 3 -":dequeue" 1 "sequences" 32558 3 -":empty?" 1 "sequences" 32772 3 -":length" 1 "sequences" 32831 3 -":trim" 1 "sequences" 32888 3 -":search" 1 "sequences" 32972 3 -":delete" 1 "sequences" 33129 3 -":first" 1 "sequences" 33246 3 -":last" 1 "sequences" 33324 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 diff --git a/doc/latex/sequences.tex b/doc/latex/sequences.tex index 17ca9bef6..2fc552686 100644 --- a/doc/latex/sequences.tex +++ b/doc/latex/sequences.tex @@ -404,7 +404,7 @@ \subsection{Lists} 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 \#'eq) test-not}{ +\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}{ diff --git a/lisp/l/common.l b/lisp/l/common.l index 00bb7cf08..b23de2ed6 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -501,7 +501,9 @@ if pos is bigger than the length of list, item is nconc'ed at the tail" (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 test-not) +(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)) From a3295df37054532b624ca89fcf7e2e1f0ff62466 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 26 Oct 2022 19:27:50 +0900 Subject: [PATCH 324/387] Add va_end and fix vsp in basicclass --- lisp/c/eus.c | 7 ++++++- lisp/c/eval.c | 2 ++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 3af2aeff3..54c5ee08b 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -463,6 +463,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 @@ -473,6 +477,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); @@ -502,7 +507,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);} diff --git a/lisp/c/eval.c b/lisp/c/eval.c index f28135c29..ffab7dc52 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -1758,6 +1758,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);} @@ -1781,6 +1782,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); From 7fbf581f1d10d8a138d2fe44d04c9a915341f654 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 28 Oct 2022 12:38:24 +0900 Subject: [PATCH 325/387] Memory safety in make functions and putprop --- lisp/c/makes.c | 66 +++++++++++++++++++++++------------------------ lisp/c/specials.c | 2 ++ 2 files changed, 35 insertions(+), 33 deletions(-) diff --git a/lisp/c/makes.c b/lisp/c/makes.c index 67c9c226f..194dc1aea 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -207,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; @@ -236,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);} @@ -257,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);} @@ -274,10 +276,9 @@ 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(ctx,mod,f,ftype,name) @@ -383,19 +384,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); @@ -404,7 +407,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) @@ -494,7 +496,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 @@ -524,17 +526,15 @@ pointer (*f)(); 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) diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 6306fbab3..89e099c9d 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -1281,8 +1281,10 @@ 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)*/ From 6a8b6fbfde66ad133e7ec97532e78c678eb86f4f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 28 Oct 2022 12:42:44 +0900 Subject: [PATCH 326/387] Memory safety in more make functions --- lisp/c/eus.c | 5 +++-- lisp/c/eus_proto.h | 4 ++-- lisp/c/eval.c | 2 +- lisp/c/makes.c | 55 ++++++++++++++++++++++++++++++---------------- lisp/c/reader.c | 2 +- 5 files changed, 43 insertions(+), 25 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 54c5ee08b..9a3ef4471 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -184,7 +184,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, K_ISATTY; +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; @@ -693,6 +693,7 @@ static void initsymbols() 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"); @@ -896,7 +897,7 @@ static void initclasses() C_IOERROR=speval(basicclass("IO-ERROR",C_ERROR,&ioerrorcp,0)); for (i=0;ibindfp); + bf = makebindframe(ctx,var,val,ctx->bindfp); vpush(bf); ctx->bindfp=bf; /*update bindfp*/ return(bf); } diff --git a/lisp/c/makes.c b/lisp/c/makes.c index 194dc1aea..bbcf51754 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -16,7 +16,7 @@ static char *rcsid="@(#)$Id$"; #define nextbuddy(p) ((bpointer)((eusinteger_t)p+(buddysize[p->h.bix]*sizeof(pointer)))) #endif -extern pointer LAMCLOSURE, MACRO, K_FUNCTION_DOCUMENTATION; +extern pointer LAMCLOSURE, MACRO, K_NAME, K_FUNCTION_DOCUMENTATION; extern pointer C_BINDFRAME, C_FLETFRAME; /****************************************************************/ @@ -288,6 +288,7 @@ 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; @@ -297,7 +298,8 @@ pointer (*f)(); #if ARM cd->c.code.entry2=makeint(((eusinteger_t)f)&0x3); #endif - if (name!=NULL) putprop(ctx,cd,name,defkeyword(ctx,"NAME")); + if (name!=NULL) putprop(ctx,cd,name,K_NAME); + ctx->vsp-=3; return(cd);} @@ -508,6 +510,10 @@ int size; mod->c.ldmod.handle=NIL; return(mod);} +// 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)(); @@ -537,33 +543,36 @@ register context *ctx; rdtable->c.rdtab.plist=NIL; 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(sym,val,nxt) +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.obj.iv[0]=sym; - bf->c.obj.iv[1]=val; - bf->c.obj.iv[2]=nxt; + bf->c.obj.iv[2]=vpop(); // nxt + bf->c.obj.iv[1]=vpop(); // val + bf->c.obj.iv[0]=vpop(); // sym return(bf);} pointer makeflet(ctx,nm,def,scp,nxt) register context *ctx; pointer nm,def,scp,nxt; { pointer p,ff; - ff=makeobject(C_FLETFRAME); - vpush(ff); + vpush(nm); vpush(def); vpush(scp); vpush(nxt); // fletframe scope if (scp==NULL) p=cons(ctx,makeint(0),def); @@ -576,20 +585,28 @@ pointer nm,def,scp,nxt; p=cons(ctx,ctx->bindfp,p); p=cons(ctx,nm,p); // name p=cons(ctx,LAMCLOSURE,p); - ff->c.obj.iv[0]=nm; - ff->c.obj.iv[1]=p; - ff->c.obj.iv[2]=nxt; + vpush(p); + ff=makeobject(C_FLETFRAME); + ff->c.obj.iv[1]=vpop(); // p + ff->c.obj.iv[2]=vpop(); // nxt + vpop(); // scp + vpop(); // def + ff->c.obj.iv[0]=vpop(); // nm + vpush(ff); ctx->fletfp=ff; return(ff);} pointer makemacrolet(ctx,nm,def,nxt) register context *ctx; pointer nm,def,nxt; -{ pointer ff; +{ pointer p,ff; + vpush(nm); vpush(nxt); + p=cons(ctx,MACRO,def); + vpush(p); ff=makeobject(C_FLETFRAME); - ff->c.obj.iv[0]=nm; - ff->c.obj.iv[1]=cons(ctx,MACRO,def); - ff->c.obj.iv[2]=nxt; + ff->c.obj.iv[1]=vpop(); // p + ff->c.obj.iv[2]=vpop(); // nxt + ff->c.obj.iv[0]=vpop(); // nm vpush(ff); ctx->fletfp=ff; return(ff);} diff --git a/lisp/c/reader.c b/lisp/c/reader.c index 58b7c3834..ebd9d2a77 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -244,7 +244,7 @@ eusinteger_t labx; 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); From 93971c6fb122cdb7016634ae7678fed918a57408 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 27 Oct 2022 21:09:23 +0900 Subject: [PATCH 327/387] Add getfunc_closure_noexcept to avoid nested loops in error() --- lisp/c/eus.c | 4 ++-- lisp/c/eus_proto.h | 1 + lisp/c/eval.c | 31 +++++++++++++++++++++++-------- 3 files changed, 26 insertions(+), 10 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 9a3ef4471..5e96d7337 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -393,7 +393,7 @@ va_dcl va_end(args); /* call user's error handler function */ - errhandler=getfunc_closure(ctx, intern(ctx,"SIGNALS",7,lisppkg)); + errhandler=getfunc_closure_noexcept(ctx, intern(ctx,"SIGNALS",7,lisppkg)); /* get call stack */ callstack=list_callstack(ctx,-1); @@ -443,7 +443,7 @@ va_dcl pointer_update(errobj->c.obj.iv[2],form); Spevalof(QEVALHOOK)=NIL; /* reset eval hook */ - if (errhandler!=NIL) { + if (errhandler!=NIL && errhandler!=UNBOUND) { vpush(errobj); ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-1),ctx->bindfp,1);} } diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index c26ad5c88..105d38f93 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -173,6 +173,7 @@ 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 getfunc_closure(context */*ctx*/, pointer /*f*/); +extern pointer getfunc_closure_noexcept(context */*ctx*/, pointer /*f*/); extern pointer get_sym_func(pointer /*s*/); extern void setfunc(pointer /*sym*/, pointer /*func*/); extern pointer *ovafptr(pointer /*o*/, pointer /*v*/); diff --git a/lisp/c/eval.c b/lisp/c/eval.c index b3abeeb04..8898bc546 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -97,26 +97,26 @@ register pointer sym,val; } -pointer getfunc(ctx,f) +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.obj.iv[0]==f) { return(ffp->c.obj.iv[1]);} else ffp=ffp->c.obj.iv[2];} - if (f->c.sym.spefunc==UNBOUND) error(E_UNDEF,f); - else { /*global function definition is taken, context changes*/ - return(f->c.sym.spefunc);}} + return(f->c.sym.spefunc);} -pointer getfunc_closure(ctx,f) +pointer getfunc_closure_noexcept(ctx,f) register context *ctx; register pointer f; { pointer funcname; - if (issymbol(f)) { funcname=f; f=getfunc(ctx,f);} + 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 @@ -129,9 +129,24 @@ register pointer f; f=cons(ctx,makeint(0),f); else f=cons(ctx,ctx->bindfp,f); - f=cons(ctx,funcname,f); + f=cons(ctx,vpop(),f); // funcname return(cons(ctx,LAMCLOSURE,f));} - else error(E_NOFUNCTION);} + else return(NIL);} + +pointer getfunc(ctx,f) +register context *ctx; +register pointer f; /*must be a symbol*/ +{ pointer fn=getfunc_noexcept(ctx,f); + if (fn==UNBOUND) error(E_UNDEF, f); + return(fn);} + +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) From 70d12013c5377a96f81f90102f599a6ea9a7026a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 28 Oct 2022 13:01:46 +0900 Subject: [PATCH 328/387] Prefer dot accessor in comp.l --- lisp/comp/comp.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index b9f664b27..3d26c7db5 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -351,7 +351,7 @@ (setq fdef (symbol-function fn)) (if (compiled-function-p fdef) (instance function-identifier :init-body - fn (cdr (assq (compiled-code-type fdef) + fn (cdr (assq (fdef . type) '((0 . lambda) (1 . macro) (2 . special)))) fdef) (instance function-identifier :init-body From 298915d9756cfcb6dc34c37c8e1d4342919b71bf Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 28 Oct 2022 22:24:35 +0900 Subject: [PATCH 329/387] Update past closure references in flet compilation --- lisp/comp/comp.l | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 3d26c7db5..f31960d19 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1293,6 +1293,7 @@ (setq flets (append flets-tmp flets)) (if recursive-scope (send-all newcomps :change-flets flets)) (send self :progn bodies) + (if (not recursive-scope) (send newcomp :change-flets flets)) ;; unwind/restore (setq flets (nthcdr (length flets-tmp) flets)) (send self :delete-frame 'flet nil) From 219c8e5b154fce9baf351179cc4cd03d2bd47f76 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 29 Oct 2022 13:19:55 +0900 Subject: [PATCH 330/387] Avoid setting closure-frames and closure-function-frames globally --- lisp/comp/comp.l | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index f31960d19..687fa6a2d 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -329,7 +329,8 @@ (let ((fdef (find-if #'(lambda (x) (eql (x . name) fn)) flets))) (if fdef (progn - (when (and avant-mode (fdef . level) + (when (and avant-mode closure-function-frames + (fdef . level) (> closure-level (fdef . level))) (unless (listp closure-function-frames) (setq closure-function-frames nil)) @@ -550,7 +551,7 @@ (setq var (send self :variable var))) (flet ((push-cframe (&optional (pushvar var)) ;; collect referenced variables during pre-evaluation mode - (when (and avant-mode (> closure-level (var . level))) + (when (and avant-mode closure-frames (> closure-level (var . level))) (unless (listp closure-frames) (setq closure-frames nil)) (pushnew pushvar closure-frames) (unless (pushvar . bindframe) (setq (pushvar . bindframe) t)))) From 9e8a55bc92b11d00147131bd133c051703339757 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 29 Oct 2022 13:20:28 +0900 Subject: [PATCH 331/387] Add more compile-time checks and comments --- lisp/comp/comp.l | 15 ++++++++++++++- lisp/comp/trans.l | 23 ++++++++++++++++------- 2 files changed, 30 insertions(+), 8 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 687fa6a2d..ae30cf3f3 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -49,7 +49,12 @@ (defvar comp nil "$Id$") (defvar trans) (defvar *multipass-optimize* t) -;; define as a variable so we can `(let ((closure-frames ...)))' it + +;; `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) @@ -332,6 +337,8 @@ (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) @@ -552,6 +559,8 @@ (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)))) @@ -1646,6 +1655,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) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index d431a34ee..19e834bc0 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -34,9 +34,21 @@ (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) -(defparameter avant-mode 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))) @@ -44,12 +56,9 @@ (prog1 (setf (get sym :ftab-index) ftab-next) (push sym external-functions) (incf ftab-next)) - index))) - -(defun maybe-format (fstream format-string &rest args) - ;; suppress all output in pre-evaluation mode - (unless avant-mode - (apply #'format fstream format-string args))) + (prog1 index + (unless (< index ftab-next) + (error value-error "invalid ftab-index found in ~S: ~A~%" sym index)))))) (defmethod translator (:label (l) From 93f5da1a58d86ce25282690fe237a5f28270a4d7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 31 Oct 2022 10:55:51 +0900 Subject: [PATCH 332/387] Always stash maximum vsp value before makeclosure --- lisp/comp/trans.l | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 19e834bc0..b38e49619 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -679,9 +679,12 @@ (inc pushcount)) (:closure (lab env0 env1) (if env1 - (send self :store "w") ; store to w before increasing the pushcount - (send self :clearpush)) ; clear other pending values - (send self :reset-vsp) + (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,~A,~A)" lab (if env0 "env" "NIL") (if env1 "w" "NIL")))) From 8859e7fe48566a61e7254a78785ea5e1eb980437 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 31 Oct 2022 10:56:29 +0900 Subject: [PATCH 333/387] Reset flet cbindframe after progn --- lisp/comp/comp.l | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index ae30cf3f3..7312edc38 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -1295,9 +1295,7 @@ ;; reset cbindframes to force re-evaluation ;; this is needed to ensure that each closure has an ;; unique and compatible mapping - (dolist (fdef flets-tmp) - (when (fdef . cbindframe) - (setq (fdef . cbindframe) t))) + (send self :reset-flets-cbindframe flets-tmp) ;; evaluate body (setq flets (append flets-tmp flets)) @@ -1305,6 +1303,7 @@ (send self :progn bodies) (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)))) @@ -1316,6 +1315,10 @@ (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) ;; bind statements and return type declared variables (let (v acc) From bbc2238a1f59c9ad98dcb790f1c3a559b16a6beb Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 31 Oct 2022 12:37:35 +0900 Subject: [PATCH 334/387] More builtin declarations --- lisp/c/eus_proto.h | 1 + lisp/comp/builtins.l | 33 ++++++++++++++++++++++++++++++++- lisp/comp/trans.l | 2 ++ lisp/l/common.l | 6 ++++-- lisp/l/constants.l | 20 +++++++++----------- lisp/l/eusstart.l | 5 ++--- lisp/l/process.l | 2 +- 7 files changed, 51 insertions(+), 18 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 105d38f93..89ccaa5b0 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*/*); diff --git a/lisp/comp/builtins.l b/lisp/comp/builtins.l index 14cffe04a..39cb2422f 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,6 +114,7 @@ (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") @@ -111,6 +127,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 +138,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") @@ -200,9 +220,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") @@ -222,6 +251,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") diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index b38e49619..36886a3b4 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -284,6 +284,8 @@ (let ((entry)) (setq entry (get sym 'user-function-entry)) (if (null entry) (setq entry (get sym 'builtin-function-entry))) + (if (and (null entry) (get sym 'function-alias)) + (setq entry (get (get sym 'function-alias) 'builtin-function-entry))) (send self :clearpush) (send self :reset-vsp) (if (and (not (functionp sym)) (not avant-mode)) diff --git a/lisp/l/common.l b/lisp/l/common.l index b23de2ed6..422f22c31 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -363,8 +363,10 @@ ; 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) ) diff --git a/lisp/l/constants.l b/lisp/l/constants.l index ffd5e10a3..08fbdb04e 100644 --- a/lisp/l/constants.l +++ b/lisp/l/constants.l @@ -339,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/eusstart.l b/lisp/l/eusstart.l index 7dcdbc2b7..da5db1079 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -323,8 +323,7 @@ (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.~%") ;; @@ -349,7 +348,7 @@ ) (export '(compile 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/process.l b/lisp/l/process.l index 4f485e0a7..8d9a4212d 100644 --- a/lisp/l/process.l +++ b/lisp/l/process.l @@ -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)) From 48e8c5f838fed50a22cd13f39b9cfdc2a1841902 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 31 Oct 2022 12:43:51 +0900 Subject: [PATCH 335/387] Add more system builtin declarations --- lisp/comp/builtins.l | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/comp/builtins.l b/lisp/comp/builtins.l index 39cb2422f..abb41c4e4 100644 --- a/lisp/comp/builtins.l +++ b/lisp/comp/builtins.l @@ -119,6 +119,7 @@ (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") @@ -397,6 +398,9 @@ ;(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") From 04404e4aa245bfe56920bcadc91e3ba1dcbdd958 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 31 Oct 2022 14:22:50 +0900 Subject: [PATCH 336/387] Check bindframe index of previous levels at compile-time --- lisp/comp/comp.l | 40 +++++++++++++++++++++++----------------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 7312edc38..9f604c9d8 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -346,14 +346,17 @@ (setq (fdef . bindframe) t))) ;; compile-time check to see if we are not missing any frame references - (when (and (not avant-mode) (= (- closure-level (fdef . level)) 1) + (when (and (not avant-mode) (> closure-level (fdef . level)) (fdef . bindframe)) - (unless (find (fdef . bindframe) current-fframes) - (send self :error "unbound fletframe detected when loading function ~S: ~A" - (fdef . name) (fdef . bindframe))) - (unless (< (send self :flet-bindframe fdef) current-csize) - (send self :error "invalid fletframe index detected when loading function ~S: ~A" - (fdef . name) (fdef . cbindframe)))) + (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)) @@ -566,14 +569,17 @@ (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)) 1) + (when (and (not avant-mode) (> closure-level (var . level)) (numberp (pushvar . bindframe))) - (unless (find (pushvar . bindframe) current-cframes) - (send self :error ";; unbound bindframe detected when loading variable ~S: ~A" - (var . name) (pushvar . bindframe))) - (unless (< (send self :var-bindframe pushvar) current-csize) - (send self :error ";; invalid bindframe index detected when loading variable ~S: ~A" - (var . name) (send self :var-bindframe pushvar)))))) + (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 @@ -1724,9 +1730,9 @@ (cframes (fourth aclosure)) (fframes (fifth aclosure)) (cbind (append cframes fframes))) - (setq (newcomp . current-cframes) cframes) - (setq (newcomp . current-fframes) fframes) - (setq (newcomp . current-csize) (length cbind)) + (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)) From c281f3f4f7e712c19f3ae9babe1f4424b231de13 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 4 Nov 2022 14:49:58 +0900 Subject: [PATCH 337/387] Update gc-hook to gc-debug in test comments --- test/bignum.l | 3 +-- test/coords.l | 2 +- test/object.l | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) 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/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/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) From f943d3903d04847ffb8bb1ec0fb118edbe3cacbc Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 4 Nov 2022 17:51:50 +0900 Subject: [PATCH 338/387] Skip checking functions with no level (e.g. macrolets) at compilation --- lisp/comp/comp.l | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 9f604c9d8..41fdd4fa2 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -346,7 +346,9 @@ (setq (fdef . bindframe) t))) ;; compile-time check to see if we are not missing any frame references - (when (and (not avant-mode) (> closure-level (fdef . level)) + (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))) From f3d1b7d606f9d116f8c29ef77246800655cd95e6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 4 Nov 2022 17:52:07 +0900 Subject: [PATCH 339/387] Skip cloning zero-length objects --- lisp/c/leo.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/c/leo.c b/lisp/c/leo.c index e424a79ba..b67869544 100644 --- a/lisp/c/leo.c +++ b/lisp/c/leo.c @@ -597,11 +597,11 @@ register pointer org; for (i=2; 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 From ae3fb032dc7c7ffc049ffaa8514d185e94a746a7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 9 Nov 2022 12:34:12 +0900 Subject: [PATCH 340/387] Check arguments in sys:wait-thread --- lisp/c/eus.h | 2 ++ lisp/c/mthread.c | 3 ++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 00067fffb..472e06cf9 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -862,6 +862,8 @@ extern eusinteger_t intval(pointer p); #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 */ diff --git a/lisp/c/mthread.c b/lisp/c/mthread.c index 00f231da2..2ff2feffa 100644 --- a/lisp/c/mthread.c +++ b/lisp/c/mthread.c @@ -197,7 +197,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)) { From cd85579b91c264aebb7aebc20d7174f48264a9ce Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 9 Nov 2022 15:48:06 +0900 Subject: [PATCH 341/387] Add missing run-sem slot in thread object --- lisp/c/eus.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 5e96d7337..0e24bdebc 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -799,7 +799,7 @@ 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); From 772df06f547f23ece149dfd72456f0e016591112 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 9 Nov 2022 16:07:13 +0900 Subject: [PATCH 342/387] Add mismatch argument checks in thread functions --- lisp/c/mthread.c | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/lisp/c/mthread.c b/lisp/c/mthread.c index 2ff2feffa..dfd7e7ad7 100644 --- a/lisp/c/mthread.c +++ b/lisp/c/mthread.c @@ -154,6 +154,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]; @@ -177,6 +178,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]; @@ -227,6 +229,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); @@ -335,7 +338,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);} @@ -343,7 +347,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);} @@ -351,7 +356,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);} @@ -447,9 +453,11 @@ 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; From b42c68f0e62abd4622184cab5eef88fcd798ca38 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Nov 2022 12:31:46 +0900 Subject: [PATCH 343/387] Fix warning typos --- lisp/c/mthread.c | 6 +++--- lisp/c/pthreads.c | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/c/mthread.c b/lisp/c/mthread.c index dfd7e7ad7..6f1e692ee 100644 --- a/lisp/c/mthread.c +++ b/lisp/c/mthread.c @@ -403,7 +403,7 @@ pointer argv[]; { int stat; 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])); @@ -418,7 +418,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(); @@ -462,7 +462,7 @@ pointer argv[]; 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; 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)); From 576dab0a6116fa678bd02f57bbc6ea02419a1cf7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Nov 2022 13:37:50 +0900 Subject: [PATCH 344/387] Add more help files --- doc/help.eus/makehelp.l | 5 ++ doc/jlatex/euslisp.hlp | 135 +++++++++++++++++++++++++++++++++++++++ doc/latex/euslisp.hlp | 136 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 276 insertions(+) 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 54e311195..dd6f6f1df 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -1274,6 +1274,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" 16907 2 +"sys::free-threads" 2 "jmthread" 17032 3 +"sys:thread" 2 "jmthread" 17420 3 +"sys:thread-no-wait" 2 "jmthread" 18262 3 +"sys:wait-thread" 2 "jmthread" 18502 3 +"sys:plist" 3 "jmthread" 18947 3 +"sys:make-mutex-lock" 2 "jmthread" 19776 3 +"sys:mutex-lock" 2 "jmthread" 19923 3 +"sys:mutex-unlock" 2 "jmthread" 20153 3 +"sys:mutex" 3 "jmthread" 20311 3 +"sys:make-cond" 2 "jmthread" 21112 3 +"sys:cond-wait" 2 "jmthread" 21331 3 +"sys:cond-signal" 2 "jmthread" 21606 3 +"sys:make-semaphore" 2 "jmthread" 21716 3 +"sys:sema-post" 2 "jmthread" 21854 3 +"sys:sema-wait" 2 "jmthread" 21918 3 +"sys:barrier-synch" 0 "jmthread" 21999 4 +":init" 1 "jmthread" 23019 3 +":add" 1 "jmthread" 23168 3 +":remove" 1 "jmthread" 23271 3 +":wait" 1 "jmthread" 23372 3 +"sys:synch-memory-port" 0 "jmthread" 23514 4 +":read" 1 "jmthread" 23831 3 +":write" 1 "jmthread" 24021 3 +":init" 1 "jmthread" 24332 3 "make-equilevel-lut" 2 "jimage" 654 3 "look-up" 2 "jimage" 984 3 "look-up2" 2 "jimage" 1395 3 diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index eab12ceeb..d5db040cd 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -1276,6 +1276,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" 12877 2 +"sys::free-threads" 2 "mthread" 12976 3 +"sys:thread" 2 "mthread" 13253 3 +"sys:thread-no-wait" 2 "mthread" 14005 3 +"sys:wait-thread" 2 "mthread" 14209 3 +"sys:plist" 3 "mthread" 14573 3 +"sys:make-mutex-lock" 2 "mthread" 15279 3 +"sys:mutex-lock" 2 "mthread" 15411 3 +"sys:mutex-unlock" 2 "mthread" 15591 3 +"sys:mutex" 3 "mthread" 15711 3 +"sys:make-cond" 2 "mthread" 16341 3 +"sys:cond-wait" 2 "mthread" 16504 3 +"sys:cond-signal" 2 "mthread" 16719 3 +"sys:make-semaphore" 2 "mthread" 16807 3 +"sys:sema-post" 2 "mthread" 16924 3 +"sys:sema-wait" 2 "mthread" 16976 3 +"sys:barrier-synch" 0 "mthread" 17062 4 +":init" 1 "mthread" 17899 3 +":add" 1 "mthread" 18016 3 +":remove" 1 "mthread" 18098 3 +":wait" 1 "mthread" 18181 3 +"sys:synch-memory-port" 0 "mthread" 18290 4 +":read" 1 "mthread" 18543 3 +":write" 1 "mthread" 18666 3 +":init" 1 "mthread" 18892 3 "make-equilevel-lut" 2 "image" 509 3 "look-up" 2 "image" 782 3 "look-up2" 2 "image" 1079 3 From f1148dafbe586eb6a1856b90d8263cbcc8682070 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Nov 2022 22:57:33 +0900 Subject: [PATCH 345/387] Add fillchunk function to fill up heap until GCMARGIN --- lisp/c/memory.c | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/lisp/c/memory.c b/lisp/c/memory.c index e52dfd4ab..2f482340e 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -157,6 +157,19 @@ register int k; return(k); } +int fillchunk(k) +register int k; +{ numunion nu; + float gcm; + int j; + gcm=min(5.0,fltval(speval(GCMARGIN))); + while (freeheap<(totalheap*gcm)) { + j=newchunk(k); + if (j==ERR) return(j); + } + return(j); +} + void splitheap(k,buddy) /*heart of the allocator*/ register int k; register struct buddyfree *buddy; @@ -217,7 +230,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 +242,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); @@ -289,13 +303,12 @@ register int req; /*index to buddy: must be greater than 0*/ freeheap, totalheap, fltval(speval(GCMARGIN))); */ gc(); collected=1; 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) { From 7c5c0813c4ff46922b0c78f834d4874a2de25a66 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Nov 2022 23:00:04 +0900 Subject: [PATCH 346/387] Fix gcmargin min value: gcmargin can never be greater than one! --- lisp/c/memory.c | 2 +- lisp/c/memory.mutex.c | 6 +++--- lisp/c/memory.safe.c | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/c/memory.c b/lisp/c/memory.c index 2f482340e..263e63ef7 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -162,7 +162,7 @@ register int k; { numunion nu; float gcm; int j; - gcm=min(5.0,fltval(speval(GCMARGIN))); + gcm=min(0.9,fltval(speval(GCMARGIN))); while (freeheap<(totalheap*gcm)) { j=newchunk(k); if (j==ERR) return(j); diff --git a/lisp/c/memory.mutex.c b/lisp/c/memory.mutex.c index 57bd3bf88..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) { diff --git a/lisp/c/memory.safe.c b/lisp/c/memory.safe.c index 04f362f33..98df08d04 100644 --- a/lisp/c/memory.safe.c +++ b/lisp/c/memory.safe.c @@ -92,7 +92,7 @@ int cid; /*class id*/ if (k>=MAXBUDDY) { /*no enough room*/ if (bbreq->size=MAXBUDDY) { From 4c2325c0dd813a64a1ef81f393351d7bb33075d3 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Nov 2022 23:39:05 +0900 Subject: [PATCH 347/387] Expand heap when trying consecutive gc (jsk-ros-pkg/jsk_roseus#728) --- lisp/c/memory.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lisp/c/memory.c b/lisp/c/memory.c index 263e63ef7..fbb96717d 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]; @@ -167,6 +172,7 @@ register int k; j=newchunk(k); if (j==ERR) return(j); } + gc_consecutive_count=0; return(j); } @@ -302,6 +308,12 @@ 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;} j=fillchunk(DEFAULTCHUNKINDEX); if (j==ERR) { @@ -786,6 +798,7 @@ void gc() { if (debug) fprintf(stderr,"\n;; gc:"); // breakck; gccount++; + gc_consecutive_count++; markall(); sweepall(); if (debug) { @@ -809,6 +822,7 @@ void gc() } // breakck; gccount++; + gc_consecutive_count++; times(&tbuf1); #if THREADED From 3e5eb077ebd0fe1acc19cc92954f1f198698848a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 10 Nov 2022 23:56:05 +0900 Subject: [PATCH 348/387] Use default value of 1 in sys::make-thread --- doc/jlatex/euslisp.hlp | 50 ++++++++++++++++++++--------------------- doc/jlatex/jmthread.tex | 2 +- doc/latex/euslisp.hlp | 50 ++++++++++++++++++++--------------------- doc/latex/mthread.tex | 2 +- lisp/c/mthread.c | 5 +++-- 5 files changed, 55 insertions(+), 54 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index dd6f6f1df..9469c6da6 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -1384,31 +1384,31 @@ ":buttonrelease" 1 "jxtoolkit" 43583 3 ":resize" 1 "jxtoolkit" 43844 3 "sys:make-thread" 2 "jmthread" 16176 3 -"sys:*threads*" 5 "jmthread" 16907 2 -"sys::free-threads" 2 "jmthread" 17032 3 -"sys:thread" 2 "jmthread" 17420 3 -"sys:thread-no-wait" 2 "jmthread" 18262 3 -"sys:wait-thread" 2 "jmthread" 18502 3 -"sys:plist" 3 "jmthread" 18947 3 -"sys:make-mutex-lock" 2 "jmthread" 19776 3 -"sys:mutex-lock" 2 "jmthread" 19923 3 -"sys:mutex-unlock" 2 "jmthread" 20153 3 -"sys:mutex" 3 "jmthread" 20311 3 -"sys:make-cond" 2 "jmthread" 21112 3 -"sys:cond-wait" 2 "jmthread" 21331 3 -"sys:cond-signal" 2 "jmthread" 21606 3 -"sys:make-semaphore" 2 "jmthread" 21716 3 -"sys:sema-post" 2 "jmthread" 21854 3 -"sys:sema-wait" 2 "jmthread" 21918 3 -"sys:barrier-synch" 0 "jmthread" 21999 4 -":init" 1 "jmthread" 23019 3 -":add" 1 "jmthread" 23168 3 -":remove" 1 "jmthread" 23271 3 -":wait" 1 "jmthread" 23372 3 -"sys:synch-memory-port" 0 "jmthread" 23514 4 -":read" 1 "jmthread" 23831 3 -":write" 1 "jmthread" 24021 3 -":init" 1 "jmthread" 24332 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/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/latex/euslisp.hlp b/doc/latex/euslisp.hlp index d5db040cd..1a1c92217 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -1387,31 +1387,31 @@ ":buttonrelease" 1 "xtoolkit" 38413 3 ":resize" 1 "xtoolkit" 38612 3 "sys:make-thread" 2 "mthread" 12293 3 -"sys:*threads*" 5 "mthread" 12877 2 -"sys::free-threads" 2 "mthread" 12976 3 -"sys:thread" 2 "mthread" 13253 3 -"sys:thread-no-wait" 2 "mthread" 14005 3 -"sys:wait-thread" 2 "mthread" 14209 3 -"sys:plist" 3 "mthread" 14573 3 -"sys:make-mutex-lock" 2 "mthread" 15279 3 -"sys:mutex-lock" 2 "mthread" 15411 3 -"sys:mutex-unlock" 2 "mthread" 15591 3 -"sys:mutex" 3 "mthread" 15711 3 -"sys:make-cond" 2 "mthread" 16341 3 -"sys:cond-wait" 2 "mthread" 16504 3 -"sys:cond-signal" 2 "mthread" 16719 3 -"sys:make-semaphore" 2 "mthread" 16807 3 -"sys:sema-post" 2 "mthread" 16924 3 -"sys:sema-wait" 2 "mthread" 16976 3 -"sys:barrier-synch" 0 "mthread" 17062 4 -":init" 1 "mthread" 17899 3 -":add" 1 "mthread" 18016 3 -":remove" 1 "mthread" 18098 3 -":wait" 1 "mthread" 18181 3 -"sys:synch-memory-port" 0 "mthread" 18290 4 -":read" 1 "mthread" 18543 3 -":write" 1 "mthread" 18666 3 -":init" 1 "mthread" 18892 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/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/lisp/c/mthread.c b/lisp/c/mthread.c index 6f1e692ee..4d33bae6c 100644 --- a/lisp/c/mthread.c +++ b/lisp/c/mthread.c @@ -112,8 +112,9 @@ pointer argv[]; int i,count; unsigned int tid; - ckarg2(1,3); - count=ckintval(argv[0]); + ckarg2(0,3); + if (n>=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]); From eb89cc1d92faf6c6617a389bb4f28996a2c7a254 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Nov 2022 11:17:00 +0900 Subject: [PATCH 349/387] Delete the new context when thread creation fails, not the current one --- lisp/c/mthread.c | 23 ++++++++++++++--------- lisp/c/mthread_alpha.c | 6 +++--- lisp/c/mthread_posix.c | 6 +++--- 3 files changed, 20 insertions(+), 15 deletions(-) diff --git a/lisp/c/mthread.c b/lisp/c/mthread.c index 4d33bae6c..91f92ca6b 100644 --- a/lisp/c/mthread.c +++ b/lisp/c/mthread.c @@ -131,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_PROGRAM_ERROR,(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_PROGRAM_ERROR,(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 @@ -471,7 +474,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); 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 ); } From 3598849a73b21eab380362397fa67f36da810f8e Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Nov 2022 11:36:50 +0900 Subject: [PATCH 350/387] Check thread id arguments in unix thread functions --- lisp/c/mthread.c | 18 +++++++++++++----- lisp/c/sysfunc.c | 2 +- 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/lisp/c/mthread.c b/lisp/c/mthread.c index 91f92ca6b..6b7a13990 100644 --- a/lisp/c/mthread.c +++ b/lisp/c/mthread.c @@ -384,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);} @@ -394,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));} @@ -404,7 +409,7 @@ 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 supported!\n"); @@ -491,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);} @@ -505,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));} @@ -523,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/sysfunc.c b/lisp/c/sysfunc.c index 82928fd06..720634486 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -860,7 +860,7 @@ pointer argv[]; if (n==0) con=ctx; else { x=ckintval(argv[0]); - if (x<0 || x>MAXTHREAD) error(E_INDEX_ERROR,(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; From a705bd10a9e03175465e4aa7405613f788da04f0 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 11 Nov 2022 12:04:55 +0900 Subject: [PATCH 351/387] Exit threads on error by default --- lisp/c/sysfunc.c | 1 + lisp/l/conditions.l | 2 ++ 2 files changed, 3 insertions(+) diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index 720634486..9eee7efc0 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -693,6 +693,7 @@ 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) { diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 1658b23e4..5a813bf08 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -217,6 +217,8 @@ (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)))) From 26e5829e468e9d25d8120406d1283247aff865ea Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 12 Nov 2022 14:41:26 +0900 Subject: [PATCH 352/387] Revert "Allow returns and tagbody on dolist, dotimes, do-symbols and do-external-symbols (#241)" This reverts commit b9f3b4b015e117385c07a0c3dc1d5e344697811a. --- lisp/l/common.l | 130 ++++++++++++++++++++---------------------------- 1 file changed, 54 insertions(+), 76 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index 422f22c31..a2fb88f8e 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -149,89 +149,67 @@ (send ',sym :constant ,val ,doc) ',sym)) + (defmacro dotimes (vars &rest forms) - (let ((endvar (gensym "DOTIMES")) - (loop-tag (gensym "DOTIMES"))) - `(block nil - (let ((,(car vars) 0) - (,endvar ,(cadr vars))) - (declare (integer ,(car vars) ,endvar)) - (tagbody ,loop-tag - (if (> ,endvar ,(car vars)) - (tagbody - ,@forms - (setq ,(car vars) (1+ ,(car vars))) - (go ,loop-tag)))) - ,(caddr vars))))) + (let ((endvar (gensym "DOTIMES"))) + `(let ((,(car vars) 0) (,endvar ,(cadr vars))) + (declare (integer ,(car vars) ,endvar)) + (while (< ,(car vars) ,endvar) + ,@forms + (setq ,(car vars) (1+ ,(car vars)))) + ,(caddr vars)))) (defmacro dolist (vars &rest forms) - (let ((lists (gensym "DOLIST")) - (loop-tag (gensym "DOLIST")) - (decl (car forms))) - (if (and (consp decl) (eq (car decl) 'declare)) - (setq forms (cdr forms)) - (setq decl nil)) - `(block nil - (let ((,(car vars) nil) - (,lists ,(cadr vars))) - ,decl - (tagbody ,loop-tag - (if (endp ,lists) - (setq ,(car vars) nil) - (progn - (setq ,(car vars) (pop ,lists)) - (tagbody - ,@forms - (go ,loop-tag))))) - ,(caddr vars))))) + (let ((lists (gensym "DOLIST")) (decl (car forms))) + (if (and (consp decl) (eq (car decl) 'declare)) + (setq forms (cdr forms)) + (setq decl nil)) + `(let ((,(car vars) nil) (,lists ,(cadr vars))) + ,decl + (while ,lists + (setq ,(car vars) (pop ,lists)) + ,@forms) + ,(caddr vars)))) (defmacro do-symbols (vars &rest forms) - (let* ((symbols (gensym "DOSYM")) - (v (car vars)) - (pkg (if (cadr vars) (cadr vars) '*package*)) - (pkgv (gensym)) - (i (gensym)) - (size (gensym)) - (svec (gensym)) - (loop-tag (gensym "DO-SYMBOLS"))) - `(block nil - (let* ((,v nil) - (,pkgv (find-package ,pkg)) - (,i 0) - (,svec (,pkgv . intsymvector)) - (,size (length ,svec))) - (tagbody ,loop-tag - (if (< ,i ,size) - (tagbody - (setq ,v (elt ,svec ,i)) - (inc ,i) - (when (symbolp ,v) . ,forms) - (go ,loop-tag)))) - ,(caddr vars))))) + (let* ((symbols (gensym "DOSYM")) + (v (car vars)) + (pkg (if (cadr vars) (cadr vars) '*package*)) + (pkgv (gensym)) + (i (gensym)) + (size (gensym)) + (svec (gensym)) + ) + `(let* ((,v nil) + (,pkgv (find-package ,pkg)) + (,i 0) + (,svec (,pkgv . intsymvector)) + (,size (length ,svec))) + (while (< ,i ,size) + (setq ,v (elt ,svec ,i)) + (inc ,i) + (when (symbolp ,v) . ,forms)) + ,(caddr vars)))) (defmacro do-external-symbols (vars &rest forms) - (let* ((symbols (gensym "DOEXTSYM")) - (v (car vars)) - (pkg (if (cadr vars) (cadr vars) '*package*)) - (pkgv (gensym)) - (i (gensym)) - (size (gensym)) - (svec (gensym)) - (loop-tag (gensym "DO-EXTERNAL-SYMBOLS"))) - `(block nil - (let* ((,v nil) - (,pkgv (find-package ,pkg)) - (,i 0) - (,svec (,pkgv . symvector)) - (,size (length ,svec))) - (tagbody ,loop-tag - (if (< ,i ,size) - (tagbody - (setq ,v (elt ,svec ,i)) - (inc ,i) - (when (symbolp ,v) . ,forms) - (go ,loop-tag)))) - ,(caddr vars))))) + (let* ((symbols (gensym "DOEXTSYM")) + (v (car vars)) + (pkg (if (cadr vars) (cadr vars) '*package*)) + (pkgv (gensym)) + (i (gensym)) + (size (gensym)) + (svec (gensym)) + ) + `(let* ((,v nil) + (,pkgv (find-package ,pkg)) + (,i 0) + (,svec (,pkgv . symvector)) + (,size (length ,svec))) + (while (< ,i ,size) + (setq ,v (elt ,svec ,i)) + (inc ,i) + (when (symbolp ,v) . ,forms)) + ,(caddr vars)))) (defmacro do-all-symbols (var &rest forms) (let ((apackage (gensym "DOALLSYM"))) From e13e31ee99266a45866d43ae24d51d01e13f7df9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 14 Nov 2022 16:42:17 +0900 Subject: [PATCH 353/387] Allow to return non-nil on dolist, dotimes, do-symbols and do-external-symbols --- lisp/l/common.l | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index a2fb88f8e..cf6866d23 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -154,10 +154,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))) @@ -166,10 +167,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")) @@ -185,11 +187,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")) @@ -205,11 +208,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"))) From aea924100f80647582f5a208d036856418b42e8a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 20 Nov 2022 10:59:06 +0900 Subject: [PATCH 354/387] Avoid memory operations in UNIX:SIGNAL --- lisp/c/eus.c | 3 +++ lisp/c/unixcall.c | 11 +++++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 0e24bdebc..7ba91e09a 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -896,10 +896,13 @@ static void initclasses() 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;i Date: Sun, 20 Nov 2022 19:26:05 +0900 Subject: [PATCH 355/387] Avoid more dead_locks --- lisp/c/memory.c | 13 +++++++++---- lisp/c/predicates.c | 4 ++-- lisp/c/sysfunc.c | 9 ++++++++- 3 files changed, 19 insertions(+), 7 deletions(-) diff --git a/lisp/c/memory.c b/lisp/c/memory.c index fbb96717d..c25ac7b9d 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -385,7 +385,7 @@ int e,cid; #endif } #if THREADED - rw_rdlock(&gc_lock); + // rw_rdlock(&gc_lock); #endif #ifdef DEBUG fflush( stdout ); @@ -403,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; @@ -828,12 +828,17 @@ void gc() #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 @@ -847,8 +852,8 @@ 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 || speval(QGCDEBUG)!=NIL) { diff --git a/lisp/c/predicates.c b/lisp/c/predicates.c index c141c22f0..967fc5089 100644 --- a/lisp/c/predicates.c +++ b/lisp/c/predicates.c @@ -203,10 +203,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/sysfunc.c b/lisp/c/sysfunc.c index 9eee7efc0..29eb12704 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)));} From 9d90f807f6af3977dc61d63c4f9ade6ce40cd01a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 20 Nov 2022 22:07:51 +0900 Subject: [PATCH 356/387] Pre-allocate SIGNALS symbol for error() --- lisp/c/eus.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 7ba91e09a..cfc5b5296 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -128,6 +128,7 @@ pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; pointer TOPLEVEL,QEVALHOOK,QEXITHOOK,FATALERROR; +pointer SIGNALS; pointer QUNBOUND,QDEBUG,QGCHOOK,QGCDEBUG; pointer QTHREADS; /* system:*threads* */ pointer QPARAGC; @@ -393,7 +394,7 @@ va_dcl va_end(args); /* call user's error handler function */ - errhandler=getfunc_closure_noexcept(ctx, intern(ctx,"SIGNALS",7,lisppkg)); + errhandler=getfunc_closure_noexcept(ctx, SIGNALS); /* get call stack */ callstack=list_callstack(ctx,-1); @@ -738,6 +739,7 @@ static void initsymbols() 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; From 77903a10e82d094a1981a43b6cf50bfc205de72d Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 29 Nov 2022 17:42:31 +0900 Subject: [PATCH 357/387] Register extern getprop --- lisp/c/eus_proto.h | 1 + lisp/c/specials.c | 28 ++++++++++++++++------------ 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 89ccaa5b0..6d79136d4 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -599,6 +599,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*/); diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 89e099c9d..5d273c157 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -1222,13 +1222,24 @@ pointer argv[]; 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; @@ -1237,13 +1248,7 @@ register pointer argv[]; } printf( "\n" ); #endif - p=argv[0]->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); - } - 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*/ @@ -1291,8 +1296,7 @@ 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:" ); From b34b2ef24ddd985006387220712ce31ef8e962d0 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 29 Nov 2022 18:44:38 +0900 Subject: [PATCH 358/387] Add bindframe and fletframe structs to the cellunion --- lisp/c/eus.h | 12 ++++++++++++ lisp/c/eval.c | 24 ++++++++++++------------ lisp/c/makes.c | 18 +++++++++--------- lisp/c/specials.c | 4 ++-- lisp/c/sysfunc.c | 12 ++++++------ 5 files changed, 41 insertions(+), 29 deletions(-) diff --git a/lisp/c/eus.h b/lisp/c/eus.h index 472e06cf9..da639eaba 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -367,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; @@ -422,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; diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 8898bc546..8bd4faa3f 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -48,16 +48,16 @@ register pointer sym; if (sym->c.sym.vtype==V_CONSTANT) return(sym->c.sym.speval); GC_POINT; while (bf!=NULL) { - var=bf->c.obj.iv[0]; - val=bf->c.obj.iv[1]; + 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->c.obj.iv[2] /* next */) break; - bf=bf->c.obj.iv[2]; + 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;*/ @@ -78,15 +78,15 @@ register pointer sym,val; pointer_update(ctx->specials->c.vec.v[vt],val); return(val);} while (bf!=NULL) { - var=bf->c.obj.iv[0]; + var=bf->c.bfp.sym; if (sym==var) { - if (bf->c.obj.iv[1]==UNBOUND) goto setspecial; - pointer_update(bf->c.obj.iv[1],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->c.obj.iv[1]); + vaddr=getobjv(sym,var,bf->c.bfp.val); if (vaddr) {pointer_update(*vaddr,val); return(val);}} - if (bf==bf->c.obj.iv[2] /*next*/) break; - bf=bf->c.obj.iv[2]; + 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); @@ -102,8 +102,8 @@ register context *ctx; register pointer f; /*must be a symbol*/ { pointer ffp=ctx->fletfp; while (ffp!=NULL && isfletframe(ffp)) { - if (ffp->c.obj.iv[0]==f) { return(ffp->c.obj.iv[1]);} - else ffp=ffp->c.obj.iv[2];} + 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) diff --git a/lisp/c/makes.c b/lisp/c/makes.c index bbcf51754..6920aad46 100644 --- a/lisp/c/makes.c +++ b/lisp/c/makes.c @@ -563,9 +563,9 @@ pointer sym,val,nxt; vpush(sym), vpush(val), vpush(nxt); bf=makeobject(C_BINDFRAME); // if (nxt==NULL) nxt=NIL; - bf->c.obj.iv[2]=vpop(); // nxt - bf->c.obj.iv[1]=vpop(); // val - bf->c.obj.iv[0]=vpop(); // sym + 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) @@ -587,11 +587,11 @@ pointer nm,def,scp,nxt; p=cons(ctx,LAMCLOSURE,p); vpush(p); ff=makeobject(C_FLETFRAME); - ff->c.obj.iv[1]=vpop(); // p - ff->c.obj.iv[2]=vpop(); // nxt + ff->c.ffp.fclosure=vpop(); // p + ff->c.ffp.next=vpop(); // nxt vpop(); // scp vpop(); // def - ff->c.obj.iv[0]=vpop(); // nm + ff->c.ffp.name=vpop(); // nm vpush(ff); ctx->fletfp=ff; return(ff);} @@ -604,9 +604,9 @@ pointer nm,def,nxt; p=cons(ctx,MACRO,def); vpush(p); ff=makeobject(C_FLETFRAME); - ff->c.obj.iv[1]=vpop(); // p - ff->c.obj.iv[2]=vpop(); // nxt - ff->c.obj.iv[0]=vpop(); // nm + 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);} diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 5d273c157..62f46ed12 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -607,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->c.obj.iv[1]; + fn=ffpp->c.ffp.fclosure; fn=ccdr(fn); fn=ccdr(fn); fn=ccdr(fn); ccar(fn)=ctx->fletfp; - fns=ccdr(fns); ffpp=ffpp->c.obj.iv[2];} + fns=ccdr(fns); ffpp=ffpp->c.ffp.next;} result=progn(ctx,ccdr(arg)); ctx->fletfp=ffp; return(result);} diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index 29eb12704..df389246c 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -778,10 +778,10 @@ pointer *argv; else if (isint(argv[0]) && intval(argv[0])==0) return(NIL); else error(E_NOBINDFRAME);} while (bf) { - vpush(cons(ctx,bf->c.obj.iv[0],bf->c.obj.iv[1])); + vpush(cons(ctx,bf->c.bfp.sym,bf->c.bfp.val)); i++; - if (bf==bf->c.obj.iv[2]) break; - bf=bf->c.obj.iv[2];} + if (bf==bf->c.bfp.next) break; + bf=bf->c.bfp.next;} return(stacknlist(ctx,i));} pointer LISTFUNCTIONBINDINGS(ctx,n,argv) @@ -797,10 +797,10 @@ pointer *argv; else if (isint(argv[0]) && intval(argv[0])==0) return(NIL); else error(E_NOFLETFRAME);} while (ff) { - vpush(cons(ctx,ff->c.obj.iv[0],ff->c.obj.iv[1])); + vpush(cons(ctx,ff->c.ffp.name,ff->c.ffp.fclosure)); i++; - if (ff==ff->c.obj.iv[2]) break; - ff=ff->c.obj.iv[2];} + if (ff==ff->c.ffp.next) break; + ff=ff->c.ffp.next;} return(stacknlist(ctx,i));} pointer LISTFUNCTIONBINDINGS(ctx,n,argv) From 3f8cdfc988c588ca26ae35c3a619c241ccfb64b7 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Tue, 20 Dec 2022 00:00:30 +0900 Subject: [PATCH 359/387] Set explicit return value for fillchunk when no new chunks are needed --- lisp/c/memory.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/c/memory.c b/lisp/c/memory.c index c25ac7b9d..e36c20fb6 100644 --- a/lisp/c/memory.c +++ b/lisp/c/memory.c @@ -166,7 +166,7 @@ int fillchunk(k) register int k; { numunion nu; float gcm; - int j; + int j=0; gcm=min(0.9,fltval(speval(GCMARGIN))); while (freeheap<(totalheap*gcm)) { j=newchunk(k); From 54af50d31b2854a326f4868459265745dd05dda4 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 21 Dec 2022 12:16:53 +0900 Subject: [PATCH 360/387] Avoid segmentation fault when copying *unbound* --- lisp/c/leo.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/c/leo.c b/lisp/c/leo.c index b67869544..6eea57163 100644 --- a/lisp/c/leo.c +++ b/lisp/c/leo.c @@ -555,7 +555,7 @@ register pointer org; register int i,s; 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]; if (p_marked(org)) return(cpvec[intval(x)]); @@ -614,7 +614,7 @@ register pointer obj; { pointer x,klass; register int i,s; - if (isnum(obj) || pissymbol(obj) || pisclass(obj)) return; + if (obj==NULL || isnum(obj) || pissymbol(obj) || pisclass(obj)) return; x=obj->c.obj.iv[1]; if (p_marked(obj)) { pointer_update(obj->c.obj.iv[1],cpvec[intval(x)+1]); From 992d6f957926bd5e376a13d15718478082bf55b9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 21 Dec 2022 17:07:07 +0900 Subject: [PATCH 361/387] Add closure-identifier in comp.l --- lisp/comp/comp.l | 61 +++++++++++++++++++++++++++++++----------------- 1 file changed, 39 insertions(+), 22 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 41fdd4fa2..c28caa1e7 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -161,7 +161,7 @@ ; (eval-when (load compile eval) (defclass function-identifier :super object - :slots (name entry binding level offset bindframe cbindframe body comp clist)) + :slots (name entry binding level offset bindframe cbindframe body newcomp clist)) ) (eval-when (load eval) @@ -173,7 +173,7 @@ level lev entry ent body bd - comp cmp + newcomp cmp bindframe nil) self) (:init-body (sym bin &optional bd) @@ -183,6 +183,36 @@ self)) ) +; closure identifier +; +(eval-when (load compile eval) +(defclass closure-identifier :super object + :slots (entry def newcomp cframes fframes)) +) + +(eval-when (load eval) +(defmethod closure-identifier + (:init (ent form cmp cf ff) + (setq 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 entry def)))) +) + ; identifier table ; (eval-when (load compile eval) @@ -1162,7 +1192,7 @@ ;; make cleanup closure (send self :closure cleaner "unwind protect" cframes fframes) (setq newcomp (send self :copy-compiler)) - (send self :add-closure (list cleaner fn newcomp cframes fframes)))) + (send self :add-closure cleaner fn newcomp cframes fframes))) (send trans :bind-cleaner) (send self :eval prot) (send trans :call-cleaner cleaner) @@ -1233,7 +1263,7 @@ (setq entry (send self :genlabel "CLO")) (send self :closure entry "lambda-closure" cframes fframes) (setq newcomp (send self :copy-compiler)) - (send self :add-closure (list entry fn newcomp cframes fframes))))))) + (send self :add-closure entry fn newcomp cframes fframes)))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet (let (newcomp newcomps flets-tmp flist fletframe) @@ -1285,7 +1315,7 @@ (send self :closure (fn . entry) "flet env" cframes fframes) (setq (fn . offset) (1- (send trans :offset-from-fp))) (send self :add-closure - (list (fn . entry) (fn . body) (fn . comp) cframes fframes))))) + (fn . entry) (fn . body) (fn . newcomp) cframes fframes)))) (if (not recursive-scope) ;; when not recursive setup the bindframe after the closure declaration @@ -1710,7 +1740,9 @@ (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 (entry def newcomp cframes fframes) + (let ((clo (instance closure-identifier :init 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)) @@ -1726,22 +1758,7 @@ ) (:compile-closures () (dolist (aclosure (reverse function-closures)) - (let* ((entry (first aclosure)) - (def (second aclosure)) - (newcomp (third aclosure)) - (cframes (fourth aclosure)) - (fframes (fifth aclosure)) - (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 entry def))) + (send aclosure :compile)) (setq function-closures nil)) (:toplevel-eval (form) (setq function-closures nil) From 6d9fe73d4850107343818482a27540e3d8b30427 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 21 Dec 2022 17:33:02 +0900 Subject: [PATCH 362/387] Add blocks in compiled closures --- lisp/comp/comp.l | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index c28caa1e7..9c401b4e6 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -187,13 +187,14 @@ ; (eval-when (load compile eval) (defclass closure-identifier :super object - :slots (entry def newcomp cframes fframes)) + :slots (name entry def newcomp cframes fframes)) ) (eval-when (load eval) (defmethod closure-identifier - (:init (ent form cmp cf ff) - (setq entry ent + (:init (sym ent form cmp cf ff) + (setq name sym + entry ent def form newcomp cmp cframes cf @@ -210,7 +211,7 @@ ;; only reassign the most recent level (when (eq (fdef . cbindframe) t) (setq (fdef . cbindframe) (position (fdef . bindframe) cbind)))) - (send newcomp :compile-a-closure entry def)))) + (send newcomp :compile-a-closure name entry def)))) ) ; identifier table @@ -1146,7 +1147,7 @@ (send trans :store-local j 0 (frame . offset)))))) ;; makeclosure (send trans :closure form (plusp closure-level) (not (not frame))))) - (:lambda-preevaluation (fn &optional newcomp) + (: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)) @@ -1156,7 +1157,9 @@ (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)))) @@ -1192,7 +1195,7 @@ ;; make cleanup closure (send self :closure cleaner "unwind protect" cframes fframes) (setq newcomp (send self :copy-compiler)) - (send self :add-closure cleaner fn newcomp cframes fframes))) + (send self :add-closure nil cleaner fn newcomp cframes fframes))) (send trans :bind-cleaner) (send self :eval prot) (send trans :call-cleaner cleaner) @@ -1263,7 +1266,7 @@ (setq entry (send self :genlabel "CLO")) (send self :closure entry "lambda-closure" cframes fframes) (setq newcomp (send self :copy-compiler)) - (send self :add-closure entry fn newcomp cframes fframes)))))) + (send self :add-closure nil entry fn newcomp cframes fframes)))))) (:flet (funcs bodies recursive-scope) ;recursive-scope==T for labels, NIL for flet (let (newcomp newcomps flets-tmp flist fletframe) @@ -1287,7 +1290,7 @@ (setq (newcomp . flets) (append flets-tmp flets)) (setq (newcomp . idtable) idtable) (dolist (fn flets-tmp) - (send self :lambda-preevaluation (fn . body) newcomp))) + (send self :lambda-preevaluation (fn . body) (fn . name) newcomp))) ;; pre-evaluate body (let ((trans (send trans :copy-translator)) @@ -1315,7 +1318,7 @@ (send self :closure (fn . entry) "flet env" cframes fframes) (setq (fn . offset) (1- (send trans :offset-from-fp))) (send self :add-closure - (fn . entry) (fn . body) (fn . newcomp) cframes fframes)))) + (fn . name) (fn . entry) (fn . body) (fn . newcomp) cframes fframes)))) (if (not recursive-scope) ;; when not recursive setup the bindframe after the closure declaration @@ -1740,19 +1743,22 @@ (eval-when (load eval) (defmethod compiler (:add-initcode (form) (setq initcodes (cons form initcodes))) - (:add-closure (entry def newcomp cframes fframes) - (let ((clo (instance closure-identifier :init entry def newcomp cframes fframes))) + (: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) ) ) From c70bae26aa7d3dab69705f2bd5f28e38116d80d9 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Dec 2022 23:51:30 +0900 Subject: [PATCH 363/387] Add compile-method to compile single methods --- lisp/comp/comp.l | 59 ++++++++++++++++++++++++++++++++--------------- lisp/l/eusstart.l | 3 ++- 2 files changed, 42 insertions(+), 20 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 9c401b4e6..71a51c1b0 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -15,7 +15,7 @@ (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* *type-check-declare*))) @@ -2053,27 +2053,48 @@ (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)) + (symbol-name (gensym "C"))))) + (setq funcs (remove-if #'compiled-function-p funcs :key #'symbol-function)) (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)) - #+(or :linux :cygwin) - (unix:unlink (namestring (make-pathname :defaults fname :type "o"))) - funcs - )) + (compile-tmp fname) + funcs)) + +(defun compile-method (obj meth) + (let ((fname (format nil "eus~d~A.l" (unix:getpid) + (symbol-name (gensym "C")))) + (kls (if (classp obj) obj (class obj))) + (body (if (classp obj) + (assoc meth (send obj :methods)) + (cadr (find-method obj meth))))) + (cond + ((not body) nil) + ((compiled-function-p (second body)) t) + (t + (with-open-file (f fname :direction :output) + (format f "~S~%" `(defmethod ,(send kls :name) ,body))) + (compile-tmp fname) + meth)))) (defun compile-file-if-src-newer (srcfile &optional (objdir "./") &rest args) diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index da5db1079..f4daa3ead 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -339,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 @@ -346,7 +347,7 @@ ;; 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)) (alias 'exit 'unix::exit) ;; From d21747f92c61f7a2eba6403fa8ee128a6d957262 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 22 Dec 2022 23:59:25 +0900 Subject: [PATCH 364/387] Add compile-method documentation --- doc/jlatex/euslisp.hlp | 93 +++++++++++++++++++------------------- doc/jlatex/jevaluation.tex | 9 +++- doc/latex/euslisp.hlp | 93 +++++++++++++++++++------------------- doc/latex/evaluation.tex | 10 +++- 4 files changed, 110 insertions(+), 95 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 9469c6da6..1cd8c62c5 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -552,52 +552,53 @@ "new-history" 2 "jevaluation" 13806 3 "compile-file" 2 "jevaluation" 23323 3 "compile" 2 "jevaluation" 24121 3 -"compile-file-if-src-newer" 2 "jevaluation" 24477 3 -"compiler:*optimize*" 5 "jevaluation" 24778 2 -"compiler:*safety*" 5 "jevaluation" 24864 2 -"compiler:*verbose*" 5 "jevaluation" 24933 2 -"compiler:*type-check-declare*" 5 "jevaluation" 25129 2 -"compiler::compiler-implementation-version" 2 "jevaluation" 25329 3 -"load" 2 "jevaluation" 25546 3 -"load-files" 2 "jevaluation" 29467 3 -"*modules*" 5 "jevaluation" 29582 2 -"provide" 2 "jevaluation" 29686 3 -"require" 2 "jevaluation" 30103 3 -"system:binload" 2 "jevaluation" 31345 3 -"system::txtload" 2 "jevaluation" 31568 2 -"describe" 2 "jevaluation" 31671 3 -"describe-list" 2 "jevaluation" 31818 3 -"inspect" 3 "jevaluation" 31958 3 -"more" 2 "jevaluation" 32295 3 -"break" 2 "jevaluation" 32668 3 -"help" 2 "jevaluation" 32965 3 -"apropos" 2 "jevaluation" 33256 3 -"apropos-list" 2 "jevaluation" 33667 3 -"constants" 2 "jevaluation" 33812 3 -"variables" 2 "jevaluation" 33987 3 -"functions" 2 "jevaluation" 34180 3 -"btrace" 2 "jevaluation" 34367 3 -"step-hook" 2 "jevaluation" 34473 2 -"step" 2 "jevaluation" 34500 3 -"trace" 2 "jevaluation" 34639 3 -"untrace" 2 "jevaluation" 34828 3 -"timing" 3 "jevaluation" 34899 3 -"time" 3 "jevaluation" 35044 3 -"lisp::print-callstack" 2 "jevaluation" 35159 3 -"sys:list-callstack" 2 "jevaluation" 35400 3 -"sys:list-all-catchers" 2 "jevaluation" 35607 3 -"sys:list-all-blocks" 2 "jevaluation" 35685 3 -"sys:list-all-tags" 2 "jevaluation" 35761 3 -"sys:list-all-instances" 2 "jevaluation" 35844 3 -"sys:list-all-bindings" 2 "jevaluation" 36233 3 -"sys:list-all-special-bindings" 2 "jevaluation" 36580 3 -"sys:list-all-function-bindings" 2 "jevaluation" 36739 3 -"dump-object" 2 "jevaluation" 37745 2 -"dump-structure" 2 "jevaluation" 37793 3 -"dump-loadable-structure" 2 "jevaluation" 37948 3 -"sys:save" 2 "jevaluation" 39010 3 -"lisp-implementation-type" 2 "jevaluation" 42414 3 -"lisp-implementation-version" 2 "jevaluation" 42486 3 +"compile-method" 2 "jevaluation" 24474 3 +"compile-file-if-src-newer" 2 "jevaluation" 24920 3 +"compiler:*optimize*" 5 "jevaluation" 25221 2 +"compiler:*safety*" 5 "jevaluation" 25307 2 +"compiler:*verbose*" 5 "jevaluation" 25376 2 +"compiler:*type-check-declare*" 5 "jevaluation" 25572 2 +"compiler::compiler-implementation-version" 2 "jevaluation" 25772 3 +"load" 2 "jevaluation" 25989 3 +"load-files" 2 "jevaluation" 29910 3 +"*modules*" 5 "jevaluation" 30025 2 +"provide" 2 "jevaluation" 30129 3 +"require" 2 "jevaluation" 30546 3 +"system:binload" 2 "jevaluation" 31788 3 +"system::txtload" 2 "jevaluation" 32011 2 +"describe" 2 "jevaluation" 32114 3 +"describe-list" 2 "jevaluation" 32261 3 +"inspect" 3 "jevaluation" 32401 3 +"more" 2 "jevaluation" 32738 3 +"break" 2 "jevaluation" 33111 3 +"help" 2 "jevaluation" 33408 3 +"apropos" 2 "jevaluation" 33699 3 +"apropos-list" 2 "jevaluation" 34110 3 +"constants" 2 "jevaluation" 34255 3 +"variables" 2 "jevaluation" 34430 3 +"functions" 2 "jevaluation" 34623 3 +"btrace" 2 "jevaluation" 34810 3 +"step-hook" 2 "jevaluation" 34916 2 +"step" 2 "jevaluation" 34943 3 +"trace" 2 "jevaluation" 35082 3 +"untrace" 2 "jevaluation" 35271 3 +"timing" 3 "jevaluation" 35342 3 +"time" 3 "jevaluation" 35487 3 +"lisp::print-callstack" 2 "jevaluation" 35602 3 +"sys:list-callstack" 2 "jevaluation" 35843 3 +"sys:list-all-catchers" 2 "jevaluation" 36050 3 +"sys:list-all-blocks" 2 "jevaluation" 36128 3 +"sys:list-all-tags" 2 "jevaluation" 36204 3 +"sys:list-all-instances" 2 "jevaluation" 36287 3 +"sys:list-all-bindings" 2 "jevaluation" 36676 3 +"sys:list-all-special-bindings" 2 "jevaluation" 37023 3 +"sys:list-all-function-bindings" 2 "jevaluation" 37182 3 +"dump-object" 2 "jevaluation" 38188 2 +"dump-structure" 2 "jevaluation" 38236 3 +"dump-loadable-structure" 2 "jevaluation" 38391 3 +"sys:save" 2 "jevaluation" 39453 3 +"lisp-implementation-type" 2 "jevaluation" 42857 3 +"lisp-implementation-version" 2 "jevaluation" 42929 3 "sys:gc" 2 "jsysfunc" 6326 3 "sys:gctime" 2 "jsysfunc" 6520 3 "sys:alloc" 2 "jsysfunc" 6837 3 diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index 45b141b48..cbd004b6d 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -441,12 +441,19 @@ \subsubsection{クロージャコンパイル} モジュールが作成中にEuslispのコアにハードリンクされていないかぎり、 {\em :pic}は、Tに設定すべきである。} -\funcdesc{compile}{funcname}{ +\funcdesc{compile}{\&rest funcnames}{ 関数をコンパイルする。{\bf compile}は、最初に関数定義をテンポラリファイルに 出力する。そのファイルは、{\bf compile-file}によってコンパイルされ、 それから{\bf load}によってロードされる。 テンポラリファイルは削除される。} +\funcdesc{compile-method}{obj meth}{ +オプジェクトインスタンスやクラス{\em obj}のメソッド{\em meth}をコンパイルする。 +{\bf compile-method}は、最初にメソッド定義をテンポラリファイルに +出力する。そのファイルは、{\bf compile-file}によってコンパイルされ、 +それから{\bf load}によってロードされる。 +テンポラリファイルは削除される。} + \funcdesc{compile-file-if-src-newer}{srcfile \&key compiler-options}{ {\em srcfile}が対応するオブジェクトファイルよりも新しい（最近変更された） ならば、コンパイルする。そのオブジェクトファイルは、".o"拡張子を diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 1a1c92217..74d12adec 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -557,52 +557,53 @@ "new-history" 2 "evaluation" 13457 3 "compile-file" 2 "evaluation" 20978 3 "compile" 2 "evaluation" 21659 3 -"compile-file-if-src-newer" 2 "evaluation" 21910 3 -"compiler:*optimize*" 5 "evaluation" 22131 2 -"compiler:*safety*" 5 "evaluation" 22191 2 -"compiler:*verbose*" 5 "evaluation" 22246 2 -"compiler:*type-check-declare*" 5 "evaluation" 22418 2 -"compiler::compiler-implementation-version" 2 "evaluation" 22561 3 -"load" 2 "evaluation" 22750 3 -"load-files" 2 "evaluation" 26177 3 -"*modules*" 5 "evaluation" 26279 2 -"provide" 2 "evaluation" 26368 3 -"require" 2 "evaluation" 26695 3 -"system:binload" 2 "evaluation" 27662 3 -"system::txtload" 2 "evaluation" 27854 2 -"describe" 2 "evaluation" 27951 3 -"describe-list" 2 "evaluation" 28084 3 -"inspect" 3 "evaluation" 28195 3 -"more" 2 "evaluation" 28440 3 -"break" 2 "evaluation" 28720 3 -"help" 2 "evaluation" 28924 3 -"apropos" 2 "evaluation" 29535 3 -"apropos-list" 2 "evaluation" 29904 3 -"constants" 2 "evaluation" 30034 3 -"variables" 2 "evaluation" 30183 3 -"functions" 2 "evaluation" 30337 3 -"btrace" 2 "evaluation" 30490 3 -"step-hook" 2 "evaluation" 30579 2 -"step" 2 "evaluation" 30606 3 -"trace" 2 "evaluation" 30730 3 -"untrace" 2 "evaluation" 30877 3 -"timing" 3 "evaluation" 30932 3 -"time" 3 "evaluation" 31063 3 -"lisp::print-callstack" 2 "evaluation" 31163 3 -"sys:list-callstack" 2 "evaluation" 31417 3 -"sys:list-all-catchers" 2 "evaluation" 31611 3 -"sys:list-all-blocks" 2 "evaluation" 31687 3 -"sys:list-all-tags" 2 "evaluation" 31761 3 -"sys:list-all-instances" 2 "evaluation" 31842 3 -"sys:list-all-bindings" 2 "evaluation" 32139 3 -"sys:list-all-special-bindings" 2 "evaluation" 32357 3 -"sys:list-all-function-bindings" 2 "evaluation" 32474 3 -"dump-object" 2 "evaluation" 33210 2 -"dump-structure" 2 "evaluation" 33258 3 -"dump-loadable-structure" 2 "evaluation" 33389 3 -"sys:save" 2 "evaluation" 34261 3 -"lisp-implementation-type" 2 "evaluation" 36971 3 -"lisp-implementation-version" 2 "evaluation" 37040 3 +"compile-method" 2 "evaluation" 21908 3 +"compile-file-if-src-newer" 2 "evaluation" 22217 3 +"compiler:*optimize*" 5 "evaluation" 22438 2 +"compiler:*safety*" 5 "evaluation" 22498 2 +"compiler:*verbose*" 5 "evaluation" 22553 2 +"compiler:*type-check-declare*" 5 "evaluation" 22725 2 +"compiler::compiler-implementation-version" 2 "evaluation" 22868 3 +"load" 2 "evaluation" 23057 3 +"load-files" 2 "evaluation" 26484 3 +"*modules*" 5 "evaluation" 26586 2 +"provide" 2 "evaluation" 26675 3 +"require" 2 "evaluation" 27002 3 +"system:binload" 2 "evaluation" 27969 3 +"system::txtload" 2 "evaluation" 28161 2 +"describe" 2 "evaluation" 28258 3 +"describe-list" 2 "evaluation" 28391 3 +"inspect" 3 "evaluation" 28502 3 +"more" 2 "evaluation" 28747 3 +"break" 2 "evaluation" 29027 3 +"help" 2 "evaluation" 29231 3 +"apropos" 2 "evaluation" 29842 3 +"apropos-list" 2 "evaluation" 30211 3 +"constants" 2 "evaluation" 30341 3 +"variables" 2 "evaluation" 30490 3 +"functions" 2 "evaluation" 30644 3 +"btrace" 2 "evaluation" 30797 3 +"step-hook" 2 "evaluation" 30886 2 +"step" 2 "evaluation" 30913 3 +"trace" 2 "evaluation" 31037 3 +"untrace" 2 "evaluation" 31184 3 +"timing" 3 "evaluation" 31239 3 +"time" 3 "evaluation" 31370 3 +"lisp::print-callstack" 2 "evaluation" 31470 3 +"sys:list-callstack" 2 "evaluation" 31724 3 +"sys:list-all-catchers" 2 "evaluation" 31918 3 +"sys:list-all-blocks" 2 "evaluation" 31994 3 +"sys:list-all-tags" 2 "evaluation" 32068 3 +"sys:list-all-instances" 2 "evaluation" 32149 3 +"sys:list-all-bindings" 2 "evaluation" 32446 3 +"sys:list-all-special-bindings" 2 "evaluation" 32664 3 +"sys:list-all-function-bindings" 2 "evaluation" 32781 3 +"dump-object" 2 "evaluation" 33517 2 +"dump-structure" 2 "evaluation" 33565 3 +"dump-loadable-structure" 2 "evaluation" 33696 3 +"sys:save" 2 "evaluation" 34568 3 +"lisp-implementation-type" 2 "evaluation" 37278 3 +"lisp-implementation-version" 2 "evaluation" 37347 3 "sys:gc" 2 "sysfunc" 4597 3 "sys:gctime" 2 "sysfunc" 4726 3 "sys:alloc" 2 "sysfunc" 4943 3 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index 644b5f243..d0a8f006f 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -481,9 +481,15 @@ \subsubsection{Closure Compilation} {\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 meth}{ +compiles the method {\em meth} 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.} From 63cb4905088a62834e3a33752135c36fa48aedac Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 23 Dec 2022 11:19:28 +0900 Subject: [PATCH 365/387] Use alias instead of setf symbol-function to set compiler entry --- lib/llib/documentation.l | 6 +++--- lib/llib/unittest.l | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) 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/unittest.l b/lib/llib/unittest.l index 57e32b640..1fc377073 100644 --- a/lib/llib/unittest.l +++ b/lib/llib/unittest.l @@ -248,7 +248,7 @@ :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) From 4374ed7f06a37f94e3b4c6920610affc8e005bab Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 23 Dec 2022 12:17:01 +0900 Subject: [PATCH 366/387] Fix compiler::function-alias for special forms --- lisp/comp/comp.l | 8 ++++++-- lisp/comp/trans.l | 2 -- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index 71a51c1b0..db9330ea1 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -116,6 +116,9 @@ (if (null (= req n)) (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))) @@ -668,6 +671,7 @@ (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))) @@ -840,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) @@ -1768,7 +1772,7 @@ (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)) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index 36886a3b4..b38e49619 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -284,8 +284,6 @@ (let ((entry)) (setq entry (get sym 'user-function-entry)) (if (null entry) (setq entry (get sym 'builtin-function-entry))) - (if (and (null entry) (get sym 'function-alias)) - (setq entry (get (get sym 'function-alias) 'builtin-function-entry))) (send self :clearpush) (send self :reset-vsp) (if (and (not (functionp sym)) (not avant-mode)) From bed4d4b939c87097349c4b90e942a1e220d6a549 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 24 Dec 2022 17:04:57 +0900 Subject: [PATCH 367/387] Accept multiple arguments in compile-method --- doc/jlatex/euslisp.hlp | 92 +++++++++++++++++++------------------- doc/jlatex/jevaluation.tex | 4 +- doc/latex/euslisp.hlp | 92 +++++++++++++++++++------------------- doc/latex/evaluation.tex | 4 +- lisp/comp/comp.l | 28 +++++++----- 5 files changed, 112 insertions(+), 108 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 1cd8c62c5..9be210004 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -553,52 +553,52 @@ "compile-file" 2 "jevaluation" 23323 3 "compile" 2 "jevaluation" 24121 3 "compile-method" 2 "jevaluation" 24474 3 -"compile-file-if-src-newer" 2 "jevaluation" 24920 3 -"compiler:*optimize*" 5 "jevaluation" 25221 2 -"compiler:*safety*" 5 "jevaluation" 25307 2 -"compiler:*verbose*" 5 "jevaluation" 25376 2 -"compiler:*type-check-declare*" 5 "jevaluation" 25572 2 -"compiler::compiler-implementation-version" 2 "jevaluation" 25772 3 -"load" 2 "jevaluation" 25989 3 -"load-files" 2 "jevaluation" 29910 3 -"*modules*" 5 "jevaluation" 30025 2 -"provide" 2 "jevaluation" 30129 3 -"require" 2 "jevaluation" 30546 3 -"system:binload" 2 "jevaluation" 31788 3 -"system::txtload" 2 "jevaluation" 32011 2 -"describe" 2 "jevaluation" 32114 3 -"describe-list" 2 "jevaluation" 32261 3 -"inspect" 3 "jevaluation" 32401 3 -"more" 2 "jevaluation" 32738 3 -"break" 2 "jevaluation" 33111 3 -"help" 2 "jevaluation" 33408 3 -"apropos" 2 "jevaluation" 33699 3 -"apropos-list" 2 "jevaluation" 34110 3 -"constants" 2 "jevaluation" 34255 3 -"variables" 2 "jevaluation" 34430 3 -"functions" 2 "jevaluation" 34623 3 -"btrace" 2 "jevaluation" 34810 3 -"step-hook" 2 "jevaluation" 34916 2 -"step" 2 "jevaluation" 34943 3 -"trace" 2 "jevaluation" 35082 3 -"untrace" 2 "jevaluation" 35271 3 -"timing" 3 "jevaluation" 35342 3 -"time" 3 "jevaluation" 35487 3 -"lisp::print-callstack" 2 "jevaluation" 35602 3 -"sys:list-callstack" 2 "jevaluation" 35843 3 -"sys:list-all-catchers" 2 "jevaluation" 36050 3 -"sys:list-all-blocks" 2 "jevaluation" 36128 3 -"sys:list-all-tags" 2 "jevaluation" 36204 3 -"sys:list-all-instances" 2 "jevaluation" 36287 3 -"sys:list-all-bindings" 2 "jevaluation" 36676 3 -"sys:list-all-special-bindings" 2 "jevaluation" 37023 3 -"sys:list-all-function-bindings" 2 "jevaluation" 37182 3 -"dump-object" 2 "jevaluation" 38188 2 -"dump-structure" 2 "jevaluation" 38236 3 -"dump-loadable-structure" 2 "jevaluation" 38391 3 -"sys:save" 2 "jevaluation" 39453 3 -"lisp-implementation-type" 2 "jevaluation" 42857 3 -"lisp-implementation-version" 2 "jevaluation" 42929 3 +"compile-file-if-src-newer" 2 "jevaluation" 24929 3 +"compiler:*optimize*" 5 "jevaluation" 25230 2 +"compiler:*safety*" 5 "jevaluation" 25316 2 +"compiler:*verbose*" 5 "jevaluation" 25385 2 +"compiler:*type-check-declare*" 5 "jevaluation" 25581 2 +"compiler::compiler-implementation-version" 2 "jevaluation" 25781 3 +"load" 2 "jevaluation" 25998 3 +"load-files" 2 "jevaluation" 29919 3 +"*modules*" 5 "jevaluation" 30034 2 +"provide" 2 "jevaluation" 30138 3 +"require" 2 "jevaluation" 30555 3 +"system:binload" 2 "jevaluation" 31797 3 +"system::txtload" 2 "jevaluation" 32020 2 +"describe" 2 "jevaluation" 32123 3 +"describe-list" 2 "jevaluation" 32270 3 +"inspect" 3 "jevaluation" 32410 3 +"more" 2 "jevaluation" 32747 3 +"break" 2 "jevaluation" 33120 3 +"help" 2 "jevaluation" 33417 3 +"apropos" 2 "jevaluation" 33708 3 +"apropos-list" 2 "jevaluation" 34119 3 +"constants" 2 "jevaluation" 34264 3 +"variables" 2 "jevaluation" 34439 3 +"functions" 2 "jevaluation" 34632 3 +"btrace" 2 "jevaluation" 34819 3 +"step-hook" 2 "jevaluation" 34925 2 +"step" 2 "jevaluation" 34952 3 +"trace" 2 "jevaluation" 35091 3 +"untrace" 2 "jevaluation" 35280 3 +"timing" 3 "jevaluation" 35351 3 +"time" 3 "jevaluation" 35496 3 +"lisp::print-callstack" 2 "jevaluation" 35611 3 +"sys:list-callstack" 2 "jevaluation" 35852 3 +"sys:list-all-catchers" 2 "jevaluation" 36059 3 +"sys:list-all-blocks" 2 "jevaluation" 36137 3 +"sys:list-all-tags" 2 "jevaluation" 36213 3 +"sys:list-all-instances" 2 "jevaluation" 36296 3 +"sys:list-all-bindings" 2 "jevaluation" 36685 3 +"sys:list-all-special-bindings" 2 "jevaluation" 37032 3 +"sys:list-all-function-bindings" 2 "jevaluation" 37191 3 +"dump-object" 2 "jevaluation" 38197 2 +"dump-structure" 2 "jevaluation" 38245 3 +"dump-loadable-structure" 2 "jevaluation" 38400 3 +"sys:save" 2 "jevaluation" 39462 3 +"lisp-implementation-type" 2 "jevaluation" 42866 3 +"lisp-implementation-version" 2 "jevaluation" 42938 3 "sys:gc" 2 "jsysfunc" 6326 3 "sys:gctime" 2 "jsysfunc" 6520 3 "sys:alloc" 2 "jsysfunc" 6837 3 diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index cbd004b6d..d9cb2490f 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -447,8 +447,8 @@ \subsubsection{クロージャコンパイル} それから{\bf load}によってロードされる。 テンポラリファイルは削除される。} -\funcdesc{compile-method}{obj meth}{ -オプジェクトインスタンスやクラス{\em obj}のメソッド{\em meth}をコンパイルする。 +\funcdesc{compile-method}{obj \&rest meths}{ +オプジェクトインスタンスやクラス{\em obj}のメソッド{\em meths}をコンパイルする。 {\bf compile-method}は、最初にメソッド定義をテンポラリファイルに 出力する。そのファイルは、{\bf compile-file}によってコンパイルされ、 それから{\bf load}によってロードされる。 diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index 74d12adec..bd9987f1a 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -558,52 +558,52 @@ "compile-file" 2 "evaluation" 20978 3 "compile" 2 "evaluation" 21659 3 "compile-method" 2 "evaluation" 21908 3 -"compile-file-if-src-newer" 2 "evaluation" 22217 3 -"compiler:*optimize*" 5 "evaluation" 22438 2 -"compiler:*safety*" 5 "evaluation" 22498 2 -"compiler:*verbose*" 5 "evaluation" 22553 2 -"compiler:*type-check-declare*" 5 "evaluation" 22725 2 -"compiler::compiler-implementation-version" 2 "evaluation" 22868 3 -"load" 2 "evaluation" 23057 3 -"load-files" 2 "evaluation" 26484 3 -"*modules*" 5 "evaluation" 26586 2 -"provide" 2 "evaluation" 26675 3 -"require" 2 "evaluation" 27002 3 -"system:binload" 2 "evaluation" 27969 3 -"system::txtload" 2 "evaluation" 28161 2 -"describe" 2 "evaluation" 28258 3 -"describe-list" 2 "evaluation" 28391 3 -"inspect" 3 "evaluation" 28502 3 -"more" 2 "evaluation" 28747 3 -"break" 2 "evaluation" 29027 3 -"help" 2 "evaluation" 29231 3 -"apropos" 2 "evaluation" 29842 3 -"apropos-list" 2 "evaluation" 30211 3 -"constants" 2 "evaluation" 30341 3 -"variables" 2 "evaluation" 30490 3 -"functions" 2 "evaluation" 30644 3 -"btrace" 2 "evaluation" 30797 3 -"step-hook" 2 "evaluation" 30886 2 -"step" 2 "evaluation" 30913 3 -"trace" 2 "evaluation" 31037 3 -"untrace" 2 "evaluation" 31184 3 -"timing" 3 "evaluation" 31239 3 -"time" 3 "evaluation" 31370 3 -"lisp::print-callstack" 2 "evaluation" 31470 3 -"sys:list-callstack" 2 "evaluation" 31724 3 -"sys:list-all-catchers" 2 "evaluation" 31918 3 -"sys:list-all-blocks" 2 "evaluation" 31994 3 -"sys:list-all-tags" 2 "evaluation" 32068 3 -"sys:list-all-instances" 2 "evaluation" 32149 3 -"sys:list-all-bindings" 2 "evaluation" 32446 3 -"sys:list-all-special-bindings" 2 "evaluation" 32664 3 -"sys:list-all-function-bindings" 2 "evaluation" 32781 3 -"dump-object" 2 "evaluation" 33517 2 -"dump-structure" 2 "evaluation" 33565 3 -"dump-loadable-structure" 2 "evaluation" 33696 3 -"sys:save" 2 "evaluation" 34568 3 -"lisp-implementation-type" 2 "evaluation" 37278 3 -"lisp-implementation-version" 2 "evaluation" 37347 3 +"compile-file-if-src-newer" 2 "evaluation" 22227 3 +"compiler:*optimize*" 5 "evaluation" 22448 2 +"compiler:*safety*" 5 "evaluation" 22508 2 +"compiler:*verbose*" 5 "evaluation" 22563 2 +"compiler:*type-check-declare*" 5 "evaluation" 22735 2 +"compiler::compiler-implementation-version" 2 "evaluation" 22878 3 +"load" 2 "evaluation" 23067 3 +"load-files" 2 "evaluation" 26494 3 +"*modules*" 5 "evaluation" 26596 2 +"provide" 2 "evaluation" 26685 3 +"require" 2 "evaluation" 27012 3 +"system:binload" 2 "evaluation" 27979 3 +"system::txtload" 2 "evaluation" 28171 2 +"describe" 2 "evaluation" 28268 3 +"describe-list" 2 "evaluation" 28401 3 +"inspect" 3 "evaluation" 28512 3 +"more" 2 "evaluation" 28757 3 +"break" 2 "evaluation" 29037 3 +"help" 2 "evaluation" 29241 3 +"apropos" 2 "evaluation" 29852 3 +"apropos-list" 2 "evaluation" 30221 3 +"constants" 2 "evaluation" 30351 3 +"variables" 2 "evaluation" 30500 3 +"functions" 2 "evaluation" 30654 3 +"btrace" 2 "evaluation" 30807 3 +"step-hook" 2 "evaluation" 30896 2 +"step" 2 "evaluation" 30923 3 +"trace" 2 "evaluation" 31047 3 +"untrace" 2 "evaluation" 31194 3 +"timing" 3 "evaluation" 31249 3 +"time" 3 "evaluation" 31380 3 +"lisp::print-callstack" 2 "evaluation" 31480 3 +"sys:list-callstack" 2 "evaluation" 31734 3 +"sys:list-all-catchers" 2 "evaluation" 31928 3 +"sys:list-all-blocks" 2 "evaluation" 32004 3 +"sys:list-all-tags" 2 "evaluation" 32078 3 +"sys:list-all-instances" 2 "evaluation" 32159 3 +"sys:list-all-bindings" 2 "evaluation" 32456 3 +"sys:list-all-special-bindings" 2 "evaluation" 32674 3 +"sys:list-all-function-bindings" 2 "evaluation" 32791 3 +"dump-object" 2 "evaluation" 33527 2 +"dump-structure" 2 "evaluation" 33575 3 +"dump-loadable-structure" 2 "evaluation" 33706 3 +"sys:save" 2 "evaluation" 34578 3 +"lisp-implementation-type" 2 "evaluation" 37288 3 +"lisp-implementation-version" 2 "evaluation" 37357 3 "sys:gc" 2 "sysfunc" 4597 3 "sys:gctime" 2 "sysfunc" 4726 3 "sys:alloc" 2 "sysfunc" 4943 3 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index d0a8f006f..d28d601c5 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -487,8 +487,8 @@ \subsubsection{Closure Compilation} The file is compiled by {\bf compile-file} and then is loaded by {\bf load}. Temporary files are deleted.} -\funcdesc{compile-method}{obj meth}{ -compiles the method {\em meth} of the class or object instance {\em obj}. +\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.} diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index db9330ea1..bd40ec585 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -2084,21 +2084,25 @@ (compile-tmp fname) funcs)) -(defun compile-method (obj meth) +(defun compile-method (obj &rest meths) (let ((fname (format nil "eus~d~A.l" (unix:getpid) (symbol-name (gensym "C")))) (kls (if (classp obj) obj (class obj))) - (body (if (classp obj) - (assoc meth (send obj :methods)) - (cadr (find-method obj meth))))) - (cond - ((not body) nil) - ((compiled-function-p (second body)) t) - (t - (with-open-file (f fname :direction :output) - (format f "~S~%" `(defmethod ,(send kls :name) ,body))) - (compile-tmp fname) - meth)))) + body) + (labels ((get-method (meth) + (if (classp obj) + (assoc meth (send obj :methods)) + (cadr (find-method obj meth)))) + (to-compile (def) + (and (consp def) (not (compiled-function-p (second def)))))) + + (setq body (mapcar #'get-method meths)) + (setq body (remove-if-not #'to-compile body)) + (when body + (with-open-file (f fname :direction :output) + (format f "~S~%" `(defmethod ,(send kls :name) ,@body))) + (compile-tmp fname) + (mapcar #'car body))))) (defun compile-file-if-src-newer (srcfile &optional (objdir "./") &rest args) From aa041950664a714fd7356f0f06e0d544cdb1b913 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 25 Dec 2022 12:16:20 +0900 Subject: [PATCH 368/387] Fix macro compilation in 'compile' --- lisp/comp/comp.l | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index bd40ec585..f604263fe 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -2050,7 +2050,7 @@ (setq dump (case (car def) (lambda `(defun ,funmac . ,(cdr def))) - (macro `(defun ,funmac . ,(cdr def))))) + (macro `(defmacro ,funmac . ,(cdr def))))) (pprint dump f) ))) ) (defun comfile (&rest files) (dolist (f files) (send comp :compile-file f))) From e7cacdceac073983507fe41a3838ec1219354692 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 25 Dec 2022 12:22:12 +0900 Subject: [PATCH 369/387] Add comp::dump-method and fix class reference when compiling parent methods --- lisp/comp/comp.l | 66 +++++++++++++++++++++++++++--------------------- 1 file changed, 37 insertions(+), 29 deletions(-) diff --git a/lisp/comp/comp.l b/lisp/comp/comp.l index f604263fe..3eb880760 100644 --- a/lisp/comp/comp.l +++ b/lisp/comp/comp.l @@ -2044,14 +2044,34 @@ (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 `(defmacro ,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) @@ -2077,32 +2097,20 @@ pname)) (defun compile (&rest funcs) - (let ((fname (format nil "eus~d~A.l" (unix:getpid) - (symbol-name (gensym "C"))))) - (setq funcs (remove-if #'compiled-function-p funcs :key #'symbol-function)) - (apply #'dump-function fname 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) - funcs)) + res))) (defun compile-method (obj &rest meths) - (let ((fname (format nil "eus~d~A.l" (unix:getpid) - (symbol-name (gensym "C")))) - (kls (if (classp obj) obj (class obj))) - body) - (labels ((get-method (meth) - (if (classp obj) - (assoc meth (send obj :methods)) - (cadr (find-method obj meth)))) - (to-compile (def) - (and (consp def) (not (compiled-function-p (second def)))))) - - (setq body (mapcar #'get-method meths)) - (setq body (remove-if-not #'to-compile body)) - (when body - (with-open-file (f fname :direction :output) - (format f "~S~%" `(defmethod ,(send kls :name) ,@body))) - (compile-tmp fname) - (mapcar #'car body))))) + (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) From 3228d5c625ec5b30a77bd761768059b44fa0cb12 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 25 Dec 2022 22:24:35 +0900 Subject: [PATCH 370/387] Force null *print-circle* in :prin1 to avoid deadlocks (#465) --- lisp/c/printer.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lisp/c/printer.c b/lisp/c/printer.c index 6c13a3310..e12bc6129 100644 --- a/lisp/c/printer.c +++ b/lisp/c/printer.c @@ -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,6 +586,13 @@ 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); } } From 3296768d8821a425f502b715807b4a480b46d04a Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 26 Dec 2022 13:39:50 +0900 Subject: [PATCH 371/387] Avoid segmentation fault when marking/unmarking *unbound* --- lisp/c/printer.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/c/printer.c b/lisp/c/printer.c index e12bc6129..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; @@ -599,7 +599,7 @@ register int prlevel; 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"); From 4219be0c47b832430845cbe96584476d76053202 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sat, 31 Dec 2022 20:16:45 +0900 Subject: [PATCH 372/387] Use getfunc_closure when compiling sharp quote to match interpreter evaluation --- lisp/c/eus_proto.h | 2 -- lisp/c/eval.c | 5 ----- lisp/c/specials.c | 2 +- lisp/comp/trans.l | 2 +- 4 files changed, 2 insertions(+), 9 deletions(-) diff --git a/lisp/c/eus_proto.h b/lisp/c/eus_proto.h index 6d79136d4..55b975ff7 100644 --- a/lisp/c/eus_proto.h +++ b/lisp/c/eus_proto.h @@ -175,8 +175,6 @@ extern pointer setval(context */*ctx*/, pointer /*sym*/, pointer /*val*/); extern pointer getfunc(context */*ctx*/, pointer /*f*/); extern pointer getfunc_closure(context */*ctx*/, pointer /*f*/); extern pointer getfunc_closure_noexcept(context */*ctx*/, pointer /*f*/); -extern pointer get_sym_func(pointer /*s*/); -extern void setfunc(pointer /*sym*/, pointer /*func*/); extern pointer *ovafptr(pointer /*o*/, pointer /*v*/); extern void bindspecial(context */*ctx*/, pointer /*sym*/, pointer /*newval*/); extern void unbindx(context */*ctx*/, int /*count*/); diff --git a/lisp/c/eval.c b/lisp/c/eval.c index 8bd4faa3f..bdf152b16 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -155,11 +155,6 @@ 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; diff --git a/lisp/c/specials.c b/lisp/c/specials.c index 62f46ed12..131aee3f4 100644 --- a/lisp/c/specials.c +++ b/lisp/c/specials.c @@ -1043,7 +1043,7 @@ register pointer *argv; #ifdef SPEC_DEBUG printf( "SETFUNC:" ); hoge_print_sub(argv[0]); hoge_print(argv[1]); #endif - setfunc(argv[0],argv[1]); + pointer_update(argv[0]->c.sym.spefunc,argv[1]); return(argv[1]);} pointer SYMFUNC(ctx,n,argv) diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index b38e49619..ba5632bf4 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -308,7 +308,7 @@ (send self :discard argc) (send self :push "w")) (:getfunc (sym) - (send self :push (format nil "(pointer)get_sym_func(fqv[~d])" + (send self :push (format nil "(pointer)getfunc_closure(ctx,fqv[~d])" (send self :quote-entry sym)))) ) From 8b67abbd28a04b72cfd5bcbeb4e5bfd08767f4ca Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 4 Jan 2023 18:16:40 +0900 Subject: [PATCH 373/387] Print form with s-expression formatting in unittest.l --- lib/llib/unittest.l | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/llib/unittest.l b/lib/llib/unittest.l index 1fc377073..6a126f72c 100644 --- a/lib/llib/unittest.l +++ b/lib/llib/unittest.l @@ -116,10 +116,10 @@ (cond ((derivedp failure error) (if result - (format *error-output* "~C[3~Cm[ERROR] test ~A failed at ~A" #x1b 49 + (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 ~A" #x1b 49 + (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)) From b21b21bc63283b201ce4a32ae5e647bf3353e1df Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 30 Dec 2022 16:00:01 +0900 Subject: [PATCH 374/387] Avoid segmentation fault when comparing unbound objects --- lisp/c/predicates.c | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/c/predicates.c b/lisp/c/predicates.c index 967fc5089..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); From e0ac920aff70bbbef715a85d83bdb06a874e771f Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Wed, 4 Jan 2023 07:56:39 +0900 Subject: [PATCH 375/387] Fix copy_object with fewer than 2 slots --- lisp/c/leo.c | 42 +++++++++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 15 deletions(-) diff --git a/lisp/c/leo.c b/lisp/c/leo.c index 6eea57163..bb9ebc5c0 100644 --- a/lisp/c/leo.c +++ b/lisp/c/leo.c @@ -552,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 (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) @@ -580,21 +589,21 @@ 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: - if (s>1) 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: if (s>0) clone->c.vec.v[0]=copyobj(ctx,x); @@ -612,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 (obj==NULL || isnum(obj) || pissymbol(obj) || pisclass(obj)) return; - x=obj->c.obj.iv[1]; + 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) Date: Thu, 16 Feb 2023 11:08:47 +0900 Subject: [PATCH 376/387] Release qsort_lock on type errors --- lisp/c/sequence.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/c/sequence.c b/lisp/c/sequence.c index 3ffc7e01d..366a345b2 100644 --- a/lisp/c/sequence.c +++ b/lisp/c/sequence.c @@ -1012,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 From 7976af87d9d3027222b47251e9acd6372bbe6b84 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 16 Feb 2023 17:52:18 +0900 Subject: [PATCH 377/387] Revert assoc :key behavior for backward compatibility (#436 and #450) --- lisp/c/lists.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/c/lists.c b/lisp/c/lists.c index fa637cd8a..218b29638 100644 --- a/lisp/c/lists.c +++ b/lisp/c/lists.c @@ -334,7 +334,8 @@ register pointer argv[]; if (islist(target)) { /*ignore non-pair elements*/ if (rassoc==NIL) temp=ccar(target); else temp=ccdr(target); - if (key!=NIL) temp=call1(ctx,key,temp); + if (key==NIL) temp=ccar(target); + else temp=call1(ctx,key,target); 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); From 74fd0ec54143d1f6ad76b530a1b05cc8cec50294 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 16 Feb 2023 18:22:20 +0900 Subject: [PATCH 378/387] Add *signal-handlers* and eussig for backward compatibility --- lisp/l/conditions.l | 19 +++++++++++++++++++ lisp/l/toplevel.l | 1 + 2 files changed, 20 insertions(+) diff --git a/lisp/l/conditions.l b/lisp/l/conditions.l index 5a813bf08..ba1ec6fc3 100644 --- a/lisp/l/conditions.l +++ b/lisp/l/conditions.l @@ -3,6 +3,7 @@ (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*) @@ -254,6 +255,24 @@ (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/toplevel.l b/lisp/l/toplevel.l index 4e2f114eb..e54eac2b9 100644 --- a/lisp/l/toplevel.l +++ b/lisp/l/toplevel.l @@ -283,6 +283,7 @@ (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 From ccc73a2a1a441b1cf2aacd76577a0b06b7da899b Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 16 Feb 2023 18:47:09 +0900 Subject: [PATCH 379/387] Add *error-handler* for backward compatibility --- lisp/c/eus.c | 22 +++++++++++++++++++++- lisp/l/eusstart.l | 2 +- lisp/l/exports.l | 2 +- 3 files changed, 23 insertions(+), 3 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index cfc5b5296..4b007ee26 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -127,7 +127,7 @@ pointer SELF; pointer CLASS; pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT; pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER; -pointer TOPLEVEL,QEVALHOOK,QEXITHOOK,FATALERROR; +pointer TOPLEVEL,QEVALHOOK,QEXITHOOK,ERRHANDLER,FATALERROR; pointer SIGNALS; pointer QUNBOUND,QDEBUG,QGCHOOK,QGCDEBUG; pointer QTHREADS; /* system:*threads* */ @@ -393,6 +393,25 @@ va_dcl 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(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_NOSLOT: case E_NOPACKAGE: case E_NOMETHOD: + case E_NOKEYPARAM: case E_READLABEL: case E_ILLCH: case E_NOCATCHER: + 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;} + /* call user's error handler function */ errhandler=getfunc_closure_noexcept(ctx, SIGNALS); @@ -715,6 +734,7 @@ static void initsymbols() PRLEVEL=deflocal(ctx,"*PRINT-LEVEL*",NIL,lisppkg); QREADTABLE=deflocal(ctx,"*READTABLE*",NIL,lisppkg); TOPLEVEL=defvar(ctx,"*TOPLEVEL*",NIL,lisppkg); + ERRHANDLER=deflocal(ctx,"*ERROR-HANDLER*",NIL,lisppkg); QEVALHOOK=deflocal(ctx,"*EVALHOOK*",NIL,lisppkg); QUNBOUND=intern(ctx,"*UNBOUND*",9,lisppkg); RANDSTATE=deflocal(ctx,"*RANDOM-STATE*",UNBOUND,lisppkg); diff --git a/lisp/l/eusstart.l b/lisp/l/eusstart.l index f4daa3ead..0ed126a3c 100644 --- a/lisp/l/eusstart.l +++ b/lisp/l/eusstart.l @@ -25,7 +25,7 @@ (export '(*print-case* *print-circle* *print-object* *print-structure* *print-length* *print-level* *readtable* *toplevel* *read-base* *print-base* - *evalhook* *debug* *exit-on-fatal-error* + *error-handler* *evalhook* *debug* *exit-on-fatal-error* *unbound* *random-state* *features* *package* *standard-input* *standard-output* diff --git a/lisp/l/exports.l b/lisp/l/exports.l index 22e773d71..981d932a4 100644 --- a/lisp/l/exports.l +++ b/lisp/l/exports.l @@ -22,7 +22,7 @@ (export '(*print-case* *print-circle* *print-object* *print-structure* *print-length* *print-level* *readtable* *toplevel* *read-base* *print-base* - *evalhook* *debug* + *error-handler* *evalhook* *debug* *unbound* *random-state* *features* *package* *standard-input* *standard-output* From 59547a22849ff7e55ea67035b476646ce7539905 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Thu, 16 Feb 2023 19:37:32 +0900 Subject: [PATCH 380/387] Add *signal-handlers* and *error-handler* documentation --- doc/jlatex/euslisp.hlp | 123 +++++++++++++++++++------------------ doc/jlatex/jevaluation.tex | 12 ++++ doc/latex/euslisp.hlp | 123 +++++++++++++++++++------------------ doc/latex/evaluation.tex | 13 ++++ 4 files changed, 151 insertions(+), 120 deletions(-) diff --git a/doc/jlatex/euslisp.hlp b/doc/jlatex/euslisp.hlp index 9be210004..48b34238b 100644 --- a/doc/jlatex/euslisp.hlp +++ b/doc/jlatex/euslisp.hlp @@ -539,66 +539,69 @@ "unix::sigint-received" 0 "jevaluation" 7276 4 "unix::sigcont-received" 0 "jevaluation" 7338 4 "unix:install-signal-handler" 3 "jevaluation" 7406 3 -"*prompt-string*" 5 "jevaluation" 11623 2 -"*program-name*" 5 "jevaluation" 11706 2 -"eustop" 2 "jevaluation" 11850 3 -"sigint-handler" 2 "jevaluation" 11929 3 -"euserror" 2 "jevaluation" 12100 3 -"reset" 2 "jevaluation" 12265 3 -"exit" 2 "jevaluation" 12397 3 -"*top-selector*" 5 "jevaluation" 12571 2 -"h" 2 "jevaluation" 12697 3 -"!" 2 "jevaluation" 12825 3 -"new-history" 2 "jevaluation" 13806 3 -"compile-file" 2 "jevaluation" 23323 3 -"compile" 2 "jevaluation" 24121 3 -"compile-method" 2 "jevaluation" 24474 3 -"compile-file-if-src-newer" 2 "jevaluation" 24929 3 -"compiler:*optimize*" 5 "jevaluation" 25230 2 -"compiler:*safety*" 5 "jevaluation" 25316 2 -"compiler:*verbose*" 5 "jevaluation" 25385 2 -"compiler:*type-check-declare*" 5 "jevaluation" 25581 2 -"compiler::compiler-implementation-version" 2 "jevaluation" 25781 3 -"load" 2 "jevaluation" 25998 3 -"load-files" 2 "jevaluation" 29919 3 -"*modules*" 5 "jevaluation" 30034 2 -"provide" 2 "jevaluation" 30138 3 -"require" 2 "jevaluation" 30555 3 -"system:binload" 2 "jevaluation" 31797 3 -"system::txtload" 2 "jevaluation" 32020 2 -"describe" 2 "jevaluation" 32123 3 -"describe-list" 2 "jevaluation" 32270 3 -"inspect" 3 "jevaluation" 32410 3 -"more" 2 "jevaluation" 32747 3 -"break" 2 "jevaluation" 33120 3 -"help" 2 "jevaluation" 33417 3 -"apropos" 2 "jevaluation" 33708 3 -"apropos-list" 2 "jevaluation" 34119 3 -"constants" 2 "jevaluation" 34264 3 -"variables" 2 "jevaluation" 34439 3 -"functions" 2 "jevaluation" 34632 3 -"btrace" 2 "jevaluation" 34819 3 -"step-hook" 2 "jevaluation" 34925 2 -"step" 2 "jevaluation" 34952 3 -"trace" 2 "jevaluation" 35091 3 -"untrace" 2 "jevaluation" 35280 3 -"timing" 3 "jevaluation" 35351 3 -"time" 3 "jevaluation" 35496 3 -"lisp::print-callstack" 2 "jevaluation" 35611 3 -"sys:list-callstack" 2 "jevaluation" 35852 3 -"sys:list-all-catchers" 2 "jevaluation" 36059 3 -"sys:list-all-blocks" 2 "jevaluation" 36137 3 -"sys:list-all-tags" 2 "jevaluation" 36213 3 -"sys:list-all-instances" 2 "jevaluation" 36296 3 -"sys:list-all-bindings" 2 "jevaluation" 36685 3 -"sys:list-all-special-bindings" 2 "jevaluation" 37032 3 -"sys:list-all-function-bindings" 2 "jevaluation" 37191 3 -"dump-object" 2 "jevaluation" 38197 2 -"dump-structure" 2 "jevaluation" 38245 3 -"dump-loadable-structure" 2 "jevaluation" 38400 3 -"sys:save" 2 "jevaluation" 39462 3 -"lisp-implementation-type" 2 "jevaluation" 42866 3 -"lisp-implementation-version" 2 "jevaluation" 42938 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:gctime" 2 "jsysfunc" 6520 3 "sys:alloc" 2 "jsysfunc" 6837 3 diff --git a/doc/jlatex/jevaluation.tex b/doc/jlatex/jevaluation.tex index d9cb2490f..5d4e35e90 100644 --- a/doc/jlatex/jevaluation.tex +++ b/doc/jlatex/jevaluation.tex @@ -145,6 +145,18 @@ \subsection{エラーとUnixシグナルをハンドリングする} コンディション{\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} \newpage diff --git a/doc/latex/euslisp.hlp b/doc/latex/euslisp.hlp index bd9987f1a..4c9a635bb 100644 --- a/doc/latex/euslisp.hlp +++ b/doc/latex/euslisp.hlp @@ -544,66 +544,69 @@ "unix::sigint-received" 0 "evaluation" 5970 4 "unix::sigcont-received" 0 "evaluation" 6032 4 "unix:install-signal-handler" 3 "evaluation" 6100 3 -"*prompt-string*" 5 "evaluation" 11528 2 -"*program-name*" 5 "evaluation" 11592 2 -"eustop" 2 "evaluation" 11704 3 -"sigint-handler" 2 "evaluation" 11776 3 -"euserror" 2 "evaluation" 11952 3 -"reset" 2 "evaluation" 12076 3 -"exit" 2 "evaluation" 12195 3 -"*top-selector*" 5 "evaluation" 12360 2 -"h" 2 "evaluation" 12487 3 -"!" 2 "evaluation" 12599 3 -"new-history" 2 "evaluation" 13457 3 -"compile-file" 2 "evaluation" 20978 3 -"compile" 2 "evaluation" 21659 3 -"compile-method" 2 "evaluation" 21908 3 -"compile-file-if-src-newer" 2 "evaluation" 22227 3 -"compiler:*optimize*" 5 "evaluation" 22448 2 -"compiler:*safety*" 5 "evaluation" 22508 2 -"compiler:*verbose*" 5 "evaluation" 22563 2 -"compiler:*type-check-declare*" 5 "evaluation" 22735 2 -"compiler::compiler-implementation-version" 2 "evaluation" 22878 3 -"load" 2 "evaluation" 23067 3 -"load-files" 2 "evaluation" 26494 3 -"*modules*" 5 "evaluation" 26596 2 -"provide" 2 "evaluation" 26685 3 -"require" 2 "evaluation" 27012 3 -"system:binload" 2 "evaluation" 27979 3 -"system::txtload" 2 "evaluation" 28171 2 -"describe" 2 "evaluation" 28268 3 -"describe-list" 2 "evaluation" 28401 3 -"inspect" 3 "evaluation" 28512 3 -"more" 2 "evaluation" 28757 3 -"break" 2 "evaluation" 29037 3 -"help" 2 "evaluation" 29241 3 -"apropos" 2 "evaluation" 29852 3 -"apropos-list" 2 "evaluation" 30221 3 -"constants" 2 "evaluation" 30351 3 -"variables" 2 "evaluation" 30500 3 -"functions" 2 "evaluation" 30654 3 -"btrace" 2 "evaluation" 30807 3 -"step-hook" 2 "evaluation" 30896 2 -"step" 2 "evaluation" 30923 3 -"trace" 2 "evaluation" 31047 3 -"untrace" 2 "evaluation" 31194 3 -"timing" 3 "evaluation" 31249 3 -"time" 3 "evaluation" 31380 3 -"lisp::print-callstack" 2 "evaluation" 31480 3 -"sys:list-callstack" 2 "evaluation" 31734 3 -"sys:list-all-catchers" 2 "evaluation" 31928 3 -"sys:list-all-blocks" 2 "evaluation" 32004 3 -"sys:list-all-tags" 2 "evaluation" 32078 3 -"sys:list-all-instances" 2 "evaluation" 32159 3 -"sys:list-all-bindings" 2 "evaluation" 32456 3 -"sys:list-all-special-bindings" 2 "evaluation" 32674 3 -"sys:list-all-function-bindings" 2 "evaluation" 32791 3 -"dump-object" 2 "evaluation" 33527 2 -"dump-structure" 2 "evaluation" 33575 3 -"dump-loadable-structure" 2 "evaluation" 33706 3 -"sys:save" 2 "evaluation" 34578 3 -"lisp-implementation-type" 2 "evaluation" 37288 3 -"lisp-implementation-version" 2 "evaluation" 37357 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 diff --git a/doc/latex/evaluation.tex b/doc/latex/evaluation.tex index d28d601c5..1c6efc548 100644 --- a/doc/latex/evaluation.tex +++ b/doc/latex/evaluation.tex @@ -145,6 +145,19 @@ \subsection{Handling Errors and Unix Signals} 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 From 1f13cbd3ecf596550de47ee9e02ba587323db9c6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Fri, 17 Feb 2023 09:09:32 +0900 Subject: [PATCH 381/387] Set vsp before getfunc_closure in compilation --- lisp/c/eval.c | 4 ++++ lisp/comp/trans.l | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/lisp/c/eval.c b/lisp/c/eval.c index bdf152b16..1691dee15 100644 --- a/lisp/c/eval.c +++ b/lisp/c/eval.c @@ -133,6 +133,8 @@ register pointer f; 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*/ @@ -140,6 +142,8 @@ register pointer f; /*must be a symbol*/ 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; diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index ba5632bf4..db80dc765 100644 --- a/lisp/comp/trans.l +++ b/lisp/comp/trans.l @@ -308,6 +308,10 @@ (send self :discard argc) (send self :push "w")) (:getfunc (sym) + ;; 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)))) ) From 0d97f432118143ce97b29062de75a078fcdd63e5 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 26 Mar 2023 15:23:07 +0900 Subject: [PATCH 382/387] Fix typos in README.md --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 68cd112ee..500c7a1b5 100644 --- a/README.md +++ b/README.md @@ -34,10 +34,10 @@ $ 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)) From 537dbca418a1d6483a427b5f4bfe98061953a8b8 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 26 Mar 2023 18:45:13 +0900 Subject: [PATCH 383/387] Move 'entry2' slot to compiled-code --- lisp/c/eus.c | 36 ++++++++++++------------------------ lisp/c/eus.h | 2 +- 2 files changed, 13 insertions(+), 25 deletions(-) diff --git a/lisp/c/eus.c b/lisp/c/eus.c index 4b007ee26..5a940692f 100644 --- a/lisp/c/eus.c +++ b/lisp/c/eus.c @@ -826,38 +826,26 @@ static void initclasses() "IDLE", "WAIT"); C_THREAD=speval(THREAD); /*13*/ +#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 - 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 - "ENV0","ENV1"); -#else - CLOSURE=basicclass("CLOSURE",C_CODE,&closurecp, -#if ARM // ARM uses entry2 in struct closure in eus.h - 2,"ENTRY2", -#else - 1, -#endif - "ENV1"); + 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*/ diff --git a/lisp/c/eus.h b/lisp/c/eus.h index da639eaba..b934ae293 100644 --- a/lisp/c/eus.h +++ b/lisp/c/eus.h @@ -244,7 +244,7 @@ struct fcode { /*foreign function code*/ 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;}; From e86ddeda4a59f06247b5bdac2da528a067bcf9bd Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Sun, 26 Mar 2023 21:44:26 +0900 Subject: [PATCH 384/387] Use 'Char' in reader.c for ARM compatibility --- lisp/c/reader.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/lisp/c/reader.c b/lisp/c/reader.c index ebd9d2a77..baaa7c657 100644 --- a/lisp/c/reader.c +++ b/lisp/c/reader.c @@ -471,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) /* #| ... |# */ @@ -501,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; @@ -554,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);} @@ -736,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;} From 83b684f0f5ea89d767be2cb5e532344dcfb855c6 Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 27 Mar 2023 19:31:37 +0900 Subject: [PATCH 385/387] Remove duplicate LISTFUNCTIONBINDINGS --- lisp/c/sysfunc.c | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/lisp/c/sysfunc.c b/lisp/c/sysfunc.c index df389246c..6c77cfe1c 100644 --- a/lisp/c/sysfunc.c +++ b/lisp/c/sysfunc.c @@ -803,25 +803,6 @@ pointer *argv; ff=ff->c.ffp.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++; - if (ff==ff->c.ffp.next) break; - ff=ff->c.ffp.next;} - return(stacknlist(ctx,i));} - pointer LISTSPECIALBINDINGS(ctx,n,argv) register context *ctx; int n; From 1c3239efb8d9e9f6ca336abd87564dec156f6cea Mon Sep 17 00:00:00 2001 From: Guilherme Affonso Date: Mon, 27 Mar 2023 19:33:59 +0900 Subject: [PATCH 386/387] Revert 'Return variable name in defparameter and defconstant' --- lisp/l/common.l | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/lisp/l/common.l b/lisp/l/common.l index cf6866d23..902e9254f 100644 --- a/lisp/l/common.l +++ b/lisp/l/common.l @@ -139,15 +139,11 @@ (defmacro defparameter (var init &optional (doc nil)) (unless (symbolp var) (error type-error "symbol expected")) - `(progn - (send ',var :global ,init ,doc) - ',var)) + `(send ',var :global ,init ,doc)) (defmacro defconstant (sym val &optional doc) (unless (symbolp sym) (error type-error "symbol expected")) - `(progn - (send ',sym :constant ,val ,doc) - ',sym)) + `(send ',sym :constant ,val ,doc) ) (defmacro dotimes (vars &rest forms) From bcb2afec9b0983e2b119605def5c4a37fb301f02 Mon Sep 17 00:00:00 2001 From: Kei Okada Date: Wed, 29 Mar 2023 15:39:17 +0900 Subject: [PATCH 387/387] fix CI (euslisp-dfsg check) for eus10 --- .github/workflows/dfsg-deban-eus10.patch | 46 ++++++++++++++++++++++++ .travis.sh | 1 + 2 files changed, 47 insertions(+) create mode 100644 .github/workflows/dfsg-deban-eus10.patch 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/.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;