Menu
▾
▴
clisp-cvs digest, Vol 1 #928 - 6 msgs
|
From: <cli...@li...> - 2005-01-26 15:55:24
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/tests ChangeLog,1.310,1.311 setf.tst,1.23,1.24 (Bruno Haible) 2. clisp/src ChangeLog,1.4152,1.4153 places.lisp,1.63,1.64 (Bruno Haible) 3. clisp/doc impbody.xml,1.354,1.355 (Bruno Haible) 4. clisp/src NEWS,1.229,1.230 (Bruno Haible) 5. clisp/src ChangeLog,1.4153,1.4154 NEWS,1.230,1.231 io.d,1.280,1.281 spvw_circ.d,1.32,1.33 predtype.d,1.130,1.131 lispbibl.d,1.607,1.608 constobj.d,1.168,1.169 (Bruno Haible) 6. clisp/src compiler.lisp,1.247,1.248 ChangeLog,1.4154,1.4155 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests ChangeLog,1.310,1.311 setf.tst,1.23,1.24 Date: Wed, 26 Jan 2005 13:02:44 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26998/tests Modified Files: ChangeLog setf.tst Log Message: Fix (SETF (VALUES-LIST ...) ...). Index: setf.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/setf.tst,v retrieving revision 1.23 retrieving revision 1.24 diff -u -d -r1.23 -r1.24 --- setf.tst 24 Jan 2005 10:36:15 -0000 1.23 +++ setf.tst 26 Jan 2005 13:02:42 -0000 1.24 @@ -537,6 +537,9 @@ (VALUES (SETQ L (FOO))) |# +(macroexpand-1 '(setf (values-list l) (foo))) +(VALUES-LIST (SETF L (MULTIPLE-VALUE-LIST (FOO)))) + ;; Check that the PUSH macroexpander doesn't blindly call subst or sublis. (define-setf-expander bothvars (x y) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.310 retrieving revision 1.311 diff -u -d -r1.310 -r1.311 --- ChangeLog 24 Jan 2005 10:36:15 -0000 1.310 +++ ChangeLog 26 Jan 2005 13:02:41 -0000 1.311 @@ -1,3 +1,7 @@ +2005-01-26 Bruno Haible <br...@cl...> + + * setf.tst: Add a test for SETF VALUES-LIST. + 2005-01-21 Bruno Haible <br...@cl...> * alltest.tst: At the end, clean up symbols affected by side-effects. --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4152,1.4153 places.lisp,1.63,1.64 Date: Wed, 26 Jan 2005 13:02:43 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26998/src Modified Files: ChangeLog places.lisp Log Message: Fix (SETF (VALUES-LIST ...) ...). Index: places.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/places.lisp,v retrieving revision 1.63 retrieving revision 1.64 diff -u -d -r1.63 -r1.64 --- places.lisp 25 Dec 2004 13:27:22 -0000 1.63 +++ places.lisp 26 Jan 2005 13:02:41 -0000 1.64 @@ -795,56 +795,57 @@ (when (and (consp place) (symbolp (car place))) (when (global-in-fenv-p (car place) (svref env 1)) ; Operator nicht lokal definiert - (let ((plist-info (get (first place) 'SYSTEM::SETF-EXPANDER))) - (when plist-info - (return-from setf - (cond ((symbolp plist-info) ; Symbol kommt von kurzem DEFSETF - `(,plist-info ,@(cdr place) ,value) - ) - ((and (eq (first place) 'THE) (eql (length place) 3)) - `(SETF ,(third place) (THE ,(second place) ,value)) - ) - ((and (eq (first place) 'VALUES-LIST) (eql (length place) 2)) - `(VALUES-LIST - (SETF ,(second place) - (MULTIPLE-VALUE-LIST ,value) - ) ) ) - (t - (multiple-value-bind (temps subforms stores setterform getterform) - (get-setf-expansion place env) - (declare (ignore getterform)) - (let ((bindlist (mapcar #'list temps subforms))) - (if (= (length stores) 1) - ;; 1 store variable - (wrap-let* (nconc bindlist - (list `(,(first stores) ,value)) - ) - setterform - ) - ;; mehrere Store-Variable - (if ;; Hat setterform die Gestalt - ;; (VALUES (SETQ v1 store1) ...) ? - (and (consp setterform) - (eq (car setterform) 'VALUES) - (do ((str stores (cdr str)) - (sqr (cdr setterform) (cdr sqr))) - ((or (null str) (null sqr)) - (and (null str) (null sqr))) - (unless (simple-assignment-p env (car sqr) (list (car str))) - (return nil) - ) ) ) - (let ((vlist (mapcar #'second (rest setterform)))) - `(LET* ,bindlist - (MULTIPLE-VALUE-SETQ ,vlist ,value) - (VALUES ,@vlist) - ) + (if (and (eq (first place) 'VALUES-LIST) (eql (length place) 2)) + (return-from setf + `(VALUES-LIST + (SETF ,(second place) (MULTIPLE-VALUE-LIST ,value)) + ) + ) + (let ((plist-info (get (first place) 'SYSTEM::SETF-EXPANDER))) + (when plist-info + (return-from setf + (cond ((symbolp plist-info) ; Symbol kommt von kurzem DEFSETF + `(,plist-info ,@(cdr place) ,value) + ) + ((and (eq (first place) 'THE) (eql (length place) 3)) + `(SETF ,(third place) (THE ,(second place) ,value)) + ) + (t + (multiple-value-bind (temps subforms stores setterform getterform) + (get-setf-expansion place env) + (declare (ignore getterform)) + (let ((bindlist (mapcar #'list temps subforms))) + (if (= (length stores) 1) + ;; 1 store variable + (wrap-let* (nconc bindlist + (list `(,(first stores) ,value)) + ) + setterform ) - (wrap-let* bindlist - `(MULTIPLE-VALUE-BIND ,stores ,value - ,setterform - ) ) - )) ) ) ) - ) ) ) ) ) ) + ;; mehrere Store-Variable + (if ;; Hat setterform die Gestalt + ;; (VALUES (SETQ v1 store1) ...) ? + (and (consp setterform) + (eq (car setterform) 'VALUES) + (do ((str stores (cdr str)) + (sqr (cdr setterform) (cdr sqr))) + ((or (null str) (null sqr)) + (and (null str) (null sqr))) + (unless (simple-assignment-p env (car sqr) (list (car str))) + (return nil) + ) ) ) + (let ((vlist (mapcar #'second (rest setterform)))) + `(LET* ,bindlist + (MULTIPLE-VALUE-SETQ ,vlist ,value) + (VALUES ,@vlist) + ) + ) + (wrap-let* bindlist + `(MULTIPLE-VALUE-BIND ,stores ,value + ,setterform + ) ) + )) ) ) ) + ) ) ) ) ) ) ) ;; 2. Schritt: macroexpandieren (when (eq place (setq place (macroexpand-1 place env))) (return) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4152 retrieving revision 1.4153 diff -u -d -r1.4152 -r1.4153 --- ChangeLog 26 Jan 2005 01:26:45 -0000 1.4152 +++ ChangeLog 26 Jan 2005 13:02:37 -0000 1.4153 @@ -1,3 +1,8 @@ +2005-01-26 Bruno Haible <br...@cl...> + + * places.lisp (setf): Handle (SETF (VALUES-LIST ...) ...) correctly, + although there can be no SETF expander for VALUES-LIST. + 2005-01-25 Sam Steingold <sd...@gn...> * stream.d (MAKE-STREAM): handle_to_stream() already duplicates --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/doc impbody.xml,1.354,1.355 Date: Wed, 26 Jan 2005 13:11:29 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29049 Modified Files: impbody.xml Log Message: Add a note about the VALUES-LIST place. Index: impbody.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impbody.xml,v retrieving revision 1.354 retrieving revision 1.355 diff -u -d -r1.354 -r1.355 --- impbody.xml 24 Jan 2005 17:35:54 -0000 1.354 +++ impbody.xml 26 Jan 2005 13:11:26 -0000 1.355 @@ -630,7 +630,9 @@ <varlistentry><term>&values-list;</term> <listitem><simpara><code>(&setf; (&values-list; &list-r;) &form-r;)</code> is equivalent to <code>(&values-list; (&setf; &list-r; - (&multiple-value-list; &form-r;)))</code> + (&multiple-value-list; &form-r;)))</code>. Note that this &place; is + restricted: it can only be used in &setf;, &letf;, &letf-star;, not + in other positions. </simpara></listitem></varlistentry> </variablelist></para> --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src NEWS,1.229,1.230 Date: Wed, 26 Jan 2005 13:21:39 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31212 Modified Files: NEWS Log Message: Mention issue DECLARATION-SCOPE. Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.229 retrieving revision 1.230 diff -u -d -r1.229 -r1.230 --- NEWS 25 Jan 2005 09:37:51 -0000 1.229 +++ NEWS 26 Jan 2005 13:21:36 -0000 1.230 @@ -138,6 +138,10 @@ and vertical bars. * ANSI CL compliance issues: + + Issue <DECLARATION-SCOPE:NO-HOISTING> is implemented: The scope of + declarations that don't apply to bindings, such as free SPECIAL, NOTINLINE + or OPTIMIZE declarations, includes only the body forms and no longer + includes the initforms of the LAMBDA/LET/LET*/MULTIPLE-VALUE-BIND bindings. + Vectors of element type NIL are now strings in all aspects. But the type BASE-STRING does _not_ include vectors of element type NIL. + TYPE-OF now returns STANDARD-CHAR instead of CHARACTER when possible. --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4153,1.4154 NEWS,1.230,1.231 io.d,1.280,1.281 spvw_circ.d,1.32,1.33 predtype.d,1.130,1.131 lispbibl.d,1.607,1.608 constobj.d,1.168,1.169 Date: Wed, 26 Jan 2005 13:25:51 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31931/src Modified Files: ChangeLog NEWS io.d spvw_circ.d predtype.d lispbibl.d constobj.d Log Message: Allow bignums as read-label values. Index: io.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/io.d,v retrieving revision 1.280 retrieving revision 1.281 diff -u -d -r1.280 -r1.281 --- io.d 25 Jan 2005 14:35:08 -0000 1.280 +++ io.d 26 Jan 2005 13:25:29 -0000 1.281 @@ -2216,7 +2216,7 @@ # UP: disentangles #n# - References to #n= - markings in an Object. # > value of SYS::*READ-REFERENCE-TABLE*: # Aliste of Pairs (marking . marked Object), where -# each marking is an Object #<READ-LABEL n>. +# each marking is an object #<READ-LABEL n>. # > obj: Object # < result: destructively modified Object without References local object make_references (object obj) { @@ -2224,7 +2224,8 @@ # SYS::*READ-REFERENCE-TABLE* = NIL -> nothing to do: if (nullp(alist)) { return obj; - } else { # check, if SYS::*READ-REFERENCE-TABLE* is an Aliste: + } else { + # Check if SYS::*READ-REFERENCE-TABLE* is an alist: { var object alistr = alist; # run through list while (consp(alistr)) { # each List-Element must be a Cons: @@ -3581,20 +3582,16 @@ # #'(lambda (stream sub-char n) # (if *read-suppress* # (if n -# (if (sys::fixnump n) -# (let* ((label (make-internal-label n)) -# (h (assoc label sys::*read-reference-table* :test #'eq))) -# (if (consp h) -# (error "~S of ~S: Label #~S= must not be defined twice." 'read stream n) -# (progn -# (push (setq h (cons label label)) sys::*read-reference-table*) -# (let ((obj (read stream t nil t))) -# (if (eq obj label) -# (error "~S of ~S: #~S= #~S# is not allowed." 'read stream n n) -# (setf (cdr h) obj) -# ) ) ) ) ) -# (error "~S of ~S: Label #~S= too big" 'read stream n) -# ) +# (let ((h (assoc n sys::*read-reference-table* :test #'read-label-equal))) +# (if (consp h) +# (error "~S of ~S: Label #~S= must not be defined twice." 'read stream n) +# (let ((label (make-read-label n))) +# (push (setq h (cons label label)) sys::*read-reference-table*) +# (let ((obj (read stream t nil t))) +# (if (equal obj label) +# (error "~S of ~S: #~S= #~S# is not allowed." 'read stream n n) +# (setf (cdr h) obj) +# ) ) ) ) ) # (error "~S of ~S: Between # and = a number must be specified." 'read stream) # ) # (values) ; no values (comment) @@ -3604,24 +3601,21 @@ # #'(lambda (stream sub-char n) # (unless *read-suppress* # (if n -# (if (sys::fixnump n) -# (let* ((label (make-internal-label n)) -# (h (assoc label sys::*read-reference-table* :test #'eq))) -# (if (consp h) -# label ; will be disentangled later -# ; (you could also return (cdr h) ) -# (error "~S of ~S: Label #~S= is not defined." 'read stream n) -# ) -# (error "~S of ~S: Label #~S# too big" 'read stream n) -# ) +# (let ((h (assoc n sys::*read-reference-table* :test #'read-label-equal))) +# (if (consp h) +# (car h) ; the label, will be disentangled later +# ; (you could also return (cdr h) ) +# (error "~S of ~S: Label #~S= is not defined." 'read stream n) +# ) ) # (error "~S of ~S: Between # and # a number must be specified." 'read stream) # ) ) ) ) # UP: creates an internal Label and looks it up in *READ-REFERENCE-TABLE*. # lookup_label() # > stack layout: Stream, sub-char, n. -# < result: (or (assoc label sys::*read-reference-table* :test #'eq) label) -local object lookup_label (void) { +# < result: (or (assoc n sys::*read-reference-table* :test #'read-label-equal) label) +# can trigger GC +local maygc object lookup_label (void) { var object n = STACK_0; if (nullp(n)) { # not specified? pushSTACK(STACK_2); # STREAM-ERROR slot STREAM @@ -3631,28 +3625,34 @@ fehler(reader_error, GETTEXT("~S from ~S: a number must be given between #"" and ~C")); } - # n is an Integer >=0 - if (!small_read_label_integer_p(n)) { # n is too big - pushSTACK(STACK_2); # STREAM-ERROR slot STREAM - pushSTACK(STACK_(1+1)); # sub-char - pushSTACK(STACK_(0+2)); # n - pushSTACK(STACK_(2+3)); # Stream - pushSTACK(S(read)); - fehler(reader_error,GETTEXT("~S from ~S: label #~S? too large")); - } - var object label = make_small_read_label(posfixnum_to_L(n)); # Internal-Label with Nummer n + # n is an Integer >=0. var object alist = # value of SYS::*READ-REFERENCE-TABLE* Symbol_value(S(read_reference_table)); - # execute (assoc label alist :test #'eq): + # Execute (assoc n alist :test #'read-label-equal): + var bool smallp = small_read_label_integer_p(n); + var object label = (smallp ? make_small_read_label(posfixnum_to_L(n)) : nullobj); while (consp(alist)) { var object acons = Car(alist); # List-element if (!consp(acons)) goto bad_reftab; # must be a Cons ! - if (eq(Car(acons),label)) # its CAR = label ? - return acons; # yes -> fertig + var object key = Car(acons); # its CAR is a read-label + if (smallp + ? eq(key,label) # is it = <READ-LABEL n> ? + : big_read_label_p(key) && eql(TheBigReadLabel(key)->brl_value,n)) + return acons; # yes -> done alist = Cdr(alist); } - if (nullp(alist)) # List-end with NIL ? - return label; # yes -> (assoc ...) = NIL -> finished with label + if (nullp(alist)) { # List-end with NIL ? + # yes -> (assoc ...) = NIL -> create read-label with number n: + if (smallp) + return label; + else { + # This is the extremely rare case that n is so large that a BigReadLabel + # is needed. + label = allocate_big_read_label(); + TheBigReadLabel(label)->brl_value = STACK_0; + return label; + } + } bad_reftab: # value of SYS::*READ-REFERENCE-TABLE* is no Alist pushSTACK(Symbol_value(S(read_reference_table))); # value of SYS::*READ-REFERENCE-TABLE* pushSTACK(S(read_reference_table)); # SYS::*READ-REFERENCE-TABLE* @@ -3668,10 +3668,10 @@ VALUES0; skipSTACK(3); return; } - # create Label and lookup in Table: + # Create label and lookup in table: var object lookup = lookup_label(); if (consp(lookup)) { - # found -> has already been there -> error: + # Found -> has already been there -> error: pushSTACK(STACK_2); # STREAM-ERROR slot STREAM pushSTACK(STACK_(0+1)); # n pushSTACK(STACK_(2+2)); # Stream @@ -3679,34 +3679,36 @@ fehler(reader_error, GETTEXT("~S from ~S: label #~S= may not be defined twice")); } else { - # lookup = label, not jeopardized by GC. + # lookup = label. + pushSTACK(lookup); + # Stack layout: stream, sub-char, n, label. # (push (setq h (cons label label)) sys::*read-reference-table*) : - var gcv_object_t* stream_ = check_stream_arg(&STACK_2); + var gcv_object_t* stream_ = check_stream_arg(&STACK_3); { var object new_cons = allocate_cons(); - Car(new_cons) = Cdr(new_cons) = lookup; # h = (cons label label) + Car(new_cons) = Cdr(new_cons) = STACK_0; # h = (cons label label) pushSTACK(new_cons); # save h } + # Stack layout: stream, sub-char, n, label, h. { var object new_cons = allocate_cons(); # new List-Cons Car(new_cons) = STACK_0; Cdr(new_cons) = Symbol_value(S(read_reference_table)); Symbol_value(S(read_reference_table)) = new_cons; } - var object obj = read_recursive_no_dot(stream_); # read Objekt - var object h = popSTACK(); - if (eq(obj,Car(h))) { # read Objekt = (car h) = label ? + var object obj = read_recursive_no_dot(stream_); # read an object + if (eq(obj,STACK_1)) { # read object = label ? # yes -> cyclic Definition -> Error pushSTACK(*stream_); # STREAM-ERROR slot STREAM - pushSTACK(STACK_(0+1)); # n - pushSTACK(STACK_(0+2)); # n + pushSTACK(STACK_(2+1)); # n + pushSTACK(STACK_(2+2)); # n pushSTACK(*stream_); # Stream pushSTACK(S(read)); fehler(reader_error,GETTEXT("~S from ~S: #~S= #~S#"" is illegal")); } - # insert read Objekt as (cdr h): - Cdr(h) = obj; - VALUES1(obj); skipSTACK(3); + # Insert read object as (cdr h): + Cdr(STACK_0) = obj; + VALUES1(obj); skipSTACK(5); } } @@ -3716,9 +3718,10 @@ VALUES1(NIL); skipSTACK(3); return; } - /* construct Label and lookup in Table: */ + /* Lookup in table: */ var object lookup = lookup_label(); - if (consp(lookup)) { /* found -> return Label as read object: */ + if (consp(lookup)) { + /* Found -> return label as read object: */ VALUES1(Car(lookup)); skipSTACK(3); } else { /* not found */ pushSTACK(STACK_2); # STREAM-ERROR slot STREAM @@ -8448,11 +8451,10 @@ write_sstring_case(stream_,O(printstring_read_label)); # "READ-LABEL" JUSTIFY_SPACE; JUSTIFY_LAST(true); -#ifdef TYPECODES - pr_uint(stream_,(as_oint(obj) >> (oint_data_shift+1)) & (bit(oint_data_len-2)-1)); # print bits 21..0 decimally -#else - pr_uint(stream_,(as_oint(obj) >> oint_data_shift) & (bit(oint_data_len)-1)); # print bits decimally -#endif + var object n = (orecordp(obj) # BigReadLabel or Small-Read-Label? + ? TheBigReadLabel(obj)->brl_value + : small_read_label_value(obj)); + print_integer(n,10,stream_); # print n in decimal JUSTIFY_END_FILL; UNREADABLE_END; } @@ -8978,6 +8980,9 @@ } LEVEL_END; break; + case Rectype_BigReadLabel: # #<READ-LABEL n> + pr_readlabel(stream_,obj); + break; case Rectype_Encoding: # #<ENCODING [charset] line-terminator> CHECK_PRINT_READABLY(obj); LEVEL_CHECK; Index: spvw_circ.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_circ.d,v retrieving revision 1.32 retrieving revision 1.33 diff -u -d -r1.32 -r1.33 --- spvw_circ.d 25 Jan 2005 09:19:32 -0000 1.32 +++ spvw_circ.d 26 Jan 2005 13:25:45 -0000 1.33 @@ -1321,6 +1321,25 @@ default: ; } #endif + if (Record_type(obj) == Rectype_BigReadLabel) { + # BigReadLabel + # Search read-label obj in the alist: + var object alist = env->alist; + while (consp(alist)) { + var object acons = Car(alist); + if (eq(Car(acons),obj)) { + # Found. + # Replace *ptr = obj = (car acons) with (cdr acons), but + # leave the mark bit untouched: + *ptr = (marked(ptr) ? with_mark_bit(Cdr(acons)) : (object)Cdr(acons)); + return; + } + alist = Cdr(alist); + } + # not found -> abort + env->bad = obj; + longjmp(env->abbruch_context,true); + } if (mlb_add(&env->bitmap,obj)) # object already marked? return; # On replacement of Read-Labels in Hash-Tables their structure @@ -1350,14 +1369,14 @@ case_small_read_label: # Small-Read-Label { - # search Read-Label obj in the Alist: + # Search read-label obj in the alist: var object alist = env->alist; while (consp(alist)) { var object acons = Car(alist); if (eq(Car(acons),obj)) { - # found - # replace *ptr = obj = (car acons) with (cdr acons) , - # but leave the mark bit untouched: + # Found. + # Replace *ptr = obj = (car acons) with (cdr acons), but + # leave the mark bit untouched: *ptr = (marked(ptr) ? with_mark_bit(Cdr(acons)) : (object)Cdr(acons)); return; } @@ -1507,6 +1526,25 @@ default: ; } #endif + if (Record_type(obj) == Rectype_BigReadLabel) { + # BigReadLabel + # Search read-label obj in the alist: + var object alist = subst_circ_alist; + while (consp(alist)) { + var object acons = Car(alist); + if (eq(Car(acons),obj)) { + # Found. + # Replace *ptr = obj = (car acons) with (cdr acons): + *ptr = Cdr(acons); + return; + } + alist = Cdr(alist); + } + # not found -> abort + subst_circ_bad = obj; + begin_longjmp_call(); + longjmp(subst_circ_jmpbuf,true); + } # traverse all elements: { var uintC len = Record_nonweak_length(obj); @@ -1529,13 +1567,13 @@ case_small_read_label: # Small-Read-Label { - # search Read-Label obj in the Alist: + # Search read-label obj in the alist: var object alist = subst_circ_alist; while (consp(alist)) { var object acons = Car(alist); if (eq(Car(acons),obj)) { - # found - # replace *ptr = obj = (car acons) with (cdr acons) : + # Found. + # Replace *ptr = obj = (car acons) with (cdr acons): *ptr = Cdr(acons); return; } @@ -1681,6 +1719,25 @@ default: ; } #endif + if (Record_type(obj) == Rectype_BigReadLabel) { + # BigReadLabel + # Search read-label obj in the alist: + var object alist = subst_circ_alist; + while (consp(alist)) { + var object acons = Car(alist); + if (eq(Car(acons),obj)) { + # Found. + # Replace *ptr = obj = (car acons) with (cdr acons), but + # leave the mark bit untouched: + *ptr = (marked(ptr) ? with_mark_bit(Cdr(acons)) : (object)Cdr(acons)); + return; + } + alist = Cdr(alist); + } + # not found -> abort + subst_circ_bad = obj; + longjmp(subst_circ_jmpbuf,true); + } if (marked(TheRecord(obj))) # object already marked? return; mark(TheRecord(obj)); # mark @@ -1711,14 +1768,14 @@ case_small_read_label: # Small-Read-Label { - # search Read-Label obj in the Alist: + # Search read-label obj in the Alist: var object alist = subst_circ_alist; while (consp(alist)) { var object acons = Car(alist); if (eq(Car(acons),obj)) { - # found - # replace *ptr = obj = (car acons) with (cdr acons) , - # but leave the mark bit untouched: + # Found. + # Replace *ptr = obj = (car acons) with (cdr acons), but + # leave the mark bit untouched: *ptr = (marked(ptr) ? with_mark_bit(Cdr(acons)) : (object)Cdr(acons)); return; } @@ -1820,6 +1877,8 @@ default: ; } #endif + if (Record_type(obj) == Rectype_BigReadLabel) + return; if (!marked(TheRecord(obj))) # already unmarked? return; unmark(TheRecord(obj)); # unmark Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.230 retrieving revision 1.231 diff -u -d -r1.230 -r1.231 --- NEWS 26 Jan 2005 13:21:36 -0000 1.230 +++ NEWS 26 Jan 2005 13:25:29 -0000 1.231 @@ -206,6 +206,8 @@ contain a host specification. + The PRINT-UNREADABLE macro prints extraneous spaces if CUSTOM:*PRINT-UNREADABLE-ANSI* is true. + + In the #n= and #n# reader syntax, the integer n may now be larger than + 7 digits. Thanks to Paul F. Dietz <di...@dl...> and his ANSI compliance suite, which helped detect some of these deficiencies. Thanks to Yuji Minejima <ggb...@ni...> and his ANSI compliance Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4153 retrieving revision 1.4154 diff -u -d -r1.4153 -r1.4154 --- ChangeLog 26 Jan 2005 13:02:37 -0000 1.4153 +++ ChangeLog 26 Jan 2005 13:25:28 -0000 1.4154 @@ -1,3 +1,25 @@ +2005-01-22 Bruno Haible <br...@cl...> + + Allow bignums as read-label values. + * lispbibl.d (Rectype_BigReadLabel): New enum item. + (BigReadLabel): New type. + (bigreadlabel_length): New macro. + (small_read_label_value): New macro. + (TheBigReadLabel): New macro. + (big_read_label_p, allocate_big_read_label): New macros. + * spvw_circ.d (subst, subst_circ_mark): Support BigReadLabel. + (subst_circ_unmark): Update. + * io.d (lookup_label): Support big integers as well. Can trigger GC + now. + (label_definition_reader): Update. + (pr_readlabel): Use small_read_label_value. Add support for + BigReadLabel. + (pr_orecord): Support BigReadLabel. + * predtype.d (TYPE-OF, CLASS-OF): Add support for BigReadLabel. + (enum_hs_big_read_label): New enum value. + (heap_statistics_mapper): Add support for BigReadLabel. + Found by Paul Dietz's ansi-tests test suite. + 2005-01-26 Bruno Haible <br...@cl...> * places.lisp (setf): Handle (SETF (VALUES-LIST ...) ...) correctly, Index: constobj.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constobj.d,v retrieving revision 1.168 retrieving revision 1.169 diff -u -d -r1.168 -r1.169 --- constobj.d 25 Jan 2005 14:35:12 -0000 1.168 +++ constobj.d 26 Jan 2005 13:25:48 -0000 1.169 @@ -258,6 +258,7 @@ LISPOBJ(hs_global_symbol_macro,"EXT::GLOBAL-SYMBOL-MACRO") LISPOBJ(hs_macro,"SYS::MACRO") LISPOBJ(hs_function_macro,"EXT::FUNCTION-MACRO") + LISPOBJ(hs_big_read_label,"SYS::READ-LABEL") LISPOBJ(hs_encoding,"EXT::ENCODING") #ifdef FOREIGN LISPOBJ(hs_foreign_pointer,"EXT::FOREIGN-POINTER") Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.607 retrieving revision 1.608 diff -u -d -r1.607 -r1.608 --- lispbibl.d 25 Jan 2005 14:35:06 -0000 1.607 +++ lispbibl.d 26 Jan 2005 13:25:46 -0000 1.608 @@ -4251,6 +4251,7 @@ Rectype_GlobalSymbolmacro, Rectype_Macro, Rectype_FunctionMacro, + Rectype_BigReadLabel, Rectype_Encoding, Rectype_Fpointer, # only used #ifdef FOREIGN #ifdef DYNAMIC_FFI @@ -5228,6 +5229,13 @@ } * FunctionMacro; #define functionmacro_length ((sizeof(*(FunctionMacro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t)) +# BigReadLabel +typedef struct { + XRECORD_HEADER + gcv_object_t brl_value _attribute_aligned_object_; +} * BigReadLabel; +#define bigreadlabel_length ((sizeof(*(BigReadLabel)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t)) + # Encoding typedef struct { XRECORD_HEADER @@ -5998,10 +6006,14 @@ type_data_object(system_type, ((uintL)(n)<<1) + bit(0)) #define small_read_label_integer_p(obj) \ (posfixnump(obj) && (posfixnum_to_L(obj) < bit(oint_data_len-2))) + #define small_read_label_value(obj) \ + fixnum((as_oint(obj) >> (oint_data_shift+1)) & (bit(oint_data_len-2)-1)) #else #define make_small_read_label(n) \ type_data_object(small_read_label_type, (uintL)(n)) #define small_read_label_integer_p(obj) posfixnump(obj) + #define small_read_label_value(obj) \ + fixnum((as_oint(obj) >> oint_data_shift) & (bit(oint_data_len)-1)) #endif # Machine pointers: @@ -6154,6 +6166,7 @@ #define TheGlobalSymbolmacro(obj) ((GlobalSymbolmacro)(type_pointable(orecord_type,obj))) #define TheMacro(obj) ((Macro)(type_pointable(orecord_type,obj))) #define TheFunctionMacro(obj) ((FunctionMacro)(type_pointable(orecord_type,obj))) + #define TheBigReadLabel(obj) ((BigReadLabel)(type_pointable(orecord_type,obj))) #define TheEncoding(obj) ((Encoding)(type_pointable(orecord_type,obj))) #ifdef FOREIGN #define TheFpointer(obj) ((Fpointer)(type_pointable(orecord_type,obj))) @@ -6313,6 +6326,7 @@ #define TheGlobalSymbolmacro(obj) ((GlobalSymbolmacro)(ngci_pointable(obj)-varobject_bias)) #define TheMacro(obj) ((Macro)(ngci_pointable(obj)-varobject_bias)) #define TheFunctionMacro(obj) ((FunctionMacro)(ngci_pointable(obj)-varobject_bias)) + #define TheBigReadLabel(obj) ((BigReadLabel)(ngci_pointable(obj)-varobject_bias)) #define TheEncoding(obj) ((Encoding)(ngci_pointable(obj)-varobject_bias)) #ifdef FOREIGN #define TheFpointer(obj) ((Fpointer)(ngci_pointable(obj)-varobject_bias)) @@ -6904,6 +6918,10 @@ #define functionmacrop(obj) \ (orecordp(obj) && (Record_type(obj) == Rectype_FunctionMacro)) +# Test for BigReadLabel +#define big_read_label_p(obj) \ + (orecordp(obj) && (Record_type(obj) == Rectype_BigReadLabel)) + # Test for Encoding #define encodingp(obj) \ (orecordp(obj) && (Record_type(obj) == Rectype_Encoding)) @@ -9052,6 +9070,14 @@ allocate_xrecord(0,Rectype_FunctionMacro,functionmacro_length,0,orecord_type) # is used by RECORD +# UP: allocates a BigReadLabel +# allocate_big_read_label() +# < result: a fresh BigReadLabel +# can trigger GC +#define allocate_big_read_label() \ + allocate_xrecord(0,Rectype_BigReadLabel,bigreadlabel_length,0,orecord_type) +# is used by IO + # UP: allocates an Encoding # allocate_encoding() # < result: a fresh Encoding Index: predtype.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/predtype.d,v retrieving revision 1.130 retrieving revision 1.131 diff -u -d -r1.130 -r1.131 --- predtype.d 25 Jan 2005 09:19:36 -0000 1.130 +++ predtype.d 26 Jan 2005 13:25:46 -0000 1.131 @@ -1660,6 +1660,8 @@ value1 = S(macro); break; case Rectype_FunctionMacro: /* FunctionMacro */ value1 = S(function_macro); break; + case Rectype_BigReadLabel: /* BigReadLabel -> READ-LABEL */ + value1 = S(read_label); break; case Rectype_Encoding: /* Encoding */ value1 = S(encoding); break; #ifdef FOREIGN @@ -1967,6 +1969,7 @@ case Rectype_GlobalSymbolmacro: /* Global-Symbol-Macro -> <t> */ case Rectype_Macro: /* Macro -> <t> */ case Rectype_FunctionMacro: /* FunctionMacro -> <t> */ + case Rectype_BigReadLabel: /* BigReadLabel -> <t> */ case Rectype_Encoding: /* Encoding -> <t> */ #ifdef FOREIGN case Rectype_Fpointer: /* Foreign-Pointer-Wrapping -> <t> */ @@ -2600,6 +2603,7 @@ enum_hs_global_symbol_macro, enum_hs_macro, enum_hs_function_macro, + enum_hs_big_read_label, enum_hs_encoding, #ifdef FOREIGN enum_hs_foreign_pointer, @@ -2942,6 +2946,8 @@ pighole = &locals->builtins[(int)enum_hs_macro]; break; case Rectype_FunctionMacro: /* FunctionMacro */ pighole = &locals->builtins[(int)enum_hs_function_macro]; break; + case Rectype_BigReadLabel: /* BigReadLabel */ + pighole = &locals->builtins[(int)enum_hs_big_read_label]; break; case Rectype_Encoding: /* Encoding */ pighole = &locals->builtins[(int)enum_hs_encoding]; break; #ifdef FOREIGN --__--__-- Message: 6 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src compiler.lisp,1.247,1.248 ChangeLog,1.4154,1.4155 Date: Wed, 26 Jan 2005 13:28:29 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32609/src Modified Files: compiler.lisp ChangeLog Log Message: Fix handling of SPECIAL-declared optional variables in inline LAMBDA. Index: compiler.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v retrieving revision 1.247 retrieving revision 1.248 diff -u -d -r1.247 -r1.248 --- compiler.lisp 25 Jan 2005 09:16:22 -0000 1.247 +++ compiler.lisp 26 Jan 2005 13:28:24 -0000 1.248 @@ -5936,6 +5936,7 @@ (let (*specials* *ignores* *ignorables* *readonlys* other-decls req-vars req-anodes req-stackzs opt-vars opt-anodes opt-stackzs ; optional and svar together! + optdefaulted-vars optdefaulted-anodes optdefaulted-stackzs rest-vars rest-anodes rest-stackzs fixed-anodes fixed-stackz reqfixed-vars reqfixed-dummys reqfixed-stackzs @@ -6024,30 +6025,43 @@ (return-from main-args (finish-using-applyarg '() optvarr optinitr optsvarr restvar)) - (let* ((svar-init (not (null arglist))) ; = NIL or T - (anode (if svar-init - (progn - (let ((*no-code* t)) - (c-form (car optinitr) 'NIL)) - (let ((*venv* oldvenv) - (*fenv* oldfenv) - (*benv* oldbenv) - (*genv* oldgenv) - (*denv* olddenv)) - (c-form (pop arglist) 'ONE))) - (c-form (car optinitr) 'ONE))) - (var (bind-movable-var (car optvarr) anode))) - (push anode opt-anodes) - (push var opt-vars) - (push *stackz* opt-stackzs) - (push-*venv* var) - (unless (eql (car optsvarr) 0) - (let* ((anode (c-form svar-init 'ONE)) - (var (bind-movable-var (car optsvarr) anode))) - (push anode opt-anodes) - (push var opt-vars) - (push *stackz* opt-stackzs) - (push-*venv* var)))))) + (let ((svar-init (not (null arglist)))) ; = NIL or T + (if svar-init + (progn + (let ((*no-code* t)) + (c-form (car optinitr) 'NIL)) + (let* ((anode + (let ((*venv* oldvenv) + (*fenv* oldfenv) + (*benv* oldbenv) + (*genv* oldgenv) + (*denv* olddenv)) + (c-form (pop arglist) 'ONE))) + (var (bind-movable-var (car optvarr) anode))) + (push anode opt-anodes) + (push var opt-vars) + (push *stackz* opt-stackzs) + (push-*venv* var) + (unless (eql (car optsvarr) 0) + (let* ((anode (c-form svar-init 'ONE)) + (var (bind-movable-var (car optsvarr) anode))) + (push anode opt-anodes) + (push var opt-vars) + (push *stackz* opt-stackzs) + (push-*venv* var))))) + (let* ((anode (c-form (car optinitr) 'ONE)) + (var (bind-movable-var (car optvarr) anode))) + (push anode optdefaulted-anodes) + (push var optdefaulted-vars) + (push *stackz* optdefaulted-stackzs) + (push-*venv* var) + (unless (eql (car optsvarr) 0) + (let* ((anode (c-form svar-init 'ONE)) + (var (bind-movable-var (car optsvarr) anode))) + (push anode optdefaulted-anodes) + (push var optdefaulted-vars) + (push *stackz* optdefaulted-stackzs) + (push-*venv* var)))))))) (if (eql restvar 0) ;; consume further arguments: (when applyarglist @@ -6077,6 +6091,9 @@ (setq opt-vars (nreverse opt-vars)) (setq opt-anodes (nreverse opt-anodes)) (setq opt-stackzs (nreverse opt-stackzs)) + (setq optdefaulted-vars (nreverse optdefaulted-vars)) + (setq optdefaulted-anodes (nreverse optdefaulted-anodes)) + (setq optdefaulted-stackzs (nreverse optdefaulted-stackzs)) ;; activate the bindings of the Aux-Variables: (multiple-value-setq (aux-vars aux-anodes) (bind-aux-vars auxvar auxinit)) @@ -6085,13 +6102,14 @@ (let* ((body-anode (c-form `(PROGN ,@body-rest))) ;; check the variables: (varlist - (append req-vars opt-vars rest-vars + (append req-vars opt-vars optdefaulted-vars rest-vars reqfixed-vars optfixed-vars optsfixed-vars restfixed-vars aux-vars)) (closurevars (append (checking-movable-var-list req-vars req-anodes) (checking-movable-var-list opt-vars opt-anodes) + (checking-movable-var-list optdefaulted-vars optdefaulted-anodes) (checking-movable-var-list rest-vars rest-anodes) (checking-fixed-var-list reqfixed-vars) (checking-fixed-var-list optfixed-vars) @@ -6108,6 +6126,8 @@ (append req-anodes opt-anodes rest-anodes ) (append req-stackzs opt-stackzs rest-stackzs) fixed-anodes)) + ,@(mapcap #'c-bind-movable-var-anode + optdefaulted-vars optdefaulted-anodes) ,@(mapcap #'c-bind-fixed-var reqfixed-vars reqfixed-dummys reqfixed-stackzs) ,@(c-bind-with-svars optfixed-vars optfixed-dummys @@ -6123,14 +6143,14 @@ (make-anode :type 'FUNCALL :sub-anodes - `(,@req-anodes ,@opt-anodes ,@rest-anodes + `(,@req-anodes ,@opt-anodes ,@optdefaulted-anodes ,@rest-anodes ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes) ,@aux-anodes ,body-anode) :seclass (seclass-without (anodelist-seclass-or - `(,@req-anodes ,@opt-anodes ,@rest-anodes + `(,@req-anodes ,@opt-anodes ,@optdefaulted-anodes ,@rest-anodes ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes) ,@aux-anodes ,body-anode)) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4154 retrieving revision 1.4155 diff -u -d -r1.4154 -r1.4155 --- ChangeLog 26 Jan 2005 13:25:28 -0000 1.4154 +++ ChangeLog 26 Jan 2005 13:28:26 -0000 1.4155 @@ -1,5 +1,12 @@ 2005-01-22 Bruno Haible <br...@cl...> + * compiler.lisp (c-FUNCALL-INLINE): Fix long-standing bug in the + handling of SPECIAL-declared optional variables: If the initforms + of these variables come from the lambdalist, use sequential calls to + c-bind-movable-var-anode instead of c-parallel-bind-movable-var-anode. + +2005-01-22 Bruno Haible <br...@cl...> + Allow bignums as read-label values. * lispbibl.d (Rectype_BigReadLabel): New enum item. (BigReadLabel): New type. --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |
