Menu
▾
▴
clisp-cvs digest, Vol 1 #634 - 8 msgs
|
From: <cli...@li...> - 2004-08-03 23:05:01
|
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 lispbibl.d,1.535,1.536 spvw_circ.d,1.29,1.30 spvw_debug.d,1.50,1.51 eval.d,1.162,1.163 io.d,1.236,1.237 record.d,1.90,1.91 clos-genfun2.lisp,1.18,1.19 disassem.lisp,1.18,1.19 edit.lisp,1.10,1.11 functions.lisp,1.3,1.4 ChangeLog,1.3365,1.3366 (Bruno Haible) 2. clisp/src ChangeLog,1.3366,1.3367 control.d,1.97,1.98 (Bruno Haible) 3. clisp/src ChangeLog,1.3367,1.3368 (Sam Steingold) 4. clisp/doc multithread.txt,1.3,1.4 (Bruno Haible) 5. clisp/doc multithread.txt,1.4,1.5 (Sam Steingold) 6. clisp/src genclisph.d,1.141,1.142 ChangeLog,1.3368,1.3369 (Sam Steingold) 7. clisp/src genclisph.d,1.142,1.143 (Sam Steingold) 8. clisp/src genclisph.d,1.143,1.144 (Sam Steingold) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src lispbibl.d,1.535,1.536 spvw_circ.d,1.29,1.30 spvw_debug.d,1.50,1.51 eval.d,1.162,1.163 io.d,1.236,1.237 record.d,1.90,1.91 clos-genfun2.lisp,1.18,1.19 disassem.lisp,1.18,1.19 edit.lisp,1.10,1.11 functions.lisp,1.3,1.4 ChangeLog,1.3365,1.3366 Date: Tue, 03 Aug 2004 11:05:17 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27346/src Modified Files: lispbibl.d spvw_circ.d spvw_debug.d eval.d io.d record.d clos-genfun2.lisp disassem.lisp edit.lisp functions.lisp ChangeLog Log Message: Access a closure's name in a way that also works for generic-functions. Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3365 retrieving revision 1.3366 diff -u -d -r1.3365 -r1.3366 --- ChangeLog 2 Aug 2004 19:48:28 -0000 1.3365 +++ ChangeLog 3 Aug 2004 11:05:13 -0000 1.3366 @@ -1,3 +1,23 @@ +2004-06-12 Bruno Haible <br...@cl...> + + * lispbibl.d (Closure, Cclosure): Rename field clos_name to + clos_name_or_class_version. + (Closure_name): New macro. + * spvw_circ.d (get_circ_mark, get_circ_unmark): Use it. + * spvw_debug.d (nobject_out1): Likewise. + * eval.d (trace_call, match_cclosure_key, eval_closure): Likewise. + (interpret_bytecode_): Likewise. + * io.d (pr_cclosure, pr_cclosure_lang): Likewise. + * record.d (SYS::CLOSURE-NAME): Likewise. + (SYS::%MAKE-CLOSURE, SYS::CONSTANT-INITFUNCTION-P, + CLOS::%SHARED-INITIALIZE, do_initialize_instance, CLOS::%MAKE-INSTANCE): + Likewise. + * functions.lisp (function-lambda-expression, function-name): Use + sys::closure-name. + * clos-genfun2.lisp (need-gf-already-called-warning-p): Likewise. + * disassem.lisp (disassemble): Likewise. + * edit.lisp (ed, uncompile): Likewise. + 2004-08-02 Sam Steingold <sd...@gn...> * modules/berkeley-db/bdb.c (object_handle): renamed to ... Index: eval.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/eval.d,v retrieving revision 1.162 retrieving revision 1.163 diff -u -d -r1.162 -r1.163 --- eval.d 26 May 2004 11:26:48 -0000 1.162 +++ eval.d 3 Aug 2004 11:05:11 -0000 1.163 @@ -2187,10 +2187,10 @@ return; pushSTACK(stream); if (cclosurep(fun)) { - pushSTACK(TheCclosure(fun)->clos_name); + pushSTACK(Closure_name(fun)); write_ascii_char(&STACK_1,'c'); } else if (closurep(fun)) { - pushSTACK(TheClosure(fun)->clos_name); + pushSTACK(TheIclosure(fun)->clos_name); write_ascii_char(&STACK_1,'C'); } else if (subrp(fun)) { pushSTACK(TheSubr(fun)->name); @@ -2679,7 +2679,7 @@ { /* halve argcount --> the number of pairs Key.Value: */ if (argcount%2) /* number was odd -> not paired: */ - fehler_key_odd(argcount,TheClosure(closure)->clos_name); + fehler_key_odd(argcount,Closure_name(closure)); if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1)) fehler_too_many_args(unbound,closure,argcount,ca_limit_1); # Due to argcount <= ca_limit_1, all count's fit in a uintC. @@ -2705,7 +2705,7 @@ } check_for_illegal_keywords (!((TheCodevec(codevec)->ccv_flags & bit(6)) == 0), - TheClosure(closure)->clos_name, + Closure_name(closure), { pushSTACK(bad_keyword); /* save */ pushSTACK(bad_value); /* save */ pushSTACK(closure); /* save the closure */ @@ -2714,7 +2714,7 @@ {var object kwlist = listof(key_anz); closure = popSTACK(); bad_value = popSTACK(); bad_keyword = popSTACK(); /* report errors: */ - fehler_key_badkw(TheClosure(closure)->clos_name, + fehler_key_badkw(Closure_name(closure), bad_keyword,bad_value,kwlist);}}); #undef for_every_keyword # now assign Arguments and Parameters: @@ -3835,16 +3835,16 @@ if (!nullp(args)) goto fehler_dotted; setSTACK(STACK = STACKbefore); # clean up STACK closure = popSTACK(); - fehler_eval_zuwenig(TheCclosure(closure)->clos_name); + fehler_eval_zuwenig(Closure_name(closure)); fehler_zuviel: # Argument-list args is not NIL at the end if (atomp(args)) goto fehler_dotted; setSTACK(STACK = STACKbefore); # clean up STACK closure = popSTACK(); - fehler_eval_zuviel(TheCclosure(closure)->clos_name); + fehler_eval_zuviel(Closure_name(closure)); fehler_dotted: # Argument-list args ends with Atom /= NIL setSTACK(STACK = STACKbefore); # clean up STACK closure = popSTACK(); - fehler_eval_dotted(TheCclosure(closure)->clos_name); + fehler_eval_dotted(Closure_name(closure)); } #ifdef DYNAMIC_FFI @@ -6452,7 +6452,7 @@ # The Compiler has already checked, that it's a Symbol. if (!boundp(Symbol_value(symbol))) { pushSTACK(symbol); # CELL-ERROR slot NAME - pushSTACK(symbol); pushSTACK(TheCclosure(closure)->clos_name); + pushSTACK(symbol); pushSTACK(Closure_name(closure)); fehler(unbound_variable,GETTEXT("~S: symbol ~S has no value")); } VALUES1(Symbol_value(symbol)); @@ -6466,7 +6466,7 @@ # The Compiler has already checked, that it's a Symbol. if (!boundp(Symbol_value(symbol))) { pushSTACK(symbol); # CELL-ERROR slot NAME - pushSTACK(symbol); pushSTACK(TheCclosure(closure)->clos_name); + pushSTACK(symbol); pushSTACK(Closure_name(closure)); fehler(unbound_variable,GETTEXT("~S: symbol ~S has no value")); } pushSTACK(Symbol_value(symbol)); @@ -6479,7 +6479,7 @@ var object symbol = TheCclosure(closure)->clos_consts[n]; # The Compiler has already checked, that it's a Symbol. if (constantp(TheSymbol(symbol))) { - pushSTACK(symbol); pushSTACK(TheCclosure(closure)->clos_name); + pushSTACK(symbol); pushSTACK(Closure_name(closure)); fehler(error,GETTEXT("~S: assignment to constant symbol ~S is impossible")); } Symbol_value(symbol) = value1; mv_count=1; Index: spvw_circ.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_circ.d,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- spvw_circ.d 2 Jun 2004 10:22:12 -0000 1.29 +++ spvw_circ.d 3 Aug 2004 11:05:11 -0000 1.30 @@ -480,7 +480,7 @@ if (env->pr_closure) # track components? goto m_record_components; # all components are printed (see below) else { # only mark the name (tail-end-recursive) - obj = TheClosure(obj)->clos_name; goto entry; + obj = Closure_name(obj); goto entry; } case_structure: # Structure if (mlb_add(&env->bitmap,obj)) # marked? @@ -837,7 +837,7 @@ if (env->pr_closure) # track components? goto m_record_components; # all components are printed (see below) else { # only mark the name (tail-end-recursive) - obj = TheClosure(obj)->clos_name; goto entry; + obj = Closure_name(obj); goto entry; } case_structure: # Structure if (marked(TheStructure(obj))) # marked? @@ -1080,7 +1080,7 @@ if (env->pr_closure) # were components tracked? goto u_record_components; # all components are printed (see below) else { # only unmark the name (tail-end-recursive) - obj = TheClosure(obj)->clos_name; goto entry; + obj = Closure_name(obj); goto entry; } case_structure: # unmark structure: if (!marked(TheStructure(obj))) # already unmarked? Index: record.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/record.d,v retrieving revision 1.90 retrieving revision 1.91 diff -u -d -r1.90 -r1.91 --- record.d 27 Jul 2004 23:50:06 -0000 1.90 +++ record.d 3 Aug 2004 11:05:13 -0000 1.91 @@ -58,20 +58,23 @@ return &TheRecord(record)->recdata[index]; /* record element address */ } +/* (SYS::%RECORD-REF record index) return the index'th entry in the record */ LISPFUNNR(record_ref,2) -{ /* (SYS::%RECORD-REF record index) return the index'th entry in the record */ +{ VALUES1(*(record_up())); /* record element as value */ } /* (SYS::%RECORD-STORE record index value) store value as the index'th entry in the record and return value. */ -LISPFUNN(record_store,3) { +LISPFUNN(record_store,3) +{ var object value = popSTACK(); VALUES1(*(record_up()) = value); /* set record element */ } +/* (SYS::%RECORD-LENGTH record) return the length of the record. */ LISPFUNNR(record_length,1) -{ /* (SYS::%RECORD-LENGTH record) return the length of the record. */ +{ /* the record must be a Closure/Structure/Stream/OtherRecord: */ if_recordp(STACK_0, ; , { fehler_record(); } ); var object record = popSTACK(); @@ -257,8 +260,8 @@ (SYS::CLOSURE-CONSTS closure) returns a list of all constants of a compiled closure. (SYS::MAKE-CODE-VECTOR list) returns for a list of fixnums >=0, <256 - a simple-bit-vector of eight fold length, that contains these numbers - as bytes. + a simple-8bit-vector of the same length, that contains these numbers + as bytes. (SYS::%MAKE-CLOSURE name codevec consts seclass) returns a closure with given name (a symbol), given code-vector (a simple-bit-vector) and further given constants. @@ -273,6 +276,7 @@ (APPLY generic-function arguments) == (APPLY (APPLY ergebnis arguments) arguments) . */ + /* (SYS::CLOSURE-NAME closure) returns the name of a closure. */ LISPFUNNR(closure_name,1) { var object closure = popSTACK(); @@ -282,7 +286,7 @@ fehler(error, /* type_error ?? */ GETTEXT("~S: ~S is not a closure")); } - VALUES1(TheClosure(closure)->clos_name); + VALUES1(Closure_name(closure)); } /* error, if argument is not a compiled closure */ @@ -336,8 +340,8 @@ } /* (SYS::MAKE-CODE-VECTOR list) returns for a list of fixnums >=0, <256 - a simple-bit-vector of eight fold length, that contains these - numbers as bytes. */ + a simple-8bit-vector of the same length, that contains these numbers + as bytes. */ LISPFUNNR(make_code_vector,1) { var object bv = allocate_bit_vector(Atype_8Bit,llength(STACK_0)); /* simple-8bit-vector */ /* fill: */ @@ -400,7 +404,7 @@ fehler(error,GETTEXT("~S: function ~S is too big: ~S")); } var object closure = allocate_closure(length,seclass); - TheCclosure(closure)->clos_name = STACK_2; /* fill name */ + TheCclosure(closure)->clos_name_or_class_version = STACK_2; /* fill name */ TheCclosure(closure)->clos_codevec = STACK_1; /* fill codevector */ { /* fill constants: */ var object constsr = popSTACK(); @@ -430,7 +434,7 @@ { var object obj = popSTACK(); VALUES_IF(closurep(obj) - && eq(TheClosure(obj)->clos_name,S(constant_initfunction)) + && eq(TheClosure(obj)->clos_name_or_class_version,S(constant_initfunction)) && eq(TheClosure(obj)->clos_codevec,O(constant_initfunction_code))); } @@ -690,14 +694,16 @@ /* =========================================================================== * CLOS objects: */ +/* (CLOS::STRUCTURE-OBJECT-P object) tests if object is a structure. */ LISPFUNNF(structure_object_p,1) -{ /* (CLOS::STRUCTURE-OBJECT-P object) checks if object is a structure. */ +{ var object obj = popSTACK(); VALUES_IF(structurep(obj)); } +/* (CLOS::STD-INSTANCE-P object) tests if object is a CLOS-object. */ LISPFUNNF(std_instance_p,1) -{ /* (CLOS::STD-INSTANCE-P object) checks if object is a CLOS-object. */ +{ var object obj = popSTACK(); VALUES_IF(instancep(obj)); } @@ -1232,7 +1238,7 @@ eval_init: /* evaluate the initform: */ if (closurep(init) - && eq(TheClosure(init)->clos_name,S(constant_initfunction)) + && eq(TheClosure(init)->clos_name_or_class_version,S(constant_initfunction)) && eq(TheClosure(init)->clos_codevec,O(constant_initfunction_code))) { value1 = TheClosure(init)->other[0]; } else { @@ -1426,7 +1432,7 @@ if (nullp(init)) goto slot_done; if (closurep(init) - && eq(TheClosure(init)->clos_name,S(constant_initfunction)) + && eq(TheClosure(init)->clos_name_or_class_version,S(constant_initfunction)) && eq(TheClosure(init)->clos_codevec,O(constant_initfunction_code))) { value1 = TheClosure(init)->other[0]; } else { @@ -1512,7 +1518,7 @@ { var object init = Car(Cdr(Cdr(default_initarg))); if (closurep(init) - && eq(TheClosure(init)->clos_name,S(constant_initfunction)) + && eq(TheClosure(init)->clos_name_or_class_version,S(constant_initfunction)) && eq(TheClosure(init)->clos_codevec,O(constant_initfunction_code))) { pushSTACK(TheClosure(init)->other[0]); /* default in the stack */ } else { Index: clos-genfun2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-genfun2.lisp,v retrieving revision 1.18 retrieving revision 1.19 diff -u -d -r1.18 -r1.19 --- clos-genfun2.lisp 30 Jul 2004 11:58:43 -0000 1.18 +++ clos-genfun2.lisp 3 Aug 2004 11:05:13 -0000 1.19 @@ -219,7 +219,7 @@ (defvar *warn-if-gf-already-called* t) (defun need-gf-already-called-warning-p (gf) (and *warn-if-gf-already-called* (not (gf-never-called-p gf)) - (not (memq (sys::%record-ref gf 0) + (not (memq (sys::closure-name gf) *dynamically-modifiable-generic-function-names*)))) (defun warn-if-gf-already-called (gf) (when (need-gf-already-called-warning-p gf) Index: spvw_debug.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_debug.d,v retrieving revision 1.50 retrieving revision 1.51 diff -u -d -r1.50 -r1.51 --- spvw_debug.d 7 Jun 2004 10:41:25 -0000 1.50 +++ spvw_debug.d 3 Aug 2004 11:05:11 -0000 1.51 @@ -122,7 +122,7 @@ string_out(out, (genericfunctionp(obj) ? O(printstring_generic_function) : O(printstring_compiled_closure))); - obj = TheClosure(obj)->clos_name; + obj = Closure_name(obj); } #ifdef DYNAMIC_FFI else if (ffunctionp(obj)) { Index: edit.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/edit.lisp,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- edit.lisp 4 Jun 2004 13:57:10 -0000 1.10 +++ edit.lisp 3 Aug 2004 11:05:13 -0000 1.11 @@ -47,7 +47,7 @@ (if (or (pathnamep arg) (stringp arg)) (edit-file arg) (if (and (cond ((function-name-p arg) (setq funname arg) t) - ((functionp arg) (function-name-p (setq funname (sys::%record-ref arg 0)))) + ((functionp arg) (function-name-p (setq funname (sys::closure-name arg)))) (t nil) ) (fboundp (setq sym (get-funname-symbol funname))) @@ -85,7 +85,7 @@ (defun uncompile (arg &aux funname sym fun def) (if (and (cond ((function-name-p arg) (setq funname arg) t) - ((functionp arg) (function-name-p (setq funname (sys::%record-ref arg 0)))) + ((functionp arg) (function-name-p (setq funname (sys::closure-name arg)))) (t nil) ) (fboundp (setq sym (get-funname-symbol funname))) Index: io.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/io.d,v retrieving revision 1.236 retrieving revision 1.237 diff -u -d -r1.236 -r1.237 --- io.d 14 Jun 2004 10:39:52 -0000 1.236 +++ io.d 3 Aug 2004 11:05:11 -0000 1.237 @@ -9491,7 +9491,7 @@ } else { # *PRINT-CLOSURE* = NIL -> # only print #<GENERIC-FUNCTION name> resp. #<COMPILED-CLOSURE name> : - pr_other_obj(stream_,TheClosure(obj)->clos_name, + pr_other_obj(stream_,Closure_name(obj), (TheCodevec(TheClosure(obj)->clos_codevec)->ccv_flags & bit(4) # generic function? ? O(printstring_generic_function) : O(printstring_compiled_closure))); @@ -9540,7 +9540,7 @@ INDENT_START(3); # indent by 3 characters, because of '#Y(' JUSTIFY_START(1); JUSTIFY_LAST(false); - prin_object(stream_,TheClosure(*obj_)->clos_name); # print Name + prin_object(stream_,Closure_name(*obj_)); # print Name JUSTIFY_SPACE; # print Codevector bytewise, treat possible circularity: pr_circle(stream_,TheClosure(*obj_)->clos_codevec,&pr_cclosure_codevector); Index: disassem.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/disassem.lisp,v retrieving revision 1.18 retrieving revision 1.19 diff -u -d -r1.18 -r1.19 --- disassem.lisp 30 Jul 2004 11:58:43 -0000 1.18 +++ disassem.lisp 3 Aug 2004 11:05:13 -0000 1.19 @@ -57,7 +57,7 @@ ;; the object is a closure. (unless (sys::%compiled-function-p object) (setq object - (compile-lambda (sys::%record-ref object 0) ; name + (compile-lambda (sys::closure-name object) ; name (sys::%record-ref object 1) ; lambdabody (sys::%record-ref object 4) ; venv (sys::%record-ref object 5) ; fenv Index: functions.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/functions.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- functions.lisp 26 May 2004 20:03:23 -0000 1.3 +++ functions.lisp 3 Aug 2004 11:05:13 -0000 1.4 @@ -36,7 +36,7 @@ ((sys::subr-info obj) (values nil nil (sys::subr-info obj))) ((sys::%compiled-function-p obj) ; compiled closure? - (let* ((name (sys::%record-ref obj 0)) + (let* ((name (sys::closure-name obj)) (def (get name 'sys::definition))) (values (when def (cons 'LAMBDA (cddar def))) t name))) ((sys::closurep obj) ; interpreted closure? @@ -47,7 +47,7 @@ (sys::%record-ref obj 6) ; benv (sys::%record-ref obj 7) ; genv (sys::%record-ref obj 8)); denv - (sys::%record-ref obj 0))))) ; name + (sys::closure-name obj))))) ; name (defun function-name (obj) ;; Equivalent to (nth-value 2 (function-lambda-expression obj)) @@ -57,6 +57,6 @@ (sys::%record-ref obj 0)) ((sys::subr-info obj)) ((sys::%compiled-function-p obj) ; compiled closure? - (sys::%record-ref obj 0)) + (sys::closure-name obj)) ((sys::closurep obj) ; interpreted closure? - (sys::%record-ref obj 0)))) + (sys::closure-name obj)))) Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.535 retrieving revision 1.536 diff -u -d -r1.535 -r1.536 --- lispbibl.d 26 Jul 2004 19:06:14 -0000 1.535 +++ lispbibl.d 3 Aug 2004 11:05:10 -0000 1.536 @@ -5609,9 +5609,9 @@ # Closures typedef struct { SRECORD_HEADER - gcv_object_t clos_name _attribute_aligned_object_; - gcv_object_t clos_codevec _attribute_aligned_object_; - gcv_object_t other[unspecified] _attribute_aligned_object_; + gcv_object_t clos_name_or_class_version _attribute_aligned_object_; + gcv_object_t clos_codevec _attribute_aligned_object_; + gcv_object_t other[unspecified] _attribute_aligned_object_; } * Closure; # interpreted Closure: typedef struct { @@ -5643,9 +5643,9 @@ # compiled Closure: typedef struct { SRECORD_HEADER - gcv_object_t clos_name _attribute_aligned_object_; - gcv_object_t clos_codevec _attribute_aligned_object_; - gcv_object_t clos_consts[unspecified] _attribute_aligned_object_; # Closure-constants + gcv_object_t clos_name_or_class_version _attribute_aligned_object_; + gcv_object_t clos_codevec _attribute_aligned_object_; + gcv_object_t clos_consts[unspecified] _attribute_aligned_object_; # Closure-constants } * Cclosure; #define cclosure_length(ptr) srecord_length(ptr) #define Cclosure_length(obj) cclosure_length(TheCclosure(obj)) @@ -5657,7 +5657,10 @@ #define Cclosure_flags(obj) cclosure_flags(TheCclosure(obj)) #define Cclosure_seclass(obj) Cclosure_flags(obj) #define Cclosure_set_seclass(cc,se) record_flags_replace(TheCclosure(cc),se) +# Closed-over environment, as a set of nested simple-vectors. #define clos_venv clos_consts[0] +# The function's name. +#define Closure_name(obj) TheClosure(obj)->clos_name_or_class_version typedef struct { VRECORD_HEADER # self-pointer for GC, length in bits # Here: Content of the Bitvector. --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3366,1.3367 control.d,1.97,1.98 Date: Tue, 03 Aug 2004 12:46:08 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12619 Modified Files: ChangeLog control.d Log Message: Use Closure_name also in FUNCTION-SIDE-EFFECT. Index: control.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/control.d,v retrieving revision 1.97 retrieving revision 1.98 diff -u -d -r1.97 -r1.98 --- control.d 27 Jul 2004 23:49:19 -0000 1.97 +++ control.d 3 Aug 2004 12:46:05 -0000 1.98 @@ -2221,26 +2221,36 @@ VALUES_IF(form_constant_p(popSTACK())); } +/* (FUNCTION-SIDE-EFFECT fun) -> seclass, fdefinition, name */ LISPFUNNR(function_side_effect,1) -{ /* (FUNCTION-SIDE-EFFECT fun) -> seclass, fdefinition, name - this function is called at compile time, so the argument does not have to - be a function, it may be a variable name whose value will be some function - at run time, therefore we never signal errors, just return *SECLASS-DIRTY* */ +{ /* This function is called at compile time, so the argument does not have to + be a function, it may be a variable name whose value will be some function + at run time. Therefore we never signal errors, just return *SECLASS-DIRTY*. */ var object fdef = popSTACK(); var object name = unbound; - if (consp(fdef) && (eq(S(quote),Car(fdef)) || eq(S(function),Car(fdef)))) + if (consp(fdef) && consp(Cdr(fdef)) + && (eq(S(quote),Car(fdef)) || eq(S(function),Car(fdef)))) fdef = Car(Cdr(fdef)); - if (funnamep(fdef)) fdef = funname_to_symbol(name=fdef); /* won't cons! */ - if (symbolp(fdef)) fdef = Symbol_function(fdef); - /* if the argument was a constant function, then we have it now */ + if (funnamep(fdef)) { + name = fdef; + fdef = funname_to_symbol(fdef); /* cannot trigger GC here! */ + } + if (symbolp(fdef)) + fdef = Symbol_function(fdef); + /* If the argument was a function object, then we have it now. */ var seclass_t seclass = seclass_default; - if (subrp(fdef)) seclass = (seclass_t)TheSubr(fdef)->seclass; - else if (cclosurep(fdef)) seclass = (seclass_t)Cclosure_seclass(fdef); + if (subrp(fdef)) + seclass = (seclass_t)TheSubr(fdef)->seclass; + else if (cclosurep(fdef)) + seclass = (seclass_t)Cclosure_seclass(fdef); if (!boundp(name) && boundp(fdef)) { - if (subrp(fdef)) name = TheSubr(fdef)->name; - else if (closurep(fdef)) name = TheClosure(fdef)->clos_name; + if (subrp(fdef)) + name = TheSubr(fdef)->name; + else if (closurep(fdef)) + name = Closure_name(fdef); } - VALUES3(seclass_object(seclass),boundp(fdef) ? fdef : NIL, + VALUES3(seclass_object(seclass), + boundp(fdef) ? fdef : NIL, boundp(name) ? name : NIL); } Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3366 retrieving revision 1.3367 diff -u -d -r1.3366 -r1.3367 --- ChangeLog 3 Aug 2004 11:05:13 -0000 1.3366 +++ ChangeLog 3 Aug 2004 12:46:04 -0000 1.3367 @@ -12,6 +12,8 @@ (SYS::%MAKE-CLOSURE, SYS::CONSTANT-INITFUNCTION-P, CLOS::%SHARED-INITIALIZE, do_initialize_instance, CLOS::%MAKE-INSTANCE): Likewise. + * control.d (FUNCTION-SIDE-EFFECT): Likewise. Check that Cdr(fdef) is + a cons before accessing its Car. * functions.lisp (function-lambda-expression, function-name): Use sys::closure-name. * clos-genfun2.lisp (need-gf-already-called-warning-p): Likewise. --__--__-- Message: 3 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3367,1.3368 Date: Tue, 03 Aug 2004 16:35:14 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22996/src Modified Files: ChangeLog Log Message: formatting Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3367 retrieving revision 1.3368 diff -u -d -r1.3367 -r1.3368 --- ChangeLog 3 Aug 2004 12:46:04 -0000 1.3367 +++ ChangeLog 3 Aug 2004 16:35:09 -0000 1.3368 @@ -9,9 +9,9 @@ (interpret_bytecode_): Likewise. * io.d (pr_cclosure, pr_cclosure_lang): Likewise. * record.d (SYS::CLOSURE-NAME): Likewise. - (SYS::%MAKE-CLOSURE, SYS::CONSTANT-INITFUNCTION-P, - CLOS::%SHARED-INITIALIZE, do_initialize_instance, CLOS::%MAKE-INSTANCE): - Likewise. + (SYS::%MAKE-CLOSURE, SYS::CONSTANT-INITFUNCTION-P) + (CLOS::%SHARED-INITIALIZE, do_initialize_instance) + (CLOS::%MAKE-INSTANCE): Likewise. * control.d (FUNCTION-SIDE-EFFECT): Likewise. Check that Cdr(fdef) is a cons before accessing its Car. * functions.lisp (function-lambda-expression, function-name): Use --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/doc multithread.txt,1.3,1.4 Date: Tue, 03 Aug 2004 18:17:56 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10719 Modified Files: multithread.txt Log Message: State a general principle about multithreading. Explain why hash tables must have an (optional) way of being locked. Index: multithread.txt =================================================================== RCS file: /cvsroot/clisp/clisp/doc/multithread.txt,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- multithread.txt 12 Jul 2004 14:00:12 -0000 1.3 +++ multithread.txt 3 Aug 2004 18:17:54 -0000 1.4 @@ -3,6 +3,28 @@ is currently being developed and does not work yet. +General principles +------------------ + +* Parallelizability Principle: + + Simple formulation: + "A program that was developed for a single-threaded world and which shares + no application objects with programs running in other threads must run + fine, without problems." + + Extended formulation: + "If, in a single-threaded world, execution of program A before program B + produces semantically the same results as execution of program B before + program A, then in a multithreaded world, it is possible to run A and B + simultaneously in different threads, and the result will be the same as + in the two single-threaded cases (A before B, or B before A)." + That's what the users ultimately want. + - If A and B have no objects in common, then the implementation ensures by + itself that the principle is fulfilled. + - If A and B shared some objects, the implementation allows the programs + to satisfy the principle with little effort. + Installation ------------ @@ -53,7 +75,8 @@ -------- PACKAGE objects are LOCKABLE and are locked by INTERN before adding a -symbol (if FUND-SYMBOL fails). +symbol (if FIND-SYMBOL fails). +(This is a consequence of the Parallelizability Principle.) This puts an unknown speed penalty on READ and therefore LOAD. CLOS @@ -61,6 +84,7 @@ DEFCLASS, DEFGENERIC, DEFMETHOD, DEFSTRUCT must get a global "DEF-CLOS" lock because they change the global class hierarchy. +(This is a consequence of the Parallelizability Principle.) Hash Tables and Sequences ------------------------- @@ -70,6 +94,16 @@ If two threads evaluate (INCF (GETHASH x global-ht 0)), the results are undefined. +-- But this doesn't allow the programmer to fulfill the Parallelizability + Principle easily. + Program PRELUDE: (defparameter global-ht (make-hash-table)) + Program A: (setf (gethash 'a global-ht) 'aaaa) + Program B: (setf (gethash 'b global-ht) 'bbbb) + The Parallelizability Principle implies that the programmer should + have an easy way to declare that global-ht is shared, without modifying + the programs A and B. The obvious proposal is that he changes the PRELUDE: + (defparameter global-ht (make-hash-table :lockable t)) +-- Automatic locking will impose an unjustifiable penalty on HASH-TABLEs and SEQUENCEs local to threads. It is also consistent with the usual Common Lisp approach of --__--__-- Message: 5 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc multithread.txt,1.4,1.5 Date: Tue, 03 Aug 2004 21:03:28 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12597 Modified Files: multithread.txt Log Message: refute Bruno's (make-hash-table :lockable t) proposal Index: multithread.txt =================================================================== RCS file: /cvsroot/clisp/clisp/doc/multithread.txt,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- multithread.txt 3 Aug 2004 18:17:54 -0000 1.4 +++ multithread.txt 3 Aug 2004 21:03:26 -0000 1.5 @@ -99,10 +99,25 @@ Program PRELUDE: (defparameter global-ht (make-hash-table)) Program A: (setf (gethash 'a global-ht) 'aaaa) Program B: (setf (gethash 'b global-ht) 'bbbb) - The Parallelizability Principle implies that the programmer should + The Parallelizability Principle implies that one should have an easy way to declare that global-ht is shared, without modifying - the programs A and B. The obvious proposal is that he changes the PRELUDE: + the programs A and B. The obvious proposal is a change in the PRELUDE: (defparameter global-ht (make-hash-table :lockable t)) + While this automatic locking will indeed work when no keys are shared, + this is not a universal solution: + Program A: (incf (gethash 10 global-ht 0)) + Program B: (incf (gethash 10 global-ht 0)) + It is possible that both GETHASH calls will happen before both + PUTHASH calls unless both INCF forms are guarded with a lock. + Instead of making GLOBAL-HT an instance of LOCK (and relying on some + magic which cannot always work), one needs to create an explicit lock with + (defparameter global-ht-lock (ext:make-lock)) + and wrap all his GLOBAL-HT accesses with + (with-lock (global-ht-lock) + (incf (gethash 'a global-ht 0))) + The bottom line is: programs that use global variables do not fall + under the Parallelizability Principle because they share application + objects with programs running in other threads. -- Automatic locking will impose an unjustifiable penalty on HASH-TABLEs and SEQUENCEs local to threads. --__--__-- Message: 6 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src genclisph.d,1.141,1.142 ChangeLog,1.3368,1.3369 Date: Tue, 03 Aug 2004 22:48:49 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31185/src Modified Files: genclisph.d ChangeLog Log Message: (number_immediatep): export (positivep): use it Index: genclisph.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/genclisph.d,v retrieving revision 1.141 retrieving revision 1.142 diff -u -d -r1.141 -r1.142 --- genclisph.d 26 Jul 2004 17:20:27 -0000 1.141 +++ genclisph.d 3 Aug 2004 22:48:45 -0000 1.142 @@ -1308,7 +1308,14 @@ printf("#define positivep(obj) (!wbit_test(as_oint(obj),%d))\n",sign_bit_o); #endif #else - printf2("#define positivep(obj) ((as_oint(obj) & wbit(1)) ? (as_oint(obj) & %d) == 0 : (Record_flags(obj) & %d) == 0)\n",wbit(sign_bit_o),bit(7)); + #ifdef STANDARD_HEAPCODES + printf("#define number_immediatep(obj) ((as_oint(obj) & wbit(1)) != 0)\n"); + #elif LINUX_NOEXEC_HEAPCODES + printf("#define number_immediatep(obj) ((as_oint(obj) & wbit(1)) == 0)\n"); + #else + #error "what is your HEAPCODES model?" + #endif + printf2("#define positivep(obj) (number_immediatep(obj) ? (as_oint(obj) & %d) == 0 : (Record_flags(obj) & %d) == 0)\n",wbit(sign_bit_o),bit(7)); #endif #ifdef TYPECODES printf("#define FN_positivep(obj) positivep(obj)\n"); Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3368 retrieving revision 1.3369 diff -u -d -r1.3368 -r1.3369 --- ChangeLog 3 Aug 2004 16:35:09 -0000 1.3368 +++ ChangeLog 3 Aug 2004 22:48:45 -0000 1.3369 @@ -1,3 +1,8 @@ +2004-08-03 Sam Steingold <sd...@gn...> + + * genclisph.d (number_immediatep): export + (positivep): use it + 2004-06-12 Bruno Haible <br...@cl...> * lispbibl.d (Closure, Cclosure): Rename field clos_name to --__--__-- Message: 7 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src genclisph.d,1.142,1.143 Date: Tue, 03 Aug 2004 22:50:36 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31506 Modified Files: genclisph.d Log Message: fixed typo in the last patch Index: genclisph.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/genclisph.d,v retrieving revision 1.142 retrieving revision 1.143 diff -u -d -r1.142 -r1.143 --- genclisph.d 3 Aug 2004 22:48:45 -0000 1.142 +++ genclisph.d 3 Aug 2004 22:50:34 -0000 1.143 @@ -1308,9 +1308,9 @@ printf("#define positivep(obj) (!wbit_test(as_oint(obj),%d))\n",sign_bit_o); #endif #else - #ifdef STANDARD_HEAPCODES + #if defined(STANDARD_HEAPCODES) printf("#define number_immediatep(obj) ((as_oint(obj) & wbit(1)) != 0)\n"); - #elif LINUX_NOEXEC_HEAPCODES + #elif defined(LINUX_NOEXEC_HEAPCODES) printf("#define number_immediatep(obj) ((as_oint(obj) & wbit(1)) == 0)\n"); #else #error "what is your HEAPCODES model?" --__--__-- Message: 8 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src genclisph.d,1.143,1.144 Date: Tue, 03 Aug 2004 23:03:02 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1406 Modified Files: genclisph.d Log Message: avoid wbit() in clisp.h Index: genclisph.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/genclisph.d,v retrieving revision 1.143 retrieving revision 1.144 diff -u -d -r1.143 -r1.144 --- genclisph.d 3 Aug 2004 22:50:34 -0000 1.143 +++ genclisph.d 3 Aug 2004 23:03:00 -0000 1.144 @@ -1309,9 +1309,9 @@ #endif #else #if defined(STANDARD_HEAPCODES) - printf("#define number_immediatep(obj) ((as_oint(obj) & wbit(1)) != 0)\n"); + printf1("#define number_immediatep(obj) ((as_oint(obj) & %d) != 0)\n",wbit(1)); #elif defined(LINUX_NOEXEC_HEAPCODES) - printf("#define number_immediatep(obj) ((as_oint(obj) & wbit(1)) == 0)\n"); + printf1("#define number_immediatep(obj) ((as_oint(obj) & %d) == 0)\n",wbit(1)); #else #error "what is your HEAPCODES model?" #endif --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |