Menu
▾
▴
clisp-cvs digest, Vol 1 #924 - 3 msgs
|
From: <cli...@li...> - 2005-01-25 19:39:08
|
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/src compiler.lisp,1.245,1.246 ChangeLog,1.4139,1.4140 (Bruno Haible) 2. clisp/src compiler.lisp,1.246,1.247 ChangeLog,1.4140,1.4141 (Bruno Haible) 3. clisp/src lispbibl.d,1.604,1.605 spvw_circ.d,1.31,1.32 spvw_garcol.d,1.94,1.95 spvw_gcmark.d,1.5,1.6 spvw_memfile.d,1.84,1.85 io.d,1.278,1.279 hashtabl.d,1.114,1.115 predtype.d,1.129,1.130 ChangeLog,1.4141,1.4142 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src compiler.lisp,1.245,1.246 ChangeLog,1.4139,1.4140 Date: Tue, 25 Jan 2005 09:14:32 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20780/src Modified Files: compiler.lisp ChangeLog Log Message: Correct the scope of free SPECIAL declarations. Index: compiler.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v retrieving revision 1.245 retrieving revision 1.246 diff -u -d -r1.245 -r1.246 --- compiler.lisp 24 Jan 2005 15:40:16 -0000 1.245 +++ compiler.lisp 25 Jan 2005 09:14:24 -0000 1.246 @@ -3785,7 +3785,6 @@ closuredummy-stackz closuredummy-venvc) (multiple-value-setq (*specials* *ignores* *ignorables* *readonlys*) (process-declarations declarations)) - (push-specials) ;; visibility of Closure-Dummyvar: (push nil *venvc*) (setq closuredummy-venvc *venvc*) @@ -3819,6 +3818,7 @@ ;; activate the bindings of the Aux-Variables: (multiple-value-setq (aux-vars aux-anodes) (bind-aux-vars auxvar auxinit)) + (push-specials) (let* ((body-anode (c-form `(PROGN ,@body-rest) (if gf-p 'ONE 'ALL))) ;; check the variables: (closurevars @@ -4617,7 +4617,6 @@ (*venvc* *venvc*)) (multiple-value-bind (*specials* *ignores* *ignorables* *readonlys*) (process-declarations declarations) - (push-specials) ;; syntax-test of the parameter-list: (multiple-value-bind (symbols initforms) (analyze-letlist (second *form*)) @@ -4627,6 +4626,7 @@ (multiple-value-bind (varlist anodelist stackzlist) (process-movable-var-list symbols initforms *-flag) (unless *-flag (push 0 *stackz*)) ; room for closing-bindings + (push-specials) (let ((body-anode (c-form `(PROGN ,@body-rest)))) ; compile Body ;; check the variables: (let* ((closurevars @@ -4688,14 +4688,14 @@ (*venvc* *venvc*)) (multiple-value-bind (*specials* *ignores* *ignorables* *readonlys*) (process-declarations declarations) - (push-specials) (if (null symbols) ; empty variable-list -> bind nothing - (let* ((anode1 (c-form (third *form*) 'NIL)) - (anode2 (c-form `(PROGN ,@(cdddr *form*))))) - (make-anode :type 'MULTIPLE-VALUE-BIND - :sub-anodes (list anode1 anode2) - :seclass (anodes-seclass-or anode1 anode2) - :code `(,anode1 ,anode2))) + (let ((anode1 (c-form (third *form*) 'NIL))) + (push-specials) + (let ((anode2 (c-form `(PROGN ,@(cdddr *form*))))) + (make-anode :type 'MULTIPLE-VALUE-BIND + :sub-anodes (list anode1 anode2) + :seclass (anodes-seclass-or anode1 anode2) + :code `(,anode1 ,anode2)))) (let ((anode1 (c-form (third *form*) 'ALL))) (push nil *venvc*) ; visibility of Closure-Dummyvar (multiple-value-bind (varlist stackvarlist) @@ -4709,44 +4709,45 @@ ((null varlistr) (nreverse L)) (let ((var (car varlistr))) (push-*venv* var) - (push *stackz* L) (bind-fixed-var-2 var)))) - (body-anode ; compile Body - (c-form `(PROGN ,@body-rest))) - ; check the variables: - (closurevars (checking-fixed-var-list varlist)) - (codelist ; generate Code - `(,anode1 - (NV-TO-STACK ,(length symbols)) - ,@(c-make-closure closurevars closuredummy-venvc - closuredummy-stackz) - ,@ ; bind special- or Closure-variables: - (do ((stackvarlistr stackvarlist - (cdr stackvarlistr)) - (stackzlistr stackzlist (cdr stackzlistr)) - (varlistr varlist (cdr varlistr)) - (L '())) - ((null varlistr) (nreverse L)) - (setq L (revappend - (c-bind-fixed-var - (car varlistr) - (car stackvarlistr) - (car stackzlistr)) - L))) - ,body-anode - (UNWIND ,*stackz* ,oldstackz ,*for-value*))) - (anode - (make-anode - :type 'MULTIPLE-VALUE-BIND - :sub-anodes (list anode1 body-anode) - :seclass (seclass-without - (anodes-seclass-or anode1 body-anode) - varlist) - :stackz oldstackz - :code codelist))) - (closuredummy-add-stack-slot - closurevars closuredummy-stackz closuredummy-venvc) - (optimize-var-list varlist) - anode)))))))))) + (push *stackz* L) (bind-fixed-var-2 var))))) + (push-specials) + (let* ((body-anode ; compile Body + (c-form `(PROGN ,@body-rest))) + ; check the variables: + (closurevars (checking-fixed-var-list varlist)) + (codelist ; generate Code + `(,anode1 + (NV-TO-STACK ,(length symbols)) + ,@(c-make-closure closurevars closuredummy-venvc + closuredummy-stackz) + ,@ ; bind special- or Closure-variables: + (do ((stackvarlistr stackvarlist + (cdr stackvarlistr)) + (stackzlistr stackzlist (cdr stackzlistr)) + (varlistr varlist (cdr varlistr)) + (L '())) + ((null varlistr) (nreverse L)) + (setq L (revappend + (c-bind-fixed-var + (car varlistr) + (car stackvarlistr) + (car stackzlistr)) + L))) + ,body-anode + (UNWIND ,*stackz* ,oldstackz ,*for-value*))) + (anode + (make-anode + :type 'MULTIPLE-VALUE-BIND + :sub-anodes (list anode1 body-anode) + :seclass (seclass-without + (anodes-seclass-or anode1 body-anode) + varlist) + :stackz oldstackz + :code codelist))) + (closuredummy-add-stack-slot + closurevars closuredummy-stackz closuredummy-venvc) + (optimize-var-list varlist) + anode))))))))))) ;; compile (COMPILER-LET ({var|(var value)}*) {form}*) (defun c-COMPILER-LET (&optional (c #'c-form)) @@ -5933,7 +5934,6 @@ (multiple-value-setq (*specials* *ignores* *ignorables* *readonlys*) (process-declarations declarations)) - (push-specials) (push 0 *stackz*) (push nil *venvc*) ; room for Closure-Dummyvar (setq closuredummy-stackz *stackz* closuredummy-venvc *venvc*) (flet ((finish-using-applyarg @@ -6068,6 +6068,7 @@ ;; activate the bindings of the Aux-Variables: (multiple-value-setq (aux-vars aux-anodes) (bind-aux-vars auxvar auxinit)) + (push-specials) (let* ((body-anode (c-form `(PROGN ,@body-rest))) ;; check the variables: (varlist Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4139 retrieving revision 1.4140 diff -u -d -r1.4139 -r1.4140 --- ChangeLog 24 Jan 2005 22:00:53 -0000 1.4139 +++ ChangeLog 25 Jan 2005 09:14:26 -0000 1.4140 @@ -1,3 +1,11 @@ +2005-01-21 Bruno Haible <br...@cl...> + + Implement the scope of free SPECIAL declarations as ANSI CL 3.3.4 + specifies it. ANSI CL issue <DECLARATION-SCOPE:NO-HOISTING>. + * compiler.lisp (c-LAMBDABODY,c-LET/LET*, c-MULTIPLE-VALUE-BIND, + c-FUNCALL-INLINE): Call push-specials immediately before + compiling the body-forms, not at the beginning. + 2005-01-24 Sam Steingold <sd...@gn...> * defpackage.lisp (defpackage): duplicate USE-PACKAGE is OK --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src compiler.lisp,1.246,1.247 ChangeLog,1.4140,1.4141 Date: Tue, 25 Jan 2005 09:16:25 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21172/src Modified Files: compiler.lisp ChangeLog Log Message: Correct scope of free declarations. Index: compiler.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v retrieving revision 1.246 retrieving revision 1.247 diff -u -d -r1.246 -r1.247 --- compiler.lisp 25 Jan 2005 09:14:24 -0000 1.246 +++ compiler.lisp 25 Jan 2005 09:16:22 -0000 1.247 @@ -1294,61 +1294,63 @@ ;; processing form instead. ;; Additional Declaration (INLINING symbol) against recursive Inlining. -;; (process-declarations declspeclist) pushes the Declarations (as they come -;; from PARSE-BODY) to *denv* and returns: -;; a list of the Special-declared symbols, -;; a list of the Ignore-declared symbols, -;; a list of the Ignorable-declared symbols, -;; a list of the Read-Only-declared symbols. -(defun process-declarations (declspeclist &aux (specials nil) (ignores nil) - (ignorables nil) (readonlys nil)) +;; (process-declarations declspeclist) analyzes the declarations (as they come +;; from PARSE-BODY) and returns: +;; a fresh list of the Special-declared symbols, +;; a fresh list of the Ignore-declared symbols, +;; a fresh list of the Ignorable-declared symbols, +;; a fresh list of the Read-Only-declared symbols, +;; a fresh list of other declaration specifiers. +(defun process-declarations (declspeclist) (setq declspeclist (nreverse declspeclist)) - (dolist (declspec declspeclist) - (if (or (atom declspec) (cdr (last declspec))) - (c-warn (TEXT "Bad declaration syntax: ~S~%Will be ignored.") - declspec) - (let ((declspectype (car declspec))) - (if (and (symbolp declspectype) - (or (memq declspectype *declaration-types*) - (do ((L *denv* (cdr L))) - ((null L) nil) - (if (and (eq (first (car L)) 'DECLARATION) - (memq declspectype (rest (car L)))) - (return t))) - (and *compiling-from-file* - (memq declspectype *user-declaration-types*)))) - (cond ((eq declspectype 'SPECIAL) - (dolist (x (cdr declspec)) - (if (symbolp x) - (push x specials) - (c-warn - (TEXT "Non-symbol ~S may not be declared SPECIAL.") - x)))) - ((eq declspectype 'IGNORE) - (dolist (x (cdr declspec)) - (if (symbolp x) - (push x ignores) - (c-warn - (TEXT "Non-symbol ~S may not be declared IGNORE.") - x)))) - ((eq declspectype 'IGNORABLE) - (dolist (x (cdr declspec)) - (if (symbolp x) - (push x ignorables) - (c-warn - (TEXT "Non-symbol ~S may not be declared IGNORABLE.") - x)))) - ((eq declspectype 'SYS::READ-ONLY) - (dolist (x (cdr declspec)) - (if (symbolp x) - (push x readonlys) - (c-warn - (TEXT "Non-symbol ~S may not be declared READ-ONLY.") - x)))) - (t (push declspec *denv*))) - (c-warn (TEXT "Unknown declaration ~S.~%The whole declaration will be ignored.") - declspectype declspec))))) - (values specials ignores ignorables readonlys)) + (let ((specials '()) + (ignores '()) + (ignorables '()) + (readonlys '()) + (other '())) + (dolist (declspec declspeclist) + (if (or (atom declspec) (cdr (last declspec))) + (c-warn (TEXT "Bad declaration syntax: ~S~%Will be ignored.") + declspec) + (let ((declspectype (car declspec))) + (if (and (symbolp declspectype) + (or (memq declspectype *declaration-types*) + (do ((L *denv* (cdr L))) + ((null L) nil) + (if (and (eq (first (car L)) 'DECLARATION) + (memq declspectype (rest (car L)))) + (return t))) + (and *compiling-from-file* + (memq declspectype *user-declaration-types*)))) + (cond ((eq declspectype 'SPECIAL) + (dolist (x (cdr declspec)) + (if (symbolp x) + (push x specials) + (c-warn (TEXT "Non-symbol ~S may not be declared SPECIAL.") + x)))) + ((eq declspectype 'IGNORE) + (dolist (x (cdr declspec)) + (if (symbolp x) + (push x ignores) + (c-warn (TEXT "Non-symbol ~S may not be declared IGNORE.") + x)))) + ((eq declspectype 'IGNORABLE) + (dolist (x (cdr declspec)) + (if (symbolp x) + (push x ignorables) + (c-warn (TEXT "Non-symbol ~S may not be declared IGNORABLE.") + x)))) + ((eq declspectype 'SYS::READ-ONLY) + (dolist (x (cdr declspec)) + (if (symbolp x) + (push x readonlys) + (c-warn (TEXT "Non-symbol ~S may not be declared READ-ONLY.") + x)))) + (t + (push declspec other))) + (c-warn (TEXT "Unknown declaration ~S.~%The whole declaration will be ignored.") + declspectype declspec))))) + (values specials ignores ignorables readonlys other))) ;; (declared-notinline fun denv) determines, if fun - a Symbol pointing to a ;; global function, which is not shadowed by a local function-definition - @@ -1392,6 +1394,11 @@ (return t))) (setq denv (cdr denv)))) +;; (push-*denv* declspecs) extends *denv* by the declspecs. +;; declspecs must be a freshly consed list. +(defun push-*denv* (declspecs) + (setq *denv* (nreconc declspecs *denv*))) + ;;;;**** FUNCTION MANAGEMENT @@ -3776,14 +3783,14 @@ (*denv* *denv*) (*venv* *venv*) (*venvc* *venvc*) - *specials* *ignores* *ignorables* *readonlys* + *specials* *ignores* *ignorables* *readonlys* other-decls req-vars req-dummys req-stackzs opt-vars opt-dummys opt-anodes opts-vars opts-anodes opt-stackzs rest-vars rest-dummys rest-stackzs key-vars key-dummys key-anodes keys-vars keys-anodes key-stackzs aux-vars aux-anodes closuredummy-stackz closuredummy-venvc) - (multiple-value-setq (*specials* *ignores* *ignorables* *readonlys*) + (multiple-value-setq (*specials* *ignores* *ignorables* *readonlys* other-decls) (process-declarations declarations)) ;; visibility of Closure-Dummyvar: (push nil *venvc*) @@ -3819,6 +3826,7 @@ (multiple-value-setq (aux-vars aux-anodes) (bind-aux-vars auxvar auxinit)) (push-specials) + (push-*denv* other-decls) (let* ((body-anode (c-form `(PROGN ,@body-rest) (if gf-p 'ONE 'ALL))) ;; check the variables: (closurevars @@ -4615,7 +4623,7 @@ (*denv* *denv*) (*venv* *venv*) (*venvc* *venvc*)) - (multiple-value-bind (*specials* *ignores* *ignorables* *readonlys*) + (multiple-value-bind (*specials* *ignores* *ignorables* *readonlys* other-decls) (process-declarations declarations) ;; syntax-test of the parameter-list: (multiple-value-bind (symbols initforms) @@ -4627,6 +4635,7 @@ (process-movable-var-list symbols initforms *-flag) (unless *-flag (push 0 *stackz*)) ; room for closing-bindings (push-specials) + (push-*denv* other-decls) (let ((body-anode (c-form `(PROGN ,@body-rest)))) ; compile Body ;; check the variables: (let* ((closurevars @@ -4663,10 +4672,11 @@ (test-list *form* 1) (multiple-value-bind (body-rest declarations) (parse-body (cdr *form*)) (let ((*venv* *venv*)) - (multiple-value-bind (*specials* ignores ignorables readonlys) + (multiple-value-bind (*specials* ignores ignorables readonlys other-decls) (process-declarations declarations) (declare (ignore ignores ignorables readonlys)) (push-specials) + (push-*denv* other-decls) (funcall c `(PROGN ,@body-rest)))))) ;; compile (MULTIPLE-VALUE-BIND ({var}*) form1 {declaration}* {form}*) @@ -4686,11 +4696,12 @@ (*denv* *denv*) (*venv* *venv*) (*venvc* *venvc*)) - (multiple-value-bind (*specials* *ignores* *ignorables* *readonlys*) + (multiple-value-bind (*specials* *ignores* *ignorables* *readonlys* other-decls) (process-declarations declarations) (if (null symbols) ; empty variable-list -> bind nothing (let ((anode1 (c-form (third *form*) 'NIL))) (push-specials) + (push-*denv* other-decls) (let ((anode2 (c-form `(PROGN ,@(cdddr *form*))))) (make-anode :type 'MULTIPLE-VALUE-BIND :sub-anodes (list anode1 anode2) @@ -4711,6 +4722,7 @@ (push-*venv* var) (push *stackz* L) (bind-fixed-var-2 var))))) (push-specials) + (push-*denv* other-decls) (let* ((body-anode ; compile Body (c-form `(PROGN ,@body-rest))) ; check the variables: @@ -5526,9 +5538,10 @@ symbols expansions) (list *venv*))))) (multiple-value-bind (body-rest declarations) (parse-body (cddr *form*)) - (multiple-value-bind (*specials* *ignores* *ignorables* *readonlys*) + (multiple-value-bind (*specials* *ignores* *ignorables* *readonlys* other-decls) (process-declarations declarations) (push-specials) + (push-*denv* other-decls) (dolist (symbol symbols) (if (or (constantp symbol) (proclaimed-special-p symbol)) (c-error-c (TEXT "~S: symbol ~S is declared special and must not be declared a macro") @@ -5920,7 +5933,7 @@ *denv*))))) (multiple-value-bind (body-rest declarations) (parse-body lambdabody t) - (let (*specials* *ignores* *ignorables* *readonlys* + (let (*specials* *ignores* *ignorables* *readonlys* other-decls req-vars req-anodes req-stackzs opt-vars opt-anodes opt-stackzs ; optional and svar together! rest-vars rest-anodes rest-stackzs @@ -5931,8 +5944,7 @@ restfixed-vars restfixed-dummys restfixed-stackzs aux-vars aux-anodes closuredummy-stackz closuredummy-venvc) - (multiple-value-setq - (*specials* *ignores* *ignorables* *readonlys*) + (multiple-value-setq (*specials* *ignores* *ignorables* *readonlys* other-decls) (process-declarations declarations)) (push 0 *stackz*) (push nil *venvc*) ; room for Closure-Dummyvar (setq closuredummy-stackz *stackz* closuredummy-venvc *venvc*) @@ -6069,6 +6081,7 @@ (multiple-value-setq (aux-vars aux-anodes) (bind-aux-vars auxvar auxinit)) (push-specials) + (push-*denv* other-decls) (let* ((body-anode (c-form `(PROGN ,@body-rest))) ;; check the variables: (varlist Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4140 retrieving revision 1.4141 diff -u -d -r1.4140 -r1.4141 --- ChangeLog 25 Jan 2005 09:14:26 -0000 1.4140 +++ ChangeLog 25 Jan 2005 09:16:22 -0000 1.4141 @@ -1,3 +1,14 @@ +2005-01-23 Bruno Haible <br...@cl...> + + Implement the scope of other free declarations as ANSI CL 3.3.4 + specifies it. ANSI CL issue <DECLARATION-SCOPE:NO-HOISTING>. + * compiler.lisp (process-declarations): Return the other declspecs as a + fifth value. + (push-*denv*): New function. + (c-LAMBDABODY, c-LET/LET*, c-LOCALLY, c-MULTIPLE-VALUE-BIND, + c-SYMBOL-MACROLET, c-FUNCALL-INLINE): Call push-*denv* immediately + before compiling the body-forms. + 2005-01-21 Bruno Haible <br...@cl...> Implement the scope of free SPECIAL declarations as ANSI CL 3.3.4 --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src lispbibl.d,1.604,1.605 spvw_circ.d,1.31,1.32 spvw_garcol.d,1.94,1.95 spvw_gcmark.d,1.5,1.6 spvw_memfile.d,1.84,1.85 io.d,1.278,1.279 hashtabl.d,1.114,1.115 predtype.d,1.129,1.130 ChangeLog,1.4141,1.4142 Date: Tue, 25 Jan 2005 09:19:41 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21738/src Modified Files: lispbibl.d spvw_circ.d spvw_garcol.d spvw_gcmark.d spvw_memfile.d io.d hashtabl.d predtype.d ChangeLog Log Message: Rename Read-Label to Small-Read-Label. Index: spvw_memfile.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_memfile.d,v retrieving revision 1.84 retrieving revision 1.85 diff -u -d -r1.84 -r1.85 --- spvw_memfile.d 16 Dec 2004 14:30:17 -0000 1.84 +++ spvw_memfile.d 25 Jan 2005 09:19:33 -0000 1.85 @@ -720,7 +720,7 @@ break; /*---NOTREACHED---*/ #ifdef TYPECODES - case_system: /* frame-pointer or read-label or system-constant */ + case_system: /* frame-pointer or small-read-label or system-constant */ if ((as_oint(*objptr) & wbit(0+oint_addr_shift)) ==0) { /* Frame-Pointer -> #<DISABLED> */ *objptr = disabled; Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.604 retrieving revision 1.605 diff -u -d -r1.604 -r1.605 --- lispbibl.d 20 Jan 2005 14:19:52 -0000 1.604 +++ lispbibl.d 25 Jan 2005 09:19:30 -0000 1.605 @@ -2138,7 +2138,7 @@ 2.1.2. Other immediate objects Character, Fixnum, Short-Float, and, if IMMEDIATE_FFLOAT, Single-Float. -Furthermore: Frame-Pointer, Read-Label, System. (System means some +Furthermore: Frame-Pointer, Small-Read-Label, System. (System means some finite number of special values, such as #<UNBOUND>.) 2.2. SUBRs @@ -3046,16 +3046,16 @@ # Note that cons and varobject cannot have the same encoding mod 8 # (otherwise gc_mark:up wouldn't work). # So, here are the encodings. - # machine ... .00 encodes pointers, offset 0 - # subr ... .10 encodes pointers, offset 2 - # varobject ... .01 offset 1, the pointers are == 0 mod 4 - # cons ... 011 offset 3, the pointers are == 0 mod 8 - # immediate ... 111 - # fixnum 00s 111 s = sign bit - # sfloat 01s 111 s = sign bit - # char 100 111 - # read-label 110 111 - # system 111 111 + # machine ... .00 encodes pointers, offset 0 + # subr ... .10 encodes pointers, offset 2 + # varobject ... .01 offset 1, the pointers are == 0 mod 4 + # cons ... 011 offset 3, the pointers are == 0 mod 8 + # immediate ... 111 + # fixnum 00s 111 s = sign bit + # sfloat 01s 111 s = sign bit + # char 100 111 + # small-read-label 110 111 + # system 111 111 # Varobjects all start with a word containing the type (1 byte) and a # length field (up to 24 bits). @@ -3074,11 +3074,11 @@ #endif # The types of immediate objects. - #define fixnum_type ((0 << imm_type_shift) + immediate_bias) - #define sfloat_type ((2 << imm_type_shift) + immediate_bias) - #define char_type ((4 << imm_type_shift) + immediate_bias) - #define read_label_type ((6 << imm_type_shift) + immediate_bias) - #define system_type ((7 << imm_type_shift) + immediate_bias) + #define fixnum_type ((0 << imm_type_shift) + immediate_bias) + #define sfloat_type ((2 << imm_type_shift) + immediate_bias) + #define char_type ((4 << imm_type_shift) + immediate_bias) + #define small_read_label_type ((6 << imm_type_shift) + immediate_bias) + #define system_type ((7 << imm_type_shift) + immediate_bias) # The sign bit, for immediate numbers only. #define sign_bit_t (0 + imm_type_shift) @@ -3143,15 +3143,15 @@ # Immediates look like pointers in the range 0xC0000000..0xFFFFFFFF. # We know that the Linux kernel never assigns virtual memory in this area. # So, here are the encodings. Bit 0 is used as the garcol_bit. - # machine ... ... .00 encodes pointers, offset 0 - # cons ... ... 010 offset 2, the pointers are == 0 mod 8 - # varobject ... ... 110 offset 6, the pointers are == 4 mod 8 - # immediate 11 ... ... 00 - # fixnum 11 ... 00s 00 s = sign bit - # sfloat 11 ... 01s 00 s = sign bit - # char 11 ... 100 00 - # read-label 11 ... 110 00 - # system 11 ... 111 00 + # machine ... ... .00 encodes pointers, offset 0 + # cons ... ... 010 offset 2, the pointers are == 0 mod 8 + # varobject ... ... 110 offset 6, the pointers are == 4 mod 8 + # immediate 11 ... ... 00 + # fixnum 11 ... 00s 00 s = sign bit + # sfloat 11 ... 01s 00 s = sign bit + # char 11 ... 100 00 + # small-read-label 11 ... 110 00 + # system 11 ... 111 00 # Varobjects all start with a word containing the type (1 byte) and a # length field (up to 24 bits). @@ -3166,11 +3166,11 @@ #define imm_type_shift 2 # could also be 3, if oint_data_shift == 6 # The types of immediate objects. - #define fixnum_type ((0 << imm_type_shift) + immediate_bias) - #define sfloat_type ((2 << imm_type_shift) + immediate_bias) - #define char_type ((4 << imm_type_shift) + immediate_bias) - #define read_label_type ((6 << imm_type_shift) + immediate_bias) - #define system_type ((7 << imm_type_shift) + immediate_bias) + #define fixnum_type ((0 << imm_type_shift) + immediate_bias) + #define sfloat_type ((2 << imm_type_shift) + immediate_bias) + #define char_type ((4 << imm_type_shift) + immediate_bias) + #define small_read_label_type ((6 << imm_type_shift) + immediate_bias) + #define system_type ((7 << imm_type_shift) + immediate_bias) # The sign bit, for immediate numbers only. #define sign_bit_t (0 + imm_type_shift) @@ -3472,7 +3472,7 @@ #define machine_type (0) # 0x00 # %00000000 ; machine pointer #define subr_type ( BTB0) # 0x01 # %00000001 ; SUBR #define char_type ( BTB1 ) # 0x02 # %00000010 ; character - #define system_type ( BTB1|BTB0) # 0x03 # %00000011 ; frame-pointer, read-label, system + #define system_type ( BTB1|BTB0) # 0x03 # %00000011 ; frame-pointer, small-read-label, system #define symbol_type ( BTB2 ) # 0x04 # %000001xx ; symbol # bits for symbols in the GCself pointer: #define var_bit0_t TB0 # set if the symbol is proclaimed SPECIAL or constant @@ -3869,7 +3869,7 @@ #define case_lrecord case lrecord_type # Long Record #define case_char case char_type # Character #define case_subr case subr_type # SUBR - #define case_system case system_type # Frame-Pointer, Read-Label, System + #define case_system case system_type # Frame-Pointer, Small-Read-Label, System #define case_posfixnum case fixnum_type # Fixnum >=0 #define case_negfixnum case fixnum_type|bit(sign_bit_t) # Fixnum <0 #define case_fixnum case_posfixnum: case_negfixnum # Fixnum @@ -5992,16 +5992,16 @@ seclass_default /* may do side effects */ } seclass_t; -# Read-Label +# Small-Read-Label #ifdef TYPECODES - #define make_read_label(n) \ + #define make_small_read_label(n) \ type_data_object(system_type, ((uintL)(n)<<1) + bit(0)) - #define read_label_integer_p(obj) \ + #define small_read_label_integer_p(obj) \ (posfixnump(obj) && (posfixnum_to_L(obj) < bit(oint_data_len-2))) #else - #define make_read_label(n) \ - type_data_object(read_label_type, (uintL)(n)) - #define read_label_integer_p(obj) posfixnump(obj) + #define make_small_read_label(n) \ + type_data_object(small_read_label_type, (uintL)(n)) + #define small_read_label_integer_p(obj) posfixnump(obj) #endif # Machine pointers: @@ -7003,8 +7003,8 @@ && (as_oint(obj) & 0xE0000000) != 0xC0000000) #endif - # Test for Read-Label - #define read_label_p(obj) ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias)) == read_label_type) + # Test for Small-Read-Label + #define small_read_label_p(obj) ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias)) == small_read_label_type) # Test for System-Pointer #define systemp(obj) ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias)) == system_type) Index: io.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/io.d,v retrieving revision 1.278 retrieving revision 1.279 diff -u -d -r1.278 -r1.279 --- io.d 24 Jan 2005 10:41:08 -0000 1.278 +++ io.d 25 Jan 2005 09:19:33 -0000 1.279 @@ -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 margink 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) { @@ -3632,7 +3632,7 @@ GETTEXT("~S from ~S: a number must be given between #"" and ~C")); } # n is an Integer >=0 - if (!read_label_integer_p(n)) { # n is too big + 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 @@ -3640,7 +3640,7 @@ pushSTACK(S(read)); fehler(reader_error,GETTEXT("~S from ~S: label #~S? too large")); } - var object label = make_read_label(posfixnum_to_L(n)); # Internal-Label with Nummer n + var object label = make_small_read_label(posfixnum_to_L(n)); # Internal-Label with Nummer n var object alist = # value of SYS::*READ-REFERENCE-TABLE* Symbol_value(S(read_reference_table)); # execute (assoc label alist :test #'eq): @@ -6886,12 +6886,13 @@ pr_character(stream_,obj); break; case_subr: # SUBR pr_subr(stream_,obj); break; - case_system: # Frame-Pointer, Read-Label, System + case_system: # Frame-Pointer, Small-Read-Label, System if (as_oint(obj) & wbit(0 + oint_addr_shift)) { if (as_oint(obj) & wbit(oint_data_len-1 + oint_addr_shift)) { # System-Pointer pr_system(stream_,obj); - } else { # Read-Label + } else { + # Small-Read-Label pr_readlabel(stream_,obj); } } else { # Frame-Pointer @@ -6919,7 +6920,7 @@ pr_subr(stream_,obj); else if (machinep(obj)) pr_machine(stream_,obj); - else if (read_label_p(obj)) + else if (small_read_label_p(obj)) pr_readlabel(stream_,obj); else if (systemp(obj)) pr_system(stream_,obj); @@ -8403,7 +8404,7 @@ pr_hex6_obj(stream_,obj,O(printstring_address)); } -# -------- Frame-Pointer, Read-Label, System -------- +# -------- Frame-Pointer, Small-Read-Label, System -------- # UP: prints systempointer to stream. # pr_system(&stream,obj); @@ -8433,7 +8434,7 @@ } } -# UP: prints read-label to stream. +# UP: prints read-label to stream. # pr_readlabel(&stream,obj); # > obj: Read-Label # > stream: Stream @@ -10215,7 +10216,7 @@ write_ascii_char(&STACK_0,'.'); write_ascii_char(&STACK_0,' '); prin_object(&STACK_0,STACK_1); - VALUES1(T); /* make_read_label(ci.n); */ + VALUES1(T); /* make_small_read_label(ci.n); */ } skipSTACK(2); } Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4141 retrieving revision 1.4142 diff -u -d -r1.4141 -r1.4142 --- ChangeLog 25 Jan 2005 09:16:22 -0000 1.4141 +++ ChangeLog 25 Jan 2005 09:19:36 -0000 1.4142 @@ -1,3 +1,14 @@ +2005-01-22 Bruno Haible <br...@cl...> + + * lispbibl.d (small_read_label_type): Renamed from read_label_type. + (make_small_read_label): Renamed from make_read_label. + (small_read_label_integer_p): Renamed from read_label_integer_p. + (small_read_label_p): Renamed from read_label_p. + * spvw_circ.d (subst_circ_mark, subst_circ_unmark, subst): Update. + * io.d (lookup_label, prin_object_dispatch): Update. + * hashtabl.d (sxhash_atom): Update. + * predtype.d (TYPE-OF, CLASS-OF): Update. + 2005-01-23 Bruno Haible <br...@cl...> Implement the scope of other free declarations as ANSI CL 3.3.4 Index: spvw_circ.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_circ.d,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- spvw_circ.d 11 Dec 2004 14:16:05 -0000 1.31 +++ spvw_circ.d 25 Jan 2005 09:19:32 -0000 1.32 @@ -631,7 +631,7 @@ case_machine: # Machine Pointer case_char: # Character case_subr: # Subr - case_system: # Frame-pointer, Read-label, system + case_system: # Frame-pointer, Small-Read-label, system case_fixnum: # Fixnum case_sfloat: # Short-Float #ifdef IMMEDIATE_FFLOAT @@ -992,7 +992,7 @@ case_machine: # Machine Pointer case_char: # Character case_subr: # Subr - case_system: # Frame-pointer, Read-label, system + case_system: # Frame-pointer, Small-Read-label, system case_fixnum: # Fixnum case_sfloat: # Short-Float #ifdef IMMEDIATE_FFLOAT @@ -1215,7 +1215,7 @@ case_machine: # Machine Pointer case_char: # Character case_subr: # Subr - case_system: # Frame-pointer, Read-label, system + case_system: # Frame-pointer, Small-Read-label, system case_fixnum: # Fixnum case_sfloat: # Short-Float #ifdef IMMEDIATE_FFLOAT @@ -1277,8 +1277,8 @@ goto case_subr; } elif (machinep(obj)) { goto case_machine; - } elif (read_label_p(obj)) { - goto case_read_label; + } elif (small_read_label_p(obj)) { + goto case_small_read_label; } elif (systemp(obj)) { return; } else switch (0) @@ -1338,17 +1338,17 @@ } return; #ifdef TYPECODES - case_system: # Frame-Pointer or Read-Label or System + case_system: # Frame-Pointer or Small-Read-Label or System if (!(as_oint(obj) & wbit(0+oint_addr_shift))) { # Frame-Pointer } else - # Read-Label or System + # Small-Read-Label or System if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift)) { # System } else #endif - case_read_label: - # Read-Label + case_small_read_label: + # Small-Read-Label { # search Read-Label obj in the Alist: var object alist = env->alist; @@ -1467,8 +1467,8 @@ goto case_subr; } elif (machinep(obj)) { goto case_machine; - } elif (read_label_p(obj)) { - goto case_read_label; + } elif (small_read_label_p(obj)) { + goto case_small_read_label; } elif (systemp(obj)) { return; } else switch (0) @@ -1517,17 +1517,17 @@ } break; #ifdef TYPECODES - case_system: # Frame-Pointer or Read-Label or System + case_system: # Frame-Pointer or Small-Read-Label or System if (!(as_oint(obj) & wbit(0+oint_addr_shift))) { # Frame-Pointer } else - # Read-Label or System + # Small-Read-Label or System if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift)) { # System } else #endif - case_read_label: - # Read-Label + case_small_read_label: + # Small-Read-Label { # search Read-Label obj in the Alist: var object alist = subst_circ_alist; @@ -1636,8 +1636,8 @@ goto case_subr; } elif (machinep(obj)) { goto case_machine; - } elif (read_label_p(obj)) { - goto case_read_label; + } elif (small_read_label_p(obj)) { + goto case_small_read_label; } elif (systemp(obj)) { return; } else switch (0) @@ -1699,17 +1699,17 @@ } return; #ifdef TYPECODES - case_system: # Frame-Pointer or Read-Label or System + case_system: # Frame-Pointer or Small-Read-Label or System if (!(as_oint(obj) & wbit(0+oint_addr_shift))) { # Frame-Pointer } else - # Read-Label or System + # Small-Read-Label or System if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift)) { # System } else #endif - case_read_label: - # Read-Label + case_small_read_label: + # Small-Read-Label { # search Read-Label obj in the Alist: var object alist = subst_circ_alist; @@ -1776,7 +1776,7 @@ goto case_subr; } elif (machinep(obj)) { goto case_machine; - } elif (read_label_p(obj) || systemp(obj)) { + } elif (small_read_label_p(obj) || systemp(obj)) { goto case_system; } else switch (0) #endif @@ -1840,7 +1840,7 @@ subst_circ_unmark(&TheCons(obj)->car); # end-recursive: subst_circ_unmark(&Cdr(obj)) ptr = &TheCons(obj)->cdr; goto enter_subst; - case_system: # Frame-Pointer or Read-Label or System + case_system: # Frame-Pointer or Small-Read-Label or System case_machine: # Machine Pointer case_bvector: # Bit-Vector case_b2vector: # 2Bit-Vector Index: hashtabl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/hashtabl.d,v retrieving revision 1.114 retrieving revision 1.115 diff -u -d -r1.114 -r1.115 --- hashtabl.d 13 Dec 2004 12:02:36 -0000 1.114 +++ hashtabl.d 25 Jan 2005 09:19:35 -0000 1.115 @@ -1,6 +1,6 @@ /* * Hash-Tables in CLISP - * Bruno Haible 1990-2004 + * Bruno Haible 1990-2005 * Sam Steingold 1998-2004 * German comments translated into English: Stefan Kain 2002-01-29 */ @@ -1218,7 +1218,7 @@ #ifdef TYPECODES case_machine: /* machine */ case_subr: /* subr */ - case_system: /* frame-pointer, read-label, system */ + case_system: /* frame-pointer, small-read-label, system */ #else case_symbol: /* symbol */ #endif @@ -2949,7 +2949,7 @@ goto case_subr; else if (machinep(obj)) goto case_machine; - else if (read_label_p(obj) || systemp(obj)) + else if (small_read_label_p(obj) || systemp(obj)) goto case_system; else switch (0) #endif @@ -3084,7 +3084,7 @@ /* utilize name */ check_SP(); return sxhash(TheSubr(obj)->name) + 0xFF3319BAUL; case_machine: /* machine-pointer */ - case_system: /* frame-pointer, read-label, system */ + case_system: /* frame-pointer, small-read-label, system */ /* utilize address */ return hashcode1(obj); /* numbers: according to content, like with EQL */ Index: spvw_garcol.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_garcol.d,v retrieving revision 1.94 retrieving revision 1.95 diff -u -d -r1.94 -r1.95 --- spvw_garcol.d 3 Jan 2005 11:35:24 -0000 1.94 +++ spvw_garcol.d 25 Jan 2005 09:19:32 -0000 1.95 @@ -175,7 +175,7 @@ if (marked(TheSubr(obj))) return true; else return false; case_machine: # Machine Pointer case_char: # Character - case_system: # Frame-pointer, Read-label, system + case_system: # Frame-pointer, Small-Read-label, system case_fixnum: # Fixnum case_sfloat: # Short-Float #ifdef IMMEDIATE_FFLOAT Index: spvw_gcmark.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_gcmark.d,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- spvw_gcmark.d 2 Jun 2004 10:22:12 -0000 1.5 +++ spvw_gcmark.d 25 Jan 2005 09:19:33 -0000 1.6 @@ -238,7 +238,7 @@ down_sxrecord(); case_machine: /* machine address */ case_char: /* character */ - case_system: /* frame-pointer, read-label, system */ + case_system: /* frame-pointer, small-read-label, system */ case_fixnum: /* fixnum */ case_sfloat: /* short-float */ #ifdef IMMEDIATE_FFLOAT @@ -374,7 +374,7 @@ /*FALLTHROUGH*/ case_machine: /* machine address */ case_char: /* character */ - case_system: /* frame-pointer, read-label, system */ + case_system: /* frame-pointer, small-read-label, system */ case_fixnum: /* fixnum */ case_sfloat: /* short-float */ #ifdef IMMEDIATE_FFLOAT Index: predtype.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/predtype.d,v retrieving revision 1.129 retrieving revision 1.130 diff -u -d -r1.129 -r1.130 --- predtype.d 24 Jan 2005 10:45:12 -0000 1.129 +++ predtype.d 25 Jan 2005 09:19:36 -0000 1.130 @@ -1129,7 +1129,7 @@ #ifdef TYPECODES case_subr: /* SUBR */ return false; /* should already have been EQ */ - case_system: /* SYSTEM, read-label, FRAME-pointer */ + case_system: /* SYSTEM, small-read-label, FRAME-pointer */ return false; /* should already have been EQ */ case_machine: /* machine pointer */ return false; /* should already have been EQ */ @@ -1406,8 +1406,8 @@ goto case_sfloat; } else if (machinep(arg)) { goto case_machine; - } else if (read_label_p(arg)) { - goto case_read_label; + } else if (small_read_label_p(arg)) { + goto case_small_read_label; } else if (systemp(arg)) { goto case_system; } else @@ -1753,7 +1753,7 @@ value1 = S(system_internal); break; #else - case_read_label: /* -> READ-LABEL */ + case_small_read_label: /* -> READ-LABEL */ value1 = S(read_label); break; case_system: /* -> SYSTEM-INTERNAL */ value1 = S(system_internal); break; @@ -1852,7 +1852,7 @@ goto case_float; } else if (machinep(arg)) { goto case_machine; - } else if (read_label_p(arg)) { + } else if (small_read_label_p(arg)) { goto case_system; } else if (systemp(arg)) { goto case_system; --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |
