Menu
▾
▴
clisp-cvs Digest, Vol 5, Issue 2
|
From: <cli...@li...> - 2006-09-04 04:12:32
|
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 pathname.d,1.393,1.394 ChangeLog,1.5377,1.5378 (Sam Steingold) 2. clisp/tests path.tst,1.62,1.63 ChangeLog,1.473,1.474 (Sam Steingold) 3. clisp/src ChangeLog,1.5378,1.5379 (Sam Steingold) 4. clisp configure,1.101,1.102 (Sam Steingold) 5. clisp/src NEWS,1.332,1.333 (Sam Steingold) 6. clisp/doc impbody.xml,1.442,1.443 (Sam Steingold) 7. clisp/tests restarts.tst,1.2,1.3 ChangeLog,1.474,1.475 (Sam Steingold) 8. clisp/src subr.d, 1.219, 1.220 spvw_debug.d, 1.71, 1.72 record.d, 1.110, 1.111 lispbibl.d, 1.710, 1.711 io.d, 1.293, 1.294 init.lisp, 1.252, 1.253 foreign1.lisp, 1.99, 1.100 foreign.d, 1.156, 1.157 eval.d, 1.202, 1.203 documentation.lisp, 1.24, 1.25 describe.lisp, 1.84, 1.85 constsym.d, 1.326, 1.327 constobj.d, 1.179, 1.180 compiler.lisp, 1.290, 1.291 NEWS, 1.333, 1.334 (Sam Steingold) ---------------------------------------------------------------------- Message: 1 Date: Sun, 03 Sep 2006 21:03:34 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src pathname.d,1.393,1.394 ChangeLog,1.5377,1.5378 To: cli...@li... Message-ID: <E1G...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv12961/clisp/src Modified Files: pathname.d ChangeLog Log Message: fixed bug #[ 1550803 ]: make-pathname ignores explicit :DIRECTORY NIL pathname.d (merge_dirs, MERGE-PATHNAMES): :DIRECTORY NIL overrides :DEFAULTS >From Stephen Compall <s11...@us...> Index: pathname.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/pathname.d,v retrieving revision 1.393 retrieving revision 1.394 diff -u -d -r1.393 -r1.394 --- pathname.d 12 Jan 2006 19:58:50 -0000 1.393 +++ pathname.d 3 Sep 2006 21:03:31 -0000 1.394 @@ -2703,7 +2703,7 @@ SDOUT("merge_dirs:",p_directory); SDOUT("merge_dirs:",d_directory); if (called_from_make_pathname) { - if (missingp(p_directory)) /* pathname-subdirs not given? */ + if (!boundp(p_directory)) /* pathname-subdirs not given? */ new_subdirs = d_directory; /* use defaults-subdirs */ } else if (!wildp) { if (nullp(p_directory) /* is pathname-subdirs trivial? */ @@ -2876,7 +2876,7 @@ { /* directories do not match: new-directory := pathname-directory */ var object dir = xpathname_directory(p_log,p); TheLogpathname(newp)->pathname_directory = - (missingp(dir) ? xpathname_directory(d_log,d) : dir); + (!SPECIFIED(dir) ? xpathname_directory(d_log,d) : dir); goto ldirectories_OK; } lmatch_directories: Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.5377 retrieving revision 1.5378 diff -u -d -r1.5377 -r1.5378 --- ChangeLog 3 Sep 2006 18:37:06 -0000 1.5377 +++ ChangeLog 3 Sep 2006 21:03:32 -0000 1.5378 @@ -1,3 +1,10 @@ +2006-09-03 Stephen Compall <s11...@us...> + Sam Steingold <sd...@po...> + + fixed bug #[ 1550803 ]: make-pathname ignores explicit :DIRECTORY NIL + * pathname.d (merge_dirs, MERGE-PATHNAMES): :DIRECTORY NIL + overrides :DEFAULTS + 2006-09-03 Magnus Henoch <ma...@fr...> Sam Steingold <sd...@po...> ------------------------------ Message: 2 Date: Sun, 03 Sep 2006 21:03:33 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/tests path.tst,1.62,1.63 ChangeLog,1.473,1.474 To: cli...@li... Message-ID: <E1G...@ma...> Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv12961/clisp/tests Modified Files: path.tst ChangeLog Log Message: fixed bug #[ 1550803 ]: make-pathname ignores explicit :DIRECTORY NIL pathname.d (merge_dirs, MERGE-PATHNAMES): :DIRECTORY NIL overrides :DEFAULTS >From Stephen Compall <s11...@us...> Index: path.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/path.tst,v retrieving revision 1.62 retrieving revision 1.63 diff -u -d -r1.62 -r1.63 --- path.tst 3 Jan 2006 17:19:54 -0000 1.62 +++ path.tst 3 Sep 2006 21:03:31 -0000 1.63 @@ -1088,3 +1088,10 @@ (delete-file file) (ext:delete-dir dir))) "/foo/**/*" (translate-logical-pathname "foo:bar;baz;zot.txt") #P"/foo/bar/baz/zot.txt" + +;; https://sourceforge.net/tracker/?func=detail&atid=101355&aid=1550803&group_id=1355 +(dolist (dflt (list #P"/home/" (logical-pathname "CLOCC:SRC;PORT;"))) + (dolist (dir '(NIL (:absolute "foo"))) + (assert (equal dir (pathname-directory (make-pathname :directory dir + :defaults dflt)))))) +NIL Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.473 retrieving revision 1.474 diff -u -d -r1.473 -r1.474 --- ChangeLog 11 Aug 2006 00:37:20 -0000 1.473 +++ ChangeLog 3 Sep 2006 21:03:31 -0000 1.474 @@ -1,3 +1,8 @@ +2006-09-03 Sam Steingold <sd...@po...> + + * path.tst: check that make-pathname does not ignore explicit + :DIRECTORY NIL (bug #[ 1550803 ]) + 2006-08-10 Sam Steingold <sd...@po...> * excepsit.tst: test ADJUST-ARRAY on non-adjustable vectors ------------------------------ Message: 3 Date: Sun, 03 Sep 2006 21:04:43 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog,1.5378,1.5379 To: cli...@li... Message-ID: <E1G...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv13363/clisp/src Modified Files: ChangeLog Log Message: accept FOO=BAR argument to set the shell variable Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.5378 retrieving revision 1.5379 diff -u -d -r1.5378 -r1.5379 --- ChangeLog 3 Sep 2006 21:03:32 -0000 1.5378 +++ ChangeLog 3 Sep 2006 21:04:41 -0000 1.5379 @@ -1,3 +1,7 @@ +2006-09-03 Sam Steingold <sd...@po...> + + * configure: accept FOO=BAR argument to set the shell variable + 2006-09-03 Stephen Compall <s11...@us...> Sam Steingold <sd...@po...> ------------------------------ Message: 4 Date: Sun, 03 Sep 2006 21:04:43 +0000 From: Sam Steingold <sd...@us...> Subject: clisp configure,1.101,1.102 To: cli...@li... Message-ID: <E1G...@ma...> Update of /cvsroot/clisp/clisp In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv13363/clisp Modified Files: configure Log Message: accept FOO=BAR argument to set the shell variable Index: configure =================================================================== RCS file: /cvsroot/clisp/clisp/configure,v retrieving revision 1.101 retrieving revision 1.102 diff -u -d -r1.101 -r1.102 --- configure 4 Aug 2006 00:21:13 -0000 1.101 +++ configure 3 Sep 2006 21:04:41 -0000 1.102 @@ -21,6 +21,8 @@ else CONFIG_SHELL=/bin/sh fi +fail () { echo "$*" >&2; exit 1; } + info_help () { cat << \EOP Usage: configure [options] [dirname] @@ -412,10 +414,15 @@ --ignore-absence-of-libsigsegv) ignore_absence_of_libsigsegv=yes ;; - --*) - echo "$0: invalid argument $arg" 1>&2 - echo "$0: Try \`$0 --help'" 1>&2 - exit 1 ;; + -*) + fail "$0: invalid argument $arg +$0: Try \`$0 --help'" ;; + + *=*) # set a variable + var=`echo $arg | sed 's/\([^=]*\)=.*/\1/'` + val=`echo $arg | sed 's/[^=]*=\(.*\)/\1/'` + eval "$var='$val'" + export $var ;; *) # Everything else counts as a positional argument argcount=`expr $argcount + 1` @@ -425,11 +432,8 @@ fi done -if test -n "$prev"; then - echo "$0: missing argument to $prev" 1>&2 - echo "$0: Try \`$0 --help'" 1>&2 - exit 1 -fi +test -n "$prev" && fail "$0: missing argument to $prev +$0: Try \`$0 --help'" DIRNAME=$POSARG1 COMPILER=$POSARG2 # deprecated @@ -497,10 +501,7 @@ INPLACE='' if test -n "$srcdir" ; then - if test ! -d "$srcdir" ; then - echo "$0: srcdir: ($srcdir) nonexistent" 1>&2 - exit 1 - fi + test -d "$srcdir" || fail "$0: srcdir: ($srcdir) nonexistent" ABS_SRCDIR=`abs_pwd "$srcdir"`; if [ "$DIRNAME" = "" ] ; then DIRNAME='.' @@ -515,15 +516,12 @@ DIRNAME=src fi else - if test -f ../ANNOUNCE -a -f ../SUMMARY; then - srcdir='..' - ABS_SRCDIR=`abs_pwd "$srcdir"` - if [ "$DIRNAME" = "" ] ; then - DIRNAME='.' - fi - else - echo "$0: source directory not found, use --srcdir option" 1>&2 - exit 1 + test -f ../ANNOUNCE -a -f ../SUMMARY || \ + fail "$0: source directory not found, use --srcdir option" + srcdir='..' + ABS_SRCDIR=`abs_pwd "$srcdir"` + if [ "$DIRNAME" = "" ] ; then + DIRNAME='.' fi fi maybe_mkdir "${DIRNAME}"; @@ -670,8 +668,7 @@ makemake_args="--with-dynamic-ffi $makemake_args" have_ffi=yes elif [ "$do_ffi" = "yes" ]; then - echo "$0: despite --with-dynamic-ffi, FFCALL could not be built" 1>&2 - exit 1 + fail "$0: despite --with-dynamic-ffi, FFCALL could not be built" fi fi ------------------------------ Message: 5 Date: Mon, 04 Sep 2006 00:19:57 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src NEWS,1.332,1.333 To: cli...@li... Message-ID: <E1G...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv21324/src Modified Files: NEWS Log Message: updated Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.332 retrieving revision 1.333 diff -u -d -r1.332 -r1.333 --- NEWS 11 Aug 2006 00:37:20 -0000 1.332 +++ NEWS 4 Sep 2006 00:19:54 -0000 1.333 @@ -7,6 +7,8 @@ The default value is ${datadir}/emacs/site-lisp/. Thus, clhs.el at al are now installed by "make install", and should be included in the 3rd party distributions. + + Top-level configure now accepts variables on command line, e.g., + ./configure CC=g++ CFLAGS=-g * Function PCRE:PCRE-EXEC accepts :DFA and calls pcre_dfa_exec() when built against PCRE v6. See <http://clisp.cons.org/impnotes/pcre.html>. @@ -22,6 +24,10 @@ + PRINT-OBJECT now works on built-in objects. [ 1482533 ] + ADJUST-ARRAY signals an error if :FILL-POINTER is supplied and non-NIL but the non-adjustable array has no fill pointer, as per ANSI. [ 1538333 ] + + MAKE-PATHNAME no longer ignores explicit :DIRECTORY NIL (thanks to + Stephen Compall <s11...@us...>). [ 1550803 ] + + Executable images now work on ia64 (thanks to Dr. Werner Fink + <we...@su...>). 2.39 (2006-07-16) ------------------------------ Message: 6 Date: Mon, 04 Sep 2006 04:12:27 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/doc impbody.xml,1.442,1.443 To: cli...@li... Message-ID: <E1G...@ma...> Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv9872/doc Modified Files: impbody.xml Log Message: When the OPTIMIZE SPACE level is low enough, keep function documentation and lambda list. Index: impbody.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impbody.xml,v retrieving revision 1.442 retrieving revision 1.443 diff -u -d -r1.442 -r1.443 --- impbody.xml 16 Aug 2006 01:44:50 -0000 1.442 +++ impbody.xml 4 Sep 2006 04:12:25 -0000 1.443 @@ -259,8 +259,20 @@ <para>The type assertion <code>(&the; &val-type-r; &form-r;)</code> enforces a type check in interpreted code. No type check is done in compiled code. See also the ðe; macro.</para> - </section> + +<section id="space-decl"><title>Declaration &space-dec;</title> +<para>The declaration determines what metadata is recorded in the + function object:<variablelist> + <varlistentry><term>&space-dec; ≥ 2</term> + <listitem><simpara>documentation string is discarded + </simpara></listitem></varlistentry> + <varlistentry><term>&space-dec; ≥ 3</term> + <listitem><simpara>the original &lalist; is also discarded (most + information is still available, see &describe-my;, but the names of + the positional arguments are not).</simpara></listitem></varlistentry> +</variablelist></para></section> + </section> <section id="lalist"><title>Lambda Lists ------------------------------ Message: 7 Date: Mon, 04 Sep 2006 04:12:25 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/tests restarts.tst,1.2,1.3 ChangeLog,1.474,1.475 To: cli...@li... Message-ID: <E1G...@ma...> Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv9872/tests Modified Files: restarts.tst ChangeLog Log Message: When the OPTIMIZE SPACE level is low enough, keep function documentation and lambda list. Index: restarts.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/restarts.tst,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- restarts.tst 2 Aug 2005 21:19:20 -0000 1.2 +++ restarts.tst 4 Sep 2006 04:12:22 -0000 1.3 @@ -347,11 +347,17 @@ (last '#1# 2))) ((9 8) (9 8) (7 6) (7 6)) -(handler-bind ((error (lambda (c) (princ c) (use-value 'doc-restart)))) - (setf (documentation '(doc-restart) 'function) - "docstring for doc-restart") - (documentation 'doc-restart 'function)) -"docstring for doc-restart" +(handler-bind ((error (lambda (c) (princ c) (use-value 'check-use-value)))) + (setf (documentation '(check-use-value) 'function) + "docstring for check-use-value") + (documentation 'check-use-value 'function)) +"docstring for check-use-value" -(unintern 'doc-restart) -T +(handler-bind ((error (lambda (c) (princ c) (use-value 'use-value-read)))) + (setf (documentation '(use-value-read) 'function) + "docstring for use-value-read") + (documentation 'use-value-read 'function)) +"docstring for use-value-read" + +(unintern 'check-use-value) T +(unintern 'use-value-read) T Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.474 retrieving revision 1.475 diff -u -d -r1.474 -r1.475 --- ChangeLog 3 Sep 2006 21:03:31 -0000 1.474 +++ ChangeLog 4 Sep 2006 04:12:23 -0000 1.475 @@ -1,3 +1,8 @@ +2006-09-04 Sam Steingold <sd...@po...> + + * restarts.tst: do not use DOCUMENTATION 'FUNCTION on an + un-fboundp symbol + 2006-09-03 Sam Steingold <sd...@po...> * path.tst: check that make-pathname does not ignore explicit ------------------------------ Message: 8 Date: Mon, 04 Sep 2006 04:12:27 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src subr.d, 1.219, 1.220 spvw_debug.d, 1.71, 1.72 record.d, 1.110, 1.111 lispbibl.d, 1.710, 1.711 io.d, 1.293, 1.294 init.lisp, 1.252, 1.253 foreign1.lisp, 1.99, 1.100 foreign.d, 1.156, 1.157 eval.d, 1.202, 1.203 documentation.lisp, 1.24, 1.25 describe.lisp, 1.84, 1.85 constsym.d, 1.326, 1.327 constobj.d, 1.179, 1.180 compiler.lisp, 1.290, 1.291 NEWS, 1.333, 1.334 To: cli...@li... Message-ID: <E1G...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv9872/src Modified Files: subr.d spvw_debug.d record.d lispbibl.d io.d init.lisp foreign1.lisp foreign.d eval.d documentation.lisp describe.lisp constsym.d constobj.d compiler.lisp NEWS Log Message: When the OPTIMIZE SPACE level is low enough, keep function documentation and lambda list. Index: describe.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/describe.lisp,v retrieving revision 1.84 retrieving revision 1.85 diff -u -d -r1.84 -r1.85 --- describe.lisp 18 Apr 2006 15:40:49 -0000 1.84 +++ describe.lisp 4 Sep 2006 04:12:24 -0000 1.85 @@ -521,39 +521,27 @@ (sys::%record-ref obj 3) (sys::%record-ref obj 4))))) (COMPILED-FUNCTION - (multiple-value-bind (name req opt rest-p keywords other-keys) - (sys::subr-info obj) - (if (and name req) - (progn - (format stream (TEXT "a built-in system function.")) - (sys::describe-signature stream req opt rest-p - keywords keywords other-keys)) - (progn - (format stream (TEXT "a compiled function.")) - (multiple-value-bind (req opt rest-p key-p keywords other-keys-p) - (sys::signature obj) - (sys::describe-signature stream req opt rest-p key-p keywords - other-keys-p) - (let* ((name (sys::closure-name obj)) - (funform (cond ((and (symbolp name) (macro-function name)) - `(MACRO-FUNCTION ',name)) - ((fboundp name) `(FUNCTION ,name))))) - (when funform - (terpri stream) - (format stream - (TEXT "For more information, evaluate ~{~S~^ or ~}.") - `((DISASSEMBLE ,funform)))))))))) + (let ((subrp (sys::subr-info obj))) + (format stream (if subrp + (TEXT "a built-in system function.") + (TEXT "a compiled function."))) + (describe-arglist stream obj) + (describe-documentation stream obj) + (let* ((name (sys::function-name obj)) + (funform (cond ((and (symbolp name) (macro-function name)) + `(MACRO-FUNCTION ',name)) + ((fboundp name) `(FUNCTION ,name))))) + (when funform + (terpri stream) + (format stream + (TEXT "For more information, evaluate ~{~S~^ or ~}.") + `((DISASSEMBLE ,funform))))))) (FUNCTION ;; we do not use ETYPECASE here to ensure that if we do get here, ;; we are dealing with an Iclosure object (format stream (TEXT "an interpreted function.")) - (let ((doc (sys::%record-ref obj 2))) - (terpri stream) - (format stream (TEXT "Argument list: ~:S") - (car (sys::%record-ref obj 1))) - (when doc - (terpri stream) - (format stream (TEXT "Documentation: ~A") doc))))))) + (describe-arglist stream obj) + (describe-documentation stream obj))))) (defun describe1 (obj stream) (let ((objstring (sys::write-to-short-string @@ -607,19 +595,27 @@ (defun arglist (func) (setq func (coerce func 'function)) - (if (typep func 'generic-function) - ; Generic functions store the lambda-list. It has meaningful variable names. - (clos:generic-function-lambda-list func) - ; Normal functions store only the signature, no variable names. - (sig-to-list (get-signature func)))) + (cond ((typep func 'generic-function) + ;; Generic functions store the original lambda-list. + (clos:generic-function-lambda-list func)) + ((or (sys::subr-info func) ; built-in + #+FFI (eq (type-of func) 'FFI::FOREIGN-FUNCTION)) + (sig-to-list (get-signature func))) + ((sys::%compiled-function-p func) ; compiled closure + (or (sys::closure-lambda-list func) + (sig-to-list (get-signature func)))) + ((sys::closurep func) ; interpreted closure? + (car (sys::%record-ref func 1))))) -(defun describe-signature (stream req-anz opt-anz rest-p keyword-p keywords - allow-other-keys) +(defun describe-arglist (stream function) (terpri stream) - (format stream (TEXT "Argument list: ~A.") - (format nil "(~{~A~^ ~})" - (signature-to-list req-anz opt-anz rest-p keyword-p keywords - allow-other-keys)))) + (format stream (TEXT "Argument list: ~:S") (arglist function))) + +(defun describe-documentation (stream function) + (let ((doc (clos::function-documentation function))) + (when doc + (terpri stream) + (format stream (TEXT "Documentation: ~A") doc)))) ;;----------------------------------------------------------------------------- ;; auxiliary functions for CLISP metadata Index: io.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/io.d,v retrieving revision 1.293 retrieving revision 1.294 diff -u -d -r1.293 -r1.294 --- io.d 23 Dec 2005 19:17:59 -0000 1.293 +++ io.d 4 Sep 2006 04:12:24 -0000 1.294 @@ -2,7 +2,7 @@ * Input/Output for CLISP * Bruno Haible 1990-2005 * Marcus Daniels 11.3.1997 - * Sam Steingold 1998-2005 + * Sam Steingold 1998-2006 * German comments translated into English: Stefan Kain 2001-06-12 */ @@ -4298,12 +4298,20 @@ GETTEXT("~S from ~S: object #Y~S has not the syntax of a compiled closure")); } skipSTACK(3); - # execute (SYS::%MAKE-CLOSURE (first obj) (second obj) (cddr obj)): + /* (apply (function SYS::%MAKE-CLOSURE) obj): */ pushSTACK(Car(obj)); obj = Cdr(obj); /* 1st argument (name) */ pushSTACK(Car(obj)); obj = Cdr(obj); /* 2nd argument (codevec) */ - pushSTACK(Cdr(obj)); /* 3rd argument (const list) */ - pushSTACK(Car(obj)); /* 4th argument (side-effect class) */ - funcall(L(make_closure),4); + pushSTACK(Car(obj)); obj = Cdr(obj); /* 3rd argument (side-effect class) */ + pushSTACK(Car(obj)); obj = Cdr(obj); /* 4th argument (const list) */ + if (consp(obj)) { + pushSTACK(Car(obj)); obj = Cdr(obj); /* 5th argument (lambda-list) */ + if (consp(obj)) pushSTACK(Car(obj)); /* 6th argument (documentation) */ + else pushSTACK(Fixnum_0); /* 6th argument (no documentation) */ + } else { + pushSTACK(Fixnum_0); /* 5th argument (no lambda-list) */ + pushSTACK(Fixnum_0); /* 6th argument (no documentation) */ + } + funcall(L(make_closure),6); mv_count=1; # value1 as value } else { # n specified -> read Codevector: @@ -8523,7 +8531,8 @@ # > stream: stream # < stream: stream # can trigger GC -local maygc void pr_record_ab (const gcv_object_t* stream_, const gcv_object_t* obj_, +local maygc void pr_record_ab (const gcv_object_t* stream_, + const gcv_object_t* obj_, uintL index, uintL length) { var uintL len = Record_length(*obj_); # length of record var uintL length_limit = get_print_length(); # *PRINT-LENGTH*-limit @@ -9793,10 +9802,39 @@ 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); + var object codevec = TheCclosure(*obj_)->clos_codevec; + var uintB ccv_flags = TheCodevec(codevec)->ccv_flags; + pr_circle(stream_,codevec,&pr_cclosure_codevector); + JUSTIFY_SPACE; + KLAMMER_AUF; /* ( */ + INDENT_START(get_indent_lists()); /* ==> indent by 1 character */ + JUSTIFY_START(1); + /* ignore *PRINT-LENGTH* & *PRINT-LINES* because of *PRINT-READABLE* */ + var uintL last = Cclosure_last_const(*obj_); + var uintL pos = 0; + var bool lambda_list_p = ccv_flags_lambda_list_p(ccv_flags); + var bool documentation_p = ccv_flags_documentation_p(ccv_flags); + var uintL end = last - lambda_list_p - documentation_p; + if (end != (uintL)-1) + for (; true; pos++) { + prin_object(stream_,TheCclosure(*obj_)->clos_consts[pos]); + JUSTIFY_LAST(pos==end); + if (pos==end) break; + JUSTIFY_SPACE; /* print one Space */ + } + JUSTIFY_END_FILL; + INDENT_END; + KLAMMER_ZU; JUSTIFY_SPACE; prin_object(stream_,seclass_object((seclass_t)Cclosure_seclass(*obj_))); - pr_record_ab(stream_,obj_,2,2); # print remaining components + if (lambda_list_p) { /* lambda-list is a list */ + JUSTIFY_SPACE; + pr_list(stream_,TheCclosure(*obj_)->clos_consts[last-documentation_p]); + if (documentation_p) { /* documentation is a string or NIL */ + JUSTIFY_SPACE; + prin_object(stream_,TheCclosure(*obj_)->clos_consts[last]); + } + } JUSTIFY_END_FILL; INDENT_END; KLAMMER_ZU; Index: subr.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/subr.d,v retrieving revision 1.219 retrieving revision 1.220 diff -u -d -r1.219 -r1.220 --- subr.d 17 May 2006 12:59:40 -0000 1.219 +++ subr.d 4 Sep 2006 04:12:23 -0000 1.220 @@ -932,10 +932,13 @@ LISPFUNNR(closure_codevec,1) LISPFUNNR(closure_consts,1) LISPFUNNR(make_code_vector,1) -LISPFUNNR(make_closure,4) +LISPFUNNR(make_closure,6) LISPFUNN(make_constant_initfunction,1) LISPFUNN(constant_initfunction_p,1) LISPFUNN(closure_set_seclass,2) +LISPFUNNR(closure_documentation,1) +LISPFUNN(closure_set_documentation,2) +LISPFUNNR(closure_lambda_list,1) LISPFUNN(set_funcallable_instance_function,2) LISPFUNN(copy_generic_function,2) LISPFUNN(generic_function_effective_method_function,1) @@ -1386,13 +1389,13 @@ LISPFUN(foreign_allocate,seclass_default,1,0,norest,key,3, (kw(initial_contents),kw(count),kw(read_only))) LISPFUN(foreign_free,seclass_default,1,0,norest,key,1,(kw(full))) -LISPFUNN(lookup_foreign_function,2) +LISPFUNN(lookup_foreign_function,3) LISPFUN(foreign_call_out,seclass_default,1,0,rest,nokey,0,NIL) #if defined(WIN32_NATIVE) || defined(HAVE_DLOPEN) LISPFUN(foreign_library,seclass_default,1,1,norest,nokey,0,NIL) LISPFUNN(close_foreign_library,1) LISPFUNN(foreign_library_variable,4) -LISPFUNN(foreign_library_function,4) +LISPFUNN(foreign_library_function,5) #endif /* WIN32_NATIVE || HAVE_DLOPEN */ #endif /* DYNAMIC_FFI */ #ifdef HAVE_AFFI Index: constsym.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constsym.d,v retrieving revision 1.326 retrieving revision 1.327 diff -u -d -r1.326 -r1.327 --- constsym.d 18 Apr 2006 15:48:26 -0000 1.326 +++ constsym.d 4 Sep 2006 04:12:24 -0000 1.327 @@ -774,6 +774,9 @@ LISPSYM(make_constant_initfunction,"MAKE-CONSTANT-INITFUNCTION",system) /* ABI */ LISPSYM(constant_initfunction_p,"CONSTANT-INITFUNCTION-P",system) LISPSYM(closure_set_seclass,"CLOSURE-SET-SECLASS",system) +LISPSYM(closure_documentation,"CLOSURE-DOCUMENTATION",system) +LISPSYM(closure_set_documentation,"CLOSURE-SET-DOCUMENTATION",system) +LISPSYM(closure_lambda_list,"CLOSURE-LAMBDA-LIST",system) LISPSYM(set_funcallable_instance_function,"SET-FUNCALLABLE-INSTANCE-FUNCTION",clos) LISPSYM(copy_generic_function,"%COPY-GENERIC-FUNCTION",system) /* ABI */ LISPSYM(generic_function_effective_method_function,"GENERIC-FUNCTION-EFFECTIVE-METHOD-FUNCTION",system) Index: record.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/record.d,v retrieving revision 1.110 retrieving revision 1.111 diff -u -d -r1.110 -r1.111 --- record.d 3 May 2006 17:29:43 -0000 1.110 +++ record.d 4 Sep 2006 04:12:23 -0000 1.111 @@ -1,7 +1,7 @@ /* * Functions for records and structures in CLISP * Bruno Haible 1990-2005 - * Sam Steingold 1998-2004 + * Sam Steingold 1998-2006 * German comments translated into English: Stefan Kain 2002-04-16 */ #include "lispbibl.c" @@ -331,8 +331,11 @@ LISPFUNNR(closure_consts,1) { var object closure = popSTACK(); if (!(cclosurep(closure))) fehler_cclosure(closure); - /* comprise elements 2,3,... to a list: */ - var uintC index = Cclosure_length(closure)-2; /* index := length */ + /* put elements 2,3,... to a list: */ + var uintB ccv_flags = + TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags; + var uintC index = Cclosure_last_const(closure) + 1 + - ccv_flags_documentation_p(ccv_flags) - ccv_flags_lambda_list_p(ccv_flags); /* step through closure from behind and push constants onto a list: */ pushSTACK(closure); /* closure */ pushSTACK(NIL); /* list := () */ @@ -389,39 +392,49 @@ : (nullp(modifies) ? seclass_read : seclass_default)); } -/* (SYS::%MAKE-CLOSURE name codevec consts seclass) returns a closure - with given name (a symbol), given code-vector (a simple-bit-vector), - given constants, and given side-effect class. */ -LISPFUNNR(make_closure,4) { - var seclass_t seclass = parse_seclass(STACK_0,STACK_3); skipSTACK(1); +/* (SYS::%MAKE-CLOSURE name codevec consts seclass lambda-list documentation) + returns a closure with given name (a symbol), + given code-vector (a simple-bit-vector), given constants, + given side-effect class, lambda-list and documentation. */ +LISPFUNNR(make_closure,6) { + var seclass_t seclass = parse_seclass(STACK_2,STACK_5); /* codevec must be a simple-bit-vector: */ - if (!simple_bit_vector_p(Atype_8Bit,STACK_1)) { - /* STACK_1 = codevec */ - pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM */ + if (!simple_bit_vector_p(Atype_8Bit,STACK_4)) { + /* STACK_4 = codevec */ + pushSTACK(STACK_4); /* TYPE-ERROR slot DATUM */ pushSTACK(S(simple_bit_vector)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(STACK_(1+2)); + pushSTACK(STACK_(4+2)); pushSTACK(TheSubr(subr_self)->name); fehler(type_error,GETTEXT("~S: invalid code-vector ~S")); } - /* create a new closure of length (+ 2 (length consts)) : */ - var uintL length = 2+llength(STACK_0); + /* create a new closure of length (+ 2 (length consts) lalist-p doc-p) : */ + var uintL length = 2+llength(STACK_3) + +(listp(STACK_1) ? 1 : 0)+(nullp(STACK_0) || stringp(STACK_0) ? 1 : 0); if (!(length <= (uintL)(bitm(intWsize)-1))) { /* should fit into a uintW */ - /* STACK_0 = consts */ - pushSTACK(STACK_2); /* name */ + pushSTACK(STACK_4/*consts */); + pushSTACK(STACK_6/* name */); pushSTACK(TheSubr(subr_self)->name); fehler(error,GETTEXT("~S: function ~S is too big: ~S")); } var object closure = allocate_closure(length,seclass<<4); - 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(); - var gcv_object_t* ptr = &TheCclosure(closure)->clos_consts[0]; - while (consp(constsr)) { - *ptr++ = Car(constsr); constsr = Cdr(constsr); - } + TheCclosure(closure)->clos_name_or_class_version = STACK_5; /* fill name */ + TheCclosure(closure)->clos_codevec = STACK_4; /* fill codevector */ + /* fill constants: */ + var object constsr = STACK_3; + var gcv_object_t* ptr = &TheCclosure(closure)->clos_consts[0]; + while (consp(constsr)) { + *ptr++ = Car(constsr); constsr = Cdr(constsr); } - VALUES1(closure); skipSTACK(2); + var uintB *ccv_flags = &(TheCodevec(STACK_4)->ccv_flags); + if (listp(STACK_1)) { + *ccv_flags |= bit(1); + *ptr++ = STACK_1; + } else *ccv_flags &= ~bit(1); + if (nullp(STACK_0) || stringp(STACK_0)) { + *ccv_flags |= bit(2); + *ptr++ = STACK_0; + } else *ccv_flags &= ~bit(2); + VALUES1(closure); skipSTACK(6); } /* (SYS::MAKE-CONSTANT-INITFUNCTION value) returns a closure that, when called @@ -433,6 +446,8 @@ pushSTACK(O(constant_initfunction_code)); pushSTACK(consts); pushSTACK(O(seclass_no_se)); + pushSTACK(Fixnum_0); + pushSTACK(Fixnum_0); C_make_closure(); } @@ -457,6 +472,36 @@ skipSTACK(2); } +LISPFUNNR(closure_documentation,1) +{ /* return the doc string, if any */ + var object closure = popSTACK(); + if (!cclosurep(closure)) fehler_cclosure(closure); + VALUES1(TheCodevec(TheClosure(closure)->clos_codevec)->ccv_flags & bit(2) + ? TheCclosure(closure)->clos_consts[Cclosure_last_const(closure)] + : NIL); +} +LISPFUNN(closure_set_documentation,2) +{ /* set the doc string, if anypossible*/ + STACK_0 = check_string(STACK_0); + var object closure = STACK_1; + if (!cclosurep(closure)) fehler_cclosure(closure); + if (TheCodevec(TheClosure(closure)->clos_codevec)->ccv_flags & bit(2)) + TheCclosure(closure)->clos_consts[Cclosure_last_const(closure)] = STACK_0; + VALUES1(STACK_0); skipSTACK(2); +} +LISPFUNNR(closure_lambda_list,1) +{ /* return the lambda list, if any */ + var object closure = popSTACK(); + if (!cclosurep(closure)) fehler_cclosure(closure); + var uintB ccv_flags = + TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags; + /* depending on bit(2), the ultimate or the penultimate constant */ + VALUES1(ccv_flags & bit(1) + ? TheCclosure(closure)->clos_consts + [Cclosure_last_const(closure)-ccv_flags_documentation_p(ccv_flags)] + : NIL); +} + /* (CLOS:SET-FUNCALLABLE-INSTANCE-FUNCTION closure function) redirects closure so that it calls the given function. */ LISPFUNN(set_funcallable_instance_function,2) Index: foreign.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/foreign.d,v retrieving revision 1.156 retrieving revision 1.157 diff -u -d -r1.156 -r1.157 --- foreign.d 7 Feb 2006 17:00:24 -0000 1.156 +++ foreign.d 4 Sep 2006 04:12:24 -0000 1.157 @@ -1,7 +1,7 @@ /* Foreign language interface for CLISP * Marcus Daniels 8.4.1994 * Bruno Haible 1995-2005 - * Sam Steingold 2000-2005 + * Sam Steingold 2000-2006 */ #include "lispbibl.c" @@ -3107,11 +3107,12 @@ fehler(error,GETTEXT("~S: foreign function with unknown calling convention, missing DEF-CALL-OUT: ~S")); } -/* (FFI::LOOKUP-FOREIGN-FUNCTION foreign-function-name foreign-type) +/* (FFI::LOOKUP-FOREIGN-FUNCTION foreign-function-name foreign-type properties) looks up a foreign function, given its Lisp name. */ -LISPFUNN(lookup_foreign_function,2) +LISPFUNN(lookup_foreign_function,3) { var object ffun = allocate_ffunction(); + var object props = popSTACK(); var object fvd = popSTACK(); var object name = popSTACK(); if (!(simple_vector_p(fvd) && (Svector_length(fvd) == 4) @@ -3143,6 +3144,7 @@ TheFfunction(ffun)->ff_resulttype = TheSvector(fvd)->data[1]; TheFfunction(ffun)->ff_argtypes = TheSvector(fvd)->data[2]; TheFfunction(ffun)->ff_flags = TheSvector(fvd)->data[3]; + TheFfunction(ffun)->ff_properties = props; VALUES1(ffun); } @@ -4349,12 +4351,12 @@ VALUES1(STACK_0/*fvar*/); skipSTACK(4+1); } -/* (FFI::FOREIGN-LIBRARY-FUNCTION name library offset c-function-type) - returns a foreign function. */ -LISPFUNN(foreign_library_function,4) +/* (FFI::FOREIGN-LIBRARY-FUNCTION name library properties offset + c-function-type) returns a foreign function. */ +LISPFUNN(foreign_library_function,5) { - STACK_3 = coerce_ss(STACK_3); - STACK_2 = check_library(STACK_2); + STACK_4 = coerce_ss(STACK_4); + STACK_3 = check_library(STACK_3); if (!nullp(STACK_1)) STACK_1 = check_sint32(STACK_1); { var object fvd = STACK_0; @@ -4368,9 +4370,9 @@ fehler(error,GETTEXT("~S: illegal foreign function type ~S")); } } - pushSTACK(object_address(STACK_2,STACK_3,STACK_1)); + pushSTACK(object_address(STACK_3,STACK_4,STACK_1)); if (eq(nullobj,STACK_0)) { /* not found and ignored */ - skipSTACK(4+1); VALUES1(NIL); return; + skipSTACK(5+1); VALUES1(NIL); return; } var object ffun = allocate_ffunction(); var object fvd = STACK_(0+1); @@ -4379,9 +4381,10 @@ TheFfunction(ffun)->ff_resulttype = TheSvector(fvd)->data[1]; TheFfunction(ffun)->ff_argtypes = TheSvector(fvd)->data[2]; TheFfunction(ffun)->ff_flags = TheSvector(fvd)->data[3]; + TheFfunction(ffun)->ff_properties = STACK_(2+1); STACK_0 = ffun; /* save */ - push_foreign_object(ffun,STACK_(2+1)); - VALUES1(STACK_0/*ffun*/); skipSTACK(4+1); + push_foreign_object(ffun,STACK_(3+1)); + VALUES1(STACK_0/*ffun*/); skipSTACK(5+1); } #else /* not WIN32_NATIVE HAVE_DLOPEN */ Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.710 retrieving revision 1.711 diff -u -d -r1.710 -r1.711 --- lispbibl.d 21 Jun 2006 13:54:53 -0000 1.710 +++ lispbibl.d 4 Sep 2006 04:12:23 -0000 1.711 @@ -6141,6 +6141,7 @@ gcv_object_t ff_resulttype _attribute_aligned_object_; gcv_object_t ff_argtypes _attribute_aligned_object_; gcv_object_t ff_flags _attribute_aligned_object_; + gcv_object_t ff_properties _attribute_aligned_object_; } * Ffunction; #define ffunction_length ((sizeof(*(Ffunction)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t)) @@ -6641,21 +6642,24 @@ ? TheCclosure(obj)->clos_consts[1] \ : TheClosure(obj)->clos_name_or_class_version) typedef struct { - VRECORD_HEADER # self-pointer for GC, length in bits - # Here: Content of the Bitvector. - uintW ccv_spdepth_1; # maximal SP-depth, 1-part - uintW ccv_spdepth_jmpbufsize; # maximal SP-depth, jmpbufsize-part - uintW ccv_numreq; # number of required parameters - uintW ccv_numopt; # number of optional parameters - uintB ccv_flags; # Flags. Bit 0: &REST - parameter given? - # Bit 7: keyword-parameter given? - # Bit 6: &ALLOW-OTHER-KEYS-Flag - # Bit 4: generic function? - # Bit 3: generic function with call-inhibition? - uintB ccv_signature; # abbreviated argument type, for faster FUNCALL - # If keyword-parameters are given: - uintW ccv_numkey; # Number of keyword-parameters - uintW ccv_keyconsts; # Offset in FUNC of the keywords + VRECORD_HEADER /* self-pointer for GC, length in bits */ + /* Here: Content of the Bitvector. */ + uintW ccv_spdepth_1; /* maximal SP-depth, 1-part */ + uintW ccv_spdepth_jmpbufsize; /* maximal SP-depth, jmpbufsize-part */ + uintW ccv_numreq; /* number of required parameters */ + uintW ccv_numopt; /* number of optional parameters */ + uintB ccv_flags; /* Flags: Bit 0: &REST - parameter given? + Bit 1: full lambda list at the end of const vec + Bit 2: docstring at the end of const vec + Bit 3: generic function with call-inhibition? + Bit 4: generic function? + Bit 5: not used + Bit 6: &ALLOW-OTHER-KEYS-Flag + Bit 7: keyword-parameter given? */ + uintB ccv_signature; /* abbreviated argument type, for faster FUNCALL */ + /* If keyword-parameters are given: */ + uintW ccv_numkey; /* Number of keyword-parameters */ + uintW ccv_keyconsts; /* Offset in FUNC of the keywords */ } * Codevec; #define CCV_SPDEPTH_1 0 #define CCV_SPDEPTH_JMPBUFSIZE 2 @@ -6667,12 +6671,18 @@ #define CCV_KEYCONSTS 12 #define CCV_START_NONKEY 10 #define CCV_START_KEY 14 -# Compiled closures, where Bit 4 has been set in the flags of clos_codevec -# are generic functions. +/* Compiled closures, where Bit 4 has been set in the flags of clos_codevec + are generic functions. */ %% export_def(closure_flags(ptr)); %% export_def(closure_instancep(ptr)); %% export_def(Closure_instancep(obj)); +/* the position of the last const (or doc or lalist!) */ +#define Cclosure_last_const(obj) (Cclosure_length(obj) - 1 - \ + (sizeof(*(Cclosure)0) - offsetofa(srecord_,recdata))/sizeof(gcv_object_t)) +#define ccv_flags_lambda_list_p(ccv_flags) (((ccv_flags) & bit(1)) != 0) +#define ccv_flags_documentation_p(ccv_flags) (((ccv_flags) & bit(2)) != 0) + # A compiled LISP-function gets its arguments on the STACK # and returns its values in MULTIPLE_VALUE_SPACE. # It does not return a value as a C-function. Index: documentation.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/documentation.lisp,v retrieving revision 1.24 retrieving revision 1.25 diff -u -d -r1.24 -r1.25 --- documentation.lisp 17 Nov 2005 23:09:54 -0000 1.24 +++ documentation.lisp 4 Sep 2006 04:12:24 -0000 1.25 @@ -1,19 +1,19 @@ ;;;; Generic documentation -;;;; Sam Steingold 2002 - 2005 +;;;; Sam Steingold 2002 - 2006 ;;;; Bruno Haible 2004 (in-package "CLOS") (defun function-documentation (x) - (if (typep-class x <standard-generic-function>) - (std-gf-documentation x) - (or (and (eq (type-of x) 'FUNCTION) ; interpreted function? - (sys::%record-ref x 2)) - (let ((name (sys::function-name x))) - (and (sys::function-name-p name) - (fboundp name) (eq x (sys::unwrapped-fdefinition name)) - (getf (get (sys::get-funname-symbol name) 'sys::doc) - 'function)))))) + (cond ((typep-class x <standard-generic-function>) + (std-gf-documentation x)) + ((eq (type-of x) 'FUNCTION) ; interpreted function? + (sys::%record-ref x 2)) + #+FFI ((eq (type-of x) 'ffi::foreign-function) + (getf (sys::%record-ref x 5) :documentation)) + ((sys::subr-info x) ; built-in + (get :documentation (sys::function-name x))) + (t (sys::closure-documentation x)))) ;;; documentation (defgeneric documentation (x doc-type) @@ -24,25 +24,14 @@ (function-documentation x)) (:method ((x cons) (doc-type (eql 'function))) (setq x (check-function-name x 'documentation)) - (if (symbolp x) - (documentation x 'function) - (if (and (fboundp x) (typep-class (sys::unwrapped-fdefinition x) - <standard-generic-function>)) - (std-gf-documentation (sys::unwrapped-fdefinition x)) - (documentation (second x) 'function)))) + (and (fboundp x) (function-documentation (sys::unwrapped-fdefinition x)))) (:method ((x cons) (doc-type (eql 'compiler-macro))) (setq x (check-function-name x 'documentation)) (if (symbolp x) (documentation x 'compiler-macro) (documentation (second x) 'setf-compiler-macro))) (:method ((x symbol) (doc-type (eql 'function))) - (if (and (fboundp x) (typep-class (sys::unwrapped-fdefinition x) <standard-generic-function>)) - (std-gf-documentation (sys::unwrapped-fdefinition x)) - (or (and (fboundp x) - (let ((f (sys::unwrapped-fdefinition x))) - (and (eq (type-of f) 'FUNCTION) ; interpreted function? - (sys::%record-ref f 2)))) - (getf (get x 'sys::doc) doc-type)))) + (and (fboundp x) (function-documentation (sys::unwrapped-fdefinition x)))) (:method ((x symbol) (doc-type symbol)) ;; doc-type = `compiler-macro', `setf', `variable', `type', ;; `setf-compiler-macro' @@ -92,16 +81,15 @@ (slot-definition-documentation x))) (defun set-function-documentation (x new-value) - (if (typep-class x <standard-generic-function>) - (setf (std-gf-documentation x) new-value) - (let ((name (sys::function-name x))) - (when (eq (type-of x) 'FUNCTION) ; interpreted function? - (setf (sys::%record-ref x 2) new-value)) - (when (and (sys::function-name-p name) - (fboundp name) (eq x (sys::unwrapped-fdefinition name))) - (sys::%set-documentation (sys::get-funname-symbol name) - 'function new-value)) - new-value))) + (cond ((typep-class x <standard-generic-function>) + (setf (std-gf-documentation x) new-value)) + ((eq (type-of x) 'FUNCTION) ; interpreted function? + (setf (sys::%record-ref x 2) new-value)) + #+FFI ((eq (type-of x) 'ffi::foreign-function) + (setf (getf (sys::%record-ref x 5) :documentation) new-value)) + ((sys::subr-info x) ; built-in + (get :documentation (sys::function-name x))) + (t (sys::closure-set-documentation x new-value)))) (defgeneric (setf documentation) (new-value x doc-type) (:argument-precedence-order doc-type x new-value) @@ -111,28 +99,16 @@ (set-function-documentation x new-value)) (:method (new-value (x cons) (doc-type (eql 'function))) (setq x (check-function-name x '(setf documentation))) - (if (symbolp x) - (sys::%set-documentation x 'function new-value) - (if (and (fboundp x) (typep-class (sys::unwrapped-fdefinition x) - <standard-generic-function>)) - (setf (std-gf-documentation (sys::unwrapped-fdefinition x)) new-value) - (sys::%set-documentation (second x) 'setf new-value)))) + (and (fboundp x) + (set-function-documentation (sys::unwrapped-fdefinition x) new-value))) (:method (new-value (x cons) (doc-type (eql 'compiler-macro))) (setq x (check-function-name x '(setf documentation))) (if (symbolp x) (sys::%set-documentation x 'compiler-macro new-value) (sys::%set-documentation (second x) 'setf-compiler-macro new-value))) (:method (new-value (x symbol) (doc-type (eql 'function))) - (if (and (fboundp x) (typep-class (sys::unwrapped-fdefinition x) - <standard-generic-function>)) - (setf (std-gf-documentation (sys::unwrapped-fdefinition x)) new-value) - (progn - (when (fboundp x) - (let ((f (sys::unwrapped-fdefinition x))) - (when (eq (type-of f) 'FUNCTION) ; interpreted function? - (setf (sys::%record-ref f 2) new-value)))) - (sys::%set-documentation x 'function new-value) - new-value))) + (and (fboundp x) + (set-function-documentation (sys::unwrapped-fdefinition x) new-value))) (:method (new-value (x symbol) (doc-type symbol)) ;; doc-type = `compiler-macro', `setf', `variable', `type', ;; `setf-compiler-macro' Index: foreign1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/foreign1.lisp,v retrieving revision 1.99 retrieving revision 1.100 diff -u -d -r1.99 -r1.100 --- foreign1.lisp 14 Jun 2006 18:30:47 -0000 1.99 +++ foreign1.lisp 4 Sep 2006 04:12:24 -0000 1.100 @@ -1,6 +1,6 @@ ;;; Foreign function interface for CLISP ;;; Bruno Haible 19.2.1995 -;;; Sam Steingold 1998-2005 +;;; Sam Steingold 1998-2006 #+UNICODE (progn @@ -1026,7 +1026,8 @@ :built-in :library :documentation) whole-form)) (def (gensym "DEF-CALL-OUT-")) - (doc (assoc ':documentation alist)) + (properties (and (>= 1 (compiler::declared-optimize 'space)) + (assoc ':documentation alist))) (library (second (assoc :library alist))) (c-name (foreign-name name (assoc :name alist))) (built-in (second (assoc :built-in alist))) @@ -1036,8 +1037,8 @@ `(LET ((,def ,(if library `(FFI::FOREIGN-LIBRARY-FUNCTION ',c-name (FFI::FOREIGN-LIBRARY ,library) - NIL ,ctype) - `(LOOKUP-FOREIGN-FUNCTION ',c-name ,ctype)))) + ',properties NIL ,ctype) + `(LOOKUP-FOREIGN-FUNCTION ',c-name ,ctype ',properties)))) (EXT:COMPILER-LET ((,def ,ctype)) ,(unless library `(EVAL-WHEN (COMPILE) (NOTE-C-FUN ',c-name ,def ',built-in))) @@ -1045,7 +1046,6 @@ (COMPILER::C-DEFUN ',name (C-TYPE-TO-SIGNATURE ,ctype)))) (WHEN ,def ; found library function (SYSTEM::REMOVE-OLD-DEFINITIONS ',name) - ,@(when doc `((SETF (DOCUMENTATION ',name 'FUNCTION) ',(second doc)))) (SYSTEM::%PUTD ',name ,def)) ',name))) Index: compiler.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v retrieving revision 1.290 retrieving revision 1.291 diff -u -d -r1.290 -r1.291 --- compiler.lisp 18 Apr 2006 14:11:05 -0000 1.290 +++ compiler.lisp 4 Sep 2006 04:12:24 -0000 1.291 @@ -180,7 +180,7 @@ #| The compiler's target is the virtual machine described in <doc/impbyte.xml> -and <http://clisp.cons.org/impnotes.html#bytecode>. +and <http://clisp.cons.org/impnotes/bytecode.html>. 1. Pass of the Compiler: macro-expansion, @@ -203,8 +203,9 @@ further constants) |# -(defun make-closure (&key name codevec consts seclass) - (sys::%make-closure name (sys::make-code-vector codevec) consts seclass)) +(defun make-closure (&key name codevec consts seclass lambda-list documentation) + (sys::%make-closure name (sys::make-code-vector codevec) consts seclass + lambda-list documentation)) ;; The instruction list is in <doc/impbyte.xml>. @@ -1391,8 +1392,8 @@ ;; DEBUG >= 3 => ;; >= 2 => every function has an exit restart [not implemented yet] ;; >= 1 => -;; SPACE >= 3 => -;; >= 2 => +;; SPACE >= 3 => discard arglist +;; >= 2 => discard doc string ;; >= 1 => ;; SPEED >= 3 => ;; >= 2 => @@ -1418,7 +1419,7 @@ (defun parse-optimize-quality (spec) (macrolet ((broken (&rest args) `(progn - (funcall (if (boundp '*warning-count*) #'c-warn 'warn) ,@args) + (c-warn 'warn ,@args) (values)))) (let ((quality spec) (value 3)) (if (or (symbolp spec) @@ -1598,7 +1599,9 @@ (rest-flag nil) ; Flag, if &REST - Parameter is specified. (keyword-flag nil) ; Flag, if &KEY - Parameter is specified. (keywords nil) ; List of Keyword-Constants (in the right order) - allow-other-keys-flag ; &ALLOW-OTHER-KEYS-Flag + allow-other-keys-flag ; &ALLOW-OTHER-KEYS-Flag + lambda-list ; as passed to defun, discarded if SPACE >= 3 + documentation ; discarded if SPACE >= 2 Consts-Offset ; number of local constants so far (consts nil) ; List of other constants of this function ; this list is built up foremost in the second pass. @@ -3986,10 +3989,12 @@ (fnode-rest-flag *func*) (not (eql restvar 0)) (fnode-keyword-flag *func*) keyflag (fnode-keywords *func*) keyword + (fnode-lambda-list *func*) lalist (fnode-allow-other-keys-flag *func*) allow-other-keys) (when fenv-cons (setf (caar fenv-cons) *func*)) ; Fixup for c-LABELS - (multiple-value-bind (body-rest declarations) + (multiple-value-bind (body-rest declarations docstring) (parse-body (cdr lambdabody) t) + (setf (fnode-documentation *func*) docstring) (setq declarations (nreconc type-decls declarations)) (let ((oldstackz *stackz*) (*stackz* *stackz*) @@ -10567,11 +10572,24 @@ The function make-closure is required. |# +(defun non-user-symbol-p (sym) + (let ((package (symbol-package sym))) + (or (null package) (eq package #,(find-package "SYSTEM"))))) +(defun generatedp (fname lambda-list) + (or (null fname) ; no name + (keywordp fname) ; :lambda + (and (symbolp fname) (non-user-symbol-p fname)) ; gensym + (and (consp fname) (non-user-symbol-p (second fname))) ; (setf gensym) + (some #'(lambda (arg) (and (symbolp arg) (non-user-symbol-p arg))) + lambda-list))) ; gensyms in lambda-list ;; enters a byte-list as Code into fnode. -(defun create-fun-obj (fnode byte-list SPdepth) +(defun create-fun-obj (fnode byte-list SPdepth + &aux (fname (fnode-name fnode)) + (lambda-list (fnode-lambda-list fnode)) + (!generatedp (not (generatedp fname lambda-list)))) (setf (fnode-code fnode) (make-closure - :name (fnode-name fnode) + :name fname :codevec (macrolet ((as-word (anz) (if *big-endian* @@ -10620,7 +10638,15 @@ (if (fnode-gf-p fnode) (list (coerce l 'simple-vector)) l)) - :seclass (anode-seclass (fnode-code fnode)))) + :seclass (anode-seclass (fnode-code fnode)) + ;; no metadata for anonymous functions + ;; NB: :lambda-list 0 ==> :documentation 0 + :lambda-list (if (and !generatedp (>= 2 (declared-optimize 'space))) + lambda-list + 0) ; discard + :documentation (if (and !generatedp (>= 1 (declared-optimize 'space))) + (fnode-documentation fnode) + 0))) ; discard fnode) ;; Return the signature of the byte-compiled function object Index: init.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/init.lisp,v retrieving revision 1.252 retrieving revision 1.253 diff -u -d -r1.252 -r1.253 --- init.lisp 16 Jan 2006 16:29:49 -0000 1.252 +++ init.lisp 4 Sep 2006 04:12:24 -0000 1.253 @@ -1856,9 +1856,6 @@ (EVAL-WHEN ,(if preliminaryp '(LOAD EVAL) '(COMPILE LOAD EVAL)) (SYSTEM::REMOVE-OLD-DEFINITIONS ',name ,@(if preliminaryp '('T))) - ,@(if docstring - `((SYSTEM::%SET-DOCUMENTATION ',name 'FUNCTION ',docstring)) - '()) (SYSTEM::%PUTD ',name (SYSTEM::MAKE-MACRO ,(if preliminaryp `(SYSTEM::MAKE-PRELIMINARY ,expansion) @@ -1976,10 +1973,6 @@ `((COMPILER::EVAL-WHEN-COMPILE (COMPILER::C-DEFUN ',name (lambda-list-to-signature ',lambdalist))))) - ,@(if docstring - `((SYSTEM::%SET-DOCUMENTATION ,symbolform - 'FUNCTION ',docstring)) - '()) (SYSTEM::%PUTD ,symbolform ,(if preliminaryp `(SYSTEM::MAKE-PRELIMINARY (FUNCTION ,name (LAMBDA ,@lambdabody))) Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.333 retrieving revision 1.334 diff -u -d -r1.333 -r1.334 --- NEWS 4 Sep 2006 00:19:54 -0000 1.333 +++ NEWS 4 Sep 2006 04:12:24 -0000 1.334 @@ -1,3 +1,12 @@ +Important notes +--------------- + +* All .fas files generated by previous CLISP versions are invalid and + must be recompiled. This is because DOCUMENTATION and LAMBDA-LIST are + now kept with the closures. + Set CUSTOM:*LOAD-OBSOLETE-ACTION* to :COMPILE to automate this. + See <http://clisp.cons.org/impnotes.html#loadfile> for details. + User visible changes -------------------- @@ -13,6 +22,10 @@ * Function PCRE:PCRE-EXEC accepts :DFA and calls pcre_dfa_exec() when built against PCRE v6. See <http://clisp.cons.org/impnotes/pcre.html>. +* When the OPTIMIZE SPACE level is low enough, keep function + documentation and lambda list. + See <http://clisp.cons.org/impnotes/declarations.html#space-decl>. + * Bug fixes: + Make it possible to set *IMPNOTES-ROOT-DEFAULT* and *CLHS-ROOT-DEFAULT* to local paths, as opposed to URLs. [ 1494059 ] Index: spvw_debug.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_debug.d,v retrieving revision 1.71 retrieving revision 1.72 diff -u -d -r1.71 -r1.72 --- spvw_debug.d 23 Dec 2005 19:20:18 -0000 1.71 +++ spvw_debug.d 4 Sep 2006 04:12:23 -0000 1.72 @@ -453,5 +453,7 @@ FUN(object,Symbol,TheSymbol) FUN(object,Hashtable,TheHashtable) FUN(object,Dfloat,TheDfloat) +FUN(object,Cclosure,TheCclosure) +FUN(object,int,Cclosure_length) #undef FUN #endif Index: constobj.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constobj.d,v retrieving revision 1.179 retrieving revision 1.180 diff -u -d -r1.179 -r1.180 --- constobj.d 15 May 2006 14:37:26 -0000 1.179 +++ constobj.d 4 Sep 2006 04:12:24 -0000 1.180 @@ -1,7 +1,7 @@ /* * list of all objects known to the C-program ("program-constants") * Bruno Haible 1990-2005 - * Sam Steingold 1998-2005 + * Sam Steingold 1998-2006 * German comments translated into English: Stefan Kain 2002-02-20 The symbols are already treated specially in CONSTSYM. @@ -331,7 +331,7 @@ LISPOBJ(memory_image_host,"NIL") # the host on which this image was dumped /* The date of the last change of the bytecode interpreter or the arglist of any built-in function in FUNTAB */ - LISPOBJ(version,"(20050505)") + LISPOBJ(version,"(20060802)") #ifdef MACHINE_KNOWN LISPOBJ(machine_type_string,"NIL") LISPOBJ(machine_version_string,"NIL") Index: eval.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/eval.d,v retrieving revision 1.202 retrieving revision 1.203 diff -u -d -r1.202 -r1.203 --- eval.d 3 May 2006 17:29:43 -0000 1.202 +++ eval.d 4 Sep 2006 04:12:24 -0000 1.203 @@ -1496,21 +1496,13 @@ pushSTACK(Cdr(form)); /* list of the new decl-specs */ while (mconsp(STACK_0)) { var object declspec = Car(STACK_0); /* next decl-spec */ - { /* check for (COMPILE) */ - /* Test: (EQUAL d '(COMPILE)) = - (and (consp d) (eq (car d) 'COMPILE) (null (cdr d))) */ - if (consp(declspec) - && eq(Car(declspec),S(compile)) - && nullp(Cdr(declspec))) - compile_decl = true; - else if (consp(declspec) && eq(Car(declspec),S(optimize))) { - pushSTACK(Cdr(declspec)); funcall(S(note_optimize),1); - pushSTACK(value1); - declspec = allocate_cons(); - Car(declspec) = S(optimize); - Cdr(declspec) = popSTACK(); /* value1 */ - } - } + /* check for (COMPILE) + Test: (EQUAL d '(COMPILE)) = + (and (consp d) (eq (car d) 'COMPILE) (null (cdr d))) */ + if (consp(declspec) + && eq(Car(declspec),S(compile)) + && nullp(Cdr(declspec))) + compile_decl = true; { /* push this declaration onto STACK_(0+2) : */ pushSTACK(declspec); var object new_cons = allocate_cons(); ------------------------------ ------------------------------------------------------------------------- Using Tomcat but need to do more? Need to support web services, security? Get stuff done quickly with pre-integrated technology to make your job easier Download IBM WebSphere Application Server v.1.0.1 based on Apache Geronimo http://sel.as-us.falkag.net/sel?cmd=lnk&kid=120709&bid=263057&dat=121642 ------------------------------ _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest, Vol 5, Issue 2 *************************************** |