diff options
| author | LaMont Jones <lamont@debian.org> | 2003-05-07 08:36:40 -0600 |
|---|---|---|
| committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 |
| commit | e21d47d7813159bb71e0671df9b52ec0470c358d (patch) | |
| tree | 3c7770ea846123c291f599044e9f234ac17616bb | |
| parent | 8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (diff) | |
| parent | deda2c0fd8689349fea2a900199a76ff7ecb319e (diff) | |
| download | scm-debian/5d6-3.2.tar.gz scm-debian/5d6-3.2.zip | |
Import Debian changes 5d6-3.2debian/5d6-3.2
scm (5d6-3.2) unstable; urgency=low
* Fix hppa compile. Closes: #144062
scm (5d6-3.1) unstable; urgency=low
* NMU with patch from James Troup, to fix FTBFS on sparc. Closes: #191171
scm (5d6-3) unstable; urgency=low
* Add build depend on xlibs-dev (Closes: #148020)
scm (5d6-2) unstable; urgency=low
* Remove libregexx-dev from build-depends.
* Change build to use ./scmlit rather than scmlit (should fix some build
problems) (looks like alpha is mostly building)
* New release (Closes: #140175)
* Built with turtlegraphics last time (Closes: #58515)
scm (5d6-1) unstable; urgency=low
* New upstream.
* Add xlib and turtlegr to requested list of features. (closes
some bug)
* Make clean actually clean most everything up.
* Remove hacks renaming build to something else and just set build as a
.PHONY target in debian/rules.
* Add the turtlegr code.
scm (5d5-1) unstable; urgency=low
* New upstream
* Has fixes for 64 bit archs. May fix alpha compile problem. Does fix
(Closes: #140175)
* Take out -O2 arg.
scm (5d4-3) unstable; urgency=low
* Don't link with regexx, but just use libc6's regular expression
functions.
* Define (terms) to output /usr/share/common-licenses/GPL (Closes:
#119321)
scm (5d4-2) unstable; urgency=low
* Add texinfo to build depends (Closes: #107011)
scm (5d4-1) unstable; urgency=low
* New upstream release.
* Move install-info --remove to prerm.
scm (5d3-5) unstable; urgency=low
* Move scm info files to section "The Algorithmic Language Scheme" to
match up with guile.
scm (5d3-4) unstable; urgency=low
* Fix build depends (Closes: #76691)
scm (5d3-3) unstable; urgency=low
* Fix path in scm dhelp file.
scm (5d3-2) unstable; urgency=low
* Actually put the header files in the package. Oops.
scm (5d3-1) unstable; urgency=low
* New upstream. (Closes: #74761)
* Make (terms) use new license location.
* Make use libregexx rather than librx.
* Fix build depends for above.
* Using new regex lib seems to fix crash (Closes: #66787)
* Consider adding scm-dev package with headers, but instead just add the
headers to the scm package. (Closes: #70787)
* Add doc-base support.
| -rw-r--r-- | .gdbinit | 17 | ||||
| -rw-r--r-- | ANNOUNCE | 218 | ||||
| -rw-r--r-- | ChangeLog | 1690 | ||||
| -rw-r--r-- | Iedline.scm | 12 | ||||
| -rw-r--r-- | Init5d6.scm (renamed from Init5d2.scm) | 1037 | ||||
| -rw-r--r-- | Link.scm | 208 | ||||
| -rw-r--r-- | Macexp.scm | 586 | ||||
| -rw-r--r-- | Macro.scm | 449 | ||||
| -rw-r--r-- | Macroexpand.scm | 370 | ||||
| -rw-r--r-- | Makefile | 392 | ||||
| -rw-r--r-- | README | 384 | ||||
| -rw-r--r-- | Transcen.scm | 17 | ||||
| -rw-r--r-- | Xlibscm.info | 1113 | ||||
| -rw-r--r-- | Xlibscm.texi | 262 | ||||
| -rw-r--r-- | bench.scm | 34 | ||||
| -rw-r--r-- | bld.scm | 59 | ||||
| -rwxr-xr-x | build | 11 | ||||
| -rw-r--r-- | build.features | 123 | ||||
| -rw-r--r-- | build.scm | 303 | ||||
| -rwxr-xr-x | compile.scm | 112 | ||||
| -rw-r--r-- | continue.c | 14 | ||||
| -rw-r--r-- | continue.h | 20 | ||||
| -rw-r--r-- | crs.c | 48 | ||||
| -rw-r--r-- | debian/changelog | 113 | ||||
| -rw-r--r-- | debian/control | 5 | ||||
| -rw-r--r-- | debian/doc-base | 12 | ||||
| -rw-r--r-- | debian/postinst | 10 | ||||
| -rw-r--r-- | debian/postrm | 4 | ||||
| -rw-r--r-- | debian/prerm | 8 | ||||
| -rwxr-xr-x | debian/rules | 48 | ||||
| -rw-r--r-- | debug.c | 751 | ||||
| -rw-r--r-- | disarm.scm | 12 | ||||
| -rw-r--r-- | dynl.c | 25 | ||||
| -rw-r--r-- | edline.c | 16 | ||||
| -rw-r--r-- | eval.c | 2632 | ||||
| -rw-r--r-- | features.txi | 196 | ||||
| -rw-r--r-- | findexec.c | 125 | ||||
| -rw-r--r-- | gmalloc.c | 5 | ||||
| -rw-r--r-- | grtest.scm | 82 | ||||
| -rw-r--r-- | gsubr.c | 13 | ||||
| -rw-r--r-- | hobbit.info | 1952 | ||||
| -rw-r--r-- | hobbit.scm | 6981 | ||||
| -rw-r--r-- | hobbit.texi | 2273 | ||||
| -rwxr-xr-x | inc2scm | 20 | ||||
| -rw-r--r-- | ioext.c | 104 | ||||
| -rw-r--r-- | keysymdef.scm | 674 | ||||
| -rw-r--r-- | mkimpcat.scm | 164 | ||||
| -rw-r--r-- | patchlvl.h | 4 | ||||
| -rw-r--r-- | platform.txi | 43 | ||||
| -rw-r--r-- | posix.c | 53 | ||||
| -rw-r--r-- | r4rstest.scm | 99 | ||||
| -rw-r--r-- | ramap.c | 44 | ||||
| -rw-r--r-- | record.c | 68 | ||||
| -rw-r--r-- | repl.c | 647 | ||||
| -rw-r--r-- | requires.scm | 12 | ||||
| -rw-r--r-- | rgx.c | 22 | ||||
| -rw-r--r-- | rope.c | 44 | ||||
| -rw-r--r-- | sc2.c | 12 | ||||
| -rw-r--r-- | scl.c | 251 | ||||
| -rw-r--r-- | scm.1 | 66 | ||||
| -rw-r--r-- | scm.c | 284 | ||||
| -rw-r--r-- | scm.doc | 234 | ||||
| -rw-r--r-- | scm.h | 273 | ||||
| -rw-r--r-- | scm.info | 2938 | ||||
| -rw-r--r-- | scm.spec | 168 | ||||
| -rw-r--r-- | scm.texi | 1215 | ||||
| -rw-r--r-- | scm5d6.info | 8382 | ||||
| -rw-r--r-- | scmfig.h | 111 | ||||
| -rw-r--r-- | scmhob.h | 105 | ||||
| -rw-r--r-- | scmhob.scm | 51 | ||||
| -rw-r--r-- | scmmain.c | 45 | ||||
| -rw-r--r-- | script.c | 41 | ||||
| -rw-r--r-- | setjump.h | 22 | ||||
| -rw-r--r-- | socket.c | 36 | ||||
| -rw-r--r-- | subr.c | 271 | ||||
| -rw-r--r-- | syntest1.scm | 166 | ||||
| -rw-r--r-- | syntest2.scm | 186 | ||||
| -rw-r--r-- | sys.c | 664 | ||||
| -rw-r--r-- | time.c | 41 | ||||
| -rw-r--r-- | tmp3 | 2 | ||||
| -rw-r--r-- | turtle | 20 | ||||
| -rw-r--r-- | turtlegr.c | 1298 | ||||
| -rw-r--r-- | unexalpha.c | 36 | ||||
| -rw-r--r-- | unexelf.c | 2 | ||||
| -rw-r--r-- | unif.c | 115 | ||||
| -rw-r--r-- | unix.c | 52 | ||||
| -rw-r--r-- | version.txi | 4 | ||||
| -rw-r--r-- | x.c | 540 | ||||
| -rw-r--r-- | x.h | 19 | ||||
| -rw-r--r-- | x11.scm | 106 | ||||
| -rw-r--r-- | xatoms.scm | 80 | ||||
| -rw-r--r-- | xevent.h | 2 | ||||
| -rw-r--r-- | xevent.scm | 2 | ||||
| -rwxr-xr-x | xgen.scm | 176 |
94 files changed, 35667 insertions, 7089 deletions
@@ -15,26 +15,26 @@ # the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. # # As a special exception, the Free Software Foundation gives permission -# for additional uses of the text contained in its release of GUILE. +# for additional uses of the text contained in its release of SCM. # -# The exception is that, if you link the GUILE library with other files +# The exception is that, if you link the SCM library with other files # to produce an executable, this does not by itself cause the # resulting executable to be covered by the GNU General Public License. # Your use of that executable is in no way restricted on account of -# linking the GUILE library code into it. +# linking the SCM library code into it. # # This exception does not however invalidate any other reasons why # the executable file might be covered by the GNU General Public License. # # This exception applies only to the code released by the -# Free Software Foundation under the name GUILE. If you copy +# Free Software Foundation under the name SCM. If you copy # code from other Free Software Foundation releases into a copy of -# GUILE, as the General Public License permits, the exception does +# SCM, as the General Public License permits, the exception does # not apply to the code that you add in this way. To avoid misleading # anyone as to the status of such modified files, you must delete # this exception notice from them. # -# If you write modifications of your own for GUILE, it is your choice +# If you write modifications of your own for SCM, it is your choice # whether to permit this exception to apply to your modifications. # If you do not wish that, delete this exception notice. @@ -64,6 +64,11 @@ define scm call newline(sys_protects[2]),(void)0 end +define code + call scm_princode($arg0, scm_estk_ptr[2], sys_protects[2], 1),(void)0 + call newline(sys_protects[2]),(void)0 +end + define lload if (errjmp_bad) echo sorry, errjmp_bad\n @@ -1,137 +1,31 @@ -This message announces the availability of Scheme release scm5d2. - -New in scm5d2: - - * Makefile (install): Make sure $(libscmdir)require.scm exists. - (libscmdir): Use instead of IMPLPATH. - * repl.c (scm_top_level): Corrected error test on exit in case 0 - is not success. - (repl): Return MAKINUM(EXIT_SUCCESS) when exiting an interactive - session on EOF, this should not be an error. - * build.scm (define-compile-commands): Added. - (defcommand): Added. - (platform): formatted; simplified names. - * Makefile (features.txi): Added. - * scm.texi (Build Options): take feature documentation from - "features.txi". - * build (make-features-txi): Creates documentation of build - features from 'features table. - * build.scm (build:define-feature): Added. Feature definitions - moved to top level. - * Init5d1.scm (comment): Added. - (read:sharp): Added `#;' comment syntax, *feature* SHARP:SEMI. - * sys.c (scm_env_v2lst): Made tolerant to argc of zero, - since ecache_evalx may call it thus for DO loops binding - no values. - * eval.c (debug_env_save): Function for use in ENV_SAVE when the - CAREFUL_INTS paranoid debugging flag is #defined. - (ecache_eval_args): Now calls ecache_evalx(), which - evaluates a list of expressions and returns a list allocated on - the ecache in scm_env_tmp. - (m_do): (m_letrec1): (ceval_1): LET, LETREC, and DO now call - ecache_evalx instead of using inline loops, this seems to improve - speed by 5% - 10% for jacal and for simsynch simulation. C stack - usage will increase somewhat for large env frames. - (lookupcar): Added support for constant bindings, to be created by - LET, LETREC, LET*. - * scl.c (dbl_prec): Use dbl_mant_dig in preference of potentially - undefined DBL_MANT_DIG. - * gmalloc.c: include "getpagesize.h" conditionalized on __svr4__. - * build.scm (batch:chop-to-fit-system): Removed. Use new - batch:try-chopped-command instead. - (mysql): Added to features. - (build:build): Added comments describing stages and errors. - * Makefile: Added platform.txi dependency where dependent on - scm.texi. - * Makefile (scm.info require.scm): "cp -p" more portable than "cp -a"? - * sys.c (mode_bits): Fix for null output string case. - * unif.c (make_sh_array): Reduced consing by using scm_cvapply - instead of apply. - *sys.c (mode_bits): Now takes an optional buffer which, on exit, - will hold a mode string suitable to pass to fopen(), without any - SCM extension characters. - * r4rstest.scm (float-print-test): stop after first error. - * sys.c (try_open_file): Insure that only 'r', 'w', 'b', or '+' - may be included in mode strings passed to fopen. - * repl.c (scm_freshline): Added FRESHLINE. - * sys.c (init_storage): Make def_outp tracked, so freshline will - work with it. - * ramap.c (cind): Now takes C vector of indices, which may be - allocated on the C stack, rather than a uve. - (ramapc): (ramap): (ramap_cxr): (array_imap): (array_for_each): (rafe): - Use scm_cvapply instead of apply, allocate index and argument vectors - on the C stack for array ranks < 5. - * record.c (makrectyp): (recprin1): Use scm_cvapply instead of - apply. - (rec_prinset): Checks arity of argument procedure. - * sys.c (sfputc): (sfwrite): (sfgetc): Use scm_cvapply instead of - apply. - (mksfpt): Checks arities of soft port procedures when the port is made. - * eval.c (scm_cvapply): (scm_arity_check): Exported. - (makacro): (makmacro): (makmmacro): Call scm_cvapply rather than - consing up argument lists. Check arity of macro transformers - once, when syntax is defined. - * subr.c (make_vector): Fixed broken length argument test. - * sys.c (scm_env_v2lst): Now takes list tail in scm_env_tmp, so - tail can be allocated on ecache. - * repl.c (scm_top_level): Print out supplied program arguments for - failure exits to simplify debugging scripts. - * eval.c (varcheck): Fixed for RECKLESS case. - * eval.c (scm_arity_check): (macroexp1): Argument number checking - in macroexp1 abstracted as scm_arity_check, for use in map, - for-each ... - (scm_cvapply): Apply a function to a C vector of arguments, used by - map and for-each. - (scm_v2lst): Added for use in scm_cvapply. - (map): (for_each): Speed considerably improved: No longer allocate - Scheme vector temporaries for up to 5 list arguments. No longer - allocate unnecessary argument lists, allocate on ecache if - possible. - * repl.c (iprin1): Print out first elt of cclo environment -- - makes record procedures more identifiable. - * sys.c (scm_env_v2lst): Now takes last cdr of list as argument. - * sys.c (scm_port_entry): Make 16-bit safe. - * Tscript.scm: File added to implement transcript-on, - transcript-off without burdening normal i/o. - * Init5d1.scm (transcript-on): (transcript-off): Now autoloads - from SCM/Tscript.scm - (_TRACKED): Added. - * socket.c (l_socket): (l_connect): (l_listen): Modified to use - port table. - (l_shutdown): (l_getpeername): (l_getsockname): Test for OPFPORTP, not - just OPPORTP. - * posix.c (l_pipe): Modified to use port table. - (prinpipe): Removed. - * ioext.c (reopen_file): (l_dup): (l_dup2): Modified to use port - table. - * crs.c (prinwindow): Removed. - (mkwindow): Uses scm_port_entry. - * repl.c (iprin1): Uses "name" field for printing ports. - (input_waiting): (wait_for_input): - (trans_on): (trans_off): Removed in favor of soft-port implementation. - (lputc): (lgetc): (lputs): (lfwrite): (lungetc): Removed check for - transcript, added line and column number support. Unread char now - kept in port table rather than CAR. - (lreadpr): (line_num): Removed line counting for load port, now done - using general line and column counting. - (scm_port_line): (scm_port_column): (scm_port_filename): Added. - (err_head): Now prints out multiple filenames for nested loads. - Tries to recover from recursive errors if current-error-port is a - soft-port. - * unif.c (uve_read): Removed ungetc call, if there is an unread - character, just call lgetc repeatedly for the first elt. - * sys.c (must_malloc): (must_realloc): Now check whether the heap - is initialized or not, so may be called earlier. - (scm_init_gra): (scm_grow_gra): Use above feature. - (scm_port_entry): Added, allocates entry in a port table used to store - unread characters, file names, line & column numbers, &c. - (mark_port_table): (sweep_port_table): Gc support for port table. - ptobfuns now has a "name" element, used for printing. - (prinfport): (prinstpt): (prinsfpt): Removed. - - From David Yeh: - * scl.c (makdbl): Mods to compile using MSVC. - * scmfig.h: Don't #define SINGLES for MSC. +This message announces the availability of Scheme release scm5d6. + +New in scm5d6: + +From Aubrey Jaffer: + + + Tanel Tammet's Hobbit compiler is now integrated into the SCM + distribution. + + + hobbit.scm modified for (symbol) GC changes in SCM. Use of + scm_gc_protect() instead of lists of protected objects means code + produced by Hobbit is smaller and more readable. + + + Converted the hobbit documentation to texinfo format. + http://swissnet.ai.mit.edu/~jaffer/hobbit_toc.html + +From George Bronnikov: + + + Ported SCM to the PLAN9 operating-system. + +From Martin Lafaix + + + scm.c (l_raise, l_sleep): + + script.c (dld_find_executable): + + scmmain.c, scmfig.h: Ported to OS/2, IBM VisualAge C++ v3. + +Plus improvements and bug fixes too numerous to include here (see +scm/ChangeLog). -=-=- @@ -147,51 +41,66 @@ include SCM in other programs. Documentation is online at: http://swissnet.ai.mit.edu/~jaffer/SCM.html SCM source is available from: - http://swissnet.ai.mit.edu/ftpdir/scm/scm5d2.zip - ftp.gnu.org:pub/gnu/jacal/scm5d2.zip (FTP instructions follow) + http://swissnet.ai.mit.edu/ftpdir/scm/scm5d6.zip + swissnet.ai.mit.edu:/pub/scm/scm5d6.zip + http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d6-1.src.rpm + swissnet.ai.mit.edu:/pub/scm/scm-5d6-1.src.rpm +Also available as i386 binary RPM: + http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d6-1.i386.rpm + swissnet.ai.mit.edu:/pub/scm/scm-5d6-1.i386.rpm SLIB is a portable Scheme library which SCM uses: - http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip - ftp.gnu.org:pub/gnu/jacal/slib2c7.zip + http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip + swissnet.ai.mit.edu:/pub/scm/slib2d4.zip +Also available as RPM: + http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d4-1.noarch.rpm + swissnet.ai.mit.edu:/pub/scm/slib-2d4-1.noarch.rpm JACAL is a symbolic math system written in Scheme: - http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b0.zip - ftp.gnu.org:pub/gnu/jacal/jacal1b0.zip + http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b2.zip + swissnet.ai.mit.edu:/pub/scm/jacal1b2.zip HOBBIT is a compiler for SCM code: http://swissnet.ai.mit.edu/ftpdir/scm/hobbit5x.tar.gz - ftp.gnu.org:pub/gnu/jacal/hobbit5x.tar.gz + swissnet.ai.mit.edu:/pub/scm/hobbit5x.tar.gz SLIB-PSD is a portable debugger for Scheme (requires emacs editor): http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz - ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz + swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz SMG-SCM is an SMG interface package which works with SCM on VMS. http://swissnet.ai.mit.edu/ftpdir/scm/smg-scm2a1.zip - ftp.gnu.org:pub/gnu/jacal/smg-scm2a1.zip + swissnet.ai.mit.edu:/pub/scm/smg-scm2a1.zip A VMS version of Unzip is available by anonymous FTP from ftp.spc.edu:[ANONYMOUS.MACRO32]UNZIP.EXE. TURTLSCM is a turtle graphics package which works with SCM on MS-DOS or X11 machines: http://swissnet.ai.mit.edu/ftpdir/scm/turtlegr.tar.gz - ftp.gnu.org:pub/gnu/jacal/turtlegr.tar.gz + swissnet.ai.mit.edu:/pub/scm/turtlegr.tar.gz XSCM is a X windows interface package which works with SCM: http://swissnet.ai.mit.edu/ftpdir/scm/xscm-2.01.tar.gz - ftp.gnu.org:pub/gnu/jacal/xscm-2.01.tar.gz + swissnet.ai.mit.edu:/pub/scm/xscm-2.01.tar.gz MacSCM is a Macintosh applications building package which works with SCM (similar to XSCM). http://swissnet.ai.mit.edu/ftpdir/scm/macscm.tar.Z + swissnet.ai.mit.edu:/pub/scm/macscm.tar.Z WB is a disk based, sorted associative array (B-tree) library for SCM. Using WB, large databases can be created and managed from SCM. - http://swissnet.ai.mit.edu/ftpdir/scm/wb1a2.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/wb1a7.zip + swissnet.ai.mit.edu:/pub/scm/wb1a7.zip + http://swissnet.ai.mit.edu/ftpdir/scm/wb-1a7-1.src.rpm + swissnet.ai.mit.edu:/pub/scm/wb-1a7-1.src.rpm +Also available as i386 binary RPM: + http://swissnet.ai.mit.edu/ftpdir/scm/wb-1a7-1.i386.rpm + swissnet.ai.mit.edu:/pub/scm/wb-1a7-1.i386.rpm SIMSYNCH is a digital logic simulation system written in SCM. http://swissnet.ai.mit.edu/ftpdir/scm/synch1b0.zip - ftp.gnu.org:pub/gnu/jacal/synch1b0.zip + swissnet.ai.mit.edu:/pub/scm/synch1b0.zip DLD is a C library package allowing SCM to dynamically load object files on VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation @@ -199,22 +108,17 @@ files on VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation systems. ftp.gnu.org:pub/gnu/dld/dld-3.3.tar.gz -SCM.EXE (265k) is a SCM executable for DOS and MS-Windows. -Note: SCM.EXE still requires slib2c7 and scm5d2 above. +SCM.EXE (282k) is a SCM executable for DOS and MS-Windows. +Note: SCM.EXE still requires slib2d4 and scm5d6 above. http://swissnet.ai.mit.edu/ftpdir/scm/scm.exe + swissnet.ai.mit.edu:/pub/scm/scm.exe #! implements "#!" (POSIX) shell-scripts for MS-DOS batch files. http://swissnet.ai.mit.edu/ftpdir/scm/sharpbang.zip + swissnet.ai.mit.edu:/pub/scm/sharpbang.zip http://swissnet.ai.mit.edu/ftpdir/scm/#!.zip + swissnet.ai.mit.edu:/pub/scm/#!.zip Programs for printing and viewing TexInfo documentation (which SCM has) come with GNU Emacs or can be obtained via ftp from: ftp.gnu.org:pub/gnu/texinfo/texinfo-4.0.tar.gz - - -=-=- - - ftp ftp.gnu.org (anonymous) - bin - cd pub/gnu/jacal - get slib2c7.zip - get scm5d2.zip @@ -1,8 +1,1358 @@ -Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> +2002-04-14 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * patchlvl.h (SCMVERSION): Bumped from 5d5 to 5d6. + + * build.scm (platform->os): Added. + +2002-04-11 Aubrey Jaffer <agj@alum.mit.edu> + + * scm.texi (Invoking Build): Updated script examples. Changed vms + example to darwin. + + * Makefile (CITERS): Added hobbit.scm. + (CC): Commented out "CC = gcc". + +2002-04-11 Tanel Tammet <tammet@staff.ttu.ee> + + * hobbit.scm (verbose): compilation corrected. + (require): moved from top level to hobbit procedure. + (copy-tree, acons, system): compilation introduced. + +2002-04-08 Aubrey Jaffer <agj@alum.mit.edu> + + * compile.scm (compile->executable): Removed gratuitous "-cscm.c". + + * scm.c (SYSTNAME): __MACH__ was causing conflicting #define. + __MACH__ is "unix". + +2002-04-07 Aubrey Jaffer <agj@alum.mit.edu> + + * scl.c (subr1s, subr2s): Corrected conditioning for + scm_make_dfloat, scm_next_dfloat, and scm_dfloat_parts. + + * scm.c (LACK_RAISE): Cleaned up conditional tree for l_raise. + + * repl.c (kbhit): #define to 0 for PLAN9. + + * sys.c: PLAN9 needed fwrite() prototype. + (mark_finalizers): Was wrongly conditioned on !NO_SYM_GC. + + * mkimpcat.scm (build): Changed to load "build" (sans ".scm"). + + * hobbit.texi (Compiling And Linking): Added examples for + compile-file and compile->executable. + + * compile.scm (compile->executable): Replaces link-named-scm. + +2002-04-05 <aj@cypress.com> + + * scmfig.h (STDC_HEADERS): Corrected PLAN9 typo. + (sizet): Corrected for PLAN9. + +2002-04-03 Aubrey Jaffer <agj@alum.mit.edu> + + * sys.c, time.c, continue.h, findexec.c, repl.c, scmfig.h, scm.h: + Ported to PLAN9. + + * build.scm (plan9-8): Added port for Intel running PLAN9. + Comments desribe PLAN9 native C compiler `8c' options. + +2002-04-03 George Bronnikov <goga@rubinstein.mccme.ru> + + * scm.c (raise, system, isatty): Added for PLAN9 port. + +2002-03-30 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d5.scm (vicinity:suffix?, set-vicinities!): Added PLAN9. + Cleaned archaic conditional defines. + (set-vicinities!): Moved to just before load of require.scm. + + * requires.scm (PLAN9): Added support. + +2002-03-28 Aubrey Jaffer <agj@alum.mit.edu> + + * hobbit.texi: Changed most inline code snippets to @example. + +2002-03-28 Martin Lafaix <lafaix@online.fr> + + * scm.c (l_raise, l_sleep): + * script.c (dld_find_executable): + * scmmain.c, scmfig.h: Ported to OS/2, IBM VisualAge C++ v3. + +2002-03-22 <aj@cypress.com> + + * build.scm (C-libraries): Fixed dlll svr4-gcc-sun-ld. + +2002-03-21 Aubrey Jaffer <agj@alum.mit.edu> + + * hobbit.scm (every1): Renamed from EVERY. Hobbit self-compile + chokes on multi-arg EVERY, complaining of non-liftable lambdaterm. + +2002-03-19 Aubrey Jaffer <agj@alum.mit.edu> + + * build.scm (make-dll-archive gcc): Was mistakenly labeled sunos. + +2002-03-10 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (hobbit.texi): Moved from hobfiles to dfiles. + + * scm.spec (%files, %post): Added hobbit. + + * hobbit.texi: Reorganization to chapter/section structure. + (Benchmarks): Shuffled so source not broken over dvi and pdf page + boundaries. + + * Makefile (Xlibscm.pdf, hobbit.pdf): Targets added. + +2002-03-05 Aubrey Jaffer <agj@alum.mit.edu> + + * scl.c (istr2int, in2ex): Conditioned HP700 workaround on hpux. + + * r4rstest.scm (SECTION 6 5 9): Added 32-bit corner cases. + + * hobbit.texi (Compiling And Linking): Moved from "scm.texi". + +2002-03-04 Radey Shouman <shouman@ne.mediaone.net> + + * scl.c (ist2int): Fix integer overflow bug for fixnum-only case. + eg: (string->number "80000000" 16) ==> 0 + +2002-03-03 Aubrey Jaffer <agj@alum.mit.edu> + + * hobbit.texi: Converted to texinfo from plaintext hobbit.doc. + + * unif.c (bit_position): Renamed from position. + + * eval.c (scm_cp_list): Renamed from copy_list to avoid hobbit + conflict. + + * Link.scm (file->init_name): Added to map "-" ==> "_". + + * hobbit.scm (scm-gc-protect): Wraps replace protect-constant. + (*c-keywords*): Added names from "sc2.c". + + * Init5d5.scm (hobbit.tms): Removed dependence on missing file. + + * mkimpcat.scm: Reorganized more compactly. + (compile): Added feature. + + * build.scm (manifest): Added "compile.scm". + + * compile.scm (scm): For script to compile inexacts. + (hobbit, compile-file, link-named-scm): Extracted from Link.scm. + Require 'compile to use. + + * rope.c (scm_gc_protect): Always return argument. + + * xgen.scm (progname): Added so works when loaded (vs. script). + (xatoms): Read XcmsColorFormat value as two hex integers so SCMLIT + doesn't truncate 32-bit value. + + * xatoms.scm (X:RGB): Corrected (SCMLIT truncated 32-bit value). + (X:RGBi): Added. + + * Makefile (ifiles): Added "compile.scm". + (xevent.scm, xatoms.scm): Added aliases for xevent.h. + +2002-02-28 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d5.scm (*features*): Moved forward in file. + + * scm.c (scm_init_INITS): Added. + + * repl.c (scm_top_level): Added call to scm_init_INITS(). + + * build.scm (turtlegr, mysql): Changed to compiled-init. + + * Makefile (udscm5): Removed "-l debug". + (BUILD): Abstracted ./build -hsystem -p WHATEVER. + + * rope.c (scm_gc_protect): Don't bother protecting IMPs. + + * hobbit.scm (file-exists?): Removed. + comlist.scm functions moved to end; names corrected. + (*constant-list-var*): Removed; replaced with calls to + scm_gc_protect. + (*filter-inside-term-res*, filter-inside-term-aux!): Moved inside + filter-inside-term. + (nth-cdr, split): Unused; removed. + (first-n-reverse): Moved inside only use: make-tailrec-call. + (headerline, *h-port*): Moved inside display-header. + (build-wrapper-aux, build-wrapper): Moved inside build-wrappers. + (my-last-pair-aux): Moved inside my-last-pair. + + * Link.scm (link:link): Fixed prepending "./" for SUN-DL. + +2002-02-26 Radey Shouman <shouman@ne.mediaone.net> + + * eval.c (scm_cvapply): Removed PUSH_TRACE and POP_TRACE, which + were #ifdeffed out. Testing with a version that pushed temporary + values on the C stack showed little to gain. + +2002-02-25 Aubrey Jaffer <agj@alum.mit.edu> + + * hobbit.scm (neq?): Inlined; removed. + (make-list, some): Rename egregious conflicts with SLIB, comlist. + (butlast): Changed to 2 argument function. + + * Makefile (TAGFILES): build.scm was tagged twice. + + * Link.scm (compile-file): Fixed suffix substitution. + +2002-02-23 Aubrey Jaffer <agj@alum.mit.edu> + + * sys.c (sysintern): Use scm_gc_protect(). + + * scm.h (scm_uprotects): Added to sys_protects[]. + + * scm.c (init_scm): Added init_rope() call. + + * rope.c (scm_gc_protect, init_rope): Added. + +2002-02-17 Aubrey Jaffer <agj@alum.mit.edu> + + * sys.c (mark_subrs): Renamed from mark_subr_table. + (gra_report): Report both alloclen and len. + (init_types): scm.exe uses 397; always init malloc 420 subrs. + (scm_trim_gra): Added to downsize after init. + + * scm.h (subrs_gra): Renamed from subr_table_gra. + + * scm.c (scm_init_extensions): scm_trim_gra() ifndef HAVE_DYNL. + +2002-02-14 Aubrey Jaffer <agj@alum.mit.edu> + + * inc2scm, xgen.scm (go-script): Run even if not *script*. + + * Makefile (CPROTO): Moved to srcdir.mk. + (x.h): Only create with $(CPROTO) if $(CPROTO) exists. + (x11.scm, keysymdef.scm, xevent.h, x.h): Don't use #!. + +2002-02-13 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (PREVDOCS): Changed to prevdocs/ + +2002-02-11 Aubrey Jaffer <agj@alum.mit.edu> + + * patchlvl.h (SCMVERSION): Bumped from 5d4 to 5d5. + + * sys.c (init_types): Initial subr_table size depends on + SHORT_SIZET. + +2002-02-10 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (CITERS, TAGFILES): Abstracted functional file groups. + + * debug.c (stacktrace1): call to intprint() need long cast. + + * rope.c: No longer include "continue.h". + + * scmfig.h (PTR_GT, PTR_LE, PTR_GE): Put near PTR_LT. + + * sys.c (heap_report): Moved from "repl.c". + + * eval.c (scm_check_linum): Most calls to needed 0L. + + * repl.c (everr): Call to scm_check_linum needed 0L. + + * scm.texi (Allocating memory): must_realloc_cell, must_realloc + disallowed during init. + + * sys.c (gra_report): Added. + (scm_gc_protect): Removed. + (init_types): Initialize sys_protects to UNDEFINED. + (init_types): Increased initial *_gra limits to prevent realloc + during init. + (must_realloc_cell, must_realloc): ASSERT !errjmp_bad. + + * repl.c (lroom): Call gra_report(). + + * scm.h (flo0, NUM_PROTECTS): Don't #ifdef to save 4 bytes. + (f_apply_closure, eval_env, list_unspecified, f_evapply): In + sys_protects[]. + + * eval.c (init_eval): Removed calls to scm_gc_protect; put them in + sys_protects[]. + +2002-02-08 Aubrey Jaffer <agj@alum.mit.edu> + + * eval.c (init_eval): eval_env assignment uses sysintern for INTS + discipline. + + * sys.c (scm_estk_grow, scm_estk_shrink): +0L. + (mksafeport): Only called from init_storage(); don't DEFER_INTS. + (sysintern, scm_grow_gra): Only called while protected; don't + DEFER_INTS. + (scm_port_entry): Move malloc to init_storage(). + (init_storage): Inlined creation of null string and vector; fixed + INTS discipline. + + * scm.c (*scm-version*): Value changed to ssymbol for INTS + discipline. + +2002-02-06 Aubrey Jaffer <agj@alum.mit.edu> + + * sys.c (scm_open_ports, sysintern): Removed gratuitous casts. + + * scm.c (init_scm): Changed order of init_*s. + + * subr.c (mkbig): Removed gratuitous cast. + + * unif.c (resizuve): Removed gratuitous cast. + +2002-02-03 Aubrey Jaffer <agj@alum.mit.edu> + + * sys.c (scm_grow_gra): Don't DEFER_INTS; only called from inits. + (scm_estk_shrink): Cast sizet passed to make_stk_seg(). + + * eval.c: Cleanup; made __LINE__ numbers int. + + * scmmain.c (main): freeall is always 1. + + * scmfig.h (ints_infot): linum long->int. + + * scl.c (inex_divbigbig): Added default case. + + * scm.texi (Memory Management for Environments): Added indexes. + +2002-02-02 Aubrey Jaffer <agj@alum.mit.edu> + + * posix.c (l_pipe): DEFER_INTS was missing. + + * eval.c (init_eval): Cast argument to intern(). + + * repl.c (scm_top_level): Removed unreachable code. + + * sys.c (scm_estk_shrink): Removed unused SCM *v. + +2002-01-31 Aubrey Jaffer <agj@alum.mit.edu> + + * scm.texi (Uniform Array): Updated for SLIB changes. + + * unif.c (float_eq_double_P, i_short): Removed. + (scm_prot2type): Removed most legacy prototypes; much simpler! + + * Init5d4.scm (make-uniform-wrapper): Get rank correct. + (read:array): Use orthogonal prototypes for legacy syntax. + + * ramap.c (array-indexes): Change to use create-array. + + * Init5d4.scm (Ac64, Ac32, Ar64, Ar32, As64, As32, As16, As8, + Au64, Au32, Au16, Au8, At1): Added prototype makers. + +2002-01-29 Aubrey Jaffer <agj@alum.mit.edu> + + * debug.c (num_frames, estk_frame, cont_frame, stacktrace1): + Removed "static"; moved prototypes to scm.h. + +2002-01-28 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (macroexp1): Fix error handling for line-numbered objects + other than pairs. + + * repl.c (lread_rec): Add line numbers to vectors read using + READ-NUMBERED, to allow more specific unquoted vector warnings. + + * Init5d4.scm (read:sharp-char): Make #\C-M-a equivalent to #\M-C-a. + +2002-01-28 Aubrey Jaffer <agj@alum.mit.edu> + + * scm.texi (Uniform Array): Removed most uniform-vector functions. + + * Init5d4.scm: Removed uniform-vector functions. + + * unif.c (uve_len, uniform-vector-length): Removed. + (uniform-vector-set1!, uniform-vector-ref): Removed. + (scm_prot2type, array_prot): Converted to new prototypes. + + * unif.c (raprin1): Changed to new array syntax. + + * Init5d4.scm (read:sharp-char): Rearranged. + (read:array): Support new array syntax. + +2002-01-26 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d4.scm (call-with-open-ports): Accept arguments reversed. + (try-create-file): Accept symbol for modes argument. + (OPEN_READ, OPEN_WRITE, OPEN_BOTH): Changed to symbols. + (_IONBF, _TRACKED, _EXCLUSIVE): Work with strings OR symbols. + + * ioext.c (reopen_file, l_dup2, scm_try_create_file): + * sys.c (mksfpt, try_open_file): + * posix.c (open_pipe): Accept symbol for modes argument. + + * scm.texi (tc7_svect): Uniform short vector type. + +2002-01-24 Radey Shouman <shouman@ne.mediaone.net> + + * scm.c (l_sleep): Microsoft Sleep takes millisecond argument, + convert from seconds. + + * repl.c (scm_err_line): Added for standard printing of erring + file and line number. + (err_head): Use scm_err_line. + + * debug.c (princlosure, scm_scope_trace): Use scm_err_line. + + * findexec.c: Do nothing if __MINGW32__ is #defined, so scmlit can + be built with mingw using the makefile. + +2002-01-22 Radey Shouman <shouman@ne.mediaone.net> + + * eval.c: (scm_cvapply, apply): Save and restore scm_trace + expression for better backtraces. + (map, for_each): No longer need additional tracing. + + * debug.c: (stacktrace1): Use BOOL_F as default value of trace, to + avoid confusion with the UNDEFINED end-of-estk marker. + +2002-01-22 Aubrey Jaffer <agj@alum.mit.edu> + + * ioext.c, time.c, scm.c, findexec.c (__MACH__): Darwin port. + + * build.scm (Darwin): Added support for APPLE/MACH/PPC. + + * repl.c (swapcar): Added synchronization primitive. + + * scm.texi (Process Synchronization): Added make-exchanger. + + * Init5d4.scm (make-exchanger): Defined using swap-car!. + +2002-01-20 Aubrey Jaffer <agj@alum.mit.edu> + + * xgen.scm: QASE renamed from CASEV. + + * Init5d4.scm, scm.texi (qase): Renamed from casev. + Feature `database-utilities' renamed `databases'. + + * build.scm: Feature `database-utilities' renamed `databases'. + +2002-01-19 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (intro): Moved above srcdir.hk. Added "make scm". + +2002-01-18 Radey Shouman <Shouman@ne.mediaone.net> + + * ramap.c (racp): Fixed bug in array-copy! from a general array to + a bit-array or a char-array. + +2002-01-15 Aubrey Jaffer <agj@alum.mit.edu> + + * scmfig.h: Added MSVC pragmas. + + * unif.c (raprin1): Fixed #Aid array prefix. + (float_eq_double_P): Added workaround for MSVC. + +2002-01-13 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (scm): Added just-bignums-and-arrays target for JACAL. + + * Init5d4.scm (set-vicinities!): Load "requires.scm" if + "require.scm" absent. + + * scm.c (SYSTNAME): __MACH__ -> "mach". + + * scm.texi (Automatic C Preprocessor Definitions): Updated with + Apple Darwin flags. + +2002-01-03 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d4.scm (array=?): Added. + +2001-12-06 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (scm.info): Depends on rautil.txi. + +2001-12-01 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d4.scm (logical): Removed legacy definitions. + + * r4rstest.scm (4 2 2): Added test for LET bug. + +2001-11-15 Aubrey Jaffer <agj@alum.mit.edu> + + * build.scm (build): Updated for SLIB dbutil changes. + +2001-11-11 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d4.scm (bit-reverse integer->list list->integer + booleans->integer bitwise:laminate bitwise:delaminate): Added bit + order and lamination functions. + + (integer->gray-code gray-code->integer gray-code<? gray-code<=? + gray-code>? gray-code>=?): Added Gray code functions. + +2001-10-27 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c (gc_start, gc_end): Removed check for FPORTP(cur_errp), + no longer useful since we now write to sys_errp with no real + output until gc is over. + +2001-10-21 Aubrey Jaffer <agj@alum.mit.edu> + + * build (build-from-argv): Fail gracefully if params is #f. + +2001-09-27 Aubrey Jaffer <agj@alum.mit.edu> + + * ioext.c (file-exists?): Defined using ACCESS. + (scm_try_create_file): Conditional on O_EXCL being defined. + +2001-09-26 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d4.scm (_EXCLUSIVE): Added. + (try-create-file): Added; supports open for exclusive write. + (file-exists?): Conditionally defined. + + * ioext.c (scm_try_create_file): Moved from "unix.c". + +2001-09-24 Aubrey Jaffer <agj@alum.mit.edu> + + * scm.texi (SCM Session): boot-tail documented. + +2001-09-21 Aubrey Jaffer <agj@alum.mit.edu> + + * bench.scm (benchmark): Metric interchange units. + +2001-09-11 Aubrey Jaffer <agj@alum.mit.edu> + + * xgen.scm (schemeify-name): Converted to use StudlyCapsExpand. + + * Init5d4.scm (string-case): Added StudlyCapsExpand. + +2001-09-10 Radey Shouman <Shouman@ne.mediaone.net> + + * unix.c: (scm_try_create_file): Opens a file only if it does not + already exist. (Uses open() with the O_EXCL flag). + + * sys.c: (try_open_file): Calls back to try-create-file if an "x" + flag is specified. + + * Init5d4.scm: (try-create-file): autoloaded. + +2001-09-03 Igor Goldenberg <igold@mail.ru> + + * findexec.c, scmfig.h, scm.c, time.c (__amigaos__): replaces + obsolete __amigados__. + + * build.scm (amiga-gcc): "-O2" option removed (executable fails). + +2001-09-02 Aubrey Jaffer <agj@alum.mit.edu> + + * scm.texi (SCM Options): Added "-r*rs" options. + + * mkimpcat.scm (2rs, 3rs, 4rs, 5rs): Added aliases to make + "-r2rs".."-r5rs" command-line options work. + + * Init5d4.scm (*syntax-rules*): Renamed from *R4RS-MACROS*. + +2001-09-01 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d4.scm (boot-tail): Converted -r2, -r3, -r4, and -r5 + options to use r2rs, r3rs, r4rs, and r5rs features added to SLIB. + + * Makefile (scmlit): 'rm slibcat implcat' *after* compilation. + +2001-08-31 Aubrey Jaffer <agj@alum.mit.edu> + + * scm.c, scmfig.h, script.c, time.c: Changed unix flags to + HAVE_UNIX. + +2001-08-31 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (m_expand_body, macroexp1): Try harder to keep non-memoizing + macros unmemoized. + + * repl.c (scm_io_error): Now returns non-zero if EINTR seen. + (lfflush, lflush, lputc, lputs, lfwrite): No longer use + SYSCALL, but leave checking for EINTR to scm_io_error -- errno + need not be checked or set until an erring return value is seen. + (scm_warn): Now takes a scheme object to be printed as third argument. + +2001-08-30 Radey Shouman <Shouman@ne.mediaone.net> + + * sys.c (scm_port_entry): Now accepts a stream argument and + allocates the port cell. Puts a back pointer (not a gc protect) + into the port table, for introspection. + (open-ports): Returns a list of open ports. Should be useful for + fork, and maybe dump. + (port-type): Describes a port. + + * crs.c ioext.c posix.c scm.h socket.c Use new scm_port_entry call. + + * ioext.c (ldup): Better error reporting for invalid mode flags. + +2001-08-27 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (scm_arity_check): Always return false for negative argc. + (macroexp1): Better error message for malformed expressions. + +2001-08-26 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c (lungetc): Calls ungetc function if provided, this allows + string ports to work without using up port table entries. + + * sys.c (stclose): Allows gc of string. + (stungetc): ungetc for string ports. + +2001-08-24 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c: (scm_io_error): Added BROKEN-PIPE callback. + + * eval.c (m_case): Added callback to @case-aux to check for CASEs + that can be optimized to jump tables. + + * Init5d4.scm (@case-aux): Definition added. + +2001-08-23 Radey Shouman <Shouman@ne.mediaone.net> + + * scmfig.h eval.c record.c rgx.c sys.c unif.c + (SCM2PTR, PTR2SCM): Added test definition, so we can verify that + the code still works. Flushed out two actual bugs in eval.c. + +2001-08-16 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (m_case): CASE speed tweak. + (scm_case_selector): Added auxiliary function for CASE runtime. + + * sys.c (scm_gc_protect): Added to simplify eval.c. + +2001-08-15 Aubrey Jaffer <agj@alum.mit.edu> + + * Link.scm (link:link): Load main file last for sun-dl. + +2001-08-13 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (NO_ENV_CACHE): option bitrot fixed. + (scm_v2lst): Now takes third argument for compatibility with + scm_env_v2lst. + + * sys.c (scm_env_v2lst): Length argument now long instead of int + for compatibility with scm_v2lst. + +2001-08-11 Radey Shouman <Shouman@ne.mediaone.net> + + * dynl.c: DLOPEN_MODE now uses RTLD_GLOBAL iff it is #defined, + Linux (at least) requires it in order to stack compiled modules. + Also use RTLD_NOW, which allows reporting errors at load time, + rather than crashing the program when an undefined symbol is accessed. + +2001-08-09 Aubrey Jaffer <agj@alum.mit.edu> + + * mkimpcat.scm (add-link): Support symbols (features) in list. + (unix): Uses this feature. + + * Init5d4.scm (slib:load-compiled): Require any symbols in list. + + * Link.scm (link:link): Run 'init_<file>' only for first object + file. + +2001-07-30 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c: (err_head): Make sure cur_outp is open before fflushing it. + * sys.c: (clptob): Make flushing a closed port raise an error. + +2001-07-27 Radey Shouman <Shouman@ne.mediaone.net> + + * sys.c: (mode_bits, try_open_file, mksfpt): + * ioext.c: (reopen_file, l_dup): + Improved error checking for mode strings. + +2001-07-24 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c (scm_io_error, lflush, lwrite, display, newline, + write_char, scm_freshline): Common code checking for EPIPE after + file errors, now prints warning before closing port. + + * ioext.c (read_line, read_line1): Remove check that current + input port is open, errors caught by dispatching on closed port. + + * sys.c (init_types): Add a closed port type, so we can avoid I/O + to closed FILEs even if we don't explicitly check for a closed SCM + port before each operation. + +2001-07-21 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c: (char_readyp, lflush, lwrite, display, newline): + (write_char, read_char, peek_char, scm_freshline): + Don't assume currrent input or output ports are open. + Remove checks for EPIPE. + + (lfputc, lfputs, lfwrite): Checks for EPIPE moved here. Now + check errno only if an erring return value is seen. Signals error + for non-EPIPE errors. + + (def_err_response): Exit quietly (without core dump) if default + error port has been closed. + + * ioext.c (read_line, read_line1): + No longer assume current input port is open. + + * unif.c: (uve_write): Use lfwrite instead of fwrite, + (checks for EPIPE). + + * sys.c (safewrite): Fix return value. + +2001-07-19 Aubrey Jaffer <agj@alum.mit.edu> + + * sys.c (port_closedp): Added. + +2001-07-13 Aubrey Jaffer <agj@alum.mit.edu> + + * Link.scm (link:link): Runs 'init_<file>' for all linked + object-files with inits. + +2001-07-13 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c (def_err_response): Deal with closed error-port. + +2001-07-12 Steve VanDevender <stevev@hexadecimal.uoregon.edu> + + * unexalpha.c (TEXT_START): Fixed for Digital UNIX 4.0d and 4.0g. + +2001-07-12 Radey Shouman <Shouman@ne.mediaone.net> + + * (scm_port_entry): Fixed for 64-bit machines. + (SCM_PORTNUM_MAX): Replaces PORT_TABLE_MAXLEN, fixed for 64-bit + machines. Thanks for bug report from Steve VanDevender + <stevev@hexadecimal.uoregon.edu> + + (sysintern): Make sure we have a non-garbage-collectable symbol + whether it existed previously interned or not. This can be an + issue with dynamically loaded code, since sysintern can be called + at any time. + +2001-07-02 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (force): Now works for zero or multiple values. + +2001-06-27 Steve VanDevender <stevev@hexadecimal.uoregon.edu> + + * gmalloc.c (check_block, check_frag_blocks): Conditioned on + #ifdef DEBUG_GMALLOC. + +2001-06-27 Radey Shouman <Shouman@ne.mediaone.net> + + * sys.c (prinport): Print filename or pipe command, if available. + +2001-06-23 Radey Shouman <Shouman@ne.mediaone.net> + + * r4rstest.scm (test-numeric-predicates): Added tests for bignum + to flonum comparisons. + + * scl.c (lessp, eqp, lmin, lmax): Make bignum to float + comparisons transitive as required by R5RS. + (scm_twos_power, scm_bigdblcomp): Support functions added. + + * eval.c (m_letstar1): Introduced to allow more sensible error + messages for LET, LETREC. + +2001-06-17 Aubrey Jaffer <agj@alum.mit.edu> + + * posix.c (scm_getlogin): Added -- doesn't work on RH6.2. + + * Init5d4.scm (getlogin, login->home-directory): Added. + (home-vicinity): Defined in terms of getlogin, etc. + +2001-06-14 Radey Shouman <Shouman@ne.mediaone.net> + + * subr.c (scm_bitfield): Made more efficient. + +2001-06-10 Radey Shouman <Shouman@ne.mediaone.net> + + * scl.c (integer-expt): For negative exponents, raise to a + positive power first, then reciprocate. This should almost always + reduce roundoff error.. For INUMs, convert to floats before + raising to the positive power, to avoid allocating bignums. + + (next-double-float): Takes two flonums, returns the next flonum + from the first in the direction of the second. Not sure whether + this should stay. + +2001-05-28 Aubrey Jaffer <agj@alum.mit.edu> + + * r4rstest.scm (test-inexact): Added (test (atan 1) atan 1 1). + +2001-05-23 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (ceval_1, ceval_1): Optimize LAMBDA expressions without + rest arguments in function call position to LETs. Introduce + IM_FUNCALL spcsym for other non-variable reference expressions in + function call position so they are not repeatedly expanded. + +2001-05-16 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (pdf): Added targets. + +2001-05-15 Radey Shouman <Shouman@ne.mediaone.net> + + * Macro.scm: (macro:compile-syntax-rules): Generalized ellipsis + quote from (... ...) to (... <pattern-or-template>). + + * sys.c: (free_storage): Zero loc_gc_hook since it will be freed, + otherwise restart may fail. + +2001-05-14 Steve VanDevender <stevev@hexadecimal.uoregon.edu> + + * eval.c (scm_arity_check): Lacked explicit return value in the + tcs_closures case. + +2001-05-05 Aubrey Jaffer <agj@alum.mit.edu> + + * Macro.scm (@pprint): Added. + +2001-04-17 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (scm_eval_values): Now applies eval, so that + values-context errors are caught for expressions entered in the + repl. Example bug: > (cons (values) '()) => (#<undefined>) + + (ceval_1): Primitive @EVAL does not copytree its argument. + + * Init5d4.scm (eval): Now defined in terms of @eval. + +2001-04-16 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (all): make x.so after other components. + (myscm): Removed target; use 'make all' instead. + +2001-04-16 Radey Shouman <Shouman@ne.mediaone.net> + + * scl.c (previous_dfloat, next_dfloat, dfloat_parts): Fixed + for gradual underflow, as long as DBL_MIN_EXP is #defined. + + * repl.c scm.h Init5d4.scm + * eval.c (ceval_1, apply, cvapply): Moved most of the work of + applying a closure into ceval_1, by providing a syntax token + IM_EVAL_FOR_APPLY. CALL-WITH-VALUES is now a specfun, no special + form or closure needed. + +2001-04-13 Radey Shouman <Shouman@ne.mediaone.net> + + * scl.c (dfloat_parts, make_dfloat, next_dfloat): + (previous_dfloat): Implement DOUBLE-FLOAT-PARTS, + MAKE-DOUBLE-FLOAT, NEXT-DOUBLE-FLOAT, PREVIOUS-DOUBLE-FLOAT. Low + level floating point functions. + +2001-04-10 Radey Shouman <Shouman@ne.mediaone.net> + + * subr.c (scm_copybit): No longer makes so many bignums. + (scm_2scomp1): Static auxiliary function. + (scm_big_ash): Uses scm_2scomp1. + +2001-04-09 Radey Shouman <Shouman@ne.mediaone.net> + + * subr.c (scm_big_ash, scm_ash): Faster bignum ash, + allocates only one bignum per call. + (scm_copy_big_2scomp): Static support routine. + +2001-04-07 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c (scm_stack_trace): Reworked with general stack-inspection + function estk_frame. + (def_err_response): Use null s_subr argument to indicate that an + entire expression is being printed. + + * eval.c (macroexp1): Check early for unbound variable references + in a form, so nicer error messages can be produced. + +2001-04-06 Radey Shouman <Shouman@ne.mediaone.net> + + * subr.c (scm_big_and): Fixed bug in LOGAND for one negative and + one positive argument. + Bug example: (logand #x-10000 #x3ffffffff) => #x3ffffffff + +2001-04-04 Radey Shouman <Shouman@ne.mediaone.net> + + * Macro.scm (macro:compile-syntax-rules): Better error messages, + renamed some internal functions for clarity. Fix checking of + pattern variable rank in templates. Some legal syntax-rules + templates were being rejected, eg + (syntax-rules () ((_ (?x ...) (?y ...)) + (let ((?x (list ?y ...)) ...) + (list ?x ...))))) + +2001-03-30 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (scm_values): Exported, since it can reasonably be called + from subrs. + + * record.c (recprin1): Call default printer if the custom printer + returns #F. Print object-hash value of the rtd after type name, + so all distinct record types can be distinguished by eye. + + (rec_rtdprin1): Custom printer for record type descriptors, + includes rtd object-hash value. + +2001-03-29 Radey Shouman <Shouman@ne.mediaone.net> + + * repl.c (everr): Pass a `writing' value of 2, rather than + 1, during printing of error messages, so writing procedures + may take special action. + + * record.c (recprin1, rec_prinset): record-printer now takes + three arguments instead of two, the third being a boolean + WRITING?. + Supress calling the record-printer during error reports, + avoiding the possibility of a recursive error. + + * eval.c (m_letrec1): Fix error report in case macro keyword + is a synthetic identifier. + (m_letstar): Preserve distinction between LET* and LET in the + printed representation of evaluated code, for easier debugging of + backtraces. + +2001-03-24 Dai Inukai <GAF05426@nifty.ne.jp> + + * scmmain.c (main): Since release 2.0.5, FreeBSD's double + precision arithmetic defaults to 53 bits instead of 64 bits. Set + precision to 64 bits for all arithmetics and run the risk of + overflow, though I have not seen any in 6 months of use. + +2001-03-27 Radey Shouman <Shouman@ne.mediaone.net> + + * Macexp.scm (macro:expand): + * eval.c (scm_macroexpand1): Now expand identifier macros. + +2001-03-26 Radey Shouman <Shouman@ne.mediaone.net> + + * Macro.scm (syntax-rules): Only use procedure->identifier-macro + if needed, so macros print something without an error message. + + * eval.c (scm_macroexpand1): Expand forms with identifier macros + in keyword position (needed for macro:expand). Should also expand + single identifiers ... + +2001-03-23 Radey Shouman <Shouman@ne.mediaone.net> + + *sys.c (scm_gc_hook, scm_run_finalizers, mark_finalizers): + Added hook to be run like an interrupt shortly after gc. Added + finalizer facility to gc. + (scm_add_finalizer): Implements Scheme-level interface to + finalizer facility, ADD-FINALIZER. + + *scm.c (process_signals): run scm_gc_hook. + (setitimer): beautified somewhat. + + *repl.c (scm_top_level): Modified for gc hook. + +2001-03-20 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (ceval_1): modified + (values, m_call_wv, scm_eval_values): Added. + Implement CALL-WITH-VALUES and VALUES by returning extra values in + scm_env_tmp. + (scm_arity_check): Raise an error for unknown tc7_specfuns. + + * repl.c (repl): Expects and prints multiple values. + + * Init5d4.scm (call-with-values): Implemented by wrapping + undocumented special form @CALL-WITH-VALUES. CALL-WITH-VALUES + is hard to implement using the C level apply function, because + that function is not tail-recursive. + +2001-03-18 Aubrey Jaffer <agj@alum.mit.edu> + + * build.scm (build): Removed unused parameter scm-srcdir. + + * scm.spec (%post): 'ln -s %{prefix}/lib/scm /usr/local/lib/scm' + fixes vicinity problem caused by linking /usr/local/bin/scm. + +Thu Mar 15 21:33:30 EST 2001 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * patchlvl.h (SCMVERSION): Bumped from 5d3 to 5d4. + +2001-03-15 Aubrey Jaffer <agj@alum.mit.edu> + + * x.c (init_x): Don't scm_ldprog("xatoms.scm") because it + redefines STRING. + +2001-03-15 Radey Shouman <Shouman@ne.mediaone.net> + + * scm.spec: Added spec file to generate a .rpm file. + +2001-03-13 Radey Shouman <Shouman@ne.mediaone.net> + + * Macro.scm (macro:compile-syntax-rules): Support for identifier + macros. + + * repl.c (iprin1): Print inlined procedure calls without infinite + recursion. + + * scm.h: subtypes of tcs_cons_imcar are broken out for use in repl.c. + + * eval.c (makidmacro): Implement PROCEDURE->IDENTIFIER-MACRO. + (macroexp1, lookupcar, prinmacro): Clean up macro type codes, + support identifier macros. + + (m_inline_lambda, env_depth, env_tail, ceval_1): Support inline + procedures. Commented out for now, since the macro expander is not + yet smart enough to figure out which lambda expressions can be + inlined. + +2001-03-04 Aubrey Jaffer <agj@alum.mit.edu> + + * unif.c (init_unif): Removed scm_ldstr() call -- was failing to + define string-case functions when compiled on files.posmikk. + + * Init5d3.scm (string-case): provided if string-upcase! defined. + (display-file): Take optional port argument. + +2001-02-25 Aubrey Jaffer <agj@alum.mit.edu> + + * build.scm (build:serve): Improved error reporting. + +2001-02-22 Radey Shouman <Shouman@ne.mediaone.net> + + * record.c (rec_constr): Fixed error checking of fields argument. + +2001-02-12 Aubrey Jaffer <agj@alum.mit.edu> + + * Init5d3.scm (pprint): Added (returns last argument). + +2001-02-07 Aubrey Jaffer <agj@alum.mit.edu> + + * unif.c (init_unif): Moved string-*case definitions from + Init5d3.scm. Added string-append. + +2001-01-30 Marc Espie <espie@lusheeta.liafa.jussieu.fr> + + * build.scm, *.c: Ported to OpenBSD. + +2001-01-21 Aubrey Jaffer <agj@alum.mit.edu> + + * x.c (x_event_keysym): Added. Translates XKeyEvent to KeySym. + (x_window_geometry_set): Added interface to XConfigureWindow. + + * Makefile (keysymdef.scm): Added target. + + * inc2scm (scm<-includes): #ifdef each prospective #define. + +2001-01-18 Radey Shouman <Shouman@ne.mediaone.net> + + * ramap.c (ramap_cxr): Fix bug in dynamic allocation of + workspace for large number of arguments (>= 5 in argument list). + +2001-12-18 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (xafiles): Generated xlib-scheme files weren't being + installed. + +2001-01-18 Aubrey Jaffer <agj@alum.mit.edu> + + * x.c (scm2display_screen): Fixed off-by-one problem. + +2000-12-06 Aubrey Jaffer <agj@alum.mit.edu> + + * r4rstest.scm (Section 5 2 1): added (begin)s. + +2000-12-04 Radey Shouman <Shouman@ne.mediaone.net> + + * eval.c (m_begin): now accepts (BEGIN) which evaluates to + #<unspecified>. + (m_expand_body): checks for memoized (BEGIN) so that empty BEGINs + do not interrupt a sequence of internal definitions. Properly + rewrites internal definitions in several BEGINs as one LETREC, + rather than several. + +2000-11-13 Aubrey Jaffer <jaffer@ai.mit.edu> + + * x.c (x_default_ccc, x:default-ccc): Added. + (x_list_properties, x:list-properties): Added. + (x_window_ref, x:window-ref): Added. + (tc16_xccc): Added. + (CCC2SCM_P, CCC2SCM, xtc_ccc): Added backlinks from CCCs. + (print_xccc): Print out device-dependent ColorSpace names. + +2000-11-07 Aubrey Jaffer <jaffer@ai.mit.edu> + + * x.c (x_list_properties): Added. + (x_propdata2scm): Fixed. + +2000-11-06 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * xatoms.scm (X:CIEXYZ): Added Xcms formats from Xcms.h. + + * xgen.scm (xatoms): Also grab Xcms formats from Xcms.h. + + * x.c (x_visual_class, x_visual_geometry): Added. + (free_visual): Fixed vinfo_mask argument to XGetVisualInfo. + +2000-10-30 Aubrey Jaffer <jaffer@ai.mit.edu> + + * x.c (tc16_xvisual): Now holds XVisualInfo. + (x:default-visual): Removed. + + * xtest.scm: Removed use of x:default-visual. + + * xgen.scm (xatoms): Added. + + * xatoms.scm: Translation of Xatom.h added. + +2000-10-14 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Init5d3.scm (call-with-open-ports): Added. + (call-with-input-file): + (call-with-output-file): Use call-with-open-ports. + +2000-10-07 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Init5d3.scm (call-with-outputs): Added. + +2000-09-24 Jacob Strauss <jastr@mit.edu> + + * scm.texi (waitpid): Fixed return value paragraph. + +2000-09-23 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * build.scm (build:serve): Added. + +2000-09-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * r4rstest.scm (display): Test only on chars and strings. + +2000-08-05 Aubrey Jaffer <jaffer@ai.mit.edu> + + * rautil.scm (subarray): Added. + +2000-06-11 Ben Goetter <goetter@mazama.net> + + * build.scm (Microsoft-C-nt): Set options correctly for + feature 'stack-limit. + + * scmfig.h (MSDOS): NT lacks sbrk(). + +Sat Jun 3 22:12:39 EDT 2000 Aubrey Jaffer <jaffer@ai.mit.edu> + + * patchlvl.h (SCMVERSION): Bumped from 5d2 to 5d3. + +2000-06-01 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.texi (Making SCM): Updated. + +2000-05-02 C Nick Beaudrot <cbeaudro@cs.brown.edu> + + * scmfig.h: __SVR4 is the official Sun flag. + +2000-04-18 Aubrey Jaffer <jaffer@ai.mit.edu> + + * r4rstest.scm (modulo): Added test cases. + +2000-04-18 Radey Shouman <Radey_Shouman@splashtech.com> + + * subr.c (modulo): Fixed sign handling bug for INUM0, following + Dirk Herrmann's <D.Herrmann@tu-bs.de> fix for Guile. + +2000-03-31 Radey Shouman <Radey_Shouman@splashtech.com> + + * ioext.c (file_set_position): Do not disable port tracking for + zero pos. + +2000-03-30 Radey Shouman <Radey_Shouman@splashtech.com> + + * ioext.c (file_set_position): For tracked ports (line & column + number), issue warning and turn off tracking. + + * repl.c (scm_port_col): column numbers made consistently 1-based. + Fixed handling of ungetted chars. + +2000-03-28 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Makefile (Xlibscm_toc.html): fixed. + + * Transcen.scm (pi, pi*, pi/): Added. + +2000-02-24 Radey Shouman <Radey_Shouman@splashtech.com> + + * Init5d2.scm (warn, error): Don't use PROVIDED?, it can cause + error loops. + (library-vicinity): Give a meaningful error message if we can't load + require.scm. + +2000-02-16 Radey Shouman <Radey_Shouman@splashtech.com> + + * Macexp.scm (macro:expand): Fixed for keywords that would be + lexically shadowed except for hygiene. + +2000-02-15 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (ceval_1): Check for immediate procedure argument to + APPLY. + +2000-02-14 Radey Shouman <Radey_Shouman@splashtech.com> + + * Init5d2.scm (read:sharp): Accept #! syntax without checking + line-number, so source files may be READ. Made more robust. + + * Macexp.scm (macro:expand-syntax): Fixed handling of BEGIN with + only one subform. + +2000-02-11 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (env2tree): Rewritten to make it easier to change + behavior based on bound values. + +2000-02-07 Radey Shouman <Radey_Shouman@splashtech.com> + + * Macro.scm (define-syntax, let-syntax, letrec-syntax): Made + Primitive syntax. + + * eval.c (makro): Abstracts process of making syntax. + (makacro, makmacro, makmmacro): Now call makro. + (makpmacro, @procedure->primitive-syntax): Scheme level way of + defining primitive syntax, meaning syntax that @macroexpand and + hence macro:expand will not expand. + + * scm.h (IM_DEFINE): now an ISYM but not SPCSYM, since IM_DEFINE + no longer occurs in executable Scheme code there is no reason + dispatching on it need be fast. There is now one spare SPCSYM. + +2000-02-06 Radey Shouman <Radey_Shouman@splashtech.com> + + * Macexp.scm (macro:expand): Fixed handling of CASE. + + * eval.c (m_letstar): Transforms (LET* () ...) into either a + BEGIN, a single body form, or, if at top level, a LAMBDA + expression. Wrapping macro arguments in (LET () ... ) to allow + internal DEFINE becomes free. + + (ceval_1): Code to deal with zero binding LET* commented out. + + (nullenv_p): Added, since we test for null environments in both + m_define and m_letstar. + + (scm_extended_env, env2tree): #define constant + ENV_TREED for the car bit that identifies environments that have + been migrated out of ecache. + + (wrapenv): Return '() if at top level, instead of + allocating a cell for an environment object. + + (topdenote_eq): Added to reduce code size. + + (m_begin): if only one form, just returns it. + (scm_macroexpand1): Fixed to work with macro:expand. + +2000-02-06 Radey Shouman <Radey_Shouman@splashtech.com> + + * Macexp.scm: Added, rewritten replacement for Macroexpand.scm. + Implements MACRO:EXPAND including LET-SYNTAX and LETREC-SYNTAX. + Rewrites synthetic identifiers to symbols for pretty display. + +2000-02-04 Aubrey Jaffer <jaffer@ai.mit.edu> + + * build.scm (C-libraries): __FreeBSD__ uses libncurses. + + * crs.c: __FreeBSD__ includes ncurses.h + +2000-02-02 Radey Shouman <Radey_Shouman@splashtech.com> + + * scm.texi: Updated documentation for DEFMACRO and SYNTAX-RULES. + + * ramap.c (array_map, array_for_each, array_imap): No longer + need to call procedurep, scm_arity_check is sufficient. + + * eval.c (scm_arity_check): Was not doing the right thing if + passed an immediate as a procedure. + + (ceval_1): Added ALLOW_INTS_EGC to ensure that a tight + loop applying a closure of >3 arguments will handle signals. Bug + report thanks to Tomas Lozano-Perez <tlp@mit.edu>. + +2000-02-01 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Xlibscm.texi: TeX doesn't like @itemx in @tables. + +2000-02-01 Radey Shouman <Radey_Shouman@splashtech.com> + + * Macro.scm (compile-pattern): Allow (... ...) escapes to be + matched in patterns as a literal ... ellipsis, allowing use of + ellipses as syntax in user macros. + + * sys.c (scm_env_cons3): Added. + * eval.c (scm_env_cons_tmp): Removed, replaced in one remaining + use by scm_env_cons3. + +2000-01-28 Radey Shouman <Radey_Shouman@splashtech.com> + + * Init5d2.scm (file-exists?, file-readable?): Zero errno to + prevent spurious error messages. + + * Macro.scm (@print): Moved from Init*.scm, where it did no good + since 'macro was never provided at that stage. + + (destructuring-bind): SYNTAX-RULES version, gives better error + reporting. + +2000-01-28 Dorai Sitaram <dorai@owlnet.rice.edu> + (actually contributed March 1993) + + * Init5d2.scm (destructuring-bind): + (defmacro:get-destructuring-bind-pairs): Added for destructuring + DEFMACRO. + +2000-01-28 Radey Shouman <Radey_Shouman@splashtech.com> + * Init5d2.scm (defmacro:simple-defmacro): Added, does what + DEFMACRO used to do. + (defmacro): Now does CL style destructuring. + +2000-01-27 Radey Shouman <Radey_Shouman@splashtech.com> + + * Init5d2.scm (defmacro): Now accepts + (DEFMACRO (<name> . <args>) ...) as equivalent to + (DEFMACRO <name> (<args>) ...) + +2000-01-24 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (map, for_each): Check that the cdr of each list + argument is in fact a pair -- averting possible segfault. + +2000-01-11 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Makefile (SCMLIT, SCMEXE): local executables for build, bench, ... + +2000-01-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Init5d2.scm (track-all, stack-all, break-all): Added autoloads. + (trace, break): Improved Macro Autoloads. + +2000-01-04 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Init5d2.scm (boot-tail): Added -h(ave) feature option. + +2000-01-03 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Init5d2.scm (error, warn): print-call-stack. + +1999-12-23 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c (scm_top_level): Moved dowinds() call later in the error + recovery sequence so that the errjmp_recursive flag is cleared + before calling DYNAMIC-WIND exit thunks. This move prevents + spurious "recursive error" exits. + Bug report by Tomas Lozano-Perez <tlp@ai.mit.edu>. + +1999-12-17 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.texi (Bibliography): Added (Japanese) SchemePrimer. + +1999-12-17 Radey Shouman <Radey_Shouman@splashtech.com> + + * Init5d2.scm (@print): Added. + +1999-12-10 Aubrey Jaffer <jaffer@ai.mit.edu> + + * r4rstest.scm (SECTION 6 9): Added tests for map of single + argument +, -, and *. + +1999-12-10 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (scm_cvapply): Fixed bug in handling of asubrs. + +Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@ai.mit.edu> * patchlvl.h (SCMVERSION): Bumped from 5d1 to 5d2. -1999-12-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-12-02 Aubrey Jaffer <jaffer@ai.mit.edu> * Makefile (install): Make sure $(libscmdir)require.scm exists. (libscmdir): Use instead of IMPLPATH. @@ -16,11 +1366,11 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * repl.c (scm_top_level): Corrected error test on exit in case 0 is not success. - + (repl): Return MAKINUM(EXIT_SUCCESS) when exiting an interactive session on EOF, this should not be an error. -1999-11-14 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-11-14 Aubrey Jaffer <jaffer@ai.mit.edu> * build.scm (define-compile-commands): Added. (defcommand): Added. @@ -53,7 +1403,7 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> evaluates a list of expressions and returns a list allocated on the ecache in scm_env_tmp. - (m_do): (m_letrec1): (ceval_1): LET, LETREC, and DO now call + (m_do, m_letrec1, ceval_1): LET, LETREC, and DO now call ecache_evalx instead of using inline loops, this seems to improve speed by 5% - 10% for jacal and for simsynch simulation. C stack usage will increase somewhat for large env frames. @@ -69,23 +1419,23 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> 1999-11-04 David Yeh <theyeh@uclink.berkeley.edu> * scl.c (makdbl): Mods to compile using MSVC -1999-11-01 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-11-01 Aubrey Jaffer <jaffer@ai.mit.edu> * gmalloc.c: include "getpagesize.h" conditionalized on __svr4__. -1999-10-31 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-10-31 Aubrey Jaffer <jaffer@ai.mit.edu> * build.scm (batch:chop-to-fit-system): Removed. Use new batch:try-chopped-command instead. (mysql): Added to features. (build:build): Added comments describing stages and errors. -1999-10-17 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-10-17 Aubrey Jaffer <jaffer@ai.mit.edu> * Makefile: Added platform.txi dependency where dependent on scm.texi. -1999-10-16 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-10-16 Aubrey Jaffer <jaffer@ai.mit.edu> * Makefile (scm.info require.scm): "cp -p" more portable than "cp -a"? @@ -104,7 +1454,7 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> will hold a mode string suitable to pass to fopen(), without any SCM extension characters. -1999-10-13 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-10-13 Aubrey Jaffer <jaffer@ai.mit.edu> * r4rstest.scm (float-print-test): stop after first error. @@ -124,20 +1474,20 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * ramap.c (cind): Now takes C vector of indices, which may be allocated on the C stack, rather than a uve. - (ramapc): (ramap): (ramap_cxr): (array_imap): (array_for_each): (rafe): + (ramapc, ramap, ramap_cxr, array_imap, array_for_each, rafe): Use scm_cvapply instead of apply, allocate index and argument vectors on the C stack for array ranks < 5. - * record.c (makrectyp): (recprin1): Use scm_cvapply instead of + * record.c (makrectyp, recprin1): Use scm_cvapply instead of apply. (rec_prinset): Checks arity of argument procedure. - * sys.c (sfputc): (sfwrite): (sfgetc): Use scm_cvapply instead of + * sys.c (sfputc, sfwrite, sfgetc): Use scm_cvapply instead of apply. (mksfpt): Checks arities of soft port procedures when the port is made. - * eval.c (scm_cvapply): (scm_arity_check): Exported. - (makacro): (makmacro): (makmmacro): Call scm_cvapply rather than + * eval.c (scm_cvapply, scm_arity_check): Exported. + (makacro, makmacro, makmmacro): Call scm_cvapply rather than consing up argument lists. Check arity of macro transformers once, when syntax is defined. @@ -159,13 +1509,13 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> 1999-10-04 Radey Shouman <Radey_Shouman@splashtech.com> - * eval.c (scm_arity_check): (macroexp1): Argument number checking + * eval.c (scm_arity_check, macroexp1): Argument number checking in macroexp1 abstracted as scm_arity_check, for use in map, for-each ... - (scm_cvapply): Apply a function to a C vector of arguments, used by + (scm_cvapply): Apply a function to a C vector of arguments, used by map and for-each. - (scm_v2lst): Added for use in scm_cvapply. - (map): (for_each): Speed considerably improved: No longer allocate + (scm_v2lst): Added for use in scm_cvapply. + (map, for_each): Speed considerably improved: No longer allocate Scheme vector temporaries for up to 5 list arguments. No longer allocate unnecessary argument lists, allocate on ecache if possible. @@ -175,7 +1525,7 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * sys.c (scm_env_v2lst): Now takes last cdr of list as argument. -1999-09-21 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-09-21 Aubrey Jaffer <jaffer@ai.mit.edu> * sys.c (scm_port_entry): Make 16-bit safe. @@ -184,21 +1534,21 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * Tscript.scm: File added to implement transcript-on, transcript-off without burdening normal i/o. - * Init5d1.scm (transcript-on): (transcript-off): Now autoloads + * Init5d1.scm (transcript-on, transcript-off): Now autoloads from SCM/Tscript.scm (_TRACKED): Added. - * socket.c (l_socket): (l_connect): (l_listen): Modified to use + * socket.c (l_socket, l_connect, l_listen): Modified to use port table. - (l_shutdown): (l_getpeername): (l_getsockname): Test for OPFPORTP, not + (l_shutdown, l_getpeername, l_getsockname): Test for OPFPORTP, not just OPPORTP. * posix.c (l_pipe): Modified to use port table. (prinpipe): Removed. - * ioext.c (reopen_file): (l_dup): (l_dup2): Modified to use port + * ioext.c (reopen_file, l_dup, l_dup2): Modified to use port table. * crs.c (prinwindow): Removed. @@ -206,19 +1556,17 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> (mkwindow): Uses scm_port_entry. * repl.c (iprin1): Uses "name" field for printing ports. + (input_waiting, wait_for_input, trans_on, trans_off): Removed in + favor of soft-port implementation. - (input_waiting): (wait_for_input): - - (trans_on): (trans_off): Removed in favor of soft-port implementation. - - (lputc): (lgetc): (lputs): (lfwrite): (lungetc): Removed check for + (lputc, lgetc, lputs, lfwrite, lungetc): Removed check for transcript, added line and column number support. Unread char now kept in port table rather than CAR. - (lreadpr): (line_num): Removed line counting for load port, now done + (lreadpr, line_num): Removed line counting for load port, now done using general line and column counting. - (scm_port_line): (scm_port_column): (scm_port_filename): Added. + (scm_port_line, scm_port_column, scm_port_filename): Added. (err_head): Now prints out multiple filenames for nested loads. Tries to recover from recursive errors if current-error-port is a @@ -227,24 +1575,24 @@ Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * unif.c (uve_read): Removed ungetc call, if there is an unread character, just call lgetc repeatedly for the first elt. - * sys.c (must_malloc): (must_realloc): Now check whether the heap + * sys.c (must_malloc, must_realloc): Now check whether the heap is initialized or not, so may be called earlier. - (scm_init_gra): (scm_grow_gra): Use above feature. + (scm_init_gra, scm_grow_gra): Use above feature. - (scm_port_entry): Added, allocates entry in a port table used to store + (scm_port_entry): Added, allocates entry in a port table used to store unread characters, file names, line & column numbers, &c. - (mark_port_table): (sweep_port_table): Gc support for port table. + (mark_port_table, sweep_port_table): Gc support for port table. ptobfuns now has a "name" element, used for printing. - (prinfport): (prinstpt): (prinsfpt): Removed. + (prinfport, prinstpt, prinsfpt): Removed. -Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> +Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@ai.mit.edu> * patchlvl.h (SCMVERSION): Bumped from 5d0 to 5d1. -1999-09-12 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-09-12 Aubrey Jaffer <jaffer@ai.mit.edu> * x.c (init_x): Load "xevent.scm". @@ -256,7 +1604,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * requires.scm: Sample "require.scm". -1999-09-11 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-09-11 Aubrey Jaffer <jaffer@ai.mit.edu> * Xlibscm.texi (Event): Documented x:event-ref. @@ -273,7 +1621,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * repl.c (def_err_response): Now prints "expand-time environment" message only when relevant. -1999-08-21 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-08-21 Aubrey Jaffer <jaffer@ai.mit.edu> * xgen.scm (event-map): Added. @@ -284,11 +1632,11 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * repl.c (def_err_response): Error message for expand-time only environment. - * eval.c (lookupcar): (id_denote): Now handle environment objects + * eval.c (lookupcar, id_denote): Now handle environment objects in scm_env, lookupcar will complain if this happens in a run-time (rather than expand-time) context. - (eval_syntax): Added, to be used in Macroexpand.scm for LET-SYNTAX, + (eval_syntax): Added, to be used in Macroexpand.scm for LET-SYNTAX, LETREC-SYNTAX. (ceval_1): Fixed bug in eval. @@ -314,7 +1662,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> `scm_trace'. Nested expressions involving primitives now give more accurate stack traces, without a speed penalty. - (map): (for_each): Always push an estk frame for the sake of stack + (map, for_each): Always push an estk frame for the sake of stack tracing. * repl.c (scm_stack_trace): Now may print out the value of the @@ -342,7 +1690,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * repl.c (def_err_response): Changed setjump to setjmp when setting up safeport. -1999-07-11 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-07-11 Aubrey Jaffer <jaffer@ai.mit.edu> * Makefile (incdir): Added to abstract include directory location. @@ -361,11 +1709,11 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> prototypes if they are small enough to be elements of a uvect, similarly for negative bignums and ivects. - (make_uve): (arrayp): Now use scm_prot2type. + (make_uve, arrayp): Now use scm_prot2type. SINGLES no longer need to be #DEFINEd in order to allow fvects. - * ramap.c: Modifications for fvects if SINGLES not #DEFINEd. + * ramap.c: Modifications for fvects if SINGLES not #DEFINEd. 1999-07-06 Radey Shouman <Radey_Shouman@splashtech.com> @@ -374,7 +1722,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> conform to R5RS, in response to posting of Allegro Petrofsky <Allegro@Petrofsky.Berkeley.CA.US> to comp.lang.scheme -1999-07-04 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-07-04 Aubrey Jaffer <jaffer@ai.mit.edu> * crs.c (lwinsch): Renamed from lwinsert. Why were idlok and nodelay commented out? @@ -448,7 +1796,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> below -MAXEXP, since this such numbers can be represented with gradually underflowing denormals. -1999-04-15 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-04-15 Aubrey Jaffer <jaffer@ai.mit.edu> * Makefile (require.scm): Added constructor. @@ -489,7 +1837,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * sys.c (scm_grow_gra): Fixed error in mallocated accounting, made increment grow with allocated size. -1999-03-22 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-03-22 Aubrey Jaffer <jaffer@ai.mit.edu> * Init5d0.scm (exec-self): Undo *script* meta-argument processing. @@ -501,7 +1849,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> 1999-03-17 Radey Shouman <Radey_Shouman@splashtech.com> * unif.c (raprin1): New write syntax for uniform vectors and arrays. - (array2list): (list2ura): Fixed for zero-rank arrays. + (array2list, list2ura): Fixed for zero-rank arrays. * Init5d0.scm (read:sharp): New read syntax for uniform vectors and arrays. @@ -542,7 +1890,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * Makefile (mydlls): build edit-line separately to link in libraries correctly. -1999-02-17 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-02-17 Aubrey Jaffer <jaffer@ai.mit.edu> * build.scm, mkimpcat.scm, x.c, x.h, x11.scm, xgen.scm, xscm.doc, xtest.scm: Xlib interface from xscm-2.01 @@ -588,7 +1936,7 @@ Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * build.scm (read-version): 5d0 READ as a number; Assemble characters till whitespace. -Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> +Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@ai.mit.edu> * patchlvl.h (SCMVERSION): Bumped from 5c4 to 5d0. @@ -605,7 +1953,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * scm.texi (SCM_VERSION): abstracted to version.txi. -1999-01-12 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-01-12 Aubrey Jaffer <jaffer@ai.mit.edu> * build (make-readme): moved (require 'posix) here. @@ -615,7 +1963,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * build (make-readme): added. Makes README from scm5c4.info. -1999-01-11 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-01-11 Aubrey Jaffer <jaffer@ai.mit.edu> * Makefile (README): added target. @@ -643,7 +1991,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * ioext.c (director-for-each): fail gracefully if can't open directory. -1999-01-08 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-01-08 Aubrey Jaffer <jaffer@ai.mit.edu> * scm.texi (Smob Cells): Explained NUMDIGS_MAX limit. @@ -663,7 +2011,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * repl.c (heap_report): Only call scm_brk_report() if scm_init_brk has been set. -1999-01-04 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1999-01-04 Aubrey Jaffer <jaffer@ai.mit.edu> * scm.texi (Unix Shell Scripts): merged in "SCSH scripts". Removed description of single non-\ argument on first script line. @@ -725,14 +2073,14 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> 1998-12-14 Radey Shouman <Radey_Shouman@splashtech.com> - * eval.c (m_lambda): (closure): Now checks that argc <= 3 during + * eval.c (m_lambda, closure): Now checks that argc <= 3 during memoization instead of each time a closure is made. (macroexp1): Gives more sensible error messages when a non-identifier non-list is in the function position. 1998-12-10 Radey Shouman <Radey_Shouman@splashtech.com> - * (scm_top_level): (repl): Made repl an acceptable second argument to + * (scm_top_level, repl): Made repl an acceptable second argument to scm_top_level. 1998-12-09 Aubrey Jaffer <jaffer@ai.mit.edu> @@ -796,7 +2144,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> done with native C types. Moved from subr.c to scl.c because of FLOAT dependencies. - * eval.c (lookupcar): (ceval_1): Added MEMOIZE_LOCALS cpp macro to + * eval.c (lookupcar, ceval_1): Added MEMOIZE_LOCALS cpp macro to control memoization of local variables to ilocs. 1998-12-05 Aubrey Jaffer <jaffer@ai.mit.edu> @@ -831,9 +2179,9 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * scl.c (makdbl): Combined some DEFER_INTS and ALLOW_INTS, possible because NEWCELL is now callable with ints deferred. - (product): (divide): Now scale bignums if necessary before + (product, divide): Now scale bignums if necessary before converting them to doubles for calculating inexact results. - (big2scaldbl): (bigdblop): (inex_divbigbig): Auxiliary functions + (big2scaldbl, bigdblop, inex_divbigbig): Auxiliary functions added. (idbl2str): Decrease minimum exponent to allow printing of gradually underflowing IEEE doubles. @@ -849,7 +2197,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * scm.h (NUMDIGS): Added cast so that NALLOC error reports would print correctly. -1998-12-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-12-02 Aubrey Jaffer <jaffer@ai.mit.edu> * setjump.h: windframe removed -- dowinds could only be processed while (possibly oversize) stack was intact. @@ -901,7 +2249,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> setjump *must* be called with this argument before using a safeport. - * repl.c (scm_stack_trace): (def_err_response): Use new + * repl.c (scm_stack_trace, def_err_response): Use new safeport features. * Macro.scm (substitute-in-template): Added check that all pattern @@ -936,13 +2284,13 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> 1998-11-26 Radey Shouman <rshouman@metro2000.com> - * eval.c (ceval): (env2tree): (ident_eqp): Removed redundant + * eval.c (ceval, env2tree, ident_eqp): Removed redundant DEFER_INTS_EGC before ENV_PUSH. (ceval_1): Removed label retunspec, replaced by jumps to retx. Seems to run a tad faster, be a little easier to look at. (copy_list): Now takes second argument giving minimum length of list, allowing the removal of several calls to ilength. - (m_case): (m_cond): (ceval_1): ilength checks replaced. + (m_case, m_cond, ceval_1): ilength checks replaced. 1998-11-25 Radey Shouman <Radey_Shouman@splashtech.com> @@ -959,7 +2307,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * sys.c (init_types): Initialize sys_safep to tmp_errp. (reset_safeport): Now does exactly nothing if handed a non-safe-port. - (init_types): (init_storage): Moved initialization of tmp_errp and + (init_types, init_storage): Moved initialization of tmp_errp and sys_protects earlier, in case allocating ptobs or smobs causes errors to be thrown. @@ -974,7 +2322,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> allocate pairs for a safe-port. * repl.c (scm_stack_trace): Now uses sys_safep and reset_safeport. - (def_err_response): (handle_it): (repl_driver): (everr): + (def_err_response, handle_it, repl_driver, everr): Now checks and dies horribly but predictably if def_err_response is recursively entered. @@ -986,14 +2334,14 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> message (I don't remember when that disappeared) and prints at most 12 traced frames. - * sys.c (makesafeport): (safewrite): (safeputs): (safeputc): + * sys.c (makesafeport, safewrite, safeputs, safeputc): (safeflush): Added support for `safe' ports for error messages, which will accept and re-output only a fixed number of characters. Subsequent characters are simply discarded. 1998-11-19 Radey Shouman <rshouman@metro2000.com> - * record.c (rec_error): (rec_accessor1): (rec_modifier1): + * record.c (rec_error, rec_accessor1, rec_modifier1): (rec_constr1): Better error reporting, including the name of the expected record type and the relevant field. @@ -1012,7 +2360,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> (renaming-transformer): Added to support `explicit renaming' low-level macros. - * eval.c (varcheck): (m_lambda): Some checks moved from m_lambda + * eval.c (varcheck, m_lambda): Some checks moved from m_lambda to varcheck, argument added to varcheck to give different message (about "formals") in case of lambda. (ENVP): Added predicate macro local to eval.c. @@ -1022,8 +2370,8 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> * eval.c (varcheck): Renamed from uniqcheck, now checks that elements are identifiers so m_do, m_lambda, m_letrec1 don't have to. - * Init5c4.scm (alarm-interrupt) (profile-alarm-interrupt) - (virtual-alarm-interrupt) Now initially defined to turn off their + * Init5c4.scm (alarm-interrupt, profile-alarm-interrupt): + (virtual-alarm-interrupt): Now initially defined to turn off their respective alarms, so that restarting does not cause an error when an alarm is pending. @@ -1045,14 +2393,14 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> unmemocar. (uniqcheck): Added, checks for non-unique identifiers in a binding list. - (m_lambda): (m_letrec1): (m_do): Now check for duplicate bound + (m_lambda, m_letrec1, m_do): Now check for duplicate bound names. 1998-11-13 Radey Shouman <Radey_Shouman@splashtech.com> * unif.c (shap2ra): better error checking of dimension specs -1998-11-12 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-11-12 Aubrey Jaffer <jaffer@ai.mit.edu> * scmfig.h (SCM_NEED_FDS SCM_INTERRUPTED): added argument to make clear that this is not a constant. @@ -1073,7 +2421,7 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> If an open fails because there are no unused file handles, GC for for file handles. -1998-11-11 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-11-11 Aubrey Jaffer <jaffer@ai.mit.edu> * Init5c4.scm (vicinity:suffix?): Abstracted from pathname->vicinity and "Link.scm". @@ -1087,13 +2435,13 @@ Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> 1998-11-05 Aubrey Jaffer <jaffer@ai.mit.edu> - * ioext.c (init_ioext): (provide 'directory-for-each) changed to + * ioext.c (init_ioext, provide 'directory-for-each) changed to add_feature("directory-for-each"); so ioext.o can be statically linked. 1998-11-04 Radey Shouman <Radey_Shouman@splashtech.com> - * scm.h (ESTK_PARENT): (ESTK_PARENT_WRITABLEP): + * scm.h (ESTK_PARENT, ESTK_PARENT_WRITABLEP): (ESTK_PARENT_INDEX): SCM_ prepended, definition moved to scm.h, now used in repl.c. @@ -1111,7 +2459,7 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * patchlvl.h (SCMVERSION): Bumped from 5c3 to 5c4. -1998-11-03 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-11-03 Aubrey Jaffer <jaffer@ai.mit.edu> * ioext.c (directory-for-each): Added. @@ -1121,7 +2469,7 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * sys.c (makcclo): Fixed argument to ASSERT. -1998-11-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-11-02 Aubrey Jaffer <jaffer@ai.mit.edu> * record.c rgx.c scm.texi socket.c subr.c sys.c unif.c: Callers to must_malloc and friends now check that length will fit in field. @@ -1144,18 +2492,18 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-10-29 Radey Shouman <Radey_Shouman@splashtech.com> - * eval.c (m_and): (m_or): Special case for one argument. + * eval.c (m_and, m_or): Special case for one argument. 1998-10-28 Radey Shouman <Radey_Shouman@splashtech.com> * setjump.h - * sys.c (scm_make_cont): (scm_dynthrow): (egc_copy_roots): + * sys.c (scm_make_cont, scm_dynthrow, egc_copy_roots): No longer copy scm_estk if CHEAP_CONTINUATIONS is #defined. * eval.c (ceval_1): Fix up environment stack accounting for CHEAP_CONTINUATIONS. -1998-10-27 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-10-27 Aubrey Jaffer <jaffer@ai.mit.edu> * scm.c (scm_init_extensions): Added call to init_user_scm for RTL case. @@ -1168,13 +2516,13 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * Init5c3.scm (with-XXX-to-port): Oops. fixed earlier change. -1998-10-19 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-10-19 Aubrey Jaffer <jaffer@ai.mit.edu> * scm.texi (Build Options): Build platform table in Makefile and @include. 1998-10-19 Radey Shouman <Radey_Shouman@splashtech.com> - * dynl.c (l_dyn_call): (l_dyn_main_call): Now use new P_SHL macro, + * dynl.c (l_dyn_call, l_dyn_main_call): Now use new P_SHL macro, prevents compiler warning under hpux. * sys.c (scm_free_gra): Now sets elts pointer to zero. @@ -1182,7 +2530,7 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> (egc_sweep): Give dead cells immediate values, prevents obscure gc bug seen in hpux. - * sys.c (scm_estk_grow): (scm_estk_shrink): Deleted incorrect + * sys.c (scm_estk_grow, scm_estk_shrink): Deleted incorrect DEFER/ALLOW_INTS. (init_storage): SHORT_INT fixconfig message now suggests changing @@ -1217,11 +2565,11 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * sys.c (scm_estk_reset): Now takes an argument giving the size of the environment stack to create, 0 gives a default size. - (scm_estk_grow): (scm_estk_shrink): Rewritten to use segmented + (scm_estk_grow, scm_estk_shrink): Rewritten to use segmented stack, so all of the stack need not be copied when the stack grows or when a continuation is captured. - (scm_env_cons): (scm_env_cons2): (scm_env_cons_tmp): + (scm_env_cons, scm_env_cons2, scm_env_cons_tmp): (scm_extend_env): Rewritten using local temporary for indexing into ecache. @@ -1230,7 +2578,7 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * scm.c: SIGPROF #undefined if LACK_SETITIMER is #defined, needed to build profiling version of SCM. -1998-10-06 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-10-06 Aubrey Jaffer <jaffer@ai.mit.edu> * build.scm (read-version): Will use implementation-vicinity if scm-srcdir does not contain "patchlvl.h". @@ -1239,7 +2587,7 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * scm.c (run_scm): Fixed finals call loop -1998-10-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-10-02 Aubrey Jaffer <jaffer@ai.mit.edu> * unif.c, sys.c, subr.c, socket.c, scm.h, scl.c, rgx.c, posix.c: Fixed argument types in calls to must_malloc_cell(). @@ -1269,9 +2617,9 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * sys.c (must_malloc_cell): Takes an argument specifying the CAR of the cell to be returned. - * scm.h (MAKE_LENGTH): (MAKE_NUMDIGS): Preprocessor macros added. + * scm.h (MAKE_LENGTH, MAKE_NUMDIGS): Preprocessor macros added. -1998-09-29 Aubrey Jaffer <aubrey_jaffer@splashtech.com> +1998-09-29 Aubrey Jaffer <jaffer@ai.mit.edu> * build (build-from-argv): slib:warns if not successful. (bi): Exits with error indication when build not successful. @@ -1282,13 +2630,13 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-09-22 Radey Shouman <Radey_Shouman@splashtech.com> - * sys.c (scm_init_gra): (scm_grow_gra): (scm_free_gra): GRowable + * sys.c (scm_init_gra, scm_grow_gra, scm_free_gra): GRowable Array type. - (newsmob): (newptob): (add_final): Implemented using scm_gra type. + (newsmob, newptob, add_final): Implemented using scm_gra type. 1998-09-18 Radey Shouman <Radey_Shouman@splashtech.com> - * Init5c3.scm (profile-timer): (milli-alarm): Defined in terms of + * Init5c3.scm (profile-timer, milli-alarm): Defined in terms of SETITIMER. * sys.c (sysintern): No longer changes the CDR of an existing @@ -1305,7 +2653,7 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-09-17 Aubrey Jaffer <jaffer@ai.mit.edu> - * Init5c3.scm (with-input-from-port): (with-output-to-port): + * Init5c3.scm (with-input-from-port, with-output-to-port): (with-error-to-port): Replicated procedure rather than using SWAPPORTS twice. This in combo with repl.c change fixes Radey's strange multi-process bug! @@ -1329,11 +2677,11 @@ Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * unif.c (resizuve): Fixed accounting of mallocated storage for strings and bitvectors. - * sys.c (igc_for_alloc): (must_malloc): (must_realloc): + * sys.c (igc_for_alloc, must_malloc, must_realloc): (must_malloc_cell): (must_realloc_cell): Fixed accounting of mallocated storage. - (igc): Added malloc consistency check for patched gmalloc, conditional + (igc): Added malloc consistency check for patched gmalloc, conditional on #define DEBUG_GMALLOC. (gc_sweep): Fixed accounting of bignum storage for DIGSTOOBIG case. @@ -1352,7 +2700,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * gmalloc.c: Imported gmalloc.c from emacs 20.2.1. - (check_block): (check_frag_blocks): Debugging functions added. + (check_block, check_frag_blocks): Debugging functions added. * sys.c (scm_protect_temp): Added, is currently, and probably will remain, a noop to force allocation of a SCM temporary on the @@ -1360,7 +2708,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * scl.c (big2str): Added call to scm_protect_temp. - * eval.c (map): (for_each): Added calls to scm_protect_temp. + * eval.c (map, for_each): Added calls to scm_protect_temp. * rgx.c (lregcomp): Added call to scm_protect_temp. @@ -1388,19 +2736,19 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * scmfig.h (VERIFY_INTS): Added macro to print warnings if interrupts are improperly allowed and CAREFUL_INTS is #defined. - (VOLATILE): Expands to `volatile' keyword if __STDC__ is #defined. + (VOLATILE): Expands to `volatile' keyword if __STDC__ is #defined. * sys.c (sys_errp): Interrupt safe system output port added. - (scm_estk_reset): (must_malloc): (must_realloc): (scm_make_cont): + (scm_estk_reset, must_malloc, must_realloc, scm_make_cont): Now should be run with ints deferred, no longer ever allow ints. scm-estk_reset builds a new stack if scm_estk is BOOL_F. * scm.c (process_signals): Modified to print deferred output to sys_errp. - * eval.c (SCM_ENV_SAVE): (SCM_ENV_RESTORE): now ENV_SAVE, + * eval.c (SCM_ENV_SAVE, SCM_ENV_RESTORE): now ENV_SAVE, ENV_RESTORE, local to eval.c - (apply): (ceval_1): Ints deferred before call to scm_make_cont, + (apply, ceval_1): Ints deferred before call to scm_make_cont, which no longer allows ints. (closure): Now takes the number of required closure arguments as a second argument. @@ -1409,7 +2757,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * repl.c (iprlist): Uses GCCDR so that fatal error messages during gc may print better. (handle_it): Call to scm_egc made conditional on NO_ENV_CACHE. - (growth_mon): (gc_start): (gc_end): (heap_report): Now use + (growth_mon, gc_start, gc_end, heap_report): Now use sys_errp. (ints_warn): Added for interrupt warnings using VERIFY_INTS. (scm_stack_trace): Now completely prints stacks up to 20 deep, @@ -1440,11 +2788,11 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-08-24 Radey Shouman <radey@colorage.com> - * scm.c (scmable_signal): (err_signal): (init_signals): + * scm.c (scmable_signal, err_signal, init_signals): (ignore_signals): - (unignore_signals): (restore_signals): Abstracted signal handling. + (unignore_signals, restore_signals): Abstracted signal handling. - (fpe_signal): (bus_signal): (segv_signal): (alrm_signal): + (fpe_signal, bus_signal, segv_signal, alrm_signal): (prof_signal): Removed. * repl.c (process_signals): Moved to scm.c @@ -1453,7 +2801,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-08-20 Radey Shouman <radey@colorage.com> - * scm.c (prof_signal): (scm_proftimer): (ignore_signals): + * scm.c (prof_signal, scm_proftimer, ignore_signals): (unignore_signals): Added handler for SIGPROF, raised via call to setitimer (Scheme function PROFILE-TIMER). @@ -1483,7 +2831,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-08-17 Radey Shouman <radey@colorage.com> - * sys.c (scm_egc): (scm_egc_copy_roots): Eliminated extra root + * sys.c (scm_egc, scm_egc_copy_roots): Eliminated extra root argument, made safe because EGC_ROOT is always called with ints deferred. @@ -1492,15 +2840,15 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> (gc_sweep): Now uses HUGE_LENGTH instead of LENGTH for string termination check. - (must_malloc_cell): (must_realloc_cell): Added. + (must_malloc_cell, must_realloc_cell): Added. - (gc_for_alloc): Static function abstracts gc calls for malloc/realloc. + (gc_for_alloc): Static function abstracts gc calls for malloc/realloc. * unif.c (make_uve): Removed call to makestr in order to support huge strings. - (resizuve): Now uses must_realloc_cell. + (resizuve): Now uses must_realloc_cell. - * subr.c (make_vector): (mkbig): (adjbig): Now use + * subr.c (make_vector, mkbig, adjbig): Now use must_malloc_cell, must_realloc_cell. * socket.c (maksknm): Now uses must_malloc_cell. @@ -1514,11 +2862,11 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * repl.c (handle_it): Keep pointers to discarded new cells. - * record.c (rec_constr1): (init_record): Now use must_malloc_cell. + * record.c (rec_constr1, init_record): Now use must_malloc_cell. * posix.c (scm_getgroups): Now uses must_malloc_cell. - * dynl.c (l_dyn_link): (l_dyn_call): Moved NEWCELL out of deferred + * dynl.c (l_dyn_link, l_dyn_call): Moved NEWCELL out of deferred ints sections. For dlopen versions, print more error messages. 1998-08-17 Aubrey Jaffer <jaffer@colorage.com> @@ -1548,7 +2896,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * sys.c (scm_estk_grow): Now pushes estk ptr, with ints deferred. - * eval.c (ENV_PUSH): (ENV_POP): Now done with DEFER_INTS_EGC to + * eval.c (ENV_PUSH, ENV_POP): Now done with DEFER_INTS_EGC to prevent problems with interrupt handlers that run Scheme code. 1998-07-27 Radey Shouman <radey@colorage.com> @@ -1556,7 +2904,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * sys.c (scm_estk_grow): Protected critical section with DEFER/ALLOW_INTS - (must_malloc): (must_realloc): Protected igc call with + (must_malloc, must_realloc): Protected igc call with DEFER/ALLOW_INTS. (scm_egc): Added DEFER/ALLOW_INTS around call to igc -- prevents @@ -1565,7 +2913,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> (igc): Now SCM_ENV_SAVE before any gc marking to fix gc bug tickled by running Scheme code from interrupts. - (scm_egc): (scm_egc_copy_roots): Now take a single argument, a gc + (scm_egc, scm_egc_copy_roots): Now take a single argument, a gc root. Simplifies handling of the case where scm_egc calls igc, and possibly itself. @@ -1589,10 +2937,10 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> several meaningful values for ints_disabled. (handle_it): More careful about interrupts when saving estk. * - *scmfig.h (DEFER_INTS): (ALLOW_INTS): (DEFER_INTS_EGC): + *scmfig.h (DEFER_INTS, ALLOW_INTS, DEFER_INTS_EGC): (ALLOW_INTS_EGC): ints_viol calls changed. - * ramap.c (array_for_each): (array_map): Always act as if CCLO is + * ramap.c (array_for_each, array_map): Always act as if CCLO is defined, this does no harm, and allows CCLO optimizations for the dynamicly loaded case. @@ -1602,7 +2950,7 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> IDENTIFIER->SYMBOL. (closure): Removed env argument, now uses scm_env and is more careful about interrupts. - (env2tree): Now uses DEFER_INTS_EGC. + (env2tree): Now uses DEFER_INTS_EGC. 1998-07-22 Aubrey Jaffer <jaffer@colorage.com> @@ -1649,23 +2997,23 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-07-14 Radey Shouman <radey@colorage.com> - * eval.c (ENV_PUSH): (ENV_POP): Modified for interrupt safety. + * eval.c (ENV_PUSH, ENV_POP): Modified for interrupt safety. - (ceval_1): (apply): (procedurep): (macroexp1): (make_specfun): + (ceval_1, apply, procedurep, macroexp1, make_specfun): cclo is now a subtype of tc7_specfun, which also includes tc16_apply and tc16_call_cc, smobs are now never procedures. (apply): Added call/cc support, error checking for subr_2o and subr_3 types. - * sys.c (gc_mark): (gc_sweep): Modified for new specfun, cclo + * sys.c (gc_mark, gc_sweep): Modified for new specfun, cclo representation. (gc): Now does ecache gc if given optional argument. * repl.c (iprin1): Modified for new specfun, cclo representation. - (handle_it): Now saves and restores estk for interrupt safety. + (handle_it): Now saves and restores estk for interrupt safety. * ramap.c (array_map): Changed for new cclo representation. @@ -1691,10 +3039,10 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> (m_body): Added, error checks bodies and inserts the ISYM tokens. - (m_lambda): (m_letstar): (m_letrec1): (m_letrec): (m_let): Now + (m_lambda, m_letstar, m_letrec1, m_letrec, m_let): Now call m_body. - (m_cond): (m_case): (m_quote): Modified to avoid destructively changing + (m_cond, m_case, m_quote): Modified to avoid destructively changing their argument forms. Since m_expand_body speculatively macro expands forms the process must be reversible. @@ -1707,7 +3055,7 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-07-07 Radey Shouman <radey@colorage.com> * eval.c (SPECFUN): Removed -- now the only case. - (ceval_1): (m_cont): IM_CONT case removed. + (ceval_1, m_cont): IM_CONT case removed. (scm_evalatomcar): Added check for tc16_specfun. Made unquoted vector message conditional on RECKLESS. @@ -1725,7 +3073,7 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * eval.c (ceval_1): Fixed argument number check for closures and made conditional on CAUTIOUS. - (ceval_1): (evalatomcar): (lookupcar): Moved check for + (ceval_1, evalatomcar, lookupcar): Moved check for using macro as variable from ceval_1 and evalatomcar to lookupcar. 1998-07-02 Radey Shouman <radey@colorage.com> @@ -1738,7 +3086,7 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> ecache allocated lists now no longer passed to apply of asubrs and rpsubrs -- this is not interrupt safe. - (macroexp1): Added argument number checks for subrs, this gives error + (macroexp1): Added argument number checks for subrs, this gives error messages with unmemoized code. * eval.c (ceval_1): Fixed error reporting -- "wrong number of @@ -1749,7 +3097,7 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-07-01 Radey Shouman <radey@colorage.com> - * eval.c (ceval): (ceval_1): (ilookup): (lookupcar): (farlookup): + * eval.c (ceval, ceval_1, ilookup, lookupcar, farlookup): New model of interrupt control for protecting ecache references using DEFER_INTS_EGC, ALLOW_INTS_EGC. These need not be strictly nested, ints are always allowed by ceval_1 before tail-calling a @@ -1760,9 +3108,9 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> (scm_macroexp1): Now checks arity for closures, checking had been broken for non-CAUTIOUS SCM. - * scmfig.h (DEFER_INTS_EGC): (ALLOW_INTS_EGC): Defined. + * scmfig.h (DEFER_INTS_EGC, ALLOW_INTS_EGC): Defined. - * sys.c (scm_env_cons): (scm_env_cons): (scm_env_cons2): + * sys.c (scm_env_cons, scm_env_cons, scm_env_cons2): (scm_extend_env): DEFER_INTS replaced with DEFER_INTS_EGC. * repl.c (repl_report): At verbose level 3 now reports number of @@ -1785,15 +3133,15 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-06-19 Radey Shouman <radey@colorage.com> - * eval.c (ilookup): (farlookup): (unmemocar): (ceval_1): + * eval.c (ilookup, farlookup, unmemocar, ceval_1): (id_denote): Wrapped all pointer-chasing of possible ecache cells in DEFER/ALLOW_INTS for safety when interrupt handlers may evaluate Scheme code asynchronously. - (scm_macroexp1): (m_define): (m_atlet_syntax): Environments now + (scm_macroexp1, m_define, m_atlet_syntax): Environments now always wrapped when passed to macro expanders. - (ecache_p): (debug_env_car): (debug_env_cdr): Added for CAREFUL_INTS + (ecache_p, debug_env_car, debug_env_cdr): Added for CAREFUL_INTS checking. (test_ints): Added when CAREFUL_INTS is defined for checking interrupt @@ -1803,15 +3151,15 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-06-15 Radey Shouman <radey@colorage.com> - * scm.h (SCM_ENV_SAVE): (SCM_ENV_RESTORE): Added, to prevent + * scm.h (SCM_ENV_SAVE, SCM_ENV_RESTORE): Added, to prevent oversights in sys.c. - * sys.c (scm_env_cons): (scm_env_cons2): Made interrupt safe; + * sys.c (scm_env_cons, scm_env_cons2): Made interrupt safe; return results in global scm_env_tmp, use DEFER/ALLOW_INTS. - (scm_extend_env): (scm_env_cons_tmp): Added. + (scm_extend_env, scm_env_cons_tmp): Added. (scm_env_acons): Deleted, superseded by scm_extend_env. - *eval.c (ceval_1): (apply): Replaced and rewrote scm_env_ routines + *eval.c (ceval_1, apply): Replaced and rewrote scm_env_ routines to use new interrupt safe versions. ENV_TMP replaced by scm_env_tmp, it was hard to remember that ENV_TMP might move. CLEAR_ENV_TMP removed since scm_env_tmp will be overwritten almost @@ -1959,7 +3307,7 @@ Fri Jun 5 16:01:02 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * sys.c: cosmetic changes. -Wed May 20 17:53:52 EDT 1998 Aubrey Jaffer <jaffer@aubrey.jaffer> +Wed May 20 17:53:52 EDT 1998 Aubrey Jaffer <jaffer@ai.mit.edu> * patchlvl.h (SCMVERSION): Bumped from 5b5 to 5c0. @@ -1983,13 +3331,13 @@ Wed May 20 17:53:52 EDT 1998 Aubrey Jaffer <jaffer@aubrey.jaffer> 1998-05-14 Radey Shouman <radey@colorage.com> - * Init.scm (bit-extract): (logical:bit-field): - (logical:bitwise-if): (logical:copy-bit): + * Init.scm (bit-extract, logical:bit-field): + (logical:bitwise-if, logical:copy-bit): (logical:copy-bit-field): definitions added for SLIB compatibility. * subr.c (scm_bitfield): renamed BIT-EXTRACT to BIT-FIELD, added range check on END. - (scm_bitif): (scm_copybitfield): (scm_copybit): added. + (scm_bitif, scm_copybitfield, scm_copybit): added. 1998-05-12 Aubrey Jaffer <jaffer@colorage.com> @@ -2036,7 +3384,7 @@ Fri May 8 17:40:44 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-04-16 <radey@colorage.com> - * unif.c (scm_logaref): (scm_logaset): Added. + * unif.c (scm_logaref, scm_logaset): Added. Thu Apr 9 11:31:20 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> @@ -2102,16 +3450,16 @@ Thu Apr 9 11:31:20 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-03-26 Radey Shouman <radey@colorage.com> - * eval.c (ilookup): (lookupcar): (farlookup): (ceval): (evalatomcar): - (ceval_1): (iqq): (wrapenv): Substantial changes to use + * eval.c (ilookup, lookupcar, farlookup, ceval, evalatomcar): + (ceval_1, iqq, wrapenv): Substantial changes to use copy-collected stack cache intended to reduce time in gc. - * sys.c (egc_mark): (egc_sweep): (egc_copy): (egc_copy_stack): - (egc_copy_roots): (scm_egc): The cache garbage collector. - (scm_env_cons): (scm_env_cons2): (scm_env_acons): Functions to + * sys.c (egc_mark, egc_sweep, egc_copy, egc_copy_stack): + (egc_copy_roots, scm_egc): The cache garbage collector. + (scm_env_cons, scm_env_cons2, scm_env_acons): Functions to allocate storage in the environment cache. - * repl.c (scm_egc_start): (scm_egc_end): (scm_ecache_report): + * repl.c (scm_egc_start, scm_egc_end, scm_ecache_report): (scm_stack_trace): Added to support environment cache. stack-trace now does not print all of stacktraces deeper than 10 levels. @@ -2312,7 +3660,7 @@ Sun Sep 28 14:48:10 1997 Radey Shouman <shouman@zianet.com> * ramap.c (array_imap): Fixed for zero-rank arrays arguments. -Fri Sep 19 23:23:46 EDT 1997 Aubrey Jaffer <jaffer@aubrey.jaffer> +Fri Sep 19 23:23:46 EDT 1997 Aubrey Jaffer <jaffer@ai.mit.edu> * patchlvl.h (SCMVERSION): Bumped from 5b1 to 5b2. @@ -2550,16 +3898,16 @@ Sat Feb 1 21:41:15 EST 1997 Aubrey Jaffer <jaffer@scm.bertronics.com> Sat Jan 25 19:48:19 1997 Radey Shouman <shouman@zianet.com> - * scm.h (IM_DELAY) (IM_QUASIQUOTE) (IM_UNQUOTE) (IM_UQ_SPLICING) - (IM_ELSE) (IM_ARROW): Added to support hygienic macros. + * scm.h (IM_DELAY, IM_QUASIQUOTE, IM_UNQUOTE, IM_UQ_SPLICING): + (IM_ELSE, IM_ARROW): Added to support hygienic macros. * repl.c: isymnames modified. * eval.c (lookupcar): Added support for hygienic macros - (evalatomcar): Added. - (ident2sym) (id_denote) (unpaint) (prinid) (ident_eqp) - (rename_ident) (syn_quote) (m_atlet_syntax) (m_the_macro): added. - (m_quote) (m_cond) (m_case) (m_quasiquote): Modified to be + (evalatomcar): Added. + (ident2sym, id_denote, unpaint, prinid, ident_eqp) + (rename_ident, syn_quote, m_atlet_syntax, m_the_macro): added. + (m_quote, m_cond, m_case, m_quasiquote): Modified to be referentially transparent. (m_iqq): added. (m_delay): now memoizes to prevent speed hit from slower lookupcar. @@ -2592,7 +3940,7 @@ Mon Dec 2 20:40:40 1996 Radey Shouman <shouman@zianet.com> (ceval): Modified to do the right thing with farlocs. * scm.h (MAKILOC): Added, now used in lookupcar. - (IM_FARLOC_CDR) (IM_FARLOC_CAR): ISYMS added. + (IM_FARLOC_CDR, IM_FARLOC_CAR): ISYMS added. Sun Dec 1 00:41:07 1996 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> @@ -2922,9 +4270,9 @@ Sun Mar 24 00:18:10 1996 Aubrey Jaffer <jaffer@jacal.bertronics> Sun Mar 10 17:23:39 1996 Radey Shouman <shouman@ccwf.cc.utexas.edu> * ramap.c (sc2array): Added, converts a scalar to a shared array. - (ramapc): Uses sc2array to convert scalar arguments to arrays + (ramapc): Uses sc2array to convert scalar arguments to arrays for ARRAY-MAP! &c. - (ura_read, ura_write, ura_fill): Added. + (ura_read, ura_write, ura_fill): Added. (array_map): Added check for number of arguments when procedure arg is a subr. Added cclo case. @@ -2942,10 +4290,10 @@ Sun Mar 10 17:23:39 1996 Radey Shouman <shouman@ccwf.cc.utexas.edu> dynamic linking of ramap.c. (rafill): moved from ramap.c, to allow filling of arrays on creation without needing ramap.c. - (uve_fill): Added, for filling uves / 1-d arrays without needing + (uve_fill): Added, for filling uves / 1-d arrays without needing ramap.c. - (uve_read, uve_write): (Re)added - (ura_read, ura_write): Moved to ramap.c, now call uve_[read write]. + (uve_read, uve_write): (Re)added + (ura_read, ura_write): Moved to ramap.c, now call uve_[read write]. (ra2l): uses cvref instead of aref, maybe faster and works for enclosed arrays. (init_unif): Added feature 'string-case, to prevent require @@ -3215,7 +4563,7 @@ Sat Mar 25 20:37:48 1995 Aubrey Jaffer (jaffer@jacal) regex library is conditionalized with _GNU_SOURCE. From: Radey Shouman <shouman@ccwf.cc.utexas.edu> - * Iedline.scm ((make-edited-line-port)): + * Iedline.scm (make-edited-line-port): * edline.c (lreadline): Added Gnu `readline' input editing (get ftp.sys.toronto.edu:/pub/rc/editline.shar). @@ -3307,7 +4655,7 @@ Sat Feb 11 17:30:14 1995 Aubrey Jaffer (jaffer@jacal) (lexecp i_exec l_putenv): added. * posix.c (open_pipe l_open_input_pipe l_open_output_pipe - prinpipe): moved from ioext.c. + prinpipe): moved from ioext.c. (l_fork): added. Fri Feb 10 10:50:03 1995 Aubrey Jaffer (jaffer@jacal) @@ -4634,7 +5982,7 @@ Sun Oct 4 01:45:25 1992 Aubrey Jaffer (jaffer at camelot) optimizations for AND and OR. From: hugh@ear.MIT.EDU (Hugh Secker-Walker) - * eval.c repl.c scm.h (syntax_mem): syntax forms are now memoized + * eval.c repl.c scm.h (syntax_mem): syntax forms are now memoized so that syntax checks are done only once. Interpreter is now smaller and faster and uses less stack space. Modifications to code are now made under DEFER_INTS as they always should have @@ -4796,7 +6144,7 @@ Wed May 13 14:01:07 1992 Aubrey Jaffer (jaffer at Ivan) Tue May 12 15:36:17 1992 Aubrey Jaffer (jaffer at train) - * config.h sys.c (alloc_some_heap expmem): expmem captures + * config.h sys.c (alloc_some_heap expmem): expmem captures whether the INIT_HEAP_SIZE allocation was successful. If so, alloc_some_heap uses exponential heap allocation instead of HEAP_SEG_SIZE. @@ -5014,7 +6362,7 @@ Mon Feb 10 14:31:24 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c (alloc_some_heap): fixed bugs. One fix from bowles@is.s.u-tokyo.ac.jp. - * eval.c (ceval): fixed bug with internal (define foo bar) where + * eval.c (ceval): fixed bug with internal (define foo bar) where bar is a global. Put badfun2: back in for better error reporting. * patchlvl.h (PATCHLEVEL): 11 @@ -5035,7 +6383,7 @@ Fri Jan 17 16:36:07 1992 Aubrey Jaffer (jaffer at Ivan) sizet. init_storage no longer uses it. gc() now uses it instead of pointer to local. This fixes bug with gcc -O. - * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above + * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above fix. Thu Jan 16 22:33:00 1992 Aubrey Jaffer (jaffer at Ivan) @@ -5085,7 +6433,7 @@ Thu Dec 19 19:16:50 1991 Aubrey Jaffer (jaffer at train) * makefile.unix (subr.o): explicit compilation line added. - * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries. + * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries. Sun Dec 8 23:31:04 1991 Aubrey Jaffer (jaffer at Ivan) diff --git a/Iedline.scm b/Iedline.scm index 8c076a0..1d49559 100644 --- a/Iedline.scm +++ b/Iedline.scm @@ -15,26 +15,26 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. diff --git a/Init5d2.scm b/Init5d6.scm index 19c2ff2..a847689 100644 --- a/Init5d2.scm +++ b/Init5d6.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1991-1999 Free Software Foundation, Inc. +;; Copyright (C) 1991-2002 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -15,26 +15,26 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. @@ -42,7 +42,7 @@ ;;; Author: Aubrey Jaffer. (define (scheme-implementation-type) 'SCM) -(define (scheme-implementation-version) "5d2") +(define (scheme-implementation-version) "5d6") (define (scheme-implementation-home-page) "http://swissnet.ai.mit.edu/~jaffer/SCM.html") @@ -53,7 +53,7 @@ ((MACOS THINKC) '(#\:)) ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT) '(#\/)) + ((UNIX COHERENT PLAN9) '(#\/)) ((VMS) '(#\: #\]))))) (lambda (chr) (memv chr suffi)))) @@ -76,64 +76,19 @@ (define in-vicinity string-append) -;;; This is the vicinity where this file resides. -(define implementation-vicinity #f) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use -;;; (implementation-vicinity) as (library-vicinity). "require.scm", -;;; the first file loaded from (library-vicinity), can redirect it. - -(define library-vicinity #f) -(define home-vicinity #f) -(define (set-vicinities! init-file) - (set! implementation-vicinity - (let ((vic (pathname->vicinity init-file))) - (lambda () vic))) - (set! library-vicinity - (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) - (if library-path - (lambda () library-path) - (lambda () - (let ((olv library-vicinity) - (oload load)) - (dynamic-wind - (lambda () (set! load identity)) - (lambda () - (try-load (in-vicinity (implementation-vicinity) - "require.scm"))) - (lambda () (set! load oload))) - (if (eq? olv library-vicinity) - (error "Can't find library-vicinity")) - (library-vicinity)))))) - (set! home-vicinity - (let ((home (getenv "HOME"))) - (and home - (case (software-type) - ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME - (if (not - (char=? #\/ - (string-ref home (+ -1 (string-length home))))) - (set! home (string-append home "/")))))) - (lambda () home)))) -(set-vicinities! *load-pathname*) - -;;; Here for backward compatability -(define scheme-file-suffix - (case (software-type) - ((NOSVE) (lambda () "_scm")) - (else (lambda () ".scm")))) - (set! *features* - (append '(getenv tmpnam abort transcript with-file - ieee-p1178 rev4-report rev4-optional-procedures - hash object-hash delay dynamic-wind fluid-let - multiarg-apply multiarg/and- logical defmacro - string-port source current-time sharp:semi) + (append '(ed getenv tmpnam abort transcript with-file + ieee-p1178 rev4-report rev4-optional-procedures + hash object-hash delay dynamic-wind fluid-let + multiarg-apply multiarg/and- logical defmacro + string-port source current-time sharp:semi) *features*)) +(define eval + (let ((@eval @eval) + (@copy-tree @copy-tree)) + (lambda (x) (@eval (@copy-tree x))))) + (define (exec-self) (require 'i/o-extensions) (execv (execpath) (if *script* @@ -142,58 +97,76 @@ (member *script* (program-arguments)))) (program-arguments)))) -(define (display-file file) +(define (display-file file . port) (call-with-input-file file (lambda (inport) (do ((c (read-char inport) (read-char inport))) ((eof-object? c)) - (write-char c))))) + (apply write-char c port))))) (define (terms) - (display-file "/usr/doc/copyright/GPL")) + (display-file (in-vicinity (implementation-vicinity) "COPYING"))) -;; Array syntax: -;; n is a decimal number, which may be elided for a default value of 1. -;; #nA\( ... ) character array -;; #nAt( ... ) boolean array -;; #nAe[sfdl]( ... ) exact number array -;; #nAu[sfdl]( ... ) positive exact number array -;; #nAi[sfdl]( ... ) inexact real number array -;; #nAic[sfdl]( ... ) inexact complex number array +(define (read:try-number port . ic) + (define chr0 (char->integer #\0)) + (let loop ((arg (and (not (null? ic)) (- (char->integer (car ic)) chr0)))) + (let ((c (peek-char port))) + (cond ((eof-object? c) #f) + ((char-numeric? c) + (loop (+ (* 10 (or arg 0)) + (- (char->integer (read-char port)) chr0)))) + (else arg))))) (define (read:array rank port) - (let ((prot + (define (bomb pc wid) + (error (string-append "array syntax? #" + (number->string rank) + "A" (string pc) + (if wid (number->string wid) "")))) + (list->uniform-array + rank + (case (char-downcase (peek-char port)) + ((#\\) (read-char port) #\a) + ((#\t) (read-char port) #t) + ((#\c #\r) + (let* ((pc (read-char port)) + (wid (read:try-number port))) + (case wid + ((64 32) (case pc + ((#\c) (* +i wid)) + (else (exact->inexact wid)))) + (else (bomb pc wid))))) + ((#\s #\u) + (let* ((pc (read-char port)) + (wid (read:try-number port))) + (case (or wid (peek-char port)) + ((32 16 8) (case pc + ((#\s) (- wid)) + (else wid))) + ((#\s #\f #\d #\l) (read-char port) 32) + ((#\() 32) ;legacy + (else (bomb pc wid))))) + ((#\e) ;legacy + (read-char port) + (case (char-downcase (peek-char port)) + ((#\s) (read-char port) -16) + ((#\f #\d #\l) (read-char port) -32) + (else -32))) + ((#\i) ;legacy + (read-char port) + (case (char-downcase (peek-char port)) + ((#\c) + (read-char port) (case (char-downcase (peek-char port)) - ((#\\) (read-char port) #\a) - ((#\t) (read-char port) #t) - ((#\e) - (read-char port) - (case (char-downcase (peek-char port)) - ((#\s) (read-char port) 'exact-short) - ((#\f #\d #\l) (read-char port) -2) - (else -2))) - ((#\u) - (read-char port) - (case (char-downcase (peek-char port)) - ((#\s #\f #\d #\l) (read-char port) 2) - (else 2))) - ((#\i) - (read-char port) - (case (char-downcase (peek-char port)) - ((#\c) - (read-char port) - (case (char-downcase (peek-char port)) - ((#\s #\f #\d #\l) (read-char port))) - 0+1.0i) - ((#\s #\f) (read-char port) 1.0) - ((#\d #\l) (read-char port) 1/3) - (else 1/3))) - (else #f)))) - (list->uniform-array rank prot (read port)))) + ((#\s #\f #\d #\l) (read-char port))) + +64i) + ((#\s #\f) (read-char port) 32.0) + ((#\d #\l) (read-char port) 64.0) + (else (bomb (read-char port) #f)))) + (else #f)) + (read port))) (define (read:sharp c port) - (define (barf c) - (error "unknown # object" c)) - (define chr0 (char->integer #\0)) + (define (barf c) (error "unknown # object" c)) (define (feature? exp) (cond ((symbol? exp) (or (memq exp *features*) (eq? exp (software-type)))) @@ -218,60 +191,52 @@ (begin (read port) (if #f #f)))) ((#\a #\A) (read:array 1 port)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (let loop ((arg (- (char->integer c) chr0))) - (let ((c (peek-char port))) - (cond ((char-numeric? c) - (loop (+ (* 10 arg) - (- (char->integer (read-char port)) chr0)))) - ((memv c '(#\a #\A)) - (read-char port) - (read:array arg port)) - (else - (warn "obsolete array read syntax") - (read:array arg port)))))) - ((#\!) (if (= 1 (line-number)) - (let skip ((metarg? #f)) - (case (read-char port) - ((#\newline) (if metarg? (skip #t))) - ((#\\) (skip #t)) - ((#\!) (if (not (and (eqv? #\# (peek-char port)) - (read-char port))) - (skip metarg?))) - (else (skip metarg?)))) - (barf c))) + (let* ((num (read:try-number port c)) + (c (peek-char port))) + (cond ((memv c '(#\a #\A)) (read-char port) (read:array num port)) + (else (error "syntax? #" num c))))) + ((#\!) (let skip ((metarg? #f)) + (let ((c (read-char port))) + (case c + ((#\newline) (if metarg? (skip #t))) + ((#\\) (skip #t)) + ((#\!) (cond ((eqv? #\# (peek-char port)) + (read-char port) + (if #f #f)) + (else (skip metarg?)))) + (else (if (char? c) (skip metarg?) c)))))) + ((#\?) (case (read port) + ((line) (port-line port)) + ((column) (port-column port)) + ((file) (port-filename port)) + (else #f))) (else (barf c)))) -;; We can assume TOK has at least 2 characters. +;;; We can assume TOK has at least 2 characters. (define read:sharp-char - (letrec ((control (lambda (c) - (and (char? c) - (if (eqv? c #\?) - (integer->char 127) - (integer->char - (logand 31 (char->integer c))))))) - (meta (lambda (c) - (and (char? c) - (integer->char - (logior 128 (char->integer c))))))) + (letrec ((process + (lambda (modifier tok) + (and (char=? #\- (string-ref tok 1)) + (if (= 3 (string-length tok)) + (modifier (string-ref tok 2)) + (let ((c (read:sharp-char + (substring tok 2 (string-length tok))))) + (and c (modifier c))))))) + (control + (lambda (c) + (and (char? c) + (if (eqv? c #\?) + (integer->char 127) + (integer->char (logand #o237 (char->integer c))))))) + (meta + (lambda (c) + (and (char? c) + (integer->char (logior 128 (char->integer c))))))) (lambda (tok) (case (string-ref tok 0) - ((#\C #\c) - (and (char=? #\- (string-ref tok 1)) - (if (= 3 (string-length tok)) - (control (string-ref tok 2)) - (let ((c (read:sharp-char - (substring tok 2 (string-length tok))))) - (and c (control c)))))) - ((#\^) - (and (= 2 (string-length tok)) - (control (string-ref tok 1)))) - ((#\M #\m) - (and (char=? #\- (string-ref tok 1)) - (if (= 3 (string-length tok)) - (meta (string-ref tok 2)) - (let ((c (read:sharp-char - (substring tok 2 (string-length tok))))) - (and c (meta c)))))))))) + ((#\C #\c) (process control tok)) + ((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1)))) + ((#\M #\m) (process meta tok)))))) ;;;; Function used to accumulate comments before a definition. (define comment @@ -290,8 +255,9 @@ (else (set! *accumulated-comments* (append (reverse args) *accumulated-comments*))))))) -;; Make #; convert the rest of the line to a (comment ...) form. -;; "build.scm" uses this. +;;; Make #; convert the rest of the line to a (comment ...) form. +;;; "build.scm" uses this. +;;; requires line-i/o (define read:sharp (let ((rdsharp read:sharp)) (lambda (c port) @@ -309,12 +275,8 @@ (define !#(if #f #f)) ;for scsh hack. ;;;; Here are some Revised^2 Scheme functions: -(define 1+ - (let ((+ +)) - (lambda (n) (+ n 1)))) -(define -1+ - (let ((+ +)) - (lambda (n) (+ n -1)))) +(define 1+ (let ((+ +)) (lambda (n) (+ n 1)))) +(define -1+ (let ((+ +)) (lambda (n) (+ n -1)))) (define 1- -1+) (define <? <) (define <=? <=) @@ -323,12 +285,14 @@ (define >=? >=) (define t #t) (define nil #f) -(define identity - (if (defined? cr) cr (lambda (x) x))) - -(if (not (defined? the-macro)) - (define the-macro identity)) -(define sequence (the-macro begin)) +(define identity cr) + +(cond ((defined? defsyntax) +(defsyntax define-syntax (the-macro defsyntax))) + (else +(define defsyntax define) +(define the-macro identity))) +(defsyntax sequence (the-macro begin)) (define copy-tree @copy-tree) ;;; VMS does something strange when output is sent to both @@ -340,44 +304,82 @@ ;;; translation if not opened in `b' mode. (define OPEN_READ (case (software-type) - ((MS-DOS WINDOWS ATARIST) "rb") - (else "r"))) + ((MS-DOS WINDOWS ATARIST) 'rb) + (else 'r))) (define OPEN_WRITE (case (software-type) - ((MS-DOS WINDOWS ATARIST) "wb") - (else "w"))) + ((MS-DOS WINDOWS) 'wbc) + ((ATARIST) 'wb) + (else 'w))) (define OPEN_BOTH (case (software-type) - ((MS-DOS WINDOWS ATARIST) "r+b") - (else "r+"))) -(define (_IONBF mode) (string-append mode "0")) -(define (_TRACKED mode) (string-append mode "?")) + ((MS-DOS WINDOWS) 'r+bc) + ((ATARIST) 'r+b) + (else 'r+))) +(define ((make-moder str) mode) + (if (symbol? mode) + (string->symbol (string-append (symbol->string mode) str)) + (string-append mode str))) +(define _IONBF (make-moder "0")) +(define _TRACKED (make-moder "?")) +(define _EXCLUSIVE (make-moder "x")) (define could-not-open #f) -(define (open-input-file str) - (or (open-file str OPEN_READ) - (and (procedure? could-not-open) (could-not-open) #f) - (error "OPEN-INPUT-FILE couldn't open file " str))) (define (open-output-file str) (or (open-file str OPEN_WRITE) (and (procedure? could-not-open) (could-not-open) #f) (error "OPEN-OUTPUT-FILE couldn't open file " str))) -(define (open-io-file str) (open-file str OPEN_BOTH)) +(define (open-input-file str) + (or (open-file str OPEN_READ) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))) + +(define (string-index str chr) + (define len (string-length str)) + (do ((pos 0 (+ 1 pos))) + ((or (>= pos len) (char=? chr (string-ref str pos))) + (and (< pos len) pos)))) + +(if (not (defined? try-create-file)) +(define (try-create-file str modes . perms) + (if (symbol? modes) (set! modes (symbol->string modes))) + (let ((idx (string-index modes #\x))) + (cond ((require:feature->path 'i/o-extensions) + (require 'i/o-extensions) + (apply try-create-file str modes perms)) + ((not idx) + (warn "not exclusive modes?" modes str) + (try-open-file str modes)) + (else (set! modes (string-append (substring modes 0 idx) + (substring modes (+ 1 idx) + (string-length modes)))) + (cond ((not (string-index modes #\w)) + (warn 'try-create-file "not writing?" modes str) + (try-open-file str modes)) + (else + (cond ((and (not (null? perms)) + (not (eqv? #o666 (car perms)))) + (warn "perms?" (car perms) str))) + (cond ((file-exists? str) #f) + (else (try-open-file str modes)))))))))) (define close-input-port close-port) (define close-output-port close-port) -(define close-io-port close-port) -(define (call-with-input-file str proc) - (let* ((file (open-input-file str)) - (ans (proc file))) - (close-input-port file) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) ans)) +(define (call-with-input-file str proc) + (call-with-open-ports (open-input-file str) proc)) + (define (call-with-output-file str proc) - (let* ((file (open-output-file str)) - (ans (proc file))) - (close-output-port file) - ans)) + (call-with-open-ports (open-output-file str) proc)) (define (with-input-from-port port thunk) (dynamic-wind (lambda () (set! port (set-current-input-port port))) @@ -412,8 +414,34 @@ (close-port nport) ans)) +(define (call-with-outputs thunk proc) + (define stdout #f) + (define stderr #f) + (define status #f) + (set! stdout + (call-with-output-string + (lambda (stdout) + (set! stderr + (call-with-output-string + (lambda (stderr) + (call-with-current-continuation + (lambda (escape) + (dynamic-wind + (lambda () + (set! status #f) + (set! stdout (set-current-output-port stdout)) + (set! stderr (set-current-error-port stderr))) + (lambda () (set! status (list (thunk)))) + (lambda () + (set! stdout (set-current-output-port stdout)) + (set! stderr (set-current-error-port stderr)) + (if (not status) (escape #f)))))))))))) + (apply proc stdout stderr (or status '()))) + (define (warn . args) (define cep (current-error-port)) + (if (defined? print-call-stack) + (print-call-stack cep)) (perror "WARN") (errno 0) (display "WARN: " cep) @@ -426,6 +454,8 @@ (define (error . args) (define cep (current-error-port)) + (if (defined? print-call-stack) + (print-call-stack cep)) (perror "ERROR") (errno 0) (display "ERROR: " cep) @@ -446,15 +476,22 @@ (for-each (lambda (x) (set! result x) (write x) (display #\ )) args) (newline) result) +(define (pprint . args) + (define result #f) + (for-each (lambda (x) (set! result x) (pretty-print x)) args) + result) (define (pp . args) (for-each pretty-print args) (if #f #f)) +(if (not (defined? file-exists?)) (define (file-exists? str) (let ((port (open-file str OPEN_READ))) - (and port (close-port port) #t))) + (errno 0) + (and port (close-port port) #t)))) (define (file-readable? str) (let ((port (open-file str OPEN_READ))) + (errno 0) (and port (char-ready? port) (do ((c (read-char port) @@ -467,22 +504,20 @@ (define difftime -) (define offset-time +) -(if (not (memq 'ed *features*)) - (begin - (define (ed . args) - (system (apply string-append - (or (getenv "EDITOR") "editor") - (map (lambda (s) (string-append " " s)) args)))) - (set! *features* (cons 'ed *features*)))) +(if (not (defined? ed)) +(define (ed . args) + (system (apply string-append + (or (getenv "EDITOR") "ed") + (map (lambda (s) (string-append " " s)) args))))) (if (not (defined? output-port-width)) - (define (output-port-width . arg) 80)) +(define (output-port-width . arg) 80)) (if (not (defined? output-port-height)) - (define (output-port-height . arg) 24)) +(define (output-port-height . arg) 24)) (if (not (defined? last-pair)) - (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))) +(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))) (define slib:error error) (define slib:warn warn) @@ -490,7 +525,9 @@ (define slib:form-feed #\page) (define slib:eval eval) -;;; Load. +(define (make-exchanger . pair) (lambda (rep) (swap-car! pair rep))) + +;;;; Load. (define load:indent 0) (define (load:pre file) (define cep (current-error-port)) @@ -513,12 +550,19 @@ (newline cep) (force-output cep)))) +;;; Here for backward compatibility +(define scheme-file-suffix + (case (software-type) + ((NOSVE) (lambda () "_scm")) + (else (lambda () ".scm")))) + (define (has-suffix? str suffix) (let ((sufl (string-length suffix)) (sl (string-length str))) (and (> sl sufl) (string=? (substring str (- sl sufl) sl) suffix)))) +(define *load-reader* #f) (define (scm:load file . libs) (define filesuf file) (define hss (has-suffix? file (scheme-file-suffix))) @@ -531,11 +575,11 @@ (fs2 (file-readable? fs))) (and fs2 (apply link:link fs libs) (set! filesuf fs) #t) )))) - (and (null? libs) (try-load file)) + (and (null? libs) (try-load file *load-reader*)) ;;HERE is where the suffix gets specified (and (not hss) (errno 0) ; clean up error from TRY-LOAD above (set! filesuf (string-append file (scheme-file-suffix))) - (try-load filesuf)) + (try-load filesuf *load-reader*)) (and (procedure? could-not-open) (could-not-open) #f) (begin (set! load:indent 0) (error "LOAD couldn't find file " file))) @@ -547,88 +591,335 @@ (define sfs (scheme-file-suffix)) (define filesuf file) (load:pre file) - (or (and (or (try-load file) + (or (and (or (try-load file *load-reader*) ;;HERE is where the suffix gets specified (and (not (has-suffix? file sfs)) (begin (set! filesuf (string-append file sfs)) - (try-load filesuf))))) + (try-load filesuf *load-reader*))))) (and (procedure? could-not-open) (could-not-open) #f) (error "LOAD couldn't find file " file)) (load:post filesuf)) (define slib:load-source scm:load-source) +;;; This is the vicinity where this file resides. +(define implementation-vicinity #f) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. +(define library-vicinity #f) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. +(define home-vicinity #f) + +(define (login->home-directory login) + (cond ((defined? getpw) + (let ((pwvect (getpw login))) + (and pwvect (vector-ref pwvect 5)))) + ((not (file-exists? "/etc/passwd")) #f) + (else + (call-with-input-file "/etc/passwd" + (lambda (iprt) + (require 'string-search) + (require 'line-i/o) + (let tryline () + (define line (read-line iprt)) + (define (get-field) + (define idx (string-index line #\:)) + (and idx + (let ((fld (substring line 0 idx))) + (set! line (substring line (+ 1 idx) + (string-length line))) + fld))) + (cond ((eof-object? line) #f) + ((string-index line #\:) + => (lambda (idx) + (define name (substring line 0 idx)) + (cond ((equal? login name) + (do ((ans (get-field) (get-field)) + (cnt 4 (+ -1 cnt))) + ((or (negative? cnt) (not ans)) ans))) + (else (tryline)))))))))))) + +(if (not (defined? getlogin)) +(define (getlogin) (or (getenv "USER") (getenv "LOGNAME")))) + +;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use +;;; (implementation-vicinity) as (library-vicinity). "require.scm", +;;; the first file loaded from (library-vicinity), can redirect it. +(define (set-vicinities! init-file) + (set! implementation-vicinity + (let ((vic (pathname->vicinity init-file))) + (lambda () vic))) + (set! library-vicinity + (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) + (if library-path + (lambda () library-path) + (lambda () + (let ((olv library-vicinity) + (oload load)) + (dynamic-wind + (lambda () (set! load identity)) + (lambda () + (let ((filename (in-vicinity (implementation-vicinity) + "require.scm"))) + (or (try-load filename) + (try-load (in-vicinity (implementation-vicinity) + "requires.scm")) + (error "Can't load" filename)))) + (lambda () (set! load oload))) + (if (eq? olv library-vicinity) + (error "Can't find library-vicinity")) + (library-vicinity)))))) + (set! home-vicinity + (let ((home (getenv "HOME"))) + (and (not home) login->home-directory + (let ((login (getlogin))) + (and login (set! home (login->home-directory login))))) + (and home + (case (software-type) + ((UNIX COHERENT PLAN9 MS-DOS) ;V7 unix has a / on HOME + (if (not + (eqv? #\/ (string-ref home (+ -1 (string-length home))))) + (set! home (string-append home "/")))))) + (lambda () home)))) +;;; SET-VICINITIES! is also called from BOOT-TAIL +(set-vicinities! *load-pathname*) + +;;;; Initialize SLIB (load (in-vicinity (library-vicinity) "require")) -;;; DO NOT MOVE! This must be done after "require.scm" is loaded. -(define slib:load-source scm:load-source) -(define slib:load scm:load) +;;; This turns off line-numbering off for SLIB loads. +(define *slib-load-reader* (and (defined? read-numbered) read-numbered)) + +;;; DO NOT MOVE! SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after +;;; "require.scm" is loaded. +(define (slib:load-source file . libs) + (fluid-let ((*load-reader* *slib-load-reader*)) + (apply scm:load file libs))) +(define (slib:load file . libs) + (fluid-let ((*load-reader* *slib-load-reader*)) + (apply scm:load file libs))) +;;; Dynamic link-loading (cond ((or (defined? dyn:link) - (defined? vms:dynamic-link-call) - (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms"))) + (defined? vms:dynamic-link-call)) (load (in-vicinity (implementation-vicinity) "Link")))) (cond ((defined? link:link) - (define (slib:load-compiled . args) - (or (apply link:link args) - (error "Couldn't link files " args))) - (provide 'compiled))) - +(define (slib:load-compiled . args) + (cond ((symbol? (car args)) + (require:require (car args)) + (apply slib:load-compiled (cdr args))) + ((apply link:link args)) + (else (error "Couldn't link files " args)))) +(provide 'compiled))) + +;;; Complete the function set for feature STRING-CASE. +(cond + ((defined? string-upcase!) (define (string-upcase str) (string-upcase! (string-copy str))) (define (string-downcase str) (string-downcase! (string-copy str))) (define (string-capitalize str) (string-capitalize! (string-copy str))) (define string-ci->symbol - (if (equal? "a" (symbol->string 'a)) - (lambda (str) (string->symbol (string-downcase str))) - (lambda (str) (string->symbol (string-upcase str))))) - -(define logical:logand logand) -(define logical:logior logior) -(define logical:logxor logxor) -(define logical:lognot lognot) -(define logical:ash ash) -(define logical:logcount logcount) -(define logical:integer-length integer-length) -(define logical:integer-expt integer-expt) - -(define logical:bit-field bit-field) -(define bit-extract bit-field) -(define logical:bitwise-if bitwise-if) -(define logical:copy-bit copy-bit) -(define logical:copy-bit-field copy-bit-field) - -(define (logical:ipow-by-squaring x k acc proc) - (cond ((zero? k) acc) - ((= 1 k) (proc acc x)) - (else (logical:ipow-by-squaring (proc x x) - (quotient k 2) - (if (even? k) acc (proc acc x)) - proc)))) - -;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer): + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda (str) (string->symbol (s2cis str))))) +(define symbol-append + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda args + (string->symbol + (apply string-append + (map + (lambda (obj) + (cond ((string? obj) (s2cis obj)) + ((number? obj) (s2cis (number->string obj))) + ((symbol? obj) (symbol->string obj)) + ((not obj) "") + (else (slib:error 'wrong-type-to 'symbol-append obj)))) + args)))))) +(define (StudlyCapsExpand nstr . delimitr) + (set! delimitr + (cond ((null? delimitr) "-") + ((char? (car delimitr)) (string (car delimitr))) + (else (car delimitr)))) + (do ((idx (+ -1 (string-length nstr)) (+ -1 idx))) + ((> 1 idx) nstr) + (cond ((and (> idx 1) + (char-upper-case? (string-ref nstr (+ -1 idx))) + (char-lower-case? (string-ref nstr idx))) + (set! nstr + (string-append (substring nstr 0 (+ -1 idx)) + delimitr + (substring nstr (+ -1 idx) + (string-length nstr))))) + ((and (char-lower-case? (string-ref nstr (+ -1 idx))) + (char-upper-case? (string-ref nstr idx))) + (set! nstr + (string-append (substring nstr 0 idx) + delimitr + (substring nstr idx + (string-length nstr)))))))) +(provide 'string-case))) + +;;;; Bit order and lamination + +(define (bit-reverse k n) + (do ((m (if (negative? n) (lognot n) n) (ash m -1)) + (k (+ -1 k) (+ -1 k)) + (rvs 0 (logior (ash rvs 1) (logand 1 m)))) + ((negative? k) (if (negative? n) (lognot rvs) rvs)))) + +(define (integer->list k . len) + (if (null? len) + (do ((k k (ash k -1)) + (lst '() (cons (odd? k) lst))) + ((<= k 0) lst)) + (do ((idx (+ -1 (car len)) (+ -1 idx)) + (k k (ash k -1)) + (lst '() (cons (odd? k) lst))) + ((negative? idx) lst)))) + +(define (list->integer bools) + (do ((bs bools (cdr bs)) + (acc 0 (+ acc acc (if (car bs) 1 0)))) + ((null? bs) acc))) +(define (booleans->integer . bools) + (list->integer bools)) + +(define (bitwise:laminate . ks) + (define nks (length ks)) + (define nbs (apply max (map integer-length ks))) + (do ((kdx (+ -1 nbs) (+ -1 kdx)) + (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks)) + (ash ibs nks)))) + ((negative? kdx) ibs))) + +(define (bitwise:delaminate count k) + (define nbs (* count (+ 1 (quotient (integer-length k) count)))) + (do ((kdx (- nbs count) (- kdx count)) + (lst (vector->list (make-vector count 0)) + (map (lambda (k bool) (+ (if bool 1 0) (ash k 1))) + lst + (integer->list (ash k (- kdx)) count)))) + ((negative? kdx) lst))) + +;;;; Gray-code + +(define (integer->gray-code k) + (logxor k (ash k -1))) + +(define (gray-code->integer k) + (if (negative? k) + (error 'gray-code->integer 'negative? k) + (do ((ktmp k (ash ktmp -1)) + (ans 0 (logxor ans ktmp))) + ((zero? ktmp) ans)))) + +(define (grayter k1 k2) + (define kl1 (integer-length k1)) + (define kl2 (integer-length k2)) + (cond ((eqv? kl1 kl2) (> (gray-code->integer k1) (gray-code->integer k2))) + (else (> kl1 kl2)))) + +(define (gray-code<? k1 k2) + (not (or (eqv? k1 k2) (grayter k1 k2)))) +(define (gray-code<=? k1 k2) + (or (eqv? k1 k2) (not (grayter k1 k2)))) +(define (gray-code>? k1 k2) + (and (not (eqv? k1 k2)) (grayter k1 k2))) +(define (gray-code>=? k1 k2) + (or (eqv? k1 k2) (grayter k1 k2))) + +(define @case-aux + (let ((integer-jump-table 1) + (char-jump-table 2)) + (lambda (keys actions else-action) + (let ((n (length keys))) + (define (every-key pred) + (let test ((keys keys)) + (or (null? keys) + (and (pred (car keys)) (test (cdr keys)))))) + (define (jump-table keys) + (let ((minkey (apply min keys)) + (maxkey (apply max keys))) + (and (< (- maxkey minkey) (* 4 n)) + (let ((actv (make-vector + (+ 2 (- maxkey minkey)) else-action))) + (for-each + (lambda (key action) + (vector-set! actv (+ 1 (- key minkey)) action)) + keys actions) + (list integer-jump-table minkey actv))))) + (cond ((< n 5) #f) + ((every-key integer?) + (jump-table keys)) + ((every-key char?) + (let* ((int-keys (map char->integer keys))) + (cond ((jump-table int-keys) => + (lambda (x) + (cons char-jump-table + (cons (integer->char (cadr x)) + (cddr x))))) + (else #f))))))))) + +;;;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer): (define *defmacros* '()) (define (defmacro? m) (and (assq m *defmacros*) #t)) (define defmacro:transformer (lambda (f) (procedure->memoizing-macro - (lambda (exp env) - (@copy-tree (apply f (cdr exp))))))) - -(define defmacro + (lambda (exp env) + (@copy-tree (apply f (remove-line-numbers! (cdr exp)))))))) + +(define defmacro:get-destructuring-bind-pairs + (lambda (s e) + (let loop ((s s) (e e) (r '())) + (cond ((pair? s) + (loop (car s) `(car ,e) + (loop (cdr s) `(cdr ,e) r))) + ((null? s) r) + ((symbol? s) (cons `(,s ,e) r)) + (else (error 'destructuring-bind "illegal syntax")))))) + +(defsyntax destructuring-bind + (let ((destructuring-bind-transformer + (lambda (s x . ff) + (let ((tmp (gentemp))) + `(let ((,tmp ,x)) + (let ,(defmacro:get-destructuring-bind-pairs s tmp) + ,@ff)))))) + (set! *defmacros* + (acons 'destructuring-bind + destructuring-bind-transformer *defmacros*)) + (defmacro:transformer destructuring-bind-transformer))) + +(defsyntax defmacro:simple-defmacro (let ((defmacro-transformer (lambda (name parms . body) - `(define ,name + `(defsyntax ,name (let ((transformer (lambda ,parms ,@body))) (set! *defmacros* (acons ',name transformer *defmacros*)) (defmacro:transformer transformer)))))) (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*)) (defmacro:transformer defmacro-transformer))) +(defmacro:simple-defmacro defmacro (name . body) + (define (expn name pattern body) + (let ((args (gentemp))) + `(defmacro:simple-defmacro ,name ,args + (destructuring-bind ,pattern ,args ,@body)))) + (if (pair? name) + (expn (car name) (cdr name) body) + (expn name (car body) (cdr body)))) + (define (macroexpand-1 e) (if (pair? e) (let ((a (car e))) (cond ((symbol? a) (set! a (assq a *defmacros*)) - (if a (apply (cdr a) (cdr e)) e)) + (if a (apply (cdr a) (cdr e)) e)) (else e))) e)) @@ -662,15 +953,15 @@ (evl o)) (set! *load-pathname* old-load-pathname))))) -;;; Autoloads for SLIB procedures. +;;;; Autoloads for SLIB procedures. -(define (tracef . args) (require 'trace) (apply tracef args)) -(define (trace:tracef . args) (require 'trace) (apply trace:tracef args)) (define (trace-all . args) (require 'debug) (apply trace-all args)) -(define (pretty-print . args) (require 'pretty-print) - (apply pretty-print args)) +(define (track-all . args) (require 'debug) (apply track-all args)) +(define (stack-all . args) (require 'debug) (apply stack-all args)) +(define (break-all . args) (require 'debug) (apply break-all args)) +(define (pretty-print . args) (require 'pretty-print) (apply pretty-print args)) -;; (require 'transcript) would get us SLIB transcript -- not what we want. +;;; (require 'transcript) would get us SLIB transcript -- not what we want. (define (transcript-on arg) (load (in-vicinity (implementation-vicinity) (string-append "Tscript" (scheme-file-suffix)))) @@ -678,15 +969,13 @@ (define (transcript-off) (error "No transcript active")) -;;; Macros. +;;;; Macros. -;;; Trace gets redefmacroed when tracef autoloads. -(defmacro trace x - (if (null? x) '() - `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x)))) -(defmacro break x - (if (null? x) '() - `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) x)))) +;;; Trace gets re-defmacroed when tracef autoloads. +(defmacro trace x (cond ((null? x) '()) (else (require 'trace) `(trace ,@x)))) +(defmacro track x (cond ((null? x) '()) (else (require 'track) `(track ,@x)))) +(defmacro stack x (cond ((null? x) '()) (else (require 'stack) `(stack ,@x)))) +(defmacro break x (cond ((null? x) '()) (else (require 'break) `(break ,@x)))) (defmacro defvar (var val) `(if (not (defined? ,var)) (define ,var ,val))) @@ -698,7 +987,7 @@ (else (slib:error 'trying-to-defconst name 'to-different-value value))) `(define ,name ,value)))) -(defmacro casev (key . clauses) +(defmacro qase (key . clauses) `(case ,key ,@(map (lambda (clause) (if (list? (car clause)) @@ -714,6 +1003,7 @@ (cdr clause)) clause)) clauses))) +(defmacro (casev . args) `(qase ,@args)) (defmacro fluid-let (clauses . body) (let ((ids (map car clauses)) @@ -751,30 +1041,35 @@ (cond ((defined? stack-trace) - #+breakpoint-error;; remove line to enable breakpointing on calls to ERROR - (define (error . args) - (define cep (current-error-port)) - (perror "ERROR") - (errno 0) - (display "ERROR: " cep) - (if (not (null? args)) - (begin (display (car args) cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) - (cdr args)))) - (newline cep) - (cond ((stack-trace) (newline cep))) - (display " * Breakpoint established: (continue <val>) to return." cep) - (newline cep) (force-output cep) - (require 'debug) (apply breakpoint args)) - - (define (user-interrupt . args) - (define cep (current-error-port)) - (newline cep) (display "ERROR: user interrupt" cep) - (newline cep) - (cond ((stack-trace) (newline cep))) - (display " * Breakpoint established: (continue <val>) to return." cep) - (newline cep) (force-output cep) - (require 'debug) (apply breakpoint args)) + ;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR +(define (error . args) + (define cep (current-error-port)) + (if (defined? print-call-stack) + (print-call-stack cep)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr args)))) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue <val>) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + +(define (user-interrupt . args) + (define cep (current-error-port)) + (newline cep) + (if (defined? print-call-stack) + (print-call-stack cep)) + (display "ERROR: user interrupt" cep) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue <val>) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) )) ;;; ABS and MAGNITUDE can be the same. @@ -787,30 +1082,48 @@ (set! abs magnitude))) (if (defined? array?) - (begin - (define uniform-vector? array?) - (define make-uniform-vector dimensions->uniform-array) -; (define uniform-vector-ref array-ref) - (define (uniform-vector-set! u i o) - (uniform-vector-set1! u o i)) -; (define uniform-vector-fill! array-fill!) -; (define uniform-vector-read! uniform-array-read!) -; (define uniform-vector-write uniform-array-write) - - (define (make-array fill . args) - (dimensions->uniform-array args () fill)) - (define (make-uniform-array prot . args) - (dimensions->uniform-array args prot)) - (define (list->array ndim lst) - (list->uniform-array ndim '() lst)) - (define (list->uniform-vector prot lst) - (list->uniform-array 1 prot lst)) - (define (array-shape a) - (let ((dims (array-dimensions a))) - (if (pair? dims) - (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) - dims) - dims))))) +(begin + +(define (array-null? array) + (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd))) + (array-shape array))))) +(define (create-array prot . args) + (if (array-null? prot) + (dimensions->uniform-array args (array-prototype prot)) + (dimensions->uniform-array args (array-prototype prot) + (apply array-ref prot + (map car (array-shape prot)))))) +(define (make-array initial-value . dimensions) + (apply create-array (vector initial-value) dimensions)) +(define (make-uniform-wrapper prot) + (if (string? prot) (set! prot (string->number prot))) + (if prot + (lambda opt (if (null? opt) + (list->uniform-array 1 prot '()) + (list->uniform-array 0 prot (car opt)))) + vector)) +(define Ac64 (make-uniform-wrapper "+64i")) +(define Ac32 (make-uniform-wrapper "+32i")) +(define Ar64 (make-uniform-wrapper "64.")) +(define Ar32 (make-uniform-wrapper "32.")) +(define As64 (make-uniform-wrapper -64)) +(define As32 (make-uniform-wrapper -32)) +(define As16 (make-uniform-wrapper -16)) +(define As8 (make-uniform-wrapper -8)) +(define Au64 (make-uniform-wrapper 64)) +(define Au32 (make-uniform-wrapper 32)) +(define Au16 (make-uniform-wrapper 16)) +(define Au8 (make-uniform-wrapper 8)) +(define At1 (make-uniform-wrapper #t)) + +(define (array-shape a) + (let ((dims (array-dimensions a))) + (if (pair? dims) + (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) + dims) + dims))) +(define array=? equal?) +)) (define (alarm-interrupt) (alarm 0)) (if (defined? setitimer) @@ -842,8 +1155,8 @@ ;;; if it wants to alter the arguments which BOOT-TAIL processes. (define *argv* #f) -(if (not (defined? *R4RS-macro*)) - (define *R4RS-macro* #f)) +(if (not (defined? *syntax-rules*)) + (define *syntax-rules* #f)) (if (not (defined? *interactive*)) (define *interactive* #f)) @@ -866,9 +1179,14 @@ (member "-no-init-file" (program-arguments)) (member "--no-init-file" (program-arguments)) (try-load (in-vicinity (or (home-vicinity) (user-vicinity)) - (string-append "ScmInit") (scheme-file-suffix))) + (string-append "ScmInit") (scheme-file-suffix)) + *load-reader*) (errno 0)) + ;; Include line numbers in loaded code. + (if (defined? read-numbered) + (set! *load-reader* read-numbered)) + (cond ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0))) (require 'getopt) @@ -877,12 +1195,12 @@ ;;; (define getopt:opt #f) ;;; (define (getopt argc argv optstring) #f)) - (let* ((simple-opts "muqvbis") - (arg-opts '("a kbytes" "no-init-file" "-no-init-file" - "-version" "-help" "p number" - "r feature" "f filename" "l filename" - "d filename" "c string" "e string" - "o filename")) + (let* ((simple-opts "muvqibs") + (arg-opts '("a kbytes" "-version" "-help" + "no-init-file" "-no-init-file" "p number" + "h feature" "r feature" "d filename" + "f filename" "l filename" + "c string" "e string" "o filename")) (opts (apply string-append ":" simple-opts (map (lambda (o) (string-append (string (string-ref o 0)) ":")) @@ -898,27 +1216,27 @@ (thunk) (let ((complete #f)) (dynamic-wind - (lambda () #f) - (lambda () - (thunk) - (set! complete #t)) - (lambda () - (if (not complete) (close-port (current-input-port)))))))) + (lambda () #f) + (lambda () + (thunk) + (set! complete #t)) + (lambda () + (if (not complete) (close-port (current-input-port)))))))) (define (do-string-arg) (require 'string-port) (do-thunk (lambda () - ((if *R4RS-macro* macro:eval eval) + ((if *syntax-rules* macro:eval eval) (call-with-input-string - (string-append "(begin " *optarg* ")") - read)))) + (string-append "(begin " *optarg* ")") + read)))) (set! didsomething #t)) (define (do-load file) (do-thunk (lambda () - (cond (*R4RS-macro* (require 'macro) (macro:load file)) + (cond (*syntax-rules* (require 'macro) (macro:load file)) (else (load file))))) (set! didsomething #t)) @@ -938,7 +1256,7 @@ (lambda (o) (display (string-append " [-" o "]") cep) (set! i (+ 1 i)) - (cond ((zero? (modulo i 4)) (newline cep) (display indent cep)))) + (cond ((zero? (modulo i 5)) (newline cep) (display indent cep)))) (cdr arg-opts)) (display " [-- | -s | -] [file] [args...]" cep) (newline cep) (if success? (display success? cep) (quit #f))) @@ -946,14 +1264,15 @@ ;; -a int => ignore (handled by scm_init_from_argv) ;; -c str => (eval str) ;; -e str => (eval str) - ;; -d str => (require 'database-utilities) (open-database str) + ;; -d str => (require 'databases) (open-database str) ;; -f str => (load str) ;; -l str => (load str) - ;; -r str => (require str) + ;; -r sym => (require sym) + ;; -h sym => (provide sym) ;; -o str => (dump str) ;; -p int => (verbose int) - ;; -m => (set! *R4RS-macro* #t) - ;; -u => (set! *R4RS-macro* #f) + ;; -m => (set! *syntax-rules* #t) + ;; -u => (set! *syntax-rules* #f) ;; -v => (verbose 3) ;; -q => (verbose 0) ;; -i => (set! *interactive* #t) @@ -977,46 +1296,44 @@ (string-append *optarg* "' unreasonable") #f)))) ((#\e #\c) (do-string-arg)) ;sh-like ((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*) - ((#\d) (require 'database-utilities) - (open-database *optarg*)) + ((#\d) (require 'databases) + (open-database *optarg*)) ((#\o) (require 'dump) - (if (< *optind* (length *argv*)) - (dump *optarg* #t) - (dump *optarg*))) + (if (< *optind* (length *argv*)) + (dump *optarg* #t) + (dump *optarg*))) ((#\r) (do-thunk (lambda () (if (and (= 1 (string-length *optarg*)) (char-numeric? (string-ref *optarg* 0))) (case (string-ref *optarg* 0) - ((#\2) (require 'rev3-procedures) - (require 'rev2-procedures)) - ((#\3) (require 'rev3-procedures)) - ((#\4) (require 'rev4-optional-procedures)) - ((#\5) (require 'values) - (require 'macro) - (require 'eval) - (set! *R4RS-macro* #t)) + ((#\2) (require 'r2rs)) + ((#\3) (require 'r3rs)) + ((#\4) (require 'r4rs)) + ((#\5) (require 'r5rs) + (set! *syntax-rules* #t)) (else (require (string->symbol *optarg*)))) (require (string->symbol *optarg*)))))) + ((#\h) (do-thunk (lambda () (provide (string->symbol *optarg*))))) ((#\p) (verbose (string->number *optarg*))) ((#\q) (verbose 0)) ((#\v) (verbose 3)) ((#\i) (set! *interactive* #t) ;sh-like - (verbose (max 2 (verbose)))) + (verbose (max 2 (verbose)))) ((#\b) (set! didsomething #t) - (set! *interactive* #f)) + (set! *interactive* #f)) ((#\s) (set! moreopts #f) ;sh-like - (set! didsomething #t) - (set! *interactive* #t)) - ((#\m) (set! *R4RS-macro* #t)) - ((#\u) (set! *R4RS-macro* #f)) + (set! didsomething #t) + (set! *interactive* #t)) + ((#\m) (set! *syntax-rules* #t)) + ((#\u) (set! *syntax-rules* #f)) ((#\n) (if (not (string=? "o-init-file" *optarg*)) (usage "scm: unrecognized option `-n" *optarg* "'" #f))) ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f)) ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f)) ((#f) (set! moreopts #f) ;sh-like - (cond ((and (< *optind* (length *argv*)) - (string=? "-" (list-ref *argv* *optind*))) - (set! *optind* (+ 1 *optind*))))) + (cond ((and (< *optind* (length *argv*)) + (string=? "-" (list-ref *argv* *optind*))) + (set! *optind* (+ 1 *optind*))))) (else (or (cond ((not (string? option)) #f) ((string-ci=? "no-init-file" option)) @@ -1076,7 +1393,7 @@ There is no warranty, to the extent permitted by law. (set! *interactive* #t))))) (cond ((not *interactive*) (quit)) - ((and *R4RS-macro* (not (provided? 'macro))) + ((and *syntax-rules* (not (provided? 'macro))) (require 'repl) (require 'macro) (let* ((oquit quit)) @@ -1,4 +1,4 @@ -;; Copyright (C) 1993, 1994, 1995, 1997, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1994, 1995, 1997, 1998, 2002 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -15,160 +15,114 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. -;;;; "Link.scm", Compiling and dynamic linking code for SCM. +;;;; "Link.scm", Dynamic linking/loading code for SCM. ;;; Author: Aubrey Jaffer. -;;; This is an unusual autoload because it should load either the -;;; source or compiled version if present. -(if (not (defined? hobbit)) ;Autoload for hobbit - (define (hobbit . args) - (require 'hobbit) - (apply hobbit args))) - -(define (compile-file file . args) - (apply hobbit file args) - (load (in-vicinity (implementation-vicinity) "build")) - (build-from-whole-argv - (list "build" "-tdll" - (string-append "--compiler-options=-I" (implementation-vicinity)) - "-c" - (begin (require 'glob) - ((filename:substitute?? (scheme-file-suffix) ".c") file)) - "-hsystem" - ))) - -(define link-named-scm - (let ((scm:object-suffix (case (software-type) - ((MSDOS VMS) ".obj") - (else ".o")))) - (lambda (name . modules) - (load (in-vicinity (implementation-vicinity) "build")) - (let* ((iv (implementation-vicinity)) - (oss (string-append scm:object-suffix " ")) - (command - (append - (list "build" "--type=exe" "-cscm.c" "-hsystem" - ;; "-F" "compiled-closure" "inexact" - (string-append "--linker-options=-L" - (implementation-vicinity))) - (map (lambda (n) (string-append "-iinit_" n)) modules) - (list - (apply string-append - "-j" - (map (lambda (n) - (string-append n oss)) modules)) - "-o" name)))) - (cond ((>= (verbose) 3) - (write command) (newline))) - (build-from-whole-argv command))))) - -;;;; Dynamic linking/loading - (cond ((defined? dyn:link) - (define link:modules '()) - (define link:able-suffix - (cond ((provided? 'shl) ".sl") - ((provided? 'sun-dl) ".so") - ((provided? 'mac-dl) ".shlb") - (else ".o"))) - (define link:link - (lambda (file . libs) - (define oloadpath *load-pathname*) - (let* ((sl (string-length file)) - (lasl (string-length link:able-suffix)) - (fname (let loop ((i (- sl 1))) - (cond ((negative? i) file) - ((vicinity:suffix? (string-ref file i)) - (substring file (+ i 1) sl)) - (else (loop (- i 1)))))) - (nsl (string-length fname)) - (name (cond ((< nsl lasl) fname) - ((string-ci=? (substring fname (- nsl lasl) nsl) - link:able-suffix) - (substring fname 0 (- nsl lasl))) - (else fname))) - (linkobj #f)) - (set! *load-pathname* file) - (set! linkobj (assoc name link:modules)) - (cond (linkobj (dyn:unlink (cdr linkobj)))) - (if (and (provided? 'sun-dl) - (> 3 (string-length file)) - (not (eqv? (string-ref file 0) '#\/))) - (set! file (string-append "./" file))) - (set! linkobj (dyn:link file)) - (for-each (lambda (lib) - (cond ((dyn:link lib)) - (else (slib:error "couldn't link: " lib)))) - libs) - (cond ((not linkobj) - (set! *load-pathname* oloadpath) #f) - ((dyn:call - (string-append - "init_" (list->string (map char-downcase (string->list name)))) - linkobj) - (set! link:modules (acons name linkobj link:modules)) - (set! *load-pathname* oloadpath) #t) - (else - (dyn:unlink linkobj) - (set! *load-pathname* oloadpath) #f))))))) +(define link:able-suffix + (cond ((provided? 'shl) ".sl") + ((provided? 'sun-dl) ".so") + ((provided? 'mac-dl) ".shlb") + (else ".o"))) +(define (file->init_name name) + (string-append + "init_" + (list->string + (map (lambda (chr) (if (eqv? #\- chr) #\_ chr)) + (map char-downcase (string->list name)))))) +(define link:link + (lambda (file . libs) + (define oloadpath *load-pathname*) + (let* ((sl (string-length file)) + (lasl (string-length link:able-suffix)) + (fname (let loop ((i (- sl 1))) + (cond ((negative? i) file) + ((vicinity:suffix? (string-ref file i)) + (substring file (+ i 1) sl)) + (else (loop (- i 1)))))) + (nsl (string-length fname)) + (name (cond ((< nsl lasl) fname) + ((string-ci=? (substring fname (- nsl lasl) nsl) + link:able-suffix) + (substring fname 0 (- nsl lasl))) + (else fname))) + (linkobj #f)) + (set! *load-pathname* file) + (if (and (provided? 'sun-dl) + (< 3 sl) + (not (eqv? (string-ref file 0) '#\/))) + (set! file (string-append "./" file))) + (set! linkobj (or (provided? 'sun-dl) (dyn:link file))) + (and linkobj + (for-each (lambda (lib) + (or (dyn:link lib) (slib:error "couldn't link: " lib))) + libs)) + (if (provided? 'sun-dl) (set! linkobj (dyn:link file))) + (cond ((not linkobj) + (set! *load-pathname* oloadpath) #f) + ((dyn:call (file->init_name name) linkobj) + (set! *load-pathname* oloadpath) #t) + (else + (dyn:unlink linkobj) + (set! *load-pathname* oloadpath) #f))))))) (cond ((defined? vms:dynamic-link-call) - (define link:able-suffix #f) - (define (link:link file) - (define dir "") - (define fil "") - (let loop ((i (- (string-length file) 1))) - (cond ((negative? i) (set! dir file)) - ((vicinity:suffix? (string-ref file i)) - (set! dir (substring file 0 (+ i 1))) - (set! fil (substring file (+ i 1) (string-length file)))) - (else (loop (- i 1))))) - (vms:dynamic-link-call dir fil (string-append "init_" fil))))) +(define link:able-suffix #f) +(define (link:link file) + (define dir "") + (define fil "") + (let loop ((i (- (string-length file) 1))) + (cond ((negative? i) (set! dir file)) + ((vicinity:suffix? (string-ref file i)) + (set! dir (substring file 0 (+ i 1))) + (set! fil (substring file (+ i 1) (string-length file)))) + (else (loop (- i 1))))) + (vms:dynamic-link-call dir fil (file->init_name fil))))) (cond ((provided? 'sun-dl) ;; These libraries are (deferred) linked in conversion to ".so" - (define (usr:lib lib) #f) - (define (x:lib lib) #f)) +(define (usr:lib lib) #f) +(define (x:lib lib) #f)) ((provided? 'shl) - (define (usr:lib lib) - (if (member lib '("c" "m")) - (string-append "/lib/lib" lib link:able-suffix) - (string-append "/usr/lib/lib" lib link:able-suffix))) - (define (x:lib lib) (string-append "/usr/X11R5/lib/lib" - lib link:able-suffix))) +(define (usr:lib lib) + (if (member lib '("c" "m")) + (string-append "/lib/lib" lib link:able-suffix) + (string-append "/usr/lib/lib" lib link:able-suffix))) +(define (x:lib lib) (string-append "/usr/X11R5/lib/lib" + lib link:able-suffix))) ((provided? 'dld:dyncm) - (define (usr:lib lib) - (or (and (member lib '("c" "m")) - (let ((sa (string-append "/usr/lib/lib" lib ".sa"))) - (and (file-exists? sa) sa))) - (string-append "/usr/lib/lib" lib ".a"))) - (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))) +(define (usr:lib lib) + (or (and (member lib '("c" "m")) + (let ((sa (string-append "/usr/lib/lib" lib ".sa"))) + (and (file-exists? sa) sa))) + (string-append "/usr/lib/lib" lib ".a"))) +(define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))) ((provided? 'dld) - (define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a")) - (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa")))) +(define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a")) +(define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa")))) diff --git a/Macexp.scm b/Macexp.scm new file mode 100644 index 0000000..6802699 --- /dev/null +++ b/Macexp.scm @@ -0,0 +1,586 @@ +;; Copyright (C) 1999 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of SCM. +;; +;; The exception is that, if you link the SCM library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the SCM library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name SCM. If you copy +;; code from other Free Software Foundation releases into a copy of +;; SCM, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for SCM, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "Macexp.scm", macro expansion, respecting hygiene. +;;; Author: Radey Shouman + +;; LLIST is a lambda list, BINDINGS an alist using the same identifiers. +(define extended-environment + (let ((env:annotation-marker 4)) + (lambda (llist bindings env) + (cons llist (cons env:annotation-marker (cons bindings env)))))) + +(define syntax-extended-environment + (let ((env:syntax-marker 6)) + ;;BINDINGS is an alist + (lambda (bindings env) + (cons (cons env:syntax-marker bindings) env)))) + +(define (environment-ref env id) + (environment-annotation id env)) + +;;(debind:if_ ?llist ?val ?body ?alt) +;;?alt should evaluate to a procedure taking two arguments, a pattern +;;and an object. This macro requires the (... ...) ellipsis quote +;;extension. +(define-syntax debind:if + (syntax-rules () + ((_ "PARSE LLIST" () ?val ?body ?alt) + (if (null? ?val) ?body (?alt '() ?val))) + + ((_ "PARSE LLIST" (?pattern (... ...)) ?val ?body ?alt) + (let loop ((v ?val)) + (cond ((null? v) + (debind:if "PARSE ..." ?pattern ?val ?body)) + ((pair? v) + (let ((carv (car v))) + (debind:if "PARSE LLIST" ?pattern carv + (loop (cdr v)) ?alt))) + (else + (?alt '(?pattern (... ...)) ?val))))) + + ((_ "PARSE LLIST" (?first . ?rest) ?val ?body ?alt) + (if (pair? ?val) + (let ((carv (car ?val)) + (cdrv (cdr ?val))) + (debind:if "PARSE LLIST" ?first carv + (debind:if "PARSE LLIST" ?rest cdrv ?body ?alt) + ?alt)) + (?alt '(?first . ?rest) ?val))) + + ((_ "PARSE LLIST" ?name ?val ?body ?alt) + (let ((?name ?val)) ?body)) + + ((_ "PARSE ..." () ?val ?body) + ?body) + + ((_ "PARSE ..." (?pattern (... ...)) ?val ?body) + (debind:if "PARSE ..." ?pattern ?val ?body)) + + ((_ "PARSE ..." (?first . ?rest) ?val ?body) + (debind:if "PARSE ..." ?first (map car ?val) + (debind:if "PARSE ..." ?rest (map cdr ?val) + ?body))) + + ((_ "PARSE ..." ?name ?val ?body) + (let ((?name ?val)) ?body)) + + ((_ ?llist ?val ?body) + (debind:if ?llist ?val ?body + (lambda (pat val "debind:if" '?llist val + "does not match" pat)))) + + ((_ ?llist ?val ?body ?alt) + (let ((val ?val) + (alt ?alt)) + (debind:if "PARSE LLIST" ?llist val ?body alt))))) + +;; Uncomment for DESTRUCTURING-BIND enhanced with ellipsis (...) patterns. +;(define-syntax destructuring-bind +; (syntax-rules () +; ((_ ?llist ?val ?body1 ?body ...) +; (debind:if ?llist ?val +; (let () ?body1 ?body ...) +; (lambda (pat val) +; (slib:error 'destructuring-bind '?llist +; val "does not match" pat)))))) + +;; This should really dispatch on the keyword only, then +;; use destructuring-case for each keyword, that way errors +;; may be more accurately reported for primitives. +;; +;;(keyword-case expr env (pattern body ...) ...) +(define-syntax keyword-case + (syntax-rules (else) + ((_ "RECURSE" ?expr ?env) + (error 'keyword-case ?expr "not matched")) + ((_ "RECURSE" ?expr ?env + (else ?body1 ?body ...)) + (let () ?body1 ?body ...)) + ((_ "RECURSE" ?expr ?env + ((?keyword . ?pattern) ?body1 ?body ...) + ?clause ...) + (let ((alt (lambda (ignore1 ignore2) + (keyword-case "RECURSE" ?expr ?env ?clause ...)))) + ;;Keywords are renamed in the top-level environment for each + ;;comparison, this is wasteful and somewhat ugly. + (if (identifier-equal? (renamed-identifier '?keyword '()) + (car ?expr) ?env) + (debind:if ?pattern (cdr ?expr) + (let () ?body1 ?body ...) + alt) + (alt #f #f)))) + ((_ ?expr ?env ?clause1 ?clause ...) + (let ((expr ?expr)) + (if (or (not (pair? expr)) + (not (identifier? (car expr)))) + (error 'keyword-case expr "bad form") + (keyword-case "RECURSE" expr ?env ?clause1 ?clause ...)))))) + +;; This is still not safe when ENV has non-macro bindings in it. +;; It could be made safe by rebuilding an equivalent environment, +;; retaining values only for syntactic bindings. +(define (macro:expand-syntax form env pretty? verbose?) + (define globals '()) + (define shadowed-globals '()) + (define top-lambda (renamed-identifier 'LAMBDA #f)) + (define top-let (renamed-identifier 'LET #f)) + (define top-let* (renamed-identifier 'LET* #f)) + (define top-letrec (renamed-identifier 'LETREC #f)) + (define top-arrow (renamed-identifier '=> #f)) + (define top-else (renamed-identifier 'ELSE #f)) + (define top-define (renamed-identifier 'DEFINE #f)) + (define top-begin (renamed-identifier 'BEGIN #f)) + (define (arrow? id env) + (and (identifier? id) + (identifier-equal? id top-arrow env))) + (define (else? id env) + (and (identifier? id) + (identifier-equal? id top-else env))) + (define (define? form env) + (and (list? form) ;FORM will have been expanded. + (identifier? (car form)) + (identifier-equal? top-define (car form) env))) + (define (begin? form env) + (and (list? form) + (identifier? (car form)) + (identifier-equal? (car form) top-begin env))) + + (define locally-bound? environment-annotation) + + (define pretty-name + (if pretty? + (letrec ((counter 0) + (genname + (lambda (sym) + (set! counter (+ counter 1)) + (string->symbol + (string-append (symbol->string sym) + "|" (number->string counter)))))) + (lambda (name env) + (if (symbol? name) + (if (or (memq name + '(LAMBDA LET LET* LETREC DO DEFINE SET! + BEGIN IF COND CASE AND OR QUOTE + QUASIQUOTE UNQUOTE UNQUOTE-SPLICING + DEFINE-SYNTAX LET-SYNTAX LETREC-SYNTAX + SYNTAX-QUOTE ELSE =>)) + (locally-bound? name env)) + (genname name) + name) + (genname (identifier->symbol name))))) + identity)) + + ;; Local bindings -> (identifier pretty-name (usage-context ...)) + ;; This will change. + (define (initial-binding name env) + (or (identifier? name) + (slib:error 'macro:expand name "not identifier")) + (list name (pretty-name name env) '())) + (define binding->name cadr) + (define binding->contexts caddr) + (define (binding-add-context! b context) + (let ((ctx (caddr b))) + (if (not (list? ctx)) + (error 'not-a-list ctx)) + (or (memq context ctx) + (set-car! (cddr b) (cons context ctx))))) + + ;; Produces an alist + (define (llist->bindings llist env) + (let recurse ((ll llist)) + (cond ((pair? ll) + (cons (initial-binding (car ll) env) + (recurse (cdr ll)))) + ((identifier? ll) + (list (initial-binding ll env))) + ((null? ll) ll) + (else (error 'strange-lambda-list llist))))) + + (define (expand-begin forms env context) + (if (null? forms) + '() + (let recurse ((forms forms)) + (if (null? (cdr forms)) + (list (expand (car forms) env context)) + (cons (expand (car forms) env 'SIDE-EFFECT) + (recurse (cdr forms))))))) + + (define (expand-body forms env context) + (define (rewrite forms defs) + (if (null? defs) + (expand-begin forms env context) + (list + (expand-primitive + `(,top-letrec ,(reverse defs) ;reverse just to make it pretty + ,@forms) env context)))) + (let loop ((forms forms) + (defs '())) + (if (null? (cdr forms)) + (rewrite forms defs) + (let ((form1 (expand (car forms) env 'SIDE-EFFECT))) + (cond ((define? form1 env) + (loop (cdr forms) + (cons (cdr form1) defs))) + ((begin? form1 env) + (loop (append (cdr form1) (cdr forms)) + defs)) + (else (rewrite forms defs))))))) + + (define (lookup id env) + (or (environment-ref env id) + (let* ((sym (identifier->symbol id)) + (binding (cond ((assq sym globals)) + (else + (let ((b (initial-binding sym env))) + (set! globals (cons b globals)) + b))))) + (cond ((not pretty?) id) + ((not (locally-bound? sym env))) + ((assq sym shadowed-globals)) + (else + (set! shadowed-globals + (cons (cons sym (binding->name binding)) + shadowed-globals)))) + binding))) + + (define pretty-varref + (if pretty? + (lambda (id env) + (if (symbol? id) + id + (let ((sym (identifier->symbol id))) + (if (identifier-equal? id sym env) sym id)))) + (lambda (id env) id))) + + (define unpaint + (if pretty? + (lambda (x) + (cond ((symbol? x) x) + ((identifier? x) (identifier->symbol x)) + ((pair? x) (cons (unpaint (car x)) (unpaint (cdr x)))) + ((vector? x) (let* ((n (vector-length x)) + (v (make-vector n))) + (do ((i 0 (+ i 1))) + ((>= i n) v) + (vector-set! v i (unpaint (vector-ref x i)))))) + (else x))) + identity)) + + (define (expand* forms env context) + (map (lambda (form) (expand form env context)) forms)) + + (define (expand-primitive form env context) + (define keyword (and (pair? form) + (if pretty? + (identifier->symbol (car form)) + (car form)))) + (keyword-case + form env + ;;Binding forms + ((LAMBDA llist body1 body ...) + (let* ((bindings (llist->bindings llist env)) + (env (extended-environment llist bindings env)) + (body (expand-body (cons body1 body) env context)) + (llist (let recurse ((ll llist) + (bl bindings)) + (cond ((null? ll) '()) + ((pair? ll) (cons (binding->name (car bl)) + (recurse (cdr ll) (cdr bl)))) + (else (binding->name bl)))))) + `(,keyword ,llist ,@body))) + ((LET ((names values) ...) body1 body ...) + (let* ((values (expand* values env 'VALUE)) + (bindings (llist->bindings names env)) + (env (extended-environment names bindings env)) + (body (expand-body (cons body1 body) env context))) + `(,keyword ,(map (lambda (b val) (list (binding->name b) val)) + bindings values) + ,@body))) + ((LET name1 ((names values) ...) body1 body ...) + (expand `((,top-letrec + ((,name1 (,(pretty-varref top-lambda env) ,names + ,@(cons body1 body)))) + ,name1) ,@values) + env context)) + ((LETREC ((names values) ...) body1 body ...) + (let* ((bindings (llist->bindings names env)) + (env (extended-environment names bindings env)) + (values (expand* values env 'VALUE)) + (body (expand-body (cons body1 body) env context))) + `(,keyword ,(map (lambda (b val) (list (binding->name b) val)) + bindings values) + ,@body))) + ((LET* ((names values) ...) body1 body ...) + (let recurse ((ns names) + (vs values) + (env env) + (bs '())) + (if (null? ns) + (let ((body (expand-body (cons body1 body) env context))) + `(,keyword ,(reverse bs) ,@body)) + (let ((binding (initial-binding (car ns) env))) + (recurse (cdr ns) (cdr vs) + (extended-environment (car ns) + (list binding) + env) + (cons (list (binding->name binding) + (expand (car vs) env 'VALUE)) + bs)))))) + ((DO ((names inits . steps) ...) + (test exit ...) + body ...) + (let* ((steps (map (lambda (name step) + (if (null? step) name (car step))) + names steps)) + (inits (expand* inits env 'VALUE)) + (bindings (llist->bindings names env)) + (env (extended-environment names bindings env)) + (steps (expand* steps env 'VALUE)) + (test (expand test env 'BOOLEAN)) + (exit (expand-begin exit env context)) + (body (expand-begin body env 'SIDE-EFFECT))) + `(,keyword + ,(map (lambda (binding init step) + (list (binding->name binding) init step)) + bindings inits steps) + ,(cons test exit) + ,@body))) + ((DEFINE (name . llist) body ...) + (expand-primitive + `(,keyword ,name (,top-lambda ,llist ,@body)) env context)) + ((DEFINE name value) + (cond ((null? env) ;Top level + (binding-add-context! (lookup name env) 'DEFINE) + `(,keyword ,(pretty-varref name env) + ,(expand value env 'VALUE))) + (else + `(,keyword ,name ,value)))) ;Expansion will be done by expand-body. + + ((SET! var value) + (let ((b (lookup var env))) + (binding-add-context! b 'SET!) + `(,keyword ,(binding->name b) ,(expand value env 'VALUE)))) + + ;;Non-binding forms + ((BEGIN body ...) + (let ((body (expand-begin body env context))) + (if (null? (cdr body)) + (car body) + `(,keyword ,@body)))) + ((IF test conseq . alt) + `(,keyword ,(expand test env 'BOOLEAN) + ,(expand conseq env context) + ,@(if (pair? alt) + (list (expand (car alt) env context)) + '()))) + ((COND (test exprs ...) ...) + `(,keyword + ,@(map (lambda (test exprs) + (cond ((null? exprs) (list (expand test env context))) + ((arrow? (car exprs) env) + (list (expand test env 'VALUE) + (pretty-varref top-arrow env) + (expand (cadr exprs) env 'PROCEDURE))) + ((else? test env) + (cons (pretty-varref top-else env) + (expand-begin exprs env context))) + (else + (cons (expand test env 'BOOLEAN) + (expand-begin exprs env context))))) + test exprs))) + ((CASE obj (datums exprs ...) ...) + `(,keyword ,(expand obj env 'VALUE) + ,@(map (lambda (datums exprs) + (cons (if (else? datums env) + (pretty-varref datums env) + (unpaint datums)) + (expand-begin exprs env context))) + datums exprs))) + ((AND forms ...) + `(,keyword ,@(expand* forms env context))) + ((OR forms ...) + `(,keyword ,@(expand* forms env context))) + + ;; Should unpaint synthetic identifiers + ((QUOTE obj) + `(,keyword ,(unpaint obj))) + ((QUASIQUOTE obj) + `(,keyword + ,(let qexp ((obj obj) + (depth 0)) + (cond ((not (pair? obj)) + (unpaint obj)) + ((identifier? (car obj)) + (let ((keyword (car obj))) + (keyword-case + obj env + ((QUASIQUOTE arg) + (list keyword (qexp arg (+ depth 1)))) + ((UNQUOTE arg) + (list keyword + (if (zero? depth) + (expand arg env context) + (qexp arg (- depth 1))))) + ((UNQUOTE-SPLICING arg) + (list keyword + (if (zero? depth) + (expand arg env context) + (qexp arg (- depth 1))))) + (else + (cons (unpaint keyword) (qexp (cdr obj) depth)))))) + (else + (cons (qexp (car obj) depth) + (qexp (cdr obj) depth))))))) + ((DEFINE-SYNTAX name def) + form) + ((LET-SYNTAX ((names defs) ...) body1 body ...) + (let* ((env (syntax-extended-environment '() env)) + (defs (map (lambda (name def) + (cons name (eval-syntax def env))) + names defs)) + (env (syntax-extended-environment defs env)) + (body (expand-body (cons body1 body) env context))) + (if pretty? + `(,(pretty-varref top-let env) () ,@body) + `(,top-let* (,(list marker #f)) ,@body)))) + ((LETREC-SYNTAX ((names defs) ...) body1 body ...) + (let* ((eframe (map (lambda (name) (cons name #f)) names)) + (env (syntax-extended-environment eframe env))) + (do ((ds defs (cdr ds)) + (ef eframe (cdr ef))) + ((null? ds)) + (set-cdr! (car ef) (eval-syntax (car ds) env))) + (let ((body (expand-body (cons body1 body) env context))) + (if pretty? + `(,(pretty-varref top-let env) () ,@body) + `(,top-let* (,(list marker #f)) ,@body))))) + ;;SCM extension + ((SYNTAX-QUOTE obj) + `(,keyword ,obj)) + (else + (warn 'expand-syntax "Unexpected primitive syntax" form) + form))) + + (define (handle-shadowed form env) + (if (define? form env) + (list (car form) (cadr form) + (handle-shadowed (caddr form))) + `(,(pretty-varref top-let env) + ,(map (lambda (s) + (list (cdr s) + (if (environment-ref env (car s)) + (renamed-identifier (car s) #f) + (car s)))) + shadowed-globals) + ,form))) + + (define (expand form env context) + (cond + ((identifier? form) + (let ((expanded (@macroexpand1 form env))) + (cond ((eq? form expanded) form) + ((not expanded) + (let* ((b (lookup form env)) + (name (binding->name b))) + (binding-add-context! b context) + name)) + (else expanded)))) + ((number? form) form) + ((char? form) form) + ((boolean? form) form) + ((null? form) form) + ((string? form) form) + ((list? form) + (if (identifier? (car form)) + (let ((expanded (@macroexpand1 form env))) + (cond ((eq? expanded form) + (expand-primitive form env context)) + ((not expanded) + (cons (expand (car form) env 'PROCEDURE) + (map (lambda (arg) + (expand arg env 'VALUE)) + (cdr form)))) + (else + (expand expanded env context)))) + (cons (expand (car form) env 'PROCEDURE) + (expand* (cdr form) env 'VALUE)))) + (else + (warn 'expand-syntax "Unexpected type of form" form) + form))) + + (let ((res (expand form env 'TOP))) + (cond (verbose? + (display "Globals: ") + (pretty-print globals) + (display "Shadowed Globals: ") + (pretty-print shadowed-globals))) + (cond ((null? shadowed-globals) res) + ((not (begin? res env)) (handle-shadowed res env)) + (else (cons (car res) + (map (lambda (form) + (handle-shadowed form env)) + (cdr res))))))) + +(define (macro:expand form . opt) + (macro:expand-syntax form '() + (not (memq 'not-pretty opt)) + (memq 'verbose opt))) + +;; Debugging fodder. +(begin + (define (read* filename) + (call-with-input-file filename + (lambda (p) + (let loop ((forms '())) + (let ((form (read p))) + (if (eof-object? form) + (cons 'BEGIN (reverse forms)) + (loop (cons form forms)))))))) + (define (expand-file filename . opt) + (apply macro:expand (read* filename) '() opt)) + (define s (read* (or *load-pathname* "Macexp.scm")))) + + +;;; Local Variables: +;;; mode:scheme +;;; eval:(put 'destructuring-bind 'scheme-indent-function 1) +;;; eval:(put 'destructuring-case 'scheme-indent-function 1) +;;; End: @@ -15,26 +15,26 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. @@ -56,12 +56,19 @@ ;; We keep local copies of these standard special forms, otherwise, ;; redefining them before they are memoized below can lead to ;; infinite recursion. - (@let-syntax ((lambda (the-macro lambda)) + (let-syntax ((lambda (the-macro lambda)) + (begin (the-macro begin)) + (quote (the-macro quote)) (let (the-macro let)) - (cond (the-macro cond)) - (if (the-macro if)) + (let* (the-macro let*)) + (letrec (the-macro letrec)) (and (the-macro and)) - (or (the-macro or))) + (or (the-macro or)) + (delay (the-macro delay)) + (do (the-macro do)) + (case (the-macro case)) + (cond (the-macro cond)) + (quasiquote (the-macro quasiquote))) (let ((var-rtd (make-record-type '? '(name rank))) (e-pat-rtd (make-record-type '... '(pattern vars))) (rule-rtd (make-record-type 'rule '(pattern inserted template)))) @@ -83,7 +90,8 @@ (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern)) (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars)) - (define rule (record-constructor rule-rtd '(pattern inserted template))) + (define make-rule + (record-constructor rule-rtd '(pattern inserted template))) (define rule->pattern (record-accessor rule-rtd 'pattern)) (define rule->inserted (record-accessor rule-rtd 'inserted)) (define rule->template (record-accessor rule-rtd 'template)) @@ -92,6 +100,12 @@ (if (null? y) x (append x y))) + (define (append-if pred x y) + (let recur ((x x)) + (cond ((null? x) y) + ((pred (car x)) (cons (car x) (recur (cdr x)))) + (else (recur (cdr x)))))) + (define ellipsis? (let (($... (renamed-identifier '... #f))) (lambda (x env) @@ -108,111 +122,130 @@ (duplicates? (cdr vars))))) (define (compile-pattern literals rule-exp env-def) - (let recur ((pat (cdar rule-exp)) - (vars '()) - (rank 0) - (k (lambda (compiled vars) - (let ((dup (duplicates? (map car vars)))) - (if dup - (error - "syntax-rules: duplicate pattern variable:" - dup " in rule " rule-exp))) - (apply rule - compiled - (rewrite-template - (cadr rule-exp) vars env-def))))) + (define (compile1 pat vars rank ell? k) (cond ((null? pat) (k pat vars)) ((identifier? pat) - (let ((lit (memq pat literals))) - (if lit - (k (renamed-identifier pat env-def) vars) - (let ((var (pattern-variable pat rank))) - (k var (cons (cons pat var) vars)))))) - ((pair? pat) - (if (and (pair? (cdr pat)) - (ellipsis? (cadr pat) env-def) - (or (null? (cddr pat)) - (error "bad ellipsis:" pat))) - (if (ellipsis? (car pat) env-def) - (recur (car pat) vars rank k) - (recur (car pat) '() (+ rank 1) - (lambda (comp1 vars1) - (k (list - (ellipsis-pattern comp1 (map cdr vars1))) - (append2 vars1 vars))))) - (recur (car pat) '() rank - (lambda (comp1 vars1) - (recur (cdr pat) vars rank - (lambda (comp2 vars2) - (k (cons comp1 comp2) - (append2 vars1 vars2)))))))) + (if (or (memq pat literals) + (and (not ell?) (ellipsis? pat env-def))) + (k (renamed-identifier pat env-def) vars) + (let ((var (pattern-variable pat rank))) + (k var (cons (cons pat var) vars))))) ((vector? pat) - (recur (vector->list pat) vars rank - (lambda (comp vars) - (k (list->vector comp) vars)))) - (else - (k pat vars))))) + (compile1 (vector->list pat) vars rank ell? + (lambda (comp vars) + (k (list->vector comp) vars)))) + ((not (pair? pat)) + (k pat vars)) + ((and ell? (ellipsis? (car pat) env-def)) + (or (and (pair? (cdr pat)) + (null? (cddr pat))) + (error "bad ellipsis quote:" pat)) + (compile1 (cadr pat) vars rank #f k)) + ((and ell? + (pair? (cdr pat)) + (ellipsis? (cadr pat) env-def)) + (or (null? (cddr pat)) + (error "bad ellipsis:" pat)) + (compile1 + (car pat) '() (+ rank 1) ell? + (lambda (comp1 vars1) + (k (list + (ellipsis-pattern comp1 (map cdr vars1))) + (append2 vars1 vars))))) + (else ; pat is a pair + (compile1 + (car pat) '() rank ell? + (lambda (comp1 vars1) + (compile1 + (cdr pat) vars rank ell? + (lambda (comp2 vars2) + (k (cons comp1 comp2) + (append2 vars1 vars2))))))))) + (let ((pat (car rule-exp)) + (tmpl (cadr rule-exp))) + (if (identifier? pat) + (apply make-rule #f (rewrite-template tmpl '() env-def)) + (compile1 + (cdr pat) '() 0 #t + (lambda (compiled vars) + (let ((dup (duplicates? (map car vars)))) + (if dup + (error + "syntax-rules: duplicate pattern variable:" + dup " in rule " rule-exp) + (apply make-rule + (cons #f compiled) + (rewrite-template tmpl vars env-def))))))))) (define (rewrite-template template vars env-def) - (let recur ((tmpl template) - (rank 0) - (inserted '()) - (k (lambda (compiled inserted opened) - (list inserted compiled)))) + (let rewrite1 ((tmpl template) + (rank 0) + (inserted '()) + (ell? #t) + (k (lambda (compiled inserted opened) + (list inserted compiled)))) (cond ((null? tmpl) (k tmpl '() '())) ((identifier? tmpl) (let ((v (assq tmpl vars))) - (if v - (cond ((= rank (pattern-variable->rank (cdr v))) - (k (cdr v) '() (list (cdr v)))) - ((> rank (pattern-variable->rank (cdr v))) - (k (cdr v) '() '())) - (else - (error "pattern variable rank mismatch:" tmpl - " in " template))) - (k tmpl (list tmpl) '())))) - ((pair? tmpl) - (if (and (pair? (cdr tmpl)) - (ellipsis? (cadr tmpl) env-def)) - (if (and (ellipsis? (car tmpl) env-def) - (or (null? (cddr tmpl)) - (error "bad ellipsis:" tmpl))) - ;; (... ...) escape - (k (car tmpl) (list (car tmpl)) '()) - (recur (car tmpl) (+ rank 1) '() - (lambda (comp1 ins1 op1) - (if (null? op1) - (error "Bad ellipsis:" - tmpl " in template " template)) - (recur (cddr tmpl) rank inserted - (lambda (comp2 ins2 op2) - (k (cons - (ellipsis-pattern comp1 op1) - comp2) - (append2 ins1 ins2) - (append2 op1 op2))))))) - (recur (car tmpl) rank '() - (lambda (comp1 ins1 op1) - (recur (cdr tmpl) rank inserted - (lambda (comp2 ins2 op2) - (k (cons comp1 comp2) - (append2 ins1 ins2) - (append2 op1 op2)))))))) + (cond ((not v) + (k tmpl (list tmpl) '())) + ((zero? (pattern-variable->rank (cdr v))) + (k (cdr v) '() '())) + ((>= rank (pattern-variable->rank (cdr v))) + (k (cdr v) '() (list (cdr v)))) + (else + (error "pattern variable rank mismatch:" tmpl + " in " template))))) ((vector? tmpl) - (recur (vector->list tmpl) rank inserted - (lambda (compiled inserted opened) - (k (list->vector compiled) inserted opened)))) - (else - (k tmpl '() '()))))) - + (rewrite1 + (vector->list tmpl) rank inserted ell? + (lambda (compiled inserted opened) + (k (list->vector compiled) inserted opened)))) + ((not (pair? tmpl)) + (k tmpl '() '())) + ((and ell? (ellipsis? (car tmpl) env-def)) + ;; (... ...) escape + (or (and (pair? (cdr tmpl)) + (null? (cddr tmpl))) + (error "Bad ellpsis quote:" tmpl + " in template " template)) + (rewrite1 (cadr tmpl) rank inserted #f k)) + ((and ell? + (pair? (cdr tmpl)) + (ellipsis? (cadr tmpl) env-def)) + (rewrite1 + (car tmpl) (+ rank 1) '() ell? + (lambda (comp1 ins1 op1) + (if (null? op1) + (error "Bad ellipsis:" tmpl + " in template " template)) + (rewrite1 + (cddr tmpl) rank inserted ell? + (lambda (comp2 ins2 op2) + (k (cons (ellipsis-pattern comp1 op1) + comp2) + (append2 ins1 ins2) + (append-if (lambda (op) + (> (pattern-variable->rank op) + rank)) + op1 op2))))))) + (else ; tmpl is a pair + (rewrite1 + (car tmpl) rank '() ell? + (lambda (comp1 ins1 op1) + (rewrite1 + (cdr tmpl) rank inserted ell? + (lambda (comp2 ins2 op2) + (k (cons comp1 comp2) + (append2 ins1 ins2) + (append2 op1 op2)))))))))) ;;; Match EXP to RULE, returning alist of variable bindings or #f. (define (match rule exp env-use) - (let recur ((r (rule->pattern rule)) - (x (cdr exp))) + (define (match1 r x) (cond ((null? r) (and (null? x) '())) ((pair? r) @@ -220,8 +253,8 @@ (and (list? x) (let ((pat (ellipsis-pattern->pattern (car r)))) - (let match1 ((x x) - (vals '())) + (let match-list ((x x) + (vals '())) (if (null? x) (if (null? vals) (map list (ellipsis-pattern->vars (car r))) @@ -230,14 +263,14 @@ (map (lambda (al) (map cdr al)) (reverse vals))))) - (let ((val (recur pat (car x)))) + (let ((val (match1 pat (car x)))) (and val - (match1 (cdr x) (cons val vals)))))))) + (match-list (cdr x) (cons val vals)))))))) (and (pair? x) - (let ((v1 (recur (car r) (car x)))) + (let ((v1 (match1 (car r) (car x)))) (and v1 - (let ((v2 (recur (cdr r) (cdr x)))) + (let ((v2 (match1 (cdr r) (cdr x)))) (and v2 (append2 v1 v2)))))))) ((identifier? r) ;literal (and (identifier? x) (identifier-equal? r x env-use) '())) @@ -245,16 +278,30 @@ (list (cons r x))) ((vector? r) (and (vector? x) - (recur (vector->list r) (vector->list x)))) + (match1 (vector->list r) (vector->list x)))) (else - (and (equal? r x) '()))))) + (and (equal? r x) '())))) + (let ((pat (rule->pattern rule))) + (if (pair? pat) + (and (pair? exp) + (match1 (cdr pat) (cdr exp))) + (if (pair? exp) #f '())))) + + (define (substitute-in-template x-use rule vars env-def) + (define (length-error pats vals) + (apply error + "syntax-rules: pattern variable length mismatch:\n" + x-use + (map (lambda (name val) + `(,(pattern-variable->name + name) -> ,val)) + pats vals))) - (define (substitute-in-template rule vars env-def) (let ((ins (map (lambda (id) (cons id (renamed-identifier id env-def))) (rule->inserted rule)))) - (let recur ((tmpl (rule->template rule)) - (vars vars)) + (let subst1 ((tmpl (rule->template rule)) + (vars vars)) (cond ((null? tmpl) tmpl) ((pair? tmpl) @@ -269,62 +316,75 @@ (if (pair? es) (if (= n (length (car es))) (check (cdr es)) - (error "syntax-rules: pattern variable length mismatch:")))) + (length-error enames evals)))) (append! (map (lambda (eval) - (recur etmpl - (append! - (map cons enames eval) - vars))) + (subst1 etmpl + (append! + (map cons enames eval) + vars))) (apply map list evals)) - (recur (cdr tmpl) vars))) - (cons (recur (car tmpl) vars) - (recur (cdr tmpl) vars)))) + (subst1 (cdr tmpl) vars))) + (cons (subst1 (car tmpl) vars) + (subst1 (cdr tmpl) vars)))) ((identifier? tmpl) (let ((a (assq tmpl ins))) (if a (cdr a) tmpl))) ((pattern-variable? tmpl) (@copy-tree (cdr (assq tmpl vars)))) ((vector? tmpl) - (list->vector (recur (vector->list tmpl) vars))) + (list->vector (subst1 (vector->list tmpl) vars))) (else tmpl))))) ;; MACRO:COMPILE-SYNTAX-RULES (lambda (x-def env-def) - (or (and (list? x-def) - (< 2 (length x-def)) - (list? (cadr x-def))) - (error "Malformed syntax-rules:" x-def)) - (let ((literals (cadr x-def))) - (for-each (lambda (x) - (or (identifier? x) - (error "Bad literals list:" x-def))) - literals) - (let ((rules (map (lambda (rule-expr) - (or (and (list? rule-expr) - (= 2 (length rule-expr)) - (pair? (car rule-expr))) - (error "Bad rule:" rule-expr)) - (compile-pattern literals rule-expr env-def)) - (cddr x-def)))) + (let ((x-def (remove-line-numbers! x-def))) + (or (and (list? x-def) + (< 2 (length x-def)) + (list? (cadr x-def))) + (error "Malformed syntax-rules:" x-def)) + (let ((literals (cadr x-def))) + (for-each (lambda (x) + (or (identifier? x) + (error "Bad literals list:" x-def))) + literals) + (let ((rules (map (lambda (rule-expr) + (or (and (list? rule-expr) + (= 2 (length rule-expr)) + (let ((pat (car rule-expr))) + (or (pair? pat) + (identifier? pat)))) + (error "Bad rule:" rule-expr)) + (compile-pattern literals rule-expr env-def)) + (cddr x-def)))) - (lambda (x-use env-use) - (let loop ((rules rules)) - (cond ((null? rules) - (error "macro use does not match definition:" - x-use)) - ((match (car rules) x-use env-use) - => (lambda (vars) - (substitute-in-template (car rules) vars env-def))) - (else - (loop (cdr rules)))))))))))) + (lambda (x-use env-use) + ;;FIXME We should use the line numbers. + (let ((x-use (remove-line-numbers! x-use))) + (let loop ((rules rules)) + (cond ((null? rules) + (error "macro use does not match definition:" + x-use)) + ((match (car rules) x-use env-use) + => (lambda (vars) + (substitute-in-template + x-use (car rules) vars env-def))) + (else + (loop (cdr rules)))))))))))))) -(define syntax-rules +(define-syntax syntax-rules (procedure->syntax (lambda (expr env-def) - (procedure->memoizing-macro - (macro:compile-syntax-rules expr env-def))))) + (let ((transformer (macro:compile-syntax-rules expr env-def))) + (let loop ((rules (cddr expr))) + (cond ((null? rules) + (procedure->memoizing-macro transformer)) + ((identifier? (caar rules)) + (procedure->identifier-macro transformer)) + (else + (loop (cdr rules))))))))) + ;; Explicit renaming macro facility, as in ;; W. Clinger, "Hygienic Macros Through Explicit Renaming" @@ -358,22 +418,79 @@ (lambda (exp env-def) `(,?transformer ,(cadr exp) (,?syntax-quote ,env-def)))))) -(define define-syntax - (syntax-rules () - ((define-syntax ?name ?val) - (define ?name (the-macro ?val))))) - -(define-syntax let-syntax - (syntax-rules () ((let-syntax ((?name ?val) ...) . ?body) - (@let-syntax - ((?name (the-macro ?val)) ...) . ?body)))) - -(define-syntax letrec-syntax - (syntax-rules () ((letrec-syntax ((?name ?val) ...) . ?body) - (@letrec-syntax - ((?name (the-macro ?val)) ...) . ?body)))) - -;; MACRO:EXPAND would require substantial work. (define macro:load load) (define macro:eval eval) +(define (macro:expand . args) + (load (in-vicinity (implementation-vicinity) "Macexp")) + (apply macro:expand args)) (provide 'macro) + +;; These are not part of the SYNTAX-RULES implementation, but I see +;; no better place to put them: + +;; A debugging utility macro that is easy to grep for. +(define-syntax @print + (syntax-rules (quote) + ((_ '?arg) + (begin (display '?arg) + (newline))) + ((_ ?arg) + (begin (display '?arg) + (display " => ") + (let ((x ?arg)) + (write x) + (newline) + x))) + ((_ ?arg1 ?arg ...) + (begin + (@print ?arg1) + (begin + (display " ") + (@print ?arg)) + ...)))) + +(define-syntax @pprint + (syntax-rules (quote) + ((_ '?arg) + (begin (display '?arg) + (newline))) + ((_ ?arg) + (begin (display '?arg) + (display " => ") + (let ((x ?arg)) + (pprint x) + (newline) + x))) + ((_ ?arg1 ?arg ...) + (begin + (@pprint ?arg1) + (begin + (display " ") + (@pprint ?arg)) + ...)))) + +;; Better run time error reporting than the version in Init*.scm, +;; also only takes a given car or cdr once. +(define-syntax destructuring-bind + (syntax-rules () + ((_ "PARSE-LLIST" () ?val ?body ?err) + (if (null? ?val) ?body (?err '() ?val))) + ((_ "PARSE-LLIST" (?name1 . ?rest) ?val ?body ?err) + (if (pair? ?val) + (let ((carv (car ?val)) + (cdrv (cdr ?val))) + (destructuring-bind "PARSE-LLIST" ?name1 carv + (destructuring-bind "PARSE-LLIST" ?rest cdrv ?body ?err) + ?err)) + (?err '(?name1 . ?rest) ?val))) + ((_ "PARSE-LLIST" ?name ?val ?body ?err) + (let ((?name ?val)) ?body)) + ((_ ?llist ?val ?body1 ?body ...) + (let ((err (lambda (pat val) + (slib:error 'destructuring-bind '?llist + val "does not match" pat))) + (val ?val)) + (destructuring-bind "PARSE-LLIST" ?llist val + ;;Use LET to allow internal DEFINE in body. + (let () ?body1 ?body ...) + err))))) diff --git a/Macroexpand.scm b/Macroexpand.scm deleted file mode 100644 index 3b658f8..0000000 --- a/Macroexpand.scm +++ /dev/null @@ -1,370 +0,0 @@ -;; Copyright (C) 1999 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. -;; -;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. -;; -;; The exception is that, if you link the GUILE library with other files -;; to produce an executable, this does not by itself cause the -;; resulting executable to be covered by the GNU General Public License. -;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. -;; -;; This exception does not however invalidate any other reasons why -;; the executable file might be covered by the GNU General Public License. -;; -;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy -;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does -;; not apply to the code that you add in this way. To avoid misleading -;; anyone as to the status of such modified files, you must delete -;; this exception notice from them. -;; -;; If you write modifications of your own for GUILE, it is your choice -;; whether to permit this exception to apply to your modifications. -;; If you do not wish that, delete this exception notice. - -;;;; "Macroexpand.scm", macro expansion, respecting hygiene. -;;; Author: Radey Shouman - -;; It is possible to break MACRO:EXPAND by redefining primitive -;; syntax, eg LAMBDA, LET, QUOTE to different primitive syntax, -;; or by defining any of @LAMBDA, @LET, @LET*, @LETREC, @DO, -;; or @EXPAND as primitive syntax. - -;; We still need LET-SYNTAX and LETREC-SYNTAX. - -(define macro:expand - (let (($lambda (renamed-identifier 'lambda '())) - ($let (renamed-identifier 'let '())) - ($let* (renamed-identifier 'let* '())) - ($letrec (renamed-identifier 'letrec '())) - ($do (renamed-identifier 'do '())) - ($define (renamed-identifier 'define '())) - ($quote (renamed-identifier 'quote '())) - ($quasiquote (renamed-identifier 'quasiquote '())) - ($unquote (renamed-identifier 'unquote '())) - ($unquote-splicing (renamed-identifier 'unquote-splicing '())) - ($case (renamed-identifier 'case '())) - ($cond (renamed-identifier 'cond '())) - ($begin (renamed-identifier 'begin '())) - ($if (renamed-identifier 'if '())) - ($and (renamed-identifier 'and '())) - ($or (renamed-identifier 'or '())) - ($set! (renamed-identifier 'set! '())) - ($delay (renamed-identifier 'delay '())) - ($syntax-quote (renamed-identifier 'syntax-quote '())) - ($@apply (renamed-identifier '@apply '())) - ($else (renamed-identifier 'else '())) - (@lambda (renamed-identifier '@lambda '())) - (@let (renamed-identifier '@let '())) - (@let* (renamed-identifier '@let* '())) - (@letrec (renamed-identifier '@letrec '())) - (@do (renamed-identifier '@do '())) - (@expand (renamed-identifier '@expand '()))) - - (define expander - (macro:compile-syntax-rules - '(syntax-rules (lambda let letrec let* do @let*) - ((_ (lambda ?formals ?body ...)) - (@lambda ?formals ?body ...)) - - ((_ (let ((?name ?val) ...) ?body ...)) - (@let ((?name ...) ?val ...) ?body ...)) - ((_ (let ?proc ((?name ?val) ...) ?body ...)) - (@expand - (letrec ((?proc (lambda (?name ...) ?body ...))) - (?proc ?val ...)))) - - ((_ (letrec ((?name ?val) ...) ?body ...)) - (@letrec ((?name ...) ?val ...) ?body ...)) - - ((_ (let* () ?body ...)) - (@let (()) ?body ...)) - ((_ (let* ((?name1 ?val1) (?name ?val) ...) ?body ...)) - (@expand - (@let* (?name1 ?val1) (let* ((?name ?val) ...) ?body ...)))) - ((_ (@let* (?name ?val ...) (let* () ?body ...))) - (@let* (?name ?val ...) ?body ...)) - ((_ (@let* (?name ?val ...) - (let* ((?name2 ?val2) (?name3 ?val3) ...) ?body ...))) - (@expand - (@let* (?name ?val ... ?name2 ?val2) - (let* ((?name3 ?val3) ...) ?body ...)))) - ((_ (@let* (?name ?val ...) ?body ...)) - (@let* (?name ?val ...) ?body ...)) - - ((_ (do ((?var ?init ?step) ...) - (?test ?clause ...) - ?body ...)) - (@do (?var ...) (?init ...) - (?test ?clause ...) - (?body ...) - (?step ...))) - - ((_ ?form) - ?form)) - '())) - - (define (simplify-identifiers expr env) - (let simplify ((expr expr)) - (cond ((identifier? expr) - (let ((sym (identifier->symbol expr))) - (if (identifier-equal? sym expr env) sym expr))) - ((pair? expr) - (cons (simplify (car expr)) - (simplify (cdr expr)))) - (else expr)))) - - (define (unpaint expr) - (cond ((identifier? expr) - (identifier->symbol expr)) - ((pair? expr) - (cons (unpaint (car expr)) (unpaint (cdr expr)))) - ((vector? expr) - (list->vector (map unpaint (vector->list expr)))) - (else expr))) - - (define (defines->bindings defs) - (reverse ;purely cosmetic - (map (lambda (b) - (if (pair? (cadr b)) - (list (caadr b) - (cons $lambda (cons (cdadr b) (cddr b)))) - (cdr b))) - defs))) - - (define (expand-define expr env) - (let ((binding (car (defines->bindings (list expr))))) - (cons (simplify-identifiers $define env) - (list (simplify-identifiers (car binding) env) - (macro:expand (cadr binding) env))))) - - (define (expand-body expr-list env) - (let loop ((defines '()) - (exprs expr-list)) - (if (null? exprs) #f ; should check higher up. - (let ((exp1 (macro:expand (car exprs) env))) - (if (and (pair? exp1) - (identifier? (car exp1)) - (identifier-equal? (car exp1) $define env)) - (loop (cons exp1 defines) (cdr exprs)) - (if (null? defines) - (cons exp1 (expand* (cdr exprs) env)) - (let ((bindings (defines->bindings defines))) - (list - (macro:expand - (cons $letrec (cons bindings exprs)) - env))))))))) - - (define (expand* exprs env) - (map (lambda (x) - (macro:expand x env)) - exprs)) - - ;;(@lambda formals body ...) - (define (expand-lambda expr env) - (let* ((formals (cadr expr)) - (body (cddr expr)) - (bound - (let recur ((f formals)) - (cond ((null? f) '()) - ((pair? f) (cons 'required (recur (cdr f)))) - ((identifier? f) (list 'rest-list)) - (else (error 'lambda 'bad-formals expr))))) - (env1 (extended-environment formals bound env))) - (cons (simplify-identifiers $lambda env) - (cons (simplify-identifiers formals env1) - (expand-body body env1))))) - - ;;(@let ((formals) bindings) body ...) - (define (expand-let expr env) - (let* ((formals (caadr expr)) - (bindings (expand* (cdadr expr) env)) - (env1 (extended-environment formals - (map (lambda (x) 'let) formals) - env))) - (cons (simplify-identifiers $let env) - (cons (map list formals bindings) - (expand-body (cddr expr) env1))))) - - (define (expand-let* expr env) - (let loop ((inp (cadr expr)) - (formals '()) - (bindings '()) - (env1 env)) - (if (null? inp) - (cons (simplify-identifiers $let* env) - (map list (reverse formals) (reverse bindings)) - (expand-body (cddr expr) env1)) - (loop (cddr inp) - (cons (car inp) formals) - (cons (macro:expand (cadr inp) env1) bindings) - (extended-environment (car inp) 'let* env1))))) - - ;;(@letrec ((formals) bindings) body ...) - (define (expand-letrec expr env) - (let* ((formals (caadr expr)) - (env1 (extended-environment - formals - (map (lambda (x) 'letrec) formals) - env)) - (bindings (expand* (cdadr expr) env1))) - (cons (simplify-identifiers $letrec env) - (cons (map list formals bindings) - (expand-body (cddr expr) env1))))) - - ;;(@do vars inits (test clause ...) (body ...) steps) - (define (expand-do expr env) - (let* ((vars (cadr expr)) - (inits (expand* (caddr expr) env)) - (env1 (extended-environment - vars (map (lambda (x) 'do) inits) env)) - (steps (expand* (list-ref expr 5) env1))) - (cons (simplify-identifiers $do env) - (cons - (map list vars inits steps) - (cons (expand* (cadddr expr) env1) - (expand* (list-ref expr 4) env1)))))) - - (define (expand-quote expr env) - (let ((obj (cadr expr))) - (if (or (boolean? obj) - (number? obj) - (string? obj)) - obj - (list (simplify-identifiers $quote env) - (unpaint obj))))) - - (define (expand-quasiquote expr env) - (list (simplify-identifiers $quasiquote env) - (let qq ((expr (cadr expr)) - (level 0)) - (cond ((vector? expr) - (list->vector (qq (vector->list expr) level))) - ((not (pair? expr)) - (unpaint expr)) - ((not (identifier? (car expr))) - (cons (qq (car expr) level) (qq (cdr expr) level))) - ((identifier-equal? (car expr) $quasiquote env) - (list (simplify-identifiers $quasiquote env) - (qq (cadr expr) (+ level 1)))) - ((or (identifier-equal? (car expr) $unquote env) - (identifier-equal? (car expr) $unquote-splicing env)) - (list (simplify-identifiers (car expr) env) - (if (zero? level) - (macro:expand (cadr expr) env) - (qq (cadr expr) (- level 1))))) - (else - (cons (qq (car expr) level) - (qq (cdr expr) level))))))) - - (define (expand-case expr env) - (cons (simplify-identifiers $case env) - (cons (macro:expand (cadr expr) env) - (map (lambda (clause) - (cond ((pair? (car clause)) - (cons (unpaint (car clause)) - (expand* (cdr clause) env))) - ((and (identifier? (car clause)) - (identifier-equal? $else - (car clause) env)) - (cons (simplify-identifiers - (car clause) env) - (expand* (cdr clause) env))) - (else (error 'macro:expand 'case - "bad clause" expr)))) - (cddr expr))))) - - (define (expand-cond expr env) - (cons (simplify-identifiers $cond env) - (map (lambda (clause) (expand* clause env)) - (cdr expr)))) - - ;; for IF, BEGIN, SET! - (define (expand-simple expr env) - (cons (simplify-identifiers (car expr) env) - (expand* (cdr expr) env))) - - (define (expand-primitives expr env) - (let loop ((expr (list '@expand expr))) - (let* ((expanded (expander expr env)) - (head (car expanded))) - (cond ((identifier-equal? @LAMBDA head env) - (expand-lambda expanded env)) - ((identifier-equal? @LET head env) - (expand-let expanded env)) - ((identifier-equal? @LET* head env) - (expand-let* expanded env)) - ((identifier-equal? @LETREC head env) - (expand-letrec expanded env)) - ((identifier-equal? @DO head env) - (expand-do expanded env)) - ((identifier-equal? $QUOTE head env) - (expand-quote expanded env)) - ((identifier-equal? $QUASIQUOTE head env) - (expand-quasiquote expanded env)) - ((identifier-equal? $BEGIN head env) - (expand-simple expanded env)) - ((identifier-equal? $IF head env) - (expand-simple expanded env)) - ((identifier-equal? $AND head env) - (expand-simple expanded env)) - ((identifier-equal? $OR head env) - (expand-simple expanded env)) - ((identifier-equal? $SET! head env) - (expand-simple expanded env)) - ((identifier-equal? $DELAY head env) - (expand-simple expanded env)) - ((identifier-equal? $@APPLY head env) - (expand-simple expanded env)) - ((identifier-equal? $CASE head env) - (expand-case expanded env)) - ((identifier-equal? $COND head env) - (expand-cond expanded env)) - ((and (identifier-equal? $DEFINE head env) - (null? (environment->tree env))) - (expand-define expanded env)) - ((identifier-equal? $SYNTAX-QUOTE head env) - (cons (simplify-identifiers head env) - (cdr expanded))) - ((identifier-equal? @EXPAND head env) - (loop expanded)) - (else - (print 'macro:expand - "Warning: unknown primitive syntax" (car expanded)) - expanded))))) - - (lambda (expr env) - (let loop ((expr expr)) - (let ((expanded (@macroexpand1 expr env))) - (cond ((not expanded) - (cond ((pair? expr) - (if (list? expr) - (expand* expr env) - (print 'macro:expand "expansion not a list" expr))) - ((identifier? expr) - (simplify-identifiers expr env)) - (else expr))) - ((eq? expanded expr) - (expand-primitives expr env)) - (else - (loop expanded)))))))) - -;;; Local Variables: -;;; eval: (put 'identifier-case 'scheme-indent-function 1) -;;; End: @@ -15,26 +15,26 @@ # the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. # # As a special exception, the Free Software Foundation gives permission -# for additional uses of the text contained in its release of GUILE. +# for additional uses of the text contained in its release of SCM. # -# The exception is that, if you link the GUILE library with other files +# The exception is that, if you link the SCM library with other files # to produce an executable, this does not by itself cause the # resulting executable to be covered by the GNU General Public License. # Your use of that executable is in no way restricted on account of -# linking the GUILE library code into it. +# linking the SCM library code into it. # # This exception does not however invalidate any other reasons why # the executable file might be covered by the GNU General Public License. # # This exception applies only to the code released by the -# Free Software Foundation under the name GUILE. If you copy +# Free Software Foundation under the name SCM. If you copy # code from other Free Software Foundation releases into a copy of -# GUILE, as the General Public License permits, the exception does +# SCM, as the General Public License permits, the exception does # not apply to the code that you add in this way. To avoid misleading # anyone as to the status of such modified files, you must delete # this exception notice from them. # -# If you write modifications of your own for GUILE, it is your choice +# If you write modifications of your own for SCM, it is your choice # whether to permit this exception to apply to your modifications. # If you do not wish that, delete this exception notice. @@ -42,17 +42,39 @@ # Author: Aubrey Jaffer SHELL = /bin/sh -CPROTO = cproto -#CC = -CFLAGS = -g -O +#CC = gcc +CFLAGS = -g #LIBS = -LD = $(CC) -g -O +LD = $(CC) -g +SCMLIT = ./scmlit +SCMEXE = ./scm + +#BUILD = ./build -hsystem -p svr4-gcc-sun-ld +BUILD = ./build -hsystem + +#for RPMs +RELEASE = 1 + +intro: + @echo + @echo "This is the scm$(VERSION) distribution. Read \"scm.info\"" + @echo "to learn how to build and install SCM. Or browse" + @echo " http://swissnet.ai.mit.edu/~jaffer/SCM.html" + @echo + $(MAKE) scm + +#srcdir=$(HOME)/scm/ +#srcdir=/usr/local/src/scm/ +include srcdir.mk +srcdir.mk: Makefile + echo "CPROTO=`type cproto | sed 's%.* %%'`" > srcdir.mk + echo "srcdir=`pwd`/" >> srcdir.mk # directory where COPYING and InitXXX.scm reside. #IMPLPATH = /usr/local/src/scm/ #this one is good for bootstrapping -IMPLPATH = `pwd`/ -# Pathname where InitXXX.scm resides. +#IMPLPATH = `pwd`/ +IMPLPATH=$(srcdir) include patchlvl.h IMPLINIT = $(IMPLPATH)Init$(VERSION).scm @@ -60,30 +82,27 @@ IMPLINIT = $(IMPLPATH)Init$(VERSION).scm # SCM_INIT_PATH is the environment variable whose value is the # pathname where InitXXX.scm resides. -intro: - @echo - @echo "This is the scm$(VERSION) distribution. Read \"scm.info\"" - @echo "to learn how to build and install SCM. Or browse" - @echo " http://swissnet.ai.mit.edu/~jaffer/SCM.html" - cfiles = scmmain.c scm.c time.c repl.c ioext.c scl.c sys.c eval.c \ subr.c sc2.c unif.c rgx.c crs.c dynl.c record.c posix.c socket.c\ unix.c rope.c ramap.c gsubr.c edline.c Iedline.scm continue.c \ - findexec.c script.c + findexec.c script.c debug.c ofiles = scm.o time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \ - continue.o findexec.o script.o + continue.o findexec.o script.o debug.o # ramap.o -ifiles = Init$(VERSION).scm Transcen.scm Link.scm Macro.scm Macroexpand.scm \ - Tscript.scm -xfiles = x.c x.h xgen.scm xevent.scm xevent.h inc2scm x11.scm +ifiles = Init$(VERSION).scm Transcen.scm Link.scm Macro.scm Macexp.scm \ + Tscript.scm compile.scm +hobfiles = hobbit.scm scmhob.scm scmhob.h +xafiles = xatoms.scm x11.scm xevent.scm keysymdef.scm +xfiles = x.c x.h xgen.scm xevent.h inc2scm $(xafiles) all: require.scm $(MAKE) mydlls - $(MAKE) myscm + $(MAKE) myscm5 + $(MAKE) x.so require.scm: cp -p requires.scm require.scm -scmlit: $(ofiles) scmmain.o require.scm +scmlit: $(ofiles) scmmain.o require.scm Makefile $(LD) -o scmlit $(ofiles) scmmain.o $(LIBS) $(MAKE) checklit scmflags.h: scmflags @@ -91,6 +110,7 @@ scmflags: echo "#ifndef IMPLINIT" > newflags.h echo "#define IMPLINIT \"$(IMPLINIT)\"" >> newflags.h echo "#endif" >> newflags.h + echo "/*#define CAUTIOUS*/" >> newflags.h -if (diff newflags.h scmflags.h) then rm newflags.h; \ else mv newflags.h scmflags.h; fi @@ -100,6 +120,7 @@ scm.o: scm.c scm.h scmfig.h scmflags.h patchlvl.h scmmain.o: scmmain.c scm.h scmfig.h scmflags.h patchlvl.h scl.o: scl.c scm.h scmfig.h scmflags.h eval.o: eval.c scm.h scmfig.h scmflags.h setjump.h +debug.o: debug.c scm.h scmfig.h scmflags.h setjump.h unif.o: unif.c scm.h scmfig.h scmflags.h #ramap.o: ramap.c scm.h scmfig.h scmflags.h repl.o: repl.c scm.h scmfig.h scmflags.h setjump.h @@ -109,17 +130,16 @@ subr.o: subr.c scm.h scmfig.h scmflags.h rope.o: rope.c scm.h scmfig.h scmflags.h continue.o: continue.c continue.h setjump.h scmflags.h -srcdir=$(HOME)/scm/ - udscm4: $(cfiles) $(hfiles) build.scm build - $(srcdir)build -hsystem -o udscm4 -s $(IMPLPATH) -Fcautious \ - bignums arrays inexact engineering-notation dump dynamic-linking + $(BUILD) -o udscm4 -s $(IMPLPATH) \ + -Fcautious bignums arrays inexact dump dynamic-linking \ + engineering-notation rm $(ofiles) scmmain.o -udscm5: $(cfiles) $(hfiles) build.scm build - $(srcdir)build -hsystem -o udscm5 -l debug -s $(IMPLPATH) -Fcautious \ - bignums arrays inexact engineering-notation dump dynamic-linking \ - macro #-DNO_SYM_GC +udscm5: $(cfiles) $(hfiles) build.scm build Makefile + $(BUILD) -o udscm5 -s $(IMPLPATH) \ + -Fcautious bignums arrays inexact dump dynamic-linking \ + macro engineering-notation #-DNO_SYM_GC rm $(ofiles) scmmain.o myscm4: udscm4 $(ifiles) require.scm @@ -127,87 +147,104 @@ myscm4: udscm4 $(ifiles) require.scm -mv scm scm~ echo "(quit)" | ./udscm4 -no-init-file -o scm -myscm: udscm5 $(ifiles) require.scm +myscm5: udscm5 $(ifiles) require.scm -rm slibcat implcat -mv scm scm~ echo "(quit)" | ./udscm5 -no-init-file -r5 -o scm $(MAKE) check + $(MAKE) checkmacro + +scm: scmlit + $(BUILD) -s $(IMPLPATH) -Fcautious bignums arrays + $(MAKE) check mylib: libscm.a libscm.a: - $(srcdir)build -hsystem -Fcautious bignums arrays inexact \ + $(BUILD) -Fcautious bignums arrays inexact \ dynamic-linking -t lib libtest: libscm.a libtest.c gcc -o libtest libtest.c libscm.a -ldl -lm -lc ./libtest pgscm: - $(srcdir)build -hsystem -s $(IMPLPATH) -Fcautious bignums arrays \ + $(BUILD) -s $(IMPLPATH) -Fcautious bignums arrays \ inexact engineering-notation dump dynamic-linking -o udscm \ --compiler-options=-pg --linker-options=-pg -DLACK_SETITIMER echo "(quit)" | ./udscm -no-init-file -o pgscm mydebug: - $(srcdir)build -hsystem -oudgdbscm -s $(IMPLPATH) -F cautious \ - bignums arrays inexact engineering-notation dump dynamic-linking \ - macro \ - debug --compiler-options=-Wall --linker-options=-Wall #-DTEST_FARLOC + $(BUILD) -oudgdbscm -s $(IMPLPATH) \ + -F cautious bignums arrays inexact engineering-notation dump \ + dynamic-linking macro debug \ + --compiler-options=-Wall --linker-options=-Wall \ + -DNO_ENV_CACHE #-DTEST_FARLOC -DTEST_SCM2PTR echo "(quit)" | ./udgdbscm -no-init-file -r5 -o gdbscm incdir=/usr/include/ -x11.scm: inc2scm Makefile +x11.scm: inc2scm rm -f x11.scm - ./inc2scm x11.scm x: $(incdir) X11/X.h X11/cursorfont.h X11/Xlib.h X11/Xutil.h -xevent.h: xgen.scm - ./xgen.scm $(incdir)X11/Xlib.h + $(SCMLIT) -l inc2scm x11.scm x: $(incdir) X11/X.h X11/cursorfont.h X11/Xlib.h \ + X11/Xutil.h +keysymdef.scm: inc2scm + rm -f keysymdef.scm + $(SCMLIT) -l inc2scm keysymdef.scm x: $(incdir) X11/keysym.h X11/keysymdef.h +xevent.h xevent.scm xatoms.scm: xgen.scm Makefile + $(SCMLIT) -l xgen.scm $(incdir)X11/Xlib.h x.h: x.c xevent.h - $(CPROTO) x.c > x.h + if [ ! -z "$(CPROTO)" ]; then $(CPROTO) x.c > x.h; fi x.so: x.c x.h xevent.h - $(srcdir)build -h system -Fx -t dll --compiler-options=-Wall -mydlls: x.so + $(BUILD) -Fx -t dll --compiler-options=-Wall +mydlls: if [ -f /usr/lib/libreadline.so ]; \ - then $(srcdir)build -h system -Fedit-line -t dll;fi - $(srcdir)build -h system -Fcurses -t dll - $(srcdir)build -h system -t dll -c sc2.c rgx.c record.c gsubr.c \ + then $(BUILD) -Fedit-line -t dll; fi + $(BUILD) -Fcurses -t dll + $(BUILD) -t dll -c sc2.c rgx.c record.c gsubr.c \ ioext.c posix.c unix.c socket.c ramap.c myturtle: - $(srcdir)build -h system -F turtlegr -t dll + $(BUILD) -Fturtlegr -t dll implcat: *.so mkimpcat.scm - ./scmlit -lmkimpcat.scm + $(SCMLIT) -lmkimpcat.scm checklit: - ./scmlit -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' + $(SCMLIT) -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' \ + -e '(or (null? errs) (quit 1))' check: r4rstest.scm - ./scm -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' + $(SCMEXE) -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' \ + -e '(or (null? errs) (quit 1))' +checkmacro: syntest1.scm syntest2.scm r4rstest.scm + $(SCMEXE) -rmacro -fsyntest1.scm -fsyntest2.scm \ + -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)' -fsyntest1 \ + -e '(or (null? errs) (quit 1))' bench: echo `whoami`@`hostname` testing scm \ - `scm -e'(display *scm-version*)'` >> BenchLog + `$(SCMEXE) -e'(display *scm-version*)'` >> BenchLog echo on `date` >> BenchLog ls -l scm >> BenchLog size scm >> BenchLog uname -a >> BenchLog - ./scm -lbench.scm + $(SCMEXE) -lbench.scm cat bench.log >> BenchLog echo >> BenchLog echo tail -20 BenchLog benchlit: echo `whoami`@`hostname` testing scmlit \ - `scmlit -e'(display *scm-version*)'` >> BenchLog + `$(SCMLIT) -e'(display *scm-version*)'` >> BenchLog echo on `date` >> BenchLog ls -l scmlit >> BenchLog size scmlit >> BenchLog uname -a >> BenchLog - ./scmlit -lbench.scm + $(SCMLIT) -lbench.scm cat bench.log >> BenchLog echo >> BenchLog echo tail -20 BenchLog report: - ./scmlit -e"(slib:report #t)" - scm -e"(slib:report #t)" + $(SCMLIT) -e"(slib:report #t)" + $(SCMEXE) -e"(slib:report #t)" +htmldir=../public_html/ dvidir=../dvi/ -dvi: $(dvidir)scm.dvi $(dvidir)Xlibscm.dvi +dvi: $(dvidir)scm.dvi $(dvidir)Xlibscm.dvi $(dvidir)hobbit.dvi $(dvidir)scm.dvi: version.txi scm.texi platform.txi features.txi\ $(dvidir)scm.fn Makefile # cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)scm.texi @@ -215,36 +252,77 @@ $(dvidir)scm.dvi: version.txi scm.texi platform.txi features.txi\ cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)scm.texi $(dvidir)scm.fn: cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)scm.texi -$(dvidir)Xlibscm.dvi: version.txi Xlibscm.texi \ - $(dvidir)Xlibscm.fn Makefile +$(dvidir)Xlibscm.dvi: version.txi Xlibscm.texi $(dvidir)Xlibscm.fn Makefile # cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)Xlibscm.texi -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex Xlibscm.??) cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)Xlibscm.texi $(dvidir)Xlibscm.fn: cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)Xlibscm.texi +$(dvidir)hobbit.dvi: version.txi hobbit.texi $(dvidir)hobbit.fn Makefile +# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)hobbit.texi + -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex hobbit.??) + cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)hobbit.texi +$(dvidir)hobbit.fn: + cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)hobbit.texi xdvi: $(dvidir)scm.dvi xdvi -s 6 $(dvidir)scm.dvi Xdvi: $(dvidir)Xlibscm.dvi xdvi -s 6 $(dvidir)Xlibscm.dvi - -htmldir=../public_html/ -html: $(htmldir)scm_toc.html $(htmldir)Xlibscm_toc.html +hobdvi: $(dvidir)hobbit.dvi + xdvi -s 6 $(dvidir)hobbit.dvi + +pdf: $(htmldir)scm.pdf $(htmldir)Xlibscm.pdf $(htmldir)hobbit.pdf +$(htmldir)scm.pdf: version.txi scm.texi platform.txi features.txi\ + $(dvidir)scm.fn Makefile + cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)scm.texi + mv $(dvidir)scm.pdf $(htmldir) +$(htmldir)Xlibscm.pdf: version.txi Xlibscm.texi $(dvidir)Xlibscm.fn Makefile + cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)Xlibscm.texi + mv $(dvidir)Xlibscm.pdf $(htmldir) +$(htmldir)hobbit.pdf: version.txi hobbit.texi $(dvidir)hobbit.fn Makefile + cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)hobbit.texi + mv $(dvidir)hobbit.pdf $(htmldir) +xpdf: $(htmldir)scm.pdf + xpdf -z 3 $(htmldir)scm.pdf +Xpdf: $(htmldir)Xlibscm.pdf + xpdf -z 3 $(htmldir)Xlibscm.pdf +hobpdf: $(htmldir)hobbit.pdf + xpdf -z 3 $(htmldir)hobbit.pdf + +PREVDOCS = prevdocs/ +html: $(htmldir)scm_toc.html $(htmldir)Xlibscm_toc.html $(htmldir)hobbit_toc.html scm_toc.html: version.txi scm.texi platform.txi features.txi texi2html -split -verbose scm.texi -Xlibscm_toc.html: $(htmldir)Xlibscm_toc.html -$(htmldir)Xlibscm_toc.html: version.txi Xlibscm.texi - cd $(htmldir);texi2html -split -verbose $(srcdir)Xlibscm.texi - -scmprev/scm_toc.html: -# cd scmprev;make scm_toc.html - cd scmprev;texi2html -split -verbose scm.texi - -$(htmldir)scm_toc.html: scmprev/scm_toc.html scm_toc.html Makefile - hitch scmprev/scm_\*.html scm_\*.html $(htmldir) +Xlibscm_toc.html: version.txi Xlibscm.texi + texi2html -split -verbose Xlibscm.texi +hobbit_toc.html: version.txi hobbit.texi + texi2html -split -verbose hobbit.texi + +$(htmldir)scm_toc.html: scm_toc.html Makefile + -rm -f scm_stoc.html + if [ -f $(PREVDOCS)scm_toc.html ]; \ + then hitch $(PREVDOCS)scm_\*.html scm_\*.html $(htmldir); \ + else cp scm_*.html $(htmldir); fi +$(htmldir)Xlibscm_toc.html: Xlibscm_toc.html Makefile + -rm -f Xlibscm_stoc.html + cp Xlibscm_*.html $(htmldir) +$(htmldir)hobbit_toc.html: hobbit_toc.html Makefile + -rm -f hobbit_stoc.html + cp hobbit_*.html $(htmldir) + +$(PREVDOCS)scm_toc.html: +$(PREVDOCS)scm.info: srcdir.mk Makefile + cd $(PREVDOCS); unzip -a $(dest)scm*.zip + rm $(PREVDOCS)scm/scm.info + cd $(PREVDOCS)scm; make scm.info; make scm_toc.html + cd $(PREVDOCS); mv -f scm/scm.info scm/*.html ./ + rm -rf $(PREVDOCS)scm ################ INSTALL DEFINITIONS ################ +rpm_prefix=/usr/src/redhat/ + prefix = /usr/local/ exec_prefix = $(prefix) # directory where `make install' will put executable. @@ -258,23 +336,22 @@ infodir = $(prefix)info/ includedir = $(prefix)include/ README: build build.scm scm.info - scm -l build -e"(make-readme)" + $(SCMEXE) -l build -e"(make-readme)" info: installinfo -installinfo: $(infodir)scm.info $(infodir)Xlibscm.info +installinfo: $(infodir)scm.info $(infodir)Xlibscm.info $(infodir)hobbit.info platform.txi: build.scm - ./scmlit -r database-browse -l build.scm -e "(browse build 'platform)" \ + $(SCMLIT) -r database-browse -l build.scm -e "(browse build 'platform)" \ > platform.txi -features.txi: build.features build.scm - ./scmlit -l build.features -e"(make-features-txi)" -scm$(VERSION).info: version.txi scm.texi platform.txi features.txi - -mv scm.info scmtemp.info +features.txi: build build.scm + $(SCMLIT) -l build -e"(make-features-txi)" +scm.info: version.txi scm.texi platform.txi features.txi makeinfo scm.texi --no-split -o scm.info mv scm.info scm$(VERSION).info - -mv scmtemp.info scm.info -scm.info: scm$(VERSION).info -# infobar scmprev/scm.info scm$(VERSION).info scm.info + if [ -f $(PREVDOCS)scm.info ]; \ + then infobar $(PREVDOCS)scm.info scm$(VERSION).info scm.info; \ + else cp scm$(VERSION).info scm.info; fi $(infodir)scm.info: scm.info cp -p scm.info $(infodir)scm.info -install-info $(infodir)scm.info $(infodir)dir @@ -282,45 +359,52 @@ $(infodir)scm.info: scm.info Xlibscm.info: version.txi Xlibscm.texi makeinfo Xlibscm.texi --no-split -o Xlibscm.info -$(infodir)Xlibscm.info: +$(infodir)Xlibscm.info: Xlibscm.info cp Xlibscm.info $(infodir)Xlibscm.info -install-info $(infodir)Xlibscm.info $(infodir)/dir -rm $(infodir)Xlibscm.info*.gz +hobbit.info: version.txi hobbit.texi + makeinfo hobbit.texi --no-split -o hobbit.info +$(infodir)hobbit.info: hobbit.info + cp hobbit.info $(infodir)hobbit.info + -install-info $(infodir)hobbit.info $(infodir)/dir + -rm $(infodir)hobbit.info*.gz + infoz: installinfoz -installinfoz: $(infodir)scm.info.gz $(infodir)Xlibscm.info.gz +installinfoz: $(infodir)scm.info.gz $(infodir)Xlibscm.info.gz $(infodir)hobbit.info.gz $(infodir)scm.info.gz: $(infodir)scm.info gzip -f $(infodir)scm.info $(infodir)Xlibscm.info.gz: $(infodir)Xlibscm.info gzip -f $(infodir)Xlibscm.info +$(infodir)hobbit.info.gz: $(infodir)hobbit.info + gzip -f $(infodir)hobbit.info install: scm.1 test -d $(bindir) || mkdir $(bindir) test -d $(mandir) || mkdir $(mandir) test -d $(man1dir) || mkdir $(man1dir) - -cp scm $(bindir) -# -strip $(bindir)scm + -cp scm scmlit $(bindir) + -strip $(bindir)scmlit -cp scm.1 $(man1dir) test -d $(libdir) || mkdir $(libdir) test -d $(libscmdir) || mkdir $(libscmdir) - -cp Init$(VERSION).scm Link.scm Transcen.scm Macro.scm Tscript.scm \ - COPYING $(libscmdir) + -cp $(ifiles) $(hobfiles) COPYING r4rstest.scm $(libscmdir) test -f $(libscmdir)require.scm || \ cp requires.scm $(libscmdir)require.scm - -cp mkimpcat.scm Iedline.scm *.sl *.so $(libscmdir) + -cp build build.scm mkimpcat.scm Iedline.scm *.sl *.so $(xafiles)\ + $(libscmdir) installlib: test -d $(includedir) || mkdir $(includedir) - cp scm.h $(includedir)scm.h - cp scmfig.h $(includedir)scmfig.h + cp scm.h scmfig.h scmflags.h $(includedir) test -d $(libdir) || mkdir $(libdir) cp libscm.a $(libdir)libscm.a uninstall: -rm $(bindir)scm -rm $(man1dir)scm.1 - -rm $(includedir)scm.h - -rm $(includedir)scmfig.h + -rm $(includedir)scm.h $(includedir)scmfig.h $(includedir)scmflags.h -rm $(libdir)libscm.a # -rm $(libscmdir)Init$(VERSION).scm # -rm $(libscmdir)Link.scm @@ -350,18 +434,20 @@ confiles = scmconfig.h.in mkinstalldirs acconfig-1.5.h install-sh \ configure configure.in Makefile.in COPYING README.unix hfiles = scm.h scmfig.h setjump.h patchlvl.h continue.h -tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm +tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm \ + syntest2.scm syntest1.scm dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \ - scm.info scm.texi Xlibscm.info Xlibscm.texi ChangeLog + scm.info scm.texi Xlibscm.info Xlibscm.texi hobbit.info hobbit.texi \ + ChangeLog mfiles = Makefile build.scm build build.bat requires.scm \ - .gdbinit mkimpcat.scm disarm.scm + .gdbinit mkimpcat.scm disarm.scm scm.spec vfiles = setjump.mar setjump.s afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \ - $(vfiles) $(ufiles) $(xfiles) + $(hobfiles) $(vfiles) $(ufiles) $(xfiles) makedev = make -f $(HOME)/makefile.dev CHPAT=$(HOME)/bin/chpat -RSYNC=rsync -v --rsync-path bin/rsync +RSYNC=rsync -avessh dest = $(HOME)/dist/ temp/scm: $(afiles) -$(RM_R) temp @@ -369,10 +455,13 @@ temp/scm: $(afiles) mkdir temp/scm ln $(afiles) temp/scm -release: dist - cp $(srcdir)ANNOUNCE $(htmldir)SCM_ANNOUNCE - $(RSYNC) $(htmldir)SCM.html $(htmldir)SCM_ANNOUNCE nestle.ai.mit.edu:public_html/ - $(RSYNC) $(dest)README $(dest)scm$(VERSION).zip nestle.ai.mit.edu:dist/ +release: dist rpm + cvs tag -F scm$(VERSION) + cp $(srcdir)ANNOUNCE $(htmldir)SCM_ANNOUNCE.txt + $(RSYNC) $(htmldir)SCM.html $(htmldir)SCM_ANNOUNCE.txt nestle.ai.mit.edu:public_html/ + $(RSYNC) $(dest)README $(dest)scm$(VERSION).zip \ + $(dest)scm-$(VERSION)-$(RELEASE).src.rpm $(dest)scm-$(VERSION)-$(RELEASE).i386.rpm \ + nestle.ai.mit.edu:dist/ # upload $(dest)README $(dest)scm$(VERSION).zip ftp.gnu.org:gnu/jacal/ # $(MAKE) indiana indiana: @@ -385,7 +474,7 @@ indiana: postnews: echo -e "Newsgroups: comp.lang.scheme\n" | cat - ANNOUNCE | \ inews -h -O -S \ - -f "announce@docupress.com (Aubrey Jaffer & Radey Shouman)" \ + -f "announce@voluntocracy.org (Aubrey Jaffer & Radey Shouman)" \ -t "SCM$(VERSION) Released" -d world upzip: $(HOME)/pub/scm.zip @@ -394,7 +483,15 @@ upzip: $(HOME)/pub/scm.zip dist: $(dest)scm$(VERSION).zip $(dest)scm$(VERSION).zip: temp/scm $(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) zip - cvs tag -F scm$(VERSION) + +rpm: pubzip +# $(dest)scm-$(VERSION)-$(RELEASE).i386.rpm: $(dest)scm$(VERSION).zip + cp -f $(HOME)/pub/scm.zip $(rpm_prefix)SOURCES/scm$(VERSION).zip + rpm -ba scm.spec # --clean + rm $(rpm_prefix)SOURCES/scm$(VERSION).zip + mv $(rpm_prefix)RPMS/i386/scm-$(VERSION)-$(RELEASE).i386.rpm \ + $(rpm_prefix)SRPMS/scm-$(VERSION)-$(RELEASE).src.rpm $(dest) + shar: scm.shar scm.shar: temp/scm $(makedev) PROD=scm shar @@ -410,7 +507,7 @@ doszip: /c/scm/dist/scm$(VERSION).zip $(makedev) DEST=/c/scm/dist/ PROD=scm ver=$(VERSION) zip cd ..; zip -9ur /c/scm/dist/scm$(VERSION).zip \ scm/turtle scm/turtlegr.c scm/grtest.scm - zip -d /c/scm/dist/scm$(VERSION).zip scm/scm.info scm/Xlibscm.info + zip -d /c/scm/dist/scm$(VERSION).zip scm/scm.info scm/Xlibscm.info scm/hobbit.info pubzip: $(HOME)/pub/scm.zip $(HOME)/pub/scm.zip: temp/scm $(makedev) DEST=$(HOME)/pub/ PROD=scm zip @@ -421,45 +518,31 @@ pubdiffs: temp/scm distdiffs: temp/scm $(makedev) DEST=$(dest) PROD=scm ver=$(ver) distdiffs +CITERS = ANNOUNCE ../jacal/ANNOUNCE \ + ../wb/README ../wb/ANNOUNCE ../synch/ANNOUNCE \ + $(htmldir)README.html ../dist/README \ + $(htmldir)SLIB.html $(htmldir)JACAL.html \ + $(htmldir)SCM.html $(htmldir)SIMSYNCH.html \ + ../jacal/jacal.texi ../wb/wb.texi \ + /c/scm/dist/install.bat /c/scm/dist/makefile \ + /c/scm/dist/mkdisk.bat hobbit.texi hobbit.scm + +updates: Init$(ver).scm + $(CHPAT) scm$(VERSION) scm$(ver) $(CITERS) + $(CHPAT) scm-$(VERSION) scm-$(ver) $(CITERS) + $(CHPAT) $(VERSION) $(ver) ../wb/wb.spec $(htmldir)SCM.html scm.spec + +Init$(ver).scm: + mv -f Init$(VERSION).scm Init$(ver).scm + $(CHPAT) $(VERSION) $(ver) patchlvl.h Init$(ver).scm -HOBBITVERSION = 5x -hobfiles = README.hob hobbit.doc hobbit.tms hobbit.scm scmhob.h -#hobfiles = hobbit.doc COPYING Makefile.hob hobbit.scm scmhob.h scmhob.scm - -hobtemp/scm: $(hobfiles) - -$(RM_R) hobtemp - mkdir hobtemp - mkdir hobtemp/scm - ln $(hobfiles) hobtemp/scm - -hobdist: $(dest)hobbit$(HOBBITVERSION).zip -$(dest)hobbit$(HOBBITVERSION).zip: hobtemp/scm - $(makedev) DEST=$(dest) PROD=scm ver=-hob$(HOBBITVERSION) \ - zip TEMP=hobtemp/ - mv $(dest)scm-hob$(HOBBITVERSION).zip \ - $(dest)hobbit$(HOBBITVERSION).zip -hobbit$(HOBBITVERSION).zip: hobtemp/scm - $(makedev) TEMP=hobtemp/ name=hobbit$(HOBBITVERSION) PROD=scm zip - -new: - echo `date` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change +new: updates + echo `date -I` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change echo>> change echo \ \* patchlvl.h \(SCMVERSION\): Bumped from $(VERSION) to $(ver).>>change echo>> change cat ChangeLog >> change mv -f change ChangeLog - $(CHPAT) scm$(VERSION) scm$(ver) ANNOUNCE ../jacal/ANNOUNCE \ - ../wb/README ../wb/ANNOUNCE \ - $(htmldir)README.html ../dist/README \ - $(htmldir)SLIB.html $(htmldir)JACAL.html \ - $(htmldir)SCM.html $(htmldir)Hobbit.html \ - $(htmldir)SIMSYNCH.html \ - /c/scm/dist/install.bat /c/scm/dist/makefile \ - /c/scm/dist/mkdisk.bat hobbit.doc - cp -f hobbit.doc $(htmldir)hobbit.txt - mv -f Init$(VERSION).scm Init$(ver).scm - $(CHPAT) $(VERSION) $(ver) patchlvl.h \ - Init$(ver).scm $(htmldir)SCM.html cvs remove Init$(VERSION).scm cvs add Init$(ver).scm cvs commit -m 'Init$(VERSION).scm changed to Init$(ver).scm' \ @@ -505,23 +588,24 @@ name8s: scmlit }else p=1;\ l=$$1\ }END{exit stat}' - -ctags: $(hfiles) $(cfiles) $(xfiles) - etags $(hfiles) $(cfiles) $(xfiles) -TAGS: -tags: $(hfiles) $(cfiles) $(ifiles) $(vfiles) turtlegr.c\ - version.txi scm.texi Xlibscm.texi build.scm build $(xfiles) -# # $(ufiles) $(mfiles) ChangeLog hobbit.scm - etags $(hfiles) $(cfiles) $(ifiles) $(vfiles) turtlegr.c\ - Xlibscm.texi scm.texi build.scm build $(xfiles) -# # $(ufiles) $(mfiles) ChangeLog hobbit.scm + +ctagfiles = $(hfiles) $(cfiles) $(xfiles) +ctags: $(ctagfiles) + etags $(ctagfiles) + +TAGFILES = $(hfiles) $(cfiles) $(ifiles) $(vfiles)\ + version.txi scm.texi Xlibscm.texi hobbit.texi build $(xfiles) $(mfiles) +# # $(ufiles) ChangeLog hobbit.scm +TAGS: $(TAGFILES) + etags $(TAGFILES) +tags: TAGS + mostlyclean: clean: -rm -f core a.out ramap.o ramap.obj $(ofiles) scmmain.o lints -$(RM_R) *temp - -rm -f scm$(VERSION).info - distclean: clean - -rm -f $(EXECFILES) *.o *.obj a.out implcat slibcat gdbscm TAGS + -rm -f $(EXECFILES) *.o *.obj a.out TAGS implcat slibcat gdbscm realclean: distclean -rm -f scm.doc realempty: temp/scm @@ -1,90 +1,93 @@ -This directory contains the distribution of scm5d2. Scm conforms to +This directory contains the distribution of scm5d6. Scm conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. SCM runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Unix and similar systems. - `http://swissnet.ai.mit.edu/~jaffer/SCM.html' + <http://swissnet.ai.mit.edu/~jaffer/SCM.html> Manifest ======== -`.gdbinit' provides commands for debugging SCM with GDB -`COPYING' details the LACK OF WARRANTY for SCM and the conditions - for distributing SCM. -`ChangeLog' changes to SCM. -`Iedline.scm' Gnu readline input editing. -`Init.scm' Scheme initialization. -`Link.scm' compiles and dynamically links. -`Macro.scm' Supports Syntax-Rules Macros. -`Makefile' builds SCMLIT using the `make' program. -`QUICKREF' Quick Reference card for R4RS and IEEE Scheme. -`README' contains a MANIFEST, INSTALLATION INSTRUCTIONS, hints - for EDITING SCHEME CODE, and a TROUBLE SHOOTING GUIDE. -`Transcen.scm' inexact builtin procedures. -`bench.scm' computes and records performance statistics of pi.scm. -`build.bat' invokes build.scm for MS-DOS -`build.scm' database for compiling and linking new SCM programs. -`continue.c' continuations. -`continue.h' continuations. -`crs.c' interactive terminal control. -`dynl.c' dynamically load object files. -`ecrt0.c' discover the start of initialized data space - dynamically at runtime. -`edline.c' Gnu readline input editing (get - ftp.sys.toronto.edu:/pub/rc/editline.shar). -`eval.c' evaluator, apply, map, and foreach. -`example.scm' example from R4RS which uses inexact numbers. -`findexec.c' find the executable file function. -`gmalloc.c' Gnu malloc(); used for unexec. -`gsubr.c' make_gsubr for arbitrary (< 11) arguments to C - functions. -`ioext.c' system calls in common between PC compilers and unix. -`mkimpcat.scm' build SCM-specific catalog for SLIB. -`patchlvl.h' patchlevel of this release. -`pi.c' computes digits of pi [cc -o pi pi.c;time pi 100 5]. -`pi.scm' computes digits of pi [type (pi 100 5)]. Test - performance against pi.c. -`posix.c' posix library interface. -`pre-crt0.c' loaded before crt0.o on machines which do not remap - part of the data space into text space in unexec. -`r4rstest.scm' tests conformance with Scheme specifications. -`ramap.c' array mapping -`record.c' proposed `Record' user definable datatypes. -`repl.c' error, read-eval-print loop, read, write and load. -`rgx.c' string regular expression match. -`rope.c' C interface functions. -`sc2.c' procedures from R2RS and R3RS not in R4RS. -`scl.c' inexact arithmetic -`scm.1' unix style man page. -`scm.c' initialization, interrupts, and non-IEEE utility - functions. -`scm.doc' man page generated from scm.1. -`scm.h' data type and external definitions of SCM. -`scm.texi' SCM installation and use. -`scmfig.h' contains system dependent definitions. -`scmmain.c' initialization, interrupts, and non-IEEE utility - functions. -`script.c' utilities for running as `#!' script. -`setjump.h' continuations, stacks, and memory allocation. -`setjump.mar' provides setjump and longjump which do not use $unwind - utility on VMS. -`setjump.s' provides setjump and longjump for the Cray YMP. -`socket.c' BSD socket interface. -`split.scm' example use of crs.c. Input, output, and diagnostic - output directed to separate windows. -`subr.c' the rest of IEEE functions. -`sys.c' call-with-current-continuation, opening and closing - files, storage allocation and garbage collection. -`time.c' functions dealing with time. -`ugsetjump.s' provides setjump and longjump which work on Ultrix VAX. -`unexalpha.c' Convert a running program into an Alpha executable file. -`unexec.c' Convert a running program into an executable file. -`unexelf.c' Convert a running ELF program into an executable file. -`unexhp9k800.c' Convert a running HP-UX program into an executable file. -`unexsgi.c' Convert a running program into an IRIX executable file. -`unexsunos4.c' Convert a running program into an executable file. -`unif.c' uniform vectors. -`unix.c' non-posix system calls on unix systems. +`.gdbinit' provides commands for debugging SCM with GDB +`COPYING' details the LACK OF WARRANTY for SCM and the conditions + for distributing SCM. +`ChangeLog' changes to SCM. +`Iedline.scm' Gnu readline input editing. +`Init.scm' Scheme initialization. +`Link.scm' Dynamic link/loading. +`Macro.scm' Supports Syntax-Rules Macros. +`Makefile' builds SCMLIT using the `make' program. +`QUICKREF' Quick Reference card for R4RS and IEEE Scheme. +`README' contains a MANIFEST, INSTALLATION INSTRUCTIONS, hints + for EDITING SCHEME CODE, and a TROUBLE SHOOTING GUIDE. +`Transcen.scm' inexact builtin procedures. +`bench.scm' computes and records performance statistics of pi.scm. +`build.bat' invokes build.scm for MS-DOS +`build.scm' database for compiling and linking new SCM programs. +`compile.scm' Hobbit compilation to C. +`continue.c' continuations. +`continue.h' continuations. +`crs.c' interactive terminal control. +`debug.c' debugging, printing code. +`dynl.c' dynamically load object files. +`ecrt0.c' discover the start of initialized data space + dynamically at runtime. +`edline.c' Gnu readline input editing (get + ftp.sys.toronto.edu:/pub/rc/editline.shar). +`eval.c' evaluator, apply, map, and foreach. +`example.scm' example from R4RS which uses inexact numbers. +`findexec.c' find the executable file function. +`gmalloc.c' Gnu malloc(); used for unexec. +`gsubr.c' make_gsubr for arbitrary (< 11) arguments to C + functions. +`ioext.c' system calls in common between PC compilers and unix. +`mkimpcat.scm' build SCM-specific catalog for SLIB. +`patchlvl.h' patchlevel of this release. +`pi.c' computes digits of pi [cc -o pi pi.c;time pi 100 5]. +`pi.scm' computes digits of pi [type (pi 100 5)]. Test + performance against pi.c. +`posix.c' posix library interface. +`pre-crt0.c' loaded before crt0.o on machines which do not remap + part of the data space into text space in unexec. +`r4rstest.scm' tests conformance with Scheme specifications. +`ramap.c' array mapping +`record.c' proposed `Record' user definable datatypes. +`repl.c' error, read-eval-print loop, read, write and load. +`rgx.c' string regular expression match. +`rope.c' C interface functions. +`sc2.c' procedures from R2RS and R3RS not in R4RS. +`scl.c' inexact arithmetic +`scm.1' unix style man page. +`scm.c' initialization, interrupts, and non-IEEE utility + functions. +`scm.doc' man page generated from scm.1. +`scm.h' data type and external definitions of SCM. +`scm.texi' SCM installation and use. +`scmfig.h' contains system dependent definitions. +`scmmain.c' initialization, interrupts, and non-IEEE utility + functions. +`script.c' utilities for running as `#!' script. +`setjump.h' continuations, stacks, and memory allocation. +`setjump.mar' provides setjump and longjump which do not use $unwind + utility on VMS. +`setjump.s' provides setjump and longjump for the Cray YMP. +`socket.c' BSD socket interface. +`split.scm' example use of crs.c. Input, output, and diagnostic + output directed to separate windows. +`subr.c' the rest of IEEE functions. +`sys.c' call-with-current-continuation, opening and closing + files, storage allocation and garbage collection. +`time.c' functions dealing with time. +`ugsetjump.s' provides setjump and longjump which work on Ultrix VAX. +`unexalpha.c' Convert a running program into an Alpha executable file. +`unexec.c' Convert a running program into an executable file. +`unexelf.c' Convert a running ELF program into an executable file. +`unexhp9k800.c' Convert a running HP-UX program into an executable file. +`unexsgi.c' Convert a running program into an IRIX executable file. +`unexsunos4.c' Convert a running program into an executable file. +`unif.c' uniform vectors. +`unix.c' non-posix system calls on unix systems. + File: scm.info, Node: SLIB, Next: Building SCM, Prev: Making SCM, Up: Installing SCM @@ -94,22 +97,22 @@ SLIB [SLIB] is a portable Scheme library meant to provide compatibility and utility functions for all standard Scheme implementations. Although -SLIB is not *neccessary* to run SCM, I strongly suggest you obtain and +SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and install it. Bug reports about running SCM without SLIB have very low priority. SLIB is available from the same sites as SCM: - * swissnet.ai.mit.edu:/pub/scm/slib2c7.tar.gz + * swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz - * ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz + * ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz -Unpack SLIB (`tar xzf slib2c7.tar.gz' or `unzip -ao slib2c7.zip') in an +Unpack SLIB (`tar xzf slib2d4.tar.gz' or `unzip -ao slib2d4.zip') in an appropriate directory for your system; both `tar' and `unzip' will create the directory `slib'. Then create a file `require.scm' in the SCM "implementation-vicinity" -(this is the same directory as where the file `Init5d2.scm' is +(this is the same directory as where the file `Init5d6.scm' is installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") @@ -140,36 +143,25 @@ Making SCM ========== The SCM distribution has "Makefile" which contains rules for making -"scmlit", a "bare-bones" version of SCM sufficient for running -`build.scm'. `build.scm' is used to compile (or create scripts to -compile) full featured versions. +"scmlit", a "bare-bones" version of SCM sufficient for running `build'. +`build' is used to compile (or create scripts to compile) full +featured versions. Makefiles are not portable to the majority of platforms. If `Makefile' works for you, good; If not, I don't want to hear about it. If you -need to compile SCM without build.scm, there are several ways to -proceed: +need to compile SCM without build, there are several ways to proceed: - * Use SCM on a different platform to run `build.scm' to create a - script to build SCM; + * Use the build (http://swissnet.ai.mit.edu/~jaffer/buildscm.html) + web page to create custom batch scripts for compiling SCM. - * Use another implementation of Scheme to run `build.scm' to create a + * Use SCM on a different platform to run `build' to create a script + to build SCM; + + * Use another implementation of Scheme to run `build' to create a script to build SCM; * Create your own script or `Makefile'. - * Buy a SCM executable from jaffer @ ai.mit.edu. See the end of the - `ANNOUNCE' file in the distribution for details. - - * Use scmconfig (From: bos@scrg.cs.tcd.ie): - - Build and install scripts using GNU "autoconf" are available from - `scmconfig4e3.tar.gz' in the distribution directories. See - `README.unix' in `scmconfig4e3.tar.gz' for further instructions. - - *Note:* The last release of scmconfig (4e3) was on March 20, 1996. - I am moving it to the OLD subdirectory until someone submits an - update. - File: scm.info, Node: Editing Scheme Code, Next: Debugging Scheme Code, Prev: SCM Session, Up: Operational Features @@ -177,11 +169,11 @@ File: scm.info, Node: Editing Scheme Code, Next: Debugging Scheme Code, Prev: Editing Scheme Code =================== - - Function: ed ARG1 ... + - Function: ed arg1 ... The value of the environment variable `EDITOR' (or just `ed' if it isn't defined) is invoked as a command with arguments ARG1 .... - - Function: ed FILENAME + - Function: ed filename If SCM is compiled under VMS `ed' will invoke the editor with a single the single argument FILENAME. @@ -190,11 +182,11 @@ Gnu Emacs: files ending in .scm are automatically put into scheme-mode. EMACS for MS-DOS and MS-Windows systems is available (free) from: - `http://simtel.coast.net/SimTel/gnu/demacs.html' + <http://simtel.coast.net/SimTel/gnu/demacs.html> If your Emacs can run a process in a buffer you can use the Emacs -command `M-x run-scheme' with SCM. Otherwise, use the emacs command -`M-x suspend-emacs'; or see "other systems" below. + command `M-x run-scheme' with SCM. Otherwise, use the emacs + command `M-x suspend-emacs'; or see "other systems" below. Epsilon (MS-DOS): There is lisp (and scheme) mode available by use of the package @@ -213,7 +205,7 @@ Epsilon (MS-DOS): other systems: Define the environment variable `EDITOR' to be the name of the - editing program you use. The SCM procedure `(ed arg1 ...)' will + editing program you use. The SCM procedure `(ed arg1 ...)' will invoke your editor and return to SCM when you exit the editor. The following definition is convenient: @@ -229,32 +221,32 @@ File: scm.info, Node: Problems Compiling, Next: Problems Linking, Prev: Autom Problems Compiling ================== -FILE PROBLEM / MESSAGE HOW TO FIX -*.c include file not found. Correct the status of - STDC_HEADERS in scmfig.h. - fix #include statement or add - #define for system type to - scmfig.h. -*.c Function should return a value. Ignore. - Parameter is never used. - Condition is always false. - Unreachable code in function. -scm.c assignment between incompatible Change SIGRETTYPE in scm.c. - types. -time.c CLK_TCK redefined. incompatablility between - <stdlib.h> and <sys/types.h>. - Remove STDC_HEADERS in scmfig.h. - Edit <sys/types.h> to remove - incompatability. -subr.c Possibly incorrect assignment Ignore. - in function lgcd. -sys.c statement not reached. Ignore. - constant in conditional - expression. -sys.c undeclared, outside of #undef STDC_HEADERS in scmfig.h. - functions. -scl.c syntax error. #define SYSTNAME to your system - type in scl.c (softtype). +FILE PROBLEM / MESSAGE HOW TO FIX +*.c include file not found. Correct the status of + STDC_HEADERS in scmfig.h. + fix #include statement or add + #define for system type to + scmfig.h. +*.c Function should return a value. Ignore. + Parameter is never used. + Condition is always false. + Unreachable code in function. +scm.c assignment between incompatible Change SIGRETTYPE in scm.c. + types. +time.c CLK_TCK redefined. incompatablility between + <stdlib.h> and <sys/types.h>. + Remove STDC_HEADERS in scmfig.h. + Edit <sys/types.h> to remove + incompatability. +subr.c Possibly incorrect assignment Ignore. + in function lgcd. +sys.c statement not reached. Ignore. + constant in conditional + expression. +sys.c undeclared, outside of #undef STDC_HEADERS in scmfig.h. + functions. +scl.c syntax error. #define SYSTNAME to your system + type in scl.c (softtype). @@ -263,8 +255,8 @@ File: scm.info, Node: Problems Linking, Next: Problems Running, Prev: Problem Problems Linking ================ -PROBLEM HOW TO FIX -_sin etc. missing. Uncomment LIBS in makefile. +PROBLEM HOW TO FIX +_sin etc. missing. Uncomment LIBS in makefile. @@ -273,38 +265,38 @@ File: scm.info, Node: Problems Running, Next: Testing, Prev: Problems Linking Problems Running ================ -PROBLEM HOW TO FIX -Opening message and then machine Change memory model option to C -crashes. compiler (or makefile). - Make sure sizet definition is - correct in scmfig.h. - Reduce the size of HEAP_SEG_SIZE in - setjump.h. -Input hangs. #define NOSETBUF -ERROR: heap: need larger initial. Increase initial heap allocation - using -a<kb> or INIT_HEAP_SIZE. -ERROR: Could not allocate. Check sizet definition. - Use 32 bit compiler mode. - Don't try to run as subproccess. -remove <FLAG> in scmfig.h and Do so and recompile files. -recompile scm. -add <FLAG> in scmfig.h and -recompile scm. -ERROR: Init5d2.scm not found. Assign correct IMPLINIT in makefile - or scmfig.h. - Define environment variable - SCM_INIT_PATH to be the full - pathname of Init5d2.scm. -WARNING: require.scm not found. Define environment variable - SCHEME_LIBRARY_PATH to be the full - pathname of the scheme library - [SLIB]. - Change library-vicinity in - Init5d2.scm to point to library or - remove. - Make sure the value of - (library-vicinity) has a trailing - file separator (like / or \). +PROBLEM HOW TO FIX +Opening message and then machine Change memory model option to C +crashes. compiler (or makefile). + Make sure sizet definition is + correct in scmfig.h. + Reduce the size of HEAP_SEG_SIZE in + setjump.h. +Input hangs. #define NOSETBUF +ERROR: heap: need larger initial. Increase initial heap allocation + using -a<kb> or INIT_HEAP_SIZE. +ERROR: Could not allocate. Check sizet definition. + Use 32 bit compiler mode. + Don't try to run as subproccess. +remove <FLAG> in scmfig.h and Do so and recompile files. +recompile scm. +add <FLAG> in scmfig.h and +recompile scm. +ERROR: Init5d6.scm not found. Assign correct IMPLINIT in makefile + or scmfig.h. + Define environment variable + SCM_INIT_PATH to be the full + pathname of Init5d6.scm. +WARNING: require.scm not found. Define environment variable + SCHEME_LIBRARY_PATH to be the full + pathname of the scheme library + [SLIB]. + Change library-vicinity in + Init5d6.scm to point to library or + remove. + Make sure the value of + (library-vicinity) has a trailing + file separator (like / or \). @@ -333,13 +325,13 @@ of pi. > (load "pi") ;loading "pi" ;done loading "pi.scm" - ;Evaluation took 20 mSec (0 in gc) 767 cells work, 233 bytes other + ;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B other #<unspecified> > (pi 100 5) 00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 70679 - ;Evaluation took 550 mSec (60 in gc) 36976 cells work, 1548 bytes other + ;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other #<unspecified> Loading `bench.scm' will compute and display performance statistics of @@ -347,34 +339,34 @@ SCM running `pi.scm'. `make bench' or `make benchlit' appends the performance report to the file `BenchLog', facilitating tracking effects of changes to SCM on performance. -PROBLEM HOW TO FIX -Runs some and then machine crashes. See above under machine crashes. -Runs some and then ERROR: ... Remove optimization option to C -(after a GC has happened). compiler and recompile. - #define SHORT_ALIGN in `scmfig.h'. -Some symbol names print incorrectly. Change memory model option to C - compiler (or makefile). - Check that HEAP_SEG_SIZE fits - within sizet. - Increase size of HEAP_SEG_SIZE (or - INIT_HEAP_SIZE if it is smaller - than HEAP_SEG_SIZE). -ERROR: Rogue pointer in Heap. See above under machine crashes. -Newlines don't appear correctly in Check file mode (define OPEN_... in -output files. `Init5d2.scm'). -Spaces or control characters appear Check character defines in -in symbol names. `scmfig.h'. -Negative numbers turn positive. Check SRS in `scmfig.h'. -VMS: Couldn't unwind stack. #define CHEAP_CONTIUATIONS in - `scmfig.h'. -VAX: botched longjmp. +PROBLEM HOW TO FIX +Runs some and then machine crashes. See above under machine crashes. +Runs some and then ERROR: ... Remove optimization option to C +(after a GC has happened). compiler and recompile. + #define SHORT_ALIGN in `scmfig.h'. +Some symbol names print incorrectly. Change memory model option to C + compiler (or makefile). + Check that HEAP_SEG_SIZE fits + within sizet. + Increase size of HEAP_SEG_SIZE (or + INIT_HEAP_SIZE if it is smaller + than HEAP_SEG_SIZE). +ERROR: Rogue pointer in Heap. See above under machine crashes. +Newlines don't appear correctly in Check file mode (define OPEN_... in +output files. `Init5d6.scm'). +Spaces or control characters appear Check character defines in +in symbol names. `scmfig.h'. +Negative numbers turn positive. Check SRS in `scmfig.h'. +VMS: Couldn't unwind stack. #define CHEAP_CONTIUATIONS in + `scmfig.h'. +VAX: botched longjmp. Sparc(SUN-4) heap is growing out of control You are experiencing a GC problem peculiar to the Sparc. The problem is that SCM doesn't know how to clear register windows. Every location which is not reused still gets marked at GC time. This causes lots of stuff which should be collected to not be. - This will be a problem with any *conservative* GC until we find + This will be a problem with any _conservative_ GC until we find what instruction will clear the register windows. This problem is exacerbated by using lots of call-with-current-continuations. diff --git a/Transcen.scm b/Transcen.scm index 7898251..b0d1a2b 100644 --- a/Transcen.scm +++ b/Transcen.scm @@ -15,26 +15,26 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. @@ -43,6 +43,11 @@ (define compile-allnumbers #t) ;for HOBBIT compiler +(define $pi (* 4 ($atan 1))) +(define pi $pi) +(define (pi* z) (* $pi z)) +(define (pi/ z) (/ $pi z)) + (define (exp z) (if (real? z) ($exp z) (make-polar ($exp (real-part z)) (imag-part z)))) diff --git a/Xlibscm.info b/Xlibscm.info index 4c57ced..1052cba 100644 --- a/Xlibscm.info +++ b/Xlibscm.info @@ -1,5 +1,5 @@ -This is Info file Xlibscm.info, produced by Makeinfo version 1.68 from -the input file Xlibscm.texi. +This is Xlibscm.info, produced by makeinfo version 4.0 from +Xlibscm.texi. INFO-DIR-SECTION The Algorithmic Language Scheme START-INFO-DIR-ENTRY @@ -12,7 +12,7 @@ File: Xlibscm.info, Node: Top, Next: Xlibscm, Prev: (dir), Up: (dir) This manual documents the X - SCM Language X Interface. The most recent information about SCM can be found on SCM's "WWW" home page: - `http://swissnet.ai.mit.edu/~jaffer/SCM.html' + <http://swissnet.ai.mit.edu/~jaffer/SCM.html> Copyright (C) 1990-1999 Free Software Foundation @@ -33,19 +33,18 @@ approved by the author. * Menu: * Xlibscm:: -* Display:: -* Screen:: -* Window:: -* Window Visibility:: +* Display and Screens:: +* Drawables:: * Graphics Context:: * Cursor:: * Colormap:: * Rendering:: +* Images:: * Event:: * Index:: -File: Xlibscm.info, Node: Xlibscm, Next: Display, Prev: Top, Up: Top +File: Xlibscm.info, Node: Xlibscm, Next: Display and Screens, Prev: Top, Up: Top Xlibscm ******* @@ -111,12 +110,12 @@ the suitability of this documentation for any purpose. It is provided "as is" without express or implied warranty. -File: Xlibscm.info, Node: Display, Next: Screen, Prev: Xlibscm, Up: Top +File: Xlibscm.info, Node: Display and Screens, Next: Drawables, Prev: Xlibscm, Up: Top -Display -******* +Display and Screens +******************* - - Function: x:open-display DISPLAY-NAME + - Function: x:open-display display-name DISPLAY-NAME Specifies the hardware display name, which determines the display and communications domain to be used. On a POSIX-conformant system, if the display-name is #f, it defaults to @@ -142,7 +141,7 @@ Display SCREEN-NUMBER sets an internal variable that can be accessed by using the x:default-screen procedure. - - Function: x:close DISPLAY + - Function: x:close display DISPLAY specifies the connection to the X server. The `x:close' function closes the connection to the X server for @@ -155,39 +154,32 @@ Display generated. Before exiting, you should call X:CLOSE-DISPLAY or X:FLUSH explicitly so that any pending errors are reported. - - Function: x:protocol-version DISPLAY + - Function: x:protocol-version display Returns cons of the major version number (11) of the X protocol associated with the connected DISPLAY and the minor protocol revision number of the X server. - - Function: x:server-vendor DISPLAY + - Function: x:server-vendor display Returns a string that provides some identification of the owner of the X server implementation. The contents of the string are implementation-dependent. - - Function: x:vendor-release DISPLAY + - Function: x:vendor-release display Returns a number related to a vendor's release of the X server. - -File: Xlibscm.info, Node: Screen, Next: Window, Prev: Display, Up: Top - -Screen -****** - A display consists of one or more "Screen"s. Each screen has a -"root-window", "default-graphics-context", "default-visual", and -"colormap". +"root-window", "default-graphics-context", and "colormap". - - Function: x:screen-count DISPLAY + - Function: x:screen-count display Returns the number of available screens. - - Function: x:default-screen DISPLAY + - Function: x:default-screen display Returns the default screen number specified by the `x:open-display' function. Use this screen number in applications which will use only a single screen. - - Function: x:root-window DISPLAY SCREEN-NUMBER - - Function: x:root-window DISPLAY + - Function: x:root-window display screen-number + - Function: x:root-window display SCREEN-NUMBER, if givien, specifies the appropriate screen number on the host server. Otherwise the default-screen for DISPLAY is used. @@ -196,34 +188,40 @@ A display consists of one or more "Screen"s. Each screen has a `x:root-window' for functions that need a drawable of a particular screen or for creating top-level windows. - - Function: x:root-window WINDOW + - Function: x:root-window window Returns the root window for the specified WINDOW's screen. - - Function: x:default-colormap DISPLAY SCREEN-NUMBER - - Function: x:default-colormap DISPLAY - - Function: x:default-colormap WINDOW + - Function: x:default-colormap display screen-number + - Function: x:default-colormap display + - Function: x:default-colormap window Returns the default colormap of the specified screen. - - Function: x:default-gc DISPLAY SCREEN-NUMBER - - Function: x:default-gc DISPLAY - - Function: x:default-gc WINDOW + - Function: x:default-ccc display screen-number + - Function: x:default-ccc display + - Function: x:default-ccc window + Returns the default Color-Conversion-Context (ccc) of the specified + screen. + + - Function: x:default-gc display screen-number + - Function: x:default-gc display + - Function: x:default-gc window Returns the default graphics-context of the specified screen. - - Function: x:default-depths DISPLAY SCREEN-NUMBER - - Function: x:default-depths DISPLAY - - Function: x:default-depths WINDOW - Returns a vector of depths supported by the specified screen. + - Function: x:screen-depths display screen-number + - Function: x:screen-depths display + - Function: x:screen-depths window + Returns an array of depths supported by the specified screen. The "Visual" type describes possible colormap depths and arrangements. - - Function: x:default-visual DISPLAY SCREEN-NUMBER - - Function: x:default-visual DISPLAY - - Function: x:default-visual WINDOW + - Function: x:default-visual display screen-number + - Function: x:default-visual display + - Function: x:default-visual window Returns the default Visual type for the specified screen. - - Function: x:make-visual DISPLAY DEPTH CLASS - - Function: x:make-visual WINDOW DEPTH CLASS + - Function: x:make-visual display depth class + - Function: x:make-visual window depth class The integer DEPTH specifies the number of bits per pixel. The CLASS argument specifies one of the possible visual classes for a screen: @@ -242,52 +240,83 @@ The "Visual" type describes possible colormap depths and arrangements. `X:make-visual' returns a visual type for the screen specified by DISPLAY or WINDOW if successful; #f if not. + - Function: x:visual-class visual + - Function: x:visual-class screen + - Function: x:visual-class display + Returns the (integer) visual class of its argument. + + - Function: x:visual-geometry visual + - Function: x:visual-geometry screen + - Function: x:visual-geometry display + Returns a list of the: + * red_mask + + * green_mask - - Function: x:screen-cells DISPLAY SCREEN-NUMBER - - Function: x:screen-cells DISPLAY - - Function: x:screen-cells WINDOW + * blue_mask + + * colormap_size + + - Function: x:screen-cells display screen-number + - Function: x:screen-cells display + - Function: x:screen-cells window Returns the number of entries in the default colormap. - - Function: x:screen-depth DISPLAY SCREEN-NUMBER - - Function: x:screen-depth DISPLAY - - Function: x:screen-depth WINDOW + - Function: x:screen-depth display screen-number Returns the depth of the root window of the specified screen. + - Function: x:screen-depth display + - Function: x:screen-depth window + - Function: x:screen-depth visual + Returns the depth of argument. + The "depth" of a window or pixmap is the number of bits per pixel it has. The "depth" of a graphics context is the depth of the drawables it can be used in conjunction with graphics output. - - Function: x:screen-size DISPLAY SCREEN-NUMBER - - Function: x:screen-size DISPLAY - - Function: x:screen-size WINDOW + - Function: x:screen-size display screen-number + - Function: x:screen-size display + - Function: x:screen-size window Returns a list of integer height and width of the screen in pixels. - - Function: x:screen-dimensions DISPLAY SCREEN-NUMBER - - Function: x:screen-dimensions DISPLAY - - Function: x:screen-dimensions WINDOW + - Function: x:screen-dimensions display screen-number + - Function: x:screen-dimensions display + - Function: x:screen-dimensions window Returns a list of integer height and width of the screen in millimeters. - - Function: x:screen-white DISPLAY SCREEN-NUMBER - - Function: x:screen-white DISPLAY - - Function: x:screen-white WINDOW + - Function: x:screen-white display screen-number + - Function: x:screen-white display + - Function: x:screen-white window Returns the white pixel value of the specified screen. - - Function: x:screen-black DISPLAY SCREEN-NUMBER - - Function: x:screen-black DISPLAY - - Function: x:screen-black WINDOW + - Function: x:screen-black display screen-number + - Function: x:screen-black display + - Function: x:screen-black window Returns the black pixel value of the specified screen. -File: Xlibscm.info, Node: Window, Next: Window Visibility, Prev: Screen, Up: Top +File: Xlibscm.info, Node: Drawables, Next: Graphics Context, Prev: Display and Screens, Up: Top -Window -****** +Drawables +********* A "Drawable" is either a window or pixmap. - - Function: x:create-window WINDOW POSITION SIZE BORDER-WIDTH DEPTH - CLASS VISUAL FIELD-NAME VALUE ... +* Menu: + +* Windows and Pixmaps:: +* Window Attributes:: +* Window Properties and Visibility:: + + +File: Xlibscm.info, Node: Windows and Pixmaps, Next: Window Attributes, Prev: Drawables, Up: Drawables + +Windows and Pixmaps +=================== + + - Function: x:create-window window position size border-width depth + class visual field-name value ... Creates and returns an unmapped Input-Output subwindow for a specified parent WINDOW and causes the X server to generate a CreateNotify event. The created window is placed on top in the @@ -312,14 +341,14 @@ A "Drawable" is either a window or pixmap. The returned window will have the attributes specified by FIELD-NAMEs and VALUE. - - Function: x:create-window WINDOW POSITION SIZE BORDER-WIDTH BORDER - BACKGROUND + - Function: x:create-window window position size border-width border + background The returned window inherits its depth, class, and visual from its parent. All other window attributes, except BACKGROUND and BORDER, have their default values. - - Function: x:create-pixmap DRAWABLE SIZE DEPTH - - Function: x:create-pixmap DISPLAY SIZE DEPTH + - Function: x:create-pixmap drawable size depth + - Function: x:create-pixmap display size depth SIZE is a list, vector, or pair of nonzero integers specifying the width and height desired in the new pixmap. @@ -328,7 +357,7 @@ A "Drawable" is either a window or pixmap. drawable argument. The DEPTH argument must be one of the depths supported by the screen of the specified DRAWABLE. - - Function: x:close WINDOW + - Function: x:close window Destroys the specified WINDOW as well as all of its subwindows and causes the X server to generate a DestroyNotify event for each window. The window should not be used again. If the window @@ -342,21 +371,21 @@ A "Drawable" is either a window or pixmap. mapped WINDOW will generate x:Expose events on other windows that were obscured by the window being destroyed. - - Function: x:close PIXMAP + - Function: x:close pixmap Deletes the association between the PIXMAP and its storage. The X server frees the pixmap storage when there are no references to it. - - Function: x:window-geometry DRAWABLE + - Function: x:window-geometry drawable Returns a list of: coordinates - `cons' of x and y coordinates that define the location of the + `list' of x and y coordinates that define the location of the DRAWABLE. For a window, these coordinates specify the upper-left outer corner relative to its parent's origin. For pixmaps, these coordinates are always zero. size - `cons' of the DRAWABLE's dimensions (width and height). For + `list' of the DRAWABLE's dimensions (width and height). For a window, these dimensions specify the inside size, not including the border. @@ -367,16 +396,103 @@ A "Drawable" is either a window or pixmap. depth The depth of the DRAWABLE (bits per pixel for the object). - - Function: x:window-set! WINDOW FIELD-NAME VALUE ... + - Function: x:window-geometry-set! window field-name value ... + Changes the "Configuration" components specified by FIELD-NAMEs + for the specified WINDOW. + +These are the attributes settable by `x:window-geometry-set!'. That +these attributes are encoded by small integers - just like those of the +next section. Be warned therefore that confusion of attribute names +will likely not signal errors, just cause mysterious behavior. + + - Attribute: x:CWX + - Attribute: x:CWY + - Attribute: x:CW-Width + - Attribute: x:CW-Height + The x:CWX and x:CYY members are used to set the window's x and y + coordinates, which are relative to the parent's origin and + indicate the position of the upper-left outer corner of the + window. The x:CW-Width and x:CW-Height members are used to set + the inside size of the window, not including the border, and must + be nonzero. Attempts to configure a root window have no effect. + + If a window's size actually changes, the window's subwindows move + according to their window gravity. Depending on the window's bit + gravity, the contents of the window also may be moved + + - Attribute: x:CW-Border-Width + The integer x:CW-Border-Width is used to set the width of the + border in pixels. Note that setting just the border width leaves + the outer-left corner of the window in a fixed position but moves + the absolute position of the window's origin. It is an error to + set the border-width attribute of an InputOnly window nonzero. + + - Attribute: x:CW-Sibling + The sibling member is used to set the sibling window for stacking + operations. + + - Attribute: x:CW-Stack-Mode + The x:CW-Stack-Mode member is used to set how the window is to be + restacked and can be set to x:Above, x:Below, x:Top-If, + x:Bottom-If, or x:Opposite. + +If a sibling and a stack-mode are specified, the window is restacked as +follows: + +`x:Above' + The window is placed just above the sibling. + +`x:Below' + The window is placed just below the sibling. + +`x:Top-If' + If the sibling occludes the window, the window is placed at the + top of the stack. + +`x:Bottom-If' + If the window occludes the sibling, the window is placed at the + bottom of the stack. + +`x:Opposite' + If the sibling occludes the window, the window is placed at the + top of the stack. If the window occludes the sibling, the window + is placed at the bottom of the stack. + +If a stack-mode is specified but no sibling is specified, the window is +restacked as follows: + +`x:Above' + The window is placed at the top of the stack. + +`x:Below' + The window is placed at the bottom of the stack. + +`x:Top-If' + If any sibling occludes the window, the window is placed at the + top of the stack. + +`x:Bottom-If' + If the window occludes any sibling, the window is placed at the + bottom of the stack. + +`x:Opposite' + If any sibling occludes the window, the window is placed at the + top of the stack. If the window occludes any sibling, the window + is placed at the bottom of the stack. + + +File: Xlibscm.info, Node: Window Attributes, Next: Window Properties and Visibility, Prev: Windows and Pixmaps, Up: Drawables + +Window Attributes +================= + + - Function: x:window-set! window field-name value ... Changes the components specified by FIELD-NAMEs for the specified WINDOW. The restrictions are the same as for `x:create-window'. The order in which components are verified and altered is server dependent. If an error occurs, a subset of the components may have been altered. -Window Attributes -================= - The `x:create-window' and `x:window-set!' procedures take five and one argument (respectively) followed by pairs of arguments, where the first is one of the property-name symbols (or its top-level value) listed @@ -427,16 +543,16 @@ below; and the second is the value to associate with that property. children to be reconfigured (depending on their win-gravity). For a change of width and height, the (x, y) pairs are defined: - Gravity Direction Coordinates - x:North-West-Gravity (0, 0) - x:North-Gravity (Width/2, 0) - x:North-East-Gravity (Width, 0) - x:West-Gravity (0, Height/2) - x:Center-Gravity (Width/2, Height/2) - x:East-Gravity (Width, Height/2) - x:South-West-Gravity (0, Height) - x:South-Gravity (Width/2, Height) - x:South-East-Gravity (Width, Height) + Gravity Direction Coordinates + x:North-West-Gravity (0, 0) + x:North-Gravity (Width/2, 0) + x:North-East-Gravity (Width, 0) + x:West-Gravity (0, Height/2) + x:Center-Gravity (Width/2, Height/2) + x:East-Gravity (Width, Height/2) + x:South-West-Gravity (0, Height) + x:South-Gravity (Width/2, Height) + x:South-East-Gravity (Width, Height) When a window with one of these bit-gravity values is resized, the corresponding pair defines the change in position of each pixel in @@ -557,50 +673,51 @@ below; and the second is the value to associate with that property. the event-mask argument and the circumstances in which you would want to specify the event mask: - Event Mask Circumstances - x:No-Event-Mask No events wanted - x:Key-Press-Mask Keyboard down events wanted - x:Key-Release-Mask Keyboard up events wanted - x:Button-Press-Mask Pointer button down events wanted - x:Button-Release-Mask Pointer button up events wanted - x:Enter-Window-Mask Pointer window entry events wanted - x:Leave-Window-Mask Pointer window leave events wanted - x:Pointer-Motion-Mask Pointer motion events wanted - x:Pointer-Motion-Hint-Mask If x:Pointer-Motion-Hint-Mask is - selected in combination with one or - more motion-masks, the X server is - free to send only one x:Motion-Notify - event (with the is_hint member of - the X:Pointer-Moved-Event structure - set to x:Notify-Hint) to the client - for the event window, until either - the key or button state changes, the - pointer leaves the event window, or - the client calls X:Query-Pointer or - X:Get-Motion-Events. The server - still may send x:Motion-Notify - events without is_hint set to - x:Notify-Hint. - x:Button1-Motion-Mask Pointer motion while button 1 down - x:Button2-Motion-Mask Pointer motion while button 2 down - x:Button3-Motion-Mask Pointer motion while button 3 down - x:Button4-Motion-Mask Pointer motion while button 4 down - x:Button5-Motion-Mask Pointer motion while button 5 down - x:Button-Motion-Mask Pointer motion while any button down - x:Keymap-State-Mask Keyboard state wanted at window - entry and focus in - x:Exposure-Mask Any exposure wanted - x:Visibility-Change-Mask Any change in visibility wanted - x:Structure-Notify-Mask Any change in window structure wanted - x:Resize-Redirect-Mask Redirect resize of this window - x:Substructure-Notify-Mask Substructure notification wanted - x:Substructure-Redirect-Mask Redirect structure requests on - children - x:Focus-Change-Mask Any change in input focus wanted - x:Property-Change-Mask Any change in property wanted - x:Colormap-Change-Mask Any change in colormap wanted - x:Owner-Grab-Button-Mask Automatic grabs should activate with - owner_events set to True + Event Mask Circumstances + x:No-Event-Mask No events wanted + x:Key-Press-Mask Keyboard down events wanted + x:Key-Release-Mask Keyboard up events wanted + x:Button-Press-Mask Pointer button down events wanted + x:Button-Release-Mask Pointer button up events wanted + x:Enter-Window-Mask Pointer window entry events wanted + x:Leave-Window-Mask Pointer window leave events wanted + x:Pointer-Motion-Mask Pointer motion events wanted + x:Pointer-Motion-Hint-Mask If x:Pointer-Motion-Hint-Mask is + selected in combination with one or + more motion-masks, the X server is + free to send only one x:Motion-Notify + event (with the is_hint member of + the X:Pointer-Moved-Event structure + set to x:Notify-Hint) to the client + for the event window, until either + the key or button state changes, the + pointer leaves the event window, or + the client calls X:Query-Pointer or + X:Get-Motion-Events. The server + still may send x:Motion-Notify + events without is_hint set to + x:Notify-Hint. + x:Button1-Motion-Mask Pointer motion while button 1 down + x:Button2-Motion-Mask Pointer motion while button 2 down + x:Button3-Motion-Mask Pointer motion while button 3 down + x:Button4-Motion-Mask Pointer motion while button 4 down + x:Button5-Motion-Mask Pointer motion while button 5 down + x:Button-Motion-Mask Pointer motion while any button down + x:Keymap-State-Mask Keyboard state wanted at window + entry and focus in + x:Exposure-Mask Any exposure wanted + x:Visibility-Change-Mask Any change in visibility wanted + x:Structure-Notify-Mask Any change in window structure wanted + x:Resize-Redirect-Mask Redirect resize of this window + x:Substructure-Notify-Mask Substructure notification wanted + x:Substructure-Redirect-Mask Redirect structure requests on + children + x:Focus-Change-Mask Any change in input focus wanted + x:Property-Change-Mask Any change in property wanted + x:Colormap-Change-Mask Any change in colormap wanted + x:Owner-Grab-Button-Mask Automatic grabs should activate with + owner_events set to True + - Attribute: x:CW-Dont-Propagate The do-not-propagate-mask attribute defines which events should @@ -642,18 +759,56 @@ below; and the second is the value to associate with that property. in the displayed cursor. On the root window, the default cursor is restored. + - Function: x:window-ref window field-name ... + Returns a list of the components specified by FIELD-NAMEs for the + specified WINDOW. Allowable FIELD-NAMEs are a subset of those for + `x:window-set!': + + * x:CW-Back-Pixel + + * x:CW-Bit-Gravity + + * x:CW-Win-Gravity + + * x:CW-Backing-Store + + * x:CW-Backing-Planes + + * x:CW-Backing-Pixel + + * x:CW-Override-Redirect + + * x:CW-Save-Under + + * x:CW-Event-Mask + + * x:CW-Dont-Propagate + + * x:CW-Colormap + -File: Xlibscm.info, Node: Window Visibility, Next: Graphics Context, Prev: Window, Up: Top +File: Xlibscm.info, Node: Window Properties and Visibility, Prev: Window Attributes, Up: Drawables + +Window Properties and Visibility +================================ + + - Function: x:get-window-property window property + Returns the (string or list of numbers) value of PROPERTY of + WINDOW. -Window Visibility -***************** + - Function: x:get-window-property window property #t + Removes and returns the (string or list of numbers) value of + PROPERTY of WINDOW. + + - Function: x:list-properties window + Returns a list of the properties (strings) defined for WINDOW. In X parlance, a window which is hidden even when not obscured by other windows is "unmapped"; one which shows is "mapped". It is an unfortunate name-collision with Scheme, and is ingrained in the attribute names. - - Function: x:map-window WINDOW + - Function: x:map-window window Maps the WINDOW and all of its subwindows that have had map requests. Mapping a window that has an unmapped ancestor does not display the window but marks it as eligible for display when the @@ -690,13 +845,7 @@ attribute names. be to repaint the window. This method usually leads to simpler programs and to proper interaction with window managers. - - Function: x:map-raised WINDOW - This procedure is similar to `x:map-window' in that it maps the - WINDOW and all of its subwindows that have had map requests. - However, it also raises the specified WINDOW to the top of the - stack. - - - Function: x:map-subwindows WINDOW + - Function: x:map-subwindows window Maps all subwindows of a specified WINDOW in top-to-bottom stacking order. The X server generates x:Expose events on each newly displayed window. This may be much more efficient than @@ -704,7 +853,7 @@ attribute names. perform much of the work only once, for all of the windows, rather than for each window. - - Function: x:unmap-window WINDOW + - Function: x:unmap-window window Unmaps the specified WINDOW and causes the X server to generate an UnmapNotify event. If the specified WINDOW is already unmapped, `x:unmap-window' has no effect. Normal exposure processing on @@ -715,7 +864,7 @@ attribute names. generate x:Expose events on windows that were formerly obscured by it. - - Function: x:unmap-subwindows WINDOW + - Function: x:unmap-subwindows window Unmaps all subwindows for the specified WINDOW in bottom-to-top stacking order. It causes the X server to generate an UnmapNotify event on each subwindow and x:Expose events on formerly obscured @@ -725,7 +874,7 @@ attribute names. rather than for each window. -File: Xlibscm.info, Node: Graphics Context, Next: Cursor, Prev: Window Visibility, Up: Top +File: Xlibscm.info, Node: Graphics Context, Next: Cursor, Prev: Drawables, Up: Top Graphics Context **************** @@ -736,24 +885,24 @@ tile, stipple, clipping region, end style, join style, and so on. Graphics operations (for example, drawing lines) use these values to determine the actual drawing operation. - - Function: x:create-gc DRAWABLE FIELD-NAME VALUE ... + - Function: x:create-gc drawable field-name value ... Creates and returns graphics context. The graphics context can be used with any destination drawable having the same root and depth as the specified DRAWABLE. - - Function: x:gc-set! GRAPHICS-CONTEXT FIELD-NAME VALUE ... + - Function: x:gc-set! graphics-context field-name value ... Changes the components specified by FIELD-NAMEs for the specified GRAPHICS-CONTEXT. The restrictions are the same as for `x:create-gc'. The order in which components are verified and altered is server dependent. If an error occurs, a subset of the components may have been altered. - - Function: x:copy-gc-fields! GCONTEXT-SRC GCONTEXT-DST FIELD-NAME ... + - Function: x:copy-gc-fields! gcontext-src gcontext-dst field-name ... Copies the components specified by FIELD-NAMEs from GCONTEXT-SRC to GCONTEXT-DST. GCONTEXT-SRC and GCONTEXT-DST must have the same root and depth. - - Function: x:gc-ref GRAPHICS-CONTEXT FIELD-NAME ... + - Function: x:gc-ref graphics-context field-name ... Returns a list of the components specified by FIELD-NAMEs ... from the specified GRAPHICS-CONTEXT. @@ -1086,7 +1235,7 @@ File: Xlibscm.info, Node: Cursor, Next: Colormap, Prev: Graphics Context, Up Cursor ****** - - Function: x:create-cursor DISPLAY SHAPE + - Function: x:create-cursor display shape X provides a set of standard cursor shapes in a special font named "cursor". Applications are encouraged to use this interface for their cursors because the font can be customized for the individual @@ -1098,8 +1247,8 @@ Cursor background (see X:Recolor-Cursor). The names of all cursor shapes are defined with the prefix XC: in `x11.scm'. - - Function: x:create-cursor SOURCE-FONT SOURCE-CHAR MASK-FONT - MASK-CHAR FGC BGC + - Function: x:create-cursor source-font source-char mask-font + mask-char fgc bgc Creates a cursor from the source and mask bitmaps obtained from the specified font glyphs. The integer SOURCE-CHAR must be a defined glyph in SOURCE-FONT. The integer MASK-CHAR must be a defined @@ -1109,11 +1258,11 @@ Cursor metrics, and there is no restriction on the placement of the hotspot relative to the bounding boxes. - - Function: x:create-cursor SOURCE-FONT SOURCE-CHAR #F #F FGC BGC + - Function: x:create-cursor source-font source-char #f #f fgc bgc If MASK-FONT and MASK-CHAR are #f, all pixels of the source are displayed. - - Function: x:create-cursor SOURCE-PIXMAP MASK-PIXMAP FGC BGC ORIGIN + - Function: x:create-cursor source-pixmap mask-pixmap fgc bgc origin MASK-PIXMAP must be the same size as the pixmap defined by the SOURCE-PIXMAP argument. The foreground and background RGB values must be specified using FOREGROUND-COLOR and BACKGROUND-COLOR, @@ -1128,7 +1277,7 @@ Cursor in MASK-PIXMAP define which source pixels are displayed, and the pixels set to 0 define which pixels are ignored. - - Function: x:create-cursor SOURCE-PIXMAP #F FGC BGC ORIGIN + - Function: x:create-cursor source-pixmap #f fgc bgc origin If MASK-PIXMAP is #f, all pixels of the source are displayed. @@ -1139,7 +1288,7 @@ Colormap A "colormap" maps pixel values to "RGB" color space values. - - Function: x:create-colormap WINDOW VISUAL ALLOC-POLICY + - Function: x:create-colormap window visual alloc-policy WINDOW specifies the window on whose screen you want to create a colormap. VISUAL specifies a visual type supported on the screen. ALLOC-POLICY Specifies the colormap entries to be allocated. You @@ -1150,12 +1299,16 @@ A "colormap" maps pixel values to "RGB" color space values. Note that WINDOW is used only to determine the screen. `X:Gray-Scale' + `X:Pseudo-Color' + `X:Direct-Color' The initial values of the colormap entries are undefined. `X:Static-Gray' + `X:Static-Color' + `X:True-Color' The entries have defined values, but those values are specific to VISUAL and are not defined by X. The @@ -1170,6 +1323,7 @@ A "colormap" maps pixel values to "RGB" color space values. undefined. `X:Gray-Scale' + `X:Pseudo-Color' The effect is as if an `XAllocColorCells' call returned all pixel values from zero to N - 1, where N is the colormap @@ -1185,7 +1339,7 @@ A "colormap" maps pixel values to "RGB" color space values. To create a new colormap when the allocation out of a previously shared colormap has failed because of resource exhaustion, use: - - Function: x:copy-colormap-and-free COLORMAP + - Function: x:copy-colormap-and-free colormap Creates and returns a colormap of the same visual type and for the same screen as the specified COLORMAP. It also moves all of the client's existing allocation from the specified COLORMAP to the @@ -1207,8 +1361,8 @@ A "colormap" maps pixel values to elements of the "RGB" datatype. An RGB is a list or vector of 3 integers, describing the red, green, and blue intensities respectively. The integers are in the range 0 - 65535. - - Function: x:alloc-colormap-cells COLORMAP NCOLORS NPLANES - - Function: x:alloc-colormap-cells COLORMAP NCOLORS NPLANES CONTIGUOUS? + - Function: x:alloc-colormap-cells colormap ncolors nplanes + - Function: x:alloc-colormap-cells colormap ncolors nplanes contiguous? The `X:Alloc-Color-Cells' function allocates read/write color cells. The number of colors, NCOLORS must be positive and the number of planes, NPLANES nonnegative. If NCOLORS and nplanes are @@ -1220,6 +1374,7 @@ blue intensities respectively. The integers are in the range 0 - 65535. request. `x:Gray-Scale' + `x:Pseudo-Color' Each mask has exactly one bit set to 1. If CONTIGUOUS? is non-false and if all masks are ORed together, a single @@ -1236,8 +1391,8 @@ blue intensities respectively. The integers are in the range 0 - 65535. succeeded or #f if it failed. The first array has the pixels allocated and the second has the plane-masks. - - Function: x:alloc-colormap-cells COLORMAP NCOLORS RGB - - Function: x:alloc-colormap-cells COLORMAP NCOLORS RGB CONTIGUOUS? + - Function: x:alloc-colormap-cells colormap ncolors rgb + - Function: x:alloc-colormap-cells colormap ncolors rgb contiguous? The specified NCOLORS must be positive; and RGB a list or vector of 3 nonnegative integers. If NCOLORS colors, NREDS reds, NGREENS greens, and NBLUES blues are requested, NCOLORS pixels are @@ -1260,8 +1415,8 @@ blue intensities respectively. The integers are in the range 0 - 65535. allocated. The second, third, and fourth elements are the red, green, and blue plane-masks. - - Function: x:free-colormap-cells COLORMAP PIXELS PLANES - - Function: x:free-colormap-cells COLORMAP PIXELS + - Function: x:free-colormap-cells colormap pixels planes + - Function: x:free-colormap-cells colormap pixels Frees the cells represented by pixels whose values are in the PIXELS unsigned-integer uniform-vector. The PLANES argument should not have any bits set to 1 in common with any of the @@ -1284,12 +1439,12 @@ blue intensities respectively. The integers are in the range 0 - 65535. passing `x:Alloc-All' to `X:Create-Colormap'). If more than one pixel is in error, the one that gets reported is arbitrary. - - Function: x:colormap-find-color COLORMAP RGB + - Function: x:colormap-find-color colormap rgb RGB is a list or vector of 3 integers, describing the red, green, and blue intensities respectively; or an integer `#xrrggbb', packing red, green and blue intensities in the range 0 - 255. - - Function: x:colormap-find-color COLORMAP COLOR-NAME + - Function: x:colormap-find-color colormap color-name The case-insensitive string COLOR_NAME specifies the name of a color (for example, `red') @@ -1306,19 +1461,19 @@ blue intensities respectively. The integers are in the range 0 - 65535. deallocated. - - Function: x:color-ref COLORMAP PIXEL + - Function: x:color-ref colormap pixel Returns a list of 3 integers, describing the red, green, and blue intensities respectively of the COLORMAP entry of the cell indexed by PIXEL. The integer PIXEL must be a valid index into COLORMAP. - - Function: X:Color-Set! COLORMAP PIXEL RGB + - Function: X:Color-Set! colormap pixel rgb RGB is a list or vector of 3 integers, describing the red, green, and blue intensities respectively; or an integer `#xrrggbb', packing red, green and blue intensities in the range 0 - 255. - - Function: X:Color-Set! COLORMAP PIXEL COLOR-NAME + - Function: X:Color-Set! colormap pixel color-name The case-insensitive string COLOR_NAME specifies the name of a color (for example, `red') @@ -1329,7 +1484,7 @@ blue intensities respectively. The integers are in the range 0 - 65535. screen, the changes are visible immediately. - - Function: x:install-colormap COLORMAP + - Function: x:install-colormap colormap Installs the specified COLORMAP for its associated screen. All windows associated with COLORMAP immediately display with true colors. A colormap is associated with a window when the window is @@ -1340,21 +1495,24 @@ blue intensities respectively. The integers are in the range 0 - 65535. has that colormap. + - Function: x:ccc colormap + Returns the Color-Conversion-Context of COLORMAP. + -File: Xlibscm.info, Node: Rendering, Next: Event, Prev: Colormap, Up: Top +File: Xlibscm.info, Node: Rendering, Next: Images, Prev: Colormap, Up: Top Rendering ********* - - Function: x:flush DISPLAY - - Function: x:flush WINDOW + - Function: x:flush display + - Function: x:flush window Flushes the output buffer. Some client applications need not use this function because the output buffer is automatically flushed as needed by calls to X:Pending, X:Next-Event, and X:Window-Event. Events generated by the server may be enqueued into the library's event queue. - - Function: x:flush GC + - Function: x:flush gc Forces sending of GC component changes. Xlib usually defers sending changes to the components of a GC to @@ -1366,7 +1524,7 @@ Rendering the GC indirectly, in such a way that the extension interface cannot know what GC will be used. - - Function: x:clear-area WINDOW (X-POS Y-POS) (WIDTH HEIGHT) EXPOSE? + - Function: x:clear-area window (x-pos y-pos) (width height) expose? Paints a rectangular area in the specified WINDOW according to the specified dimensions with the WINDOW's background pixel or pixmap. The subwindow-mode effectively is `x:Clip-By-Children'. If width @@ -1380,35 +1538,35 @@ Rendering are either visible or are being retained in a backing store. If you specify a WINDOW whose class is x:Input-Only, an error results. - - Function: x:fill-rectangle WINDOW GCONTEXT POSITION SIZE + - Function: x:fill-rectangle window gcontext position size Draw Strings ============ - - Function: x:draw-string DRAWABLE GC POSITION STRING + - Function: x:draw-string drawable gc position string POSITION specifies coordinates relative to the origin of DRAWABLE of the origin of the first character to be drawn. `x:draw-string' draws the characters of STRING, starting at POSITION. - - Function: x:image-string DRAWABLE GC POSITION STRING + - Function: x:image-string drawable gc position string POSITION specifies coordinates relative to the origin of DRAWABLE of the origin of the first character to be drawn. - `x:image-string' draws the characters *and background* of STRING, + `x:image-string' draws the characters _and background_ of STRING, starting at POSITION. Draw Shapes =========== - - Function: x:draw-points DRAWABLE GC POSITION ... + - Function: x:draw-points drawable gc position ... POSITION ... specifies coordinates of the point to be drawn. - - Function: x:draw-points DRAWABLE GC X Y ... + - Function: x:draw-points drawable gc x y ... (X, Y) ... specifies coordinates of the point to be drawn. - - Function: x:draw-points DRAWABLE GC POINT-ARRAY + - Function: x:draw-points drawable gc point-array POINT-ARRAY is a uniform short array of rank 2, whose rightmost index spans a range of 2. @@ -1420,14 +1578,14 @@ Draw Shapes foreground, subwindow-mode, clip-x-origin, clip-y-origin, and clip-mask. - - Function: x:draw-segments DRAWABLE GC POS1 POS2 ... + - Function: x:draw-segments drawable gc pos1 pos2 ... POS1, POS2, ... specify coordinates to be connected by segments. - - Function: x:draw-segments DRAWABLE GC X1 Y1 X2 Y2 ... + - Function: x:draw-segments drawable gc x1 y1 x2 y2 ... (X1, Y1), (X2, Y2) ... specify coordinates to be connected by segments. - - Function: x:draw-segments DRAWABLE GC POINT-ARRAY + - Function: x:draw-segments drawable gc point-array POINT-ARRAY is a uniform short array of rank 2, whose rightmost index spans a range of 2. @@ -1450,14 +1608,14 @@ Draw Shapes tile, stipple, tilestipple-x-origin, tile-stipple-y-origin, dash-offset, and dash-list. - - Function: x:draw-lines DRAWABLE GC POS1 POS2 ... + - Function: x:draw-lines drawable gc pos1 pos2 ... POS1, POS2, ... specify coordinates to be connected by lines. - - Function: x:draw-lines DRAWABLE GC X1 Y1 X2 Y2 ... + - Function: x:draw-lines drawable gc x1 y1 x2 y2 ... (X1, Y1), (X2, Y2) ... specify coordinates to be connected by lines. - - Function: x:draw-lines DRAWABLE GC POINT-ARRAY + - Function: x:draw-lines drawable gc point-array POINT-ARRAY is a uniform short array of rank 2, whose rightmost index spans a range of 2. @@ -1481,13 +1639,13 @@ Draw Shapes tile, stipple, tilestipple-x-origin, tile-stipple-y-origin, dash-offset, and dash-list. - - Function: x:fill-polygon DRAWABLE GC POS1 POS2 ... + - Function: x:fill-polygon drawable gc pos1 pos2 ... POS1, POS2, ... specify coordinates of the border path. - - Function: x:fill-polygon DRAWABLE GC X1 Y1 X2 Y2 ... + - Function: x:fill-polygon drawable gc x1 y1 x2 y2 ... (X1, Y1), (X2, Y2) ... specify coordinates of the border path. - - Function: x:fill-polygon DRAWABLE GC POINT-ARRAY + - Function: x:fill-polygon drawable gc point-array POINT-ARRAY is a uniform short array of rank 2, whose rightmost index spans a range of 2. @@ -1507,7 +1665,15 @@ Draw Shapes tile-stipple-x-origin, and tile-stipple-y-origin. -File: Xlibscm.info, Node: Event, Next: Index, Prev: Rendering, Up: Top +File: Xlibscm.info, Node: Images, Next: Event, Prev: Rendering, Up: Top + +Images +****** + + - Function: x:read-bitmap-file drawable file + + +File: Xlibscm.info, Node: Event, Next: Index, Prev: Images, Up: Top Event ***** @@ -1515,16 +1681,16 @@ Event These three status routines always return immediately if there are events already in the queue. - - Function: x:q-length DISPLAY + - Function: x:q-length display Returns the length of the event queue for the connected DISPLAY. Note that there may be more events that have not been read into the queue yet (see X:Events-Queued). - - Function: x:pending DISPLAY + - Function: x:pending display Returns the number of events that have been received from the X server but have not been removed from the event queue. - - Function: x:events-queued DISPLAY + - Function: x:events-queued display Returns the number of events already in the queue if the number is nonzero. If there are no events in the queue, `X:Events-Queued' attempts to read more events out of the application's connection @@ -1532,12 +1698,12 @@ events already in the queue. Both of these routines return an object of type "event". - - Function: x:next-event DISPLAY + - Function: x:next-event display Removes and returns the first event from the event queue. If the event queue is empty, `X:Next-Event' flushes the output buffer and blocks until an event is received. - - Function: x:peek-event DISPLAY + - Function: x:peek-event display Returns the first event from the event queue, but it does not remove the event from the queue. If the queue is empty, `X:Peek-Event' flushes the output buffer and blocks until an event @@ -1545,206 +1711,206 @@ Both of these routines return an object of type "event". Each event object has fields dependent on its sub-type. - - Function: x:event-ref EVENT FIELD-NAME - window The window on which EVENT was generated - and is referred to as the event window. - root is the event window's root window. - subwindow If the source window is an inferior of - the event window, the SUBWINDOW is the - child of the event window that is the - source window or the child of the event - window that is an ancestor of the - source window. Otherwise, `None'. - X-event:type An integer: X:KEY-PRESS, X:KEY-RELEASE, - X:BUTTON-PRESS, X:BUTTON-RELEASE, - X:MOTION-NOTIFY, X:ENTER-NOTIFY, - X:LEAVE-NOTIFY, X:FOCUS-IN, - X:FOCUS-OUT, X:KEYMAP-NOTIFY, X:EXPOSE, - X:GRAPHICS-EXPOSE, X:NO-EXPOSE, - X:VISIBILITY-NOTIFY, X:CREATE-NOTIFY, - X:DESTROY-NOTIFY, X:UNMAP-NOTIFY, - X:MAP-NOTIFY, X:MAP-REQUEST, - X:REPARENT-NOTIFY, X:CONFIGURE-NOTIFY, - X:CONFIGURE-REQUEST, X:GRAVITY-NOTIFY, - X:RESIZE-REQUEST, X:CIRCULATE-NOTIFY, - X:CIRCULATE-REQUEST, X:PROPERTY-NOTIFY, - X:SELECTION-CLEAR, X:SELECTION-REQUEST, - X:SELECTION-NOTIFY, X:COLORMAP-NOTIFY, - X:CLIENT-MESSAGE, or X:MAPPING-NOTIFY. - X-event:serial The serial number of the protocol - request that generated the EVENT. - X-event:send-event Boolean that indicates whether the - event was sent by a different client. - X-event:time The time when the EVENT was generated - expressed in milliseconds. - X-event:x - X-event:y For window entry/exit events the X and - Y members are set to the coordinates of - the pointer position in the event - window. This position is always the - pointer's final position, not its - initial position. If the event window - is on the same screen as the root - window, X and Y are the pointer - coordinates relative to the event - window's origin. Otherwise, X and Y - are set to zero. - - For expose events The X and Y members - are set to the coordinates relative to - the drawable's origin and indicate the - upper-left corner of the rectangle. - - For configure, create, gravity, and - reparent events the X and Y members are - set to the window's coordinates - relative to the parent window's origin - and indicate the position of the - upper-left outside corner of the - created window. - X-event:x-root - X-event:y-root The pointer's coordinates relative to - the root window's origin at the time of - the EVENT. - X-event:state For keyboard, pointer and window - entry/exit events, the state member is - set to indicate the logical state of - the pointer buttons and modifier keys - just prior to the EVENT, which is the - bitwise inclusive OR of one or more of - the button or modifier key masks: - X:BUTTON1-MASK, X:BUTTON2-MASK, - X:BUTTON3-MASK, X:BUTTON4-MASK, - X:BUTTON5-MASK, X:SHIFT-MASK, - X:LOCK-MASK, X:CONTROL-MASK, - X:MOD1-MASK, X:MOD2-MASK, X:MOD3-MASK, - X:MOD4-MASK, and X:MOD5-MASK. - - For visibility events, the state of the - window's visibility: - X:VISIBILITY-UNOBSCURED, - X:VISIBILITY-PARTIALLY-OBSCURED, or - X:VISIBILITY-FULLY-OBSCURED. - - For colormap events, indicates whether - the colormap is installed or - uninstalled: x:Colormap-Installed or - x:Colormap-Uninstalled. - - For property events, indicates whether - the property was changed to a new value - or deleted: x:Property-New-Value or - x:Property-Delete. - X-event:keycode An integer that represents a physical - key on the keyboard. - X-event:same-screen Indicates whether the event window is - on the same screen as the root window. - If #t, the event and root windows are - on the same screen. If #f, the event - and root windows are not on the same - screen. - X-event:button The pointer button that changed state; - can be the X:BUTTON1, X:BUTTON2, - X:BUTTON3, X:BUTTON4, or X:BUTTON5 - value. - X-event:is-hint Detail of motion-notify events: - X:NOTIFY-NORMAL or X:NOTIFY-HINT. - X-event:mode Indicates whether the EVENT is a normal - event, pseudo-motion event when a grab - activates, or a pseudo-motion event - when a grab deactivates: - X:NOTIFY-NORMAL, X:NOTIFY-GRAB, or - X:NOTIFY-UNGRAB. - X-event:detail Indicates the notification detail: - X:NOTIFY-ANCESTOR, X:NOTIFY-VIRTUAL, - X:NOTIFY-INFERIOR, X:NOTIFY-NONLINEAR, - or X:NOTIFY-NONLINEAR-VIRTUAL. - X-event:focus If the event window is the focus window - or an inferior of the focus window, #t; - otherwise #f. - X-event:width - X-event:height The size (extent) of the rectangle. - X-event:count For mapping events is the number of - keycodes altered. - - For expose events Is the number of - Expose or GraphicsExpose events that - are to follow. If count is zero, no - more Expose events follow for this - window. However, if count is nonzero, - at least that number of Expose events - (and possibly more) follow for this - window. Simple applications that do - not want to optimize redisplay by - distinguishing between subareas of its - window can just ignore all Expose - events with nonzero counts and perform - full redisplays on events with zero - counts. - X-event:major-code The major_code member is set to the - graphics request initiated by the - client and can be either X_CopyArea or - X_CopyPlane. If it is X_CopyArea, a - call to XCopyArea initiated the - request. If it is X_CopyPlane, a call - to XCopyPlane initiated the request. - X-event:minor-code Not currently used. - X-event:border-width For configure events, the width of the - window's border, in pixels. - X-event:override-redirect The override-redirect attribute of the - window. Window manager clients - normally should ignore this window if - it is #t. - X-event:from-configure True if the event was generated as a - result of a resizing of the window's - parent when the window itself had a - win-gravity of x:Unmap-Gravity. - X-event:value-mask Indicates which components were - specified in the ConfigureWindow - protocol request. The corresponding - values are reported as given in the - request. The remaining values are - filled in from the current geometry of - the window, except in the case of above - (sibling) and detail (stack-mode), - which are reported as None and Above, - respectively, if they are not given in - the request. - X-event:place The window's position after the restack - occurs and is either x:Place-On-Top or - x:Place-On-Bottom. If it is - x:Place-On-Top, the window is now on - top of all siblings. If it is - x:Place-On-Bottom, the window is now - below all siblings. - X-event:new indicate whether the colormap for the - specified window was changed or - installed or uninstalled and can be - True or False. If it is True, the - colormap was changed. If it is False, - the colormap was installed or - uninstalled. - X-event:format Is 8, 16, or 32 and specifies whether - the data should be viewed as a list of - bytes, shorts, or longs - X-event:request Indicates the kind of mapping change - that occurred and can be - X:MAPPING-MODIFIER, X:MAPPING-KEYBOARD, - or X:MAPPING-POINTER. If it is - X:MAPPING-MODIFIER, the modifier - mapping was changed. If it is - X:MAPPING-KEYBOARD, the keyboard - mapping was changed. If it is - X:MAPPING-POINTER, the pointer button - mapping was changed. - X-event:first-keycode The X-event:first-keycode is set only - if the X-event:request was set to - X:MAPPING-KEYBOARD. The number in - X-event:first-keycode represents the - first number in the range of the - altered mapping, and X-event:count - represents the number of keycodes - altered. + - Function: x:event-ref event field-name + window The window on which EVENT was generated + and is referred to as the event window. + root is the event window's root window. + subwindow If the source window is an inferior of + the event window, the SUBWINDOW is the + child of the event window that is the + source window or the child of the event + window that is an ancestor of the + source window. Otherwise, `None'. + X-event:type An integer: X:KEY-PRESS, X:KEY-RELEASE, + X:BUTTON-PRESS, X:BUTTON-RELEASE, + X:MOTION-NOTIFY, X:ENTER-NOTIFY, + X:LEAVE-NOTIFY, X:FOCUS-IN, + X:FOCUS-OUT, X:KEYMAP-NOTIFY, X:EXPOSE, + X:GRAPHICS-EXPOSE, X:NO-EXPOSE, + X:VISIBILITY-NOTIFY, X:CREATE-NOTIFY, + X:DESTROY-NOTIFY, X:UNMAP-NOTIFY, + X:MAP-NOTIFY, X:MAP-REQUEST, + X:REPARENT-NOTIFY, X:CONFIGURE-NOTIFY, + X:CONFIGURE-REQUEST, X:GRAVITY-NOTIFY, + X:RESIZE-REQUEST, X:CIRCULATE-NOTIFY, + X:CIRCULATE-REQUEST, X:PROPERTY-NOTIFY, + X:SELECTION-CLEAR, X:SELECTION-REQUEST, + X:SELECTION-NOTIFY, X:COLORMAP-NOTIFY, + X:CLIENT-MESSAGE, or X:MAPPING-NOTIFY. + X-event:serial The serial number of the protocol + request that generated the EVENT. + X-event:send-event Boolean that indicates whether the + event was sent by a different client. + X-event:time The time when the EVENT was generated + expressed in milliseconds. + X-event:x + X-event:y For window entry/exit events the X and + Y members are set to the coordinates of + the pointer position in the event + window. This position is always the + pointer's final position, not its + initial position. If the event window + is on the same screen as the root + window, X and Y are the pointer + coordinates relative to the event + window's origin. Otherwise, X and Y + are set to zero. + + For expose events The X and Y members + are set to the coordinates relative to + the drawable's origin and indicate the + upper-left corner of the rectangle. + + For configure, create, gravity, and + reparent events the X and Y members are + set to the window's coordinates + relative to the parent window's origin + and indicate the position of the + upper-left outside corner of the + created window. + X-event:x-root + X-event:y-root The pointer's coordinates relative to + the root window's origin at the time of + the EVENT. + X-event:state For keyboard, pointer and window + entry/exit events, the state member is + set to indicate the logical state of + the pointer buttons and modifier keys + just prior to the EVENT, which is the + bitwise inclusive OR of one or more of + the button or modifier key masks: + X:BUTTON1-MASK, X:BUTTON2-MASK, + X:BUTTON3-MASK, X:BUTTON4-MASK, + X:BUTTON5-MASK, X:SHIFT-MASK, + X:LOCK-MASK, X:CONTROL-MASK, + X:MOD1-MASK, X:MOD2-MASK, X:MOD3-MASK, + X:MOD4-MASK, and X:MOD5-MASK. + + For visibility events, the state of the + window's visibility: + X:VISIBILITY-UNOBSCURED, + X:VISIBILITY-PARTIALLY-OBSCURED, or + X:VISIBILITY-FULLY-OBSCURED. + + For colormap events, indicates whether + the colormap is installed or + uninstalled: x:Colormap-Installed or + x:Colormap-Uninstalled. + + For property events, indicates whether + the property was changed to a new value + or deleted: x:Property-New-Value or + x:Property-Delete. + X-event:keycode An integer that represents a physical + key on the keyboard. + X-event:same-screen Indicates whether the event window is + on the same screen as the root window. + If #t, the event and root windows are + on the same screen. If #f, the event + and root windows are not on the same + screen. + X-event:button The pointer button that changed state; + can be the X:BUTTON1, X:BUTTON2, + X:BUTTON3, X:BUTTON4, or X:BUTTON5 + value. + X-event:is-hint Detail of motion-notify events: + X:NOTIFY-NORMAL or X:NOTIFY-HINT. + X-event:mode Indicates whether the EVENT is a normal + event, pseudo-motion event when a grab + activates, or a pseudo-motion event + when a grab deactivates: + X:NOTIFY-NORMAL, X:NOTIFY-GRAB, or + X:NOTIFY-UNGRAB. + X-event:detail Indicates the notification detail: + X:NOTIFY-ANCESTOR, X:NOTIFY-VIRTUAL, + X:NOTIFY-INFERIOR, X:NOTIFY-NONLINEAR, + or X:NOTIFY-NONLINEAR-VIRTUAL. + X-event:focus If the event window is the focus window + or an inferior of the focus window, #t; + otherwise #f. + X-event:width + X-event:height The size (extent) of the rectangle. + X-event:count For mapping events is the number of + keycodes altered. + + For expose events Is the number of + Expose or GraphicsExpose events that + are to follow. If count is zero, no + more Expose events follow for this + window. However, if count is nonzero, + at least that number of Expose events + (and possibly more) follow for this + window. Simple applications that do + not want to optimize redisplay by + distinguishing between subareas of its + window can just ignore all Expose + events with nonzero counts and perform + full redisplays on events with zero + counts. + X-event:major-code The major_code member is set to the + graphics request initiated by the + client and can be either X_CopyArea or + X_CopyPlane. If it is X_CopyArea, a + call to XCopyArea initiated the + request. If it is X_CopyPlane, a call + to XCopyPlane initiated the request. + X-event:minor-code Not currently used. + X-event:border-width For configure events, the width of the + window's border, in pixels. + X-event:override-redirect The override-redirect attribute of the + window. Window manager clients + normally should ignore this window if + it is #t. + X-event:from-configure True if the event was generated as a + result of a resizing of the window's + parent when the window itself had a + win-gravity of x:Unmap-Gravity. + X-event:value-mask Indicates which components were + specified in the ConfigureWindow + protocol request. The corresponding + values are reported as given in the + request. The remaining values are + filled in from the current geometry of + the window, except in the case of above + (sibling) and detail (stack-mode), + which are reported as None and Above, + respectively, if they are not given in + the request. + X-event:place The window's position after the restack + occurs and is either x:Place-On-Top or + x:Place-On-Bottom. If it is + x:Place-On-Top, the window is now on + top of all siblings. If it is + x:Place-On-Bottom, the window is now + below all siblings. + X-event:new indicate whether the colormap for the + specified window was changed or + installed or uninstalled and can be + True or False. If it is True, the + colormap was changed. If it is False, + the colormap was installed or + uninstalled. + X-event:format Is 8, 16, or 32 and specifies whether + the data should be viewed as a list of + bytes, shorts, or longs + X-event:request Indicates the kind of mapping change + that occurred and can be + X:MAPPING-MODIFIER, X:MAPPING-KEYBOARD, + or X:MAPPING-POINTER. If it is + X:MAPPING-MODIFIER, the modifier + mapping was changed. If it is + X:MAPPING-KEYBOARD, the keyboard + mapping was changed. If it is + X:MAPPING-POINTER, the pointer button + mapping was changed. + X-event:first-keycode The X-event:first-keycode is set only + if the X-event:request was set to + X:MAPPING-KEYBOARD. The number in + X-event:first-keycode represents the + first number in the range of the + altered mapping, and X-event:count + represents the number of keycodes + altered. File: Xlibscm.info, Node: Index, Prev: Event, Up: Top @@ -1757,11 +1923,12 @@ Xlibscm. * Menu: -* hostname:number.screen-number: Display. +* hostname:number.screen-number: Display and Screens. * x:alloc-colormap-cells: Colormap. +* x:ccc: Colormap. * x:clear-area: Rendering. -* x:close <1>: Window. -* x:close: Display. +* x:close <1>: Windows and Pixmaps. +* x:close: Display and Screens. * x:color-ref: Colormap. * X:Color-Set!: Colormap. * x:colormap-find-color: Colormap. @@ -1770,13 +1937,13 @@ Xlibscm. * x:create-colormap: Colormap. * x:create-cursor: Cursor. * x:create-gc: Graphics Context. -* x:create-pixmap: Window. -* x:create-window: Window. -* x:default-colormap: Screen. -* x:default-depths: Screen. -* x:default-gc: Screen. -* x:default-screen: Screen. -* x:default-visual: Screen. +* x:create-pixmap: Windows and Pixmaps. +* x:create-window: Windows and Pixmaps. +* x:default-ccc: Display and Screens. +* x:default-colormap: Display and Screens. +* x:default-gc: Display and Screens. +* x:default-screen: Display and Screens. +* x:default-visual: Display and Screens. * x:draw-lines: Rendering. * x:draw-points: Rendering. * x:draw-segments: Rendering. @@ -1789,32 +1956,39 @@ Xlibscm. * x:free-colormap-cells: Colormap. * x:gc-ref: Graphics Context. * x:gc-set!: Graphics Context. +* x:get-window-property: Window Properties and Visibility. * x:image-string: Rendering. * x:install-colormap: Colormap. -* x:make-visual: Screen. -* x:map-raised: Window Visibility. -* x:map-subwindows: Window Visibility. -* x:map-window: Window Visibility. +* x:list-properties: Window Properties and Visibility. +* x:make-visual: Display and Screens. +* x:map-subwindows: Window Properties and Visibility. +* x:map-window: Window Properties and Visibility. * x:next-event: Event. -* x:open-display: Display. +* x:open-display: Display and Screens. * x:peek-event: Event. * x:pending: Event. -* x:protocol-version: Display. +* x:protocol-version: Display and Screens. * x:q-length: Event. -* x:root-window: Screen. -* x:screen-black: Screen. -* x:screen-cells: Screen. -* x:screen-count: Screen. -* x:screen-depth: Screen. -* x:screen-dimensions: Screen. -* x:screen-size: Screen. -* x:screen-white: Screen. -* x:server-vendor: Display. -* x:unmap-subwindows: Window Visibility. -* x:unmap-window: Window Visibility. -* x:vendor-release: Display. -* x:window-geometry: Window. -* x:window-set!: Window. +* x:read-bitmap-file: Images. +* x:root-window: Display and Screens. +* x:screen-black: Display and Screens. +* x:screen-cells: Display and Screens. +* x:screen-count: Display and Screens. +* x:screen-depth: Display and Screens. +* x:screen-depths: Display and Screens. +* x:screen-dimensions: Display and Screens. +* x:screen-size: Display and Screens. +* x:screen-white: Display and Screens. +* x:server-vendor: Display and Screens. +* x:unmap-subwindows: Window Properties and Visibility. +* x:unmap-window: Window Properties and Visibility. +* x:vendor-release: Display and Screens. +* x:visual-class: Display and Screens. +* x:visual-geometry: Display and Screens. +* x:window-geometry: Windows and Pixmaps. +* x:window-geometry-set!: Windows and Pixmaps. +* x:window-ref: Window Attributes. +* x:window-set!: Window Attributes. Variable Index ************** @@ -1823,21 +1997,28 @@ This is an alphabetical list of all the global variables in Xlibscm. * Menu: -* x:CW-Back-Pixel: Window. -* x:CW-Back-Pixmap: Window. -* x:CW-Backing-Pixel: Window. -* x:CW-Backing-Planes: Window. -* x:CW-Backing-Store: Window. -* x:CW-Bit-Gravity: Window. -* x:CW-Border-Pixel: Window. -* x:CW-Border-Pixmap: Window. -* x:CW-Colormap: Window. -* x:CW-Cursor: Window. -* x:CW-Dont-Propagate: Window. -* x:CW-Event-Mask: Window. -* x:CW-Override-Redirect: Window. -* x:CW-Save-Under: Window. -* x:CW-Win-Gravity: Window. +* x:CW-Back-Pixel: Window Attributes. +* x:CW-Back-Pixmap: Window Attributes. +* x:CW-Backing-Pixel: Window Attributes. +* x:CW-Backing-Planes: Window Attributes. +* x:CW-Backing-Store: Window Attributes. +* x:CW-Bit-Gravity: Window Attributes. +* x:CW-Border-Pixel: Window Attributes. +* x:CW-Border-Pixmap: Window Attributes. +* x:CW-Border-Width: Windows and Pixmaps. +* x:CW-Colormap: Window Attributes. +* x:CW-Cursor: Window Attributes. +* x:CW-Dont-Propagate: Window Attributes. +* x:CW-Event-Mask: Window Attributes. +* x:CW-Height: Windows and Pixmaps. +* x:CW-Override-Redirect: Window Attributes. +* x:CW-Save-Under: Window Attributes. +* x:CW-Sibling: Windows and Pixmaps. +* x:CW-Stack-Mode: Windows and Pixmaps. +* x:CW-Width: Windows and Pixmaps. +* x:CW-Win-Gravity: Window Attributes. +* x:CWX: Windows and Pixmaps. +* x:CWY: Windows and Pixmaps. * x:GC-Arc-Mode: Graphics Context. * x:GC-Background: Graphics Context. * x:GC-Cap-Style: Graphics Context. @@ -1871,17 +2052,17 @@ Concept Index * colormap: Colormap. * cursor: Cursor. -* depth: Screen. -* drawable: Window. -* Drawable: Window. -* map: Window Visibility. -* mapped: Window Visibility. +* depth: Display and Screens. +* drawable: Drawables. +* Drawable: Drawables. +* map: Window Properties and Visibility. +* mapped: Window Properties and Visibility. * none: Graphics Context. * RGB: Colormap. -* unmap: Window Visibility. -* unmapped: Window Visibility. -* Visual: Screen. -* visual: Screen. +* unmap: Window Properties and Visibility. +* unmapped: Window Properties and Visibility. +* Visual: Display and Screens. +* visual: Display and Screens. * X: Xlibscm. * x:None: Graphics Context. * Xlib: Xlibscm. @@ -1889,17 +2070,19 @@ Concept Index Tag Table: -Node: Top241 -Node: Xlibscm1366 -Node: Display4144 -Node: Screen6776 -Node: Window10533 -Node: Window Visibility30412 -Node: Graphics Context34697 -Node: Cursor50412 -Node: Colormap52915 -Node: Rendering62691 -Node: Event70247 -Node: Index86684 +Node: Top215 +Node: Xlibscm1333 +Node: Display and Screens4123 +Node: Drawables11108 +Node: Windows and Pixmaps11369 +Node: Window Attributes18448 +Node: Window Properties and Visibility34428 +Node: Graphics Context38885 +Node: Cursor54592 +Node: Colormap57095 +Node: Rendering66961 +Node: Images74518 +Node: Event74659 +Node: Index89134 End Tag Table diff --git a/Xlibscm.texi b/Xlibscm.texi index 59e6c3c..1d41a3c 100644 --- a/Xlibscm.texi +++ b/Xlibscm.texi @@ -82,20 +82,19 @@ by the author. @end ifinfo @menu -* Xlibscm:: -* Display:: -* Screen:: -* Window:: -* Window Visibility:: -* Graphics Context:: -* Cursor:: -* Colormap:: -* Rendering:: -* Event:: -* Index:: +* Xlibscm:: +* Display and Screens:: +* Drawables:: +* Graphics Context:: +* Cursor:: +* Colormap:: +* Rendering:: +* Images:: +* Event:: +* Index:: @end menu -@node Xlibscm, Display, Top, Top +@node Xlibscm, Display and Screens, Top, Top @chapter Xlibscm @dfn{Xlibscm} is a SCM interface to @dfn{X}. @@ -188,8 +187,8 @@ the suitability of this documentation for any purpose. It is provided ``as is'' without express or implied warranty. -@node Display, Screen, Xlibscm, Top -@chapter Display +@node Display and Screens, Drawables, Xlibscm, Top +@chapter Display and Screens @defun x:open-display display-name @var{display-name} Specifies the hardware display name, which determines @@ -251,12 +250,8 @@ Returns a number related to a vendor's release of the X server. @end defun -@node Screen, Window, Display, Top -@chapter Screen - A display consists of one or more @dfn{Screen}s. Each screen has a -@dfn{root-window}, @dfn{default-graphics-context}, @dfn{default-visual}, -and @dfn{colormap}. +@dfn{root-window}, @dfn{default-graphics-context}, and @dfn{colormap}. @defun x:screen-count display Returns the number of available screens. @@ -288,16 +283,23 @@ Returns the root window for the specified @var{window}'s screen. Returns the default colormap of the specified screen. @end defun +@defun x:default-ccc display screen-number +@defunx x:default-ccc display +@defunx x:default-ccc window +Returns the default Color-Conversion-Context (ccc) of the specified +screen. +@end defun + @defun x:default-gc display screen-number @defunx x:default-gc display @defunx x:default-gc window Returns the default graphics-context of the specified screen. @end defun -@defun x:default-depths display screen-number -@defunx x:default-depths display -@defunx x:default-depths window -Returns a vector of depths supported by the specified screen. +@defun x:screen-depths display screen-number +@defunx x:screen-depths display +@defunx x:screen-depths window +Returns an array of depths supported by the specified screen. @end defun The @dfn{Visual} type describes possible colormap depths and @@ -329,9 +331,27 @@ visual classes for a screen: @code{X:make-visual} returns a visual type for the screen specified by @var{display} or @var{window} if successful; #f if not. +@end defun +@defun x:visual-class visual +@defunx x:visual-class screen +@defunx x:visual-class display +Returns the (integer) visual class of its argument. +@end defun + +@defun x:visual-geometry visual +@defunx x:visual-geometry screen +@defunx x:visual-geometry display +Returns a list of the: +@itemize @bullet +@item red_mask +@item green_mask +@item blue_mask +@item colormap_size +@end itemize @end defun + @defun x:screen-cells display screen-number @defunx x:screen-cells display @defunx x:screen-cells window @@ -339,9 +359,11 @@ Returns the number of entries in the default colormap. @end defun @defun x:screen-depth display screen-number +Returns the depth of the root window of the specified screen. @defunx x:screen-depth display @defunx x:screen-depth window -Returns the depth of the root window of the specified screen. +@defunx x:screen-depth visual +Returns the depth of argument. @cindex depth The @dfn{depth} of a window or pixmap is the number of bits per pixel it has. @@ -373,14 +395,23 @@ Returns the white pixel value of the specified screen. Returns the black pixel value of the specified screen. @end defun - -@node Window, Window Visibility, Screen, Top -@chapter Window +@node Drawables, Graphics Context, Display and Screens, Top +@chapter Drawables @cindex Drawable @cindex drawable A @dfn{Drawable} is either a window or pixmap. +@menu +* Windows and Pixmaps:: +* Window Attributes:: +* Window Properties and Visibility:: +@end menu + + +@node Windows and Pixmaps, Window Attributes, Drawables, Drawables +@section Windows and Pixmaps + @defun x:create-window window position size border-width depth class visual field-name value @dots{} Creates and returns an unmapped Input-Output subwindow for a specified parent @var{window} and causes the X server to generate a CreateNotify @@ -447,12 +478,12 @@ Returns a list of: @table @asis @item coordinates -@code{cons} of x and y coordinates that define the location of the +@code{list} of x and y coordinates that define the location of the @var{drawable}. For a window, these coordinates specify the upper-left outer corner relative to its parent's origin. For pixmaps, these coordinates are always zero. @item size -@code{cons} of the @var{drawable}'s dimensions (width and height). For +@code{list} of the @var{drawable}'s dimensions (width and height). For a window, these dimensions specify the inside size, not including the border. @item border-width @@ -463,6 +494,101 @@ The depth of the @var{drawable} (bits per pixel for the object). @end table @end defun + +@defun x:window-geometry-set! window field-name value @dots{} +Changes the @dfn{Configuration} components specified by +@var{field-name}s for the specified @var{window}. +@end defun + +@noindent +These are the attributes settable by @code{x:window-geometry-set!}. +That these attributes are encoded by small integers -- just like those +of the next section. Be warned therefore that confusion of attribute +names will likely not signal errors, just cause mysterious behavior. + +@defvr Attribute x:CWX +@defvrx Attribute x:CWY +@defvrx Attribute x:CW-Width +@defvrx Attribute x:CW-Height +The x:CWX and x:CYY members are used to set the window's x and y +coordinates, which are relative to the parent's origin and indicate the +position of the upper-left outer corner of the window. The x:CW-Width +and x:CW-Height members are used to set the inside size of the window, +not including the border, and must be nonzero. Attempts to configure a +root window have no effect. + +If a window's size actually changes, the window's subwindows move +according to their window gravity. Depending on the window's bit +gravity, the contents of the window also may be moved +@end defvr + +@defvr Attribute x:CW-Border-Width +The integer x:CW-Border-Width is used to set the width of the border in +pixels. Note that setting just the border width leaves the outer-left +corner of the window in a fixed position but moves the absolute position +of the window's origin. It is an error to set the border-width +attribute of an InputOnly window nonzero. +@end defvr + +@defvr Attribute x:CW-Sibling +The sibling member is used to set the sibling window for stacking +operations. +@end defvr + +@defvr Attribute x:CW-Stack-Mode +The x:CW-Stack-Mode member is used to set how the window is to be +restacked and can be set to x:Above, x:Below, x:Top-If, x:Bottom-If, or +x:Opposite. +@end defvr + +@noindent +If a sibling and a stack-mode are specified, the window is restacked as +follows: + +@table @code +@item x:Above +The window is placed just above the sibling. +@item x:Below +The window is placed just below the sibling. +@item x:Top-If +If the sibling occludes the window, the window is placed at the top of +the stack. +@item x:Bottom-If +If the window occludes the sibling, the window is placed at the bottom +of the stack. +@item x:Opposite +If the sibling occludes the window, the window is placed at the top of +the stack. If the window occludes the sibling, the window is placed at +the bottom of the stack. +@end table + +@noindent +If a stack-mode is specified but no sibling is specified, the window +is restacked as follows: + +@table @code +@item x:Above +The window is placed at the top of the stack. +@item x:Below +The window is placed at the bottom of the stack. +@item x:Top-If +If any sibling occludes the window, the window is placed at the top of +the stack. +@item x:Bottom-If +If the window occludes any sibling, the window is placed at the bottom +of the stack. +@item x:Opposite +If any sibling occludes the window, the window is placed at the top of +the stack. If the window occludes any sibling, the window is placed at +the bottom of the stack. +@end table + + + + +@node Window Attributes, Window Properties and Visibility, Windows and Pixmaps, Drawables +@section Window Attributes + @defun x:window-set! window field-name value @dots{} Changes the components specified by @var{field-name}s for the specified @var{window}. The restrictions are the same as for @@ -471,8 +597,6 @@ altered is server dependent. If an error occurs, a subset of the components may have been altered. @end defun -@heading Window Attributes - @noindent The @code{x:create-window} and @code{x:window-set!} procedures take five and one argument (respectively) followed by pairs of arguments, where @@ -773,9 +897,41 @@ in the parent's cursor will cause an immediate change in the displayed cursor. On the root window, the default cursor is restored. @end defvr +@defun x:window-ref window field-name @dots{} +Returns a list of the components specified by @var{field-name}s for the +specified @var{window}. Allowable @var{field-name}s are a subset of +those for @code{x:window-set!}: + +@itemize @bullet +@item x:CW-Back-Pixel +@item x:CW-Bit-Gravity +@item x:CW-Win-Gravity +@item x:CW-Backing-Store +@item x:CW-Backing-Planes +@item x:CW-Backing-Pixel +@item x:CW-Override-Redirect +@item x:CW-Save-Under +@item x:CW-Event-Mask +@item x:CW-Dont-Propagate +@item x:CW-Colormap +@end itemize +@end defun + -@node Window Visibility, Graphics Context, Window, Top -@chapter Window Visibility +@node Window Properties and Visibility, , Window Attributes, Drawables +@section Window Properties and Visibility + +@defun x:get-window-property window property +Returns the (string or list of numbers) value of @var{property} of +@var{window}. +@defunx x:get-window-property window property #t +Removes and returns the (string or list of numbers) value of +@var{property} of @var{window}. +@end defun + +@defun x:list-properties window +Returns a list of the properties (strings) defined for @var{window}. +@end defun @noindent In X parlance, a window which is hidden even when not obscured by other @@ -824,13 +980,6 @@ leads to simpler programs and to proper interaction with window managers. @end defun -@defun x:map-raised window -This procedure is similar to @code{x:map-window} in that it maps the -@var{window} and all of its subwindows that have had map requests. -However, it also raises the specified @var{window} to the top of the -stack. -@end defun - @defun x:map-subwindows window Maps all subwindows of a specified @var{window} in top-to-bottom stacking order. The X server generates x:Expose events on each newly @@ -859,7 +1008,7 @@ at a time because the server needs to perform much of the work only once, for all of the windows, rather than for each window. @end defun -@node Graphics Context, Cursor, Window Visibility, Top +@node Graphics Context, Cursor, Drawables, Top @chapter Graphics Context @noindent @@ -1312,13 +1461,13 @@ resides. Note that @var{window} is used only to determine the screen. @table @samp @item X:Gray-Scale -@itemx X:Pseudo-Color -@itemx X:Direct-Color +@item X:Pseudo-Color +@item X:Direct-Color The initial values of the colormap entries are undefined. @item X:Static-Gray -@itemx X:Static-Color -@itemx X:True-Color +@item X:Static-Color +@item X:True-Color The entries have defined values, but those values are specific to @var{visual} and are not defined by X. The @var{alloc-policy} must be @samp{X:Alloc-None}. @@ -1335,7 +1484,7 @@ undefined. @table @samp @item X:Gray-Scale -@itemx X:Pseudo-Color +@item X:Pseudo-Color The effect is as if an @code{XAllocColorCells} call returned all pixel values from zero to N - 1, where N is the colormap entries value in @var{visual}. @@ -1390,7 +1539,7 @@ be produced. All of these are allocated writable by the request. @table @samp @item x:Gray-Scale -@itemx x:Pseudo-Color +@item x:Pseudo-Color Each mask has exactly one bit set to 1. If @var{contiguous?} is non-false and if all masks are ORed together, a single contiguous set of bits set to 1 is formed. @@ -1523,8 +1672,12 @@ colormap. @end defun +@defun x:ccc colormap +Returns the Color-Conversion-Context of @var{colormap}. +@end defun + -@node Rendering, Event, Colormap, Top +@node Rendering, Images, Colormap, Top @chapter Rendering @defun x:flush display @@ -1697,7 +1850,14 @@ components: foreground, background, tile, stipple, tile-stipple-x-origin, and tile-stipple-y-origin. @end defun -@node Event, Index, Rendering, Top +@node Images, Event, Rendering, Top +@chapter Images + +@defun x:read-bitmap-file drawable file + +@end defun + +@node Event, Index, Images, Top @chapter Event @noindent @@ -1799,7 +1959,7 @@ For configure, create, gravity, and reparent events the @var{x} and parent window's origin and indicate the position of the upper-left outside corner of the created window. @item X-event:x-root -@itemx X-event:y-root +@item X-event:y-root @tab The pointer's coordinates relative to the root window's origin at the time of the @var{event}. @@ -1855,7 +2015,7 @@ Indicates the notification detail: @var{x:Notify-Ancestor}, If the event window is the focus window or an inferior of the focus window, #t; otherwise #f. @item X-event:width -@itemx X-event:height +@item X-event:height @tab The size (extent) of the rectangle. @item X-event:count @@ -1,4 +1,4 @@ -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 2001 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -41,7 +41,7 @@ ;;;; "bench.scm", Scheme benchmark computing digits of pi. ;;; Author: Aubrey Jaffer. -(require (in-vicinity (implementation-vicinity) "pi.scm")) +(load (in-vicinity (implementation-vicinity) "pi.scm")) (require 'transcript) (define isqrt (cond ((provided? 'inexact) sqrt) @@ -51,16 +51,17 @@ (else quotient))) (define around (cond ((provided? 'inexact) - (lambda (x) - (cond ((>= 3000 (abs x) 3) (inexact->exact (round x))) + (lambda (x bnd) + (cond ((>= 99999 (abs x) bnd) (inexact->exact (round x))) + ((> (abs x) 99999) (round x)) (else x)))) - (else identity))) + (else (lambda (x bnd) x)))) (define (time-pi digits) (let ((start-time (get-internal-run-time))) (pi digits 4) (i/ (* 1000 (- (get-internal-run-time) start-time)) - internal-time-units-per-second))) + internal-time-units-per-second))) (define (benchmark . arg) (define file @@ -75,22 +76,21 @@ (let* ((avg (i/ (apply + tl) (length tl))) (dev (isqrt (i/ (apply + (map (lambda (x) (* (- x avg) (- x avg))) - tl)) + tl)) (length tl))))) (and file (transcript-on file)) (for-each display - (list digits " digits took " (around avg) " mSec +/- " - (around dev) " mSec.")) + (list digits " digits took " (around avg 99) + " +/- " (around dev 3) ".ms")) (newline) - (let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits))) + (let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits)) + (scaled-dev (i/ (* (i/ (* dev 1000) digits) 1000) digits))) (for-each display - (list " That is about " scaled-avg - " mSec/k-digit^2 +/- " - (around - (i/ (* 100 (i/ (* (i/ (* dev 1000) digits) - 1000) digits)) - scaled-avg)) - "%.")) + (list " That is about " + (around scaled-avg 99) + " +/- " + (around scaled-dev 3) + ".ms/(kB)^2")) (newline) (and file (transcript-off))) )))))) diff --git a/bld.scm b/bld.scm deleted file mode 100644 index b12ecb9..0000000 --- a/bld.scm +++ /dev/null @@ -1,59 +0,0 @@ -#!/bin/sh -:;exec ./scmlit -f $0 -e"(bi)" build $* - -(require 'build) -(require 'getopt) -(require 'getopt-parameters) - -(define (build-from-argv argv) - (cond ((string? argv) - (require 'read-command) - (set! argv (call-with-input-string argv read-command)))) - (let () - (define command (string->symbol (list-ref argv *optind*))) - (define argc (length argv)) - (cond - ((pair? argv) - (set! *optind* (+ 1 *optind*)) - ((make-command-server build '*commands*) - command - (lambda (comname comval options positions arities types - defaulters checks aliases) - (let* ((params (getopt->parameter-list - argc argv options arities types aliases)) - (fparams (fill-empty-parameters defaulters params))) - (cond ((not (list? params)) #f) - ((not (check-parameters checks fparams)) #f) - ((not (check-arities (map arity->arity-spec arities) fparams)) - (slib:error 'build-from-argv "arity error" fparams) #f) - (else (comval fparams)))))))))) - -(define (build-from-whole-argv argv) - (set! *optind* 0) - (set! *optarg* #f) - (build-from-argv argv)) - -(define b build-from-whole-argv) - -(define (b*) - (require 'read-command) - (do ((e (read-command) (read-command))) - ((eof-object? e)) - (cond ((null? e)) - (else - (cond ((not (string-ci=? (car e) "build")) - (set! e (cons "build" e)))) - (write (build-from-whole-argv e)) - (newline))) - (display "build> ") - (force-output))) - -(define (bi) (build-from-argv *argv*)) - -(cond (*interactive* - (display "type (b \"build <command-line>\") to build") (newline) - (display "type (b*) to enter build command loop") (newline))) - -;;; Local Variables: -;;; mode:scheme -;;; End: @@ -1,5 +1,5 @@ -#!/bin/sh -:;exec scmlit -f $0 -e"(bi)" build $* +#! /bin/sh +:;exec ./scmlit -f $0 -e"(bi)" build $* (require (in-vicinity (program-vicinity) "build.scm")) (require 'getopt) @@ -65,6 +65,7 @@ NOS/VE, Unicos, VMS, Unix and similar systems. (append-info-node scm-info "Problems Running" "README") (append-info-node scm-info "Testing" "README"))) +(define build:csv (make-command-server build '*commands*)) (define (build-from-argv argv) (cond ((string? argv) (require 'read-command) @@ -75,15 +76,15 @@ NOS/VE, Unicos, VMS, Unix and similar systems. (cond ((pair? argv) (set! *optind* (+ 1 *optind*)) - ((make-command-server build '*commands*) + (build:csv command (lambda (comname comval options positions arities types defaulters checks aliases) (let* ((params (getopt->parameter-list argc argv options arities types aliases)) - (fparams (fill-empty-parameters defaulters params))) + (fparams (and params (fill-empty-parameters defaulters params)))) (cond ((not (list? params)) - (slib:warn 'build-from-argv 'not-parameters? fparams) + ;;(slib:warn 'build-from-argv 'not-parameters? fparams) #f) ((not (check-parameters checks fparams)) (slib:warn 'build-from-argv 'check-parameters 'failed) diff --git a/build.features b/build.features deleted file mode 100644 index 1921d3c..0000000 --- a/build.features +++ /dev/null @@ -1,123 +0,0 @@ -#!/bin/sh -:;exec scmlit -f $0 -e"(bi)" build $* - -(require (in-vicinity (program-vicinity) "build.scm")) -(require 'getopt) -(require 'getopt-parameters) - -(define (make-features-txi) - (call-with-output-file "features.txi" - (lambda (port) - ((((build 'open-table) 'features #f) 'for-each-row) - (lambda (row) - (apply (lambda (name spec documentation) - (display "@item " port) (display name port) (newline port) - (display "@cindex " port) (display name port) (newline port) - (display documentation port) (newline port) (newline port)) - row)))))) - -(define (print-manifest port) - (display "@multitable @columnfractions .22 .78" port) (newline port) - ((((build 'open-table) 'manifest #f) 'for-each-row) - (lambda (row) - (apply (lambda (file format category documentation) - (display (string-append "@item @code{" file) port) - (display "}" port) (newline port) - (display (string-append "@tab " documentation) port) - (newline port)) - row))) - (display "@end multitable" port) (newline port)) - -(define (append-info-node path node afile) - (let ((cat (open-file afile "a"))) - (do ((n (+ -1 2) (+ -1 n))) - ((negative? n) (close-port cat)) - (newline cat))) - (system (string-append "info -f " path " -n '" node "' -o - >> " afile))) - -(define (make-readme) - (require 'posix) - (let ((pipe (open-output-pipe "makeinfo --no-headers -o README")) - (scm-info (read-version - (in-vicinity (implementation-vicinity) "patchlvl.h")))) - (if (not pipe) (slib:error 'make-readme 'couldn't 'open 'pipe)) - (display "\ -This directory contains the distribution of scm" pipe) - (display scm-info pipe) - (display ". Scm conforms to -Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 -specification. SCM runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, -NOS/VE, Unicos, VMS, Unix and similar systems. - -@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html} - -@section Manifest -" - pipe) - (print-manifest pipe) - (close-port pipe) - (set! scm-info (string-append "scm" scm-info ".info")) - (append-info-node scm-info "SLIB" "README") - (append-info-node scm-info "Making SCM" "README") - (append-info-node scm-info "Editing Scheme Code" "README") - (append-info-node scm-info "Problems Compiling" "README") - (append-info-node scm-info "Problems Linking" "README") - (append-info-node scm-info "Problems Running" "README") - (append-info-node scm-info "Testing" "README"))) - -(define (build-from-argv argv) - (cond ((string? argv) - (require 'read-command) - (set! argv (call-with-input-string argv read-command)))) - (let () - (define command (string->symbol (list-ref argv *optind*))) - (define argc (length argv)) - (cond - ((pair? argv) - (set! *optind* (+ 1 *optind*)) - ((make-command-server build '*commands*) - command - (lambda (comname comval options positions arities types - defaulters checks aliases) - (let* ((params (getopt->parameter-list - argc argv options arities types aliases)) - (fparams (fill-empty-parameters defaulters params))) - (cond ((not (list? params)) - (slib:warn 'build-from-argv 'not-parameters? fparams) - #f) - ((not (check-parameters checks fparams)) - (slib:warn 'build-from-argv 'check-parameters 'failed) - #f) - ((not (check-arities (map arity->arity-spec arities) fparams)) - (slib:error 'build-from-argv "arity error" fparams) #f) - (else (comval fparams)))))))))) - -(define (build-from-whole-argv argv) - (set! *optind* 0) - (set! *optarg* #f) - (build-from-argv argv)) - -(define b build-from-whole-argv) - -(define (b*) - (require 'read-command) - (do ((e (read-command) (read-command))) - ((eof-object? e)) - (cond ((null? e)) - (else - (cond ((not (string-ci=? (car e) "build")) - (set! e (cons "build" e)))) - (write (build-from-whole-argv e)) - (newline))) - (display "build> ") - (force-output))) - -(define (bi) (if (build-from-argv *argv*) #t (exit #f))) - -(cond (*interactive* - (display "type (b \"build <command-line>\") to build") (newline) - (display "type (b*) to enter build command loop") (newline))) - -;;; Local Variables: -;;; mode:scheme -;;; End: @@ -1,13 +1,13 @@ ;;; "build.scm" Build database and program -*-scheme-*- -;;; Copyright (C) 1994-1999 Aubrey Jaffer. +;;; Copyright (C) 1994-2002 Aubrey Jaffer. ;;; See the file `COPYING' for terms applying to this program. (require 'parameters) -(require 'database-utilities) +(require 'databases) +(require 'database-commands) (set! OPEN_WRITE "w") ; Because MS-DOS scripts need ^M -;;;(define build (create-database "buildscm.scm" 'alist-table)) -(define build (create-database #f 'alist-table)) +(define build (add-command-tables (create-database #f 'alist-table))) (require 'glob) (require 'batch) @@ -73,7 +73,8 @@ ("setjump.s" Cray-asm platform-specific "provides setjump and longjump for the Cray YMP.") ("Init.scm" Scheme required "Scheme initialization.") ("Transcen.scm" Scheme required "inexact builtin procedures.") - ("Link.scm" Scheme required "compiles and dynamically links.") + ("Link.scm" Scheme required "Dynamic link/loading.") + ("compile.scm" Scheme required "Hobbit compilation to C.") ("Macro.scm" Scheme required "Supports Syntax-Rules Macros.") ("scmfig.h" c-header required "contains system dependent definitions.") ("patchlvl.h" c-header required "patchlevel of this release.") @@ -91,6 +92,7 @@ ("eval.c" c-source required "evaluator, apply, map, and foreach.") ("sys.c" c-source required "call-with-current-continuation, opening and closing files, storage allocation and garbage collection.") ("subr.c" c-source required "the rest of IEEE functions.") + ("debug.c" c-source required "debugging, printing code.") ("unif.c" c-source required "uniform vectors.") ("rope.c" c-source required "C interface functions.") ("ramap.c" c-source optional "array mapping") @@ -215,7 +217,7 @@ #;Alias for ARRAYS (define-build-feature 'array - '((define "ARRAYS"))) + '((features arrays))) #;array-map! and array-for-each (arrays must also be featured). (define-build-feature @@ -298,7 +300,7 @@ (define-build-feature 'turtlegr '((c-file "turtlegr.c") (c-lib graphics) (features inexact) - (init "init_turtlegr"))) + (compiled-init "init_turtlegr"))) #;Interface to Xlib graphics routines. (define-build-feature @@ -318,12 +320,12 @@ #;interface to the editline or GNU readline library. (define-build-feature 'edit-line - '((c-file "edline.c") (c-lib terminfo editline) (compiled-init "init_edline"))) + '((c-file "edline.c") (c-lib termcap editline) (compiled-init "init_edline"))) #;Client connections to the mysql databases. (define-build-feature 'mysql - '((c-file "database.c") (c-lib mysql) (init "init_database"))) + '((c-file "database.c") (c-lib mysql) (compiled-init "init_database"))) #;String regular expression matching. (define-build-feature @@ -447,12 +449,15 @@ (irix mips irix gcc ) ;gcc (linux i386 linux gcc ) ;gcc (linux-aout i386 linux gcc ) ;gcc + (darwin powerpc unix cc ) ;gcc (microsoft-c 8086 ms-dos cl ) ;link (microsoft-c-nt i386 ms-dos cl ) ;link (microsoft-quick-c 8086 ms-dos qcl ) ;qlink (ms-dos 8086 ms-dos cc ) ;link + (openbsd *unknown* unix gcc ) ;gcc (os/2-cset i386 os/2 icc ) ;link386 (os/2-emx i386 os/2 gcc ) ;gcc +;; (plan9-8 i386 plan9 8c ) ;8l (svr4-gcc-sun-ld sparc sunos gcc ) ;ld (sunos sparc sunos cc ) ;ld (svr4 *unknown* unix cc ) ;ld @@ -475,18 +480,19 @@ ((m *unknown* "" "-lm" "/usr/lib/libm.a" () ()) (c *unknown* "" "-lc" "/usr/lib/libc.a" () ()) - (regex *unknown* "" "-lrx" "/usr/lib/librx.a" () ()) + (regex *unknown* "" "-lregex" "/usr/lib/libregex.a" () ()) (curses *unknown* "" "-lcurses" "/usr/lib/libcurses.a" () ()) (graphics *unknown* "-I/usr/X11/include -DX11" "-lX11" "/usr/X11/lib/libX11.sa" () ()) (editline *unknown* "" "-lreadline" "/usr/lib/libreadline.a" () ()) - (termcap *unknown* "" "-lncurses" "/usr/lib/libncurses.a" () ()) + (termcap *unknown* "" "-ltermcap" "/usr/lib/libtermcap.a" () ()) (debug *unknown* "-g" "-g" #f () ()) (socket *unknown* "" "" #f () ()) (lib *unknown* "" "" #f () ("scmmain.c")) - (mysql *unknown* "" - "-lmysqlclient" "/usr/lib/mysql/libmysqlclient.la" () ()) + (mysql *unknown* "-I/usr/include/mysql" "-L/usr/lib/mysql -lmysqlclient" + "/usr/lib/mysql/libmysqlclient.a" () ()) + (m cygwin32 "" "" "" () ()) (c cygwin32 "" "" "" () ()) (m linux-aout "" "-lm" "/usr/lib/libm.sa" () ()) (c linux-aout "" "-lc" "/usr/lib/libc.sa" () ()) @@ -499,10 +505,12 @@ (m linux "" "-lm" "/lib/libm.so" () ()) (c linux "" "-lc" "/lib/libc.so" () ()) + (regex linux "" "" "" () ()) + (termcap linux "" "-lncurses" "/usr/lib/libncurses.a" () ()) (dlll linux "-DSUN_DL" "-ldl" #f () ()) (graphics linux "-I/usr/include/X11 -DX11" "-L/usr/X11R6/lib -lX11" "/usr/X11R6/lib/libX11.so" () ()) - (curses linux "" "-lcurses" "/lib/libncurses.so" () ()) + (curses linux "" "-lncurses" "/usr/lib/libncurses.so" () ()) (nostart linux "" "" #f () ()) (dump linux "" "" #f ("unexelf.c" "gmalloc.c") ()) @@ -523,13 +531,16 @@ (m atari-st-gcc "" "-lpml" #f () ()) (m atari-st-turbo-c "" "" #f () ()) +;; (c plan9-8 "" "" #f () ()) +;; (m plan9-8 "" "" #f () ()) + (m sunos "" "-lm" #f () ()) (dlll sunos "-DSUN_DL" "-ldl" #f () ()) (nostart sunos "" "-e __start -nostartfiles -static" #f ("ecrt0.c") ()) (dump sunos "" "" #f ("unexelf.c" "gmalloc.c") ()) (m svr4-gcc-sun-ld "" "-lm" #f () ()) - (dlll svr4-gcc-sun-ld "-DSUN_DL" "-Wl,-ldl" #f () ()) + (dlll svr4-gcc-sun-ld "-DSUN_DL" "-Wl,-ldl -export-dynamic" #f () ()) (nostart svr4-gcc-sun-ld "" "-e __start -nostartfiles" #f ("ecrt0.c") ()) (dump svr4-gcc-sun-ld "" "" #f ("unexelf.c" "gmalloc.c") ()) (socket svr4-gcc-sun-ld "" "-lsocket -lnsl" #f () ()) @@ -559,6 +570,7 @@ (m Microsoft-C "" "" #f () ()) (c Microsoft-C-nt "" "" #f () ("findexec.c")) (m Microsoft-C-nt "" "" #f () ()) + (debug Microsoft-C-nt "-Zi" "/debug" #f () ()) (c Microsoft-Quick-C "" "" #f () ("findexec.c")) (m Microsoft-Quick-C "" "" #f () ()) @@ -575,12 +587,20 @@ (m highc "" "" #f () ()) (windows highc "-Hwin" "-Hwin" #f () ()) + (m darwin "" "" #f () ()) + (c darwin "" "" #f () ()) + (curses darwin "" "" #f () ()) + (regex darwin "" "" #f () ()) + (m freebsd "" "-lm" #f () ()) + (curses freebsd "" "-lncurses" "/usr/lib/libncurses.a" () ()) (regex freebsd "" "-lgnuregex" "" () ()) (editline freebsd "" "-lreadline" "" () ()) (dlll freebsd "-DSUN_DL" "" "" () ()) (nostart freebsd "" "-e start -dc -dp -Bstatic -lgnumalloc" #f ("pre-crt0.c") ()) (dump freebsd "" "/usr/lib/crt0.o" "" ("unexsunos4.c") ()) + (m openbsd "" "-lm" #f () ()) + (curses openbsd "" "-lcurses" "/usr/lib/libcurses.a" () ()) )) '(compile-commands @@ -673,12 +693,15 @@ oexe)))) (defcommand compile-c-files Microsoft-C-nt (lambda (files parms) - (and (batch:try-chopped-command parms - "cl" "-c" "-nologo" "-O2" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) + (and (batch:try-chopped-command + parms + "cl" "-c" "-nologo" + (if (memq 'stack-limit (parameter-list-ref parms 'features)) + "-Oityb1" "-Ox") + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) (truncate-up-to (map c->obj files) #\\)))) (defcommand link-c-program Microsoft-C-nt (lambda (oname objects libs parms) @@ -880,19 +903,6 @@ ; objects) ; (batch:rebuild-catalog parms) ; (string-append oname ".sl")))) -(defcommand make-dll-archive sunos - (lambda (oname objects libs parms) - (and (batch:try-command - parms - "ld" "-assert" "pure-text" "-o" - (string-append - (car (parameter-list-ref parms 'implvic)) - oname ".so.1.0") - objects) - (batch:rebuild-catalog parms) - (string-append - (car (parameter-list-ref parms 'implvic)) - oname ".so.1.0")))) (defcommand compile-c-files linux-aout (lambda (files parms) @@ -937,11 +947,9 @@ "-fpic" "-c" (c-includes parms) (c-flags parms) files) - (let* ((platform (car (parameter-list-ref - parms 'platform))) + (let* ((platform (car (parameter-list-ref parms 'platform))) (ld-opts - (map (lambda (l) - (build:lib-ld-flag l platform)) + (map (lambda (l) (build:lib-ld-flag l platform)) (parameter-list-ref parms 'c-lib))) (results (map @@ -968,8 +976,7 @@ (car (parameter-list-ref parms 'implvic)) oname ".so") objects - (map (lambda (l) - (build:lib-ld-flag l platform)) + (map (lambda (l) (build:lib-ld-flag l platform)) (parameter-list-ref parms 'c-lib))) (batch:rebuild-catalog parms) (string-append @@ -984,7 +991,7 @@ (append objects libs))) oname))) -(defcommand compile-c-files Unicos +(defcommand compile-c-files unicos (lambda (files parms) (and (batch:try-chopped-command parms @@ -1000,6 +1007,34 @@ parms "cc" "setjump.o" "-o" oname objects libs) oname))) +;; George Bronnikov <goga@rubinstein.mccme.ru> describes options for the +;; PLAN9 native C compiler `8c': +;; +;; -F Enable type-checking of calls to print(2) and other +;; formatted print routines. +;; -V By default, the compilers are non-standardly lax about +;; type equality between void* values and other pointers. +;; This flag requires ANSI C conformance. +;; -w Print warning messages about unused variables etc. (It +;; does print a lot of them, indeed.) +;; -p Invoke a standard ANSI C preprocessor before compiling +;; (instead of a rudimentary builtin one used by default). +;;(defcommand compile-c-files plan9-8 +;; (lambda (files parms) +;; (and (batch:try-chopped-command +;; parms +;; "8c" "-Fwp" "-DPLAN9" ;"-V" +;; ;;(include-spec "-i" parms) +;; (c-includes parms) +;; (c-flags parms) +;; files) +;; (truncate-up-to (map c->8 files) #\/)))) +;;(defcommand link-c-program plan9-8 +;; (lambda (oname objects libs parms) +;; (and (batch:try-command +;; parms "8l" "-o" oname objects libs) +;; oname))) + (defcommand compile-c-files gcc (lambda (files parms) (and (batch:try-chopped-command parms @@ -1029,6 +1064,19 @@ (c-flags parms) files) (truncate-up-to (map c->o files) "\\/]")))) +(defcommand make-dll-archive gcc + (lambda (oname objects libs parms) + (and (batch:try-command + parms + "ld" "-assert" "pure-text" "-o" + (string-append + (car (parameter-list-ref parms 'implvic)) + oname ".so.1.0") + objects) + (batch:rebuild-catalog parms) + (string-append + (car (parameter-list-ref parms 'implvic)) + oname ".so.1.0")))) (defcommand compile-c-files cygwin32 (lambda (files parms) @@ -1074,6 +1122,33 @@ "/usr/lib/crt0.o") (append objects libs))) oname))) +(defcommand compile-dll-c-files svr4-gcc-sun-ld + (lambda (files parms) + (and + (batch:try-chopped-command + parms + "gcc" "-O2" + "-fpic" "-c" (c-includes parms) + (c-flags parms) + files) + (let* ((platform (car (parameter-list-ref parms 'platform))) + (ld-opts + (map (lambda (l) (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib))) + (results + (map + (lambda (fname) + (and (batch:try-command + parms + "ld" "-G" "-o" + (string-append fname ".so") + (string-append fname ".o") + ld-opts) + (batch:delete-file + parms (string-append fname ".o")) + (string-append fname ".so"))) + (truncate-up-to (map c-> files) #\/)))) + (and (apply and? results) results))))) (defcommand compile-c-files svr4 (lambda (files parms) @@ -1397,6 +1472,79 @@ (car (parameter-list-ref parms 'implvic)) oname ".so")))) +(defcommand compile-c-files darwin + (lambda (files parms) + (and (batch:try-chopped-command + parms + "cc" "-O3" "-c" + (c-includes parms) + (c-flags parms) + files) + (map c->o files)))) +(defcommand link-c-program darwin + (lambda (oname objects libs parms) + (batch:rename-file parms + oname (string-append oname "~")) + (and (batch:try-command parms + "cc" "-o" oname + (append objects libs)) + oname))) + +(defcommand compile-c-files openbsd + (lambda (files parms) + (and (batch:try-chopped-command + parms + "cc" "-O2" "-Wall" "-c" + (c-includes parms) + (c-flags parms) + files) + (map c->o files)))) +(defcommand link-c-program openbsd + (lambda (oname objects libs parms) + (batch:rename-file parms + oname (string-append oname "~")) + (and (batch:try-command parms + "cc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "crt0.o" + "/usr/lib/crt0.o") + (append libs objects))) + oname))) +(defcommand compile-dll-c-files openbsd + (lambda (files parms) + (and (batch:try-chopped-command + parms + "cc" "-O2" "-Wall" "-fPIC" "-c" + (string-append + "-I" (parameter-list-ref parms 'scm-srcdir)) + (c-includes parms) + (c-flags parms) + files) + (let ((objs (map c->o files))) + (every + (lambda (f) + (and (batch:try-command + parms "gcc" "-shared" "-fPIC" f) + (batch:try-command + parms "mv" "a.out" f))) + objs) + objs)))) + +(defcommand make-dll-archive openbsd + (lambda (oname objects libs parms) + (and (batch:try-command + parms + "gcc" "-shared" "-fPIC" "-o" + (string-append + (car (parameter-list-ref parms 'implvic)) + oname ".so") + objects) + (batch:rebuild-catalog parms) + (string-append + (car (parameter-list-ref parms 'implvic)) + oname ".so")))) + (for-each (build 'add-domain) '((C-libraries C-libraries #f symbol #f))) @@ -1406,7 +1554,7 @@ *parameter-columns* *parameter-columns* ((1 platform single platform - (lambda (pl) (list batch:platform)) + (lambda (pl) (list *operating-system*)) #f "what to build it for") (2 target-name single string (lambda (pl) '("scm")) #f @@ -1446,12 +1594,9 @@ (16 scm-srcdir single filename (lambda (pl) (list (user-vicinity))) #f "directory path for files in the manifest") - (17 scm-libdir single filename - (lambda (pl) (list (implementation-vicinity))) #f - "directory path for files in the manifest") - (18 c-defines nary expression #f #f "#defines for C") - (19 c-includes nary expression #f #f "library induced defines for C") - (20 batch-port nary expression #f #f + (17 c-defines nary expression #f #f "#defines for C") + (18 c-includes nary expression #f #f "library induced defines for C") + (19 batch-port nary expression #f #f "port batch file will be written to.") )) '(build-pnames @@ -1473,7 +1618,6 @@ ("compiler options" 14) ("linker options" 15) ("scm srcdir" 16) - ("scm libdir" 17) )) '(*commands* @@ -1493,9 +1637,6 @@ #f "SCM Build Database")))) -;;;((build 'close-database)) -;;;(define build (open-database! "buildscm.scm" 'alist-table)) - (define build:error slib:error) (define build:c-libraries #f) (define build:lib-cc-flag #f) @@ -1503,6 +1644,7 @@ (define build:c-lib-support #f) (define build:c-suppress #f) (define plan-command #f) +(define platform->os #f) ;;; Look up command on a platform, but default to '*unknown* if not ;;; initially found. @@ -1588,10 +1730,15 @@ parms (cons 'batch-dialect (list (os->batch-dialect os))))))) (adjoin-parameters! - parms - (cons 'c-defines c-defines) - (cons 'c-includes c-includes)) - + parms + (cons 'c-defines c-defines) + (cons 'c-includes c-includes)) + (set! parms + (cons + (cons 'operating-system + (map platform->os (parameter-list-ref parms 'platform))) + parms)) + (let ((name (parameter-list-ref parms 'who))) (set! name (if (null? name) (current-output-port) (car name))) (batch:call-with-output-script @@ -1678,6 +1825,7 @@ (define c-> (filename:substitute?? "*.c" "*")) (define c->o (filename:substitute?? "*.c" "*.o")) +(define c->8 (filename:substitute?? "*.c" "*.8")) (define c->obj (filename:substitute?? "*.c" "*.obj")) (define obj-> (filename:substitute?? "*.obj" "*")) (define obj->exe (filename:substitute?? "*.obj" "*.exe")) @@ -1701,6 +1849,46 @@ "slibcat")) #t) +(define (logger . args) + (define cep (current-error-port)) + (cond ((provided? 'bignum) + (require 'posix-time) + (let ((ct (ctime (current-time)))) + (string-set! ct (+ -1 (string-length ct)) #\:) + (for-each (lambda (x) (display x cep)) + (cons ct (cons #\ args))))) + (else (for-each (lambda (x) (display x cep)) args))) + (newline cep)) + +(define build:qacs #f) +(define (build:serve request-line query-string header) + (define query-alist (and query-string (uri:decode-query query-string))) + (if (not build:qacs) + (set! build:qacs (make-query-alist-command-server build '*commands* #t))) + (call-with-outputs + (lambda () (build:qacs query-alist)) + (lambda (stdout stderr . status) + (cond ((or (substring? ": ERROR: " stderr) + (substring? ": WARN: " stderr)) + => (lambda (idx) + (set! stderr (substring stderr (+ 2 idx) + (string-length stderr)))))) + (cond ((null? status) + (logger "Aborting query") + (pretty-print query-alist) + (display stderr) + (list "buildscm Abort" (html:pre stdout) + "<B>" (html:pre stderr) "</B>")) + (else + (display stderr) ;query is already logged + (if (car status) + (http:content '(("Content-Type" . "text/plain")) ;application/x-sh + stdout) + (list "buildscm Error" "<B>" (html:pre stderr) "</B>" + "<HR>" + (html:pre stdout)))))))) +;;; (print 'request-line '= (cgi:request-line)) (print 'header '=) (for-each print (cgi:query-header)) + (define build:initializer (lambda (rdb) (set! build:c-libraries ((rdb 'open-table) 'c-libraries #f)) @@ -1716,10 +1904,13 @@ (set! build:c-suppress (make-defaulting-platform-lookup (build:c-libraries 'get 'suppress-files))) + (set! platform->os (((rdb 'open-table) 'platform #f) + 'get 'operating-system)) (set! plan-command (let ((lookup (make-defaulting-platform-lookup (((rdb 'open-table) 'compile-commands #f) 'get 'procedure)))) (lambda (thing plat) + ;;(print 'thing thing 'plat plat) (slib:eval (lookup thing plat))))))) (build:initializer build) diff --git a/compile.scm b/compile.scm new file mode 100755 index 0000000..ce96822 --- /dev/null +++ b/compile.scm @@ -0,0 +1,112 @@ +#! /bin/sh +:;exec scm -e"(set! *script* \"$0\")" -f$0 $* + +;; Copyright (C) 1992-2002 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of SCM. +;; +;; The exception is that, if you link the SCM library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the SCM library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name SCM. If you copy +;; code from other Free Software Foundation releases into a copy of +;; SCM, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for SCM, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "compile.scm", Compile C ==> Scheme ==> object-file. +;;; Author: Aubrey Jaffer. + +(define (go-script) + (cond ((not *script*)) + ((and (<= 1 (- (length *argv*) *optind*)) + (not (eqv? #\- (string-ref (car (list-tail *argv* *optind*)) 0)))) + (apply compile-file (list-tail *argv* *optind*))) + (else + (display "\ +\ +Usage: compile.scm FILE1.scm FILE2.scm ... +\ + Compiles Scheme FILE1.scm FILE2.scm ... to an object file named + FILE1<object-suffix>, where <object-suffix> is the object file suffix + for your computer (for instance, `.o'). FILE1.scm must be in the + current directory; FILE2.scm ... can be in other directories. +" + (current-error-port)) + (exit #f)))) + +;;; This unusual autoload loads either the +;;; source or compiled version if present. +(if (not (defined? hobbit)) ;Autoload for hobbit +(define (hobbit . args) + (require 'hobbit) + (apply hobbit args))) + +(define (compile-file file . args) + (require 'glob) + (apply hobbit file args) + (let ((command + (list "build" + "-hsystem" + "-tdll" + (string-append "--compiler-options=-I" (implementation-vicinity)) + "-c" (replace-suffix file (scheme-file-suffix) ".c")))) + (require 'build) + (cond ((>= (verbose) 3) (write command) (newline))) + (build-from-whole-argv command))) + +(define (compile->executable name . args) + (define sfs (scheme-file-suffix)) + (require 'glob) + (for-each hobbit args) + (let ((inits (map (lambda (file) + (string-append "-iinit_" (replace-suffix file sfs ""))) + args)) + (files (map (lambda (file) + (string-append "-c" (replace-suffix file sfs ".c"))) + args))) + (define command (append (list "build" + "-hsystem" + "--type=exe" + "-o" name + "-F" "compiled-closure" "inexact" + (string-append "--linker-options=-L" + (implementation-vicinity))) + files + inits)) + (require 'build) + (cond ((>= (verbose) 3) (write command) (newline))) + (build-from-whole-argv command))) + +(go-script) + +;;; Local Variables: +;;; mode:scheme +;;; End: @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -156,7 +156,7 @@ void free_continuation(cont) out of control: You are experiencing a GC problem peculiar to the Sparc. The - problem is that contin doesn't know how to clear register windows. + problem is that SCM doesn't know how to clear register windows. Every location which is not reused still gets marked at GC time. This causes lots of stuff which should be collected to not be. This will be a problem with any *conservative* GC until we find @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -63,8 +63,10 @@ extern int longjump(jump_buf env, int ret); # else /* ndef _CRAY1 */ -# include <setjmp.h> -# include <signal.h> +# ifndef PLAN9 +# include <setjmp.h> +# include <signal.h> +# endif # ifdef SIG_UNBLOCK # define jump_buf sigjmp_buf # define setjump(buf) sigsetjmp((buf), !0) @@ -170,7 +172,7 @@ void throw_to_continuation P((CONTINUATION *cont, long val, continuations on the SPARC. It flushes the register windows so that all the state of the process is contained in the stack. */ -#if defined(sparc) || defined(__sparc__) +#if defined (sparc) || defined (__sparc__) || defined (__sparc) # define FLUSH_REGISTER_WINDOWS asm("ta 3") #else # define FLUSH_REGISTER_WINDOWS /* empty */ @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -43,7 +43,12 @@ Author: Aubrey Jaffer */ #include "scm.h" -#include <curses.h> + +#ifdef __FreeBSD__ +# include <ncurses.h> +#else +# include <curses.h> +#endif #ifdef MWC # include <unctrl.h> @@ -54,18 +59,6 @@ int wgetch P((WINDOW *)); #endif -static int curses_initted = 0; - -static SCM scm_linitscr(void); - - -static void do_init_maybe() -{ - if(!curses_initted) - scm_linitscr(); - curses_initted = 1; -} - /* define WIN port type */ #define WIN(obj) ((WINDOW*)CDR(obj)) #define WINP(obj) (tc16_window==TYP16(obj)) @@ -96,8 +89,8 @@ static ptobfuns winptob = { bwaddch, bwaddstr, bwwrite, - wrefresh, /* warning from compiler is wrefresh(WINDOW*) not (FILE*) */ - wgetch, /* warning from compiler is wrefresh(WINDOW*) not (FILE*) */ + wrefresh, + wgetch, freewindow}; SCM mkwindow(win) @@ -105,16 +98,14 @@ SCM mkwindow(win) { SCM z; if (NULL==win) return BOOL_F; - NEWCELL(z); DEFER_INTS; - SETCHARS(z, win); - CAR(z) = scm_port_entry(tc16_window, OPN | RDNG | WRTNG); + z = scm_port_entry((FILE *)win, tc16_window, OPN | RDNG | WRTNG); ALLOW_INTS; return z; } SCM *loc_stdscr = 0; -SCM scm_linitscr() +SCM linitscr() { WINDOW *win; if NIMP(*loc_stdscr) { @@ -122,12 +113,10 @@ SCM scm_linitscr() return *loc_stdscr; } win = initscr(); - curses_initted = 1; return *loc_stdscr = mkwindow(win); } SCM lendwin() { - do_init_maybe(); if IMP(*loc_stdscr) return BOOL_F; return ERR==endwin() ? BOOL_F : BOOL_T; } @@ -146,7 +135,6 @@ SCM lnewwin(lines, cols, args) begin_x = CAR(CDR(args)); ASSERT(INUMP(begin_y), begin_y, ARG3, s_newwin); ASSERT(INUMP(begin_x), begin_y, ARG4, s_newwin); - do_init_maybe(); win = newwin(INUM(lines), INUM(cols), INUM(begin_y), INUM(begin_x)); return mkwindow(win); @@ -317,7 +305,7 @@ static char s_nonl[] = "nonl", s_nocbreak[] = "nocbreak", s_noecho[] = "noecho", s_noraw[] = "noraw"; static iproc subr0s[] = { - {"initscr", scm_linitscr}, + {"initscr", linitscr}, {"endwin", lendwin}, {&s_nonl[2], lnl}, {s_nonl, lnonl}, @@ -418,5 +406,5 @@ void init_crs() make_subr(s_mvwin, tc7_subr_3, lmvwin); make_subr(s_box, tc7_subr_3, lbox); add_feature("curses"); - /* add_final(lendwin); */ + add_final(lendwin); } diff --git a/debian/changelog b/debian/changelog index 981ac53..e25b173 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,112 @@ +scm (5d6-3.2) unstable; urgency=low + + * Fix hppa compile. Closes: #144062 + + -- LaMont Jones <lamont@debian.org> Wed, 7 May 2003 08:36:40 -0600 + +scm (5d6-3.1) unstable; urgency=low + + * NMU with patch from James Troup, to fix FTBFS on sparc. Closes: #191171 + + -- Joey Hess <joeyh@debian.org> Tue, 29 Apr 2003 19:56:51 -0400 + +scm (5d6-3) unstable; urgency=low + + * Add build depend on xlibs-dev (Closes: #148020) + + -- James LewisMoss <dres@debian.org> Fri, 24 May 2002 15:56:12 -0400 + +scm (5d6-2) unstable; urgency=low + + * Remove libregexx-dev from build-depends. + * Change build to use ./scmlit rather than scmlit (should fix some build + problems) (looks like alpha is mostly building) + * New release (Closes: #140175) + * Built with turtlegraphics last time (Closes: #58515) + + -- James LewisMoss <dres@debian.org> Thu, 23 May 2002 13:41:02 -0400 + +scm (5d6-1) unstable; urgency=low + + * New upstream. + * Add xlib and turtlegr to requested list of features. (closes + some bug) + * Make clean actually clean most everything up. + * Remove hacks renaming build to something else and just set build as a + .PHONY target in debian/rules. + * Add the turtlegr code. + + -- James LewisMoss <dres@debian.org> Fri, 17 May 2002 13:27:00 -0400 + +scm (5d5-1) unstable; urgency=low + + * New upstream + * Has fixes for 64 bit archs. May fix alpha compile problem. Does fix + (Closes: #140175) + * Take out -O2 arg. + + -- James LewisMoss <dres@debian.org> Sat, 6 Apr 2002 17:46:22 -0500 + +scm (5d4-3) unstable; urgency=low + + * Don't link with regexx, but just use libc6's regular expression + functions. + * Define (terms) to output /usr/share/common-licenses/GPL (Closes: + #119321) + + -- James LewisMoss <dres@debian.org> Wed, 12 Dec 2001 16:27:02 -0500 + +scm (5d4-2) unstable; urgency=low + + * Add texinfo to build depends (Closes: #107011) + + -- James LewisMoss <dres@debian.org> Sun, 29 Jul 2001 22:16:35 -0400 + +scm (5d4-1) unstable; urgency=low + + * New upstream release. + * Move install-info --remove to prerm. + + -- James LewisMoss <dres@debian.org> Tue, 22 May 2001 01:35:50 -0400 + +scm (5d3-5) unstable; urgency=low + + * Move scm info files to section "The Algorithmic Language Scheme" to + match up with guile. + + -- James LewisMoss <dres@debian.org> Mon, 11 Dec 2000 03:49:34 -0500 + +scm (5d3-4) unstable; urgency=low + + * Fix build depends (Closes: #76691) + + -- James LewisMoss <dres@debian.org> Sat, 11 Nov 2000 09:55:07 -0500 + +scm (5d3-3) unstable; urgency=low + + * Fix path in scm dhelp file. + + -- James LewisMoss <dres@debian.org> Fri, 27 Oct 2000 15:37:47 -0400 + +scm (5d3-2) unstable; urgency=low + + * Actually put the header files in the package. Oops. + + -- James LewisMoss <dres@debian.org> Thu, 26 Oct 2000 21:52:47 -0400 + +scm (5d3-1) unstable; urgency=low + + * New upstream. (Closes: #74761) + * Make (terms) use new license location. + * Make use libregexx rather than librx. + * Fix build depends for above. + * Using new regex lib seems to fix crash (Closes: #66787) + * Consider adding scm-dev package with headers, but instead just add the + headers to the scm package. (Closes: #70787) + * Add doc-base support. + + -- James LewisMoss <dres@debian.org> Sun, 22 Oct 2000 22:29:41 -0400 + scm (5d2-3) unstable frozen; urgency=low * Fix libncurses4-dev -> libncurses5-dev build depend (Closes: #58435) @@ -127,7 +236,3 @@ scm (4e6-1) unstable; urgency=low -- Karl Sackett <krs@debian.org> Fri, 13 Dec 1996 08:55:23 -0600 -Local variables: -mode: debian-changelog -add-log-mailing-address: "dres@debian.org" -End: diff --git a/debian/control b/debian/control index adca312..533edb2 100644 --- a/debian/control +++ b/debian/control @@ -3,11 +3,14 @@ Section: interpreters Priority: optional Maintainer: James LewisMoss <dres@debian.org> Standards-Version: 3.1.1 -Build-Depends: slib, librx1g-dev, libncurses5-dev, libreadline4-dev, tetex-bin +Build-Depends: slib, libncurses5-dev, libreadline4-dev, texi2html, texinfo, xlibs-dev Package: scm Architecture: any +Section: interpreters +Priority: optional Depends: slib, ${shlibs:Depends} Description: A Scheme language interpreter. Scm conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. + diff --git a/debian/doc-base b/debian/doc-base new file mode 100644 index 0000000..59abf3f --- /dev/null +++ b/debian/doc-base @@ -0,0 +1,12 @@ +Document: scm +Title: SCM: scheme interpreter +Author: Aubrey Jaffer +Abstract: This manual describes the scheme interpreter scm. +Section: Apps/Programming + +Format: info +Files: /usr/share/info/scm.info + +Format: HTML +Index: /usr/share/doc/scm/scm.html +Files: /usr/share/doc/scm/scm.html diff --git a/debian/postinst b/debian/postinst index aa12961..c762db4 100644 --- a/debian/postinst +++ b/debian/postinst @@ -1,7 +1,8 @@ #!/bin/sh set -e -install-info --quiet --section "Development" "Development" \ +install-info --quiet --section "The Algorithmic Language Scheme" \ + "The Algorithmic Language Scheme" \ --description="A Scheme language interpreter" \ /usr/share/info/scm.info.gz @@ -10,3 +11,10 @@ if [ "$1" = "configure" ]; then ln -sf ../share/doc/scm /usr/doc/scm fi fi + +# doc base support +if [ "$1" = configure ]; then + if command -v install-docs >/dev/null 2>&1; then + install-docs -i /usr/share/doc-base/scm + fi +fi diff --git a/debian/postrm b/debian/postrm deleted file mode 100644 index e7f4756..0000000 --- a/debian/postrm +++ /dev/null @@ -1,4 +0,0 @@ -#!/bin/sh -set -e - -install-info --quiet --remove scm diff --git a/debian/prerm b/debian/prerm index 85fdaab..968aa17 100644 --- a/debian/prerm +++ b/debian/prerm @@ -6,3 +6,11 @@ if [ \( "$1" = "upgrade" -o "$1" = "remove" \) -a -L /usr/doc/scm ]; then rm -f /usr/doc/scm fi +# doc base support +if [ "$1" = remove -o "$1" = upgrade ]; then + if command -v install-docs >/dev/null 2>&1; then + install-docs -r scm + fi +fi + +install-info --quiet --remove /usr/share/info/scm.info.gz diff --git a/debian/rules b/debian/rules index bc0618f..da0e302 100755 --- a/debian/rules +++ b/debian/rules @@ -2,7 +2,7 @@ # -*-Makefile-*- CC =gcc -CFLAGS =-O2 -g -Wall +CFLAGS = -g -Wall LDFLAGS = SHELL =/bin/sh @@ -17,12 +17,11 @@ INSTALL_MAN =$(INSTALL) -m 644 -o root -g root ifeq ($(DEB_BUILD_ARCH), m68k) COMPILER_OPTIONS= else -COMPILER_OPTIONS=-O2 +COMPILER_OPTIONS= endif SCM_OPTIONS = -p linux \ - --compiler-options=-g \ - --compiler-options=$(COMPILER_OPTIONS) \ + --compiler-options="$(COMPILER_OPTIONS)" \ -F cautious \ -F bignums \ -F arrays \ @@ -40,46 +39,51 @@ SCM_OPTIONS = -p linux \ -F unix \ -F curses \ -F dynamic-linking \ + -F turtlegr \ + -F xlib \ -F dump \ -F macro +# -F dump + # -F heap-can-shrink \ -NON_LIB_FILES = 'bench.scm|build.scm|example.scm|r4rstest.scm|pi.scm' +NON_LIB_FILES = 'bench.scm|build.scm|example.scm|r4rstest.scm|pi.scm|grtest.scm' #test: stamp-configure # $(checkdir) # make checklit -build: - chmod +x bld.scm +build: build-stamp +build-stamp: + chmod +x build $(checkdir) cp debian/require.scm.debian require.scm ifeq ($(DEB_BUILD_ARCH), m68k) - ${MAKE} scmlit CFLAGS=-g + ${MAKE} scmlit CFLAGS="-g -Wall" else ${MAKE} scmlit endif test -e /usr/share/slib || \ - (echo "Must have slib installed for compile" && exit 1) -# SCHEME_LIBRARY_PATH=/usr/share/slib/ ./build.scm ${SCM_OPTIONS} > debian/bld - ./bld.scm ${SCM_OPTIONS} > debian/bld + (echo "Must have slib installed for compile" && exit 1) + ./build ${SCM_OPTIONS} > debian/bld chmod ug+x debian/bld debian/bld - #-rm -f debian/bld - #makeinfo scm.texi -o scm.info make scm.info texi2html -monolithic scm.texi - touch build + touch build-stamp clean: $(checkdir) - -rm scm.info* scm.html tmp1 tmp2 scmflags.h scmlit + -rm -f scm.info* scm.html tmp1 tmp2 scmflags.h scmlit + -rm -f features.txi platform.txi -rm -f scm5d0.info -rm require.scm scm make distclean - -rm -f build debian/bld + -rm -f srcdir.mk + -rm -f debian/bld -rm -rf *~ debian/*~ debian/tmp* debian/files debian/substvars + -rm -f build-stamp binary-indep: checkroot $(checkdir) @@ -93,7 +97,6 @@ binary-arch: checkroot build $(INSTALL_DIR) debian/tmp/DEBIAN $(INSTALL_PROGRAM) debian/postinst debian/tmp/DEBIAN $(INSTALL_PROGRAM) debian/prerm debian/tmp/DEBIAN - $(INSTALL_PROGRAM) debian/postrm debian/tmp/DEBIAN # binaries $(INSTALL_DIR) debian/tmp/usr/bin @@ -103,7 +106,10 @@ binary-arch: checkroot build $(INSTALL_DIR) debian/tmp/usr/lib/scm $(INSTALL_DATA) `ls *.scm | egrep -v ${NON_LIB_FILES}` debian/tmp/usr/lib/scm $(INSTALL_DATA) slibcat debian/tmp/usr/lib/scm - chmod +x debian/tmp/usr/lib/scm/bld.scm + +# headers + $(INSTALL_DIR) debian/tmp/usr/include/scm + $(INSTALL_DATA) *.h debian/tmp/usr/include/scm # man pages $(INSTALL_DIR) debian/tmp/usr/share/man/man1 @@ -120,6 +126,9 @@ binary-arch: checkroot build $(INSTALL_DATA) scm.html debian/tmp/usr/share/doc/scm $(INSTALL_DATA) debian/copyright debian/tmp/usr/share/doc/scm + $(INSTALL_DIR) debian/tmp/usr/share/doc-base + $(INSTALL_DATA) debian/doc-base debian/tmp/usr/share/doc-base/scm + # examples $(INSTALL_DIR) debian/tmp/usr/share/doc/scm/examples $(INSTALL_DATA) r4rstest.scm debian/tmp/usr/share/doc/scm/examples @@ -127,6 +136,7 @@ binary-arch: checkroot build $(INSTALL_DATA) pi.scm debian/tmp/usr/share/doc/scm/examples $(INSTALL_DATA) pi.c debian/tmp/usr/share/doc/scm/examples $(INSTALL_DATA) bench.scm debian/tmp/usr/share/doc/scm/examples + $(INSTALL_DATA) grtest.scm debian/tmp/usr/share/doc/scm/examples $(INSTALL_DATA) split.scm debian/tmp/usr/share/doc/scm/examples # info pages @@ -148,4 +158,4 @@ checkroot: $(checkdir) test root = "`whoami`" -.PHONY: clean binary binary-arch binary-indep +.PHONY: build clean binary binary-arch binary-indep @@ -0,0 +1,751 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of SCM. + * + * The exception is that, if you link the SCM library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the SCM library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name SCM. If you copy + * code from other Free Software Foundation releases into a copy of + * SCM, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for SCM, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "debug.c" procedures for displaying and debugging code. + Authors: Radey Shouman & Aubrey Jaffer. */ + +#include "scm.h" +#include "setjump.h" + +long tc16_codeptr; /* Type code for non-executable code + wrappers */ + +static SCM prinhead P((SCM x, SCM port, int writing)); +static void prinbindings P((SCM names, SCM inits, SCM init_env, + SCM steps, SCM step_env, SCM port, int writing)); + +SCM scm_env_rlookup(addr, stenv, what) + SCM addr, stenv; + char *what; +{ + SCM env, fr; + int icdrp; + unsigned int idist, iframe; + if (IMP(addr)) { + if (!ILOCP(addr)) return BOOL_F; + iframe = IFRAME(addr); + idist = IDIST(addr); + icdrp = ICDRP(addr) && 1; + } + else { + if (!ISYMP(CAR(addr))) return BOOL_F; + icdrp = 0; + switch (ISYMNUM(CAR(addr))) { + default: return BOOL_F; + case (ISYMNUM(IM_FARLOC_CDR)): + icdrp = 1; + case (ISYMNUM(IM_FARLOC_CAR)): + fr = CDR(addr); + iframe = INUM(CAR(fr)); + idist = INUM(CDR(fr)); + break; + } + } + for (env = stenv; NIMP(env); env = CDR(env)) { + fr = CAR(env); + if (INUMP(fr)) { + ASSERT(NIMP(env) && CONSP(env), stenv, s_badenv, what); + env = CDR(env); + continue; + } + if (SCM_LINUMP(fr)) continue; + if (NIMP(fr) && CONSP(fr) && IMP(CAR(fr))) continue; + if (0==iframe--) { + while (idist--) { + if (IMP(fr) || NCONSP(fr)) return BOOL_F; + fr = CDR(fr); + } + if (!icdrp) { + if (NIMP(fr) && CONSP(fr)) + fr = CAR(fr); + else + fr = BOOL_F; + } + if (NIMP(fr) && IDENTP(fr)) return fr; + return BOOL_F; + } + } + return BOOL_F; +} + +SCM scm_env_addprop(prop, val, env) + SCM prop, val, env; +{ + if (UNBNDP(prop)) return env; + return cons2(prop, val, env); +} + +SCM scm_env_getprop(prop, env) + SCM prop, env; +{ + SCM e = env; + if (!UNBNDP(prop)) { + while (NIMP(e)) { + if (INUMP(CAR(e))) { + if (CAR(e)==prop) return CDR(e); + e = CDR(e); + ASSERT(NIMP(e), env, s_badenv, "env_getprop"); + } + e = CDR(e); + } + } + return BOOL_F; +} + +static SCM prinhead(x, port, writing) + SCM x, port; + int writing; +{ + lputc('(', port); + iprin1(CAR(x), port, writing); + lputc(' ', port); + return CDR(x); +} + +static void prinbindings(names, inits, init_env, + steps, step_env, port, writing) + SCM names, inits, init_env, steps, step_env, port; + int writing; +{ + lputc('(', port); + while (NIMP(names) && NIMP(inits)) { + lputc('(', port); + iprin1(CAR(names), port, writing); + lputc(' ', port); + scm_princode(CAR(inits), init_env, port, writing); + if (NIMP(steps)) { + lputc(' ', port); + scm_princode(CAR(steps), step_env, port, writing); + steps = CDR(steps); + } + lputc(')', port); + names = CDR(names); + inits = CDR(inits); + if (NIMP(names)) lputc(' ', port); + } + lputs(") ", port); +} + +void scm_princode(code, env, port, writing) + SCM code, env, port; + int writing; +{ + SCM oenv = env, name, init, bdgs, x = code; + if (UNBNDP(env)) { + iprin1(code, port, writing); + return; + } + tail: + if (IMP(x)) { + if (ILOCP(x)) { + local: + name = scm_env_rlookup(x, env, "princode"); + if (FALSEP(name)) goto gencase; + lputs("#@", port); + iprin1(name, port, writing); + return; + } + else + goto gencase; + } + if (SCM_GLOCP(x)) { + iprin1(x, port, writing); + return; + } + switch (TYP7(x)) { + default: gencase: + iprin1(x, port, writing); + return; + gencode: + case tcs_cons_gloc: + case tcs_cons_nimcar: + case tcs_cons_iloc: + case (127 & IM_OR): case (127 & IM_AND): case (127 & IM_BEGIN): + case (127 & IM_SET): case (127 & IM_COND): case (127 & IM_CASE): + case (127 & IM_IF): + lputc('(', port); + scm_princode(CAR(x), env, port, writing); + body: + x = CDR(x); + no_cdr: + for (; NNULLP(x); x = CDR(x)) { + if (IMP(x) || NECONSP(x)) { + lputs(" . ", port); + iprin1(x, port, writing); + break; + } + lputc(' ', port); + scm_princode(CAR(x), env, port, writing); + } + lputc(')', port); + return; + case (127 & IM_LAMBDA): + x = prinhead(x, port, writing); + env = CAR(x); + bdgs = SCM_ENV_FORMALS(env); + if (IMP(bdgs) || NECONSP(bdgs)) + iprin1(bdgs, port, writing); + else { + lputc('(', port); + while (!0) { + if (NECONSP(bdgs)) break; + iprin1(CAR(bdgs), port, writing); + if (NIMP(bdgs = CDR(bdgs))) + lputc(' ', port); + else break; + } + if (NIMP(bdgs)) { + lputs(". ", port); + iprin1(bdgs, port, writing); + } + lputc(')', port); + } + goto body; + case (127 & IM_LETREC): + case (127 & IM_LET): + x = prinhead(x, port, writing); + env = CAR(x); + prinbindings(SCM_ENV_FORMALS(env), + CAR(CDR(x)), (TYP7(x)==(127 & IM_LET) ? oenv: env), + UNDEFINED, UNDEFINED, port, writing); + x = CDR(x); + goto body; + case (127 & IM_LETSTAR): + x = prinhead(x, port, writing); + lputc('(', port); + if (NIMP(bdgs = CAR(x))) { + oenv = CAR(bdgs); + bdgs = CDR(bdgs); + while (!0) { + init = CAR(bdgs); + bdgs = CDR(bdgs); + env = CAR(bdgs); + lputc('(', port); + iprin1(SCM_ENV_FORMALS(env), port, writing); + lputc(' ', port); + scm_princode(init, oenv, port, writing); + oenv = env; + lputc(')', port); + if (IMP(bdgs = CDR(bdgs))) + break; + lputc(' ', port); + } + } + lputs(") ", port); + goto body; + case (127 & IM_DO): + { + /* (#@do (env (init ...) (test ...) (body ...) step ...)) */ + SCM test, steps; + x = prinhead(x, port, writing); + env = CAR(x); + x = CDR(x); + init = CAR(x); + x = CDR(x); + test = CAR(x); + x = CDR(x); + steps = CDR(x); + x = CAR(x); + prinbindings(SCM_ENV_FORMALS(env), init, oenv, steps, env, + port, writing); + scm_princode(test, env, port, writing); + lputc(' ', port); + goto no_cdr; + } + case (127 & IM_FUNCALL): + lputc('(', port); + x = CDR(x); + scm_princode(CAR(x), env, port, writing); + goto body; + case (127 & MAKISYM(0)): + if (!ISYMP(CAR(x))) goto gencode; + switch (ISYMNUM(CAR(x))) { + default: + goto gencode; + case ISYMNUM(IM_LINUM): + x = CDR(x); + goto tail; + case ISYMNUM(IM_FARLOC_CAR): + case ISYMNUM(IM_FARLOC_CDR): + goto local; + } + } +} + +void scm_princlosure(proc, port, writing) + SCM proc, port; + int writing; +{ + SCM env, linum = UNDEFINED; + proc = CODE(proc); + lputs("#<CLOSURE ", port); + env = CAR(proc); +#ifdef CAUTIOUS + if (NIMP(env=scm_env_getprop(SCM_ENV_PROCNAME, env))) { + iprin1(CAR(env), port, 1); + lputc(' ', port); + env = CDR(env); + if (NIMP(env) && SCM_LINUMP(CAR(env))) + linum = CAR(env); + } + else + lputs("<anon> ", port); + env = CAR(proc); + if (NIMP(env=scm_env_getprop(SCM_ENV_FILENAME, env))) + scm_line_msg(CAR(env), linum, port); +#endif + env = CAR(proc); + iprin1(SCM_ENV_FORMALS(env), port, writing); + if (writing) { + for(proc = CDR(proc); NIMP(proc); proc = CDR(proc)) { + lputc(' ', port); + scm_princode(CAR(proc), env, port, writing); + } + } + lputc('>', port); +} + +static char s_int2linum[] = "integer->line-number"; +SCM scm_int2linum(n) + SCM n; +{ + int i = INUM(n); + ASSERT(INUMP(n) && i >= 0, n, ARG1, s_int2linum); + return SCM_MAKE_LINUM(i); +} + +static char s_linum2int[] = "line-number->integer"; +SCM scm_linum2int(linum) + SCM linum; +{ + ASSERT(SCM_LINUMP(linum), linum, ARG1, s_linum2int); + return MAKINUM(SCM_LINUM(linum)); +} + +SCM scm_linump(obj) + SCM obj; +{ + return SCM_LINUMP(obj) ? BOOL_T : BOOL_F; +} + +static char s_remove_linums[] = "remove-line-numbers!"; +SCM scm_remove_linums(x) + SCM x; +{ + SCM ret = x; + SCM *px = &ret; + tail: + x = *px; + if (IMP(x)) return ret; + if (CONSP(x)) { + if (SCM_LINUMP(CAR(x))) { + *px = CDR(x); + px = &CDR(x); + goto tail; + } + if (NIMP(CAR(x))) + CAR(x) = scm_remove_linums(CAR(x)); + px = &CDR(x); + goto tail; + } + else if (VECTORP(x)) { + SCM *ve = VELTS(x); + sizet i = LENGTH(x); + while (i--) { + if (NIMP(ve[i])) + ve[i] = scm_remove_linums(ve[i]); + } + return ret; + } + else + return ret; +} + +#ifdef CAUTIOUS +long num_frames(estk, i) + SCM estk; + int i; +{ + long n = 0; + while NIMP(estk) { + n += (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN; + i = INUM(SCM_ESTK_PARENT_INDEX(estk)); + estk = SCM_ESTK_PARENT(estk); + } + return n; +} + +SCM *estk_frame(estk, i, nf) + SCM estk; + int i, nf; +{ + int n; + /* Make this 1-based, because continuations have an extra frame at + the top of the estk. */ + nf -= 1; + while NIMP(estk) { + n = (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN; + if (nf <= n) return &(VELTS(estk)[i - nf*SCM_ESTK_FRLEN]); + nf -= n; + i = INUM(SCM_ESTK_PARENT_INDEX(estk)); + estk = SCM_ESTK_PARENT(estk); + } + return (SCM *)0; +} + +SCM stacktrace1(estk, i) + SCM estk; + int i; +{ + SCM *frame, env, ste, lste = UNDEFINED; + int n, nf = num_frames(estk, i); + int nbrk1 = 7, nbrk2 = nf - 6; + if (nf <= 0) return BOOL_F; + lputs("\n;STACK TRACE", cur_errp); + for (n = 1; n <= nf; n++) { + if ((0 <= nbrk1--) || n >= nbrk2) { + if (!(frame = estk_frame(estk, i, n))) continue; + if (BOOL_F==(ste = frame[3])) continue; + env = frame[2]; + if (ste != lste) { + lste = ste; + if (reset_safeport(sys_safep, 65, cur_errp)) { + /* The usual C setjmp, not SCM's setjump. */ + if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { + lputc('\n', cur_errp); + intprint((long)n, -10, sys_safep); + lputs("; ", sys_safep); + scm_princode(ste, env, sys_safep, 1); + } + } + } + else { + lputs("\n...", cur_errp); + break; + } + } + } + lputc('\n', cur_errp); + return BOOL_T; +} + +SCM *cont_frame(contin, nf) + SCM contin; + int nf; +{ + CONTINUATION *cont = CONT(contin); + SCM estk = cont->other.estk; + int i = LENGTH(estk) - SCM_ESTK_FRLEN; + if (0 == nf) return cont->other.stkframe; + return estk_frame(estk, i, nf); +} + +static char s_stack_trace[] = "stack-trace"; +SCM scm_stack_trace(contin) + SCM contin; +{ + SCM estk; + int i; + if (UNBNDP(contin)) { + estk = scm_estk; + i = (scm_estk_ptr - VELTS(scm_estk)); + } + else { + CONTINUATION *cont; + ASSERT(NIMP(contin) && (tc7_contin==TYP7(contin)), contin, ARG1, + s_stack_trace); + cont = CONT(contin); + estk = cont->other.estk; + i = LENGTH(estk) - SCM_ESTK_FRLEN; + } + return stacktrace1(estk, i); +} + +static char s_frame_trace[] = "frame-trace"; +SCM scm_frame_trace(contin, nf) + SCM contin, nf; +{ + SCM *stkframe, code, env; + ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1, + s_frame_trace); + ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_trace); + if (!(stkframe = cont_frame(contin, INUM(nf)))) + return BOOL_F; + env = stkframe[2]; + code = stkframe[3]; + scm_princode(code, env, cur_errp, 1); + scm_scope_trace(env); + return UNSPECIFIED; +} + +static char s_frame2env[] = "frame->environment"; +SCM scm_frame2env(contin, nf) + SCM contin, nf; +{ + SCM *stkframe; + ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1, + s_frame2env); + ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame2env); + if (!(stkframe = cont_frame(contin, INUM(nf)))) + return BOOL_F; + return stkframe[2]; +} + +static char s_frame_eval[] = "frame-eval"; +SCM scm_frame_eval(contin, nf, expr) + SCM contin, nf, expr; +{ + SCM res, env, *stkframe; + ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1, + s_frame_eval); + ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_eval); + if (!(stkframe = cont_frame(contin, INUM(nf)))) + return BOOL_F; + env = stkframe[2]; + if (IMP(expr)) return expr; + DEFER_INTS_EGC; + res = ceval(expr, env, stkframe[0]); + ALLOW_INTS_EGC; + return res; +} + +#endif + +static char s_scope_trace[] = "scope-trace"; +SCM scm_scope_trace(env) + SCM env; +{ + SCM ef, file = UNDEFINED; + int fprinted = 0; + if (UNBNDP(env)) + env = scm_current_env(); + else if (NIMP(env) && CLOSUREP(env)) + env = CAR(CODE(env)); + if (scm_nullenv_p(env)) + lputs("\n; in top level environment.", cur_errp); + else + lputs("\n; in scope:", cur_errp); +#ifdef CAUTIOUS + if (NIMP(ef=scm_env_getprop(SCM_ENV_FILENAME, env))) { + file = CAR(ef); + } +#endif + for (; NIMP(env); env = CDR(env)) { + if (NCONSP(env)) { + badenv: + lputs("\n; corrupted environment ", cur_errp); + iprin1(env, cur_errp, 1); + return UNSPECIFIED; + } + ef = CAR(env); + if (SCM_LINUMP(ef)) { + lputs("\n; ", cur_errp); + scm_line_msg(file, ef, cur_errp); + fprinted++; + } + else if (INUMP(ef)) { + ASRTGO(NIMP(env) && CONSP(env), badenv); + env = CDR(env); +#ifdef CAUTIOUS + switch (ef) { + default: break; + case SCM_ENV_PROCNAME: + lputs(" procedure ", cur_errp); + iprin1(CAR(env), cur_errp, 1); + break; + } +#endif + } + else if (NIMP(ef) && CONSP(ef) && NIMP(CAR(ef)) && CONSP(CAR(ef))) { + lputs("\n; ", cur_errp); + iprin1(CAR(ef), cur_errp, 1); + lputs(" syntax bindings", cur_errp); + } + else { + lputs("\n; ", cur_errp); + iprin1(ef, cur_errp, 1); + } + } +#ifdef CAUTIOUS + if (NIMP(file) && !fprinted) { + lputs("\n; defined by ", cur_errp); + if (NIMP(file) && STRINGP(file)) + lputs("load: ", cur_errp); + iprin1(file, cur_errp, 1); + lputc('\n', cur_errp); + } +#endif + return UNSPECIFIED; +} + +static char s_env_annotation[] = "environment-annotation"; +SCM scm_env_annotation(var, stenv) + SCM var, stenv; +{ + SCM s, frame, env = stenv; +#ifdef MACRO + SCM mark = IDENT_ENV(var); + if (NIMP(mark)) mark = CAR(mark); +#endif + for (; NIMP(env); env = CDR(env)) { + frame = CAR(env); +#ifdef MACRO + if (frame==mark) { + var = IDENT_PARENT(var); + mark = IDENT_ENV(var); + if (NIMP(mark)) mark = CAR(mark); + } +#endif + if (IMP(frame)) { + if (INUMP(frame)) { +#ifndef RECKLESS + if (!(NIMP(env) && CONSP(env))) { + badenv: wta(stenv, s_badenv, s_env_annotation); + } +#endif + env = CDR(env); + } + continue; + } +#ifdef MACRO + if (NIMP(frame) && CONSP(frame) && BOOL_F==CAR(frame)) { + /* syntax binding */ + s = assq(var, CDR(frame)); + if (NIMP(s)) goto local_out; + continue; + } +#endif + for (; NIMP(frame); frame = CDR(frame)) { + if (NCONSP(frame)) { + if (var==frame) + goto local_out; + break; + } + if (CAR(frame)==var) { + local_out: + env = CDR(env); + if (IMP(env)) return BOOL_T; + if (SCM_ENV_ANNOTATION != CAR(env)) return BOOL_T; + env = CDR(env); + ASRTGO(NIMP(env), badenv); + s = assq(var, CAR(env)); + if (NIMP(s)) return s; + return BOOL_T; + } + ASRTGO(CONSP(frame), badenv); + } + } + ASRTGO(NULLP(env), badenv); + return BOOL_F; +} + +/* This is to be used for code backpointers to go into environments, + allowing run-time reporting of error line numbers. */ +SCM scm_wrapcode(code, env) + SCM code, env; +{ + SCM z, x = cons(env, code); + NEWCELL(z); + CDR(z) = x; + CAR(z) = tc16_codeptr; + return z; +} + +static int princodeptr(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ + SCM env = CAR(CDR(exp)); + lputs("#<code ", port); + exp = CDR(CDR(exp)); + if (IMP(exp) || NCONSP(exp)) + scm_princode(exp, env, port, writing); + else { + while (!0) { + if (IMP(exp) || NCONSP(exp)) break; + scm_princode(CAR(exp), env, port, writing); + lputc(' ', port); + exp = CDR(exp); + } + if (NNULLP(exp)) { + lputs(" . ", port); + scm_princode(exp, env, port, writing); + } + } + lputc('>', port); + return !0; +} + +static smobfuns codesmob = {markcdr, free0, princodeptr}; + +static iproc subr1os[] = { + {s_scope_trace, scm_scope_trace}, +#ifdef CAUTIOUS + {s_stack_trace, scm_stack_trace}, +#endif + {0, 0}}; + +static iproc subr1s[] = { + {s_int2linum, scm_int2linum}, + {"line-number?", scm_linump}, + {s_linum2int, scm_linum2int}, + {s_remove_linums, scm_remove_linums}, + {0, 0}}; + +static iproc subr2s[] = { + {s_env_annotation, scm_env_annotation}, +#ifdef CAUTIOUS + {s_frame_trace, scm_frame_trace}, + {s_frame2env, scm_frame2env}, +#endif + {0, 0}}; + +void init_debug() +{ + tc16_codeptr = newsmob(&codesmob); + init_iprocs(subr1os, tc7_subr_1o); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2s, tc7_subr_2); +#ifdef CAUTIOUS + make_subr(s_frame_eval, tc7_subr_3, scm_frame_eval); +#endif +} @@ -15,26 +15,26 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -352,10 +352,15 @@ void init_dynl() # define SHL(obj) ((void*)CDR(obj)) -# ifdef SVR4 /* Solaris 2. */ -# define DLOPEN_MODE RTLD_LAZY +# ifdef RTLD_GLOBAL +# define DLOPEN_MODE (RTLD_NOW | RTLD_GLOBAL) # else -# define DLOPEN_MODE 1 /* Thats what it says in the man page. */ +# ifdef RTLD_LAZY /* This is here out of conservatism, not + because it's known to be right. */ +# define DLOPEN_MODE RTLD_LAZY +# else +# define DLOPEN_MODE 1 /* Thats what it says in the man page. */ +# endif # endif sizet frshl(ptr) @@ -393,7 +398,7 @@ SCM l_dyn_link(fname) DEFER_INTS; handle = dlopen(CHARS(fname), DLOPEN_MODE); if (NULL==handle) { - if (verbose > 2) { + if (verbose > 1) { char *dlr = dlerror(); ALLOW_INTS; if (dlr) { @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -59,8 +59,8 @@ SCM lreadline(prompt) if (NULL == s) return EOF_VAL; NEWCELL(res); DEFER_INTS; - SETCHARS(res,s); - SETLENGTH(res,(sizet)strlen(s),tc7_string); + SETCHARS(res, s); + SETLENGTH(res, strlen(s), tc7_string); ALLOW_INTS; return res; } @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999, 2002 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -15,32 +15,32 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ /* "eval.c" eval and apply. - Authors: Aubrey Jaffer & Hugh E. Secker-Walker. */ + Authors: Radey Shouman, Aubrey Jaffer, & Hugh E. Secker-Walker. */ #include "scm.h" #include "setjump.h" @@ -48,7 +48,10 @@ #define I_SYM(x) (CAR((x)-1L)) #define I_VAL(x) (CDR((x)-1L)) #define ATOMP(x) (5==(5 & (int)CAR(x))) -#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x):ceval_1(CAR(x))) +#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x, 0):ceval_1(CAR(x))) +#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x) +#define EVALCAR(x) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x)):\ + I_VAL(CAR(x))):EVALCELLCAR(x)) /* Environment frames are initially allocated in a small cache ("ecache"). This cache is subject to copying gc, cells in it may be moved to the @@ -81,63 +84,106 @@ might have been allocated in the ecache may be passed using the global variables scm_env_tmp and scm_env. - If the CDR of a cell that might be allocated in the regular heap is + If the CAR of a cell that might be allocated in the regular heap is made to point to a cell allocated in the cache, then the first cell must be recorded as a gc root, using the macro EGC_ROOT. There is - no provision for allowing the CAR of a regular cell to point to a + no provision for allowing the CDR of a regular cell to point to a cache cell. */ #ifdef NO_ENV_CACHE -# define scm_env_cons(a,b) {scm_env_tmp=cons((a),(b));} -# define scm_env_cons2(a,b,c) {scm_env_tmp=cons2((a),(b),(c));} -# define scm_env_cons_tmp(a) {scm_env_tmp=cons((a),scm_env_tmp);} -# define EXTEND_ENV(names) {scm_env=acons((names),scm_env_tmp,scm_env);} +# define scm_env_cons(a, b) {scm_env_tmp=cons((a), (b));} +# define scm_env_cons2(a, b, c) {scm_env_tmp=cons2((a), (b), (c));} +# define scm_env_cons3(a, b, c, d) {scm_env_tmp=cons2((a), (b), cons((c), (d)));} +# define EXTEND_VALENV {scm_env=cons(scm_env_tmp, scm_env);} +# define ENV_V2LST(argc, argv) \ + {scm_env_tmp=scm_v2lst((argc), (argv), scm_env_tmp);} #else -# define EXTEND_ENV scm_extend_env +# define EXTEND_VALENV {scm_extend_env();} +# define ENV_V2LST scm_env_v2lst #endif +#define EXTEND_ENV cons SCM scm_env = EOL, scm_env_tmp = UNSPECIFIED; long tc16_env; /* Type code for environments passed to macro transformers. */ + SCM nconc2copy P((SCM x)); -SCM copy_list P((SCM x, int minlen)); -SCM scm_v2lst P((long argc, SCM *argv)); -SCM rename_ident P((SCM id, SCM env)); -SCM *lookupcar P((SCM vloc, int check)); +SCM scm_cp_list P((SCM x, int minlen)); +SCM scm_v2lst P((long argc, SCM *argv, SCM end)); +SCM renamed_ident P((SCM id, SCM env)); SCM eqv P((SCM x, SCM y)); SCM scm_multi_set P((SCM syms, SCM vals)); SCM eval_args P((SCM x)); +SCM m_quote P((SCM xorig, SCM env, SCM ctxt)); +SCM m_begin P((SCM xorig, SCM env, SCM ctxt)); +SCM m_if P((SCM xorig, SCM env, SCM ctxt)); +SCM m_set P((SCM xorig, SCM env, SCM ctxt)); +SCM m_and P((SCM xorig, SCM env, SCM ctxt)); +SCM m_or P((SCM xorig, SCM env, SCM ctxt)); +SCM m_cond P((SCM xorig, SCM env, SCM ctxt)); +SCM m_case P((SCM xorig, SCM env, SCM ctxt)); +SCM m_lambda P((SCM xorig, SCM env, SCM ctxt)); +SCM m_letstar P((SCM xorig, SCM env, SCM ctxt)); +SCM m_do P((SCM xorig, SCM env, SCM ctxt)); +SCM m_quasiquote P((SCM xorig, SCM env, SCM ctxt)); +SCM m_delay P((SCM xorig, SCM env, SCM ctxt)); +SCM m_define P((SCM xorig, SCM env, SCM ctxt)); +SCM m_letrec P((SCM xorig, SCM env, SCM ctxt)); +SCM m_let P((SCM xorig, SCM env, SCM ctxt)); +SCM m_apply P((SCM xorig, SCM env, SCM ctxt)); +SCM m_syn_quote P((SCM xorig, SCM env, SCM ctxt)); +SCM m_define_syntax P((SCM xorig, SCM env, SCM ctxt)); +SCM m_let_syntax P((SCM xorig, SCM env, SCM ctxt)); +SCM m_letrec_syntax P((SCM xorig, SCM env, SCM ctxt)); +SCM m_the_macro P((SCM xorig, SCM env, SCM ctxt)); void scm_dynthrow P((SCM cont, SCM val)); void scm_egc P((void)); void scm_estk_grow P((void)); void scm_estk_shrink P((void)); -int badargsp P((SCM proc, SCM args)); +int badargsp P((SCM formals, SCM args)); +static SCM *lookupcar P((SCM vloc)); +static SCM scm_lookupval P((SCM vloc, int memo)); static SCM asubr_apply P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)); static SCM ceval_1 P((SCM x)); -static SCM evalatomcar P((SCM x)); +static SCM evalatomcar P((SCM x, int toplevelp)); static SCM evalcar P((SCM x)); static SCM id2sym P((SCM id)); static SCM iqq P((SCM form)); -static SCM m_body P((SCM op, SCM xorig, char *what)); -static SCM m_expand_body P((SCM xorig)); -static SCM m_iqq P((SCM form, int depth, SCM env)); -static SCM m_letrec1 P((SCM op, SCM imm, SCM xorig, SCM env)); -static SCM macroexp1 P((SCM x, SCM defs)); -static SCM unmemocar P((SCM x)); -static SCM wrapenv P((void)); -static SCM *id_denote P((SCM var)); +static SCM m_body P((SCM xorig, SCM env, SCM ctxt)); +static SCM m_iqq P((SCM form, int depth, SCM env, SCM ctxt)); +static SCM m_parse_let P((SCM imm, SCM xorig, SCM x, SCM *vars, SCM *inits)); +static SCM m_let_null P((SCM body, SCM env, SCM ctxt)); +static SCM m_letrec1 P((SCM imm, SCM xorig, SCM env, SCM ctxt)); +static SCM m_letstar1 P((SCM imm, SCM vars, SCM inits, SCM body, + SCM env, SCM ctxt)); +static SCM macroexp1 P((SCM x, SCM env, SCM ctxt, int mode)); +/* static int checking_defines_p P((SCM ctxt)); */ +/* static SCM wrapenv P((void)); */ +static SCM scm_case_selector P((SCM x)); +static SCM acro_call P((SCM x, SCM env)); +static SCM m_binding P((SCM name, SCM value, SCM env, SCM ctxt)); +static SCM m_bindings P((SCM name, SCM value, SCM env, SCM ctxt)); +static SCM m_seq P((SCM x, SCM env, SCM ctxt)); +static SCM m_expr P((SCM x, SCM env, SCM ctxt)); +static void checked_define P((SCM name, SCM val, char *what)); +static int topdenote_eq P((SCM sym, SCM id, SCM env)); +static int constant_p P((SCM x)); static int prinenv P((SCM exp, SCM port, int writing)); static int prinid P((SCM exp, SCM port, int writing)); static int prinmacro P((SCM exp, SCM port, int writing)); static int prinprom P((SCM exp, SCM port, int writing)); +#ifdef MAC_INLINE +static int env_depth P((void)); +static void env_tail P((int depth)); +#endif static void unpaint P((SCM *p)); static void ecache_evalx P((SCM x)); static int ecache_eval_args P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM x)); -static int varcheck P((SCM xorig, SCM vars, char *op, char *what)); +static int varcheck P((SCM vars, SCM op, char *what)); #ifdef CAREFUL_INTS -static void debug_env_warn P((char *fnam, long line, char *what)); -static void debug_env_save P((char *fnam, long line)); +static void debug_env_warn P((char *fnam, int line, char *what)); +static void debug_env_save P((char *fnam, int line)); #endif /* Flush global variable state to estk. */ @@ -150,9 +196,11 @@ static void debug_env_save P((char *fnam, long line)); /* Make global variable state consistent with estk. */ #define ENV_RESTORE {scm_env=scm_estk_ptr[0]; scm_env_tmp=scm_estk_ptr[1];} -#define ENV_PUSH {DEFER_INTS_EGC; ENV_SAVE;\ - if (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\ - else scm_estk_ptr += SCM_ESTK_FRLEN;} +#define ENV_PUSH \ + {DEFER_INTS_EGC; ENV_SAVE;\ + if (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\ + else scm_estk_ptr += SCM_ESTK_FRLEN;\ + STATIC_ENV=scm_estk_ptr[2 - SCM_ESTK_FRLEN];} #define ENV_POP {DEFER_INTS_EGC;\ if (UNDEFINED==scm_estk_ptr[-1]) scm_estk_shrink();\ @@ -163,7 +211,7 @@ static void debug_env_save P((char *fnam, long line)); #else # ifdef CAREFUL_INTS # define EGC_ROOT(x) {if (!ints_disabled) \ - debug_env_warn(__FILE__,__LINE__,"EGC_ROOT"); \ + debug_env_warn(__FILE__, __LINE__, "EGC_ROOT"); \ scm_egc_roots[--scm_egc_root_index] = (x); \ if (0==scm_egc_root_index) scm_egc();} # else @@ -172,41 +220,47 @@ static void debug_env_save P((char *fnam, long line)); # endif #endif -#ifdef CAUTIOUS -SCM scm_trace = UNDEFINED; +#ifndef RECKLESS +SCM scm_trace = BOOL_F; +SCM scm_trace_env = EOL; #endif #define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;} #define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;} #define SIDEVAL_1(x) if NIMP(x) ceval_1(x) +#define STATIC_ENV (scm_estk_ptr[2]) #ifdef CAUTIOUS -# define TRACE(x) {scm_estk_ptr[2]=(x);} -# define TOP_TRACE(x) {scm_trace=(x);} -# define PUSH_TRACE TRACE(scm_trace) +# define TRACE(x) {scm_estk_ptr[3]=(x);} +# define TOP_TRACE(x, env) {scm_trace=(x); scm_trace_env=(env);} #else # define TRACE(x) /**/ -# define TOP_TRACE(x) /**/ -# define PUSH_TRACE /**/ +# define TOP_TRACE(x, env) /**/ +#endif +#ifndef RECKLESS +# define MACROEXP_TRACE(x, env) {scm_trace=(x); scm_trace_env=(env);} +#else +# define MACROEXP_TRACE(x, env) /**/ #endif -#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x) -#define EVALCAR(x) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x)):\ - I_VAL(CAR(x))):EVALCELLCAR(x)) long tc16_macro; /* Type code for macros */ #define MACROP(x) (tc16_macro==TYP16(x)) +#define MAC_TYPE NUMDIGS +#define MAC_PRIMITIVE 0x1L +#define MAC_MEMOIZING 0x2L +#define MAC_ACRO 0x4L +#define MAC_MACRO 0x8L +#define MAC_MMACRO 0x2L +#define MAC_IDMACRO 0x6L +/* uncomment this to experiment with inline procedures + #define MAC_INLINE 0x10L */ #ifdef MACRO long tc16_ident; /* synthetic macro identifier */ -SCM i_mark; static char s_escaped[] = "escaped synthetic identifier"; -# define M_IDENTP(x) (tc16_ident==TYP16(x)) -# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x)) -# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x)) -# define IDENT_PARENT(x) (M_IDENT_LEXP(x) ? CAR(CDR(x)) : CDR(x)) -# define IDENT_MARK(x) (M_IDENT_LEXP(x) ? CDR(CDR(x)) : BOOL_F) -# define ENV_MARK BOOL_T +# define KEYWORDP(x) (NIMP(x) && IM_KEYWORD==CAR(x)) +# define KEYWORD_MACRO CDR #else -# define IDENTP SYMBOLP -# define M_IDENTP(x) (0) +# define KEYWORDP(x) (NIMP(x) && MACROP(x)) +# define KEYWORD_MACRO(x) (x) #endif /* #define SCM_PROFILE */ @@ -285,12 +339,12 @@ int ecache_p(x) } static void debug_env_warn(fnam, line, what) char *fnam; - long line; + int line; char *what; { lputs(fnam, cur_errp); lputc(':', cur_errp); - intprint(line, 10, cur_errp); + intprint(line+0L, 10, cur_errp); lputs(": unprotected ", cur_errp); lputs(what, cur_errp); lputs(" of ecache value\n", cur_errp); @@ -298,7 +352,7 @@ static void debug_env_warn(fnam, line, what) SCM *debug_env_car(x, fnam, line) SCM x; char *fnam; - long line; + int line; { SCM *ret; if (!ints_disabled && ecache_p(x)) @@ -311,7 +365,7 @@ SCM *debug_env_car(x, fnam, line) SCM *debug_env_cdr(x, fnam, line) SCM x; char *fnam; - long line; + int line; { SCM *ret; if (!ints_disabled && ecache_p(x)) @@ -323,7 +377,7 @@ SCM *debug_env_cdr(x, fnam, line) } static void debug_env_save(fnam, line) char *fnam; - long line; + int line; { if (NIMP(scm_env) && (!scm_cell_p(scm_env))) debug_env_warn(fnam, line, "ENV_SAVE (env)"); @@ -339,18 +393,22 @@ SCM *ilookup(iloc) SCM iloc; { register int ir = IFRAME(iloc); - register SCM er; + register SCM er, *eloc; #ifdef SCM_PROFILE ilookup_cases[ir<10 ? ir : 9] [IDIST(iloc)<10 ? IDIST(iloc) : 9][ICDRP(iloc)?1:0]++; #endif DEFER_INTS_EGC; er = scm_env; + /* shortcut the two most common cases. */ + if (iloc==MAKILOC(0, 0)) return &CAR(CAR(er)); + if (iloc==MAKILOC(0, 1)) return &CAR(CDR(CAR(er))); for(;0 != ir;--ir) er = CDR(er); - er = CAR(er); - for(ir = IDIST(iloc);0 != ir;--ir) er = CDR(er); - if ICDRP(iloc) return &CDR(er); - return &CAR(CDR(er)); + eloc = &CAR(er); + for (ir = IDIST(iloc); 0 != ir; --ir) + eloc = &CDR(*eloc); + if ICDRP(iloc) return eloc; + return &CAR(*eloc); } SCM *farlookup(farloc) SCM farloc; @@ -361,163 +419,214 @@ SCM *farlookup(farloc) DEFER_INTS_EGC; er = scm_env; for (ir = INUM(CAR(x)); 0 != ir; --ir) er = CDR(er); + if (0==(ir = INUM(CDR(x)))) { + if (IM_FARLOC_CDR==CAR(farloc)) return &CAR(er); + return &CAR(CAR(er)); + } er = CAR(er); - for (ir = INUM(CDR(x)); 0 != ir; --ir) er = CDR(er); + for(--ir;0 != ir;--ir) er = CDR(er); if (IM_FARLOC_CDR==CAR(farloc)) return &CDR(er); return &CAR(CDR(er)); } -static char s_badkey[] = "Use of keyword as variable", - s_unbnd[] = "unbound variable: ", s_wtap[] = "Wrong type to apply: "; -/* check is logical OR of LOOKUP_MEMOIZE, LOOKUP_UNDEFP, and LOOKUP_MACROP, - if check is zero then memoization will not be done. */ -#define LOOKUP_MEMOIZE 1 -#define LOOKUP_UNDEFP 2 -#define LOOKUP_MACROP 4 -SCM *lookupcar(vloc, check) - SCM vloc; - int check; +char s_badenv[] = "damaged environment"; +static char s_lookup[] = "scm_env_lookup", + s_badkey[] = "Use of keyword as variable", + s_unbnd[] = "unbound variable: ", + s_wtap[] = "Wrong type to apply: ", + s_placement[] = "bad placement"; + +/* + Returns: + a symbol if VAR is not found in STENV, + an ILOC if VAR is bound in STENV, + a list (IM_FARLOC iframe idist) if VAR is bound very deeply in STENV, + a pair (IM_KEYWORD . <macro>) if VAR is a syntax keyword bound in STENV. +*/ +SCM scm_env_lookup(var, stenv) + SCM var, stenv; { - SCM env; + SCM frame, env = stenv; long icdr = 0L; - register SCM *al, fl, var = CAR(vloc); - register unsigned int idist, iframe = 0; + unsigned int idist, iframe = 0; #ifdef MACRO - SCM mark = IDENT_MARK(var); + SCM mark = IDENT_ENV(var); + if (NIMP(mark)) mark = CAR(mark); #endif - DEFER_INTS_EGC; - env = scm_env; - if (NIMP(env) && ENVP(env)) - env = CDR(env); - for(; NIMP(env); env = CDR(env)) { + for (; NIMP(env); env = CDR(env)) { idist = 0; - al = &CAR(env); - fl = CAR(*al); + frame = CAR(env); #ifdef MACRO - if (fl==mark) { + if (frame==mark) { var = IDENT_PARENT(var); - mark = IDENT_MARK(var); + mark = IDENT_ENV(var); + if (NIMP(mark)) mark = CAR(mark); } #endif -/* constant environment section -- not used as yet. - if (BOOL_T==fl) { - fl = assq(var, CDR(fl)); - if FALSEP(fl) break; - var = fl; - goto gloc_out; - } -*/ - for(;NIMP(fl);fl = CDR(fl)) { - if NCONSP(fl) - if (fl==var) { - icdr = ICDR; + if (IMP(frame)) { + if (NULLP(frame)) iframe++; + else if (INUMP(frame)) { #ifndef RECKLESS - fl = CDR(*al); + if (!(NIMP(env) && CONSP(env))) { + badenv: wta(stenv, s_badenv, s_lookup); + } +#endif + env = CDR(env); + } + else { + ASRTGO(SCM_LINUMP(frame), badenv); + } + continue; + } +#ifdef MACRO + if (NIMP(frame) && CONSP(frame) && SCM_ENV_SYNTAX==CAR(frame)) { + /* syntax binding */ + SCM s = assq(var, CDR(frame)); + if (NIMP(s)) return cons(IM_KEYWORD, CDR(s)); + continue; + } #endif + for (; NIMP(frame); frame = CDR(frame)) { + if (NCONSP(frame)) { + if (var==frame) { + icdr = ICDR; goto local_out; } - else break; - al = &CDR(*al); - if (CAR(fl)==var) { -#ifndef RECKLESS /* letrec inits to UNDEFINED */ - fl = CAR(*al); - local_out: - if ((check & LOOKUP_UNDEFP) - && UNBNDP(fl)) {env = EOL; goto errout;} -# ifdef MACRO - if ((check & LOOKUP_MACROP) - && NIMP(fl) && MACROP(fl)) goto badkey; -# endif - if ((check) && NIMP(scm_env) && ENVP(scm_env)) - everr(vloc, scm_env, var, - "run-time reference", ""); -#else /* ndef RECKLESS */ + break; + } + if (CAR(frame)==var) { local_out: +#ifndef TEST_FARLOC + var = MAKILOC(iframe, idist) + icdr; + if (iframe==IFRAME(var) && idist==IDIST(var)) + return var; + else #endif -#ifdef MEMOIZE_LOCALS - if (check) { -# ifndef TEST_FARLOC - if (iframe < 4096 && idist < (1L<<(LONG_BIT-20))) - CAR(vloc) = MAKILOC(iframe, idist) + icdr; - else -# endif - CAR(vloc) = cons2(icdr ? IM_FARLOC_CDR : IM_FARLOC_CAR, - MAKINUM(iframe), MAKINUM(idist)); - } -#endif - return icdr ? &CDR(*al) : &CAR(*al); + return cons2(icdr ? IM_FARLOC_CDR : IM_FARLOC_CAR, + MAKINUM(iframe), MAKINUM(idist)); } + ASRTGO(CONSP(frame), badenv); idist++; } iframe++; } + ASRTGO(NULLP(env), badenv); #ifdef MACRO - while M_IDENTP(var) { - ASRTGO(IMP(IDENT_MARK(var)), errout); - var = IDENT_PARENT(var); + while (M_IDENTP(var)) { + if (IMP(IDENT_ENV(var))) + var = IDENT_PARENT(var); + else break; } #endif - var = sym2vcell(var); - gloc_out: -#ifndef RECKLESS - if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) { - var = CAR(var); - errout: - everr(vloc, wrapenv(), var, -# ifdef MACRO - M_IDENTP(var) ? s_escaped : -# endif - (NULLP(env) ? s_unbnd : "damaged environment"), ""); + return var; +} + +/* Throws error for macro keywords and undefined variables, always memoizes. */ +static SCM *lookupcar(vloc) + SCM vloc; +{ + SCM *pv, val, var = CAR(vloc), env = STATIC_ENV; + SCM addr = scm_env_lookup(var, env); + if (IMP(addr) || ISYMP(CAR(addr))) { /* local ref */ + DEFER_INTS_EGC; + pv = IMP(addr) ? ilookup(addr) : farlookup(addr); } -# ifdef MACRO - if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) { - var = CAR(var); - badkey: everr(vloc, wrapenv(), var, s_badkey, ""); +#ifdef MACRO +# ifndef RECKLESS + else if (NIMP(addr) && IM_KEYWORD==CAR(addr)) { /* local macro binding */ + badkey: wta(var, s_badkey, ""); } # endif #endif - if (check) CAR(vloc) = var + 1; - return &CDR(var); + else { /* global ref */ +#ifdef MACRO + ASSERT(SYMBOLP(addr), var, s_escaped, ""); +#endif + val = sym2vcell(addr); + addr = val + tc3_cons_gloc; + pv = &CDR(val); +#ifdef MACRO + ASRTGO(!KEYWORDP(*pv), badkey); +#endif + } + ASSERT(!UNBNDP(*pv) && undefineds != *pv, var, s_unbnd, ""); + CAR(vloc) = addr; + return pv; } -static SCM unmemocar(form) - SCM form; +/* Throws error for undefined variables, memoizes if memo is non-zero. + For local macros, conses new result. */ +static SCM scm_lookupval(vloc, memo) + SCM vloc; + int memo; { - SCM env; - register int ir; - DEFER_INTS_EGC; - env = scm_env; - if (NIMP(env) && ENVP(env)) env = CDR(env); - if IMP(form) return form; - if (1==TYP3(form)) - CAR(form) = I_SYM(CAR(form)); - else if ILOCP(CAR(form)) { - for(ir = IFRAME(CAR(form)); ir != 0; --ir) env = CDR(env); - env = CAR(CAR(env)); - for(ir = IDIST(CAR(form));ir != 0;--ir) env = CDR(env); - CAR(form) = ICDRP(CAR(form)) ? env : CAR(env); + SCM val, env = STATIC_ENV, var = CAR(vloc); + SCM addr = scm_env_lookup(var, env); + if (IMP(addr)) { /* local ref */ + DEFER_INTS_EGC; + val = *ilookup(addr); } - return form; +#ifdef MACRO + else if (NIMP(addr) && IM_KEYWORD==CAR(addr)) /* local macro binding */ + val = addr; +#endif + else if (ISYMP(CAR(addr))) { /* local ref (farloc) */ + DEFER_INTS_EGC; + val = *farlookup(addr); + } + else { /* global ref */ +#ifdef MACRO + ASSERT(SYMBOLP(addr), var, s_escaped, ""); +#endif + addr = sym2vcell(addr); + val = CDR(addr); + addr += tc3_cons_gloc; + } + ASSERT(!UNBNDP(val) && val != undefineds, var, s_unbnd, ""); + if (memo && !KEYWORDP(val)) /* Don't memoize forms to be macroexpanded. */ + CAR(vloc) = addr; + return val; } /* CAR(x) is known to be a cell but not a cons */ -static SCM evalatomcar(x) +static SCM evalatomcar(x, toplevelp) SCM x; + int toplevelp; { - SCM r; + SCM ret; switch TYP7(CAR(x)) { default: - everr(x, wrapenv(), CAR(x), "Cannot evaluate: ", ""); - case tcs_symbols: + everr(x, STATIC_ENV, CAR(x), "Cannot evaluate: ", "", 0); lookup: - return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP); + case tcs_symbols: + ret = scm_lookupval(x, !0); + if (KEYWORDP(ret)) { + SCM argv[3]; + SCM mac = KEYWORD_MACRO(ret); + argv[0] = CAR(x); + argv[1] = STATIC_ENV; + argv[2] = EOL; + switch (MAC_TYPE(mac) & ~MAC_PRIMITIVE) { + default: +#ifdef MACRO + if (!toplevelp) + everr(x, argv[1], argv[0], s_badkey, "", 0); +#endif + return ret; + case MAC_IDMACRO: + ret = scm_cvapply(CDR(mac), 3L, argv); + CAR(x) = ret; + return evalcar(x); + } + } + return ret; case tc7_vector: #ifndef RECKLESS - if (2 <= verbose) scm_warn("unquoted ", s_vector); + if (2 <= verbose) scm_warn("unquoted ", s_vector, CAR(x)); #endif - r = cons2(IM_QUOTE, CAR(x), EOL); - CAR(x) = r; - return CAR(CDR(r)); + ret = cons2(IM_QUOTE, CAR(x), EOL); + CAR(x) = ret; + return CAR(CDR(ret)); case tc7_smob: #ifdef MACRO if M_IDENTP(CAR(x)) goto lookup; @@ -537,7 +646,7 @@ SCM scm_multi_set(syms, vals) ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set); switch (7 & (int)(CAR(syms))) { case 0: - loc = lookupcar(syms, LOOKUP_UNDEFP|LOOKUP_MACROP); + loc = lookupcar(syms); break; case 1: loc = &(I_VAL(CAR(syms))); @@ -556,6 +665,97 @@ SCM scm_multi_set(syms, vals) return res; } +static SCM scm_case_selector(x) + SCM x; +{ + SCM key, keys, *kv, *av; + SCM actions, offset; + long i, n; + int op = ISYMVAL(CAR(x)); + x = CDR(x); + key = EVALCAR(x); + x = CDR(x); + switch (op) { + default: wta(MAKINUM(op), "internal error", s_case); + case 0: /* linear search */ + keys = CAR(x); + kv = VELTS(keys); + av = VELTS(CAR(CDR(x))); + n = LENGTH(keys); + for (i = n - 1; i > 0; i--) + if (key == kv[i]) return av[i]; +#ifndef INUMS_ONLY + /* Bignum and flonum keys are pessimized. */ + if (NIMP(key) && NUMP(key)) + for (i = n - 1; i > 0; i--) + if (NFALSEP(eqv(kv[i], key))) return av[i]; +#endif + return av[0]; + case 1: /* integer jump table */ + offset = CAR(x); + if (INUMP(key)) + i = INUM(key) - INUM(offset) + 1; + else + i = 0; + jump: + actions = CAR(CDR(x)); + if (i >= 1 && i < LENGTH(actions)) + return VELTS(actions)[i]; + else + return VELTS(actions)[0]; + case 2: /* character jump table */ + offset = CAR(x); + if (ICHRP(key)) + i = ICHR(key) - ICHR(offset) + 1; + else + i = 0; + goto jump; + } +} + +static SCM acro_call(x, env) + SCM x, env; +{ + SCM proc, argv[3]; + x = CDR(x); + proc = scm_lookupval(x, 0); + ASRTGO(KEYWORDP(proc), errout); + proc = KEYWORD_MACRO(proc); + argv[0] = x; + argv[1] = env; + argv[2] = EOL; + switch (MAC_TYPE(proc) & ~MAC_PRIMITIVE) { + default: + errout: wta(proc, CHARS(CAR(x)), "macro expected"); + case MAC_MACRO: + x = scm_cvapply(CDR(proc), 3L, argv); + if (ilength(x) <= 0) + x = cons2(IM_BEGIN, x, EOL); + return x; + case MAC_ACRO: + x = scm_cvapply(CDR(proc), 3L, argv); + return cons2(IM_QUOTE, x, EOL); + } +} + +static SCM toplevel_define(xorig, env) + SCM xorig, env; +{ + SCM x = CDR(xorig); + SCM name = CAR(x); + ASSERT(scm_nullenv_p(env), xorig, s_placement, s_define); + ENV_PUSH; + x = cons(m_binding(name, CAR(CDR(x)), env, EOL), EOL); + x = evalcar(x); + ENV_POP; + checked_define(name, x, s_define); +#ifdef SICP + return name; +#else + return UNSPECIFIED; +#endif +} + SCM eval_args(l) SCM l; { @@ -582,7 +782,7 @@ static void ecache_evalx(x) argv[i++] = EVALCAR(x); x = CDR(x); } - scm_env_v2lst(i, argv); + ENV_V2LST((long)i, argv); } /* result is 1 if right number of arguments, 0 otherwise, @@ -598,12 +798,12 @@ static int ecache_eval_args(proc, arg1, arg2, arg3, x) ecache_evalx(x); else scm_env_tmp = EOL; - scm_env_v2lst(3, argv); + ENV_V2LST(3L, argv); #ifndef RECKLESS - proc = CAR(CODE(proc)); + proc = SCM_ENV_FORMALS(CAR(CODE(proc))); + proc = CDR(proc); proc = CDR(proc); proc = CDR(proc); - proc = CDR(proc); for (; NIMP(proc); proc=CDR(proc)) { if IMP(x) return 0; x = CDR(x); @@ -634,9 +834,23 @@ static SCM asubr_apply(proc, arg1, arg2, arg3, args) arg3 = CAR(args); args = CDR(args); } + default: return UNDEFINED; } } +static char s_values[] = "values"; +static char s_call_wv[] = "call-with-values"; +SCM scm_values(arg1, arg2, rest, what) + SCM arg1, arg2, rest; + char *what; +{ + DEFER_INTS_EGC; + ASSERT(IM_VALUES_TOKEN==scm_env_tmp, UNDEFINED, "one value expected", what); + if (! UNBNDP(arg2)) + scm_env_cons(arg2, rest); + return arg1; +} + /* the following rewrite expressions and * some memoized forms have different syntax */ @@ -648,17 +862,35 @@ static char s_variable[] = "bad variable"; static char s_bad_else_clause[] = "bad ELSE clause"; static char s_clauses[] = "bad or missing clauses"; static char s_formals[] = "bad formals"; -#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)_pos, _subr); +static char s_expr[] = "bad expression"; +#define ASSYNT(_cond, _arg, _pos, _subr)\ + if(!(_cond))scm_experr(_arg, (char *)_pos, _subr); + +/* These symbols are needed by the reader, in repl.c */ +SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; +static SCM i_lambda, i_define, i_let, i_begin, i_arrow, i_else; /* , i_atbind */ +/* These symbols are passed in the context argument to macro expanders. */ +static SCM i_bind, i_anon, i_side_effect, i_test, i_procedure, + i_argument, i_check_defines; -SCM i_dot, i_quote, i_quasiquote, i_lambda, i_define, - i_let, i_arrow, i_else, i_unquote, i_uq_splicing; +static SCM f_begin, f_define; #define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what); #ifdef MACRO -# define TOPDENOTE_EQ(sym, x, env) ((sym)==id2sym(x) && TOPLEVELP(x,env)) -# define TOPLEVELP(x,env) (0==id_denote(x)) +# define TOPLEVELP(x, env) (topdenote_eq(UNDEFINED, (x), (env))) +# define TOPDENOTE_EQ topdenote_eq # define TOPRENAME(v) (renamed_ident(v, BOOL_F)) +static int topdenote_eq(sym, id, env) + SCM sym, id, env; +{ + if (UNBNDP(sym)) { + sym = scm_env_lookup(id, env); + return NIMP(sym) && SYMBOLP(sym); + } + return sym==id2sym(id) && sym==scm_env_lookup(id, env); +} + static SCM id2sym(id) SCM id; { @@ -668,36 +900,11 @@ static SCM id2sym(id) return id; } -static SCM *id_denote(var) - SCM var; -{ - register SCM *al, fl; - SCM env, mark = IDENT_MARK(var); - DEFER_INTS_EGC; - env = scm_env; - if (NIMP(env) && ENVP(env)) env = CDR(env); - for(;NIMP(env); env = CDR(env)) { - al = &CAR(env); - for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) { - if (fl==mark) { - var = IDENT_PARENT(var); - mark = IDENT_MARK(var); - } - if NCONSP(fl) - if (fl==var) return &CDR(*al); - else break; - al = &CDR(*al); - if (CAR(fl)==var) return &CAR(*al); - } - } -# ifndef RECKLESS - while M_IDENTP(var) { - ASSERT(IMP(IDENT_MARK(var)), var, s_escaped, ""); - var = IDENT_PARENT(var); - } -# endif - return (SCM *)0; -} +#else /* def MACRO */ +# define TOPDENOTE_EQ(sym, x, env) ((sym)==(x)) +# define TOPLEVELP(x, env) (!0) +# define TOPRENAME(v) (v) +#endif static void unpaint(p) SCM *p; @@ -705,7 +912,12 @@ static void unpaint(p) SCM x; while NIMP((x = *p)) { if CONSP(x) { - if NIMP(CAR(x)) unpaint(&CAR(x)); + if (NIMP(CAR(x))) + unpaint(&CAR(x)); + else if (SCM_LINUMP(CAR(x))) { + *p = CDR(x); + continue; + } p = &CDR(*p); } else if VECTORP(x) { @@ -715,93 +927,111 @@ static void unpaint(p) p = VELTS(x); } else { +#ifdef MACRO while M_IDENTP(x) *p = x = IDENT_PARENT(x); +#endif return; } } } -#else /* def MACRO */ -# define TOPDENOTE_EQ(sym, x, env) ((sym)==(x)) -# define TOPLEVELP(x,env) (!0) -# define TOPRENAME(v) (v) -#endif -static SCM m_body(op, xorig, what) - SCM op, xorig; - char *what; -{ - ASRTSYNTAX(ilength(xorig) >= 1, s_expression); - /* Don't add another ISYM if one is present already. */ - if ISYMP(CAR(xorig)) return xorig; - /* Retain possible doc string. */ - if (IMP(CAR(xorig)) || NCONSP(CAR(xorig))) { - if NNULLP(CDR(xorig)) - return cons(CAR(xorig), m_body(op, CDR(xorig), what)); - return xorig; - } - return cons2(op, CAR(xorig), CDR(xorig)); -} - -SCM m_quote(xorig, env) - SCM xorig, env; +SCM m_quote(xorig, env, ctxt) + SCM xorig, env, ctxt; { SCM x = copytree(CDR(xorig)); ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote); -#ifdef MACRO DEFER_INTS; unpaint(&CAR(x)); ALLOW_INTS; -#endif return cons(IM_QUOTE, x); } -SCM m_begin(xorig, env) - SCM xorig, env; +SCM m_begin(xorig, env, ctxt) + SCM xorig, env, ctxt; { - ASSYNT(ilength(CDR(xorig)) >= 1, xorig, s_expression, s_begin); + int len = ilength(CDR(xorig)); + if (0==len) return cons2(IM_BEGIN, UNSPECIFIED, EOL); + if (1==len) return CAR(CDR(xorig)); + ASSYNT(len >= 1, xorig, s_expression, s_begin); return cons(IM_BEGIN, CDR(xorig)); } -SCM m_if(xorig, env) - SCM xorig, env; +static int constant_p(x) + SCM x; { - int len = ilength(CDR(xorig)); + return IMP(x) ? !0 : (CONSP(x) ? 0 : !IDENTP(x)); +} + +SCM m_if(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM test, x = CDR(xorig); + int len = ilength(x); ASSYNT(len >= 2 && len <= 3, xorig, s_expression, s_if); - return cons(IM_IF, CDR(xorig)); + test = CAR(x); + x = CDR(x); + if (FALSEP(test)) + return 3==len ? CAR(CDR(x)) : UNSPECIFIED; + if (constant_p(test)) + return CAR(x); + return cons2(IM_IF, m_expr(test, env, i_test), + cons(m_expr(CAR(x), env, ctxt), + NULLP(CDR(x)) ? EOL : + cons(m_expr(CAR(CDR(x)), env, ctxt), EOL))); } -SCM m_set(xorig, env) - SCM xorig, env; +SCM m_set(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM x = CDR(xorig); + SCM var, x = CDR(xorig); ASSYNT(2==ilength(x), xorig, s_expression, s_set); - varcheck(xorig, - (NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) : + varcheck((NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) : (ilength(CAR(x)) > 0) ? CAR(x) : UNDEFINED, - s_set, s_variable); - return cons(IM_SET, x); + IM_SET, s_variable); + var = CAR(x); + x = CDR(x); + return cons(IM_SET, cons2(var, m_expr(CAR(x), env, ctxt), EOL)); } -SCM m_and(xorig, env) - SCM xorig, env; +SCM m_and(xorig, env, ctxt) + SCM xorig, env, ctxt; { - int len = ilength(CDR(xorig)); + SCM x = CDR(xorig); + int len = ilength(x); ASSYNT(len >= 0, xorig, s_test, s_and); + tail: switch (len) { - default: return cons(IM_AND, CDR(xorig)); - case 1: return CAR(CDR(xorig)); + default: + if (FALSEP(CAR(x))) return BOOL_F; + if (constant_p(CAR(x))) { + x = CDR(x); + len--; + goto tail; + } + return cons(IM_AND, x); + case 1: return CAR(x); case 0: return BOOL_T; } } -SCM m_or(xorig, env) - SCM xorig, env; +SCM m_or(xorig, env, ctxt) + SCM xorig, env, ctxt; { - int len = ilength(CDR(xorig)); + SCM x = CDR(xorig); + int len = ilength(x); ASSYNT(len >= 0, xorig, s_test, s_or); + tail: switch (len) { - default: return cons(IM_OR, CDR(xorig)); - case 1: return CAR(CDR(xorig)); + default: + if (FALSEP(CAR(x))) { + x = CDR(x); + len--; + goto tail; + } + if (constant_p(CAR(x))) + return CAR(x); + return cons(IM_OR, x); + case 1: return CAR(x); case 0: return BOOL_F; } } @@ -809,84 +1039,114 @@ SCM m_or(xorig, env) #ifdef INUMS_ONLY # define memv memq #endif -SCM m_case(xorig, env) - SCM xorig, env; +static SCM *loc_atcase_aux = 0; +static int in_atcase_aux = 0; +SCM m_case(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM clause, cdrx = copy_list(CDR(xorig), 2), x = cdrx; -#ifndef RECKLESS - SCM s, keys = EOL; -#endif - ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_case); + SCM clause, x = CDR(xorig), key_expr = CAR(x); + SCM s, keys = EOL, action, actions = EOL, else_action = list_unspecified; + int opt = !scm_nullenv_p(env); + ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case); while(NIMP(x = CDR(x))) { clause = CAR(x); - ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case); - if TOPDENOTE_EQ(i_else, CAR(clause), env) { + s = scm_check_linum(clause, 0L); + ASSYNT(ilength(clause) >= 2, clause /* xorig */, s_clauses, s_case); + clause = s; + if (TOPDENOTE_EQ(i_else, CAR(clause), env)) { ASSYNT(NULLP(CDR(x)), xorig, s_bad_else_clause, s_case); - CAR(x) = cons(IM_ELSE, CDR(clause)); + else_action = m_seq(CDR(clause), env, ctxt); } else { + s = scm_check_linum(CAR(clause), 0L); #ifdef MACRO - SCM c = copy_list(CAR(clause), 0); - ASSYNT(!UNBNDP(c), xorig, s_clauses, s_case); - clause = cons(c, CDR(clause)); + s = scm_cp_list(s, 0); + ASSYNT(!UNBNDP(s), CAR(clause) /* xorig */, s_clauses, s_case); DEFER_INTS; - unpaint(&CAR(clause)); + unpaint(&s); ALLOW_INTS; - CAR(x) = clause; #else - ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case); -#endif -#ifndef RECKLESS - for (s = CAR(clause); NIMP(s); s = CDR(s)) - ASSYNT(FALSEP(memv(CAR(s),keys)), xorig, "duplicate key value", s_case); - keys = append(cons2(CAR(clause), keys, EOL)); -#endif + ASSYNT(ilength(s) >= 0, CAR(clause) /* xorig */, s_clauses, s_case); +#endif + action = m_seq(CDR(clause), env, ctxt); + for (; NIMP(s); s = CDR(s)) { + ASSYNT(FALSEP(memv(CAR(s), keys)), xorig, "duplicate key value", s_case); + if (NIMP(CAR(s)) && NUMP(CAR(s))) opt = 0; + keys = cons(CAR(s), keys); + actions = cons(action, actions); + } + } + } + key_expr = m_expr(key_expr, env, i_test); + if (opt && NIMP(*loc_atcase_aux) && !in_atcase_aux) { + SCM argv[3]; + argv[0] = keys; + argv[1] = actions; + argv[2] = else_action; + in_atcase_aux = !0; + x = scm_cvapply(*loc_atcase_aux, 3L, argv); + in_atcase_aux = 0; /* disabled after one error. C'est la vie. */ + if (NIMP(x) && CONSP(x)) { + s = CAR(x); + if (INUMP(s) && INUM(s) >= 0 && INUM(s) <= 2) + return cons2(MAKISYMVAL(IM_CASE, INUM(s)), key_expr, CDR(x)); } } - return cons(IM_CASE, cdrx); + keys = cons(UNSPECIFIED, keys); + actions = cons(else_action, actions); + return cons2(IM_CASE, key_expr, + cons2(vector(keys), vector(actions), EOL)); } -SCM m_cond(xorig, env) - SCM xorig, env; +SCM m_cond(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM arg1, cdrx = copy_list(CDR(xorig), 1), x = cdrx; + SCM s, clause, cdrx = scm_cp_list(CDR(xorig), 1), x = cdrx; int len = ilength(x); ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_cond); while(NIMP(x)) { - arg1 = CAR(x); - len = ilength(arg1); - ASSYNT(len >= 1, xorig, s_clauses, s_cond); - if TOPDENOTE_EQ(i_else, CAR(arg1), env) { + clause = scm_check_linum(CAR(x), 0L); + len = ilength(clause); + ASSYNT(len >= 1, CAR(x), s_clauses, s_cond); + if (TOPDENOTE_EQ(i_else, CAR(clause), env)) { ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, s_bad_else_clause, s_cond); - CAR(x) = cons(BOOL_T, CDR(arg1)); + clause = cons(BOOL_T, m_seq(CDR(clause), env, ctxt)); } else { - arg1 = CDR(arg1); - if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(arg1), env)) { - ASSYNT(3==len && NIMP(CAR(CDR(arg1))), xorig, "bad recipient", s_cond); - CAR(x) = cons2(CAR(CAR(x)), IM_ARROW, CDR(arg1)); + s = CDR(clause); + if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(s), env)) { + ASSYNT(3==len && NIMP(CAR(CDR(s))), clause, "bad recipient", s_cond); + clause = cons2(CAR(clause), IM_ARROW, CDR(s)); } + else + clause = cons(CAR(clause), m_seq(s, env, ctxt)); } + CAR(x) = clause; x = CDR(x); } return cons(IM_COND, cdrx); } -static int varcheck(xorig, vars, op, what) - SCM xorig, vars; - char *op, *what; +static int varcheck(vars, op, what) + SCM vars, op; + char *what; { SCM v1, vs; + char *opstr = ISYMCHARS(op) + 2; int argc = 0; + vars = scm_check_linum(vars, 0L); for (; NIMP(vars) && CONSP(vars); vars = CDR(vars)) { argc++; #ifndef RECKLESS v1 = CAR(vars); if (IMP(v1) || !IDENTP(v1)) - badvar: wta(xorig, what, op); + badvar: scm_experr(v1, what, opstr); for (vs = CDR(vars); NIMP(vs) && CONSP(vs); vs = CDR(vs)) { - if (v1==CAR(vs)) - nonuniq: wta(xorig, "non-unique bindings", op); + if (v1==CAR(vs)) { + nonuniq: + what = "non-unique bindings"; + goto badvar; + } } if (v1==vs) goto nonuniq; #endif @@ -896,35 +1156,122 @@ static int varcheck(xorig, vars, op, what) ASRTGO(NIMP(vars) && IDENTP(vars), badvar); return argc > 2 ? 2 : argc; } -SCM m_lambda(xorig, env) - SCM xorig, env; + +SCM m_lambda(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM x = CDR(xorig); + SCM x = CDR(xorig), formals; +#ifdef CAUTIOUS + SCM name, linum; +#endif int argc; - ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda); - argc = varcheck(xorig, CAR(x), s_lambda, s_formals); + ASSERT(ilength(x) > 1, x, s_body, s_lambda); + formals = CAR(x); + argc = varcheck(formals, IM_LAMBDA, s_formals); + formals = scm_check_linum(formals, 0L); if (argc > 3) argc = 3; - return cons2(MAKISYMVAL(IM_LAMBDA, argc), CAR(x), - m_body(IM_LAMBDA, CDR(x), s_lambda)); + x = CDR(x); + if (NIMP(CDR(x)) && NIMP(CAR(x)) && STRINGP(CAR(x))) { + env = scm_env_addprop(SCM_ENV_DOC, CAR(x), env); + x = CDR(x); + } +#ifdef CAUTIOUS + if (NIMP(ctxt) && i_bind==CAR(ctxt)) { + ctxt = CDR(ctxt); + name = CAR(ctxt); + } + else + name = i_anon; + if (NIMP(scm_trace) && xorig==scm_check_linum(scm_trace, &linum)) + if (!UNBNDP(linum)) env = EXTEND_ENV(linum, env); + env = scm_env_addprop(SCM_ENV_PROCNAME, name, env); +#endif + env = EXTEND_ENV(formals, env); + return cons2(MAKISYMVAL(IM_LAMBDA, argc), env, m_body(x, env, EOL)); +} + +#ifdef MAC_INLINE +static int env_depth() +{ + register int depth = 0; + register SCM env; + DEFER_INTS_EGC; + env = scm_env; + while(NIMP(env)) { + env = CDR(env); + depth++; + } + return depth; } -SCM m_letstar(xorig, env) +static void env_tail(depth) + int depth; +{ + register SCM env; + DEFER_INTS_EGC; + env = scm_env; + while(depth--) env = CDR(env); + scm_env = env; +} +/* FIXME update for split-env */ +SCM m_inline_lambda(xorig, env) SCM xorig, env; { - SCM x = CDR(xorig), arg1, proc, vars = EOL, *varloc = &vars; - int len = ilength(x); - ASSYNT(len >= 2, xorig, s_body, s_letstar); - proc = CAR(x); - ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_letstar); - while NIMP(proc) { - arg1 = CAR(proc); - ASSYNT(2==ilength(arg1), xorig, s_bindings, s_letstar); - ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_letstar); - *varloc = cons2(CAR(arg1), CAR(CDR(arg1)), EOL); - varloc = &CDR(CDR(*varloc)); - proc = CDR(proc); + SCM x = CDR(xorig); + SCM typ = (SCM)(tc16_macro | (MAC_INLINE << 16)); + int depth = env_depth(); + ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda); + ASSERT(ilength(CAR(x)) >= 0, xorig, s_formals, s_lambda); + varcheck(CAR(x), IM_LAMBDA, s_formals); + x = cons2(typ, MAKINUM((long)depth), + cons(CAR(x), m_body(CDR(x), env))); + return cons2(IM_QUOTE, x, EOL); +} +#endif + +static char s_nullenv_p[] = "scm_nullenv_p"; +int scm_nullenv_p(env) + SCM env; +{ + SCM fr, e; + if (IMP(env)) return !0; + for (e = env; NIMP(e); e = CDR(e)) { + ASSERT(CONSP(e), e, s_badenv, s_nullenv_p); + fr = CAR(e); + if (IMP(fr)) { + if (NULLP(fr)) return 0; + if (INUMP(fr)) { /* These frames are for meta-data, not bindings. */ + e = CDR(e); + ASSERT(NIMP(e), env, s_badenv, s_nullenv_p); + } + } else return 0; } - x = cons(vars, CDR(x)); - return cons2(IM_LETSTAR, CAR(x), m_body(IM_LETSTAR, CDR(x), s_letstar)); + return !0; +} +static SCM m_letstar1(imm, vars, inits, body, env, ctxt) + SCM imm, vars, inits, body, env, ctxt; +{ + SCM init, bdgs = cons(env, EOL); /* initial env is for debug printing. */ + SCM *loc = &CDR(bdgs); + while (NIMP(vars)) { + init = m_binding(CAR(vars), CAR(inits), env, ctxt); + env = EXTEND_ENV(CAR(vars), env); + *loc = cons2(init, env, EOL); + loc = &CDR(CDR(*loc)); + vars = CDR(vars); + inits = CDR(inits); + } + return cons2(IM_LETSTAR, bdgs, m_body(body, env, ctxt)); +} + +SCM m_letstar(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM vars, inits; + SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits); + /* IM_LETSTAR must bind at least one variable. */ + if (IMP(vars)) + return m_let_null(body, env, ctxt); + return m_letstar1(IM_LETSTAR, vars, inits, body, env, ctxt); } /* DO gets the most radically altered syntax @@ -940,33 +1287,40 @@ SCM m_letstar(xorig, env) (<body>) <stepn> ... <step2> <step1>) ;; missing steps replaced by var */ -SCM m_do(xorig, env) - SCM xorig, env; +SCM m_do(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM x = CDR(xorig), arg1, proc; + SCM x = CDR(xorig), bdg, bdgs, test, body; SCM vars = IM_DO, inits = EOL, steps = EOL; int len = ilength(x); ASSYNT(len >= 2, xorig, s_test, s_do); - proc = CAR(x); - ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_do); - while NIMP(proc) { - arg1 = CAR(proc); - len = ilength(arg1); - ASSYNT(2==len || 3==len, xorig, s_bindings, s_do); - /* vars reversed here, inits and steps reversed at evaluation */ - vars = cons(CAR(arg1), vars); /* variable */ - arg1 = CDR(arg1); - inits = cons(CAR(arg1), inits); - arg1 = CDR(arg1); - steps = cons(IMP(arg1)?CAR(vars):CAR(arg1), steps); - proc = CDR(proc); + bdgs = scm_check_linum(CAR(x), 0L); + ASSYNT(ilength(bdgs) >= 0, CAR(x), s_bindings, s_do); + while NIMP(bdgs) { + bdg = scm_check_linum(CAR(bdgs), 0L); + len = ilength(bdg); + ASSYNT(2==len || 3==len, CAR(bdgs), s_bindings, s_do); + vars = cons(CAR(bdg), vars); /* variable */ + bdg = CDR(bdg); + inits = cons(CAR(bdg), inits); + bdg = CDR(bdg); + steps = cons(IMP(bdg) ? CAR(vars) : CAR(bdg), steps); + bdgs = CDR(bdgs); } + if (IMP(vars)) vars = EOL; + inits = m_bindings(vars, inits, env, ctxt); + env = EXTEND_ENV(vars, env); + steps = m_bindings(vars, steps, env, ctxt); x = CDR(x); - ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do); + test = scm_check_linum(CAR(x), 0L); + ASSYNT(ilength(test) >= 1, CAR(x), s_test, s_do); + test = m_seq(test, env, ctxt); + if (IMP(CDR(test))) test = cons(CAR(test), list_unspecified); ASSYNT(ilength(CDR(x))>=0, xorig, s_expression, s_do); - varcheck(xorig, vars, s_do, s_variable); - x = cons2(CAR(x), CDR(x), steps); - x = cons2(vars, inits, x); + varcheck(vars, IM_DO, s_variable); + body = scm_check_linum(CDR(x), 0L); + x = cons2(test, m_seq(body, env, i_side_effect), steps); + x = cons2(env, inits, x); return cons(IM_DO, x); } @@ -1000,8 +1354,8 @@ static SCM iqq(form) return cons(iqq(CAR(form)), iqq(CDR(form))); } -static SCM m_iqq(form, depth, env) - SCM form, env; +static SCM m_iqq(form, depth, env, ctxt) + SCM form, env, ctxt; int depth; { SCM tmp; @@ -1012,7 +1366,7 @@ static SCM m_iqq(form, depth, env) SCM *data = VELTS(form); tmp = EOL; for(;--i >= 0;) tmp = cons(data[i], tmp); - tmp = m_iqq(tmp, depth, env); + tmp = m_iqq(tmp, depth, env, ctxt); for(i = 0; i < LENGTH(form); i++) { data[i] = CAR(tmp); tmp = CDR(tmp); @@ -1025,7 +1379,8 @@ static SCM m_iqq(form, depth, env) #endif return form; } - tmp = CAR(form); + form = scm_check_linum(form, 0L); /* needed? */ + tmp = scm_check_linum(CAR(form), 0L); if NIMP(tmp) { if IDENTP(tmp) { #ifdef MACRO @@ -1033,49 +1388,46 @@ static SCM m_iqq(form, depth, env) #endif if (i_quasiquote==tmp && TOPLEVELP(CAR(form), env)) { depth++; - if (0==depth) CAR(form) = IM_QUASIQUOTE; + if (0==depth) tmp = IM_QUASIQUOTE; goto label; } - if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) { + else if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) { --depth; - if (0==depth) CAR(form) = IM_UNQUOTE; + if (0==depth) tmp = IM_UNQUOTE; label: - tmp = CDR(form); - ASSERT(NIMP(tmp) && ECONSP(tmp) && NULLP(CDR(tmp)), - tmp, ARG1, s_quasiquote); - if (0!=depth) CAR(tmp) = m_iqq(CAR(tmp), depth, env); - return form; + form = CDR(form); + ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)), + form, ARG1, s_quasiquote); + if (0!=depth) + form = cons(m_iqq(CAR(form), depth, env, ctxt), EOL); + return cons(tmp, form); } } else { - if TOPDENOTE_EQ(i_uq_splicing, CAR(tmp), env) { - if (0==--edepth) { - CAR(tmp) = IM_UQ_SPLICING; - CDR(form) = m_iqq(CDR(form), depth, env); - return form; - } + if (TOPDENOTE_EQ(i_uq_splicing, CAR(tmp), env)) { + if (0==--edepth) + return cons(cons(IM_UQ_SPLICING, CDR(tmp)), + m_iqq(CDR(form), depth, env, ctxt)); } - CAR(form) = m_iqq(tmp, edepth, env); + tmp = m_iqq(tmp, edepth, env, ctxt); } } - CAR(form) = tmp; - CDR(form) = m_iqq(CDR(form), depth, env); - return form; + return cons(tmp, m_iqq(CDR(form), depth, env, ctxt)); } -SCM m_quasiquote(xorig, env) - SCM xorig, env; +SCM m_quasiquote(xorig, env, ctxt) + SCM xorig, env, ctxt; { SCM x = CDR(xorig); ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote); - x = m_iqq(copytree(x), 1, env); + x = m_iqq(x, 1, env, ctxt); return cons(IM_QUASIQUOTE, x); } -SCM m_delay(xorig, env) - SCM xorig, env; +SCM m_delay(xorig, env, ctxt) + SCM xorig, env, ctxt; { ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay); - return cons2(IM_DELAY, EOL, CDR(xorig)); + return cons2(IM_DELAY, EXTEND_ENV(EOL, env), CDR(xorig)); } static int built_inp(name, x) @@ -1092,229 +1444,450 @@ static int built_inp(name, x) return 0; } -SCM m_define(x, env) - SCM x, env; +static void checked_define(name, val, what) + SCM name, val; + char *what; { - SCM proc, arg1 = x; x = CDR(x); - /* ASSYNT(NULLP(env), x, "bad placement", s_define);*/ - ASSYNT(ilength(x) >= 2, arg1, s_expression, s_define); - proc = CAR(x); x = CDR(x); - while (NIMP(proc) && CONSP(proc)) { /* nested define syntax */ - x = cons(cons2(TOPRENAME(i_lambda), CDR(proc), x), EOL); - proc = CAR(proc); - } - ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define); - ASSYNT(1==ilength(x), arg1, s_expression, s_define); - if (NIMP(env) && ENVP(env)) { - DEFER_INTS_EGC; - env = CDR(env); - } - if NULLP(env) { - x = evalcar(x); + SCM old, vcell; #ifdef MACRO - while M_IDENTP(proc) { - ASSYNT(IMP(IDENT_MARK(proc)), proc, s_escaped, s_define); - proc = IDENT_PARENT(proc); - } + while (M_IDENTP(name)) { + ASSERT(IMP(IDENT_ENV(name)), name, s_escaped, what); + name = IDENT_PARENT(name); + } #endif - arg1 = sym2vcell(proc); + vcell = sym2vcell(name); + old = CDR(vcell); #ifndef RECKLESS - if (2 <= verbose && - built_inp(proc, CDR(arg1)) - && (CDR(arg1) != x)) - scm_warn("redefining built-in ", CHARS(proc)); - else -#endif - if (5 <= verbose && UNDEFINED != CDR(arg1)) - scm_warn("redefining ", CHARS(proc)); - CDR(arg1) = x; -#ifdef SICP - return m_quote(cons2(i_quote, CAR(arg1), EOL), EOL); -#else - return UNSPECIFIED; -#endif + if ('@'==CHARS(name)[0] && UNDEFINED != old) + scm_warn("redefining internal name ", "", name); + if (KEYWORDP(old)) { + if (1 <= verbose && built_inp(name, KEYWORD_MACRO(old))) + scm_warn("redefining built-in syntax ", "", name); + else if (3 <= verbose) + scm_warn("redefining syntax ", "", name); + } + else if (2 <= verbose && built_inp(name, old) && (old != val)) + scm_warn("redefining built-in ", "", name); + else if (5 <= verbose && UNDEFINED != old) + scm_warn("redefining ", "", name); +#endif + CDR(vcell) = val; +} + +SCM m_define(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM name, linum, x = CDR(xorig); + ASSYNT(ilength(x) >= 2, xorig, s_expression, s_define); + name = CAR(x); x = CDR(x); + while (NIMP(name) && CONSP(name)) { /* nested define syntax */ + name = scm_check_linum(name, &linum); + x = scm_add_linum(linum, cons2(TOPRENAME(i_lambda), CDR(name), x)); + x = cons(x, EOL); + name = CAR(name); } - return cons2(IM_DEFINE, proc, x); + ASSYNT(NIMP(name) && IDENTP(name), xorig, s_variable, s_define); + ASSYNT(1==ilength(x), xorig, s_expression, s_define); + return cons2(IM_DEFINE, name, x); } /* end of acros */ -static SCM m_letrec1(op, imm, xorig, env) - SCM op, imm, xorig, env; +/* returns body, x should be cdr of a LET, LET*, or LETREC form. + vars and inits are returned in the original order. */ +static SCM m_parse_let(imm, xorig, x, vars, inits) + SCM imm, xorig, x, *vars, *inits; { - SCM cdrx = CDR(xorig); /* locally mutable version of form */ + SCM clause, bdgs, *varloc = vars, *initloc = inits; + int len = ilength(x); +#ifdef MACRO + char *what = CHARS(ident2sym(CAR(xorig))); +#else char *what = CHARS(CAR(xorig)); - SCM x = cdrx, proc, arg1; /* structure traversers */ - SCM vars = imm, inits = EOL; - /* ASRTSYNTAX(ilength(x) >= 2, s_body); */ - proc = CAR(x); - ASRTSYNTAX(ilength(proc) >= 1, s_bindings); - do { - arg1 = CAR(proc); - ASRTSYNTAX(2==ilength(arg1), s_bindings); - vars = cons(CAR(arg1), vars); - inits = cons(CAR(CDR(arg1)), inits); - } while NIMP(proc = CDR(proc)); - varcheck(xorig, vars, what, s_variable); - return cons2(op, vars, cons(inits, m_body(imm, CDR(x), what))); +#endif + *varloc = imm; + *initloc = EOL; + ASSYNT(len >= 2, UNDEFINED, s_body, what); + bdgs = scm_check_linum(CAR(x), 0L); + ASSYNT(ilength(bdgs) >= 0, bdgs, s_bindings, what); + while NIMP(bdgs) { + clause = scm_check_linum(CAR(bdgs), 0L); + ASSYNT(2==ilength(clause), clause, s_bindings, what); + ASSYNT(NIMP(CAR(clause)) && IDENTP(CAR(clause)), CAR(clause), + s_variable, what); + *varloc = cons(CAR(clause), imm); + varloc = &CDR(*varloc); + *initloc = cons(CAR(CDR(clause)), EOL); + initloc = &CDR(*initloc); + bdgs = CDR(bdgs); + } + x = CDR(x); + ASSYNT(ilength(x)>0, scm_wrapcode(x, EOL) /* xorig */, s_body, what); + if (IMP(*vars)) *vars = EOL; + return x; } -SCM m_letrec(xorig, env) - SCM xorig, env; +static SCM m_let_null(body, env, ctxt) + SCM body, env, ctxt; { - SCM x = CDR(xorig); - ASSYNT(ilength(x) >= 2, xorig, s_body, s_letrec); - if NULLP(CAR(x)) /* null binding, let* faster */ - return m_letstar(cons2(CAR(xorig), EOL, - m_body(IM_LETREC, CDR(x), s_letrec)), - env); - return m_letrec1(IM_LETREC, IM_LETREC, xorig, env); + SCM x; + if (scm_nullenv_p(env)) { + env = EXTEND_ENV(EOL, env); + return cons2(IM_LET, env, cons(EOL, m_body(body, env, ctxt))); + } + x = m_body(body, env, ctxt); + return NULLP(CDR(x)) ? CAR(x) : cons(IM_BEGIN, x); } -SCM m_let(xorig, env) - SCM xorig, env; +static SCM m_letrec1(imm, xorig, env, ctxt) + SCM imm, xorig, env, ctxt; +{ + SCM vars, inits, op = MAKSPCSYM2(IM_LETREC, imm); + SCM body = m_parse_let(imm, xorig, CDR(xorig), &vars, &inits); + if (IMP(vars)) return m_let_null(body, env, ctxt); + varcheck(vars, imm, s_variable); + env = EXTEND_ENV(vars, env); + inits = m_bindings(vars, inits, env, ctxt); + return cons2(op, env, cons(inits, m_body(body, env, ctxt))); +} + +SCM m_letrec(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM cdrx = CDR(xorig); /* locally mutable version of form */ - SCM x = cdrx, proc, arg1, name; /* structure traversers */ - SCM vars = IM_LET, inits = EOL, *varloc = &vars, *initloc = &inits; + return m_letrec1(IM_LETREC, xorig, env, ctxt); +} +SCM m_let(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM proc, body, vars, inits, x = CDR(xorig); ASSYNT(ilength(x) >= 2, xorig, s_body, s_let); proc = CAR(x); - if (NULLP(proc) /* null or single binding, let* is faster */ - || (NIMP(proc) && CONSP(proc) - && NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc)))) - return m_letstar(cons2(CAR(xorig), proc, m_body(IM_LET, CDR(x), s_let)), - env); - ASSYNT(NIMP(proc), xorig, s_bindings, s_let); - if CONSP(proc) /* plain let, proc is <bindings> */ - return m_letrec1(IM_LET, IM_LET, xorig, env); - if (!IDENTP(proc)) wta(xorig, s_bindings, s_let); /* bad let */ - name = proc; /* named let, build equiv letrec */ - x = CDR(x); - ASSYNT(ilength(x) >= 2, xorig, s_body, s_let); - proc = CAR(x); /* bindings list */ - ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_let); - while NIMP(proc) { /* vars and inits both in order */ - arg1 = CAR(proc); - ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let); - ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_let); - *varloc = cons(CAR(arg1), IM_LET); - varloc = &CDR(*varloc); - *initloc = cons(CAR(CDR(arg1)), EOL); - initloc = &CDR(*initloc); - proc = CDR(proc); + if (NIMP(proc) && IDENTP(proc)) { /* named let, build equiv letrec */ + x = CDR(x); + body = m_parse_let(IM_LET, xorig, x, &vars, &inits); + x = cons2(TOPRENAME(i_lambda), vars, body); + x = cons2(i_let, cons(cons2(proc, x, EOL), EOL), cons(proc, EOL)); + return cons(m_letrec1(IM_LET, x, env, ctxt), inits); } - proc = cons2(TOPRENAME(i_lambda), vars, m_body(IM_LET, CDR(x), s_let)); - proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL), cons(name, EOL)); - return cons(m_letrec1(IM_LETREC, IM_LET, proc, env), inits); + /* vanilla let */ + body = m_parse_let(IM_LET, xorig, x, &vars, &inits); + varcheck(vars, IM_LET, s_variable); + if (IMP(vars)) + return m_let_null(body, env, ctxt); + if (IMP(CDR(vars))) /* single binding, let* is faster */ + return m_letstar1(IM_LET, vars, inits, body, env, ctxt); + inits = m_bindings(vars, inits, env, ctxt); + env = EXTEND_ENV(vars, env); + return cons2(IM_LET, env, cons(inits, m_body(body, env, ctxt))); } #define s_atapply (ISYMCHARS(IM_APPLY)+1) -SCM m_apply(xorig, env) - SCM xorig, env; +SCM m_apply(xorig, env, ctxt) + SCM xorig, env, ctxt; { ASSYNT(ilength(CDR(xorig))==2, xorig, s_expression, s_atapply); return cons(IM_APPLY, CDR(xorig)); } -static SCM m_expand_body(xorig) - SCM xorig; +static SCM m_body(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM form, x = CDR(xorig), defs = EOL; + SCM form, denv = env, x = xorig, defs = EOL; char *what = ISYMCHARS(CAR(xorig)) + 2; + ASRTSYNTAX(ilength(xorig) >= 1, s_expression); while NIMP(x) { - form = CAR(x); + form = scm_check_linum(CAR(x), 0L); if (IMP(form) || NCONSP(form)) break; if IMP(CAR(form)) break; if (! IDENTP(CAR(form))) break; - form = macroexp1(form, defs); + form = macroexp1(CAR(x), denv, i_check_defines, 1); if (IM_DEFINE==CAR(form)) { defs = cons(CDR(form), defs); x = CDR(x); } + else if (IM_BEGIN==CAR(form)) { + form = CDR(form); + x = CDR(x); + if (IMP(x)) + x = form; + else if (UNSPECIFIED==CAR(form) && IMP(CDR(form))) + ; + else + x = append(cons2(form, x, EOL)); + } else if NIMP(defs) { break; } - else if (IM_BEGIN==CAR(form)) { - x = append(cons2(CDR(form), CDR(x), EOL)); - } else { + /* Doesn't work when m_body recursively called + x = cons(form, m_seq(CDR(x), env, ctxt)); */ x = cons(form, CDR(x)); break; } } - ASSYNT(NIMP(x), CDR(xorig), s_body, what); - if NIMP(defs) - x = cons(m_letrec1(IM_LETREC, IM_DEFINE, cons2(i_define, defs, x), - wrapenv()) - , EOL); - DEFER_INTS; - CAR(xorig) = CAR(x); - CDR(xorig) = CDR(x); - ALLOW_INTS; - return xorig; +#ifdef CAUTIOUS + ASSYNT(ilength(x) > 0, x, s_body, what); +#else + ASSYNT(ilength(x) > 0, CDR(xorig), s_body, what); +#endif + if (IMP(defs)) return x; + return cons(m_letrec1(IM_DEFINE, cons2(i_define, defs, x), env, ctxt), EOL); } -static SCM macroexp1(x, defs) - SCM x, defs; +static SCM m_binding(name, value, env, ctxt) + SCM name, value, env, ctxt; { - SCM res = UNDEFINED, proc = CAR(x); - int argc; - ASRTGO(IDENTP(proc), badfun); + if (IMP(value) || NCONSP(value)) return value; + ctxt = cons2(i_bind, name, EOL); + return macroexp1(value, env, ctxt, 2); +} +static SCM m_bindings(names, values, env, ctxt) + SCM names, values, env, ctxt; +{ + SCM x; + for (x = values; NIMP(x); x = CDR(x)) { + CAR(x) = m_binding(CAR(names), CAR(x), env, ctxt); + names = CDR(names); + } + return values; +} +static SCM m_seq(x, env, ctxt) + SCM x, env, ctxt; +{ + SCM form, ret = EOL, *loc = &ret; + for (; NIMP(x); x = CDR(x)) { + form = CAR(x); + if (NIMP(form) && CONSP(form)) { + form = macroexp1(form, env, IMP(CDR(x)) ? ctxt : i_side_effect, 2); + if (NIMP(form) && IM_BEGIN==CAR(form)) { + x = append(cons2(form, CDR(x), EOL)); + continue; + } + } + *loc = cons(form, EOL); + loc = &CDR(*loc); + } + return ret; +} +static SCM m_expr(x, env, ctxt) + SCM x, env, ctxt; +{ + if (NIMP(x) && CONSP(x)) { + x = macroexp1(x, env, ctxt, 2); + if (NIMP(x) && IM_BEGIN==CAR(x)) + x = cons(IM_BEGIN, m_seq(CDR(x), env, ctxt)); + } + return x; +} + +SCM scm_check_linum(x, linum) + SCM x, *linum; +{ + SCM lin = UNDEFINED; + if (NIMP(x) && CONSP(x) && SCM_LINUMP(CAR(x))) { + lin = CAR(x); + x = CDR(x); + } + if (linum) *linum = lin; + return x; +} +SCM scm_add_linum(linum, x) + SCM x, linum; +{ + if (UNBNDP(linum)) return x; + if (NIMP(x) && CONSP(x) && SCM_LINUMP(CAR(x))) return x; + return cons(linum, x); +} + +/* + mode values: + 0 expand non-primitive macros only + 1 check for defines, expand non-primitive macros and DEFINE and BEGIN + 2 expand all macros + 3 executing: all macros must be expanded, all values must be defined and + will be memoized, the form may be destructively altered. + +*/ +static SCM macroexp1(xorig, env, ctxt, mode) + SCM xorig, env, ctxt; + int mode; +{ + SCM x = xorig, linum, proc = UNDEFINED, res = UNDEFINED; +#ifndef RECKLESS + SCM trace = scm_trace, trace_env = scm_trace_env; + long argc; + char *what = s_wtap; + MACROEXP_TRACE(xorig, env); +#endif + x = scm_check_linum(xorig, &linum); + if (IMP(x) || NCONSP(x)) { /* Happens for unquoted vectors. */ + if (NIMP(x)) + x = evalatomcar(cons(x, EOL), 0); + x = cons2(IM_QUOTE, x, EOL); + goto retx; + } + else if (IDENTP(x)) { /* Happens for @macroexpand1 */ + proc = x; + x = cons(proc, EOL); + } + else + proc = CAR(x); + ASRTGO(NIMP(proc), errout); + if (CONSP(proc)) { + if (mode < 3) { + x = xorig; + goto retx; + } + if (NIMP(CAR(proc))) + proc = macroexp1(cons(CAR(proc), CDR(proc)), env, i_procedure, mode); + if ((127L & IM_LAMBDA)==(127L & CAR(proc))) { + SCM nenv = CAR(CDR(proc)); + SCM formals = SCM_ENV_FORMALS(nenv); +#ifndef RECKLESS + if (badargsp(formals, CDR(x))) { + what = (char *)WNA; + proc = CAR(x); + goto errout; + } +#endif + res = CDR(x); + if (ilength(formals) >= 0) { + x = cons2(IM_LET, nenv, cons(res, CDR(CDR(proc)))); + goto retx; + } + } + x = cons2(IM_FUNCALL, proc, CDR(x)); + goto retx; + } + ASRTGO(IDENTP(proc), errout); macro_tail: - res = CAR(x); - proc = *lookupcar(x, IMP(defs) ? LOOKUP_UNDEFP : 0); - if (NIMP(proc) && MACROP(proc)) { - CAR(x) = res; - res = cons2(x, wrapenv(), EOL); - switch ((int)(CAR(proc)>>16) & 0x7f) { - case 2: case 6: /* mmacro */ - if (IMP(defs)) { - res = apply(CDR(proc), res, EOL); - if (ilength(res) <= 0) - res = cons2(IM_BEGIN, res, EOL); - DEFER_INTS; - CAR(x) = CAR(res); - CDR(x) = CDR(res); - ALLOW_INTS; - break; + res = proc; /* For nicer error message. */ + if (mode >= 3) { + x = cons(CAR(x), CDR(x)); + proc = scm_lookupval(x, !0); + } + else { + proc = scm_env_lookup(proc, env); + if (IMP(proc)) { /* local binding */ + x = scm_add_linum(linum, x); + goto retx; + } + if (CONSP(proc)) /* local syntax binding. */ + proc = CDR(proc); + else if (SYMBOLP(proc)) /* global variable */ + proc = CDR(sym2vcell(proc)); + } + if (KEYWORDP(proc)) { + SCM argv[3]; + long argc = 2; + proc = KEYWORD_MACRO(proc); + argv[0] = x; + argv[1] = env; + argv[2] = ctxt; + switch (MAC_TYPE(proc)) { + case MAC_MACRO: case MAC_MACRO | MAC_PRIMITIVE: + case MAC_ACRO: case MAC_ACRO | MAC_PRIMITIVE: + /* This means non-memoizing macros can't expand into internal defines. + That's ok with me. */ + if (mode > 1) + x = cons2(IM_ACRO_CALL, CAR(x), CDR(x)); + goto retx; + case MAC_MMACRO | MAC_PRIMITIVE: + case MAC_IDMACRO | MAC_PRIMITIVE: + if (0==mode || + (1==mode && f_define != CDR(proc) && f_begin != CDR(proc))) { + x = scm_add_linum(linum, x); + goto retx; } - /* else fall through */ - case 1: case 5: /* macro */ - res = apply(CDR(proc), res, EOL); - x = NIMP(res) ? res : cons2(IM_BEGIN, res, EOL); + argv[2] = ctxt; + argc = 3; + /* fall through */ + case MAC_MMACRO: + case MAC_IDMACRO: + argv[0] = x; + argv[1] = env; + x = scm_cvapply(CDR(proc), argc, argv); + if (ilength(x) <= 0) + x = cons2((0==mode ? TOPRENAME(i_begin): IM_BEGIN), x, EOL); break; - case 0: case 4: /* acro */ - res = IMP(defs) ? apply(CDR(proc), res, EOL) : UNSPECIFIED; - return cons2(IM_QUOTE, res, EOL); +#ifdef MAC_INLINE /* FIXME this is broken */ + case MAC_INLINE: + { + int depth = env_depth(); + res = CDR(proc); + depth -= INUM(CAR(res)); + res = CDR(res); + x = cons2(MAKISYMVAL(IM_LET, depth), + CAR(res), cons(CDR(x), CDR(res))); + break; + } +#endif + } + MACROEXP_TRACE(xorig, env); + x = scm_check_linum(x, 0L); + if (NIMP(CAR(x)) && IDENTP(CAR(x))) { + proc = CAR(x); + goto macro_tail; } - if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail; #ifndef RECKLESS - if (UNBNDP(defs) && IM_DEFINE==CAR(x)) - everr(x, wrapenv(), i_define, "Bad placement", ""); + if (IM_DEFINE==CAR(x) && (mode != 1) && !scm_nullenv_p(env)) { + what = s_placement; + proc = res = i_define; + errout: + if (!UNBNDP(res)) + CAR(x) = res; /* FIXME may not be right for @macroexpand1 */ + if (UNBNDP(proc) && NIMP(x) && CONSP(x)) + proc = CAR(x); + scm_experr(proc, what, ""); + } #endif - return x; } + else { /* not a macro expression, car is identifier */ + if (0 == mode) + x = BOOL_F; + else if (mode <=2 ) + x = scm_add_linum(linum, x); #ifndef RECKLESS - if (IMP(defs)) { - if (! scm_arity_check(proc, ilength(CDR(x)), (char *)0)) { - badfun: - if (!UNBNDP(res)) CAR(x) = res; - everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc, - UNBNDP(proc) ? s_unbnd : - (FALSEP(procedurep(proc)) ? s_wtap : (char *)WNA), - ""); + else if (mode >= 3) { + argc = ilength(CDR(x)); + if (! scm_arity_check(proc, argc, (char *)0)) { + if (argc < 0) { + what = s_expr; + proc = x; + } + else + what = FALSEP(procedurep(proc)) ? s_wtap : (char *)WNA; + goto errout; + } + for (proc = CDR(x); NIMP(proc); proc = CDR(proc)) { + res = CAR(proc); + if (NIMP(res)) { + if (IDENTP(res)) + scm_lookupval(proc, !0); + else if (CONSP(res)) + macroexp1(res, env, i_argument, mode); + } + } } +#endif } -#endif /* ndef RECKLESS */ + retx: + if (mode >= 3 && x != xorig) { + DEFER_INTS; + CAR(xorig) = CAR(x); + CDR(xorig) = CDR(x); + x = xorig; + ALLOW_INTS; + } + MACROEXP_TRACE(trace, trace_env); /* restore */ return x; } #ifndef RECKLESS -int badargsp(proc, args) - SCM proc, args; +int badargsp(formals, args) + SCM formals, args; { - SCM formals = CAR(CODE(proc)); while NIMP(formals) { if NCONSP(formals) return 0; if IMP(args) return 1; @@ -1323,24 +1896,23 @@ int badargsp(proc, args) } return NNULLP(args) ? 1 : 0; } -/* If what is null, signals error instead of returning false. */ +/* If what is non-null, signals error instead of returning false. */ int scm_arity_check(proc, argc, what) SCM proc; long argc; char *what; { SCM p = proc; - if (IMP(p)) - return 0; + if (IMP(p) || argc < 0) goto badproc; cclo_tail: switch TYP7(p) { default: badproc: - if (what) wta(proc, (char *)ARG1, what); + if (what) wta(proc, s_wtap, what); + return 0; + wrongnumargs: + if (what) wta(proc, (char *)WNA, what); return 0; - wrongnumargs: - if (what) wta(proc, (char *)WNA, what); - return 0; case tc7_subr_0: ASRTGO(0==argc, wrongnumargs) return !0; case tc7_cxr: case tc7_contin: @@ -1355,9 +1927,12 @@ int scm_arity_check(proc, argc, what) case tc7_lsubr_2: ASRTGO(2<=argc, wrongnumargs) return !0; case tc7_specfun: switch TYP16(proc) { - case tc16_apply: ASRTGO(2<=argc, wrongnumargs) return !0; + default: wta(proc, "internal error", "scm_arity_check"); + case tc16_apply: ASRTGO(2<=argc, wrongnumargs); return !0; case tc16_call_cc: - case tc16_eval: ASRTGO(1==argc, wrongnumargs) return !0; + case tc16_eval: ASRTGO(1==argc, wrongnumargs); /* fall through */ + case tc16_values: return !0; + case tc16_call_wv: ASRTGO(2==argc, wrongnumargs); return !0; # ifdef CCLO case tc16_cclo: p = CCLO_SUBR(p); @@ -1367,50 +1942,82 @@ int scm_arity_check(proc, argc, what) } case tcs_closures: { - SCM formals = CAR(CODE(p)); + SCM formals = SCM_ENV_FORMALS(CAR(CODE(p))); while (argc--) { - if IMP(formals) goto wrongnumargs; + ASRTGO(NIMP(formals), wrongnumargs); if (CONSP(formals)) formals = CDR(formals); else return !0; } ASRTGO(IMP(formals) || NCONSP(formals), wrongnumargs); + return !0; } } } #endif -char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval"; +char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "@eval"; char s_call_cc[] = "call-with-current-continuation"; /* s_apply[] = "apply"; */ -static SCM wrapenv() +/* static int checking_defines_p(ctxt) SCM ctxt; */ +/* {return (NIMP(ctxt) && i_check_defines==CAR(ctxt));} */ +/* static SCM wrapenv() */ +/* {register SCM z; */ +/* DEFER_INTS_EGC; if NULLP(scm_env) return EOL; */ +/* NEWCELL(z); DEFER_INTS_EGC; */ +/* if (NIMP(scm_env) && ENVP(scm_env)) return scm_env; */ +/* CDR(z) = scm_env; CAR(z) = tc16_env; */ +/* EGC_ROOT(z); return z;} */ + +SCM scm_current_env() { - register SCM z; - NEWCELL(z); - DEFER_INTS_EGC; - if (NIMP(scm_env) && ENVP(scm_env)) - return scm_env; - CDR(z) = scm_env; - CAR(z) = tc16_env; - EGC_ROOT(z); - return z; + if (NFALSEP(scm_estk)) + return STATIC_ENV; + return EOL; } -SCM ceval(x, env) - SCM x, env; +SCM ceval(x, static_env, env) + SCM x, static_env, env; { ENV_PUSH; #ifdef CAUTIOUS - scm_trace = UNSPECIFIED; + scm_trace = BOOL_F; #endif TRACE(x); + STATIC_ENV = static_env; scm_env = env; x = ceval_1(x); ENV_POP; ALLOW_INTS_EGC; return x; } +SCM scm_eval_values(x, env, valenv) + SCM x, env, valenv; +{ + SCM res; + ENV_PUSH; +#ifdef CAUTIOUS + scm_trace = BOOL_F; +#endif + TRACE(x); + STATIC_ENV = env; + scm_env = valenv; + scm_env_tmp = IM_VALUES_TOKEN; + if (NIMP(x)) x = ceval_1(x); + DEFER_INTS_EGC; + if (IM_VALUES_TOKEN==scm_env_tmp) { + if (UNBNDP(x)) + res = EOL; + else + res = cons(x, EOL); + } + else + res = cons2(x, CAR(scm_env_tmp), CDR(scm_env_tmp)); + ENV_POP; + ALLOW_INTS_EGC; + return res; +} static SCM ceval_1(x) SCM x; @@ -1433,7 +2040,7 @@ static SCM ceval_1(x) switch TYP7(x) { case tcs_symbols: /* only happens when called at top level */ - x = *lookupcar(cons(x, UNDEFINED), LOOKUP_UNDEFP); + x = evalatomcar(cons(x, UNDEFINED), !0); goto retx; case (127 & IM_AND): x = CDR(x); @@ -1448,14 +2055,7 @@ static SCM ceval_1(x) begin: t.arg1 = x; while(NNULLP(t.arg1 = CDR(t.arg1))) { - if IMP(CAR(x)) { - if ISYMP(CAR(x)) { - x = m_expand_body(x); - goto begin; - } - } - else - ceval_1(CAR(x)); + if (NIMP(CAR(x))) ceval_1(CAR(x)); x = t.arg1; } carloop: /* eval car of last form in list */ @@ -1464,7 +2064,7 @@ static SCM ceval_1(x) x = IMP(x) ? EVALIMP(x) : I_VAL(x); } else if ATOMP(CAR(x)) - x = evalatomcar(x); + x = evalatomcar(x, 0); else { x = CAR(x); goto loop; /* tail recurse */ @@ -1475,32 +2075,8 @@ static SCM ceval_1(x) return x; case (127 & IM_CASE): - x = CDR(x); - t.arg1 = EVALCAR(x); -#ifndef INUMS_ONLY - arg2 = (SCM)(IMP(t.arg1) || !NUMP(t.arg1)); -#endif - while(NIMP(x = CDR(x))) { - proc = CAR(x); - if (IM_ELSE==CAR(proc)) { - x = CDR(proc); - goto begin; - } - proc = CAR(proc); - while NIMP(proc) { - if ( -#ifndef INUMS_ONLY - arg2 ? NFALSEP(eqv(CAR(proc), t.arg1)) : -#endif - (CAR(proc)==t.arg1)) { - x = CDR(CAR(x)); - goto begin; - } - proc = CDR(proc); - } - } - x = UNSPECIFIED; - goto retx; + x = scm_case_selector(x); + goto begin; case (127 & IM_COND): while(NIMP(x = CDR(x))) { proc = CAR(x); @@ -1525,7 +2101,8 @@ static SCM ceval_1(x) TRACE(x); x = CDR(x); ecache_evalx(CAR(CDR(x))); /* inits */ - EXTEND_ENV(CAR(x)); + STATIC_ENV = CAR(x); + EXTEND_VALENV; x = CDR(CDR(x)); while (proc = CAR(x), FALSEP(EVALCAR(proc))) { for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) { @@ -1533,9 +2110,8 @@ static SCM ceval_1(x) SIDEVAL_1(t.arg1); } ecache_evalx(CDR(CDR(x))); /* steps */ - t.arg1 = CAR(CAR(scm_env)); scm_env = CDR(scm_env); - EXTEND_ENV(t.arg1); + EXTEND_VALENV; } x = CDR(proc); if NULLP(x) {x = UNSPECIFIED; goto retx;} @@ -1548,38 +2124,49 @@ static SCM ceval_1(x) case (127 & IM_LET): ENV_MAY_PUSH(envpp); TRACE(x); +#ifdef MAC_INLINE + t.arg1 = CAR(x); +#endif x = CDR(x); ecache_evalx(CAR(CDR(x))); - EXTEND_ENV(CAR(x)); +#ifdef MAC_INLINE + if (t.arg1 != IM_LET) /* inline call */ + env_tail(ISYMVAL(t.arg1)); +#endif + STATIC_ENV = CAR(x); + EXTEND_VALENV; x = CDR(x); goto cdrxbegin; case (127 & IM_LETREC): ENV_MAY_PUSH(envpp); TRACE(x); x = CDR(x); + STATIC_ENV = CAR(x); scm_env_tmp = undefineds; - EXTEND_ENV(CAR(x)); + EXTEND_VALENV; x = CDR(x); ecache_evalx(CAR(x)); - EGC_ROOT(CAR(scm_env)); - CDR(CAR(scm_env)) = scm_env_tmp; + EGC_ROOT(scm_env); + CAR(scm_env) = scm_env_tmp; scm_env_tmp = EOL; goto cdrxbegin; case (127 & IM_LETSTAR): ENV_MAY_PUSH(envpp); TRACE(x); x = CDR(x); - proc = CAR(x); - if IMP(proc) { - scm_env_tmp = EOL; - EXTEND_ENV(EOL); - goto cdrxbegin; - } + proc = CDR(CAR(x)); + /* No longer happens. + if IMP(proc) { + scm_env_tmp = EOL; + EXTEND_VALENV; + goto cdrxbegin; + } + */ do { - t.arg1 = CAR(proc); - proc = CDR(proc); scm_env_tmp = EVALCAR(proc); - EXTEND_ENV(t.arg1); + proc = CDR(proc); + STATIC_ENV = CAR(proc); + EXTEND_VALENV; } while NIMP(proc = CDR(proc)); goto cdrxbegin; case (127 & IM_OR): @@ -1609,7 +2196,7 @@ static SCM ceval_1(x) x = scm_multi_set(proc, arg2); goto retx; } - else *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2; + else *lookupcar(x) = arg2; break; case 1: I_VAL(proc) = arg2; @@ -1624,9 +2211,10 @@ static SCM ceval_1(x) x = UNSPECIFIED; #endif goto retx; - case (127 & IM_DEFINE): /* only for internal defines */ - goto badfun; - /* new syntactic forms go here. */ + case (127 & IM_FUNCALL): + x = CDR(x); + proc = ceval_1(CAR(x)); + break; case (127 & MAKISYM(0)): proc = CAR(x); ASRTGO(ISYMP(proc), badfun); @@ -1662,6 +2250,25 @@ static SCM ceval_1(x) case (ISYMNUM(IM_FARLOC_CDR)): x = *farlookup(x); goto retx; + case (ISYMNUM(IM_EVAL_FOR_APPLY)): + /* only happens when called from C-level apply or cvapply */ + envpp = 1; + proc = CAR(scm_env_tmp); + scm_env_tmp = CDR(scm_env_tmp); + goto clo_unchecked; + case (ISYMNUM(IM_LET_SYNTAX)): + x = CDR(x); + STATIC_ENV = CAR(x); + goto cdrxbegin; + case (ISYMNUM(IM_ACRO_CALL)): + x = acro_call(x, STATIC_ENV); + goto loop; + case (ISYMNUM(IM_LINUM)): + goto expand; + case (ISYMNUM(IM_DEFINE)): + x = toplevel_define(x, STATIC_ENV); + goto retx; + /* new syntactic forms go here. */ default: goto badfun; } @@ -1669,9 +2276,11 @@ static SCM ceval_1(x) proc = x; badfun: #ifdef CAUTIOUS - scm_trace = UNDEFINED; + scm_trace = BOOL_F; + everr(xorig, STATIC_ENV, proc, s_wtap, "", 0); +#else + everr(x, STATIC_ENV, proc, s_wtap, "", 0); #endif - everr(x, wrapenv(), proc, s_wtap, ""); case tc7_vector: case tcs_uves: case tc7_smob: @@ -1683,29 +2292,30 @@ static SCM ceval_1(x) proc = I_VAL(CAR(x)); break; case tcs_cons_nimcar: - if ATOMP(CAR(x)) { - TOP_TRACE(x); + expand: + TOP_TRACE(x, STATIC_ENV); #ifdef MEMOIZE_LOCALS - x = macroexp1(x, UNDEFINED); - goto loop; + x = macroexp1(x, STATIC_ENV, EOL, 3); + goto loop; #else - proc = *lookupcar(x, 0); - if (NIMP(proc) && MACROP(proc)) { - x = macroexp1(x, UNDEFINED); + if ATOMP(CAR(x)) { + proc = scm_lookupval(x, 0); + if (KEYWORDP(proc)) { + x = macroexp1(x, STATIC_ENV, EOL, 3); goto loop; } -#endif } else proc = ceval_1(CAR(x)); +#endif + } /* At this point proc is the evaluated procedure from the function position and x has the form which is being evaluated. */ - } ASRTGO(NIMP(proc), badfun); scm_estk_ptr[0] = scm_env; /* For error reporting at wrongnumargs. */ if NULLP(CDR(x)) { evap0: + TOP_TRACE(xorig, STATIC_ENV); ENV_MAY_POP(envpp, CLOSUREP(proc)); - TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { /* no arguments given */ case tc7_subr_0: @@ -1728,8 +2338,8 @@ static SCM ceval_1(x) #ifdef CAUTIOUS if (0!=ARGC(proc)) { clo_checked: + t.arg1 = SCM_ENV_FORMALS(CAR(CODE(proc))); DEFER_INTS_EGC; - t.arg1 = CAR(CODE(proc)); arg2 = scm_env_tmp; while NIMP(t.arg1) { if NCONSP(t.arg1) goto clo_unchecked; @@ -1745,17 +2355,22 @@ static SCM ceval_1(x) clo_unchecked: x = CODE(proc); scm_env = ENV(proc); - EXTEND_ENV(CAR(x)); + STATIC_ENV = CAR(x); + EXTEND_VALENV; TRACE(CDR(x)); goto cdrxbegin; case tc7_specfun: + switch TYP16(proc) { + /* default: break; */ #ifdef CCLO - if (tc16_cclo==TYP16(proc)) { + case tc16_cclo: t.arg1 = proc; proc = CCLO_SUBR(proc); goto evap1; - } #endif + case tc16_values: + return scm_values(UNDEFINED, UNDEFINED, EOL, s_values); + } case tc7_contin: case tc7_subr_1: case tc7_subr_2: @@ -1764,28 +2379,33 @@ static SCM ceval_1(x) case tc7_subr_3: case tc7_lsubr_2: umwrongnumargs: - unmemocar(x); wrongnumargs: if (envpp < 0) { scm_estk_ptr += SCM_ESTK_FRLEN; scm_env = scm_estk_ptr[0]; } - TOP_TRACE(UNDEFINED); - everr(x, wrapenv(), proc, (char *)WNA, ""); +#ifdef CAUTIOUS + if (xorig==scm_trace) STATIC_ENV = scm_trace_env; + TOP_TRACE(BOOL_F, BOOL_F); + everr(xorig, STATIC_ENV, proc, (char *)WNA, "", 0); +#else + everr(x, STATIC_ENV, proc, (char *)WNA, "", 0); +#endif default: goto badfun; } } x = CDR(x); #ifdef CAUTIOUS - if (IMP(x)) goto wrongnumargs; + if (IMP(x)) + goto wrongnumargs; #endif t.arg1 = EVALCAR(x); x = CDR(x); if NULLP(x) { + TOP_TRACE(xorig, STATIC_ENV); evap1: ENV_MAY_POP(envpp, CLOSUREP(proc)); - TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { /* have one argument in t.arg1 */ case tc7_subr_2o: @@ -1795,39 +2415,39 @@ evap1: return SUBRF(proc)(t.arg1); case tc7_cxr: #ifdef FLOATS - if SUBRF(proc) { - if INUMP(t.arg1) - return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0); - ASRTGO(NIMP(t.arg1), floerr); - if REALP(t.arg1) - return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0); + if SUBRF(proc) { + if INUMP(t.arg1) + return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0); + ASRTGO(NIMP(t.arg1), floerr); + if REALP(t.arg1) + return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0); # ifdef BIGDIG - if BIGP(t.arg1) - return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0); + if BIGP(t.arg1) + return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0); # endif - floerr: - wta(t.arg1, (char *)ARG1, SNAME(proc)); - } + floerr: + wta(t.arg1, (char *)ARG1, SNAME(proc)); + } #endif - { - int op = CXR_OP(proc); + { + int op = CXR_OP(proc); #ifndef RECKLESS - x = t.arg1; + x = t.arg1; #endif - while (op) { - ASSERT(NIMP(t.arg1) && CONSP(t.arg1), - x, ARG1, SNAME(proc)); - t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1)); - op >>= 2; + while (op) { + ASSERT(NIMP(t.arg1) && CONSP(t.arg1), + x, ARG1, SNAME(proc)); + t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1)); + op >>= 2; + } + return t.arg1; } - return t.arg1; - } - case tc7_rpsubr: - return BOOL_T; - case tc7_asubr: - return SUBRF(proc)(t.arg1, UNDEFINED); - case tc7_lsubr: - return SUBRF(proc)(cons(t.arg1, EOL)); + case tc7_rpsubr: + return BOOL_T; + case tc7_asubr: + return SUBRF(proc)(t.arg1, UNDEFINED); + case tc7_lsubr: + return SUBRF(proc)(cons(t.arg1, EOL)); case tcs_closures: ENV_MAY_PUSH(envpp); #ifdef SCM_PROFILE @@ -1850,7 +2470,8 @@ evap1: DEFER_INTS_EGC; t.arg1 = scm_make_cont(); EGC_ROOT(t.arg1); - if ((x = setjump(CONT(t.arg1)->jmpbuf))) { + x = setjump(CONT(t.arg1)->jmpbuf); + if (x) { #ifdef SHORT_INT x = (SCM)thrown_value; #endif @@ -1863,17 +2484,22 @@ evap1: goto evap1; case tc16_eval: ENV_MAY_PUSH(envpp); - TRACE(x); + TRACE(t.arg1); + STATIC_ENV = eval_env; scm_env = EOL; - x = cons(copytree(t.arg1), EOL); - goto begin; + x = t.arg1; + if (IMP(x)) goto retx; + goto loop; #ifdef CCLO case tc16_cclo: - arg2 = t.arg1; - t.arg1 = proc; - proc = CCLO_SUBR(proc); - goto evap2; -#endif + arg2 = UNDEFINED; + goto cclon; + /* arg2 = t.arg1; + t.arg1 = proc; + proc = CCLO_SUBR(proc); + goto evap2; */ +#endif + case tc16_values: return t.arg1; } case tc7_subr_2: case tc7_subr_0: @@ -1891,9 +2517,9 @@ evap1: arg2 = EVALCAR(x); x = CDR(x); if NULLP(x) { /* have two arguments */ + TOP_TRACE(xorig, STATIC_ENV); evap2: ENV_MAY_POP(envpp, CLOSUREP(proc)); - TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { case tc7_subr_2: @@ -1910,6 +2536,7 @@ evap1: switch TYP16(proc) { case tc16_apply: proc = t.arg1; + ASRTGO(NIMP(proc), badfun); if NULLP(arg2) goto evap0; if (IMP(arg2) || NCONSP(arg2)) { x = arg2; @@ -1926,7 +2553,7 @@ evap1: if NULLP(x) goto evap2; ASRTGO(NIMP(x) && CONSP(x), badlst); arg3 = x; - x = copy_list(CDR(x), 0); + x = scm_cp_list(CDR(x), 0); #ifndef RECKLESS if UNBNDP(x) {x = arg3; goto badlst;} #endif @@ -1934,14 +2561,32 @@ evap1: goto evap3; #ifdef CCLO case tc16_cclo: cclon: - return apply(CCLO_SUBR(proc), - cons2(proc, t.arg1, cons(arg2, x)), EOL); - /* arg3 = arg2; + arg3 = arg2; arg2 = t.arg1; t.arg1 = proc; proc = CCLO_SUBR(proc); - goto evap3; */ + if (UNBNDP(arg3)) goto evap2; + goto evap3; + /* return apply(CCLO_SUBR(proc), + cons2(proc, t.arg1, cons(arg2, x)), EOL); */ #endif + case tc16_values: + return scm_values(t.arg1, arg2, EOL, s_values); + case tc16_call_wv: + ENV_MAY_PUSH(envpp); + scm_env_tmp = IM_VALUES_TOKEN; /* Magic value recognized by VALUES */ + t.arg1 = apply(t.arg1, EOL, EOL); + proc = arg2; + DEFER_INTS_EGC; + if (IM_VALUES_TOKEN==scm_env_tmp) { + scm_env_tmp = EOL; + if (UNBNDP(t.arg1)) goto evap0; + goto evap1; + } + arg2 = CAR(scm_env_tmp); + x = CDR(scm_env_tmp); + goto apply4; /* Jumping to apply code results in extra list copy + for >=3 args, but we want to minimize bloat. */ } case tc7_subr_0: case tc7_cxr: @@ -1976,6 +2621,7 @@ evap1: x = CDR(x); if NIMP(x) { if (CLOSUREP(proc) && 3==ARGC(proc)) { + ALLOW_INTS_EGC; ENV_MAY_PUSH(envpp); if (ecache_eval_args(proc, t.arg1, arg2, arg3, x)) goto clo_unchecked; @@ -1983,9 +2629,9 @@ evap1: } x = eval_args(x); } + TOP_TRACE(xorig, STATIC_ENV); evap3: ENV_MAY_POP(envpp, CLOSUREP(proc)); - TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { case tc7_subr_3: @@ -2006,8 +2652,7 @@ evap1: #endif switch ARGC(proc) { case 3: - scm_env_cons2(arg2, arg3, x); - scm_env_cons_tmp(t.arg1); + scm_env_cons3(t.arg1, arg2, arg3, x); goto clo_checked; case 2: scm_env_cons2(t.arg1, arg2, cons(arg3, x)); @@ -2023,6 +2668,7 @@ evap1: switch TYP16(proc) { case tc16_apply: proc = t.arg1; + ASRTGO(NIMP(proc), badfun); t.arg1 = arg2; if IMP(x) { x = arg3; @@ -2041,6 +2687,8 @@ evap1: x = cons(arg3, x); goto cclon; #endif + case tc16_values: + return scm_values(t.arg1, arg2, cons(arg3, x), s_values); } case tc7_subr_2: case tc7_subr_1o: @@ -2074,16 +2722,14 @@ static char s_proc_doc[] = "procedure-documentation"; SCM l_proc_doc(proc) SCM proc; { - SCM code; + SCM env; ASSERT(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin, proc, ARG1, s_proc_doc); switch TYP7(proc) { case tcs_closures: - code = CDR(CODE(proc)); - if IMP(CDR(code)) return BOOL_F; - code = CAR(code); - if IMP(code) return BOOL_F; - if STRINGP(code) return code; + env = CAR(CODE(proc)); + env = scm_env_getprop(SCM_ENV_DOC, CAR(CODE(proc))); + return IMP(env) ? BOOL_F : CAR(env); default: return BOOL_F; /* @@ -2117,7 +2763,7 @@ SCM nconc2copy(lst) } /* Shallow copy. If LST is not a proper list of length at least MINLEN, returns UNDEFINED */ -SCM copy_list(lst, minlen) +SCM scm_cp_list(lst, minlen) SCM lst; int minlen; { @@ -2132,15 +2778,14 @@ SCM copy_list(lst, minlen) return res; return UNDEFINED; } -SCM scm_v2lst(n, v) +SCM scm_v2lst(n, v, end) long n; - SCM *v; + SCM *v, end; { - SCM res = EOL; + SCM res = end; for(n--; n >= 0; n--) res = cons(v[n], res); return res; } -static SCM f_apply_closure; SCM apply(proc, arg1, args) SCM proc, arg1, args; { @@ -2192,7 +2837,7 @@ SCM apply(proc, arg1, args) return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0); # endif floerr: - wta(arg1, (char *)ARG1, CHARS(SNAME(proc))); + wta(arg1, (char *)ARG1, SNAME(proc)); } #endif { @@ -2234,29 +2879,16 @@ SCM apply(proc, arg1, args) args = CDR(args); } return BOOL_T; - case tcs_closures: + case tcs_closures: { arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args)); #ifndef RECKLESS - if (badargsp(proc, arg1)) goto wrongnumargs; + if (badargsp(SCM_ENV_FORMALS(CAR(CODE(proc))), arg1)) goto wrongnumargs; #endif ENV_PUSH; - PUSH_TRACE; - scm_env_tmp = arg1; - scm_env = ENV(proc); - proc = CODE(proc); - EXTEND_ENV(CAR(proc)); - proc = CDR(proc); - while NNULLP(proc) { - if (IMP(CAR(proc)) && ISYMP(CAR(proc))) { - proc = m_expand_body(proc); - continue; - } - arg1 = EVALCAR(proc); - proc = CDR(proc); - } - ENV_POP; - ALLOW_INTS_EGC; + scm_env_cons(proc, arg1); + arg1 = ceval_1(f_evapply); return arg1; + } case tc7_contin: ASRTGO(NULLP(args), wrongnumargs); scm_dynthrow(proc, arg1); @@ -2272,8 +2904,8 @@ SCM apply(proc, arg1, args) } } -/* This function does not check that proc is a procedure, nor the - number of arguments, call scm_arity_check to do that. */ +/* This function does not check that proc is a procedure, nor that + it accepts n arguments. Call scm_arity_check to do that. */ SCM scm_cvapply(proc, n, argv) SCM proc, *argv; long n; @@ -2290,7 +2922,6 @@ SCM scm_cvapply(proc, n, argv) case tc7_subr_2: return SUBRF(proc)(argv[0], argv[1]); case tc7_subr_0: - subr0: return SUBRF(proc)(); case tc7_subr_1o: if (0==n) return SUBRF(proc)(UNDEFINED); @@ -2310,7 +2941,7 @@ SCM scm_cvapply(proc, n, argv) return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0); # endif floerr: - wta(argv[0], (char *)ARG1, CHARS(SNAME(proc))); + wta(argv[0], (char *)ARG1, SNAME(proc)); } #endif { @@ -2327,12 +2958,12 @@ SCM scm_cvapply(proc, n, argv) case tc7_subr_3: return SUBRF(proc)(argv[0], argv[1], argv[2]); case tc7_lsubr: - return SUBRF(proc)(0==n ? EOL : scm_v2lst(n, argv)); + return SUBRF(proc)(0==n ? EOL : scm_v2lst(n, argv, EOL)); case tc7_lsubr_2: return SUBRF(proc)(argv[0], argv[1], - 2==n ? EOL : scm_v2lst(n-2, &argv[2])); + 2==n ? EOL : scm_v2lst(n-2, &argv[2], EOL)); case tc7_asubr: - if (1 >= n) return SUBRF(proc)(0==n ? UNDEFINED : argv[0], UNDEFINED); + if (1 >= n) return SUBRF(proc)(0==n ? UNDEFINED: argv[0], UNDEFINED); res = argv[0]; for (i = 1; i < n; i++) res = SUBRF(proc)(res, argv[i]); @@ -2342,34 +2973,23 @@ SCM scm_cvapply(proc, n, argv) for (i = 0; i < n-1; i++) if FALSEP(SUBRF(proc)(argv[i], argv[i+1])) return BOOL_F; return BOOL_T; - case tcs_closures: + case tcs_closures: { + SCM p = proc; ENV_PUSH; - PUSH_TRACE; i = ARGC(proc); if (3==i) { scm_env_tmp = EOL; - scm_env_v2lst((int)n, argv); + ENV_V2LST(n, argv); } else { - scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i]) : EOL; + scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i], EOL) : EOL; if (i>0) - scm_env_v2lst((int)i, argv); - } - scm_env = ENV(proc); - proc = CODE(proc); - EXTEND_ENV(CAR(proc)); - proc = CDR(proc); - while NNULLP(proc) { - if (IMP(CAR(proc)) && ISYMP(CAR(proc))) { - proc = m_expand_body(proc); - continue; - } - res = EVALCAR(proc); - proc = CDR(proc); + ENV_V2LST(i, argv); } - ENV_POP; - ALLOW_INTS_EGC; + ENV_V2LST(1L, &p); + res = ceval_1(f_evapply); return res; + } case tc7_contin: scm_dynthrow(proc, argv[0]); case tc7_specfun: @@ -2382,7 +3002,7 @@ SCM scm_cvapply(proc, n, argv) #endif goto tail; } - res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv)); + res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv, EOL)); #ifdef CCLO proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure); #else @@ -2401,10 +3021,6 @@ SCM map(proc, arg1, args) long i, n = ilength(args) + 1; scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */ if NULLP(arg1) return res; -#ifdef CAUTIOUS - ENV_PUSH; - PUSH_TRACE; -#endif #ifndef RECKLESS scm_arity_check(proc, n, s_map); #endif @@ -2424,21 +3040,20 @@ SCM map(proc, arg1, args) ave = &(ve[n]); } ve[0] = arg1; - ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_map); + ASSERT(NIMP(ve[0]), arg1, ARG2, s_map); for (i = 1; i < n; i++) { ve[i] = CAR(args); - ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_map); + ASSERT(NIMP(ve[i]), ve[i], ARGn, s_map); args = CDR(args); } while (1) { arg1 = EOL; for (i = n-1;i >= 0;i--) { if IMP(ve[i]) { -#ifdef CAUTIOUS - ENV_POP; -#endif + /* We could check for lists the same length here. */ return res; } + ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_map); ave[i] = CAR(ve[i]); ve[i] = CDR(ve[i]); } @@ -2454,10 +3069,6 @@ SCM for_each(proc, arg1, args) long i, n = ilength(args) + 1; scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */ if NULLP(arg1) return UNSPECIFIED; -#ifdef CAUTIOUS - ENV_PUSH; - PUSH_TRACE; -#endif #ifndef RECKLESS scm_arity_check(proc, n, s_map); #endif @@ -2477,21 +3088,19 @@ SCM for_each(proc, arg1, args) ave = &(ve[n]); } ve[0] = arg1; - ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_for_each); + ASSERT(NIMP(ve[0]), arg1, ARG2, s_for_each); for (i = 1; i < n; i++) { ve[i] = CAR(args); - ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_for_each); + ASSERT(NIMP(ve[i]), args, ARGn, s_for_each); args = CDR(args); } while (1) { arg1 = EOL; for (i = n-1;i >= 0;i--) { if IMP(ve[i]) { -#ifdef CAUTIOUS - ENV_POP; -#endif return UNSPECIFIED; } + ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each); ave[i] = CAR(ve[i]); ve[i] = CDR(ve[i]); } @@ -2535,129 +3144,85 @@ static int prinprom(exp, port, writing) SCM port; int writing; { - lputs("#<promise ", port); + lputs("#<promise", port); + if ((2L<<16) & CAR(exp)) lputc('*', port); + lputc(' ', port); iprin1(CDR(exp), port, writing); lputc('>', port); return !0; } +static SCM makro(code, flags, what) + SCM code; + long flags; + char *what; +{ + register SCM z; + ASSERT(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L), + (char *)0), code, ARG1, what); + NEWCELL(z); + CDR(z) = code; + CAR(z) = tc16_macro | (flags << 16); + return z; +} static char s_makacro[] = "procedure->syntax"; SCM makacro(code) SCM code; { - register SCM z; - ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makacro); - NEWCELL(z); - CDR(z) = code; - CAR(z) = tc16_macro; - return z; + return makro(code, MAC_ACRO, s_makacro); } static char s_makmacro[] = "procedure->macro"; SCM makmacro(code) SCM code; { - register SCM z; - ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmacro); - NEWCELL(z); - CDR(z) = code; - CAR(z) = tc16_macro | (1L<<16); - return z; + return makro(code, MAC_MACRO, s_makmacro); } static char s_makmmacro[] = "procedure->memoizing-macro"; SCM makmmacro(code) SCM code; { - register SCM z; - ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmmacro); - NEWCELL(z); - CDR(z) = code; - CAR(z) = tc16_macro | (2L<<16); - return z; + return makro(code, MAC_MMACRO, s_makmmacro); +} +static char s_makidmacro[] = "procedure->identifier-macro"; +SCM makidmacro(code) + SCM code; +{ + return makro(code, MAC_IDMACRO, s_makidmacro); } #ifdef MACRO -/* Functions for (eventual) smart expansion */ +/* Functions for smart expansion */ + +/* @MACROEXPAND1 returns: + #F if its argument is not a macro invocation, + the argument if the argument is a primitive syntax invocation, + the result of expansion if the argument is a macro invocation + (BEGIN #F) will be returned instead of #F if #F is the result. + */ static char s_macroexpand1[] = "@macroexpand1"; SCM scm_macroexpand1(x, env) SCM x, env; { - SCM res, proc; - if (IMP(x) || NCONSP(x)) return x; - res = CAR(x); - if (IMP(res) || !IDENTP(res)) return x; - ENV_PUSH; - PUSH_TRACE; - if (NULLP(env)) - scm_env = env; - else { - ASSERT(NIMP(env) && ENVP(env), env, ARG2, s_macroexpand1); - scm_env = CDR(env); + SCM name; + if (IMP(x)) return BOOL_F; + if (CONSP(x)) { + name = CAR(x); + if (IMP(name) || !IDENTP(name)) return BOOL_F; /* probably an error */ } - proc = *lookupcar(x, 0); - ENV_POP; - ALLOW_INTS_EGC; - if (NIMP(proc) && MACROP(proc)) { - SCM argv[2]; - switch ((int)(CAR(proc)>>16) & 0x7f) { - default: return x; /* Primitive macro invocation. */ - case 2: case 1: - argv[0] = x; - argv[1] = env; - res = scm_cvapply(CDR(proc), 2L, argv); - if (res==x) return cons(CAR(x), CDR(x)); - return res; - case 0: case 4: /* Acros, primitive or not. */ - argv[0] = x; - argv[1] = env; - return cons2(TOPRENAME(i_quote), - scm_cvapply(CDR(proc), 2L, argv), - EOL); - } + else if (IDENTP(x)) { + name = x; } - return x; -} -static char s_env_ref[] = "environment-ref"; -SCM scm_env_ref(env, ident) - SCM env, ident; -{ - SCM *p, ret; - if NULLP(env) return BOOL_F; - ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env_ref); - ASSERT(NIMP(ident) && IDENTP(ident), ident, ARG2, s_env_ref); - ENV_PUSH; - PUSH_TRACE; - scm_env = CDR(env); - p = id_denote(ident); - ret = p ? *p : BOOL_F; - ENV_POP; - ALLOW_INTS_EGC; - return ret; -} -static char s_extended_env[] = "extended-environment"; -SCM scm_extended_env(names, vals, env) - SCM names, vals, env; -{ - SCM z, nenv; -# ifndef RECKLESS - SCM v = vals; - z = names; - for (z = names; NIMP(z) && CONSP(z); z = CDR(z)) { - ASSERT(NIMP(v) && CONSP(v), vals, ARG2, s_extended_env); - v = CDR(v); - } - ASSERT(NNULLP(z) || NULLP(v), vals, ARG2, s_extended_env); -# endif - nenv = acons(names, vals, env2tree(env)); - NEWCELL(z); - CDR(z) = nenv; - CAR(z) = tc16_env | (1L << 16); - return z; + else + return BOOL_F; + return macroexp1(x, env, BOOL_F, 0); } + static char s_eval_syntax[] = "eval-syntax"; SCM scm_eval_syntax(x, env) SCM x, env; { - ASSERT(IMP(env) ? NULLP(env) : ENVP(env), env, ARG2, s_eval_syntax); - return EVAL(x, env); + SCM venv = cons(undefineds, undefineds); + CDR(venv) = venv; + return EVAL(x, env, venv); } #endif /* MACRO */ @@ -2666,11 +3231,19 @@ static int prinmacro(exp, port, writing) SCM port; int writing; { - if (CAR(exp) & (4L<<16)) lputs("#<primitive-", port); - else lputs("#<", port); - if (CAR(exp) & (3L<<16)) lputs("macro", port); - else lputs("syntax", port); - if (CAR(exp) & (2L<<16)) lputc('!', port); + lputs("#<", port); + if (MAC_TYPE(exp) & MAC_PRIMITIVE) lputs("primitive-", port); + switch (MAC_TYPE(exp) & ~MAC_PRIMITIVE) { + default: + lputs("macro", port); break; + case MAC_ACRO: + lputs("syntax", port); break; +#ifdef MAC_INLINE + case MAC_INLINE: + lputs("inline function", port); break; +#endif + } + if (MAC_TYPE(exp) & MAC_MEMOIZING) lputc('!', port); lputc(' ', port); iprin1(CDR(exp), port, writing); lputc('>', port); @@ -2694,8 +3267,8 @@ static int prinid(exp, port, writing) int writing; { SCM s = IDENT_PARENT(exp); - while (!IDENTP(s)) s = IDENT_PARENT(s); - lputs("#<identifier ", port); + while (M_IDENTP(s)) s = IDENT_PARENT(s); + lputs("#<id ", port); iprin1(s, port, writing); lputc(':', port); intprint((long)exp, -16, port); @@ -2707,17 +3280,41 @@ char s_force[] = "force"; SCM force(x) SCM x; { - ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force); - if (!((1L<<16) & CAR(x))) { - SCM ans = scm_cvapply(CDR(x), 0L, (SCM *)0); - if (!((1L<<16) & CAR(x))) { - DEFER_INTS; - CDR(x) = ans; - CAR(x) |= (1L<<16); - ALLOW_INTS; + tail: + ASRTGO(NIMP(x) && (TYP16(x)==tc16_promise), badx); + switch (CAR(x)>>16) { + default: + badx: wta(x, (char *)ARG1, s_force); + case 0: + { + SCM ans; + int mv = (IM_VALUES_TOKEN==scm_env_tmp); + ans = scm_cvapply(CDR(x), 0L, (SCM *)0); + if (mv) { + DEFER_INTS_EGC; + if (IM_VALUES_TOKEN==scm_env_tmp) { + if (!UNBNDP(ans)) mv = 0; + } + else { + ans = cons2(ans, CAR(scm_env_tmp), CDR(scm_env_tmp)); + scm_env_tmp = IM_VALUES_TOKEN; + } + ALLOW_INTS_EGC; + } + if (!((1L<<16) & CAR(x))) { + DEFER_INTS; + CDR(x) = ans; + CAR(x) |= mv ? (3L<<16) : (1L<<16); + ALLOW_INTS; + } + goto tail; } + case 1: return CDR(x); + case 3: + x = CDR(x); + if (UNBNDP(x)) return scm_values(UNDEFINED, UNDEFINED, EOL, s_force); + return scm_values(CAR(x), CAR(CDR(x)), CDR(CDR(x)), s_force); } - return CDR(x); } SCM copytree(obj) @@ -2743,7 +3340,7 @@ SCM eval(obj) SCM obj; { obj = copytree(obj); - return EVAL(obj, (SCM)EOL); + return EVAL(obj, EOL, EOL); } SCM definedp(x, env) @@ -2771,7 +3368,7 @@ static char s_ident_eqp[] = "identifier-equal?"; SCM ident_eqp(id1, id2, env) SCM id1, id2, env; { - SCM s1 = id1, s2 = id2, ret; + SCM s1 = id1, s2 = id2; # ifndef RECKLESS if IMP(id1) badarg1: wta(id1, (char *)ARG1, s_ident_eqp); @@ -2784,16 +3381,12 @@ SCM ident_eqp(id1, id2, env) ASRTGO(SYMBOLP(s1), badarg1); ASRTGO(SYMBOLP(s2), badarg2); if (s1 != s2) return BOOL_F; - ENV_PUSH; - PUSH_TRACE; - if NULLP(env) scm_env = env; - else { - ASSERT(NIMP(env) && tc16_env==TYP16(env), env, ARG3, s_ident_eqp); - scm_env = CDR(env); - } - ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F; - ENV_POP; - return ret; + s1 = scm_env_lookup(id1, env); + s2 = scm_env_lookup(id2, env); + if (s1==s2) return BOOL_T; + if (NIMP(s1) && ISYMP(CAR(s1))) /* FARLOC case */ + return equal(s1, s2); + return BOOL_F; } static char s_ident2sym[] = "identifier->symbol"; @@ -2811,13 +3404,22 @@ SCM renamed_ident(id, env) { SCM z; ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident); - if NIMP(env) { - ASSERT(ENVP(env), env, ARG2, s_renamed_ident); - DEFER_INTS_EGC; - env = CDR(env); - } NEWCELL(z); - if IMP(env) { + while (NIMP(env)) { + if (INUMP(CAR(env))) { + ASSERT(NIMP(CDR(env)), env, s_badenv, s_renamed_ident); + env = CDR(CDR(env)); + } + else if (SCM_LINUMP(CAR(env))) { + env = CDR(env); + } + else { + ASSERT(NULLP(env) || (NIMP(env) && CONSP(env)), + env, s_badenv, s_renamed_ident); + break; + } + } + if (scm_nullenv_p(env)) { CAR(z) = tc16_ident; CDR(z) = id; return z; @@ -2825,7 +3427,7 @@ SCM renamed_ident(id, env) else { SCM y; CAR(z) = id; - CDR(z) = CAR(CAR(env)); + CDR(z) = env; NEWCELL(y); CAR(y) = tc16_ident | 1L<<16; CDR(y) = z; @@ -2834,117 +3436,119 @@ SCM renamed_ident(id, env) } static char s_syn_quote[] = "syntax-quote"; -SCM m_syn_quote(xorig, env) - SCM xorig, env; +SCM m_syn_quote(xorig, env, ctxt) + SCM xorig, env, ctxt; { ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_syn_quote); return cons(IM_QUOTE, CDR(xorig)); } -/* Ensure that the environment for LET-SYNTAX can be uniquely identified. */ -SCM m_atlet_syntax(xorig, env) - SCM xorig, env; -{ - SCM mark; - DEFER_INTS_EGC; - if (NIMP(env) && ENVP(env)) - env = CDR(env); - if NULLP(env) return m_let(xorig, env); - mark = CAR(CAR(env)); - if (NIMP(mark) && CONSP(mark)) return m_let(xorig, env); - mark = renamed_ident(i_mark, BOOL_F); - return m_letstar(cons2(i_let, - cons(cons2(mark, BOOL_F, EOL), EOL), - acons(TOPRENAME(i_let), CDR(xorig), EOL)), - env); +static char s_defsyntax[] = "defsyntax"; +SCM m_defsyntax(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM x = CDR(xorig), name, val; + ASSYNT(ilength(x)==2, xorig, s_expression, s_defsyntax); + ASSYNT(scm_nullenv_p(env), xorig, s_placement, s_defsyntax); + name = CAR(x); + ASSYNT(NIMP(name) && IDENTP(name), name, s_variable, s_defsyntax); + val = evalcar(CDR(x)); + ASSYNT(NIMP(val) && MACROP(val), CAR(CDR(x)), s_expr, s_defsyntax); + checked_define(name, cons(IM_KEYWORD, val), s_defsyntax); + return UNSPECIFIED; +} + +SCM m_let_syntax(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM proc, vars, inits, fr; + SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits); + /* if (IMP(vars)) return m_let_null(body, env, ctxt); */ + /* Add a unique frame for an environment mark. */ + env = EXTEND_ENV(cons(SCM_ENV_SYNTAX, EOL), env); + for (fr = EOL; NIMP(inits); inits = CDR(inits)) { + proc = scm_eval_syntax(CAR(inits), env); + ASSYNT(NIMP(proc) && MACROP(proc), CAR(inits), s_expr, s_let_syntax); + fr = acons(CAR(vars), proc, fr); + vars = CDR(vars); + } + fr = cons(SCM_ENV_SYNTAX, fr); + env = EXTEND_ENV(fr, env); + return cons2(IM_LET_SYNTAX, env, m_body(body, env, ctxt)); +} +static char s_letrec_syntax[] = "letrec-syntax"; +SCM m_letrec_syntax(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM proc, vars, vals, inits, fr; + SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits); + /* if (IMP(vars)) return m_let_null(body, env, ctxt); */ + for (fr = EOL; NIMP(vars); vars = CDR(vars)) + fr = acons(CAR(vars), UNDEFINED, fr); + fr = cons(SCM_ENV_SYNTAX, fr); + env = EXTEND_ENV(fr, env); + for (vals = EOL; NIMP(inits); inits = CDR(inits)) { + proc = scm_eval_syntax(CAR(inits), env); + ASSYNT(NIMP(proc) && MACROP(proc), CAR(inits), s_expr, s_letrec_syntax); + vals = cons(proc, vals); + } + for (fr = CDR(fr); NIMP(fr); fr = CDR(fr)) { + CDR(CAR(fr)) = CAR(vals); + vals = CDR(vals); + } + return cons2(IM_LET_SYNTAX, env, m_body(body, env, ctxt)); } static char s_the_macro[] = "the-macro"; -SCM m_the_macro(xorig, env) - SCM xorig, env; +SCM m_the_macro(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM x = CDR(xorig); + SCM addr, x = CDR(xorig); ASSYNT(1==ilength(x), xorig, s_expression, s_the_macro); - if (NIMP(CAR(x)) && IDENTP(CAR(x))) - x = *lookupcar(x, LOOKUP_UNDEFP); - else - x = evalcar(x); - ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro); - return cons2(IM_QUOTE, x, EOL); + x = CAR(x); + ASSYNT(NIMP(x) && IDENTP(x), x, s_expression, s_the_macro); + addr = scm_env_lookup(x, env); + /* Require global ref for now. */ + ASSYNT(NIMP(addr) && SYMBOLP(addr), x, s_expression, s_the_macro); + x = CDR(sym2vcell(addr)); + ASSYNT(KEYWORDP(x), xorig, ARG1, s_the_macro); + return KEYWORD_MACRO(x); } #endif -static char s_env2tree[] = "environment->tree"; -SCM env2tree(env) - SCM env; -{ - SCM ans, a, *lloc; - if NULLP(env) return env; - ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env2tree); - if ((1L << 16) & CAR(env)) return CDR(env); - if IMP(CDR(env)) return CDR(env); - ENV_PUSH; - PUSH_TRACE; - scm_env = CDR(env); - ans = a = cons(UNSPECIFIED, UNSPECIFIED); - while (!0) { - scm_env_tmp = CAR(scm_env); - lloc = &CAR(a); - while (NIMP(scm_env_tmp) && CONSP(scm_env_tmp)) { - if (undefineds==*lloc) { - *lloc = BOOL_F; - break; - } - *lloc = cons(CAR(scm_env_tmp), CDR(scm_env_tmp)); - lloc = &CDR(*lloc); - DEFER_INTS_EGC; - scm_env_tmp = CDR(scm_env_tmp); - } - scm_env = CDR(scm_env); - if IMP(scm_env) { - CDR(a) = scm_env; - break; - } - a = (CDR(a) = cons(UNSPECIFIED, UNSPECIFIED)); - } - ENV_POP; - ALLOW_INTS_EGC; - CDR(env) = ans; /* Memoize migrated environment. */ - CAR(env) |= (1L << 16); - return ans; -} - static iproc subr1s[] = { {"@copy-tree", copytree}, /* {s_eval, eval}, now a (tail recursive) specfun */ {s_force, force}, {s_proc_doc, l_proc_doc}, - {"procedure->syntax", makacro}, - {"procedure->macro", makmacro}, - {"procedure->memoizing-macro", makmmacro}, + {s_makacro, makacro}, + {s_makmacro, makmacro}, + {s_makmmacro, makmmacro}, + {s_makidmacro, makidmacro}, {"apply:nconc-to-last", nconc2copy}, - {s_env2tree, env2tree}, + /* {s_env2tree, env2tree}, */ #ifdef MACRO {s_identp, identp}, {s_ident2sym, ident2sym}, #endif {0, 0}}; -static iproc lsubr2s[] = { -/* {s_apply, apply}, now explicity initted */ - {s_map, map}, - {s_for_each, for_each}, +static iproc subr2s[] = { #ifdef MACRO {s_macroexpand1, scm_macroexpand1}, - {s_env_ref, scm_env_ref}, {s_eval_syntax, scm_eval_syntax}, #endif {0, 0}}; +static iproc lsubr2s[] = { +/* {s_apply, apply}, now explicity initted */ + {s_map, map}, + {s_for_each, for_each}, + {0, 0}}; + static iproc subr3s[] = { #ifdef MACRO {s_ident_eqp, ident_eqp}, - {s_extended_env, scm_extended_env}, #endif {0, 0}}; @@ -2955,25 +3559,28 @@ static smobfuns envsmob = {markcdr, free0, prinenv}; static smobfuns idsmob = {markcdr, free0, prinid}; #endif -SCM make_synt(name, macroizer, fcn) +SCM make_synt(name, flags, fcn) const char *name; - SCM (*macroizer)(); + long flags; SCM (*fcn)(); { SCM symcell = sysintern(name, UNDEFINED); - SCM z = macroizer(scm_maksubr(name, tc7_subr_2, fcn)); - CAR(z) |= (4L << 16); /* Flags result as primitive macro. */ + SCM z = makro(scm_maksubr(name, tc7_subr_3, fcn), + flags | MAC_PRIMITIVE, "make_synt"); +#ifdef MACRO + z = cons(IM_KEYWORD, z); +#endif CDR(symcell) = z; return CAR(symcell); } -SCM make_specfun(name, typ) +SCM make_specfun(name, typ, flags) char *name; - int typ; + int typ, flags; { SCM symcell = sysintern(name, UNDEFINED); register SCM z; NEWCELL(z); - CAR(z) = (long)typ; + CAR(z) = (long)typ | ((long)flags)<<16; CDR(z) = CAR(symcell); CDR(symcell) = z; return z; @@ -2984,56 +3591,81 @@ void init_eval() tc16_macro = newsmob(¯osmob); tc16_env = newsmob(&envsmob); init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2s, tc7_subr_2); init_iprocs(lsubr2s, tc7_lsubr_2); init_iprocs(subr3s, tc7_subr_3); #ifdef SCM_PROFILE make_subr("scm:profile", tc7_subr_1o, scm_profile); #endif - make_specfun(s_apply, tc16_apply); - make_specfun(s_call_cc, tc16_call_cc); - make_specfun(s_eval, tc16_eval); + make_specfun(s_apply, tc16_apply, 0); + make_specfun(s_call_cc, tc16_call_cc, 0); + make_specfun(s_eval, tc16_eval, 0); + make_specfun(s_values, tc16_values, 0); + make_specfun(s_call_wv, tc16_call_wv, 0); + add_feature(s_values); i_dot = CAR(sysintern(".", UNDEFINED)); i_arrow = CAR(sysintern("=>", UNDEFINED)); i_else = CAR(sysintern("else", UNDEFINED)); i_unquote = CAR(sysintern("unquote", UNDEFINED)); i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED)); + i_quasiquote = make_synt(s_quasiquote, MAC_MMACRO, m_quasiquote); + i_define = make_synt(s_define, MAC_MMACRO, m_define); + make_synt(s_delay, MAC_MMACRO, m_delay); + + i_bind = CAR(sysintern("bind", UNDEFINED)); + i_anon = CAR(sysintern("<anon>", UNDEFINED)); + i_side_effect = CAR(sysintern("side-effect", UNDEFINED)); + i_test = CAR(sysintern("test", UNDEFINED)); + i_procedure = CAR(sysintern("procedure", UNDEFINED)); + i_argument = CAR(sysintern("argument", UNDEFINED)); + i_check_defines = CAR(sysintern("check-defines", UNDEFINED)); + loc_atcase_aux = &CDR(sysintern("@case-aux", UNDEFINED)); /* acros */ - i_quasiquote = make_synt(s_quasiquote, makmmacro, m_quasiquote); - i_define = make_synt(s_define, makmmacro, m_define); - make_synt(s_delay, makmmacro, m_delay); - make_synt("defined?", makacro, definedp); + make_synt("defined?", MAC_ACRO, definedp); /* end of acros */ - make_synt(s_and, makmmacro, m_and); - make_synt(s_begin, makmmacro, m_begin); - make_synt(s_case, makmmacro, m_case); - make_synt(s_cond, makmmacro, m_cond); - make_synt(s_do, makmmacro, m_do); - make_synt(s_if, makmmacro, m_if); - i_lambda = make_synt(s_lambda, makmmacro, m_lambda); - i_let = make_synt(s_let, makmmacro, m_let); - make_synt(s_letrec, makmmacro, m_letrec); - make_synt(s_letstar, makmmacro, m_letstar); - make_synt(s_or, makmmacro, m_or); - i_quote = make_synt(s_quote, makmmacro, m_quote); - make_synt(s_set, makmmacro, m_set); - make_synt(s_atapply, makmmacro, m_apply); - /* make_synt(s_atcall_cc, makmmacro, m_cont); */ - - f_apply_closure = - CDR(sysintern(" apply-closure", - scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))"))); - + make_synt(s_and, MAC_MMACRO, m_and); + i_begin = make_synt(s_begin, MAC_MMACRO, m_begin); + make_synt(s_case, MAC_MMACRO, m_case); + make_synt(s_cond, MAC_MMACRO, m_cond); + make_synt(s_do, MAC_MMACRO, m_do); + make_synt(s_if, MAC_MMACRO, m_if); + i_lambda = make_synt(s_lambda, MAC_MMACRO, m_lambda); + i_let = make_synt(s_let, MAC_MMACRO, m_let); + make_synt(s_letrec, MAC_MMACRO, m_letrec); + make_synt(s_letstar, MAC_MMACRO, m_letstar); + make_synt(s_or, MAC_MMACRO, m_or); + i_quote = make_synt(s_quote, MAC_MMACRO, m_quote); + make_synt(s_set, MAC_MMACRO, m_set); + make_synt(s_atapply, MAC_MMACRO, m_apply); + /* make_synt(s_atcall_cc, MAC_MMACRO, m_cont); */ +#ifdef MAC_INLINE + make_synt("@inline-lambda", MAC_MMACRO, m_inline_lambda); +#endif #ifdef MACRO tc16_ident = newsmob(&idsmob); make_subr(s_renamed_ident, tc7_subr_2, renamed_ident); - make_synt(s_syn_quote, makmmacro, m_syn_quote); - make_synt("@let-syntax", makmmacro, m_atlet_syntax); - /* This doesn't do anything special, but might in the future. */ - make_synt("@letrec-syntax", makmmacro, m_letrec); - make_synt(s_the_macro, makmmacro, m_the_macro); - i_mark = CAR(sysintern("let-syntax-mark", UNDEFINED)); + make_synt(s_syn_quote, MAC_MMACRO, m_syn_quote); + make_synt(s_defsyntax, MAC_MMACRO, m_defsyntax); + make_synt(s_let_syntax, MAC_MMACRO, m_let_syntax); + make_synt(s_letrec_syntax, MAC_MMACRO, m_letrec_syntax); + + make_synt(s_the_macro, MAC_ACRO, m_the_macro); +#endif + + f_begin = CDR(CDR(KEYWORD_MACRO(sym2vcell(i_begin)))); + f_define = CDR(CDR(KEYWORD_MACRO(sym2vcell(i_define)))); + + list_unspecified = cons(UNSPECIFIED, EOL); + f_evapply = cons(IM_EVAL_FOR_APPLY, EOL); +#ifdef SCM_ENV_FILENAME + eval_env = scm_env_addprop(SCM_ENV_FILENAME, + CAR(sysintern("eval", UNDEFINED)), + EOL); +#else + eval_env = EOL; #endif + f_apply_closure = scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))"); } diff --git a/features.txi b/features.txi deleted file mode 100644 index 3580171..0000000 --- a/features.txi +++ /dev/null @@ -1,196 +0,0 @@ -@item array -@cindex array -Alias for ARRAYS - -@item array-for-each -@cindex array-for-each -array-map! and array-for-each (arrays must also be featured). - -@item arrays -@cindex arrays -Use if you want arrays, uniform-arrays and uniform-vectors. - -@item bignums -@cindex bignums -Large precision integers. - -@item careful-interrupt-masking -@cindex careful-interrupt-masking -Define this for extra checking of interrupt masking and some simple -checks for proper use of malloc and free. This is for debugging C -code in @file{sys.c}, @file{eval.c}, @file{repl.c} and makes the -interpreter several times slower than usual. - -@item cautious -@cindex cautious -Normally, the number of arguments arguments to interpreted closures -(from LAMBDA) are checked if the function part of a form is not a -symbol or only the first time the form is executed if the function -part is a symbol. defining @samp{reckless} disables any checking. -If you want to have SCM always check the number of arguments to -interpreted closures define feature @samp{cautious}. - -@item cheap-continuations -@cindex cheap-continuations -If you only need straight stack continuations, executables compile with -this feature will run faster and use less storage than not having it. -Machines with unusual stacks @emph{need} this. Also, if you incorporate -new C code into scm which uses VMS system services or library routines -(which need to unwind the stack in an ordrly manner) you may need to -use this feature. - -@item compiled-closure -@cindex compiled-closure -Use if you want to use compiled closures. - -@item curses -@cindex curses -For the @dfn{curses} screen management package. - -@item debug -@cindex debug -Turns on the features @samp{cautious}, -@samp{careful-interrupt-masking}, and @samp{stack-limit}; uses -@code{-g} flags for debugging SCM source code. - -@item dump -@cindex dump -Convert a running scheme program into an executable file. - -@item dynamic-linking -@cindex dynamic-linking -Be able to load compiled files while running. - -@item edit-line -@cindex edit-line -interface to the editline or GNU readline library. - -@item engineering-notation -@cindex engineering-notation -Use if you want floats to display in engineering notation (exponents -always multiples of 3) instead of scientific notation. - -@item generalized-c-arguments -@cindex generalized-c-arguments -@code{make_gsubr} for arbitrary (< 11) arguments to C functions. - -@item i/o-extensions -@cindex i/o-extensions -Commonly available I/O extensions: @dfn{exec}, line I/O, file -positioning, file delete and rename, and directory functions. - -@item inexact -@cindex inexact -Use if you want floating point numbers. - -@item lit -@cindex lit -Lightweight -- no features - -@item macro -@cindex macro -C level support for hygienic and referentially transparent macros -(syntax-rules macros). - -@item mysql -@cindex mysql -Client connections to the mysql databases. - -@item no-heap-shrink -@cindex no-heap-shrink -Use if you want segments of unused heap to not be freed up after -garbage collection. This may increase time in GC for *very* large -working sets. - -@item none -@cindex none -No features - -@item posix -@cindex posix -Posix functions available on all @dfn{Unix-like} systems. fork and -process functions, user and group IDs, file permissions, and -@dfn{link}. - -@item reckless -@cindex reckless -If your scheme code runs without any errors you can disable almost -all error checking by compiling all files with @samp{reckless}. - -@item record -@cindex record -The Record package provides a facility for user to define their own -record data types. See SLIB for documentation. - -@item regex -@cindex regex -String regular expression matching. - -@item rev2-procedures -@cindex rev2-procedures -These procedures were specified in the @cite{Revised^2 Report on Scheme} -but not in @cite{R4RS}. - -@item sicp -@cindex sicp -Use if you want to run code from: - -@cindex SICP -Harold Abelson and Gerald Jay Sussman with Julie Sussman. -@cite{Structure and Interpretation of Computer Programs.} -The MIT Press, Cambridge, Massachusetts, USA, 1985. - -Differences from R5RS are: -@itemize @bullet -@item -(eq? '() '#f) -@item -(define a 25) returns the symbol a. -@item -(set! a 36) returns 36. -@end itemize - -@item single-precision-only -@cindex single-precision-only -Use if you want all inexact real numbers to be single precision. This -only has an effect if SINGLES is also defined (which is the default). -This does not affect complex numbers. - -@item socket -@cindex socket -BSD @dfn{socket} interface. - -@item stack-limit -@cindex stack-limit -Use to enable checking for stack overflow. Define value of the C -preprocessor variable @var{STACK_LIMIT} to be the size to which SCM -should allow the stack to grow. STACK_LIMIT should be less than the -maximum size the hardware can support, as not every routine checks the -stack. - -@item tick-interrupts -@cindex tick-interrupts -Use if you want the ticks and ticks-interrupt functions. - -@item turtlegr -@cindex turtlegr -@dfn{Turtle} graphics calls for both Borland-C and X11 from -sjm@@ee.tut.fi. - -@item unix -@cindex unix -Those unix features which have not made it into the Posix specs: -nice, acct, lstat, readlink, symlink, mknod and sync. - -@item windows -@cindex windows -Microsoft Windows executable. - -@item x -@cindex x -Alias for Xlib feature. - -@item xlib -@cindex xlib -Interface to Xlib graphics routines. - @@ -37,54 +37,72 @@ Wed Feb 21 23:06:35 1996 Aubrey Jaffer <jaffer@jacal.bertronics> filename. A new copy of the complete path name of that file is returned. This new string may be disposed by free() later on. */ -#include <sys/file.h> -#include <sys/param.h> -#ifdef linux -# include <stdlib.h> -# include <sys/stat.h> -# include <unistd.h> /* for X_OK define */ -#endif -#ifdef __svr4__ -# include <string.h> -# include <stdlib.h> -# include <sys/stat.h> -# include <unistd.h> /* for X_OK define */ -#else -# ifdef __sgi__ +#ifndef __MINGW32__ +# ifndef PLAN9 +# include <sys/file.h> +# include <sys/param.h> +# endif +# ifdef linux +# include <stdlib.h> +# include <sys/stat.h> +# include <unistd.h> /* for X_OK define */ +# endif +# ifdef __SVR4 # include <string.h> # include <stdlib.h> # include <sys/stat.h> # include <unistd.h> /* for X_OK define */ # else -# include <strings.h> +# ifdef __sgi__ +# include <string.h> +# include <stdlib.h> +# include <sys/stat.h> +# include <unistd.h> /* for X_OK define */ +# else +# ifdef PLAN9 +# include <u.h> +# include <libc.h> +# define getcwd getwd +# define MAXPATHLEN 256 /* arbitrary? */ +# define X_OK AEXEC +# else +# include <strings.h> +# endif +# endif +# endif +# ifdef __amigaos__ +# include <stdlib.h> +# include <sys/stat.h> +# include <unistd.h> +# endif +# ifndef __STDC__ +# define const /**/ +# endif +# ifdef __FreeBSD__ +/* This might be same for 44bsd derived system. */ +# include <sys/types.h> +# include <sys/stat.h> # endif -#endif -#ifdef __amigados__ -# include <stdlib.h> -# include <sys/stat.h> -# include <unistd.h> -#endif -#ifndef __STDC__ -# define const /**/ -#endif -#ifdef __FreeBSD__ +# ifdef __OpenBSD__ /* This might be same for 44bsd derived system. */ -# include <sys/types.h> -# include <sys/stat.h> -#endif -#ifdef __alpha -# include <string.h> -# include <stdlib.h> -# include <sys/types.h> -# include <sys/stat.h> -#endif -#ifdef GO32 -# include <sys/stat.h> -#endif - -#ifndef DEFAULT_PATH -# define DEFAULT_PATH ".:~/bin::/usr/local/bin:/usr/new:/usr/ucb:/usr/bin:/bin:/usr/hosts" -#endif +# include <stdlib.h> +# include <unistd.h> +# include <sys/types.h> +# include <sys/stat.h> +# endif +# ifdef __alpha +# include <string.h> +# include <stdlib.h> +# include <sys/types.h> +# include <sys/stat.h> +# endif +# ifdef GO32 +# include <sys/stat.h> +# endif + +# ifndef DEFAULT_PATH +# define DEFAULT_PATH ".:~/bin::/usr/local/bin:/usr/new:/usr/ucb:/usr/bin:/bin:/usr/hosts" +# endif static char *copy_of(s) register const char *s; @@ -97,12 +115,12 @@ static char *copy_of(s) } /* ABSOLUTE_FILENAME_P(fname): True if fname is an absolute filename */ -#ifdef atarist -# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '/') || \ +# ifdef atarist +# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '/') || \ (fname[0] && (fname[1] == ':'))) -#else -# define ABSOLUTE_FILENAME_P(fname) (fname[0] == '/') -#endif /* atarist */ +# else +# define ABSOLUTE_FILENAME_P(fname) (fname[0] == '/') +# endif /* atarist */ char *dld_find_executable(name) const char *name; @@ -155,16 +173,21 @@ char *dld_find_executable(name) strcat(tbuf, name); if (access(tbuf, X_OK) == 0) { -#ifndef hpux -# ifndef ultrix +# ifndef hpux +# ifndef ultrix +# ifndef __MACH__ +# ifndef PLAN9 struct stat stat_temp; - if (stat(tbuf,&stat_temp)) continue; + if (stat(tbuf, &stat_temp)) continue; if (S_IFREG != (S_IFMT & stat_temp.st_mode)) continue; -# endif/* ultrix */ -#endif /* hpux */ +# endif /* PLAN9 */ +# endif /* __MACH__ */ +# endif/* ultrix */ +# endif /* hpux */ return copy_of(tbuf); } } return 0; } +#endif /* ndef MSDOS */ @@ -1622,11 +1622,13 @@ write to the Free Software Foundation, Inc., 59 Temple Place, Suite extern size_t __getpagesize PP ((void)); #endif #else +#ifndef __osf__ /* declared in <unistd.h> */ #ifndef hpux /* declared in <unistd.h> */ #ifndef __svr4__ /* declared in <unistd.h> */ #include "getpagesize.h" #endif #endif +#endif #define __getpagesize() getpagesize() #endif @@ -1649,6 +1651,7 @@ valloc (size) #endif /* Not ELIDE_VALLOC. */ +#ifdef DEBUG_GMALLOC /* Debugging functions added by Radey Shouman */ struct list *check_block_prev; int check_block(block, cont) @@ -1697,4 +1700,4 @@ int check_frag_blocks() } return 0; } - +#endif diff --git a/grtest.scm b/grtest.scm new file mode 100644 index 0000000..7401308 --- /dev/null +++ b/grtest.scm @@ -0,0 +1,82 @@ + +; This is a quick hack to test the graphics primitives. +; The SLIB scheme library is needed for random. +; IMHO, the syntax of `do' in scheme is horrible! +; - sjm + +(define (grtest) + (require 'random) ; needs SLIB + (graphics-mode!) + + (display "testing draw-to") (newline) + (clear-graphics!) + (goto-center!) + (do ((x 0 (+ x 3))) + ((> x (max-x)) 0) + (set-color! (remainder (/ x 3) (max-color))) + (draw-to x 0) + (draw-to x (max-y)) + ) + + (do ((y 0 (+ y 3))) + ((> y (max-y)) 0) + (set-color! (remainder (/ y 3) (max-color))) + (goto-center!) + (draw-to! 0 y) + (goto-center!) + (draw-to! (max-x) y) + ) + + (goto-nw!) + (do ((x 0 (+ x 2))) + ((> x (max-x)) 0) + (set-color! (remainder (/ x 2) (max-color))) + (draw-to x (max-y)) + ) + (do ((y (+ (max-y) 1) (- y 2))) + ((< y 0) 0) + (set-color! (remainder (/ y 2) (max-color))) + (draw-to (max-x) y) + ) + + (display "testing set-dot!") (newline) + (clear-graphics!) + (do ((x 0 (+ x 1))) + ((= x 100) 0) + (set-dot! (+ (random (max-x)) 1) (+ (random (max-y)) 1) + (+ (random (max-color)) 1)) + ) + + (display "testing draw with turn-to!") (newline) + (clear-graphics!) + (goto-center!) + (do ((x 0 (+ x 1))) + ((= x 100) 0) + (set-color! (+ (random (max-color)) 1)) + (turn-to! (random 360)) + (draw (random 50)) + ) + + (display "testing draw with turn-right") (newline) + (clear-graphics!) + (goto-center!) + (do ((x 0 (+ x 1))) + ((= x 100) 0) + (set-color! (+ (random (max-color)) 1)) + (turn-right (random 90)) + (draw (random 50)) + ) + + (display "testing draw with turn-left") (newline) + (clear-graphics!) + (goto-center!) + (do ((x 0 (+ x 1))) + ((= x 100) 0) + (set-color! (+ (random (max-color)) 1)) + (turn-left (random 90)) + (draw (random 50)) + ) + + (text-mode!) +) + @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -130,4 +130,5 @@ SCM gsubr_apply(args) void init_gsubr() { f_gsubr_apply = make_subr(s_gsubr_apply, tc7_lsubr, gsubr_apply); + add_feature("generalized-c-arguments"); } diff --git a/hobbit.info b/hobbit.info new file mode 100644 index 0000000..9e0c0a9 --- /dev/null +++ b/hobbit.info @@ -0,0 +1,1952 @@ +This is hobbit.info, produced by makeinfo version 4.0 from hobbit.texi. + +INFO-DIR-SECTION The Algorithmic Language Scheme +START-INFO-DIR-ENTRY +* hobbit: (hobbit). SCM Compiler. +END-INFO-DIR-ENTRY + + +File: hobbit.info, Node: Top, Next: Introduction, Prev: (dir), Up: (dir) + +Hobbit is an optimizing R4RS-Scheme to C compiler written by Tanel +Tammet. + +* Menu: + +* Introduction:: +* Compiling with Hobbit:: +* The Language Compiled:: +* Performance of Compiled Code:: +* Principles of Compilation:: +* About Hobbit:: + +Copyright (C) 1990-1999, 2002 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation +approved by the author. + + +File: hobbit.info, Node: Introduction, Next: Compiling with Hobbit, Prev: Top, Up: Top + +Introduction +************ + +Hobbit is a small optimizing scheme-to-C compiler written in Report 4 +scheme and intended for use together with the SCM scheme interpreter of +A. Jaffer. Hobbit compiles full Report 4 scheme, except that: + + * It does not fully conform to the requirement of being properly + tail-recursive: non-mutual tailrecursion is detected, but mutual + tailrecursion is not. + + * Macros from the Report 4 appendix are not supported (yet): only + the common-lisp-like defmacro is supported. + +Hobbit treats SCM files as a C library and provides integration of +compiled procedures and variables with the SCM interpreter as new +primitives. + +Hobbit compiles scheme files to C files and does not provide anything +else by itself (eg. calling the C compiler, dynamic loading). Such +niceties are described in the next chapter *Note Compiling And +Linking::. + +Hobbit (derived from hobbit5x) is now part of the SCM Scheme +implementation. The most recent information about SCM can be found on +SCM's "WWW" home page: + + <http://swissnet.ai.mit.edu/~jaffer/SCM.html> + +Hobbit4d has also been ported to the Guile Scheme implementation: + + <http://www.gnu.org/software/guile/anon-cvs.html> + + +File: hobbit.info, Node: Compiling with Hobbit, Next: The Language Compiled, Prev: Introduction, Up: Top + +Compiling with Hobbit +********************* + +* Menu: + +* Compiling And Linking:: +* Error Detection:: +* Hobbit Options:: +* CC Optimizations:: + + +File: hobbit.info, Node: Compiling And Linking, Next: Error Detection, Prev: Compiling with Hobbit, Up: Compiling with Hobbit + +Compiling And Linking +===================== + +`(require 'compile)' + + - Function: hobbit name1.scm name2.scm ... + Invokes the HOBBIT compiler to translate Scheme files `NAME1.scm', + `NAME2.scm', ... to C files `NAME1.c' and `NAME1.h'. + + - Function: compile-file name1.scm name2.scm ... + Compiles the HOBBIT translation of NAME1.scm, NAME2.scm, ... to a + dynamically linkable object file NAME1<object-suffix>, where + <object-suffix> is the object file suffix for your computer (for + instance, `.so'). NAME1.scm must be in the current directory; + NAME2.scm, ... may be in other directories. + + cd ~/scm/ + scm -rcompile -e'(compile-file "example.scm")' + + Starting to read example.scm + + Generic (slow) arithmetic assumed: 1.0e-3 found. + + ** Pass 1 completed ** + ** Pass 2 completed ** + ** Pass 3 completed ** + ** Pass 4 completed ** + ** Pass 5 completed ** + ** Pass 6 completed ** + + C source file example.c is built. + C header file example.h is built. + + These top level higher order procedures are not clonable (slow): + (nonkeyword_make-promise map-streams generate-vector runge-kutta-4) + These top level procedures create non-liftable closures (slow): + (nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system) + + ; Scheme (linux) script created by SLIB/batch Sun Apr 7 22:49:49 2002 + ; ================ Write file with C defines + (delete-file "scmflags.h") + (call-with-output-file + "scmflags.h" + (lambda (fp) + (for-each + (lambda (string) (write-line string fp)) + '("#define IMPLINIT \"Init5d6.scm\"" + "#define BIGNUMS" + "#define FLOATS" + "#define ARRAYS" + "#define DLL")))) + ; ================ Compile C source files + (system "gcc -O2 -fpic -c -I/usr/local/lib/scm/ example.c") + (system "gcc -shared -o example.so example.o -lm -lc") + (delete-file "example.o") + ; ================ Link C object files + (delete-file "slibcat") + + Compilation finished at Sun Apr 7 22:49:50 + + - Function: compile->executable exename name1.scm name2.scm ... + Compiles and links the HOBBIT translation of NAME1.scm, NAME2.scm, + ... to a SCM executable named EXENAME. NAME1.scm must be in the + current directory; NAME2.scm, ... may be in other directories. + + cd ~/scm/ + scm -rcompile -e'(compile->executable "exscm" "example.scm")' + + Starting to read example.scm + + Generic (slow) arithmetic assumed: 1.0e-3 found. + + ** Pass 1 completed ** + ** Pass 2 completed ** + ** Pass 3 completed ** + ** Pass 4 completed ** + ** Pass 5 completed ** + ** Pass 6 completed ** + + C source file example.c is built. + C header file example.h is built. + + These top level higher order procedures are not clonable (slow): + (nonkeyword_make-promise map-streams generate-vector runge-kutta-4) + These top level procedures create non-liftable closures (slow): + (nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system) + + ; Scheme (linux) script created by SLIB/batch Sun Apr 7 22:46:31 2002 + ; ================ Write file with C defines + (delete-file "scmflags.h") + (call-with-output-file + "scmflags.h" + (lambda (fp) + (for-each + (lambda (string) (write-line string fp)) + '("#define IMPLINIT \"Init5d6.scm\"" + "#define COMPILED_INITS init_example();" + "#define CCLO" + "#define FLOATS")))) + ; ================ Compile C source files + (system "gcc -O2 -c continue.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c example.c scm.c") + ; ================ Link C object files + (system "gcc -rdynamic -o exscm continue.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o example.o scm.o -L/usr/local/lib/scm/ -lm -lc") + + Compilation finished at Sun Apr 7 22:46:44 + +_Note Bene:_ `#define CCLO' must be present in `scmfig.h'. + +In order to see calls to the C compiler and linker, do + + (verbose 3) + +before calling these functions. + + +File: hobbit.info, Node: Error Detection, Next: Hobbit Options, Prev: Compiling And Linking, Up: Compiling with Hobbit + +Error Detection +=============== + +Error detection during compilation is minimal. In case your scheme code +is syntactically incorrect, hobbit may crash with no sensible error +messages or it may produce incorrect C code. + +Hobbit does not insert any type-checking code into the C output it +produces. Eg, if a hobbit-compiled program applies `car' to a number, +the program will probably crash with no sensible error messages. + +Thus it is strongly suggested to compile only throughly debugged scheme +code. + +Alternatively, it is possible to compile all the primitives into calls +to the SCM procedures doing type-checking. Hobbit will do this if you +tell it to assume that all the primitives may be redefined. Put + + (define compile-all-proc-redefined #t) + +anywhere in top level of your scheme code to achieve this. + +_Note Bene:_ The compiled code using + + (define compile-all-proc-redefined #t) + +will typically be much slower than one produced without using + + (define compile-all-proc-redefined #t). + +All errors caught by hobbit will generate an error message + + COMPILATION ERROR: + <description of the error> + +and hobbit will immediately halt compilation. + + +File: hobbit.info, Node: Hobbit Options, Next: CC Optimizations, Prev: Error Detection, Up: Compiling with Hobbit + +Hobbit Options +============== + + 1. Selecting the type of arithmetics. + + By default hobbit assumes that only immediate (ie small, up to 30 + bits) integers are used. It will automatically assume general + arithmetics in case it finds any non-immediate numbers like 1.2 or + 10000000000000 or real-only procedures like $sin anywhere in the + source. + + Another way to make Hobbit assume that generic arithmetic supported + by SCM (ie exact and/or inexact reals, bignums) is also used, is to + put the following line somewhere in your scheme source file: + + (define compile-allnumbers T) + + where T is arbitrary. + + In that case all the arithmetic primitives in all the given source + files will be assumed to be generic. This will make operations + with immediate integers much slower. You can use the special + immediate-integer-only forms of arithmetic procedures to recover: + + %negative? %number? %> %>= %= %<= %< + %positive? %zero? %eqv? %+ %- %* %/ + + See *Note The Language Compiled::. + + 2. Redefinition of procedures. + + By default hobbit assumes that neither primitives nor compiled + procedures are redefined, neither before the compiled program is + initialized, during its work or later via the interpreter. + + Hobbit checks the compiled source and whenever some variable bar is + defined as a procedure, but is later redefined, or set! is applied + to bar, then hobbit assumes thas this particular variable bar is + redefinable. bar may be a primitive (eg `car') or a name of a + compiled procedure. + + _Note Bene:_ According to the Report 4 it is NOT allowed to use + scheme keywords as variables (you may redefine these as macros + defined by defmacro, though): + + => and begin case cond define delay do else if lambda + let let letrec or quasiquote quote set! unquote unquote-splicing + + If you want to be able to redefine some procedures, eg. `+' and + `baz', then put both + + (set! + +) + (set! baz baz) + + somewhere into your file. + + As a consequence hobbit will generate code for `+' and `baz' using + the run-time values of these variables. This is generally much + slower than using non-redefined `+' and `baz' (especially for `+'). + + If you want to be able to redefine all the procedures, both + primitives (eg `car') and the compiled procedures, then put the + following into the compiled file: + + (define compile-all-proc-redefined T) + + where T is arbitrary. + + If you want to be able to redefine all the compiled procedures, + but not the scheme primitives, then put the following into the + compiled file: + + (define compile-new-proc-redefined T) + + where T is arbitrary. + + Again, remember that redefinable procedures will be typically much + slower than non-redefinable procedures. + + 3. Inlined variables and procedures. + + You may inline top-level-defined variables and procedures. Notice + that inlining is DIFFERENT for variables and procedures! + + NEVER inline variables or procedures which are set! or redefined + anywhere in you program: this will produce wrong code. + + * You may declare certain top-level defined variables to be + inlined. For example, if the following variable foo is + declared to be inlined + + (define foo 100) + + then `foo' will be everywhere replaced by `100'. + + To declare some variables foo and bar to be inlined, put a + following definition anywhere into your file: + + (define compile-inline-vars '(foo bar)) + + Usually it makes sense to inline only these variables whose value + is either a small integer, character or a boolean. + + _Note Bene:_ Do not use this kind of inlining for inlining + procedures! Use the following for procedures: + + * You may declare certain procedures to be inlined. For + example, if the following foo is declared to be inlined + + (define (foo x) (+ x 2)) + + then any call + + (foo SOMETHING) + + will be replaced by + + (+ SOMETHING 2) + + Inlining is NOT safe for variable clashes - in other words, it is + not "hygienic". + + Inlining is NOT safe for recursive procedures - if the set of + inlined procedures contains either immediate or mutual (foo calling + bar, bar calling foo) recursion, the compiler will not terminate. + To turn off full inlining (harmful for recursive funs), change the + definition of the *full-inlining-flag* in the section "compiler + options" to the value #f instead of #t. + + To declare some procedures foo and bar to be inlined, put a + following definition anywhere into your file: + + (define compile-inline '(foo bar)) + + 4. Speeding up vectors: + + Put + + (define compile-stable-vectors '(baz foo)) + + into your file to declare that baz and foo are vector names + defined once on the top level, and set! is never applied to them + (vector-set! is, of course, allowed). This speeds up vector + reference to those vectors by precomputing their location. + + 5. Speeding up and hiding certain global variables: + + Put + + (define compile-uninterned-variables '(bazvar foovar)) + + into your file to declare that bazvar and foovar are defined on + the top level and they do always have an immediate value, ie a + boolean, immediate (30-bit) integer or a character. Then bazvar + and foovar will NOT be accessible from the interpreter. They'll + be compiled directly into static C vars and used without an extra + C *-operation prefixed to other global scheme variables. + + 6. Intermediate files + + To see the output of compiler passes, change the following + definition in `hobbit.scm'. + + (define *build-intermediate-files* #f) + + to: + + (define *build-intermediate-files* #t) + + 7. Name clashes + + It may happen that several originally different scheme variable + names are represented by one and the same C variable. This will + happen, for example, if you have separate variables a-1 and a_1. + + If such (or any other) name clashes occur you may need to change + some control variables in the first sections of `hobbit.scm' (up + to the section "global variable defs") or just rename some + variables in your scheme program. + + 8. Other options + + See various control variables in the first sections of `hobbit.scm' + (up to section "global variable defs"). + + +File: hobbit.info, Node: CC Optimizations, Prev: Hobbit Options, Up: Compiling with Hobbit + +CC Optimizations +================ + +When using the C compiler to compile the C code output by hobbit, always +use strong optimizations (eg. `cc -xO3' for cc on Sun, `gcc -O2' or +`gcc -O3' for gcc). Hobbit does not attempt to do optimizations of the +kind we anticipate from the C compiler, therefore it often makes a +serious difference whether the C compiler is run with a strong +optimization flag or not. + +For the final and fast version of your program you may want to first +recompile the whole scm (scmlit for the version scm4e2) using the +`-DRECKLESS' flag suppressing error checking: the hobbit-compiled code +uses some SCM primitives in the compiled files with the suffix .o, and +a number of these primitives become faster when error checking is +disabled by `-DRECKLESS'. Notice that hobbit never inserts error +checking into the code it produces. + + +File: hobbit.info, Node: The Language Compiled, Next: Performance of Compiled Code, Prev: Compiling with Hobbit, Up: Top + +The Language Compiled +********************* + +Calls to `load' or `require' occurring at the top level of a file being +compiled are ignored. Calls to `load' or `require' within a procedure +are compiled to call (interpreted) `load' or `require' as appropriate. + +Several SCM and SLIB extensions to the Scheme report are recognized by +hobbit as Scheme primitives. + +* Menu: + +* Macros:: +* SCM Primitive Procedures:: +* SLIB Logical Procedures:: +* Fast Integer Calculations:: +* Force and Delay:: +* Suggestions for writing fast code:: + + +File: hobbit.info, Node: Macros, Next: SCM Primitive Procedures, Prev: The Language Compiled, Up: The Language Compiled + +Macros +====== + +The Common-lisp style defmacro implemented in SCM is recognized and +procedures defined by defmacro are expanded during compilation. + +_Note Bene:_ any macro used in a compiled file must be also defined in +one of the compiled files. + +`#.<EXPRESSION>' is read as the object resulting from the evaluation of +<EXPRESSION>. The calculation is performed during compile time. Thus +<EXPRESSION> must not contain variables defined or set! in the compiled +file. + + +File: hobbit.info, Node: SCM Primitive Procedures, Next: SLIB Logical Procedures, Prev: Macros, Up: The Language Compiled + +SCM Primitive Procedures +======================== + +Real-only versions of transcedental procedures (warning: these +procedures are not compiled directly into the corresponding C library +procedures, but a combination of internal SCM procedures, guaranteeing +exact correspondence with the SCM interpreter while hindering the +speed): + + $sqrt $abs $exp $log $sin $cos $tan $asin $acos + $atan $sinh $cosh $tanh $asinh $acosh $atanh $expt + +_Note Bene:_ These procedures are compiled to faster code than the +corresponding generic versions sqrt, abs, ... expt. + +A selection of other extra primitives in SCM is also recognized as +primitives. eg. get-internal-run-time, quit, abort, restart, chdir, +delete-file, rename-file. + + +File: hobbit.info, Node: SLIB Logical Procedures, Next: Fast Integer Calculations, Prev: SCM Primitive Procedures, Up: The Language Compiled + +SLIB Logical Procedures +======================= + +The following bitwise procedures in the scheme library file +`logical.scm' are compiled directly to fast C operations on immediate +integers (small 30-bit integers) (Scheme library funs in the upper row, +C ops below): + + logand logior logxor lognot logsleft logsright + & | ^ ~ << >> + +The following alternative names logical:logand, logical:logior, +logical:logxor, logical:lognot, ash, logical:ash are compiled for the +generic case, not immediate-integers-only and are thus much slower. + +Notice that the procedures logsleft, logsright are NOT in the the +library file `logical.scm:' the universal procedure ash is instead. +Procedures ash, logcount, integer-length, integer-expt, bit-extract, +ipow-by-squaring, logical:ash, logical:logcount, logical:integer-length, +logical:integer-expt, logical:bit-extract, logical:ipow-by-squaring, in +`logical.scm' are not primtives and they are all compiled into calls to +interpreted code. + +logsleft and logsright are defined for non-compiled use in the file +`scmhob.scm' included in the SCM distribution. + + +File: hobbit.info, Node: Fast Integer Calculations, Next: Force and Delay, Prev: SLIB Logical Procedures, Up: The Language Compiled + +Fast Integer Calculations +========================= + +The following primitives are for immediate (30-bit) integer-only +arithmetics. The are compiled directly into the corresponding C +operations plus some bitshifts if necessary. They are good for speed in +case the compiled program uses BOTH generic arithmetics (reals, bignums) +and immediate (30-bit) integer arithmetics. These procedures are much +faster than corresponding generic procedures taking also reals and +bignums. There is no point in using these unless the program as a whole +is compiled using generic arithmetics, since otherwise all the +arithmetics procedures are compiled directly into corresponding C +operations anyway. + +_Note Bene:_ These primitives are NOT defined in SCM or its libraries. +For non-compiled use they are defined in the file `scmhob.scm' included +in the SCM distribution. + + %negative? %number? %> %>= %= %<= %< + %positive? %zero? %eqv? %+ %- %* %/ + + +File: hobbit.info, Node: Force and Delay, Next: Suggestions for writing fast code, Prev: Fast Integer Calculations, Up: The Language Compiled + +Force and Delay +=============== + +The nonessential procedure `force' and syntax `delay' are implemented +exactly as suggested in the report 4. This implementation deviates +internally from the implementation of `force' and `delay' in the SCM +interpeter, thus it is incorrect to pass a promise created by `delay' +in the compiled code to the `force' used by interpreter, and vice-versa +for the promises created by the interpreter. + + +File: hobbit.info, Node: Suggestions for writing fast code, Prev: Force and Delay, Up: The Language Compiled + +Suggestions for writing fast code +================================= + +The following suggestions may help you to write well-optimizable and +fast code for the hobbit-scm combination. Roughly speaking, the main +points are: + + * minimizing consing and creation of new vectors and strings in + speed-critical parts, + + * minimizing the use of generic (non-integer) arithmetics in + speed-critical parts, + + * minimizing the usage of procedures as first-class objects (very + roughly speaking, explicit lambda-terms and call/cc) in + speed-critical parts, + + * using special options and fast-compiled primitives of the compiler. + +Here come the details. + + 1. Immediate arithmetics (ie using small, up to 30 bits integers) is + much faster than generic (reals and bignums) arithmetics. If you + have to use generic arithmetic in your program, then try to use + special immediate arithmetics operations `%=', `%<=', `%+', `%*', + ... for speed-critical parts of the program whenever possible. + + Also, if you use bitwise logical operations, try to use the + immediate-integer-only versions + + logand logior logxor lognot logsleft logsright + + and not `logical:logand' or `ash', for example. + + 2. Due to its inner stack-based architecture, the generic (not + escape-only) continuations are very slow in SCM. Thus they are + also slow in compiled code. Try to avoid continuations (calls to + the procedure call-with-current-continuation and calls to the + continuations it produces) in speed-critical parts. + + 3. In speed-critical parts of your program try to avoid using + procedures which are redefined or defined by set!: + + (set! bar +) + (set! f (lambda (x) (if (zero? x) 1 (* x (f (- x 1)))))) + + anywhere in the compiled program. Avoid using compiler flags + (*note Hobbit Options::): + + (define compile-all-proc-redefined T) + (define compile-new-proc-redefined T) + + 4. Do not use complicated higher-order procedures in speed-critical + parts. By "complicated" we mean "not clonable", where clonability + is defined in the following way (_Note Bene:_ the primitives `map' + and `for-each' are considered clonable and do not inflict a speed + penalty). + + A higher-order procedure (HOP for short) is defined as a procedure + with some of its formal arguments occuring in the procedure body in + a function position, that is, as a first element of a list. Such + an argument is called a "higher-order argument". + + A HOP `bar' is clonable iff it satisfies the following four + conditions: + + 1. `bar' is defined as + + (define bar (lambda ...)) + + or + + (define (bar ...) ...) + + on top level and bar is not redefined anywhere. + + 2. the name `bar' occurs inside the body of bar only in a + function position and not inside an internal lambda-term. + + 3. Let f be a higher-order argument of bar. Any occurrence of f + in bar has one of the following two forms: + + * f occurs in a function position, + + * f is passed as an argument to bar and in the call it + occurs in the same position as in the argument list. + + 4. Let f be a higher-order argument of bar. f does not occur + inside a lambda-term occurring in bar. + + Examples: + + If `member-if' is defined on top level and is not redefined + anywhere, then `member-if' is a clonable HOP: + + (define (member-if fn lst) + (if (fn (car lst)) + lst + (member-if fn (cdr lst)) )) + + member-if-not is not a clonable HOP (fn occurs in a + lambdaterm): + + (define (member-if-not fn lst) + (member (lambda (x) (not (fn x))) lst) ) + + show-f is not a clonable HOP (fn occurs in a non-function + position in (display fn)): + + (define (show-f fn x) + (set! x (fn x)) + (display fn) + x) + + 5. In speed-critical parts avoid using procedures which return + procedures. + + Eg, a procedure + + (define plus + (lambda (x) + (lambda (y) (+ y x)) )) + + returns a procedure. + + 6. A generalisation of the previous case 5: + + In speed-critical parts avoid using lambda-terms except in + non-set! function definitions like + + (define foo (lambda ...)), + (let ((x 1) (f (lambda ...))) ...) + (let* ((x 1) (f (lambda ...))) ...) + (let name ((x 1) (f (lambda ...))) ...) + (letrec ((f (lambda ...)) (g (lambda ...))) ...) + + or as arguments to clonable HOP-s or primitives map and + for-each, like + + (let ((x 0)) (map (lambda (y) (set! x (+ 1 x)) (cons x y)) LIST)) + (member-if (lambda (x) (< x 0)) LIST) + + where member-if is a clonable HOP. + + Also, avoid using variables with a procedural value anywhere + except in a function position (first element of a list) or as + an argument to a clonable HOP, map or for-each. + + Lambda-terms conforming to the current point are said to be + liftable. + + Examples: + + (define (bar x) (let ((f car)) (f (f x)))) + + has `car' in a non-function and non-HOP-argument position in + `(f car)', thus it is slower than + + (define (bar x) (let ((f 1)) (car (car x)))) + + Similarly, + + (define (bar y z w) + (let ((f (lambda (x) (+ x y)))) + (set! w f) + (cons (f (car z)) + (map f z) ))) + + has `f' occurring in a non-function position in `(set! w f)', + thus the lambda-term `(lambda (x) (+ x y))' is not liftable + and the upper `bar' is thus slower than the following + equivalent `bar' with a liftable inner lambda-term: + + (define (bar y z w) + (let ((f (lambda (x) (+ x y)))) + (set! w 0) + (cons (f (car z)) + (map f z) ))) + + Using a procedure bar defined as + + (define bar (let ((x 1)) (lambda (y) (set! x y) (+ x y)))) + + is slower than using a procedure bar defined as + + (define *bar-x* 1) + (define bar (lambda (y) (set! *bar-x* y) (+ *bar-x* y))) + + since the former definition contains a non-liftable + lambda-term. + + 7. Try to minimize the amount of consing in the speed-critical + program fragments, that is, a number of applications of cons, + list, map, quasiquote (`) and vector->list during the time + program is running. `cons' (called also by `list', `map' and + `quasiquote') is translated into a C call to an internal cons + procedure of the SCM interpreter. Excessive consing also + means that the garbage collection happens more often. Do + `(verbose 3)' to see the amount of time used by garbage + collection while your program is running. + + Try to minimize the amount of creating new vectors, strings + and symbols in the speed-critical program frgaments, that is, + a number of applications of make-vector, vector, list->vector, + make-string, string-append, *->string, string->symbol. + Creating such objects takes typically much more time than + consing. + + 8. The Scheme iteration construction `do' is compiled directly + into the C iteration construction `for'. We can expect that + the C compiler has some knowledge about `for' in the + optimization stage, thus it is probably faster to use `do' + for iteration than non-mutual tailrecursion (which is + recognized by hobbit as such and is compiled into a jump to a + beginning of a procedure) and certainly much faster than + non-tail-recursion or mutual tailrecursion (the latter is not + recognized by hobbit as such). + + 9. Declare small nonrecursive programs which do not contain + let-s or lambdaterms as being inlinable. + + Declare globally defined variables which are never set! or + redefined and whose value is a small integer, character or a + boolean, as being inlinable. *Note Hobbit Options::. + + 10. If possible, declare vectors as being stable. *Note Speeding + up vectors: Hobbit Options. This gives a minor improvement + in speed. + + 11. If possible, declare critical global vars as being uninterned. + *Note Speeding up and hiding certain global variables: Hobbit + Options. This gives a minor improvement in speed. Declare + the global variables which are never set! and have an + (unchanged) numeric or boolean value as being inlined. *Note + Hobbit Options::. + + In addition, take the following into account: + + * When using the C compiler to compile the C code output by + hobbit, always use strong optimizations (eg. `cc -xO3' for cc + on Sun, `gcc -O2' or `gcc -O3' for gcc). Hobbit does not + attempt to do optimizations of the kind we anticipate from + the C compiler, therefore it often makes a big difference if + the C compiler is run with a strong optimization flag or not. + + * hobbit does not give proper tailrecursion behaviour for mutual + tailrecursion (foo calling bar, bar calling foo + tailrecursively). + + Hobbit guarantees proper tailrecursive behaviour for + non-mutual tailrecursion (foo calling foo tailrecursively), + provided that foo is not redefined anywhere and that foo is + not a local function which occurs also in a non-function and + non-clonable-HOP-argument position (i.e. cases 3 and 6 above). + + +File: hobbit.info, Node: Performance of Compiled Code, Next: Principles of Compilation, Prev: The Language Compiled, Up: Top + +Performance of Compiled Code +**************************** + +* Menu: + +* Gain in Speed:: +* Benchmarks:: +* Benchmark Sources:: + + +File: hobbit.info, Node: Gain in Speed, Next: Benchmarks, Prev: Performance of Compiled Code, Up: Performance of Compiled Code + +Gain in Speed +============= + +The author has so far compiled and tested a number of large programs +(theorem provers for various logics and hobbit itself). + +The speedup for the provers was between 25 and 40 times for various +provable formulas. Comparison was made between the provers being +interpreted and compiled with `gcc -O2 -DRECKLESS' on Sparcstation ELC +in both cases. + +The provers were written with care to make the compiled version run +fast. They do not perform excessive consing and they perform very +little arithmetic. + +According to experiments made by A. Jaffer, the compiled form of the +example program `pi.scm' was approximately 11 times faster than the +interpreted form. + +As a comparison, his hand-coded C program for the same algorithm of +computing pi was about 12 times faster than the interpreted form. +`pi.scm' spends most of of its time in immediate arithmetics, +vector-ref and vector-set!. + +P. Kelloma"ki has reported a 20-fold speedup for his generic scheme +debugger. T. Moore has reported a 16-fold speedup for a large +gate-level IC optimizer. + +Self-compilation speeds Hobbit up only ca 10 times. + +However, there are examples where the code compiled by hobbit runs +actually slower than the same code running under interpreter: this may +happen in case the speed of the code relies on non-liftable closures +and proper mutual tailrecursion. See for example the closure-intensive +benchmark CPSTAK in the following table. + + +File: hobbit.info, Node: Benchmarks, Next: Benchmark Sources, Prev: Gain in Speed, Up: Performance of Compiled Code + +Benchmarks +========== + +We will present a table with the performance of three scheme systems on +a number of benchmarks: interpreted SCM, byte-compiled VSCM and +hobbit-compiled code. The upper 13 benchmarks of the table are the +famous Gabriel benchmarks (originally written for lisp) modified for +scheme by Will Clinger. The lower five benchmarks of the table are +proposed by other people. "Selfcompile" is the self-compile time of +Hobbit. + +Hobbit performs well on most of the benchmarks except CPSTAK and CTAK: +CPSTAK is a closure-intensive tailrecursive benchmark and CTAK is a +continuations-intensive benchmark. Hobbit performs extremely well on +these benchmarks which essentially satisfy the criterias for +well-optimizable code outlined in the section 6 above. + +FFT is real-arithmetic-intensive. + +All times are in seconds. + +SCM 4c0(U) and 1.1.5*(U) (the latter is the newest version of VSCM) are +compiled and run by Matthias Blume on a DecStation 5000 (Ultrix). VSCM +is a bytecode-compiler using continuation-passing style, and is well +optimized for continuations and closures. + +SCM 4e2(S) and Hobbit4b(S) compiled (with `cc -xO3') and run by Tanel +Tammet on a Sun SS10 (lips.cs.chalmers.se). Hobbit is a Scheme-to-C +compiler for SCM, the code it produces does not do any checking. SCM +and hobbit are not optimized for continuations. Hobbit is not +optimized for closures and proper mutual tailrecursion. + +SCM and Hobbit benchmarks were run giving ca 8 MB of free heap space +before each test. + + Benchmark |SCM 4c0(U) 1.1.5*(U)| SCM 4e2(S) Hobbit4b(S) + ----------------|------------------------------------------------ + Deriv | 3.40 3.86 | 2.9 0.18 + Div-iter | 3.45 2.12 | 2.6 0.083 + Div-rec | 3.45 2.55 | 3.5 0.42 + TAK | 1.81 1.71 | 1.4 0.018 + TAKL |14.50 11.32 | 13.8(1.8 in gc) 0.13 + TAKR | 2.20 1.64 | 1.7 1.5 0.018 + Destruct | ? ? | 7.4(1.8 in gc) 0.18 + Boyer | ? ? | 27.(3.8 in gc) 1.9 + CPSTAK | 2.72 2.64 | 2.0 1.92 3.46(2.83 in gc) + CTAK |31.0 4.11 | memory memory + CTAK(7 6 1) | ? ? | 0.83 0.74 + FFT |12.45 15.7 | 11.4 10.8 1.0 + Puzzle | 0.28 0.41 | 0.46(0.22 gc) 0.03 + ---------------------------------------------------------------- + (recfib 25) | ? ? | 4.1 0.079 + (recfib 30) | ? ? | 55. (10.in gc) 0.87 + (pi 300 3) | ? ? | 7.4 0.46 + (hanoi 15) | ? ? | 0.68 0.007 + (hanoi 20) | ? ? | 31. (9. in gc) 0.2 + ---------------------------------------------------------------- + + +File: hobbit.info, Node: Benchmark Sources, Prev: Benchmarks, Up: Performance of Compiled Code + +Benchmark Sources +================= + +A selection of (smaller) benchmark sources +------------------------------------------ + +* Menu: + +* Destruct:: +* Recfib:: +* div-iter and div-rec:: +* Hanoi:: +* Tak:: +* Ctak:: +* Takl:: +* Cpstak:: +* Pi:: + + +File: hobbit.info, Node: Destruct, Next: Recfib, Prev: Benchmark Sources, Up: Benchmark Sources + +Destruct +-------- + + ;;;; Destructive operation benchmark + (define (destructive n m) + (let ((l (do ((i 10 (- i 1)) + (a '() (cons '() a))) + ((= i 0) a)))) + (do ((i n (- i 1))) + ((= i 0)) + (if (null? (car l)) + (do ((l l (cdr l))) + ((null? l)) + (or (car l) (set-car! l (cons '() '()))) + (append! (car l) (do ((j m (- j 1)) + (a '() (cons '() a))) + ((= j 0) a)))) + (do ((l1 l (cdr l1)) + (l2 (cdr l) (cdr l2))) + ((null? l2)) + (set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1)) + (a (car l2) (cdr a))) + ((zero? j) a) + (set-car! a i)) + (let ((n (quotient (length (car l1)) 2))) + (cond ((= n 0) (set-car! l1 '()) (car l1)) + (else (do ((j n (- j 1)) + (a (car l1) (cdr a))) + ((= j 1) + (let ((x (cdr a))) + (set-cdr! a '()) x)) + (set-car! a i))))))))))) + ;; call: (destructive 600 50) + + +File: hobbit.info, Node: Recfib, Next: div-iter and div-rec, Prev: Destruct, Up: Benchmark Sources + +Recfib +------ + + (define (recfib x) + (if (< x 2) + x + (+ (recfib (- x 1)) + (recfib (- x 2))))) + + +File: hobbit.info, Node: div-iter and div-rec, Next: Hanoi, Prev: Recfib, Up: Benchmark Sources + +div-iter and div-rec +-------------------- + + ;;;; Recursive and iterative benchmark divides by 2 using lists of ()'s. + (define (create-n n) + (do ((n n (- n 1)) + (a '() (cons '() a))) + ((= n 0) a))) + (define *ll* (create-n 200)) + (define (iterative-div2 l) + (do ((l l (cddr l)) + (a '() (cons (car l) a))) + ((null? l) a))) + (define (recursive-div2 l) + (cond ((null? l) '()) + (else (cons (car l) (recursive-div2 (cddr l)))))) + (define (test-1 l) + (do ((i 300 (- i 1))) ((= i 0)) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l))) + (define (test-2 l) + (do ((i 300 (- i 1))) ((= i 0)) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l))) + ;; for the iterative test call: (test-1 *ll*) + ;; for the recursive test call: (test-2 *ll*) + + +File: hobbit.info, Node: Hanoi, Next: Tak, Prev: div-iter and div-rec, Up: Benchmark Sources + +Hanoi +----- + + ;;; C optimiser should be able to remove the first recursive call to + ;;; move-them. But Solaris 2.4 cc, gcc 2.5.8, and hobbit don't. + (define (hanoi n) + (letrec ((move-them + (lambda (n from to helper) + (if (> n 1) + (begin + (move-them (- n 1) from helper to) + (move-them (- n 1) helper to from)))))) + (move-them n 0 1 2))) + + +File: hobbit.info, Node: Tak, Next: Ctak, Prev: Hanoi, Up: Benchmark Sources + +Tak +--- + + ;;;; A vanilla version of the TAKeuchi function + (define (tak x y z) + (if (not (< y x)) + z + (tak (tak (- x 1) y z) + (tak (- y 1) z x) + (tak (- z 1) x y)))) + ;; call: (tak 18 12 6) + + +File: hobbit.info, Node: Ctak, Next: Takl, Prev: Tak, Up: Benchmark Sources + +Ctak +---- + + ;;;; A version of the TAK function that uses continuations + (define (ctak x y z) + (call-with-current-continuation + (lambda (k) + (ctak-aux k x y z)))) + + (define (ctak-aux k x y z) + (cond ((not (< y x)) (k z)) + (else (call-with-current-continuation + (ctak-aux + k + (call-with-current-continuation + (lambda (k) (ctak-aux k (- x 1) y z))) + (call-with-current-continuation + (lambda (k) (ctak-aux k (- y 1) z x))) + (call-with-current-continuation + (lambda (k) (ctak-aux k (- z 1) x y)))))))) + + (define (id x) x) + + (define (mb-test r x y z) + (if (zero? r) + (ctak x y z) + (id (mb-test (- r 1) x y z)))) + ;;; call: (ctak 18 12 6) + + +File: hobbit.info, Node: Takl, Next: Cpstak, Prev: Ctak, Up: Benchmark Sources + +Takl +---- + + ;;;; The TAKeuchi function using lists as counters. + (define (listn n) + (if (not (= 0 n)) + (cons n (listn (- n 1))) + '())) + + (define l18 (listn 18)) + (define l12 (listn 12)) + (define l6 (listn 6)) + + (define (mas x y z) + (if (not (shorterp y x)) + z + (mas (mas (cdr x) y z) + (mas (cdr y) z x) + (mas (cdr z) x y)))) + + (define (shorterp x y) + (and (pair? y) (or (null? x) (shorterp (cdr x) (cdr y))))) + ;; call: (mas l18 l12 l6) + + +File: hobbit.info, Node: Cpstak, Next: Pi, Prev: Takl, Up: Benchmark Sources + +Cpstak +------ + + ;;;; A continuation-passing version of the TAK benchmark. + (define (cpstak x y z) + (define (tak x y z k) + (if (not (< y x)) + (k z) + (tak (- x 1) + y + z + (lambda (v1) + (tak (- y 1) + z + x + (lambda (v2) + (tak (- z 1) + x + y + (lambda (v3) + (tak v1 v2 v3 k))))))))) + (tak x y z (lambda (a) a))) + ;;; call: (cpstak 18 12 6) + + +File: hobbit.info, Node: Pi, Prev: Cpstak, Up: Benchmark Sources + +Pi +-- + + (define (pi n . args) + (let* ((d (car args)) + (r (do ((s 1 (* 10 s)) + (i 0 (+ 1 i))) + ((>= i d) s))) + (n (+ (quotient n d) 1)) + (m (quotient (* n d 3322) 1000)) + (a (make-vector (+ 1 m) 2))) + (vector-set! a m 4) + (do ((j 1 (+ 1 j)) + (q 0 0) + (b 2 (remainder q r))) + ((> j n)) + (do ((k m (- k 1))) + ((zero? k)) + (set! q (+ q (* (vector-ref a k) r))) + (let ((t (+ 1 (* 2 k)))) + (vector-set! a k (remainder q t)) + (set! q (* k (quotient q t))))) + (let ((s (number->string (+ b (quotient q r))))) + (do ((l (string-length s) (+ 1 l))) + ((>= l d) (display s)) + (display #\0))) + (if (zero? (modulo j 10)) (newline) (display #\ ))) + (newline))) + + +File: hobbit.info, Node: Principles of Compilation, Next: About Hobbit, Prev: Performance of Compiled Code, Up: Top + +Principles of Compilation +************************* + +* Menu: + +* Macro-Expansion and Analysis:: Pass 1 +* Building Closures:: Pass 2 +* Lambda-lifting:: Pass 3 +* Statement-lifting:: Pass 4 +* Higher-order Arglists:: Pass 5 +* Typing and Constants:: Pass 6 + + +File: hobbit.info, Node: Macro-Expansion and Analysis, Next: Building Closures, Prev: Principles of Compilation, Up: Principles of Compilation + +Expansion and Analysis +====================== + + 1. Macros defined by defmacro and all the quasiquotes are expanded + and compiled into equivalent form without macros and quasiquotes. + + For example, `(a , x) will be converted to (cons 'a (cons x '())). + + 2. Define-s with the nonessential syntax like + + (define (foo x) ...) + + are converted to defines with the essential syntax + + (define foo (lambda (x) ...)) + + Non-top-level defines are converted into equivalent letrec-s. + + 3. Variables are renamed to avoid name clashes, so that any local + variable may have a whole procedure as its scope. This renaming + also converts let-s to let*-s. Variables which do not introduce + potential name clashes are not renamed. For example, + + (define (foo x y) + (let ((x y) + (z x)) + (let* ((x (+ z x))) + x))) + + is converted to + + (define foo + (lambda (x y) + (let* ((x__1 y) + (z x) + (x__2 (+ z x__1))) + x__2))) + + 4. In case the set of procedures defined in one letrec is actually not + wholly mutually recursive (eg, f1 calls f2, but f2 does not call + f1, or there are three procedures, f1, f2, f3 so that f1 and f2 + are mutually recursive but f3 is not called from f1 or f2 and it + does not call them, etc), it is possible to minimize the number of + additional variables passed to procedures. + + Thus letrec-s are split into ordered chunks using dependency + analysis and topological sorting, to reduce the number of mutually + passed variables. Wherever possible, letrec-s are replaced by + let*-s inside these chunks. + + 5. Normalization is performed. This converts a majority of scheme + control procedures like cond, case, or, and into equivalent terms + using a small set of primitives. New variables may be introduced + in this phase. + + In case a procedure like or or and occurs in the place where its + value is treated as a boolean (eg. first argument of if), it is + converted into an analogous boolean-returning procedure, which + will finally be represented by an analogous C procedure (eg. || or + &&). + + Associative procedures are converted into structures of + corresponding nonassociative procedures. List is converted to a + structure of cons-s. + + Map and for-each with more than two arguments are converted into an + equivalent do-cycle. map-s and for-each-s with two arguments are + treated as if they were defined in the compiled file - the + definitions map1 and for-each1 are automatically included, if + needed. + + There is an option in `hobbit.scm' to make all map-s and + for-each-s be converted into equivalent do-loops, avoiding the use + of map1 and/or for-each1 altogether. + + 6. Code is analysed for determining which primitive names and + compiled procedure names are assumed to be redefinable. + + 7. Analysing HOP clonability: hobbit will find a list of clonable + HOP-s with information about higher-order arguments. + + Criterias for HOP clonability are given in the section 6.4. + + 8. Analysis of liftability: hobbit will determine which lambda-terms + have to be built as real closures (implemented as a vector where + the first element is a pointer to a function and the rest contain + values of environment variables or environment blocks of + surrounding code) and which lambda-terms are liftable. + + Liftability analysis follows the criterias given in section 6.5 and + 6.6. + + +File: hobbit.info, Node: Building Closures, Next: Lambda-lifting, Prev: Macro-Expansion and Analysis, Up: Principles of Compilation + +Building Closures +================= + +Here Hobbit produces code for creating real closures for all the +lambda-terms which are not marked as being liftable by the previous +liftability analysis. + +Global variables (eg x-glob) are translated as pointers (locations) to +SCM objects and used via a fetch: *x_glob (or a fetch macro +GLOBAL(x-glob) which translates to *x_glob). + +While producing closures hobbit tries to minimize the indirection +levels necessary. Generally a local variable x may have to be +translated to an element of a vector of local variables built in the +procedure creating x. If x occurs in a non-liftable closure, the whole +vector of local variables is passed to a closure. + +Such a translation using a local vector will only take place if either x +is set! inside a non-liftable lambda-term or x is a name of a +recursively defined non-liftable function, and the definition of x is +irregular. The definition of x is irregular if x is given the +non-liftable recursive value T by extra computation, eg as + + (set! x (let ((u 1)) (lambda (y) (display u) (x (+ u 1))))) + +and not as a simple lambdaterm: + + (set! x (lambda (y) (display x) (x (+ y 1)))) + +In all the other cases a local scheme variable x is translated directly +to a local C variable x having the type SCM (a 32-bit integer). If +such an x occurs in a non-liftable closure, then only its value is +passed to a closure via the closure-vector. In case the +directly-translated variable x is passed to a liftable lambda-term +where it is set!, then x is passed indirectly by using its address &x. +In the lifted lambda-term it is then accessed via *. + +If all the variables x1, ..., xn created in a procedure can be +translated directly as C variables, then the procedure does not create a +special vector for (a subset of) local variables. + +An application (foo ...) is generally translated to C by an internal +apply of the SCM interpreter: apply(GLOBAL(foo), ...). Using an +internal apply is much slower than using direct a C function call, +since: + + * there is an extra fetch by GLOBAL(foo), + + * internal apply performs some computations, + + * the arguments of foo are passed as a list constructed during + application: that is, there is a lot of expensive consing every + time foo is applied via an internal apply. + +However, in case foo is either a name of a non-redefined primitive or a +name of a non-redefined liftable procedure, the application is +translated to C directly without the extra layer of calling apply: +foo(...). + +Sometimes lambda-lifting generates the case that some variable x is +accessed not directly, but by *x. See the next section. + +Undefined procedures are assumed to be defined via interpreter and are +called using an internal apply. + + +File: hobbit.info, Node: Lambda-lifting, Next: Statement-lifting, Prev: Building Closures, Up: Principles of Compilation + +Lambda-lifting +============== + +When this pass starts, all the real (nonliftable) closures have been +translated to closure-creating code. The remaining lambda-terms are +all liftable. + +Lambda-lifting is performed. That is, all procedures defined inside +some other procedure (eg. in letrec) and unnamed lambda-terms are made +top-level procedure definitions. Any N variables not bound in such +procedures which were bound in the surrounding procedure are given as +extra N first parameters of the procedure, and whenever the procedure is +called, the values of these variables are given as extra N first +arguments. + +For example: + + (define foo + (lambda (x y) + (letrec ((bar (lambda (u) (+ u x)))) + (bar y) ))) + +is converted to + + (define foo + (lambda (x y) + (foo-fn1 x y) )) + + (define foo-fn1 + (lambda (x u) + (+ u x) )) + +The case of mutually recursive definitions in letrec needs special +treatment - all free variables in mutually recursive funs have, in +general, to be passed to each of those funs. For example, in + + (define (foo x y z i) + (letrec ((f1 (lambda (u) (if x (+ (f2 u) 1)))) + (f2 (lambda (v) (if (zero? v) 1 (f1 z)))) ) + (f2 i) )) + +the procedure f1 contains a free variable x and the procedure f2 +contains a free variable z. Lambda-lifted f1 and f2 must each get both +of these variables: + + (define (foo x y z i) + (foo-fn2 x z i) ) + + (define foo-fn1 + (lambda (x z u) (if x (+ (foo-fn2 x z u) 1))) ) + + (define foo-fn2 + (lambda (x z v) (if (zero? v) 1 (foo-fn1 x z z))) ) + +Recall that hobbit has already done dependency analysis and has split +the original letrec into smaller chunks according to this analysis: see +pass 1. + +Whenever the value of some free variable is modified by set! in the +procedure, this variable is passed by reference instead. This is not +directly possible in scheme, but it is possible in C. + + (define foo + (lambda (x y z) + (letrec ((bar (lambda (u) (set! z (+ u x z))))) + (bar y) + z))) + +is converted to incorrect scheme: + + (define foo + (lambda (x y z) + (foo-fn1 x (**c-adr** z) y) + z)) + + (define foo-fn1 + (lambda (x (**c-adr** z) u) + (set! (**c-fetch** z) (+ u x (**c-fetch** z))) )) + +The last two will finally be compiled into correct C as: + + SCM foo(x, y, z) + SCM x, y, z; + { + foo_fn1(x, &z, y); + return z; + } + + SCM foo_fn1(x, z, u) + SCM x, u; + SCM *z; + { + return (*z = (u + x) + *z); + } + + +File: hobbit.info, Node: Statement-lifting, Next: Higher-order Arglists, Prev: Lambda-lifting, Up: Principles of Compilation + +Statement-lifting +================= + +As the scheme do-construction is compiled into C for, but for cannot +occur in all places in C (it is a statement), then if the do in a +scheme procedure occurs in a place which will not be a statement in C, +the whole do-term is lifted out into a new top-level procedure +analogously to lambda-lifting. Any statement-lifted parts of some +procedure foo are called foo_auxN, where N is a number. + +The special C-ish procedure **return** is pushed into a scheme term as +far as possible to extend the scope of statements in the resulting C +program. For example, + + (define foo + (lambda (x y) + (if x (+ 1 y) (+ 2 y)) )) + +is converted to + + (define foo + (lambda (x y) + (if x (**return** (+ 1 y)) (**return** (+ 2 y))) )) + +Immediate tailrecursion (foo calling foo tailrecursively) is recognized +and converted into an assignment of new values to args and a jump to +the beginning of the procedure body. + + +File: hobbit.info, Node: Higher-order Arglists, Next: Typing and Constants, Prev: Statement-lifting, Up: Principles of Compilation + +Higher-order Arglists +===================== + +All procedures taking a list argument are converted into ordinary +non-list taking procedures and they are called with the list-making +calls inserted. For example, + + (define foo + (lambda (x . y) + (cons x (reverse y)) )) + +is converted to + + (define foo + (lambda (x y) + (cons x (reverse y)) )) + +and any call to foo will make a list for a variable y. For example, + + (foo 1 2 3) + +is converted to + + (foo 1 (cons 2 (cons 3 '()))). + +All higher-order procedure calls where an argument-term contains +unbound variables will generate a new instance (provided it has not +been created already) of this higher-order procedure, carrying the +right amount of free variables inside to right places. + +For example, if there is a following definition: + + (define (member-if fn lst) + (if (fn (car lst)) + lst + (member-if fn (cdr lst)) )) + +and a call + + (member-if (lambda (x) (eq? x y)) lst), + +a new instance of member-if is created (if an analogous one has not +been created before): + + (define (member-if_inst1 tmp fn lst) + (if (fn tmp (car lst)) + lst + (member-if_inst1 tmp fn (cdr lst)) )) + +and the call is converted to + + (member-if_inst1 y foo lst) + +and a top-level define + + (define (foo y x) (eq? x y)) + +In addition, if the higher-order procedure is to be exported, an +additional instance is created, which uses apply to call all +argument-procedures, assuming they are defined via interpreter. The +exportable higher-order procedure will have a name FUN_exporthof, where +FUN is the name of the original procedure. + + +File: hobbit.info, Node: Typing and Constants, Prev: Higher-order Arglists, Up: Principles of Compilation + +Typing and Constants +==================== + +All C<->Scheme conversions for immediate objects like numbers, booleans +and characters are introduced. Internal apply is used for undefined +procedures. Some optimizations are performed to decrease the amount of +C<->Scheme object conversions. + +All vector, pair and string constants are replaced by new variables. +These variables are instantiated to the right values by init_FOO*. + +Procedures foo which are to be exported (made accesible to the +interpreter), and which have an arity different from one of the +following five templates: x, (), (x), (x y), (x y z), are made +accessible via an additional procedure foo_wrapper taking a single list +argument. + +C Code Generation +----------------- + +More or less straightforward. + +The type conversion between C objects and immediate Scheme objects of +the type boolean, char and num is performed by macros. The scheme +object '() is represented by the macro object EOL. + +Intermediate files +------------------ + +Experiment yourself by defining: + + (define *build-intermediate-files* #t) + +instead of the default: + + (define *build-intermediate-files* #f). + + +File: hobbit.info, Node: About Hobbit, Prev: Principles of Compilation, Up: Top + +About Hobbit +************ + +* Menu: + +* The Aims of Developing Hobbit:: +* Manifest:: +* Author and Contributors:: +* Future Improvements:: +* Release History:: + + +File: hobbit.info, Node: The Aims of Developing Hobbit, Next: Manifest, Prev: About Hobbit, Up: About Hobbit + +The Aims of Developing Hobbit +============================= + + 1. Producing maximally fast C code from simple scheme code. + + By "simple" we mean code which does not rely on procedures + returning procedures (closures) and nontrivial forms of + higher-order procedures. All the latter are also compiled, but + the optimizations specially target simple code fragments. Hobbit + performs global optimization in order to locate such fragments. + + 2. Producing C code which would preserve as much original scheme code + structure as possible, to enable using the output C code by a + human programmer (eg. for introducing special optimizations + possible in C). Also, this will hopefully help the C compiler to + find better optimizations. + + +File: hobbit.info, Node: Manifest, Next: Author and Contributors, Prev: The Aims of Developing Hobbit, Up: About Hobbit + +Manifest +======== + +`hobbit.scm' the hobbit compiler. +`scmhob.scm' the file defining some additional procedures recognized + by hobbit as primitives. Use it with the interpreter + only. +`scmhob.h' the common headerfile for hobbit-compiled C files. +`hobbit.texi' documentation for hobbit. + + +File: hobbit.info, Node: Author and Contributors, Next: Future Improvements, Prev: Manifest, Up: About Hobbit + +Author and Contributors +======================= + + Tanel Tammet + Department of Computing Science + Chalmers University of Technology + University of Go"teborg + S-41296 Go"teborg Sweden + +A. Jaffer (jaffer @ alum.mit.edu), the author of SCM, has been of major +help with a number of suggestions and hacks, especially concerning the +interface between compiled code and the SCM interpreter. + +Several people have helped with suggestions and detailed bug reports, +e.g. David J. Fiander (davidf@mks.com), Gordon Oulsnam +(STCS8004@IRUCCVAX.UCC.IE), Pertti Kelloma"ki (pk@cs.tut.fi), Dominique +de Waleffe (ddw2@sunbim.be) Terry Moore (tmm@databook.com), Marshall +Abrams (ab2r@midway.uchicago.edu). Georgy K. Bronnikov +(goga@bronnikov.msk.su), Bernard Urban (Bernard.URBAN@meteo.fr), +Charlie Xiaoli Huang, Tom Lord (lord@cygnus.com), +NMICHAEL@us.oracle.com, Lee Iverson (leei@ai.sri.com), Burt Leavenworth +(EDLSOFT@aol.com). + + +File: hobbit.info, Node: Future Improvements, Next: Release History, Prev: Author and Contributors, Up: About Hobbit + +Future Improvements +=================== + + 1. Optimisations: + + * the calls to internal apply: we'd like to avoid the excessive + consing of always building the list of arguments. + + * speeding up the creation of a vector for assignable + closure-variables + + * several peephole optimisations. + + 2. Improve Variable creation and naming to avoid C function name + clashes. + + 3. Report 4 macros. + + 4. Better error-checking. + + 5. Better liftability analysis. + + 6. More tailrecursion recognition. + + 7. Better numeric optimizations. + + 8. Fast real-only arithmetics: $eqv, $=, $>, $+, $*, etc. + + +File: hobbit.info, Node: Release History, Prev: Future Improvements, Up: About Hobbit + +Release History +=============== + + [In February 2002, hobbit5x was integrated into the SCM + distribution. Changes since then are recorded in `scm/ChangeLog'.] + +hobbit4d: + * the incorrect translation of char>?, char-ci>?, char>=?, + char-ci>=? string>?, string-ci>?, string-ci>=?, string>=? + reported by Burt Leavenworth (EDLSOFT@aol.com) was fixed. + + * the name clash bug for new variables new_varN occurring in + non-liftable closures (reported by Lee Iverson + (leei@ai.sri.com)) was fixed. + + * the major COPYRIGHT change: differently from all the previous + versions of Hobbit, hobbit4d is Free Software. + +hobbit4c: + * a liftability-analysis bug for for-each and map reported by + Lee Iverson (leei@ai.sri.com) has been fixed. + + * The output C code does not contain the unnecessary ;-s on + separate lines any more. + +hobbit4b: + The following bugs have been fixed: + * Erroneous treatment of [ and ] inside symbols, reported by A. + Jaffer (jaffer @ alum.mit.edu). + + * A bug in the liftability analysis, reported by A. Jaffer + (jaffer @ alum.mit.edu). + + * A bug occurring in case arguments are evaluated right-to-left, + which happens with Hobbit compiled by gcc on Linux. Reported + and patched by George K. Bronnikov (goga@bronnikov.msk.su) + + * A closure-building bug sometimes leading to a serious loss of + efficiency (liftability not recognized), reported by + NMICHAEL@us.oracle.com. + + * A bug in the liftability analysis (non-liftable lambda-term + inside a liftable lambda-term) reported by Lee Iverson + (leei@ai.sri.com) + +hobbit4a: + Several bugs found in version4x are fixed. + +hobbit4x (not public): + * A major overhaul: Hobbit is now able to compile full scheme, + not just the fast liftable-clonable fragment. + + The optimizations done by the earlier versions are preserved. + + * Numerous bugs found in earlier versions have been fixed. + +hobbit3d: + bugs found in the version 3c are fixed. + +hobbit3c: + * the form + + (define foo (let ((x1 <t1>) ... (xn <tn>)) (lambda ...))) + + is now supported for all terms <ti> except procedures defined + in the compiled files. + + * macros are partially supported by doing a preprocessing pass + using the procedures pprint-filter-file and defmacro:expand* + defined in slib. + + * the file `scmhob.scm' defining hobbit-recognized nonstandard + procedures is created. + + * the documentation is improved (thanks go to Aubrey for + suggestions). + +hobbit3b: + * Aubrey fixed some problems with the version 3. + + * It is now OK to define procedures "by name" on top level. + + * It is now OK to apply "apply", etc to procedures defined in + the compiled file. Compiled procedures may now be passed to + procedures not defined but still called in the compiled files. + +hobbit3: + * Generic arithmetic supported by SCM (exact and inexact reals, + bignums) is made available. + + * The #. special syntactic form of SCM is made available. + + * Procedures with chars are compiled open-coded, making them + faster. + + * The bug concerning strings containing an embedded \nl char is + corrected (thanks to Terry Moore, (tmm@databook.com)). + + * The special declaration compile-stable-vectors for optimizing + vector access is introduced. + + * Source code may contain top-level computations, top-level + loads are ignored. + + * The bug causing "or" to (sometimes) lose tailrecursiveness is + corrected. + + * Hobbit now allows the following very special form: + + (define foo (let ((bar bar)) (lambda ...))) + + Notice `(bar bar)'. See the section 5 above. It will + produce wrong code if bar is redefined. + + There were several versions of the 2-series, like 2.x, which + were not made public. The changes introduced are present in + the version 3. + +hobbit2: + * The following bitwise procedures in the scheme library file + `logical.scm' are compiled directly to C (Scheme library funs + in the upper row, C ops below): + + logand logior logxor lognot logsleft logsright + & | ^ ~ << >> + + Notice that the procedures logsleft, logsright are NOT in the + the library file `logical.scm': the universal procedure ash + is instead. Procedures ash, logcount, integer-length, + integer-expt, bit-extract in `logical.scm' are not recognized + by hobbit. + +hobbit1a3 (not public): + * the letrec-sorting bug often resulting in not recognizing + procedures defined in letrec (or local defines) has been + corrected. + + * the primitives string and vector are now compiled correctly. + +hobbit1a2 (not public): + * any fixed arity procedure (including primitives) may be + passed to any higher-order procedure by name. Variable arity + procedures (eg primitives list, +, display and defined funs + like `(define (foo x . y) x)') must not be passed to new + defined higher-order funs. + + * some optimizations have been introduced for calls to map and + for-each. + + * (map list x y) bug has been corrected. + + * Corrected self-compilation name clash between call_cc and + call-cc. + +hobbit1a1 (not public): + * named let is supported. + + * the inlining bug is fixed: all procedures declared to be + inlined are fully inlined, except when the flag + *full-inlining-flag* is defined as #f. + + * the letrec (or in-procedure define) bug where local procedure + names were not recognized, is fixed. + + * documentation says explicitly that definitions like + + (define foo (let ((x 0)) (lambda (y) ...))) + + are assumed to be closure-returning procedures and are + prohibited. + + * documentation allows more liberty with passing procedures to + higher-order funs by dropping the general requirement that + only unnamed lambda-terms may be passed. Still, primitives + and list-taking procedures may not be passed by name. + + * documentation prohibits passing lambda-terms with free + variables to recursive calls of higher-order procedures in + the definition of a higher-order procedure. + +hobbit1: + the first release + + + +Tag Table: +Node: Top199 +Node: Introduction1217 +Node: Compiling with Hobbit2533 +Node: Compiling And Linking2786 +Node: Error Detection7267 +Node: Hobbit Options8565 +Node: CC Optimizations15286 +Node: The Language Compiled16234 +Node: Macros16889 +Node: SCM Primitive Procedures17485 +Node: SLIB Logical Procedures18336 +Node: Fast Integer Calculations19616 +Node: Force and Delay20742 +Node: Suggestions for writing fast code21319 +Node: Performance of Compiled Code31510 +Node: Gain in Speed31766 +Node: Benchmarks33343 +Node: Benchmark Sources36435 +Node: Destruct36773 +Node: Recfib38348 +Node: div-iter and div-rec38591 +Node: Hanoi39665 +Node: Tak40234 +Node: Ctak40577 +Node: Takl41560 +Node: Cpstak42219 +Node: Pi42986 +Node: Principles of Compilation44103 +Node: Macro-Expansion and Analysis44525 +Node: Building Closures48308 +Node: Lambda-lifting51191 +Node: Statement-lifting53939 +Node: Higher-order Arglists55039 +Node: Typing and Constants56837 +Node: About Hobbit58093 +Node: The Aims of Developing Hobbit58335 +Node: Manifest59218 +Node: Author and Contributors59669 +Node: Future Improvements60719 +Node: Release History61476 + +End Tag Table diff --git a/hobbit.scm b/hobbit.scm new file mode 100644 index 0000000..80d9d31 --- /dev/null +++ b/hobbit.scm @@ -0,0 +1,6981 @@ +;====================================================================
+;
+; HOBBIT: an optimizing scheme -> C compiler for SCM
+;
+; scm5d6
+; 2002-04-11
+;
+; Copyright (C) 1992-1997: Tanel Tammet
+; Copyright (C) 1998-2002: Free Software Foundation
+;
+; tammet@staff.ttu.ee, tammet@cs.chalmers.se
+;
+; Tanel Tammet
+; Department of Computer Science
+; Tallinn University of Technology
+; Raja 15
+; 12618, Tallinn
+; Estonia
+;
+; Department of Computing Science
+; Chalmers University of Technology
+; University of Go"teborg
+; S-41296 Go"teborg
+; Sweden
+;
+;
+; Documentation is in the file hobbit.texi
+;
+; NB! the terms for usage, copying
+; and redistribution of hobbit are given in the file COPYING
+;
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 1, or (at your option)
+; any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+;====================================================================
+;
+; Last part of changelog:
+;
+; april 2-11, 2002, Tanel Tammet:
+; - "system" and "verbose" compilation corrected
+; (system was previously not compiled, verbose is compiled to prolixity)
+; - "require" moved from top level to hobbit procedure (necessary
+; for self-compilation)
+; - "copy-tree" and "acons" compilation introduced
+; pre-april, 2002, Aubrey Jaffer:
+; - numerous changes necessary for co-operation with SCM5d5
+;
+;=================================================================
+;
+; default compiler options
+; (may be changed)
+;
+;=================================================================
+
+
+;;; The following variable controls whether hobbit will do any
+;;; macroexpansion. In that case (require 'defmacroexpand) must
+;;; be able to load the macroexpander from the scheme library.
+
+(define *expand-macros-flag* #t)
+
+;;; The following variable controls whether functions declared
+;;; to be inlined are inlined in full or only once. If the set of
+;;; nested inlinable function defs contains a circularity, the
+;;; setting #t will cause Hobbit to go into an infinite loop.
+
+(define *full-inlining-flag* #t)
+
+;;; The following variable controls whether any intermediate files
+;;; will be built. In that case (require 'pretty-print) and
+;;; (require 'pprint-load) must be able to load the prettyprinter
+;;; from the scheme library.
+
+(define *build-intermediate-files* #f)
+
+;;; The following variable controls whether any information about
+;;; compilation (except warnings and error messages) are printed.
+
+(define *infomessages-flag* #t)
+
+;;; The following variables control whether all map-s and for-each-s
+;;; are converted into inline-do-loops, or map-s and for-each-s
+;;; taking only one list are compiled as any other higher-order call
+;;; to functions map1 and for-each1 (inserted by the compiler in case
+;;; of need).
+
+(define *always-map->do-flag* #f)
+(define *always-for-each->do-flag* #f)
+
+
+;================================================================
+;
+; C-specific and system-specific options
+; (change if needed)
+;
+;===============================================================
+
+;;; If your C compiler does not assume that integers without a cast
+;;; are long ints, you may need to set the following flag to #t.
+;;; In that case all integers in the output C text, which should
+;;; be long ints, will have a trailing L cast.
+
+(define *long-cast-flag* #f)
+
+;;; If your C compiler may compile the C operator <test> ? <r1> : <r2>
+;;; to the code which may evaluate BOTH <r1> and <r2> in one
+;;; evaluation of the whole operator, you MUST define *lift-ifs-flag*
+;;; as #t.
+
+(define *lift-ifs-flag* #f)
+
+;;; If you C compiler may compile the C operator <a1> || <a2>
+;;; to the code which may evaluate <a2> even if <a1> evaluates to 1,
+;;; or, analogically, <a1> && <a2> may evaluate <a2> even if
+;;; <a1> evaluates to 0, you MUST define *lift-and-or-flag* as #t.
+
+(define *lift-and-or-flag* #f)
+
+;;; The following flag may be false only if the output C program
+;;; is supposed to run only on systems where the following holds:
+;;; ((-1%2 == -1) && (-1%-2 == -1) && (1%2 == 1) && (1%-2 == 1).
+;;; Otherwise the following flag must be #t.
+
+(define *badivsgns-flag* #f)
+
+;;; *input-file-modifier* and *output-file-modifier*
+;;; are strings which are given to the C file-opener to
+;;; indicate the mode of the file to be opened.
+;;; Select the MSDOS or ATARI version if appropriate, or define
+;;; your own modifier-strings.
+
+(define *input-file-modifier* "r") ;;; for UNIX & others
+(define *output-file-modifier* "w") ;;; for UNIX & others
+
+;;; (define *input-file-modifier* "rb") ;;; for MSDOS & ATARI
+;;; (define *output-file-modifier* "wb") ;;; for MSDOS & ATARI
+
+;;; The following variable controls the maximal length of auxiliary
+;;; functions created by the compiler (longer functions are split
+;;; into separate chunks).
+
+(define *max-auxfun-size* 50)
+
+;====================================================================
+;
+; Scheme-implementation-specific definitions. Change if needed.
+;
+;====================================================================
+
+(define (report-error . lst)
+ (display #\newline)
+ (display "COMPILATION ERROR: ")
+ (display #\newline)
+ (for-each display lst)
+ (display #\newline)
+ (abort))
+
+(define compile-allnumbers #t)
+
+;=================================================================
+;
+; renamable constants
+; (you might need to change some of these to
+; avoid name clashes)
+;
+;=================================================================
+
+
+;;; If your scheme file contains symbols which start
+;;; with a number, then *c-num-symb-prefix* is prefixed to
+;;; such symbols in the C source.
+
+(define *c-num-symb-prefix* "nonum_prefix_")
+
+;;; NB! If your scheme file contains variables which are also
+;;; C keywords or C functions defined in scm,
+;;; the string *c-keyword-postfix* is added to such variable names.
+;;; The list of prohibited variables is *c-keywords*. Add new
+;;; variables there, if needed.
+
+(define *c-keyword-postfix* "_nonkeyword")
+
+(define *c-keywords*
+ '(auto double int struct break else long switch
+ case enum register typedef char extern return union
+ const float short unsigned continue for signed void
+ default goto sizeof volatile do if static while
+
+;;; Some things are commented out to make hobbit compile itself correctly.
+
+ sizet void cell subr iproc smobfuns dblproc flo dbl isymnames s-and
+ s-begin s-case s-cond s-do s-if s-lambda s-let s-letstar s-letrec s-or
+ s-quote s-set i-dot i-quote i-quasiquote i-unquote i-uq-splicing
+ tcs-cons-imcar tcs-cons-nimcar tcs-cons-gloc tcs-closures tcs-subrs
+ tc7-asubr tcs-symbols tc7-ssymbol tcs-bignums tc16-bigpos tc3-cons
+ tc3-cons-gloc tc3-closure tc7-ssymbol tc7-msymbol tc7-string
+ tc7-vector tc7-bvect tc7-ivect tc7-uvect tc7-fvect tc7-dvect tc7-cvect
+ tc7-contin tc7-cclo tc7-asubr
+;;; tc7-subr-0 tc7-subr-1
+ tc7-cxr
+;;; tc7-subr-3 tc7-subr-2
+ tc7-subr-2x tc7-subr-1o tc7-subr-2o tc7-lsubr-2
+;;; tc7-lsubr
+ tc7-smob tc-free-cell tc16-flo tc-flo tc-dblr tc-dblc
+ tc16-bigpos tc16-bigneg tc16-port tc-inport tc-outport tc-ioport
+ tc-inpipe tc-outpipe smobfuns numsmob sys-protects cur-inp cur-outp
+ listofnull undefineds nullvect nullstr symhash progargs transcript
+ def-inp def-outp rootcont sys-protects upcase downcase symhash-dim
+ heap-size stack-start-ptr heap-org freelist gc-cells-collected
+ gc-malloc-collected gc-ports-collected cells-allocated linum
+ errjmp-ok ints-disabled sig-deferred alrm-deferred han-sig han-alrm
+ must-malloc ilength s-read s-write s-newline s-make-string
+ s-make-vector s-list s-string s-vector repl-driver newsmob lthrow repl
+ gc-end gc-start growth-mon iprin1 intprint iprlist lputc lputs
+ lfwrite time-in-msec my-time init-tables init-storage init-subrs
+ init-features init-iprocs init- init-scl init-io init-repl init-time
+ init-signals ignore-signals unignore-signals init-eval init-sc2
+ free-storage init-unif uvprin1 markcdr free0 warn wta everr sysintern
+;;; intern
+ sym2vcell makstr
+;;; make-subr
+;;; makfromstr
+ closure makprom force
+ makarb tryarb relarb ceval prolixity gc gc-for-newcell tryload cons2
+;;; acons
+ resizuve cons2r lnot booleanp eq equal consp cons nullp
+ setcar setcdr listp list length append reverse list-ref memq memv
+ member assq assv assoc symbolp symbol2string string2symbol numberp exactp
+ inexactp eqp lessp zerop positivep negativep oddp evenp lmax lmin sum
+ product difference lquotient absval remainder lremainder modulo lgcd llcm
+ number2string
+;;; string2number
+ makdbl istr2flo mkbig long2big dbl2big
+ iint2str iflo2str floprint bigprint big2dbl charp char-lessp chci-eq
+ chci-lessp char-alphap char-nump char-whitep char-upperp char-lowerp
+ char2int int2char char-upcase char-downcase stringp make-string
+ string st-length st-ref st-set st-equal stci-equal st-lessp
+ stci-lessp substring st-append vectorp make-vector
+ vector
+ vector-length vector-ref vector-set for-each procedurep apply map
+ call-cc copytree
+;;; eval
+ throwval quit input-portp output-portp
+ cur-input-port cur-output-port open-file open-pipe close-port
+ close-pipe lread read-char peek-char eof-objectp lwrite display
+ newline write-char file-position file-set-position lgetenv prog-args
+ makacro makmacro makmmacro
+ remove ash round array-ref array_ref
+ sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh sqrt expt
+ log abs exp
+ ;; verbose copy-tree @copy-tree
+ last-pair subml submr subfl ;from sc2.c
+))
+
+
+;;; NB! Your scheme file must not contain symbols which end with
+;;; the third elements of the following defines appended
+;;; with an integer. The same holds for the case where "-" is written
+;;; instead of "_". In case your scheme file contains any offending
+;;; symbols, replace them either in your file or replace the offending
+;;; strings in the following defines.
+;;;
+;;; E.g. it is not allowed to have symbols like: my__12, spec-tmp-var3,
+;;; foo-inst1, foo_inst5, bar-aux2.
+;;;
+;;; E.g. it is allowed to have symbols like: my__x, spec_tmp_var,
+;;; foo-inst1x, foo_inst_5, bar-aux-spec.
+
+(define *local-var-infix* "__")
+(define *new-var-name* "new_var")
+(define *tmp-var-name* "tmp_var")
+(define *new-parameter-prefix* "npar__")
+(define *new-fun-infix* "_aux")
+(define *new-letfun-infix* "_fn")
+(define *new-instfun-infix* "_inst")
+(define *new-constant-prefix* "const_")
+(define *closure-name-suffix* "_cl")
+(define *closure-vector-name* "clargsv_")
+
+;;; The following are names for the additional scheme functions
+;;; nonkeyword-make-promise and nonkeyword-force.
+;;; If your scheme file contains a function
+;;; with these names already, you must change the following names.
+
+(define *make-promise-function* 'nonkeyword_make-promise)
+(define *force-function* 'nonkeyword_force)
+
+;;; The following two will be names for the additional scheme functions
+;;; map1 and for-each1. If your scheme file contains any functions with
+;;; such names already, you must change the following names.
+
+(define *map1-function* 'map1)
+(define *for-each1-function* 'for-each1)
+
+;;; The following name is not allowed to occur in your scheme file,
+;;; neither is <name>_<nr> allowed.
+
+(define *new-closure-var* "newclosure")
+
+;;; The following is appended to symbols (not variables!) in your scheme
+;;; file. Thus your scheme file should not contain variables or symbols
+;;; ending with the value of *symbol-name-postfix*. If needed, change
+;;; *symbol-name-postfix* from "_symb" to some other string.
+
+(define *symbol-name-postfix* "_symb")
+
+;;; The following is appended to higher-order function names in your scheme
+;;; file which should be accessible from the interpreter. Thus your scheme
+;;; file should not contain variables or symbols
+;;; ending with the value of *export-hof-postfix*. If needed, change
+;;; *export-hof-postfix* from "_exporthof" to some other string.
+
+(define *export-hof-postfix* "_exporthof")
+
+;;; The following is needed for exportable functions which do not
+;;; have a type available in scm and need a special wrapper-function
+;;; to pass variables supplied by the interpreter. The wrapper function
+;;; name for some function foo is foo_wrapper, unless you change
+;;; the following define.
+
+(define *wrapper-postfix* "_wrapper")
+
+;;; The following is appended to those function names in your scheme
+;;; which are passed in the file to functions defined out of file
+;;; or to append: in other words, passed to interpreter
+
+(define *interpreter-suffix* "_interpreter")
+
+;;; The following is appended to names of stable vectors, to
+;;; denote the precalculated VELTS(x) part of a stable vector x.
+
+(define *st-vector-postfix* "_velts0")
+
+;;; The following is appended to names of closure procedures, giving
+;;; the C-only static SCM variable name
+
+(define *closure-proc-suffix* "_clproc0")
+
+;;; The following is a string which is prepended to the name of your
+;;; scheme file (without .scm) to form a name of a function generated
+;;; to initialize non-function defined variables in your scheme file.
+
+(define *init-globals-prefix* "init_globals_")
+
+;;; The following is a string which is prepended to the name of your
+;;; scheme file (without .scm) to form a name of a function generated
+;;; to perform all top-level computations in your scheme file.
+
+(define *top-actions-prefix* "top_actions_")
+
+;;; The following is a string which is prepended to the name of your
+;;; scheme file (without .scm) to form a name of a main initialization
+;;; function for your file.
+
+(define *init-fun-prefix* "init_")
+
+;;; The following is a string which is prepended to the name of your
+;;; scheme file (without .scm) to form a C variable which is generated
+;;; as a new global to gc-protect the constant nonimmediate objects
+;;; in your file.
+
+(define *protect-variable* "protect_constants_")
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of inlinable functions in your scheme file.
+
+(define *inline-declare* 'compile-inline)
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of inlinable variables in your scheme file.
+
+(define *inline-vars-declare* 'compile-inline-vars)
+
+;;; The following is a name of a variable which has to be defined to
+;;; make hobbit compile numeric procedures for all numbers as default,
+;;; not just integers:
+
+(define *allnumbers-declare* 'compile-allnumbers)
+
+;;; The following is a name of a variable which has to be defined to
+;;; make hobbit assume all procedures may be redefined.
+
+(define *all-funs-modified-declare* 'compile-all-proc-redefined)
+
+;;; The following is a name of a variable which has to be defined to
+;;; make hobbit assume all procedures may be redefined.
+
+(define *new-funs-modified-declare* 'compile-new-proc-redefined)
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of exportable functions in your scheme file.
+
+(define *export-declare* 'compile-export)
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of stable vector names (never-assigned except the first
+;;; initialization, not even by let or as local variables) in your
+;;; scheme file.
+
+(define *stable-vectors-declare* 'compile-stable-vectors)
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of uninterned fast global vars (never holding nonimmediate values,
+;;; ie not char, bool or short int). These vars are NOT accessible
+;;; by the interpreter! They are used directly as C vars, without the GLOBAL
+;;; (ie * op) prefix.
+
+(define *fast-vars-declare* 'compile-uninterned-variables)
+
+;;; The following two are default names for the single argument
+;;; of the closure function and the variable which is assigned its
+;;; first element.
+
+(define *closurefun-arg* 'closurearg_0)
+(define *closurefun-arg-car* 'closurearg_car_0)
+
+;;; NB! The following determine the replacements for symbols
+;;; allowed in scheme variables but not in C variables.
+;;; Be careful with your scheme variables to avoid
+;;; name clashes! E.g. if you have scheme variables
+;;; bar--plus_, bar-+ and bar_+, they will all be converted to
+;;; the same C variable bar__plus_
+;;; In case of need feel free to change the replacement table.
+;;; You may also wish to change the scheme function
+;;; display-c-var, which performs the conversion.
+;;;
+;;; *global-postfix* determines the string to be appended to
+;;; variable names surrounded by *-s. The surrounding *-s
+;;; are dropped. E.g. *special-flag* will be converted to
+;;; special_flag_global
+;;; *char-replacements* determine the replacement strings
+;;; for characters not allowed in C variables. E.g. foo!?
+;;; will be converted to foo_excl__pred_
+
+(define *global-postfix* "_global")
+
+(define *char-replacements*
+ '((#\+ "_plus_")
+ (#\- "_")
+ (#\@ "_at_")
+ (#\. "_dot_")
+ (#\* "_star_")
+ (#\/ "_slash_")
+ (#\< "_less_")
+ (#\= "_equal_")
+ (#\> "_grtr_")
+ (#\! "_excl_")
+ (#\? "_pred_")
+ (#\: "_colon_")
+ (#\$ "_dollar_")
+ (#\% "_percent_")
+ (#\_ "_")
+ (#\& "_and_")
+ (#\~ "_tilde_")
+ (#\^ "_exp_")
+ (#\[ "_obrckt_")
+ (#\] "_cbrckt_")
+ (#\| "_vbar_")))
+
+;;; *c-indent* is the one-level indentation for C statements.
+;;; There is no indentation for C expressions.
+
+(define *c-indent* " ")
+
+;;; *c-infix-surround* is put before and after each infix C operator.
+;;; The sensible alternative to default "" is " " or #\space.
+
+(define *c-infix-surround* "")
+
+;;; The following are some obvious C constants. *c-null* is the
+;;; C object corresponding to scheme '().
+
+(define *c-true* 1)
+(define *c-false* 0)
+(define *c-null* "EOL")
+(define *scm-type* "SCM")
+(define *unspecified* '**unspecified**) ; you may change it
+
+;;; NB! Your scheme file must not contain any third symbols
+;;; of the following defines. If it does, replace the
+;;; offending symbol either in your file or in the following
+;;; defines (the compiler must contain the replacement anywhere
+;;; else).
+
+(define *function* '**function**)
+(define *higher-order-call* '**higher-order-call**)
+(define *higher-order-flag* #f)
+(define *dummy* '**dummy**)
+(define *not?* '**not?**)
+(define *and?* '**and**)
+(define *or?* '**or**)
+(define *open-file-function* '**open-file-function**)
+(define *set-current-input-port-function*
+ '**set-current-input-port-function**)
+(define *set-current-output-port-function*
+ '**set-current-output-port-function**)
+(define *num-s->c* '**num-s->c**)
+(define *num-c->s* '**num-c->s**)
+(define *bool-s->c* '**bool-s->c**)
+(define *bool-c->s* '**bool-c->s**)
+(define *char-c->s* '**char-c->s**)
+(define *float-c->s* '**float-c->s**)
+(define *tailrec* '**tailrec**)
+(define *c-fetch* '**c-fetch**)
+(define *c-adr* '**c-adr**)
+(define *op-if* '**op-if**)
+(define *op-begin* '**op-begin**)
+(define *op-let* '**op-let**)
+(define *do-not* '**do-not**)
+(define *return* '**return**) ; NB! do not change this!!!
+(define *goto-tailrec* '**goto-tailrec**)
+(define *mark-tailrec* '**mark-tailrec**)
+(define *define-constant* '**define-constant**)
+(define *actual-c-string* '**actual-c-string**)
+(define *actual-c-expr* '**actual-c-expr**)
+(define *actual-c-int* '**actual-c-int**)
+(define *actual-c-eval* '**actual-c-eval**)
+(define *special-pseudoquote* '**special-pseudoquote**)
+(define *global-access* '**global-access**)
+(define *sysapply* '**sysapply**)
+(define *listofnull* '**listofnull**)
+(define *velts-function* '**velts-function**)
+(define *st-vector-set* '**st-vector-set**)
+(define *st-vector-ref* '**st-vector-ref**)
+(define *make-cclo* '**make-cclo**)
+
+
+(define *special-scm->c-functions*
+ (list
+*function*
+*higher-order-call*
+*dummy*
+*not?*
+*and?*
+*or?*
+*open-file-function*
+*set-current-input-port-function*
+*set-current-output-port-function*
+*num-s->c*
+*num-c->s*
+*bool-s->c*
+*bool-c->s*
+*char-c->s*
+*float-c->s*
+*tailrec*
+*c-fetch*
+*c-adr*
+*op-if*
+*op-begin*
+*op-let*
+*do-not*
+*return*
+*goto-tailrec*
+*mark-tailrec*
+*define-constant*
+*actual-c-string*
+*actual-c-int*
+*actual-c-eval*
+*special-pseudoquote*
+*global-access*
+*listofnull*
+*velts-function*
+*st-vector-set*
+*st-vector-ref*
+*sysapply*
+*make-cclo*
+*unspecified*))
+
+
+;;; *intern-function* must be a C function taking a C string
+;;; and its length (C int) which builds a new scheme symbol
+;;; and returns it.
+;;; *makfromstr-function* must be a C function taking a C string
+;;; and its length (C int) which builds a new scheme string
+;;; and returns it.
+;;; *string->number-function* must be a C function taking a scheme string
+;;; and a radix (scheme int) which builds a new scheme number
+;;; and returns it.
+;;; Instead of using such special functions it is possible to
+;;; change the compiler functions make-symbol-constant and
+;;; make-string-constant instead.
+
+(define *intern-function* 'intern)
+(define *intern-symbol-function* 'intern)
+(define *makfromstr-function* 'makfromstr)
+(define *string->number-function* 'string2number)
+(define *c-eval-fun* 'eval)
+
+(define *internal-c-functions*
+ (list *intern-function* *makfromstr-function*
+ *intern-symbol-function* *string->number-function* *c-eval-fun*))
+
+(define *prohibited-funs* '())
+
+;;; *type-converters* is a list of scheme<->C representation
+;;; converters.
+
+(define *type-converters*
+ (list *num-s->c* *num-c->s* *bool-s->c* *bool-c->s*
+ *char-c->s* *float-c->s*))
+
+;;; The following four defines specify functions which will either
+;;; take or return (or both) C numbers or booleans. They
+;;; are actually set in set-primitive-tables.
+;;;
+;;; *num-arg-c-funs* is a set of scheme functions which will be
+;;; converted to analogous C functions (provided
+;;; *reckless-arithmetic* is #t) and which take C numbers
+;;; as arguments.
+;;; *num-res-c-funs* is a set of scheme functions which will
+;;; converted to analogous C functions (provided
+;;; *reckless-arithmetic* is #t) and which give C numbers
+;;; as results.
+;;; *bool-arg-c-funs* is a set of scheme functions which will always be
+;;; converted to analogous C functions
+;;; and which take C booleans (int 0 or non-0) as arguments.
+;;; *bool-res-c-funs* is a set of scheme functions which will be
+;;; converted to analogous C functions (some only if
+;;; *reckless-arithmetic* is #t) and which give C booleans
+;;; as results.
+
+(define *num-arg-c-funs* '())
+(define *always-num-arg-c-funs* '())
+(define *num-res-c-funs* '())
+(define *bool-arg-c-funs* '())
+(define *always-bool-res-c-funs* '())
+(define *bool-res-c-funs* '())
+
+;;; cxr-functions is a set of allowed cxr functions. You may
+;;; extend it if you wish.
+
+(define *cxr-funs*
+ '(car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
+
+;=================================================================
+;
+; global variable defs
+;
+;=================================================================
+
+;;; the following variable determines whether floats or ints are used
+
+(define *floats-flag* #f) ; must be #f in this version
+
+;;; The following variables control error-checking performed by
+;;; the resulting C program and numerical operations.
+
+(define *reckless-arithmetic-flag* #t) ; MUST be #t in this version
+(define *reckless-access-flag* #t) ; MUST be #t in this version
+
+;;; The following variable controls optimizations of integer
+;;; arithmetic for scheme<->C type conversions.
+
+(define *optimize-arithmetic* #f) ; MUST be #f in this version
+
+(define *splitted-init-function-names* '())
+(define *splitted-topaction-function-names* '())
+(define *map1-needed-flag* #f)
+(define *for-each1-needed-flag* #f)
+(define *inline-funs* '())
+(define *inline-vars* '())
+(define *top-actions-list* '())
+(define *inline-funs-data* '())
+(define *inline-vars-data* '())
+(define *c-port* '())
+(define *char-replacements-lists* '())
+(define *tmp-var-max* 500)
+(define *initial-defs* '())
+(define *passed-defs* '())
+(define *output-defs* '())
+(define *new-funs-list* '())
+(define *fun-arities-alist* '())
+(define *to-do-fun-list* '())
+(define *via-interpreter-defined* '())
+(define *non-directcomp-list* '())
+(define *current-fun-name* 'foo)
+(define *current-formal-args* '())
+(define *current-formal-argslist* '())
+(define *tailrec-flag* #f)
+(define *tmp-vars* '())
+(define *new-fun-nr* 0)
+(define *new-fun-names* '())
+(define *higher-ordr-flag* #f)
+(define *higher-order-args* '())
+(define *higher-order-funs* '())
+(define *higher-order-templates* '())
+(define *new-parameter-nr* '0)
+(define *make-new-ho-data* '())
+(define *dot-arg-funs* '())
+(define *dot-arg-templates* '())
+(define *new-instnr* '0)
+(define *new-primitive-instnr* '0)
+(define *local-vars* '())
+(define *new-constant-list* '())
+(define *symbol-constant-table* '())
+(define *interpreter-funname-table* '())
+(define *new-constant-num* 0)
+(define *passed-ho-dot-instfuns* '())
+(define *passed-closure-funs* '())
+(define *free-vars-list* '())
+(define *global-vars-list* '())
+(define *var-make-list* '())
+(define *symbol-list* '())
+(define *unknown-functions* '())
+(define *unknown-vars* '())
+(define *local-parameters* '())
+(define *top-level-funs* '())
+(define *export-functions* '())
+(define *export-table* '())
+(define *wrapper-table* '())
+(define *stable-vector-names* '())
+(define *fast-vars-list* '())
+(define *closure-var-vectornames* '())
+(define *lifted-closures-to-do* '())
+(define *lifted-trivial-closure-names* '())
+(define *lifted-closure-names* '())
+(define *liftable-hof-names* '())
+(define *non-liftable-hof-names* '())
+(define *special-c-vars* '())
+(define *closure-name-nr* 0)
+(define *closure-vector-name-nr* 0)
+(define *liftable-hof-database* '())
+(define *letrec-closure-nr* 0)
+(define *letrec-closures* '())
+(define *letrec-closure-init* '())
+(define *not-all-liftable-names* '())
+(define *all-funs-modified-flag* #f)
+(define *new-funs-modified-flag* #f)
+(define *primitives* '())
+(define *symbol-and-fun-list* '())
+(define *hobbit-declaration-vars* '())
+
+;;; the definition of force is used in case 'delay' is
+;;; found inside the program
+
+(define *force-definition*
+ (list
+ 'define
+ *force-function*
+ '(lambda (object) (object))))
+
+
+;;; the definition of make-promise is used in case 'delay' is
+;;; found inside the program
+
+(define *make-promise-definition*
+ (list
+ 'define
+ *make-promise-function*
+ '(lambda (proc)
+ (let ((result-ready? #f)
+ (result #f))
+ (lambda ()
+ (if result-ready?
+ result
+ (let ((x (proc)))
+ (if result-ready?
+ result
+ (begin (set! result-ready? #t)
+ (set! result x)
+ result)))))))))
+
+
+
+;;; a word of warning: the following two defs must not contain any
+;;; of the following: (cond, case, not, or, and, let, letrec, map, for-each)
+;;; and must not contain lambda-terms or clashing variables in let*.
+;;; There might be other analogous restrictions as well!
+
+(define *map1-definition*
+ (list 'define
+ *map1-function*
+ `(lambda (fn lst)
+ (let* ((res '()) (res-end res))
+ (do ()
+ ((,*not?* (pair? lst)) res)
+ (if (null? res)
+ (begin (set! res (cons (fn (car lst)) '()))
+ (set! res-end res))
+ (begin (set-cdr! res-end (cons (fn (car lst)) '()))
+ (set! res-end (cdr res-end))))
+ (set! lst (cdr lst)))))))
+
+
+(define *for-each1-definition*
+ (list 'define
+ *for-each1-function*
+ `(lambda (fn lst)
+ (do ()
+ ((,*not?* (pair? lst)) ,*unspecified*)
+ (fn (car lst))
+ (set! lst (cdr lst))))))
+
+;=================================================================
+;
+; top level
+;
+;=================================================================
+
+
+(define (Hobbit:compile file . files)
+ (hobbit (cons file files)))
+
+
+(define (hobbit file . files)
+ (let* ((tmpname "hobbit.tmp"))
+ (if *build-intermediate-files*
+ (begin (require 'pretty-print)))
+ (if *expand-macros-flag*
+ (begin (require 'defmacroexpand)
+ (require 'pprint-file)))
+ (if (not (memq 'hobbit *features*))
+ (set! *features* (cons 'hobbit *features*)))
+ (if (or (member '"scmhob.scm" (cons file files))
+ (member '"scmhob" (cons file files)))
+ (report-error "The file scmhob.scm is not allowed to be compiled!"))
+ (init-global)
+ ;; check for defmacros
+ (if *expand-macros-flag*
+ (if (not (find-if (lambda (x) (file-contains-defmacro? x))
+ (cons file files)))
+ (set! *expand-macros-flag* #f)))
+ (set! *initial-defs* '())
+ (if *expand-macros-flag* (for-each defmacro:load (cons file files)))
+ (for-each (lambda (x)
+ (if *infomessages-flag*
+ (begin (newline)
+ (display "Starting to read ") (display x)))
+ (read-compiled-file x tmpname))
+ (cons file files))
+ (if *infomessages-flag* (newline))
+ (compile-defs file (reverse *initial-defs*))))
+
+(define (file-contains-defmacro? str)
+ (let ((foundflag #f)
+ (expr '())
+ (port (if (file-exists? str)
+ (open-input-file str)
+ (if (file-exists? (string-append str ".scm"))
+ (open-input-file (string-append str ".scm"))
+ (report-error "Could not find file " str)))))
+ (if port
+ (do ()
+ ((or foundflag (eof-object? expr)) foundflag)
+ (set! foundflag (expr-contains-defmacro? expr))
+ (set! expr (read port)))
+ #f)))
+
+(define (expr-contains-defmacro? expr)
+ (cond ((not (pair? expr)) #f)
+ ((or (eq? 'quote (car expr)) (eq? 'quasiquote (car expr))) #f)
+ ((eq? 'defmacro (car expr)) #t)
+ (else (pair-find-if (lambda (x) (expr-contains-defmacro? x)) expr))))
+
+
+(define (read-compiled-file file tmpname)
+ (let* ((iport (if (file-exists? file)
+ (open-input-file file)
+ (if (file-exists? (string-append file ".scm"))
+ (open-input-file (string-append file ".scm"))
+ (report-error "Could not find file " file))))
+ (oport (if *expand-macros-flag* (open-output-file tmpname) '()))
+ (def #t))
+ (if *infomessages-flag* (newline))
+ (if *expand-macros-flag*
+ (begin
+ (if *infomessages-flag*
+ (begin
+ (display "Starting macroexpansion building the ")
+ (display "temporary file ")
+ (display tmpname) (display #\.) (newline)))
+ (pprint-filter-file iport defmacro:expand* oport)
+ (close-output-port oport)
+ (set! iport (open-input-file tmpname))))
+ (do ()
+ ((eof-object? def)
+ (close-input-port iport))
+ (set! def (read iport))
+ (cond ((eof-object? def))
+ ((and (pair? def)
+ (or (eq? 'load (car def))
+ (eq? 'require (car def))))
+ (report-warning "ignoring a load on top level: " def))
+ (else
+ (set! *initial-defs* (cons def *initial-defs*)))))))
+
+(define (compile-defs file deflst)
+ (let ()
+ (set! file (descmify file))
+ ;; - - - - adding primitives delay and force, if neccessary - - - - -
+ (if (find-if (lambda (x) (in-fun-position? 'delay x)) deflst)
+ (set! deflst
+ (append deflst
+ (append
+ (list *force-definition*)
+ (list *make-promise-definition*)))))
+ ;; - - - - - initial checks and flag-setting, sorting out the toplevel
+ ;; builds *top-level-names*, *modified-primitives* and
+ ;; *modified-top-level-names*:
+ (make-top-level-namelist! deflst)
+ ;; sorts out the toplevel:
+ (sort-out-toplevel! deflst file)
+ (if (not *floats-flag*)
+ (compute-floats-flag! deflst #t))
+ (if *infomessages-flag*
+ (if *floats-flag*
+ (begin
+ (display "Generic (slow) arithmetic assumed: ")
+ (display *floats-flag*)
+ (display " found.")
+ (newline))
+ (begin
+ (display "Bounded integer (fast) arithmetic assumed.")
+ (newline))))
+ (set-primitive-tables)
+ (set! *passed-defs* '())
+ ;; - - - - - vars-simplification pass - -
+ (set! *to-do-fun-list*
+ (map vars-simplify-wholedef *to-do-fun-list*))
+ ;; - - - - - finding liftable hof-s - - -
+ (set! *liftable-hof-names* '())
+ (set! *non-liftable-hof-names* '())
+ (for-each (lambda (x)
+ (if (and (pair? (caddr x))
+ (eq? 'lambda (caaddr x))
+ (liftable-hof? (caddr x) (cadr x)))
+ (set! *liftable-hof-names*
+ (cons (cadr x) *liftable-hof-names*))))
+ *to-do-fun-list*)
+ (for-each lift-analyse-def! *to-do-fun-list*)
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 1 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".anl"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *to-do-fun-list*)
+ (close-output-port fport)
+ (newline)
+ (display "analyzed & marked definitions file ")
+ (display (string-append file '".anl"))
+ (display " is built.")))
+ ;; initial analysis passes completed
+ ;; - - - - - building closures - - - - - - - -
+ (do ((part *to-do-fun-list* part))
+ ((null? part))
+ (set! *lifted-closures-to-do* '())
+ (set! *passed-defs*
+ (cons (try-closure-making-def(car part)) *passed-defs*))
+ (set! part (append *lifted-closures-to-do* (cdr part))))
+ (set! *to-do-fun-list* (reverse *passed-defs*))
+ (for-each lift-unmark-def! *to-do-fun-list*)
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 2 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".cls"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *to-do-fun-list*)
+ (close-output-port fport)
+ (newline)
+ (display "closures-building file ")
+ (display (string-append file '".cls"))
+ (display " is built.")))
+ ;; closurebuilding pass completed
+ ;; - - - - - - - - flattening starts - - - - - - - - -
+ (set! *passed-defs* '())
+ (for-each (lambda (def)
+ (set! *passed-defs*
+ (append (reverse (flatten-wholedef def))
+ *passed-defs*)))
+ *to-do-fun-list*)
+ (if (not (or (pair? *export-functions*) (null? *export-functions*)))
+ (set! *export-functions* *top-level-funs*)
+ (set! *export-functions*
+ (intersection *export-functions* *top-level-funs*)))
+ (if *map1-needed-flag*
+ (set! *passed-defs* (cons *map1-definition* *passed-defs*)))
+ (if *for-each1-needed-flag*
+ (set! *passed-defs* (cons *for-each1-definition* *passed-defs*)))
+ (set! *passed-defs* (reverse *passed-defs*))
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 3 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".flt"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *passed-defs*)
+ (close-output-port fport)
+ (newline)
+ (display "lambda-lifted & normalized definitions file ")
+ (display (string-append file '".flt"))
+ (display " is built.")))
+ (set! *to-do-fun-list* *passed-defs*)
+ ;; lambda-lifting & normalization finished
+ ;; - - - - - - - - - - lift statements - - - - - - - - - - -
+ (set! *passed-defs* '())
+ (do ((x 1 1))
+ ((null? *to-do-fun-list*))
+ (let ((tmp (car *to-do-fun-list*)))
+ (set! *to-do-fun-list* (cdr *to-do-fun-list*))
+ (set! *passed-defs* (append (lift-statements-wholedef tmp)
+ *passed-defs*))))
+ (set! *passed-defs* (reverse *passed-defs*))
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 4 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".stt"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *passed-defs*)
+ (close-output-port fport)
+ (newline)
+ (display "statement-lifted definitions file ")
+ (display (string-append file '".stt"))
+ (display " is built.")))
+ (set! *to-do-fun-list* *passed-defs*)
+ ;; statement-lifting pass finished
+ ;; - - - - - - - hof-dot-corrections starts - - - - - -
+ (set! *passed-ho-dot-instfuns* '())
+ (set! *passed-defs* '())
+ (do ((x 1 1))
+ ((null? *to-do-fun-list*))
+ (let ((tmp (car *to-do-fun-list*)))
+ (set! *to-do-fun-list* (cdr *to-do-fun-list*))
+ (if (not (memq (cadr tmp) *passed-ho-dot-instfuns*))
+ (set! *passed-defs* (cons (ho-dot-wholedef tmp)
+ *passed-defs*)))))
+ (set! *passed-defs*
+ (reverse (append (build-wrappers *passed-defs*)
+ *passed-defs*)))
+ (build-wrapped-interpreter-table)
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 5 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".hod"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *passed-defs*)
+ (close-output-port fport)
+ (newline)
+ (display "higher-order-&-dot-arglist corrected definitions file ")
+ (display (string-append file '".hod"))
+ (display " is built.")))
+ (set! *to-do-fun-list* *passed-defs*)
+ ;; hof-dot correction finished
+ ;; - - - - - - - typing & constant-correcting - - - - - - - - - -
+ (set! *passed-defs* '())
+ (do ((x 1 1))
+ ((null? *to-do-fun-list*))
+ (let ((tmp (car *to-do-fun-list*)))
+ (set! *to-do-fun-list* (cdr *to-do-fun-list*))
+ (set! *passed-defs* (cons (type-const-wholedef tmp)
+ *passed-defs*))))
+
+ (for-each (lambda (x)
+ (let ((tmp (assq x *extra-hobbit-primitive-defs*)))
+ (if (and tmp (not (memq x *modified-primitives*)))
+ (begin
+ (set! *passed-defs*
+ (cons (type-const-wholedef
+ (list 'define x (cadr tmp)))
+ *passed-defs*))
+ (if (memq x *extra-hobbit-dot-primitives*)
+ (set! *dot-arg-templates*
+ (cons (list x 'x) *dot-arg-templates*)))))))
+ *unknown-vars*)
+ (set! *passed-defs* (reverse *passed-defs*))
+ (init-export-funs! file)
+ (make-initialization-function! file)
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 6 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".typ"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *passed-defs*)
+ (close-output-port fport)
+ (newline)
+ (display "typing & constants - corrected definitions file ")
+ (display (string-append file '".typ"))
+ (display " is built.")
+ (newline)))
+ (set! *to-do-fun-list* *passed-defs*)
+ ;; typing & constant-correcting pass finished
+ ;; - - - - - - - - building .c and .h files - - - - - - - - - -
+ (set! *passed-defs* '())
+ (let ((fport (open-output-file (string-append file '".c"))))
+ (display "#include " fport)
+ (display #\" fport)
+ (display (string-append file '".h") fport)
+ (display #\" fport)
+ (newline fport)
+ (newline fport)
+ (for-each (lambda (x) (write-c-wholefun x fport))
+ *to-do-fun-list*)
+ (close-output-port fport)
+ (if *infomessages-flag*
+ (begin (newline) (newline)
+ (display "C source file ")
+ (display (string-append file '".c"))
+ (display " is built.")
+ (newline))))
+ (let ((fport (open-output-file (string-append file '".h"))))
+ (display-header fport)
+ (newline fport)
+ (for-each (lambda (x)
+ (write-fun-declaration (cadr x) fport))
+ *to-do-fun-list*)
+ (for-each (lambda (x)
+ (if (not (memq x *fast-vars-list*))
+ (write-c-*declaration x fport)))
+ *global-vars-list*)
+ (for-each (lambda (x)
+ (write-c-*declaration (cdr x) fport))
+ *interpreter-funname-table*)
+ (for-each (lambda (x)
+ (write-c-*declaration (make-closure-scmobj-name x) fport))
+ *symbol-and-fun-list*)
+ (for-each (lambda (x)
+ (write-c-static-declaration
+ (make-closure-scmobj-name x) fport))
+ *lifted-trivial-closure-names*)
+ (for-each (lambda (x)
+ (write-c-static-declaration
+ (make-closure-scmobj-name x) fport))
+ *lifted-closure-names*)
+ (for-each (lambda (x) (write-c-static-declaration (cadr x) fport))
+ (reverse *symbol-constant-table*))
+ (for-each (lambda (x)
+ (if (not (pair? (cadr x)))
+ (write-c-static-declaration (cadr x) fport)))
+ (reverse *new-constant-list*))
+ (for-each (lambda (x)
+ (write-c-*declaration
+ (string->symbol
+ (string-append (symbol->string x) *st-vector-postfix*))
+ fport))
+ (reverse *stable-vector-names*))
+ (for-each (lambda (x) (write-c-static-declaration x fport))
+ (reverse *fast-vars-list*))
+ (newline fport)
+ (close-output-port fport)
+ (if *infomessages-flag*
+ (begin
+ (display "C header file ")
+ (display (string-append file '".h"))
+ (display " is built.")
+ (newline))))
+ ;; .c and .h files built
+ ;; - - - - - - - - - extra compilation info: - - - - - - - - -
+ (set! *via-interpreter-defined*
+ (append *via-interpreter-defined*
+ (map car *switch-args-table*)
+ *cxr-funs*
+ *non-compiled-primitives*
+ *interpreter-defined-vars*
+ (map car *floats-s->c-fun-table*)))
+ ;; - - - - - - - - - redefinability info: - - - - - - - - -
+ (if *infomessages-flag* (newline))
+ (cond
+ ((not *infomessages-flag*))
+ (*all-funs-modified-flag*
+ (newline)
+ (display "All procedure names are assumed to be redefinable (slow).")
+ (newline))
+ (*new-funs-modified-flag*
+ (newline)
+ (display
+ "All new procedure names are assumed to be redefinable (slow).")
+ (newline)
+ (if (not (null? *modified-primitives*))
+ (begin
+ (display
+ "These primitive procedure names are assumed to be redefinable (slow):")
+ (newline)
+ (display *modified-primitives*)
+ (newline))))
+ (else
+ (if (not (null? *modified-primitives*))
+ (begin
+ (display
+ "These primitive procedure names are assumed to be redefinable (slow):")
+ (newline)
+ (display *modified-primitives*)
+ (newline)))
+ (if (not (null? (set-difference *modified-top-level-names*
+ (union
+ *global-vars-list* *fast-vars-list*))))
+ (begin
+ (display
+ "These top level procedure names are assumed to be redefinable (slow):")
+ (newline)
+ (display (set-difference *modified-top-level-names*
+ (union
+ *global-vars-list* *fast-vars-list*)))
+ (newline)))))
+ ;; - - - - - - - - - hof-info: - - - - - - - - - - - - - -
+ (cond
+ ((not *infomessages-flag*))
+ ((not (null? *non-liftable-hof-names*))
+ (display
+ "These top level higher order procedures are not clonable (slow):")
+ (newline)
+ (display *non-liftable-hof-names*)
+ (newline)))
+ ;; - - - - - - - - - closures-info: - - - - - - - - - - - - -
+ (cond
+ ((not *infomessages-flag*))
+ ((not (null? *not-all-liftable-names*))
+ (display
+ "These top level procedures create non-liftable closures (slow):")
+ (newline)
+ (display *not-all-liftable-names*)
+ (newline)))
+ ;; - - - - - - - - - undefined-info: - - - - - - - - - - -
+ (if (and *infomessages-flag*
+ (not (null? (set-difference (set-difference *unknown-functions*
+ *modified-top-level-names*)
+ (union *global-vars-list*
+ (union *fast-vars-list*
+ *via-interpreter-defined*))))))
+ (begin (newline)
+ (display
+ "These nonprimitive procedures are assumed to be defined externally:")
+ (newline)
+ (display
+ (set-difference (set-difference *unknown-functions*
+ *modified-top-level-names*)
+ (union *global-vars-list*
+ (union *fast-vars-list*
+ *via-interpreter-defined*))))
+ (newline)))
+ (if (and *infomessages-flag*
+ (not (null? (set-difference (set-difference *unknown-vars*
+ *modified-top-level-names*)
+ *via-interpreter-defined*))))
+ (begin (newline)
+ (display
+ "These variables undefined (but used) in your file were defined:")
+ (newline)
+ (display (set-difference (set-difference *unknown-vars*
+ *modified-top-level-names*)
+ *via-interpreter-defined*))
+ (newline)))
+ (if *infomessages-flag* (newline))))
+
+(define (sort-out-toplevel! lst file)
+ (set! *to-do-fun-list* '())
+ (set! *inline-funs* '())
+ (set! *inline-vars* '())
+ (set! *global-vars-list* '())
+ (set! *fast-vars-list* '())
+ (set! *var-make-list* '())
+ (set! *non-directcomp-list* '())
+ (set! *top-actions-list* '())
+ (do ((part lst (cdr part)))
+ ((null? part))
+ (let ((el (car part))
+ (tmp '()))
+ (cond
+ ((and (list? el)
+ (eq? 'begin (car el)))
+ (set! part (append el (cdr part))))
+ ((and (pair? el)
+ (or (eq? 'load (car el))
+ (eq? 'require (car el))))
+ (report-warning "ignoring a load on top level: " el))
+ ((or (not (pair? el))
+ (not (eq? 'define (car el)))
+ (null? (cdr el))
+ (not (list? el)))
+ ;; (report-error "the compiled file contains a non-definition: "
+ ;; el)
+ ;; (if (pair? el)
+ ;; (set! *non-directcomp-list* (cons el *non-directcomp-list*)))
+
+ (set! *top-actions-list* (cons el *top-actions-list*)))
+
+ ;; from here everything starts with 'define'.
+
+ ((or (pair? (cadr el)) ; the standard direct function def
+ (and (not (null? (cddr el)))
+ (pair? (caddr el))
+ (eq? 'lambda (car (caddr el)))))
+ ;;(and (pair? (cddr el))
+ ;; (pair? (caddr el))
+ ;; (memq (car (caddr el)) '(let let* letrec))
+ ;; (pair? (cddr (caddr el)))
+ ;; (pair? (caddr (caddr el)))
+ ;; (eq? 'lambda (car (caddr (caddr el)))))
+ ;; ;(not (find-if (lambda (x) (not (eq? (car x) (cadr x))))
+ ;; ; (cadr (caddr el))))
+ (let* ((def (normalize-top-define el))
+ (funname (cadr def))
+ (tmp '()))
+ (if (modified-fun? funname)
+ (set! *top-actions-list*
+ (cons (cons 'set! (cdr def)) *top-actions-list*))
+ (begin
+ (set! tmp (list *special-pseudoquote* funname))
+ (set! *top-actions-list* (cons tmp *top-actions-list*))
+ (set! *to-do-fun-list* (cons def *to-do-fun-list*))))))
+ ;; the following filters out macro defs:
+ ((and (pair? el)
+ (pair? (cdr el))
+ (eq? 'define (car el))
+ (not (pair? (cadr el)))
+ (pair? (cddr el))
+ (pair? (caddr el))
+ (eq? 'let (caaddr el))
+ (pair? (car (my-last-pair (caddr el))))
+ (eq? 'defmacro:transformer (caar (my-last-pair (caddr el))))))
+
+ ;; - - - from here everything will be a define-expression - - - -
+
+ ;;((and (pair? (caddr el))
+ ;; (not (eq? 'quote (car (caddr el))))
+ ;; (not (eq? 'quasiquote (car (caddr el)))))
+
+ ;; (set! *top-actions-list*
+ ;; (cons (cons 'set! (cdr el)) *top-actions-list*)))
+
+ ;;(set! tmp (make-pair-constant (caddr el)))
+ ;;(set! *top-actions-list*
+ ;; (cons (list 'set! (cadr el) (list *actual-c-eval* tmp))
+ ;; *top-actions-list*))
+ ;; (set! *via-interpreter-defined*
+ ;; (cons (cadr el) *via-interpreter-defined*))
+
+ ;; - - - - - - - - - declarations-part starts - - - - - - - - -
+ ((eq? (cadr el) *inline-declare*)
+ (set! *inline-funs* (append (cadr (caddr el)) *inline-funs*)))
+ ((eq? (cadr el) *inline-vars-declare*)
+ (set! *inline-vars* (append (cadr (caddr el)) *inline-vars*)))
+ ((eq? (cadr el) *allnumbers-declare*)
+ (set! *floats-flag* el))
+ ((eq? (cadr el) *all-funs-modified-declare*)
+ (set! *all-funs-modified-flag* #t))
+ ((eq? (cadr el) *new-funs-modified-declare*)
+ (set! *new-funs-modified-flag* #t))
+ ((eq? (cadr el) *stable-vectors-declare*)
+ (set! *stable-vector-names*
+ (append (cadr (caddr el))
+ *stable-vector-names*)))
+ ((eq? (cadr el) *fast-vars-declare*)
+ (set! *fast-vars-list*
+ (append (cadr (caddr el)) *fast-vars-list*)))
+ ((eq? (cadr el) *export-declare*)
+ (set! *export-functions*
+ (append (cadr (caddr el))
+ (if (pair? *export-functions*)
+ *export-functions*
+ '()))))
+ ;; - - - - - - - - -declarations-part ends - - - - - - - - - -
+ ((null? (cddr el)) ; form: (define foo)
+ (set! *global-vars-list* (cons (cadr el) *global-vars-list*))
+ (set! *top-actions-list*
+ (cons (list 'set! (cadr el) *unspecified*)
+ *top-actions-list*))
+ (if (not (memq (cadr el) *fast-vars-list*))
+ (set! *var-make-list*
+ (cons `(set!
+ ,(cadr el)
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string (cadr el)))
+ ,(string-length
+ (symbol->string (cadr el)))))))
+ *var-make-list*))))
+
+ (else ; form: (define foo <term>)
+ (set! *global-vars-list* (cons (cadr el) *global-vars-list*))
+ (set! *top-actions-list*
+ (cons (cons 'set! (cdr el)) *top-actions-list*))
+
+ ;;(if (symbol? (caddr el))
+ ;; ; the last el of define is a symbol; call intern:
+ ;; (set! *top-actions-list*
+ ;; (cons `(set!
+ ;; ,(cadr el)
+ ;; ,(list *actual-c-eval*
+ ;; (make-pair-constant-aux (caddr el))))
+ ;;(,*c-adr* (cdr (,*intern-function*
+ ;; (,*actual-c-string*
+ ;; ,(symbol->string (caddr el)))
+ ;; (,*actual-c-int*
+ ;; ,(string-length
+ ;; (symbol->string
+ ;; (caddr el)))))))
+ ;; *top-actions-list*))
+ ;; ; the last el of define is a non-list non-symbol:
+ ;; (set! *top-actions-list*
+ ;; (cons (cons 'set! (cdr el))
+ ;; *top-actions-list*)))
+ ;;(set! *via-interpreter-defined*
+ ;; (cons (cadr el) *via-interpreter-defined*))
+ (if (not (memq (cadr el) *fast-vars-list*))
+ (set! *var-make-list*
+ (cons `(set!
+ ,(cadr el)
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string (cadr el)))
+ ,(string-length
+ (symbol->string (cadr el)))))))
+ *var-make-list*)))))))
+ ;;(if (not (null? *top-actions-list*))
+ ;; (set! *to-do-fun-list*
+ ;; (cons (list 'define
+ ;; (make-globals-name file)
+ ;; (list* 'lambda
+ ;; '()
+ ;; (reverse (cons '() *top-actions-list*))))
+ ;; *to-do-fun-list*)))
+
+ ;; - - - - - - - - making the top-actions-fun - - - - - - -- - -
+
+ (let* ((init-all-list (reverse *top-actions-list*))
+ (init-all-splitted-lists (list '()))
+ (fname '())
+ (init-all-splitted-processed '())
+ (top-actions-fun '())
+ (split-nr 0))
+
+ ;; split up the big list
+ (do ((n 1 (+ n 1)))
+ ((null? init-all-list))
+ (if (> n *max-auxfun-size*)
+ (begin
+ (set! n 1)
+ (set! init-all-splitted-lists
+ (cons '() init-all-splitted-lists))))
+ (set! init-all-splitted-lists
+ (cons (cons (car init-all-list) (car init-all-splitted-lists))
+ (cdr init-all-splitted-lists)))
+ (set! init-all-list (cdr init-all-list)))
+
+ ;;(display "init-all-splitted-lists: ")
+ ;;(newline)
+ ;;(pretty-print init-all-splitted-lists)
+ ;;(newline)
+ (set! init-all-splitted-lists (reverse init-all-splitted-lists))
+ ;; process each sublist
+ (do ((lst init-all-splitted-lists (cdr lst)))
+ ((null? lst))
+ (set! split-nr (+ 1 split-nr))
+ (set! fname
+ (string->symbol
+ (string-append *top-actions-prefix*
+ (string-append
+ (number->string split-nr)
+ "_"
+ file))))
+ (set! *splitted-topaction-function-names*
+ (cons fname *splitted-topaction-function-names*))
+ (set! init-all-splitted-processed
+ (cons
+ (list 'define
+ fname
+ (list 'lambda
+ '()
+ (list* 'let* '() (reverse (car lst)))))
+ init-all-splitted-processed)))
+
+ ;;(display "init-all-splitted-processed: ")
+ ;;(newline)
+ ;;(pretty-print init-all-splitted-processed)
+ ;;(newline)
+
+ (set! top-actions-fun
+ (list
+ 'define (make-top-actions-funname file)
+ (list* 'lambda '()
+ (map list
+ (reverse *splitted-topaction-function-names*)))))
+
+ (set! *to-do-fun-list*
+ (cons top-actions-fun
+ (append init-all-splitted-processed
+ *to-do-fun-list*))))
+
+ ;; - - - - - - - - top-actions-fun is made and kept - - - - - - -
+ (set! *to-do-fun-list* (reverse *to-do-fun-list*))
+ (set! *non-directcomp-list* (reverse *non-directcomp-list*))
+ (set! *inline-funs-data* '())
+ (set! *inline-vars-data* '())
+ (do ((part *inline-vars* (cdr part)))
+ ((null? part))
+ (let ((tmp (member-if (lambda (x)
+ (and (pair? x)
+ (eq? 'set! (car x))
+ (eq? (cadr x) (car part))))
+ *top-actions-list*)))
+ (if tmp
+ (set! *inline-vars-data*
+ (cons (cdar tmp) *inline-vars-data*))
+ (set! *inline-vars* (remove (car part) *inline-vars*)))))
+ (do ((part *inline-funs* (cdr part)))
+ ((null? part))
+ (let ((tmp (member-if (lambda (x)
+ (or (eq? (cadr x) (car part))
+ (and (pair? (cadr x))
+ (eq? (caadr x) (car part)))))
+ *to-do-fun-list*)))
+ (if tmp
+ (set! *inline-funs-data*
+ (cons (list (car part)
+ (make-inline-body (car tmp)))
+ *inline-funs-data*))
+ (set! *inline-funs* (remove (car part) *inline-funs*))))))
+
+
+
+(define (normalize-top-define term)
+ (if (or (not (pair? (cdr term)))
+ (not (pair? (cddr term))))
+ (report-error "incorrect define: " term))
+ (if (pair? (cadr term))
+ `(define ,(caadr term) (lambda ,(cdadr term) ,@(cddr term)))
+ term))
+
+(define (make-inline-body def)
+ (let* ((tmp (rename-vars
+ (lettify-lambdas
+ (normalize-defines
+ (compile-quasiquote def))
+ 200
+ #t)))
+ (term (caddr tmp))
+ (body (cddr term)))
+ (cond ((not (list? (cadr term)))
+ (report-error "inline-function has a non-list arglist: "
+ def))
+ ((null? body)
+ (report-error "inline-function has no body: " def))
+ ((null? (cdr body))
+ term)
+ (else
+ (list (car term)
+ (cadr term)
+ (cons 'begin body))))))
+
+
+(define (make-initialization-function! file)
+ (let* ((nondefines
+ (map make-pair-constant *non-directcomp-list*))
+ (vector-elts
+ (map (lambda (x)
+ `(set! ,(string->symbol
+ (string-append
+ (symbol->string x)
+ *st-vector-postfix*))
+ (,*velts-function*
+ (,*global-access* ,x))))
+ *stable-vector-names*))
+ (init-all-list
+ (append
+ (init-closure-funs file *passed-defs*)
+ (init-interpretable-funs)
+ *var-make-list*
+ (reverse *symbol-list*)
+ (reverse *new-constant-list*)
+ (if (null? *top-actions-list*)
+ '()
+ (list
+ (list (make-top-actions-funname file))))
+ vector-elts
+ (map (lambda (x)
+ (list *c-eval-fun* x))
+ nondefines)))
+ (init-all-splitted-lists (list '()))
+ (init-all-splitted-processed '())
+ (split-nr 0)
+ (main-fun '())
+ (fname '()))
+
+
+ ;;(display "init-all-list: ")
+ ;;(newline)
+ ;;(pretty-print init-all-list)
+ ;;(newline)
+
+ ;; split up the big list
+ (do ((n 1 (+ n 1)))
+ ((null? init-all-list))
+ (if (> n *max-auxfun-size*)
+ (begin
+ (set! n 1)
+ (set! init-all-splitted-lists
+ (cons '() init-all-splitted-lists))))
+ (set! init-all-splitted-lists
+ (cons (cons (car init-all-list) (car init-all-splitted-lists))
+ (cdr init-all-splitted-lists)))
+ (set! init-all-list (cdr init-all-list)))
+
+ ;;(display "init-all-splitted-lists: ")
+ ;;(newline)
+ ;;(pretty-print init-all-splitted-lists)
+ ;;(newline)
+ (set! init-all-splitted-lists (reverse init-all-splitted-lists))
+ ;; process each sublist
+ (do ((lst init-all-splitted-lists (cdr lst)))
+ ((null? lst))
+ (set! split-nr (+ 1 split-nr))
+ (set! fname
+ (string->symbol
+ (string-append *init-fun-prefix*
+ (string-append
+ (number->string split-nr)
+ "_"
+ file))))
+ (set! *splitted-init-function-names*
+ (cons fname *splitted-init-function-names*))
+ (set! init-all-splitted-processed
+ (cons
+ (list 'define
+ fname
+ (list 'lambda
+ '()
+ (list* 'let* '() (reverse (car lst)))))
+ init-all-splitted-processed)))
+
+ ;;(display "init-all-splitted-processed: ")
+ ;;(newline)
+ ;;(pretty-print init-all-splitted-processed)
+ ;;(newline)
+
+ (set! main-fun
+ (list 'define
+ (string->symbol (string-append *init-fun-prefix* file))
+ (list 'lambda
+ '()
+ (list* 'let* '()
+ (map list
+ (reverse *splitted-init-function-names*))))))
+
+ (set! *passed-defs*
+ (append *passed-defs*
+ (append (reverse init-all-splitted-processed)
+ (list main-fun))))))
+
+
+(define (init-export-funs! file)
+ (let* ((res '())
+ (topactions-funname (make-top-actions-funname file)))
+ (set! *export-functions*
+ (remove (make-globals-name file) *export-functions*))
+ (for-each
+ (lambda (x)
+ (set! res (init-export-fun-aux x))
+ (if res
+ (for-each
+ (lambda (name)
+ (let ((fun (car (member-if
+ (lambda (x) (eq? (cadr x) name))
+ *passed-defs*))))
+ (subst-term-equal!
+ res (list *special-pseudoquote* (cadr x)) fun)))
+ (cons topactions-funname
+ *splitted-topaction-function-names*))))
+ *passed-defs*)))
+
+
+(define (init-export-fun-aux def)
+ (if (not (memq (cadr def) *export-functions*))
+ #f
+ (let* ((tmp1 (assq (cadr def) *export-table*))
+ (tmp (assq (cadr def) *wrapper-table*))
+ (arity '())
+ (flag '())
+ (res '()))
+ (cond (tmp (set! arity 'x))
+ ((begin
+ (set! arity (assq (cadr def) *dot-arg-templates*))
+ (and arity
+ (symbol? (cadr arity))))
+ (set! arity 'x))
+ (else (set! arity (cadr (caddr def)))))
+ (cond ((symbol? arity)
+ (set! flag 'tc7_lsubr))
+ (else
+ (set! flag
+ (cadr (assq (length arity)
+ '((0 tc7_subr_0)
+ (1 tc7_subr_1)
+ (2 tc7_subr_2)
+ (3 tc7_subr_3)))))))
+ (set! res
+ (list 'make_subr
+ (list *actual-c-string*
+ (if (memq (cadr def) *symbol-and-fun-list*)
+ (symbol->string
+ (make-closure-scmobj-name (cadr def)))
+ (symbol->string (cadr def))))
+ flag
+ (if tmp
+ (cadr tmp)
+ (if tmp1
+ (cadr tmp1)
+ (cadr def)))))
+ (if (memq (cadr def) *symbol-and-fun-list*)
+ (set! res `(set! (,*global-access*
+ ,(make-closure-scmobj-name (cadr def)))
+ ,res)))
+ res)))
+
+
+(define (init-closure-funs file defs)
+ (append
+ (map
+ (lambda (funname)
+ (let* ((procname (make-closure-scmobj-name funname))
+ (def-part '()))
+ (set! def-part (member-if (lambda (x) (eq? funname (cadr x))) defs))
+ `(set! ,procname ,(init-export-fun-aux (car def-part)))))
+ *lifted-trivial-closure-names*)
+ (map
+ (lambda (funname)
+ (let* ((procname (make-closure-scmobj-name funname)))
+ `(set! ,procname (make_subr (,*actual-c-string*
+ ,(symbol->string procname))
+ tc7_lsubr
+ ,funname))))
+ *lifted-closure-names*)))
+
+
+(define (init-interpretable-funs)
+ (map
+ (lambda (x)
+ (list 'set! (cdr x)
+ `(,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string (car x)))
+ ,(string-length
+ (symbol->string (car x))))))))
+ *interpreter-funname-table*))
+
+
+(define (make-globals-name file)
+ (string->symbol (string-append *init-globals-prefix* file)))
+
+(define (make-top-actions-funname file)
+ (string->symbol (string-append *top-actions-prefix* file)))
+
+(define (descmify str)
+ (let ((len (string-length str)))
+ (if (and (> len 4)
+ (string-ci=? ".scm" (substring str (- len 4) len)))
+ (substring str 0 (- len 4))
+ str)))
+
+
+
+
+(define (display-header fport)
+ (define *h-port* fport)
+ (define (headerline s)
+ (display s *h-port*)
+ (newline *h-port*))
+ (if *floats-flag* (headerline "#define FLOATS"))
+ (headerline "#include \"scmhob.h\"")
+ (headerline ""))
+
+(define (init-global)
+ (set! *floats-flag* #f)
+ (set! *tmp-vars* '())
+ (set! *new-fun-names* '())
+ (set! *new-fun-nr* 0)
+ (set! *higher-order-funs* '())
+ (set! *higher-order-templates* '())
+ (set! *new-parameter-nr* '0)
+ (set! *dot-arg-funs* '())
+ (set! *dot-arg-templates* '())
+ (set! *new-instnr* '0)
+ (set! *new-primitive-instnr* '0)
+ (set! *new-constant-list* '())
+ (set! *symbol-constant-table* '())
+ (set! *interpreter-funname-table* '())
+ (set! *new-constant-num* 0)
+ (set! *char-replacements-lists* '())
+ (set! *splitted-init-function-names* '())
+ (set! *splitted-topaction-function-names* '())
+ (set! *map1-needed-flag* #f)
+ (set! *for-each1-needed-flag* #f)
+ (set! *symbol-list* '())
+ (set! *unknown-functions* '())
+ (set! *unknown-vars* '())
+ (set! *top-level-funs* '())
+ (set! *inline-funs* '())
+ (set! *inline-vars* '())
+ (set! *export-functions* #f)
+ (set! *export-table* '())
+ (set! *wrapper-table* '())
+ (set! *stable-vector-names* '())
+ (set! *fast-vars-list* '())
+ (set! *closure-var-vectornames* '())
+ (set! *lifted-closures-to-do* '())
+ (set! *lifted-trivial-closure-names* '())
+ (set! *lifted-closure-names* '())
+ (set! *via-interpreter-defined* '())
+ (set! *special-c-vars* '())
+ (set! *closure-name-nr* 0)
+ (set! *closure-vector-name-nr* 0)
+ (set! *liftable-hof-database* '())
+ (set! *letrec-closure-nr* 0)
+ (set! *not-all-liftable-names* '())
+ (set! *all-funs-modified-flag* #f)
+ (set! *new-funs-modified-flag* #f)
+ (set! *symbol-and-fun-list* '())
+ (set! *hobbit-declaration-vars*
+ (list *inline-declare* *inline-vars-declare* *allnumbers-declare*
+ *all-funs-modified-declare* *new-funs-modified-declare*
+ *export-declare* *stable-vectors-declare* *fast-vars-declare*))
+ (set! *primitives*
+ (append (map car *switch-args-table*)
+ *cxr-funs*
+ *non-compiled-primitives*
+ (map car *floats-s->c-fun-table*)))
+ (do ((nr 1 (+ 1 nr)))
+ ((= nr *tmp-var-max*))
+ (set! *tmp-vars*
+ (cons (string->symbol (string-append *tmp-var-name*
+ (number->string nr)))
+ *tmp-vars*)))
+ (set! *tmp-vars* (reverse *tmp-vars*)))
+
+
+;; set-primitive-tables sets tables differently for the float and non-float case
+
+(define (set-primitive-tables)
+ (set! *num-arg-c-funs*
+ (append
+ (if *badivsgns-flag*
+ '()
+ '(quotient remainder))
+ (if *floats-flag*
+ '()
+ '(/))
+ '(logxor lognot logsleft logsright
+ = < > <= >= + - *
+ %= %< %> %<= %>= %+ %- %* %/)))
+ (set! *always-num-arg-c-funs*
+ ;;if *badivsgns-flag*
+ ;; '()
+ ;; '(quotient remainder))
+ '(logxor lognot logsleft logsright
+ %= %< %> %<= %>= %+ %- %* %/))
+ (set! *num-res-c-funs*
+ (append
+ (if *badivsgns-flag*
+ '()
+ '(quotient remainder))
+ (if *floats-flag*
+ '()
+ '(/))
+ '(logxor lognot logsleft logsright
+ + - *
+ %+ %- %* %/)))
+ (set! *bool-arg-c-funs*
+ (cons *and?* (cons *or?* (list *not?*))))
+ (set! *always-bool-res-c-funs*
+ (cons *and?*
+ (cons *or?*
+ (cons *not?*
+ '(boolean? symbol? char? vector? pair?
+ string? number? complex?
+ eq? char=? null?
+ %eqv? %zero? %negative? %positive? %number?
+ %= %< %> %<= %>= )))))
+ (set! *bool-res-c-funs*
+ (cons *and?*
+ (cons *or?*
+ (cons *not?*
+ '(boolean? symbol? char? vector? pair?
+ string? number? real? rational? complex?
+ integer?
+ eq? eqv? char=? null? zero? negative? positive?
+ = < > <= >=
+ %eqv? %zero? %negative? %positive? %number?
+ %= %< %> %<= %>= ))))))
+
+
+(define (report-warning . lst)
+ (display #\newline)
+ (display "COMPILER WARNING: ")
+ (display #\newline)
+ (for-each display lst)
+ (display #\newline))
+
+;;=================================================================
+;;
+;; final conversion to C
+;;
+;;=================================================================
+
+(define (write-c-*declaration var port)
+ (set! *c-port* port)
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c #\*)
+ (display-c-var var)
+ (display-c #\;)
+ (display-c-newline))
+
+(define (write-fun-declaration var port)
+ (set! *c-port* port)
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-var var)
+ (display-c "()")
+ (display-c #\;)
+ (display-c-newline))
+
+(define (write-c-static-declaration var port)
+ (set! *c-port* port)
+ (display-c "static ")
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-var var)
+ (display-c #\;)
+ (display-c-newline))
+
+
+(define (write-c-wholefun def port)
+ (let* ((fun (caddr def))
+ (top-let (caddr fun)))
+ (set! *c-port* port)
+ (set! *current-fun-name* (cadr def))
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-var (cadr def))
+ (display-c-lst (args->list (cadr fun)) #\( #f)
+ (display-c-newline)
+ (if (not (null? (cadr fun)))
+ (begin
+ (let ((scm-args (filter (lambda (x) (symbol? x)) (cadr fun)))
+ (fun-args (filter (lambda (x)
+ (and (pair? x) (eq? *function* (car x))))
+ (cadr fun)))
+ (ptr-args (filter (lambda (x)
+ (and (pair? x) (eq? *c-adr* (car x))))
+ (cadr fun))))
+ (if (not (null? ptr-args))
+ (begin
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-lst (map cadr ptr-args) #f #\*)
+ (display-c #\;)
+ (display-c-newline)))
+ (if (not (null? fun-args))
+ (begin
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-lst (map cadr fun-args) #f 'function)
+ (display-c #\;)
+ (display-c-newline)))
+ (if (not (null? scm-args))
+ (begin
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-lst scm-args #f #f)
+ (display-c #\;)
+ (display-c-newline))))))
+ (display-c #\{)
+ (display-c-newline)
+ (if (and (not (null? (cadr top-let)))
+ (find-if (lambda (x) (symbol? (car x))) (cadr top-let)))
+ (begin
+ (display-c-indent 1)
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-lst (filter (lambda (x) (symbol? x))
+ (map car (cadr top-let)))
+ #f #f)
+ (display-c #\;)
+ (display-c-newline)
+ (display-c-newline)))
+ (for-each (lambda (x)
+ (display-c-statement x 1))
+ (cddr top-let))
+ (display-c #\})
+ (display-c-newline)
+ (display-c-newline)))
+
+(define (display-c x)
+ (display x *c-port*))
+
+
+;;(define (write-c-string x)
+;; (write x *c-port*))
+
+(define (write-c-string x)
+ (display "\"" *c-port*)
+ (for-each
+ (lambda (c)
+ (cond
+ ((eq? c #\nl) (display "\\n" *c-port*))
+ ((eq? c #\") (display "\\\"" *c-port*))
+ ((eq? c #\ht) (display "\\t" *c-port*))
+ ((eq? c #\\) (display "\\\\" *c-port*))
+ (else (display c *c-port*))))
+ (string->list x))
+ (display "\"" *c-port*))
+
+
+(define (display-c-newline)
+ (newline *c-port*))
+
+(define (display-c-indent n)
+ (do ((m 0 (+ 1 m)))
+ ((= n m))
+ (display-c *c-indent*)))
+
+(define (display-c-lst lst par prefix)
+ (let ((separator #\,))
+ (cond ((char=? par #\()
+ (set! separator #\,)
+ (display-c #\())
+ ((char=? par #\{)
+ (set! separator #\;)
+ (display-c #\{))
+ (else
+ (set! separator #\,)))
+ (if (not (null? lst))
+ (begin
+ (for-each (lambda (x)
+ (cond ((and (pair? x)
+ (eq? 'set! (car x))
+ (eq? 3 (length x))
+ (eq? *dummy* (caddr x))))
+ ((or (char? prefix) (string? prefix))
+ (display-c prefix)
+ (display-c-expression x #t)
+ (display-c separator))
+ ((eq? 'function prefix)
+ (display-c "(*")
+ (display-c-expression x #t)
+ (display-c ") ()")
+ (display-c separator))
+ (else
+ (display-c-expression x #t)
+ (display-c separator))))
+ (butlast lst 1))
+ (cond ((or (char? prefix) (string? prefix))
+ (display-c prefix)
+ (display-c-expression (car (my-last-pair lst)) #t))
+ ((eq? 'function prefix)
+ (display-c "(*")
+ (display-c-expression (car (my-last-pair lst)) #t)
+ (display-c ") ()"))
+ (else
+ (display-c-expression (car (my-last-pair lst)) #t)))))
+ (cond ((char=? par #\()
+ (display-c #\)))
+ ((char=? par #\{)
+ (display-c #\;)
+ (display-c #\})))))
+
+
+
+
+(define (display-var var port)
+ (cond
+ ((eq? *listofnull* var)
+ (display "listofnull" port))
+ ((eq? *unspecified* var)
+ (display "UNSPECIFIED" port))
+ (else
+ (let* ((str (symbol->string var))
+ (char '())
+ (replacement '())
+ (len (string-length str))
+ (global-flag #f))
+ (if (and (symbol? var)
+ (char-numeric? (string-ref str 0)))
+ (display *c-num-symb-prefix* port))
+ (if (and (char=? #\* (string-ref str 0))
+ (char=? #\* (string-ref str (- len 1))))
+ (set! global-flag #t))
+ (do ((n 0 (+ 1 n)))
+ ((= n len))
+ (set! char (string-ref str n))
+ (cond ((and global-flag
+ (or (= 0 n) (= n (- len 1))))
+ char) ; do nothing
+ ((char-alphabetic? char)
+ (display (char-downcase char) port))
+ ((char-numeric? char)
+ (display char port))
+ ((begin
+ (set! replacement (assoc char *char-replacements*))
+ replacement)
+ (display (cadr replacement) port))
+ (else
+ (display char port))))
+ (cond ((memq var *c-keywords*)
+ (display *c-keyword-postfix* port))
+ (global-flag
+ (display *global-postfix* port)))))))
+
+
+(define (display-c-var var)
+ (display-var var *c-port*))
+
+
+(define (display-c-statement term n)
+ (let ()
+ (cond ((not (pair? term)))
+ ;; (display-c-indent n)
+ ;; (display-c #\;) ; empty operator
+ ;; (display-c-newline))
+ ((eq? 'if (car term))
+ (display-c-indent n)
+ (display-c "if(")
+ (display-c-expression (cadr term) #t)
+ (display-c #\))
+ (cond ((not (pair? (caddr term)))
+ (display-c #\space)
+ (display-c #\;) ; empty operator
+ (display-c-newline))
+ ((and (not (eq? 'begin (car (caddr term))))
+ (not (eq? 'if (car (caddr term)))))
+ (display-c-newline)
+ (display-c-statement (caddr term) (+ 1 n)))
+ ((eq? 'begin (car (caddr term)))
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x) (display-c-statement x (+ 1 n)))
+ (cdar (cddr term)))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ ((eq? 'if (car (caddr term)))
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (display-c-statement (car (cddr term)) (+ 1 n))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ (else (report-error "wrong syntax: " term)))
+ (cond ((null? (cdddr term))) ; do nothing
+ ((not (pair? (car (cdddr term))))) ; do nothing
+ ((and (not (eq? 'begin (caar (cdddr term))))
+ (not (eq? 'if (caar (cdddr term)))))
+ (display-c-indent n)
+ (display-c "else")
+ (display-c-newline)
+ (display-c-statement (car (cdddr term)) (+ 1 n)))
+ ((eq? 'begin (caar (cdddr term)))
+ (display-c-indent n)
+ (display-c "else")
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x) (display-c-statement x (+ 1 n)))
+ (cdar (cdddr term)))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ ((eq? 'if (caar (cdddr term)))
+ (display-c-indent n)
+ (display-c "else")
+ (display-c-newline)
+ (display-c-statement (car (cdddr term)) n))))
+ ((eq? (car term) *do-not*)
+ (display-c-indent n)
+ (display-c "for(")
+ (let ((lst1 (map (lambda (x) (list 'set! (car x) (cadr x)))
+ (cadr term)))
+ (lst2 (map (lambda (x) (list 'set! (car x) (caddr x)))
+ (filter (lambda (y) (not (null? (cddr y))))
+ (cadr term)))))
+ (if (not (null? lst1))
+ (display-c-lst lst1 #f #f))
+ (display-c #\;)
+ (if (> (length lst1) 1)
+ (begin
+ (display-c-newline) (display-c-indent n) (display-c " ")))
+ (display-c-expression (caar (cddr term)) #t)
+ (display-c #\;)
+ (if (and (> (length lst1) 1) (not (null? lst2)))
+ (begin
+ (display-c-newline) (display-c-indent n) (display-c " ")))
+ (if (not (null? lst2))
+ (display-c-lst lst2 #f #f))
+ (display-c #\))
+ (cond ((or (null? (cdddr term))
+ (not (find-if (lambda (x) (pair? x)) (cdddr term))))
+ (display-c #\space)
+ (display-c #\;) ; empty operator
+ (display-c-newline))
+ ((null? (cdr (cdddr term)))
+ (if (or (eq? 'begin (caar (cdddr term)))
+ (eq? *op-begin* (caar (cdddr term))))
+ (begin
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x)
+ (display-c-statement x (+ 1 n)))
+ (cdar (cdddr term)))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ (begin
+ (display-c-newline)
+ (display-c-statement (car (cdddr term))
+ (+ 1 n)))))
+ (else
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x)
+ (display-c-statement x (+ 1 n)))
+ (cdddr term))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline)))))
+ ((or (eq? (car term) 'begin) (eq? (car term) *op-begin*))
+ (display-c-indent n)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x) (display-c-statement x (+ 1 n)))
+ (cdr term))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ ((eq? (car term) *return*)
+ (display-c-indent n)
+ (display-c "return ")
+ (display-c-expression (cadr term) #t)
+ (display-c #\;)
+ (display-c-newline))
+ ((or (eq? *tailrec* (car term)) (eq? *mark-tailrec* (car term)))
+ (display-c "tailrecursion:")
+ (display-c-newline))
+ ((eq? *goto-tailrec* (car term))
+ (display-c-indent n)
+ (display-c "goto tailrecursion;")
+ (display-c-newline))
+ ((and (eq? 'set! (car term))
+ (eq? *dummy* (caddr term)))) ; do nothing
+ (else
+ (display-c-indent n)
+ (display-c-expression term)
+ (display-c #\;)
+ (display-c-newline)))))
+
+(define (display-c-expression term . no-par-flag)
+ (let ((fn (if (pair? term) (car term) '()))
+ (args (if (pair? term) (cdr term) '()))
+ (tmp #f))
+ (cond
+ ((symbol? term)
+ (display-c-var term))
+ ((number? term)
+ (display-c term)
+ (if *long-cast-flag* (display-c "L")))
+ ((boolean? term)
+ (if term (display-c *c-true*) (display-c *c-false*)))
+ ((char? term)
+ (if (printable-char? term)
+ (begin
+ (display-c #\')
+ (display-c term)
+ (display-c #\'))
+ (display-c (char->integer term))))
+ ((null? term)
+ (display-c *c-null*))
+ ((not (pair? term))
+ (report-error "wrong type of object for C: " term))
+ ((and (eq? *bool-c->s* fn)
+ (boolean? (car args)))
+ (if (car args)
+ (display-c "BOOL_T")
+ (display-c "BOOL_F")))
+ ((eq? *c-adr* fn)
+ (display-c #\&)
+ (display-c-expression (car args)))
+ ((eq? *c-fetch* fn)
+ (display-c #\*)
+ (display-c-expression (car args)))
+ ((eq? fn *higher-order-call*)
+ (display-c "(*")
+ (display-c-var (car args))
+ (display-c ")")
+ (display-c-lst (cdr args) #\( #f))
+ ((eq? *function* fn)
+ (display-c-expression (car args)))
+ ((or (eq? fn 'begin) (eq? fn *op-begin*))
+ (display-c-lst args #\( #f))
+ ((eq? fn *op-if*)
+ (display-c #\()
+ (display-c-expression (car args))
+ (display-c " ? ")
+ (display-c-expression (cadr args))
+ (display-c " : ")
+ (display-c-expression
+ (if (null? (cddr args))
+ *unspecified*
+ (caddr args)))
+ (display-c #\)))
+ ((eq? fn *actual-c-string*)
+ (display-c "(char *)")
+ (write-c-string (car args)))
+ ((eq? fn *actual-c-expr*)
+ (display-c (car args)))
+ ((eq? fn *actual-c-int*)
+ (display-c (car args)))
+ ((eq? fn *actual-c-eval*)
+ (display-c "eval(")
+ (display-c-var (car args))
+ (display-c ")"))
+ ((eq? 'set! fn)
+ (or (eq? *dummy* (cadr args))
+ (begin (display-c-expression (car args))
+ (display-c *c-infix-surround*)
+ (display-c "=")
+ (display-c *c-infix-surround*)
+ (display-c-expression (cadr args)))))
+ ((begin (set! tmp (assq fn *switch-args-table*))
+ tmp)
+ (display-c-expression (cons (cadr tmp) (reverse args))))
+ ((and (begin (set! tmp (assq fn *add-args-table*))
+ tmp)
+ (not (= (length args) (caddr tmp))))
+ (display-c-expression
+ (cons fn (append args (list (cadr tmp))))))
+
+ ((begin (if (memq fn '(vector string))
+ (set! args (list (normalize-list-for-c args))))
+ #f)) ; never succeeds
+ ((begin (set! tmp (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*)))
+ tmp)
+ (cond ((and (not (null? (cdddr tmp)))
+ (car (cdddr tmp)))
+ (if (or (null? no-par-flag)
+ (not (car no-par-flag)))
+ (display-c #\())
+ (display-c-expression (car args))
+ (display-c *c-infix-surround*)
+ (display-c (cadr tmp))
+ (display-c *c-infix-surround*)
+ (display-c-expression (cadr args))
+ (if (or (null? no-par-flag)
+ (not (car no-par-flag)))
+ (display-c #\))))
+ (else
+ (display-c (cadr tmp))
+ (display-c-lst args #\( #f))))
+ (else
+ (display-c-expression fn)
+ (display-c-lst args #\( #f)))))
+
+
+
+(define (printable-char? chr)
+ (or (char-alphabetic? chr)
+ (char-numeric? chr)
+ (memq chr '(#\! #\@ #\$ #\% #\^ #\& #\* #\( #\)
+ #\_ #\+ #\| #\- #\=
+ #\{ #\} #\[ #\]
+ #\; #\, #\. #\/
+ #\: #\" #\~ #\< #\> #\?
+ #\space))))
+
+
+(define *non-compiled-primitives*
+ '(apply call-with-current-continuation apply force delay load
+ map for-each list call-with-input-file call-with-output-file
+ open-input-file open-output-file with-input-from-file
+ with-output-to-file string-append
+ logical:logxor logical:lognot logical:logior logical:logand
+ logical:ash logical:logcount logical:integer-length
+ logical:bit-extract logical:integer-expt
+ defmacro:expand*
+ sin cos tan asin acos atan sinh cosh tanh asinh acosh
+ sin cos tan asin acos atan sinh cosh tanh asinh acosh
+ atanh sqrt expt integer-expt))
+
+(define *interpreter-defined-vars* '())
+;; '(*features*
+;; most-positive-fixnum most-negative-fixnum))
+
+;; defs in *extra-hobbit-primitive-defs* are used when the extra primitive
+;; is passed as an argument.
+
+(define *extra-hobbit-dot-primitives* '(%+ %- %* %/ %= %< %> %<= %>=))
+
+(define *extra-hobbit-primitive-defs*
+ '((logsleft (lambda (x y) (**return** (ash x y))))
+ (logsright (lambda (x y) (**return** (ash x (- y)))))
+ (%+ (lambda (x)
+ (let* ((r 0))
+ (do ((l x (cdr x))) ((null? l) (**return** r))
+ (set! r (%+ r (car l)))))))
+ (%- (lambda (x)
+ (let* ((r 0))
+ (do ((l x (cdr x))) ((null? l) (**return** r))
+ (set! r (%- r (car l)))))))
+ (%* (lambda (x)
+ (let* ((r 1))
+ (do ((l x (cdr x))) ((null? l) (**return** r))
+ (set! r (%* r (car l)))))))
+ (%/ (lambda (x)
+ (let* ((r 1))
+ (do ((l x (cdr x))) ((null? l) (**return** r))
+ (set! r (%/ r (car l)))))))
+ (%= (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%= (car l) (cadr l)))
+ (set! r #f))))))
+ (%< (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%< (car l) (cadr l)))
+ (set! r #f))))))
+ (%> (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%> (car l) (cadr l)))
+ (set! r #f))))))
+ (%>= (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%>= (car l) (cadr l)))
+ (set! r #f))))))
+ (%<= (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%<= (car l) (cadr l)))
+ (set! r #f))))))))
+
+(define *switch-args-table*
+ '((char>? char<?) (char-ci>? char-ci<?)
+ (char>=? char<=?) (char-ci>=? char-ci<=?)
+ (string>? string<?) (string-ci>? string-ci<?)
+ (string-ci>=? string-ci<=?) (string>=? string<=?)))
+
+(define *add-args-table*
+ (append
+ (list
+ (list 'make-vector '() 2)
+ (list 'number->string (list *num-c->s* 10) 2)
+ (list 'string->number (list *num-c->s* 10) 2)
+ (list 'make-string (list *actual-c-expr* "MAKICHR(' ')") 2))
+ '((quit 1 1)
+ (read (current-input-port) 1)
+ (read-char (current-input-port) 1)
+ (peek-char (current-input-port) 1)
+ (write (current-output-port) 2)
+ (display (current-output-port) 2)
+ (newline (current-output-port) 1)
+ (write-char (current-output-port) 2))))
+
+(define *standard-s->c-fun-table*
+ (append
+ (list (list 'force (symbol->string *force-function*) 1))
+ '((%eqv? "==" 2 #t #t)
+ (%zero? "ZERO_P" 1 #f #t)
+ (%positive? "POSITIVE_P" 1 #f #t)
+ (%negative? "NEGATIVE_P" 1 #f #t)
+ (%= "==" 2 #t #t)
+ (%< "<" 2 #t #t)
+ (%> ">" 2 #t #t)
+ (%<= "<=" 2 #t #t)
+ (%>= ">=" 2 #t #t)
+ (%+ "+" 2 #t #t)
+ (%- "-" 2 #t #t)
+ (%* "*" 2 #t #t)
+ (%/ "lquotient" 2 #f #f)
+ (cons "cons" 2) (car "CAR" 1) (cdr "CDR" 1)
+ (acons "acons" 3)
+ (list? "listp" 1) (length "length" 1) (append "append2" 2)
+ (reverse "reverse" 1) (list-tail "list_tail" 2) (list-ref "list_ref" 2)
+ (memq "memq" 2) (member "member" 2) (memv "memv" 2)
+ (assq "assq" 2) (assv "assv" 2) (assoc "assoc" 2)
+
+ (symbol->string "symbol2string" 1) (string->symbol "string2symbol" 1)
+ (system "lsystem" 1)
+ (verbose "prolixity" 1)
+ (copy-tree "copytree" 1)
+ (@copy-tree "copytree" 1)
+
+ (exact? "exactp" 1) (inexact? "inexactp" 1)
+ (odd? "oddp" 1) (even? "evenp" 1) (max "lmax" 2) (min "lmin" 2) (abs "absval" 1)
+ (quotient "lquotient" 2) (remainder "lremainder" 2)
+ (modulo "modulo" 2) (gcd "lgcd" 2) (lcm "llcm" 2)
+
+ (exact->inexact "EX2IN_FUN" 1) (floor "FLOOR_FUN" 1)
+ (ceiling "CEILING_FUN" 1)
+ (truncate "TRUNCATE_FUN" 1) (round "ROUND_FUN" 1)
+ ($sin "SIN_FUN" 1) ($cos "COS_FUN" 1) ($tan "TAN_FUN" 1)
+ ($asin "ASIN_FUN" 1)
+ ($acos "ACOS_FUN" 1) ($atan "ATAN_FUN" 1) ($sinh "SINH_FUN" 1)
+ ($cosh "COSH_FUN" 1)
+ ($tanh "TANH_FUN" 1) ($asinh "ASINH_FUN" 1) ($acosh "ACOSH_FUN" 1)
+ ($atanh "ATANH_FUN" 1)
+ ($sqrt "SQRT_FUN" 1) ($expt "EXPT_FUN" 2)
+ ($log "LOG_FUN" 1) ($abs "ABS_FUN" 1) ($exp "EXP_FUN" 1)
+
+ (inexact->exact "in2ex" 1)
+ (make-rectangular "makrect" 2) (make-polar "makpolar" 2)
+ (real-part "real_part" 1) (imag-part "imag_part" 1)
+ (magnitude "magnitude" 1) (angle "angle" 1)
+
+ (number->string "number2string" 2) (string->number "string2number" 1)
+
+ (char<? "CHAR_LESSP" 2) (char<=? "CHAR_LEQP" 2)
+ (char-ci=? "CHCI_EQ" 2) (char-ci<? "CHCI_LESSP")
+ (char-ci<=? "CHCI_LEQP" 2)
+
+ (char-alphabetic? "CHAR_ALPHAP" 1) (char-numeric? "CHAR_NUMP" 1)
+ (char-whitespace? "CHAR_WHITEP" 1) (char-upper-case? "CHAR_UPPERP" 1)
+ (char-lower-case? "CHAR_LOWERP" 1)
+
+ (char->integer "CHAR2INT" 1) (integer->char "INT2CHAR" 1)
+ (char-upcase "CHAR_UPCASE" 1) (char-downcase "CHAR_DOWNCASE" 1)
+
+ (make-string "make_string" 2)
+ (string "string" 1)
+ (string-length "ST_LENGTH" 1)
+ (string-ref "ST_REF" 2)
+ (string-set! "st_set" 3)
+ (substring "substring" 3)
+ (string-append "st_append" 1)
+ (list->string "string" 1)
+ (string->list "string2list" 1)
+ (string-copy "string_copy" 1)
+ (string-fill! "string_fill" 2)
+ (string=? "st_equal" 2) (string<? "st_lessp" 2) (string<=? "st_leqp" 2)
+ (string-ci=? "stci_equal" 2) (string-ci<? "stci_lessp")
+ (string-ci<=? "stci_leqp" 2)
+
+ (make-vector "make_vector" 2)
+ (vector "vector" 1)
+ (vector-length "VECTOR_LENGTH" 1)
+
+ (vector-ref "vector_ref" 2)
+ (vector-set! "vector_set" 3)
+ (vector->list "vector2list" 1)
+ (list->vector "vector" 1)
+
+ (read "lread" 1)
+ (read-char "scm_read_char" 1)
+ (peek-char "peek_char" 1)
+ (eof-object? "eof_objectp" 1)
+ (write "lwrite" 2)
+ (display "display" 2)
+ (newline "newline" 1)
+ (write-char "write_char" 2)
+
+ (input-port? "input_portp" 1)
+ (output-port? "output_portp" 1)
+ (current-input-port "cur_input_port" 0)
+ (current-output-port "cur_output_port" 0)
+ (close-input-port "close_port" 1)
+ (close-output-port "close_port" 1)
+
+ (get-internal-run-time "my_time" 0)
+ (quit "quit" 1)
+ (abort "abrt" 0)
+ (restart "restart" 0)
+ (chdir "chdir" 1)
+ (delete-file "del_fil" 1)
+ (rename-file "ren_fil" 2))))
+
+
+ ;;; (<s-fn> <c-fn> <nr-args> <infix-flag> <c-flag>)
+
+(define *reckless-s->c-fun-table*
+ (append
+
+ (if *badivsgns-flag*
+ '()
+ '((quotient "/" 2 #t #t)
+ (remainder "%" 2 #t #t)
+ (/ "/" 2 #t #t)))
+
+ (list
+ (list *sysapply* "apply" 3 #f #f)
+ (list *make-cclo* "makcclo" 2 #f #f)
+ (list *global-access* "GLOBAL" 1 #f #f)
+ (list *velts-function* "VELTS" 1 #f #f)
+ (list *st-vector-ref* "STBL_VECTOR_REF" 2 #f #f)
+ (list *st-vector-set* "STBL_VECTOR_SET" 3 #f #f)
+ (list *not?* "!" 1 #f #t)
+ (list *and?* "&&" 2 #t #t)
+ (list *or?* "||" 2 #t #t)
+ (list *open-file-function* "open_file" 2 #f #f)
+ (list *set-current-input-port-function* "set_inp" 1 #f #f)
+ (list *set-current-output-port-function* "set_outp" 1 #f #f)
+ (list *num-s->c* "INUM" 1 #f #f)
+ (list *num-c->s* "MAKINUM" 1 #f #f)
+ (list *bool-s->c* "NFALSEP" 1 #f #f)
+ (list *bool-c->s* "SBOOL" 1 #f #f)
+ (list *char-c->s* "MAKICHR" 1 #f #f))
+
+ '((boolean? "BOOLEAN_P" 1 #f #t)
+ (symbol? "SYMBOL_P" 1 #f #t)
+ (char? "CHAR_P" 1 #f #t)
+ (vector? "VECTOR_P" 1 #f #t)
+ (pair? "PAIR_P" 1 #f #t)
+ (number? "NUMBER_P" 1 #f #t)
+ (complex? "NUMBER_P" 1 #f #t)
+ (real? "NUMBER_P" 1 #f #t)
+ (rational? "NUMBER_P" 1 #f #t)
+ (integer? "INTEGER_P" 1 #f #t)
+ (string? "STRING_P" 1 #f #t)
+ (procedure? "procedurep" 1 #f #t)
+
+ (not "NOT" 1 #f #f)
+ (eq? "==" 2 #t #t)
+ (eqv? "==" 2 #t #t)
+ (char=? "==" 2 #t #t)
+ (null? "NULL_P" 1 #f #t)
+ (zero? "ZERO_P" 1 #f #t)
+ (positive? "POSITIVE_P" 1 #f #t)
+ (negative? "NEGATIVE_P" 1 #f #t)
+
+ (logand "&" 2 #t #t)
+ (logior "|" 2 #t #t)
+ (logxor "^" 2 #t #t)
+ (lognot "~" 1 #f #t)
+ (logsleft "<<" 2 #t #t)
+ (logsright ">>" 2 #t #t)
+
+ (= "==" 2 #t #t)
+ (< "<" 2 #t #t)
+ (> ">" 2 #t #t)
+ (<= "<=" 2 #t #t)
+ (>= ">=" 2 #t #t)
+
+ (+ "+" 2 #t #t)
+ (- "-" 2 #t #t)
+ (* "*" 2 #t #t)
+
+ (/ "lquotient" 2 #f #f)
+ (set-car! "SET_CAR" 2 #f #t)
+ (set-cdr! "SET_CDR" 2 #f #t)
+ (vector-set! "VECTOR_SET" 3 #f #t)
+ (vector-ref "VECTOR_REF" 2 #f #t)
+
+ (equal? "equal" 2))
+
+ *standard-s->c-fun-table*))
+
+(define *floats-s->c-fun-table*
+ (append
+
+ (list
+ (list *sysapply* "apply" 3 #f #f)
+ (list *make-cclo* "makcclo" 2 #f #f)
+ (list *global-access* "GLOBAL" 1 #f #f)
+ (list *velts-function* "VELTS" 1 #f #f)
+ (list *st-vector-ref* "STBL_VECTOR_REF" 2 #f #f)
+ (list *st-vector-set* "STBL_VECTOR_SET" 3 #f #f)
+ (list *not?* "!" 1 #f #t)
+ (list *and?* "&&" 2 #t #t)
+ (list *or?* "||" 2 #t #t)
+ (list *open-file-function* "open_file" 2 #f #f)
+ (list *set-current-input-port-function* "set_inp" 1 #f #f)
+ (list *set-current-output-port-function* "set_outp" 1 #f #f)
+ (list *num-s->c* "INUM" 1 #f #f)
+ (list *num-c->s* "MAKINUM" 1 #f #f)
+ (list *bool-s->c* "NFALSEP" 1 #f #f)
+ (list *bool-c->s* "SBOOL" 1 #f #f)
+ (list *char-c->s* "MAKICHR" 1 #f #f))
+
+ '((boolean? "BOOLEAN_P" 1 #f #t)
+ (symbol? "SYMBOL_P" 1 #f #t)
+ (char? "CHAR_P" 1 #f #t)
+ (vector? "VECTOR_P" 1 #f #t)
+ (pair? "PAIR_P" 1 #f #t)
+ (number? "NUMBERP" 1 #f #t) ;;; diff from the int case; scm.h macro
+ (complex? "NUMBERP" 1 #f #t) ;;; not in the int case; scm.h macro
+ (real? "realp" 1 #f #t) ;;; not in the int case;
+ (rational? "realp" 1 #f #t) ;;; not for int; ONLY for FLOATS
+ (integer? "intp" 1 #f #t) ;;; not for int; ONLY for FLOATS
+ (string? "STRING_P" 1 #f #t)
+ (procedure? "procedurep" 1 #f #t)
+
+ (not "NOT" 1 #f #f)
+ (eq? "==" 2 #t #t)
+ (eqv? "eqv" 2 #f #t);; diff for int
+ (char=? "==" 2 #t #t)
+ (null? "NULL_P" 1 #f #t)
+ (zero? "zerop" 1 #f #t);; diff for int
+ (positive? "positivep" 1 #f #t);; diff for int
+ (negative? "negativep" 1 #f #t);; diff for int
+
+ (logand "&" 2 #t #t)
+ (logior "|" 2 #t #t)
+ (logxor "^" 2 #t #t)
+ (lognot "~" 1 #f #t)
+ (logsleft "<<" 2 #t #t)
+ (logsright ">>" 2 #t #t)
+
+ (= "eqp" 2 #f #t);; diff for int
+ (< "lessp" 2 #f #t);; diff for int
+ (> "greaterp" 2 #f #t);; diff for int
+ (<= "leqp" 2 #f #t);; diff for int
+ (>= "greqp" 2 #f #t);; diff for int
+
+ (+ "sum" 2 #f #t);; diff for int
+ (- "difference" 2 #f #t);; diff for int
+ (* "product" 2 #f #t);; diff for int
+
+ (/ "divide" 2 #f #f);; diff for int
+ (quotient "lquotient" 2 #f #f)
+ (remainder "lremainder" 2 #f #f)
+
+ (set-car! "SET_CAR" 2 #f #t)
+ (set-cdr! "SET_CDR" 2 #f #t)
+ (vector-set! "VECTOR_SET" 3 #f #t)
+ (vector-ref "VECTOR_REF" 2 #f #t)
+
+ (equal? "equal" 2))
+
+ *standard-s->c-fun-table*))
+
+
+(define (primitive? fn)
+ (or (member fn *cxr-funs*)
+ (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*))
+ (assq fn *switch-args-table*)
+ (assq fn *add-args-table*)
+ (member fn '(list append cond case do let let* letrec define
+ if and or map for-each))))
+
+(define (fixed-arity-primitive? fn)
+ (or (member fn *cxr-funs*)
+ (and (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*))
+ (not (assq fn *associative-fun-table*))
+ (not (assq fn *comparison-fun-table*))
+ (not (assq fn *add-args-table*))
+ (not (member fn '(list append cond case do let let* letrec
+ define if and or map for-each
+ < > <= = >= + * - /
+ %< %> %<= %= %>= %+ %* %- %/ ))))
+ (assq fn *switch-args-table*)))
+
+(define (primitive-arity fn)
+ (let ((tmp (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*))))
+ (cond (tmp (caddr tmp))
+ ((memq fn *cxr-funs*) 1)
+ (else #f))))
+
+;===================================================================
+;
+; introducing type conversion,
+; collecting constants,
+; moving variables to top-let.
+;
+;===================================================================
+
+
+(define (type-const-wholedef term)
+ (set! *local-vars* '())
+ (set! *local-parameters*
+ (map (lambda (x) (if (pair? x) (cadr x) x))
+ (cadr (caddr term))))
+ (set! *current-fun-name* (cadr term))
+ (let* ((tmp (map type-const-pass (cddr (caddr term))))
+ (tmp2 (list 'lambda
+ (cadr (caddr term))
+ (cons 'let*
+ (cons (map (lambda (x) (list x *dummy*))
+ *local-vars*)
+ (begins->list tmp))))))
+ (list (car term) (cadr term) tmp2)))
+
+
+
+(define (begins->list lst)
+ (let ((res '()))
+ (do ((part lst (cdr part)))
+ ((null? part))
+ (if (and (pair? (car part))
+ (or (eq? 'begin (caar part))
+ (eq? *op-begin* (caar part))))
+ (set! res (append (reverse (begins->list (cdar part))) res))
+ (set! res (cons (car part) res))))
+ (reverse res)))
+
+
+(define (type-const-pass-res term)
+ (cond
+ ((string? term)
+ (make-string-constant term))
+ ((char? term)
+ (list *char-c->s* term))
+ ((vector? term)
+ (make-vector-constant term))
+ ((number? term)
+ (if (and (integer? term)
+ (exact? term)
+ (<= term most-positive-fixnum)
+ (>= term most-negative-fixnum))
+ (list *num-c->s* term)
+ (begin
+ (if (not *floats-flag*)
+ (report-warning
+ "exact arithmetic assumed but a nonexact number encountered: " term))
+ (make-number-constant term))))
+ ((symbol? term)
+ (cond ((or (memq term *local-parameters*)
+ (memq term *local-vars*)
+ (memq term *special-c-vars*)
+ (memq term *special-scm->c-functions*))
+ term)
+ ((memq term *fast-vars-list*)
+ term)
+ ((memq term *interpreter-defined-vars*)
+ (list *global-access* term))
+ ((memq term *global-vars-list*)
+ (list *global-access* term))
+ ((or (member-if (lambda (x) (eq? term (cadr x)))
+ *new-constant-list*)
+ (member-if (lambda (x) (eq? term (cadr x)))
+ *symbol-constant-table*)
+ (in-file-defined? term))
+ term)
+ (else (or (memq term *unknown-vars*)
+ (set! *unknown-vars* (cons term *unknown-vars*)))
+ (list *global-access* (make-unknown-constant term)))))
+ ((boolean? term)
+ (list *bool-c->s* term))
+ ((null? term)
+ '())
+ ((not (pair? term))
+ (report-error "disallowed object: " term))
+ ((eq? *special-pseudoquote* (car term))
+ term)
+ ((eq? *actual-c-string* (car term))
+ term)
+ ((eq? *actual-c-int* (car term))
+ term)
+ ((eq? *actual-c-eval* (car term))
+ term)
+ ((eq? 'quote (car term))
+ (cond ((or (string? (cadr term))
+ (vector? (cadr term))
+ (number? (cadr term))
+ (boolean? (cadr term))
+ (char? (cadr term))
+ (null? (cadr term)))
+ (type-const-pass (cadr term)))
+ ((symbol? (cadr term))
+ (make-symbol-constant (cadr term)))
+ ((pair? (cadr term))
+ (make-pair-constant (cadr term)))
+ (else
+ (report-error "disallowed object: " term))))
+ ((and
+ *reckless-arithmetic-flag*
+ (not (modified-fun? (car term)))
+ (or (memq (car term) *always-num-arg-c-funs*)
+ (and (not *floats-flag*)
+ (memq (car term) *num-arg-c-funs*))))
+ (let* ((tmp (map type-const-pass (cdr term)))
+ (tmp2
+ (cons (car term)
+ (map (lambda (x)
+ (if (and (pair? x)
+ (eq? (car x) *num-c->s*))
+ (cadr x)
+ (list *num-s->c* x)))
+ tmp))))
+ (cond ((memq (car term) *num-res-c-funs*)
+ (list *num-c->s* tmp2))
+ ((memq (car term) '(= < <= > >= %= %< %<= %> %>=))
+ (cond
+ ((and (pair? (cadr tmp2))
+ (pair? (caddr tmp2))
+ (eq? (car (cadr tmp2)) (car (caddr tmp2)))
+ (eq? *num-s->c* (car (cadr tmp2))))
+ (list *bool-c->s*
+ (cons (car term) (map cadr (cdr tmp2)))))
+ ((or (and (not (pair? (cadr tmp2)))
+ (pair? (caddr tmp2)))
+ (and (not (pair? (caddr tmp2)))
+ (pair? (cadr tmp2))))
+ (list *bool-c->s* (cons (car term) tmp)))
+ (else
+ (list *bool-c->s* tmp2))))
+ ((and (not *floats-flag*)
+ (memq (car term) *bool-res-c-funs*))
+ (list *bool-c->s* tmp2))
+ ((memq (car term) *always-bool-res-c-funs*)
+ (list *bool-c->s* tmp2))
+ (else
+ tmp2))))
+ ((and (or (memq (car term) '(eq? char=? %eqv? %=))
+ (and (not *floats-flag*)
+ (or (eq? 'eqv? (car term))
+ (eq? '= (car term)))))
+ (not (modified-fun? (car term))))
+ (let ((tmp (map type-const-pass (cdr term))))
+ (if (and (pair? (car tmp))
+ (memq (caar tmp) *type-converters*)
+ (pair? (cadr tmp))
+ (memq (caadr tmp) *type-converters*))
+ (list *bool-c->s* (cons (car term) (map cadr tmp)))
+ (list *bool-c->s* (cons (car term) tmp)))))
+ ((and (memq (car term) *bool-arg-c-funs*)
+ (not (modified-fun? (car term))))
+ (let* ((tmp (map type-const-pass (cdr term)))
+ (tmp2 (cons (car term) (map c-boolify tmp))))
+ (if (memq (car term) *bool-res-c-funs*)
+ (list *bool-c->s* tmp2)
+ tmp2)))
+ ((and (not *floats-flag*)
+ (memq (car term) *bool-res-c-funs*)
+ (not (modified-fun? (car term))))
+ (list *bool-c->s*
+ (cons (car term) (map type-const-pass (cdr term)))))
+ ((and (memq (car term) *always-bool-res-c-funs*)
+ (not (modified-fun? (car term))))
+ (list *bool-c->s*
+ (cons (car term) (map type-const-pass (cdr term)))))
+ ((or (eq? 'if (car term)) (eq? *op-if* (car term)))
+ (let ((tmp (map type-const-pass (cdr term))))
+ (cons (car term)
+ (cons (c-boolify (car tmp)) (cdr tmp)))))
+ ((eq? (car term) 'let*)
+ (set! *local-vars* (union (map car (cadr term)) *local-vars*))
+ (cons 'begin
+ (map type-const-pass
+ (begins->list
+ (append (map (lambda (x) (cons 'set! x)) (cadr term))
+ (cddr term))))))
+ ((eq? (car term) *op-let*)
+ (set! *local-vars* (union (map car (cadr term)) *local-vars*))
+ (cons *op-begin*
+ (map type-const-pass
+ (begins->list
+ (append (map (lambda (x) (cons 'set! x)) (cadr term))
+ (cddr term))))))
+ ((or (eq? 'begin (car term)) (eq? *op-begin* (car term)))
+ (cons (car term)
+ (begins->list (map type-const-pass (cdr term)))))
+ ((eq? (car term) 'do)
+ (set! *local-vars* (union (map car (cadr term)) *local-vars*))
+ (let ((tmp (list* 'do
+ (map (lambda (x) (map type-const-pass x))
+ (cadr term))
+ (map type-const-pass (caddr term))
+ (map type-const-pass (cdddr term)))))
+ (if (null? (cdr (caddr tmp)))
+ (cons *do-not*
+ (begins->list
+ (cons (cadr tmp)
+ (cons (cons (c-negate
+ (c-boolify
+ (car (caddr tmp))))
+ (cdr (caddr tmp)))
+ (cdddr tmp)))))
+ (cons
+ 'begin
+ (begins->list
+ (cons
+ (cons *do-not*
+ (begins->list
+ (cons (cadr tmp)
+ (cons (list
+ (c-negate
+ (c-boolify
+ (car (caddr tmp)))))
+ (cdddr tmp)))))
+ (begins->list (cdr (caddr tmp)))))))))
+ ((eq? *function* (car term))
+ (cond ((or (memq (cadr term) *local-vars*)
+ (memq (cadr term) *local-parameters*))
+ (list *function* (cadr term)))
+ ((memq (cadr term) *top-level-funs*)
+ ; (report-error
+ ; "In " *current-fun-name* " compiled function "
+ ; (cadr term) " occurs as an argument. Use lambdaterm!")
+ (list *function* (cadr term)))
+ ((in-file-defined? (cadr term))
+ (list *function* (cadr term)))
+ (else
+ (report-error
+ "In " *current-fun-name* " interpreted function "
+ (cadr term) " occurs as an argument. Use lambdaterm!"))))
+ ((and (memq (car term) *cxr-funs*)
+ (not (modified-fun? (car term))))
+ (cxr-open (car term) (type-const-pass (cadr term))))
+ ; the following always fails
+ ((begin (set! term (fun-names-to-refs term)) #f))
+ ((unknown-function? (car term) (cdr term))
+ (make-unknown-call term))
+ ((and (eq? (car term) 'vector-set!)
+ (memq (cadr term) *stable-vector-names*))
+ (cons *st-vector-set*
+ (cons (string->symbol
+ (string-append
+ (symbol->string (cadr term))
+ *st-vector-postfix*))
+ (map type-const-pass (cddr term)))))
+ ((and (eq? (car term) 'vector-ref)
+ (memq (cadr term) *stable-vector-names*))
+ (cons *st-vector-ref*
+ (cons (string->symbol
+ (string-append
+ (symbol->string (cadr term))
+ *st-vector-postfix*))
+ (map type-const-pass (cddr term)))))
+ (else
+ (cons (car term)
+ (map type-const-pass (cdr term))))))
+
+(define (type-const-pass term)
+ (define res (type-const-pass-res term))
+ (if (and (pair? res) (or (eq? 'begin (car res))
+ (eq? *op-begin* (car res))))
+ (cons (car res) (begins->list (cdr res)))
+ res))
+
+
+(define (fun-names-to-refs term)
+ (let ((hofdata (assq (car term) *liftable-hof-database*))
+ (tmp '()))
+ (if hofdata
+ (cons (car term)
+ (map (lambda (flag arg)
+ (cond
+ ((not (symbol? arg)) arg)
+ (flag arg)
+ (else (fun-names-to-refs-aux arg))))
+ (cdr hofdata)
+ (cdr term)))
+ (cons (car term)
+ (map (lambda (arg)
+ (if (symbol? arg)
+ (fun-names-to-refs-aux arg)
+ arg))
+ (cdr term))))))
+
+(define (fun-names-to-refs-aux name)
+ (if (and (not (memq name *local-parameters*))
+ (not (memq name *local-vars*))
+ (in-file-defined? name))
+ (let ((newname (make-closure-scmobj-name name)))
+ (if (not (memq name *symbol-and-fun-list*))
+ (begin
+ (set! *var-make-list*
+ (cons `(set!
+ ,(make-closure-scmobj-name name)
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string name))
+ ,(string-length
+ (symbol->string name))))))
+ *var-make-list*))
+ (set! *symbol-and-fun-list* (cons name *symbol-and-fun-list*))))
+ (list *global-access* newname))
+ name))
+
+
+(define (unknown-function? fn args)
+ (let ((len (length args)))
+ (or
+ (pair? fn)
+ (modified-fun? fn)
+ (not
+ (or (let ((tmp (memq fn *prohibited-funs*)))
+ (if tmp
+ (report-error "In " *current-fun-name*
+ " a prohibited function "
+ fn " is called."))
+ #f)
+ (eq? fn *current-fun-name*)
+ (memq fn *special-scm->c-functions*)
+ (assq fn *switch-args-table*)
+ (assq fn *add-args-table*)
+ (memq fn '(vector string if begin let* lambda set!))
+ (memq fn *internal-c-functions*)
+ (let ((tmp (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*))))
+ (if (and tmp (not (eqv? len (caddr tmp))))
+ (report-error "In " *current-fun-name* " function "
+ fn " is called with a wrong nr of args."))
+ tmp)
+ (let ((tmp (member-if (lambda (x) (eq? fn (cadr x)))
+ *to-do-fun-list*)))
+ (if (and tmp (not (eqv? len (length (cadr (caddar tmp))))))
+ (if (memq fn *top-level-funs*)
+ (report-error "In " *current-fun-name* " function "
+ fn " is called with a wrong nr of args.")
+ (report-error "In " *current-fun-name* " function "
+ fn
+ " is called with a wrong nr of args or builds closures.")))
+ tmp)
+ (let ((tmp (member-if (lambda (x) (eq? fn (cadr x))) *passed-defs*)))
+ (if (and tmp (not (eqv? len (length (cadr (caddar tmp))))))
+ (if (memq fn *top-level-funs*)
+ (report-error "In " *current-fun-name* " function "
+ fn " is called with a wrong nr of args.")
+ (report-error "In " *current-fun-name* " function "
+ fn
+ " is called with a wrong nr of args or builds closures.")))
+ tmp)
+ (memq fn *top-level-funs*))))))
+
+
+(define (in-file-defined? fn)
+ (or (memq fn *top-level-funs*)
+ (eq? fn *current-fun-name*)
+ (member-if (lambda (x) (eq? fn (cadr x))) *to-do-fun-list*)
+ (member-if (lambda (x) (eq? fn (cadr x))) *passed-defs*)))
+
+(define (top-nonlist-in-file-defined? fn)
+ (let ((x (or (member-if
+ (lambda (x) (or (eq? fn (cadr x))
+ (and (pair? (cadr x)) (eq? fn (caadr x)))))
+ *to-do-fun-list*)
+ (member-if
+ (lambda (x) (or (eq? fn (cadr x))
+ (and (pair? (cadr x)) (eq? fn (caadr x)))))
+ *passed-defs*))))
+ (and x
+ (let ((y (car x)))
+ (if (pair? (cadr y))
+ (list? (cadr y))
+ (and (pair? (cddr y))
+ (pair? (caddr y))
+ (eq? 'lambda (car (caddr y)))
+ (pair? (cdr (caddr y)))
+ (list? (cadr (caddr y)))))))))
+
+(define (make-unknown-call term)
+ (let* ((fn (car term))
+ (args1 (map type-const-pass (cdr term)))
+ (args (map make-interpreter-usable args1))
+ (glob '()))
+ (if (pair? fn)
+ (set! glob (type-const-pass (car term)))
+ (if (or (memq fn *special-c-vars*)
+ (memq fn *local-parameters*)
+ (memq fn *local-vars*))
+ (set! glob fn)
+ (set! glob (list *global-access* (make-unknown-constant fn)))))
+ (or (pair? fn)
+ (memq fn *special-c-vars*)
+ (memq fn *local-parameters*)
+ (memq fn *local-vars*)
+ (memq fn *unknown-functions*)
+ (set! *unknown-functions* (cons fn *unknown-functions*)))
+ (list *sysapply*
+ glob
+ (if (null? args) '() (car args))
+ (if (null? args)
+ '()
+ (make-apply-second-arg (cdr args))))))
+
+(define (make-unknown-call-aux term args)
+ (let ((fn (caar term)))
+ (if (or (in-file-defined? fn)
+ (memq fn *prohibited-funs*))
+ (report-error "In " *current-fun-name* " function "
+ fn " is assumed to return a closure.")
+ (make-unknown-call (car term)))))
+
+
+(define (make-interpreter-usable term)
+ (let ((fn (if (pair? term)
+ (if (and (eq? *global-access* (car term))
+ (in-file-defined? (cadr term)))
+ (cadr term)
+ #f)
+ (if (and (symbol? term)
+ (in-file-defined? term))
+ term
+ #f)))
+ (tmp '()))
+ (if (not fn)
+ term
+ (make-interpreter-funname fn))))
+
+
+(define (make-interpreter-funname fn)
+ (let ((tmp (assq fn *interpreter-funname-table*)))
+ (if tmp
+ (cdr tmp)
+ (begin
+ (set! tmp
+ (string->symbol
+ (string-append (symbol->string fn) *interpreter-suffix*)))
+ (set! *interpreter-funname-table*
+ (cons (cons fn tmp) *interpreter-funname-table*))
+ (list *global-access* tmp)))))
+
+(define (make-unknown-constant var)
+ (if (memq var *global-vars-list*)
+ var
+ (begin
+ (set! *global-vars-list* (cons var *global-vars-list*))
+ (set! *var-make-list*
+ (cons `(set!
+ ,var
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string var))
+ ,(string-length
+ (symbol->string var))))))
+ *var-make-list*))
+ var)))
+
+(define (make-apply-second-arg args)
+ (if (null? args)
+ *listofnull*
+ (list 'cons
+ (car args)
+ (make-apply-second-arg (cdr args)))))
+
+
+
+(define (make-string-constant str)
+ (let ((name (make-constant-name)))
+ (set! *new-constant-list*
+ (cons (list 'set!
+ name
+ (list 'scm-gc-protect
+ (list *makfromstr-function*
+ (list *actual-c-string* str)
+ (string-length str))))
+ *new-constant-list*))
+ name))
+
+(define (make-number-constant num)
+ (let ((name (make-constant-name))
+ (str (number->string num)))
+ (set! *new-constant-list*
+ (cons (list 'set!
+ name
+ (list 'scm-gc-protect
+ (list *string->number-function*
+ (list *makfromstr-function*
+ (list *actual-c-string* str)
+ (string-length str))
+ (list *num-c->s* 10))))
+ *new-constant-list*))
+ name))
+
+
+(define (make-vector-constant vect)
+ (let* ((name (make-constant-name))
+ (tmp (list 'set!
+ name
+ (list 'scm-gc-protect
+ (list 'list->vector
+ (make-pair-constant-aux
+ (vector->list vect)))))))
+ (set! *new-constant-list* (cons tmp *new-constant-list*))
+ name))
+
+
+(define (make-pair-constant pair)
+ (let* ((name (make-constant-name))
+ (tmp (list 'set!
+ name
+ (list 'scm-gc-protect
+ (list 'cons
+ (make-pair-constant-aux (car pair))
+ (make-pair-constant-aux (cdr pair)))))))
+ (set! *new-constant-list* (cons tmp *new-constant-list*))
+ name))
+
+(define (make-pair-constant-aux term)
+ (if (pair? term)
+ (list 'cons
+ (make-pair-constant-aux (car term))
+ (make-pair-constant-aux (cdr term)))
+ (type-const-pass (list 'quote term))))
+
+(define (make-symbol-constant symb)
+ (let ((tmp (assq symb *symbol-constant-table*)))
+ (if tmp
+ (cadr tmp)
+ (let ((name (make-symbol-name symb))
+ (str (symbol->string symb))
+ (clname '()))
+ ;; if the symb is also a top-level-fun, then avoid
+ ;; applying make_subr to the symbol name string:
+ ;; this would mess up symbol-names table for scm.
+ (if (and (memq symb *top-level-funs*)
+ (not (memq symb *symbol-and-fun-list*)))
+ (begin
+ (set! *var-make-list*
+ (cons `(set!
+ ,(make-closure-scmobj-name symb)
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string symb))
+ ,(string-length
+ (symbol->string symb))))))
+ *var-make-list*))
+
+ (set! *symbol-and-fun-list*
+ (cons symb *symbol-and-fun-list*))))
+ (set! *symbol-constant-table*
+ (cons (list symb name) *symbol-constant-table*))
+ (set! *symbol-list*
+ (cons (list 'set!
+ name
+ `(scm-gc-protect
+ (car (,*intern-symbol-function*
+ (,*actual-c-string* ,str)
+ ,(string-length str)))))
+ ;;; (list 'string->symbol
+ ;;; (list 'list->string
+ ;;; (make-pair-constant-aux
+ ;;; (string->list
+ ;;; (symbol->string symb)))))
+ *symbol-list*))
+ name))))
+
+(define (make-constant-name)
+ (set! *new-constant-num* (+ 1 *new-constant-num*))
+ (string->symbol (string-append *new-constant-prefix*
+ (number->string *new-constant-num*))))
+
+
+(define (make-symbol-name symb)
+ (string->symbol (string-append (symbol->string symb)
+ *symbol-name-postfix*)))
+
+(define (c-negate term)
+ (if (and (pair? term) (eq? *not?* (car term)))
+ (cadr term)
+ (list *not?* term)))
+
+(define (cxr-open cxr arg)
+ (let* ((str (symbol->string cxr))
+ (chr #\c)
+ (len (string-length str))
+ (res arg))
+ (do ((n (- len 2) (- n 1)))
+ ((= 0 n))
+ (set! chr (string-ref str n))
+ (set! res
+ (list (if (eqv? #\a chr) 'car 'cdr) res)))
+ res))
+
+
+(define (c-boolify term)
+ (if (and (pair? term) (eq? *bool-c->s* (car term)))
+ (cadr term)
+ (list *bool-s->c* term)))
+
+;===================================================================
+;
+; a pass for
+; correcting higher-order function calls and
+; dotted-arglist function calls.
+;
+;===================================================================
+
+
+(define (ho-dot-wholedef term)
+ (set! *current-fun-name* (cadr term))
+ (ho-dot-pass term))
+
+(define (ho-dot-pass term)
+ (cond ((or (not (pair? term)) (eq? 'quote (car term)))
+ term)
+ ((memq (car term) *dot-arg-funs*)
+ (let* ((template (assq (car term) *dot-arg-templates*))
+ (new (make-listarg-arglist (cadr template) (cdr term))))
+ (if (and (memq (car term) *higher-order-funs*)
+ (liftable-hofname? (car term)))
+ (correct-ho-call
+ (cons (car term) (map ho-dot-pass new)))
+ (cons (car term) (map ho-dot-pass new)))))
+ ((and (memq (car term) *higher-order-funs*)
+ (liftable-hofname? (car term)))
+ (correct-ho-call (map ho-dot-pass term)))
+ (else
+ (map ho-dot-pass term))))
+
+(define (correct-ho-call term)
+ (let* ((add-args '())
+ (stay-args '())
+ (name (car term))
+ (data (assq name *higher-order-templates*))
+ (new-template '()))
+
+ (do ((args (cdr term) (cdr args))
+ (funtemplate (cadr data) (cdr funtemplate)))
+ ((null? args))
+ (if (car funtemplate)
+ (begin
+ (if (and (not (pair? (car args)))
+ (and (primitive? (car args))
+ (if (fixed-arity-primitive? (car args))
+ #t
+ (report-error
+ "in function " *current-fun-name*
+ " a variable-arity primitive is passed to a higher-order fun: " term))))
+ (let*
+ ((tmpargs (reverse
+ (list-tail '(w v u z y x)
+ (- 6 (primitive-arity (car args))))))
+ (newfun
+ (list 'lambda
+ tmpargs
+ (cons (car args) tmpargs)))
+ (newname (make-new-primitive-instname (car args))))
+ (set! *to-do-fun-list*
+ (cons (list 'define newname newfun)
+ *to-do-fun-list*))
+ (set! args (cons newname (cdr args)))))
+ (if (pair? (car args))
+ (begin
+ (set! add-args
+ (append (reverse (cdar args)) add-args))
+ (set! stay-args
+ (cons (caar args) stay-args))
+ (set! new-template
+ (cons (list
+ (length
+ (filter (lambda (x)
+ (or (not (pair? x))
+ (not (eq? *c-adr* (car x)))))
+ (cdar args)))
+ (length
+ (filter (lambda (x)
+ (and (pair? x)
+ (eq? *c-adr* (car x))))
+ (cdar args))))
+ new-template)))
+ (begin
+ (set! new-template (cons (list '0 '0) new-template))
+ (set! stay-args (cons (car args) stay-args)))))
+ (begin
+ (set! new-template (cons '0 new-template))
+ (set! stay-args (cons (car args) stay-args)))))
+
+ (set! new-template (reverse new-template))
+ (set! add-args (reverse add-args))
+ (set! stay-args (reverse stay-args))
+ (let ((attempt (assoc new-template (cddr data))))
+ (if attempt
+ (begin
+ (cons (cadr attempt)
+ (append add-args
+ (map (lambda (x y)
+ (if x (list *function* y) y))
+ (cadr data)
+ stay-args))))
+ (begin
+ (make-new-ho-instance term new-template data add-args stay-args)
+ (let ((attempt2 (assoc new-template (cddr data))))
+ (cons (cadr attempt2)
+ (append add-args
+ (map (lambda (x y)
+ (if x (list *function* y) y))
+ (cadr data)
+ stay-args)))))))))
+
+
+(define (make-new-ho-instance term new-template data add-args stay-args)
+ (let* ((done-mainfun-flag #f)
+ (mainfun-place (member-if (lambda (x) (eq? (cadr x) (car term)))
+ *to-do-fun-list*))
+ (ho-fun (if mainfun-place
+ (begin
+ (set! done-mainfun-flag #f)
+ (car mainfun-place))
+ (begin
+ (set! mainfun-place
+ (member-if (lambda (x) (eq? (cadr x) (car term)))
+ *passed-defs*))
+ (if (not mainfun-place)
+ (report-error "Higher-order function "
+ (car term)
+ " is not defined."))
+ (set! done-mainfun-flag #t)
+ (car mainfun-place))))
+ (dot-data (assq (cadr ho-fun) *dot-arg-templates*))
+ (data (assq (car term) *higher-order-templates*))
+ (ho-term (caddr ho-fun))
+ (new-args '())
+ (new-name (make-new-instname (cadr ho-fun) (length (cddr data)))))
+ (set! *top-level-funs*
+ (cons new-name *top-level-funs*))
+ (set! *make-new-ho-data* '())
+ (for-each (lambda (x y)
+ (if (pair? x)
+ (let ((new (make-new-parameters x)))
+ (set! *make-new-ho-data*
+ (cons (cons (if (pair? y) (cadr y) y)
+ (args->list new))
+ *make-new-ho-data*))
+ (set! new-args
+ (append new new-args)))))
+ new-template
+ (args->list (cadr ho-term)))
+ (if dot-data
+ (begin (set! *dot-arg-funs* (cons new-name *dot-arg-funs*))
+ (set! *dot-arg-templates*
+ (cons (list new-name
+ (append new-args (cadr dot-data)))
+ *dot-arg-templates*))))
+ (set! ho-term (make-new-inst-aux
+ ho-term (args->list new-args) (cadr ho-fun) new-name))
+ (set! ho-term
+ (cons (car ho-term)
+ (cons (append new-args (cadr ho-term))
+ (cddr ho-term))))
+ (set! ho-fun
+ (list (car ho-fun) new-name ho-term))
+ (set-cdr! (my-last-pair data)
+ (list (list new-template (cadr ho-fun))))
+ (if done-mainfun-flag
+ (begin
+ (set-cdr! mainfun-place
+ (cons (car mainfun-place) (cdr mainfun-place)))
+ (set-car! mainfun-place ho-fun))
+ (begin
+ (set-cdr! mainfun-place
+ (cons ho-fun (cdr mainfun-place)))))))
+
+(define (make-new-instname genname nr)
+ (let ((name
+ (string->symbol
+ (string-append (symbol->string genname)
+ *new-instfun-infix*
+ (number->string nr)))))
+ name))
+
+(define (make-new-primitive-instname genname)
+ (set! *new-primitive-instnr* (+ 1 *new-primitive-instnr*))
+ (let ((name
+ (string->symbol
+ (string-append (symbol->string genname)
+ *new-instfun-infix*
+ (number->string *new-primitive-instnr*)))))
+ name))
+
+(define (make-new-inst-aux term n-args o-name n-name)
+ (let ((tmp #f))
+ (cond ((or (not (pair? term)) (eq? 'quote (car term))) term)
+ ((eq? *higher-order-call* (car term))
+ (set! tmp (assq (cadr term) *make-new-ho-data*))
+ (if tmp
+ (cons (car term)
+ (cons (cadr term)
+ (if (null? (cdr tmp))
+ (cddr term)
+ (append (cdr tmp) (cddr term)))))
+ (map (lambda (x) (make-new-inst-aux x n-args o-name n-name))
+ term)))
+ ((eq? (car term) 'lambda)
+ (cons (car term)
+ (cons (cadr term)
+ (map (lambda (x)
+ (make-new-inst-aux x n-args o-name n-name))
+ (cddr term)))))
+ ((eq? (car term) o-name)
+ (cons n-name
+ (append
+ n-args
+ (map (lambda (x)
+ (make-new-inst-aux x n-args o-name n-name))
+ (cdr term)))))
+ (else
+ (map (lambda (x) (make-new-inst-aux x n-args o-name n-name))
+ term)))))
+
+
+(define (make-new-parameters nums)
+ (let* ((vars1 '())
+ (vars2 '()))
+ (do ((n (car nums) (- n 1)))
+ ((zero? n))
+ (set! vars1 (cons (make-new-parameter) vars1)))
+ (do ((n (cadr nums) (- n 1)))
+ ((zero? n))
+ (set! vars2 (cons (list *c-adr* (make-new-parameter)) vars2)))
+ (set! vars1 (reverse vars1))
+ (set! vars2 (reverse vars2))
+ (append vars1 vars2)))
+
+(define (make-new-parameter)
+ (set! *new-parameter-nr* (+ 1 *new-parameter-nr*))
+ (string->symbol (string-append *new-parameter-prefix*
+ (number->string *new-parameter-nr*))))
+
+
+
+;===================================================================
+;
+; statement-lifting & tail-recursion
+;
+;===================================================================
+
+
+(define (lift-statements-wholedef defterm)
+ (set! *current-fun-name* (cadr defterm))
+ (set! *tailrec-flag* #f)
+ (set! *higher-order-flag* #f)
+ (let ((res '())
+ (res2 '())
+ (newname #f)
+ (tmp '())
+ (lambdaterm (caddr defterm)))
+ (set! *higher-order-args* (args->list (cadr lambdaterm)))
+ (set! *current-formal-args* (cadr lambdaterm))
+ (set! *current-formal-argslist* (args->list (cadr lambdaterm)))
+ (set! res (lift-statements lambdaterm '()))
+ (if (not (list? (cadr lambdaterm)))
+ (begin
+ (set! *dot-arg-funs*
+ (cons (cadr defterm) *dot-arg-funs*))
+ (set! *dot-arg-templates*
+ (cons (list (cadr defterm)
+ (cadr lambdaterm))
+ *dot-arg-templates*))))
+ (if (and *higher-order-flag*
+ (liftable-hofname? (cadr defterm)))
+ (begin
+ (set! *higher-order-args*
+ (map (lambda (x) (if (eq? x '#t) '#t '#f))
+ *higher-order-args*))
+ (set! *higher-order-funs*
+ (cons (cadr defterm) *higher-order-funs*))
+ (set! *higher-order-templates*
+ (cons
+ (list (cadr defterm)
+ *higher-order-args*
+ (list (map (lambda (x)
+ (if x (list '0 '0) '0))
+ *higher-order-args*)
+ (cadr defterm)))
+ *higher-order-templates*))
+ (if (and (memq *current-fun-name* *top-level-funs*)
+ (not (null? *export-functions*))
+ (or (not (pair? *export-functions*))
+ (memq *current-fun-name* *export-functions*)))
+ (begin
+ (set! newname
+ (string->symbol
+ (string-append (symbol->string *current-fun-name*)
+ *export-hof-postfix*)))
+ (set! *top-level-funs*
+ (cons newname *top-level-funs*))
+ (set! *export-table*
+ (cons (list *current-fun-name* newname)
+ *export-table*))
+ (set! tmp (assq *current-fun-name* *dot-arg-templates*))
+ (if tmp
+ (begin
+ (set! *dot-arg-templates*
+ (cons (list newname (cadr tmp))
+ *dot-arg-templates*))
+ (set! *dot-arg-funs*
+ (cons newname *dot-arg-funs*))))
+ (set! res2
+ (make-export-hof res))))
+ (set! res (cons (car res)
+ (cons (map (lambda (x y)
+ (if x (list *function* y) y))
+ *higher-order-args*
+ (maklist (cadr res)))
+ (cddr res))))))
+ (if *tailrec-flag*
+ (begin
+ (set! res (cons (car res)
+ (cons (cadr res)
+ (cons (list *mark-tailrec*)
+ (cddr res)))))
+ (if (not (null? res2))
+ (set! res2 (cons (car res2)
+ (cons (cadr res2)
+ (cons (list *mark-tailrec*)
+ (cddr res2))))))))
+ (set! res
+ (list 'define (cadr defterm)
+ (if (list? (cadr res))
+ res
+ (cons (car res)
+ (cons (maklist (cadr res))
+ (cddr res))))))
+ (if (null? res2)
+ (list res)
+ (list res
+ (list 'define newname
+ (if (list? (cadr res2))
+ res2
+ (cons (car res2)
+ (cons (maklist (cadr res2))
+ (cddr res2)))))))))
+
+
+(define (maklist args)
+ (cond ((symbol? args)
+ (list args))
+ ((null? args)
+ '())
+ (else (cons (car args) (maklist (cdr args))))))
+
+
+(define (make-export-hof term)
+ (cond ((or (not (pair? term))
+ (eq? 'quote (car term)))
+ term)
+ ((eq? 'lambda (car term))
+ (cons (car term)
+ (cons (cadr term)
+ (map make-export-hof (cddr term)))))
+ ((eq? (car term) *higher-order-call*)
+ (list *sysapply*
+ (cadr term)
+ (if (null? (cddr term))
+ '()
+ (make-export-hof (caddr term)))
+ (if (null? (cddr term))
+ '()
+ (make-apply-second-arg
+ (make-export-hof (cdddr term))))))
+ ((eq? (car term) *function*)
+ (cadr term))
+ ((eq? (car term) *current-fun-name*)
+ (cons (string->symbol
+ (string-append (symbol->string *current-fun-name*)
+ *export-hof-postfix*))
+ (map make-export-hof (cdr term))))
+ (else
+ (map make-export-hof term))))
+
+
+(define (lift-statements term checkvars)
+ (cond
+ ((or (not (pair? term)) (eq? 'quote (car term)))
+ term)
+ ((eq? 'lambda (car term))
+ (set! checkvars (args->list (cadr term)))
+ (append
+ (list 'lambda)
+ (list (cadr term))
+ (map (lambda (x) (lift-statements x checkvars))
+ (butlast (cddr term) 1))
+ (list
+ (lift-statements
+ (push-result-var-in *return* (car (my-last-pair term)))
+ checkvars))))
+ ((and (eq? 'set! (car term))
+ (or (null? (cdr term)) (null? (cddr term))))
+ (report-error
+ " scheme syntax in fun " *current-fun-name* ": " term))
+ ((and (eq? 'set! (car term))
+ (pair? (caddr term))
+ (memq (caaddr term) '(do if begin let*)))
+ (lift-statements (push-result-var-in (cadr term) (caddr term))
+ checkvars))
+ ((eq? 'do (car term))
+ (set! checkvars (union (map car (cadr term)) checkvars))
+ (list* 'do
+ (map
+ (lambda (x)
+ (map (lambda (y) (lift-stat-aux y checkvars)) x))
+ (cadr term))
+ (append (list
+ (lift-stat-aux (car (caddr term)) checkvars))
+ (map (lambda (x)
+ (lift-statements x checkvars))
+ (cdr (caddr term))))
+ (map (lambda (x) (lift-statements x checkvars))
+ (cdddr term))))
+ ((eq? 'if (car term))
+ (if (eq? 3 (length term))
+ (list 'if
+ (lift-stat-aux (cadr term) checkvars)
+ (lift-statements (caddr term) checkvars))
+ (list 'if
+ (lift-stat-aux (cadr term) checkvars)
+ (lift-statements (caddr term) checkvars)
+ (lift-statements (cadddr term) checkvars))))
+ ((eq? 'begin (car term))
+ (append (list 'begin)
+ (map (lambda (x)
+ (lift-statements
+ (if (and (pair? x) (eq? 'set! (car x)))
+ (push-result-var-in (cadr x) (caddr x))
+ x)
+ checkvars))
+ (cdr term))))
+ ((or (eq? 'let* (car term)) (eq? 'let (car term)))
+ (set! checkvars (union (map car (cadr term)) checkvars))
+ (append (list 'let*)
+ (list (map (lambda (x) (list (car x) *dummy*)) (cadr term)))
+ (map (lambda (x)
+ (lift-statements
+ (push-result-var-in (car x) (cadr x))
+ checkvars))
+ (cadr term))
+ (map (lambda (x) (lift-statements x checkvars))
+ (cddr term))))
+ ((and (eq? 'set! (car term))
+ (pair? (caddr term))
+ (memq (caaddr term) '(do if begin let*)))
+ (lift-statements (push-result-var-in (cadr term) (caddr term))
+ checkvars))
+ (else
+ (lift-stat-aux term checkvars))))
+
+
+
+(define (lift-stat-aux term checkvars)
+ (cond
+ ((or (not (pair? term)) (eq? 'quote (car term)))
+ term)
+ ((eq? (car term) 'if)
+ (if (and *lift-ifs-flag*
+ (or (lift-if-arg? (caddr term))
+ (and (not (null? (cdddr term)))
+ (lift-if-arg? (cadddr term)))))
+ (let ((argvars (free-vars term checkvars '()))
+ (newname (new-fun-name *current-fun-name*)))
+ (set! *to-do-fun-list*
+ (cons
+ (list 'define
+ newname
+ (list 'lambda
+ (make-arglist argvars '())
+ (fetchify (cadr argvars) term)))
+ *to-do-fun-list*))
+ (cons newname (make-arglist argvars '())))
+ (cons *op-if* (map (lambda (x) (lift-stat-aux x checkvars))
+ (cdr term)))))
+ ((eq? (car term) 'begin)
+ (cons *op-begin* (map (lambda (x) (lift-stat-aux x checkvars))
+ (cdr term))))
+ ((or (eq? (car term) 'let*) (eq? (car term) 'let))
+ (set! checkvars (union (map car (cadr term)) checkvars))
+ (append (list *op-let*)
+ (list (map (lambda (x) (lift-stat-aux x checkvars))
+ (cadr term)))
+ (map (lambda (x) (lift-stat-aux x checkvars))
+ (cddr term))))
+ ((eq? (car term) 'do)
+ (let ((argvars (free-vars term checkvars '()))
+ (newname (new-fun-name *current-fun-name*)))
+ (set! *to-do-fun-list*
+ (cons
+ (list 'define
+ newname
+ (list 'lambda
+ (make-arglist argvars '())
+ (fetchify (cadr argvars) term)))
+ *to-do-fun-list*))
+ (cons newname (make-arglist argvars '()))))
+ ((and (memq (car term) *current-formal-argslist*)
+ (liftable-hofname? *current-fun-name*))
+ (set! *higher-order-flag* #t)
+ (set! *higher-order-args*
+ (replaceq (car term) '#t *higher-order-args*))
+ (cons *higher-order-call*
+ (map (lambda (x) (lift-stat-aux x checkvars)) term)))
+ (else
+ (map (lambda (x) (lift-stat-aux x checkvars)) term))))
+
+
+;;; lift-if-arg? says whether it is needed/sensible to lift
+;;; the if-statement with such a <term> as one of the resulting args
+
+(define (lift-if-arg? term)
+ (and (pair? term)
+ (not (eq? 'quote (car term)))
+ (not (and (memq
+ (car term)
+ (cons *not?*
+ (cons *and?*
+ (cons *or?*
+ '(eq? = < > <= >=
+ number? boolean? null? pair? zero?
+ character? vector?
+ %= %< %> %<= %>=
+ %eqv? %number? %zero)))))
+ (not (member-if (lambda (x) (pair? x)) (cdr term)))))))
+
+
+(define (push-result-var-in var term)
+ (cond ((or (not (pair? term)) (eq? 'quote (car term)))
+ (if (eq? var *return*)
+ (list *return* term)
+ (list 'set! var term)))
+ ((eq? (car term) 'if)
+ (if (eq? 3 (length term))
+ (list 'if (cadr term)
+ (push-result-var-in var (caddr term)))
+ (list 'if (cadr term)
+ (push-result-var-in var (caddr term))
+ (push-result-var-in var (cadddr term)))))
+ ((eq? (car term) 'begin)
+ (append (list 'begin)
+ (butlast (cdr term) 1)
+ (list (push-result-var-in var
+ (car (my-last-pair term))))))
+ ((or (eq? (car term) 'let*) (eq? (car term) 'let))
+ (append (list 'let*)
+ (list (cadr term))
+ (butlast (cddr term) 1)
+ (list (push-result-var-in var
+ (car (my-last-pair term))))))
+ ((eq? (car term) 'do)
+ (append (list 'do)
+ (list (cadr term))
+ (list (append
+ (list (car (caddr term)))
+ (if (null? (cdr (caddr term)))
+ (list (push-result-var-in var *unspecified*))
+ (append
+ (butlast (cdr (caddr term)) 1)
+ (list
+ (push-result-var-in
+ var
+ (car (my-last-pair (caddr term)))))))))
+ (cdddr term)))
+ ;; ((eq? (car term) 'lambda)
+ ;; (report-error
+ ;; "Compiled function " *current-fun-name* " builds closures."))
+ ((eq? var *return*)
+ (if (eq? (car term) *current-fun-name*)
+ (begin
+ (set! *tailrec-flag* #t)
+ (make-tailrec-call (cdr term)))
+ (list *return* term)))
+ (else
+ (list 'set! var term))))
+
+
+(define (make-tailrec-call args)
+ (define (first-n-reverse n lst)
+ (if (zero? n) '() (cons (car lst) (first-n-reverse (- n 1) (cdr lst)))))
+ (let ((tmp1 '())
+ (tmp2 '())
+ (tmp3 '()))
+ (set! tmp3 (args->list *current-formal-args*))
+ (set! args (make-listarg-arglist *current-formal-args* args))
+ (do ((args-lst args (cdr args-lst))
+ (form-lst tmp3 (cdr form-lst)))
+ ((null? args-lst))
+ (if (not (equal? (car args-lst) (car form-lst)))
+ (begin (set! tmp1 (cons (car args-lst) tmp1))
+ (set! tmp2 (cons (car form-lst) tmp2)))))
+ (set! tmp1 (reverse tmp1))
+ (set! tmp2 (reverse tmp2))
+ (cond
+ ((null? tmp1) (list *goto-tailrec*))
+ ((null? (cdr tmp1))
+ (list 'begin
+ (list 'set! (car tmp2) (car tmp1))
+ (list *goto-tailrec*)))
+ (else
+ (let ((tmplist
+ (first-n-reverse (length tmp1) *tmp-vars*)))
+ (append
+ (list 'let*)
+ (list (map (lambda (x y) (list x y)) tmplist tmp1))
+ (map (lambda (x y) (list 'set! x y)) tmp2 tmplist)
+ (list (list *goto-tailrec*))))))))
+
+
+(define (make-listarg-arglist formals args)
+ (cond ((list? formals) args)
+ ((symbol? formals) (list (normalize-list-aux args)))
+ ((null? args)
+ (report-error
+ "In " *current-fun-name*
+ " a list-taking function is called with too few args."))
+ (else
+ (cons (car args)
+ (make-listarg-arglist (cdr formals) (cdr args))))))
+
+
+(define (build-wrappers funs)
+ (define (build-wrapper-aux arity arg)
+ (cond ((null? arity)
+ '())
+ ((not (pair? arity))
+ (list arg))
+ (else
+ (cons (list 'car arg)
+ (build-wrapper-aux (cdr arity) (list 'cdr arg))))))
+ (define (build-wrapper fun)
+ (let* ((name (cadr fun))
+ (export (assq name *export-table*))
+ (arity (cadr (caddr fun)))
+ (arity2 (assq name *dot-arg-templates*)))
+ (if arity2
+ (set! arity (cadr arity2)))
+ (if (or (not (memq name *export-functions*))
+ (symbol? arity)
+ (and (list? arity)
+ (< (length arity) 4)))
+ #f
+ `(define ,(string->symbol
+ (string-append (symbol->string name)
+ *wrapper-postfix*))
+ (lambda (x)
+ (,*return*
+ (,(if export (cadr export) name)
+ ,@(build-wrapper-aux arity 'x))))))))
+ (let ((res '()))
+ (for-each (lambda (x)
+ (let ((new (build-wrapper x)))
+ (if new
+ (begin
+ (set! res (cons new res))
+ (set! *wrapper-table*
+ (cons (list (cadr x) (cadr new))
+ *wrapper-table*))))))
+ funs)
+ res))
+
+(define (build-wrapped-interpreter-table)
+ (let ((new '())
+ (tmp '()))
+ (do ((part *interpreter-funname-table* (cdr part)))
+ ((null? part)
+ (set! *interpreter-funname-table* new))
+ (set! tmp (assq (caar part) *wrapper-table*))
+ (if tmp
+ (set! new (cons (cons (cadr tmp) (cdar part)) new))
+ (begin
+ (set! tmp (assq (caar part) *export-table*))
+ (if tmp
+ (set! new (cons (cons (cadr tmp) (cdar part)) new))
+ (set! new (cons (car part) new))))))))
+
+
+
+;===================================================================
+;
+; vars-simplifying and lambda-lifting
+;
+;==================================================================
+
+(define *new-vars-nr-for-topfun* 0)
+
+(define (vars-simplify-wholedef def)
+ (let ()
+;;;(pretty-print def)
+ (set! def (compile-quasiquote def))
+;;;(pretty-print def)
+ (set! def (normalize-defines def))
+ (set! *current-fun-name* (cadr def))
+ (set! *top-level-funs* (cons *current-fun-name* *top-level-funs*))
+;;;(pretty-print def)
+ (set! def (if *full-inlining-flag*
+ (subst-inline-full def)
+ (subst-inline def)))
+ (set! def (normalize-delay def))
+;;;(pretty-print def)
+ (set! def (rename-vars def))
+ (set! *new-vars-nr-for-topfun* 0)
+ (set! def (normalize def #f 1))
+;;;(pretty-print def)
+ (set! def (normalize-def-letrecs def))
+ (set! def (beautify-lets def))
+;;;(pretty-print def)
+ def))
+
+
+;;; flatten-wholedef performs the first normalizing and lambda-lifting pass
+
+(define (flatten-wholedef def)
+ (let ()
+;;;(newline)
+;;;(display "starting to flatten def: ") (newline)
+;;;(pretty-print def)
+ (set! *current-fun-name* (cadr def))
+ (set! def (lettify-lambdas def 100 #t))
+;;;(pretty-print def)
+ (set! def (remove-lambdasurrounding-let def))
+;;;(pretty-print def)
+ (set! *new-funs-list* '())
+ (set! def (lambda-lift def '() '()))
+;;;(pretty-print def)
+ (set! *new-funs-list* (cons def *new-funs-list*))
+ *new-funs-list*))
+
+
+(define (lambda-lift term boundvars new-names-args)
+ (let ((tmp '()))
+ (cond
+ ((symbol? term)
+ (set! tmp (assq term new-names-args))
+ (if tmp
+ (cons (cadr tmp) (make-arglist (caddr tmp) '()))
+ term))
+ ((not (pair? term)) term)
+ ((eq? (car term) 'quote) term)
+ ((eq? (car term) 'lambda)
+ (set! tmp (union (args->list (cadr term)) boundvars))
+ (cons 'lambda
+ (cons (cadr term)
+ (map (lambda (x)
+ (lambda-lift x tmp new-names-args))
+ (cddr term)))))
+ ((memq (car term) '(let let* letrec))
+ (lift-let term boundvars new-names-args))
+ ((eq? (car term) 'do)
+ ;; check next line!!!
+ (set! tmp (union (map car (cadr term)) boundvars))
+ (cons 'do
+ (cons (map (lambda (x)
+ (if (null? (cddr x))
+ (list (car x)
+ (lambda-lift (cadr x) boundvars
+ new-names-args))
+ (list (car x)
+ (lambda-lift (cadr x) boundvars
+ new-names-args)
+ (lambda-lift (caddr x)
+ tmp
+ new-names-args))))
+ (cadr term))
+ (map (lambda (x)
+ (lambda-lift x tmp new-names-args))
+ (cddr term)))))
+ ((symbol? (car term))
+ (set! tmp (assq (car term) new-names-args))
+ (let ((args (map (lambda (x)
+ (lambda-lift x boundvars new-names-args))
+ (cdr term))))
+ (if tmp
+ (cons (cadr tmp)
+ (make-arglist (caddr tmp) args))
+ (cons (car term) args))))
+ (else
+ (cons (lambda-lift (car term) boundvars new-names-args)
+ (map (lambda (x)
+ (lambda-lift x boundvars new-names-args))
+ (cdr term)))))))
+
+
+
+(define (lift-let letterm boundvars new-names-args)
+ (let* ((bindings (cadr letterm))
+ (newvars (map car bindings))
+ (body (cddr letterm))
+ (fun-bindings
+ (filter (lambda (x)
+ (and (pair? (cadr x))
+ (eq? (caadr x) 'lambda)))
+ bindings))
+ (other-bindings
+ (filter (lambda (x)
+ (not (memq x fun-bindings)))
+ bindings))
+ (next-bound (union (map car other-bindings) boundvars)))
+
+ (cond ((null? fun-bindings))
+ ((memq (car letterm) '(let* let))
+ (set! new-names-args
+ (make-new-funs-let
+ fun-bindings next-bound new-names-args #f)))
+ ((eq? (car letterm) 'letrec)
+ (set! new-names-args
+ (make-new-funs-letrec
+ fun-bindings next-bound new-names-args #f)))
+ (else (report-error "lift-let applied to non-let term " letterm)))
+
+ (cond ((not (null? other-bindings))
+ (cons (car letterm)
+ (cons (map (lambda (x)
+ (list (car x)
+ (lambda-lift (cadr x)
+ next-bound
+ new-names-args)))
+ other-bindings)
+ (map (lambda (x)
+ (lambda-lift x next-bound new-names-args))
+ body))))
+ ((null? (cdr body))
+ (lambda-lift (car body) next-bound new-names-args))
+ (else
+ (lambda-lift (cons 'begin body) next-bound new-names-args)))))
+
+
+(define (fetchify vars term)
+ (if (null? vars) term (fetchify-aux vars term)))
+
+(define (fetchify-aux vars term)
+ (cond ((symbol? term)
+ (if (memq term vars)
+ (list *c-fetch* term)
+ term))
+ ((not (pair? term))
+ term)
+ ((eq? 'quote (car term))
+ term)
+ ((and (eq? *c-adr* (car term))
+ (memq (cadr term) vars))
+ (cadr term))
+ (else
+ (cons (fetchify-aux vars (car term))
+ (fetchify-aux vars (cdr term))))))
+
+
+(define (make-arglist new-args args)
+ (if (null? (cadr new-args))
+ (append (car new-args) args)
+ (append (map (lambda (x) (list *c-adr* x)) (cadr new-args))
+ (car new-args)
+ args)))
+
+
+(define (normalize-def-letrecs def)
+ (let ((tmp '()))
+ (set! *current-fun-name* (cadr def))
+ (set! tmp
+ (normalize-def-letrecs-aux (caddr def)))
+ (list* (car def) (cadr def) (list tmp))))
+
+(define (normalize-def-letrecs-aux term)
+ (cond ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((eq? 'lambda (car term))
+ (list* (car term) (cadr term)
+ (map normalize-def-letrecs-aux (cddr term))))
+ ((eq? 'letrec (car term))
+ (if (null? (cadr term))
+ (list* 'let* '() (map normalize-def-letrecs-aux (cddr term)))
+ (restructure-letrec (map normalize-def-letrecs-aux term))))
+ (else
+ (map normalize-def-letrecs-aux term))))
+
+(define (restructure-letrec letterm)
+ (let* ((vars (map car (cadr letterm)))
+ (dependencies
+ (map (lambda (x)
+ (list (car x)
+ (occurrences-of vars (cadr x))))
+ (cadr letterm)))
+ (groups (build-sconnected-groups dependencies vars '())))
+ (set! groups (topo-sort dependencies groups))
+ (build-letrec-struct letterm dependencies groups)))
+
+
+(define (build-letrec-struct letterm deps groups)
+ (if (null? groups)
+ (list (cddr letterm))
+ (let ((bind (filter (lambda (x) (memq (car x) (car groups)))
+ (cadr letterm)))
+ (body (build-letrec-struct letterm deps (cdr groups))))
+ (cond
+ ((and (null? (cdar groups))
+ (not (memq (caar groups) (cadr (assq (caar groups) deps)))))
+ (cons 'let
+ (if (symbol? (car body))
+ (list bind body)
+ (cons bind (car body)))))
+ (else
+ (cons 'letrec
+ (if (symbol? (car body))
+ (list bind body)
+ (cons bind (car body)))))))))
+
+;;; lettify-lambdas has a topflag parameter, which is true iff
+;;; the term is a third arg of a toplevel def
+
+(define (lettify-lambdas term var-nr topflag)
+ (cond ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((memq (car term) '(define lambda))
+ (if (not (list? (cddr term)))
+ (report-error
+ *current-fun-name* " has incorrect syntax."))
+ (cons (car term)
+ (cons (cadr term)
+ (map (lambda (x) (lettify-lambdas x var-nr topflag))
+ (cddr term)))))
+ ((and (pair? term)
+ (not (list? term)))
+ (report-error
+ *current-fun-name* " has incorrect syntax."))
+ ((memq (car term) '(let let* letrec))
+ (if (not topflag)
+ (cons (car term)
+ (list* (map (lambda (x)
+ (list (car x)
+ (lettify-lambdas
+ (cadr x) var-nr #f)))
+ (cadr term))
+ (lettify-lambdas (cddr term) var-nr #f)))
+ (cons (car term)
+ (list* (map (lambda (x)
+ (list (car x)
+ (lettify-lambdas
+ (cadr x) var-nr #f)))
+ (cadr term))
+ (map
+ (lambda (x) (lettify-lambdas x var-nr #f))
+ (cddr term))))))
+
+ ((and (memq (car term) '(cond))
+ (find-if (lambda (cl)
+ (find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x))))
+ (cdr cl)))
+ (cdr term)))
+ (let* ((lcl
+ (find-if (lambda (cl)
+ (find-if (lambda (x) (and(pair? x) (eq? 'lambda (car x))))
+ (cdr cl)))
+ (cdr term)))
+ (lterm
+ (find-if (lambda (x) (and(pair? x) (eq? 'lambda (car x)))) lcl))
+ (newvar (make-new-funname))
+ (newlcl (replaceq lterm newvar lcl))
+ (newclauses (replaceq lcl newlcl (cdr term))))
+ `(let ((,newvar ,(lettify-lambdas lterm (+ 1 var-nr) #f)))
+ ,(lettify-lambdas
+ (cons 'cond newclauses) (+ 1 var-nr) #f))))
+ ((find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x)))) term)
+
+ (let* ((lterm (find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x))))
+ term))
+ (newvar (make-new-funname))
+ (newterm (replaceq lterm newvar term)))
+ `(let ((,newvar ,(lettify-lambdas lterm (+ 1 var-nr) #f)))
+ ,(lettify-lambdas newterm (+ 1 var-nr) #f))))
+ (else
+ (map (lambda (x) (lettify-lambdas x var-nr #f)) term))))
+
+
+(define (make-new-funname)
+ (set! *new-fun-nr* (+ 1 *new-fun-nr*))
+ (let ((name
+ (string->symbol
+ (string-append (symbol->string *current-fun-name*)
+ *new-letfun-infix*
+ (number->string *new-fun-nr*)))))
+ (set! *new-fun-names* (cons name *new-fun-names*))
+ name))
+
+
+(define (beautify-lets term)
+ (cond ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((eq? (car term) 'lambda)
+ (cons (car term)
+ (cons (cadr term)
+ (map beautify-lets (cddr term)))))
+ ((and (memq (car term) '(let let*))
+ (eq? 3 (length term))
+ (pair? (caddr term))
+ (memq (car (caddr term)) '(let let*)))
+ (beautify-lets
+ (list* 'let*
+ (map beautify-lets
+ (append (cadr term) (cadr (caddr term))))
+ (cddr (caddr term)))))
+ (else (map beautify-lets term))))
+
+
+;--------------------------------------------------------------
+;
+; topological sorting by dependencies
+;
+;--------------------------------------------------------------
+
+(define (topo-sort deps groups)
+ (let ((res (cons '() '())))
+ (do ((part groups (cdr part)))
+ ((null? part) (cdr res))
+ (topo-insert (car part) res deps))))
+
+(define (topo-insert el lst deps)
+ (let ((found-flag #f))
+ (do ((last-part lst (cdr last-part)))
+ ((or found-flag (null? (cdr last-part)))
+ (if (not found-flag)
+ (set-cdr! last-part (list el)))
+ lst)
+ (if (is-path? (caadr last-part) (car el) deps '())
+ (begin
+ (set-cdr! last-part (cons el (cdr last-part)))
+ (set! found-flag #t))))))
+
+(define (build-sconnected-groups deps input groups)
+ (let ((tmp '()))
+ (cond
+ ((null? input) groups)
+ ((begin (set! tmp
+ (find-if
+ (lambda (grp)
+ (and (not (null? (cdr grp)))
+ (is-path? (car input) (car grp) deps '())
+ (is-path? (car grp) (car input) deps '())))
+ groups))
+ tmp)
+ (build-sconnected-groups deps (cdr input)
+ (cons (cons (car input) tmp) (remove tmp groups))))
+ ((begin (set! tmp
+ (find-if
+ (lambda (in)
+ (and (is-path? (car input) in deps '())
+ (is-path? in (car input) deps '())))
+ (cdr input)))
+ tmp)
+ (build-sconnected-groups deps (remove tmp (cdr input))
+ (cons (list (car input) tmp) groups)))
+ (else
+ (build-sconnected-groups deps (cdr input)
+ (cons (list (car input)) groups))))))
+
+
+(define (is-path? a b deps visited)
+ (set! visited (cons a visited))
+ (set! a (cadr (assq a deps)))
+ (or (memq b a)
+ (find-if (lambda (x)
+ (and (not (memq x visited))
+ (is-path? x b deps visited)))
+ a)))
+
+(define (occurrences-of vars term)
+ (cond ((symbol? term)
+ (if (memq term vars)
+ (list term)
+ '()))
+ ((not (pair? term)) '())
+ ((eq? (car term) 'quote) '())
+ (else
+ (union (occurrences-of vars (car term))
+ (occurrences-of vars (cdr term))))))
+
+
+;---------------------------------------------------------------------
+;
+; build auxiliary functions
+;
+;--------------------------------------------------------------------
+
+
+(define (make-new-funs-let fun-bindings boundvars new-names-args lazy-flag)
+ (for-each
+ (lambda (b)
+ (let* ((freevars (merge-free-vars
+ (introduced-free-vars (cadr b) new-names-args)
+ (free-vars (cadr b) boundvars '())))
+ (new-name (make-new-funname))
+ (tmp (list 'define
+ new-name
+ (cons (caadr b)
+ (cons (make-arglist freevars (cadadr b))
+ (map (lambda (y)
+ (fetchify
+ (cadr freevars)
+ (lambda-lift
+ y
+ (union (args->list (cadadr b))
+ boundvars)
+ new-names-args)))
+ (cddadr b)))))))
+ (set! *new-funs-list* (cons tmp *new-funs-list*))
+ (set! new-names-args
+ (cons (list (car b) new-name freevars)
+ new-names-args))))
+ fun-bindings)
+ new-names-args)
+
+(define (make-new-funs-letrec fun-bindings boundvars new-names-args lazy-flag)
+ (let* ((fun-bodies (cons 'begin (map cadr fun-bindings)))
+ (intro-vars (introduced-free-vars fun-bodies new-names-args))
+ (freevars (merge-free-vars intro-vars
+ (free-vars fun-bodies boundvars '())))
+ (new-names-args
+ (append
+ (map (lambda (b)
+ (list (car b) (make-new-funname) freevars))
+ fun-bindings)
+ new-names-args)))
+ (for-each
+ (lambda (b)
+ (set! *new-funs-list*
+ (cons
+ (list 'define
+ (cadr (assq (car b) new-names-args))
+ (cons (caadr b)
+ (cons (make-arglist freevars (cadadr b))
+ (map (lambda (y)
+ (fetchify (cadr freevars)
+ (lambda-lift y
+ (union
+ (args->list (cadadr b))
+ boundvars)
+ new-names-args)))
+ (cddadr b)))))
+ *new-funs-list*)))
+ fun-bindings)
+ new-names-args))
+
+
+(define (introduced-free-vars term names-args)
+ (if (null? names-args)
+ (list '() '())
+ (introduced-free-vars-aux term names-args)))
+
+(define (introduced-free-vars-aux term names-args)
+ (cond ((symbol? term)
+ (let ((tmp (assq term names-args)))
+ (if tmp (caddr tmp) '(() ()))))
+ ((not (pair? term)) '(() ()))
+ ((eq? 'quote (car term)) '(() ()))
+ (else
+ (merge-free-vars
+ (introduced-free-vars-aux (car term) names-args)
+ (introduced-free-vars-aux (cdr term) names-args)))))
+
+
+(define (new-fun-name a)
+ (if (memq a *new-fun-names*)
+ a
+ (string->symbol
+ (string-append (symbol->string a)
+ *new-fun-infix*
+ (begin (set! *new-fun-nr* (+ 1 *new-fun-nr*))
+ (number->string *new-fun-nr*))))))
+
+
+;-------------------------------------------------------------------
+;
+; free-vars collectors
+;
+;------------------------------------------------------------------
+
+
+;;; all-free-vars takes a term and returns a list (a set) of all
+;;; all free variables in term.
+
+(define (all-free-vars term)
+ (set! *free-vars-list* '())
+ (all-free-aux! term '())
+ *free-vars-list*)
+
+(define (all-free-aux! term bound)
+ (cond
+ ((symbol? term)
+ (if (and (not (memq term bound))
+ (not (memq term *free-vars-list*)))
+ (set! *free-vars-list* (cons term *free-vars-list*))))
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? 'lambda (car term))
+ (let ((new (union (args->list (cadr term)) bound)))
+ (for-each (lambda (x) (all-free-aux! x new)) (cddr term))))
+ ((eq? 'let (car term))
+ (let ((new (union (map car (cadr term)) bound)))
+ (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
+ (for-each (lambda (x) (all-free-aux! x new)) (cddr term))))
+ ((eq? 'let* (car term))
+ (for-each (lambda (x)
+ (all-free-aux! (cadr x) bound)
+ (if (not (memq (car x) bound))
+ (set! bound (cons (car x) bound))))
+ (cadr term))
+ (for-each (lambda (x) (all-free-aux! x bound)) (cddr term)))
+ ((eq? 'letrec (car term))
+ (set! bound (union (map car (cadr term)) bound))
+ (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
+ (for-each (lambda (x) (all-free-aux! x bound)) (cddr term)))
+ ((eq? 'do (car term))
+ (let ((new (union (map car (cadr term)) bound)))
+ (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
+ (for-each (lambda (x)
+ (if (not (null? (cddr x)))
+ (all-free-aux! (caddr x) new)))
+ (cadr term))
+ (for-each (lambda (x) (all-free-aux! x new)) (caddr term))
+ (for-each (lambda (x) (all-free-aux! x new)) (cdddr term))))
+ (else
+ (for-each (lambda (x) (all-free-aux! x bound)) term))))
+
+
+;;; free-vars takes a term, a list of candidates for free vars (vars bound
+;;; somewhere higher in the term) and a list of bound variables.
+;;; The list of candidates is used in order not to consider the global
+;;; variables (external function definitions, *vars*, etc) to be free.
+;;; It returns a list of two disjoint sets: (<ordinary-free> <set!-free>),
+;;; where <set!-free> is a list of free variables which have a set!
+;;; applied to them somewhere in the term.
+;;; The differentiation is important, as ordinary (non-set!)
+;;; free variables are passed as ordinary additional variables
+;;; during lambda-lifting, whereas set!-variables have to be passed
+;;; by reference and treated accordingly (fortunately this is simple
+;;; in C: instead of x always write (*x)).
+
+
+(define (free-vars term checkvars boundvars)
+ (cond ((and (symbol? term) (memq term checkvars))
+ (if (memq term boundvars)
+ '(() ())
+ (list (list term) '())))
+ ((not (pair? term)) '(() ()))
+ ((eq? (car term) 'quote) '(() ()))
+ ((eq? (car term) 'set!)
+ (if (or (memq (cadr term) boundvars)
+ (not (memq (cadr term) checkvars)))
+ (free-vars (caddr term) checkvars boundvars)
+ (merge-free-vars (list '() (list (cadr term)))
+ (free-vars (caddr term) checkvars boundvars))))
+ ((eq? (car term) 'lambda)
+ (free-vars (cddr term)
+ checkvars
+ (append (args->list (cadr term))
+ boundvars )))
+ ((memq (car term) '(let let* letrec))
+ (free-vars (append (map cadr (cadr term))
+ (cddr term))
+ checkvars
+ (append (map car (cadr term))
+ boundvars )))
+ ((eq? (car term) 'do)
+ (free-vars (append (map cadr (cadr term))
+ (map (lambda (x)
+ (if (null? (cddr x)) 1 (caddr x)))
+ (cadr term))
+ (cddr term))
+ checkvars
+ (append (map car (cadr term))
+ boundvars )))
+ (else
+ (merge-free-vars (free-vars (car term) checkvars boundvars)
+ (free-vars (cdr term) checkvars boundvars)))))
+
+(define (merge-free-vars pair-a pair-b)
+ (let* ((norm-a (car pair-a))
+ (norm-b (car pair-b))
+ (set-a (cadr pair-a))
+ (set-b (cadr pair-b))
+ (set-res (union set-a set-b)))
+ (list (set-difference (union norm-a norm-b) set-res)
+ set-res )))
+
+(define *var-nr* 0)
+
+;================================================================
+;
+; substituting in inlined-functions and
+; converting one-arg map-s to map1-s
+;
+;================================================================
+
+
+(define (subst-inline-full term)
+ (let ((new (subst-inline term)))
+ (if (equal? term new)
+ term
+ (subst-inline-full new))))
+
+
+(define (subst-inline term)
+ (cond ((symbol? term)
+ (let ((tmp (assq term *inline-vars-data*)))
+ (if tmp (cadr tmp) term)))
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term))
+ term)
+ ((and (eq? (car term) 'map)
+ (= 3 (length term))
+ (not *always-map->do-flag*)
+ (guaranteed-all-liftable? (list (car term) (cadr term))))
+ (set! *map1-needed-flag* #t)
+ (if (or (pair? (cadr term))
+ (top-nonlist-in-file-defined? (cadr term)))
+ (subst-inline (cons *map1-function* (cdr term)))
+ (subst-inline
+ (list *map1-function*
+ `(lambda (x) (,(cadr term) x))
+ (caddr term)))))
+ ((and (eq? (car term) 'for-each)
+ (= 3 (length term))
+ (not *always-for-each->do-flag*)
+ (guaranteed-all-liftable? (list (car term) (cadr term))))
+ (set! *for-each1-needed-flag* #t)
+ (if (or (pair? (cadr term))
+ (top-nonlist-in-file-defined? (cadr term)))
+ (subst-inline (cons *for-each1-function* (cdr term)))
+ (subst-inline
+ (list *for-each1-function*
+ `(lambda (x) (,(cadr term) x))
+ (caddr term)))))
+ ((memq (car term) *inline-funs*)
+ (let ((data (assq (car term) *inline-funs-data*))
+ (tmp (subst-inline (cdr term))))
+ (subst-inline-aux
+ (caddr (cadr data))
+ (map (lambda (par arg)
+ (list par arg))
+ (cadr (cadr data))
+ tmp))))
+ ((and (eq? (car term) 'set!)
+ (assq (cadr term) *inline-vars-data*))
+ (cons 'set! (cons (cadr term) (map subst-inline (cddr term)))))
+ ((list? term)
+ (map subst-inline term))
+ (else
+ term)))
+
+
+(define (subst-inline-aux term pairs)
+ (cond ((symbol? term)
+ (let ((tmp (assq term pairs)))
+ (if tmp
+ (cadr tmp)
+ term)))
+ ((not (pair? term))
+ term)
+ (else
+ (cons (subst-inline-aux (car term) pairs)
+ (subst-inline-aux (cdr term) pairs)))))
+
+;================================================================
+;
+; normalization (simplifying transformation)
+;
+;================================================================
+
+;;; normalize is a main normalizing function, which should
+;;; normalize a term in one pass.
+;;;
+;;; MB! Quasiquote-compiler, normalize-defines and rename-vars
+;;; must have been applied before the application of the current
+;;; transformer.
+
+(define (normalize term bool-flag var-nr)
+ (cond ((not (pair? term)) term)
+ ((eq? (car term) 'quote) term)
+ ((memq (car term) '(set! set-car! set-cdr! vector-set!))
+ (list 'begin
+ (map (lambda (x) (normalize x bool-flag var-nr)) term)
+ *unspecified*))
+ ((eq? (car term) 'if)
+ (normalize-if (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'cond)
+ (normalize-cond (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'not)
+ (normalize-not (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'and)
+ (normalize-and (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'or)
+ (normalize-or (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'case)
+ (normalize-case term bool-flag var-nr))
+ ((eq? (car term) 'do)
+ (normalize-do (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'lambda)
+ (cons (car term)
+ (cons (cadr term)
+ (normalize (cddr term) bool-flag var-nr))))
+ ((eq? 'letrec (car term))
+ ;;(restructure-letrec
+ ;; (map (lambda (x) (normalize x bool-flag var-nr)) term))
+ (map (lambda (x) (normalize x bool-flag var-nr)) term))
+ ((modified-fun? (car term))
+ (map (lambda (x) (normalize x bool-flag var-nr)) term))
+
+ ((eq? (car term) 'list)
+ (normalize-list term bool-flag var-nr))
+ ((eq? (car term) 'for-each)
+ (for-each->do term bool-flag var-nr))
+ ((eq? (car term) 'map)
+ (map->do term bool-flag var-nr))
+ ((eq? (car term) 'open-input-file)
+ (normalize-open-input-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'open-output-file)
+ (normalize-open-output-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'call-with-input-file)
+ (normalize-call-with-input-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'call-with-output-file)
+ (normalize-call-with-output-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'with-input-from-file)
+ (normalize-with-input-from-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'with-output-to-file)
+ (normalize-with-output-to-file (cdr term) bool-flag var-nr))
+ ((eq? 'string-append (car term))
+ (normalize-string-append term bool-flag var-nr))
+ ((assq (car term) *associative-fun-table*)
+ (normalize-associative
+ (assq (car term) *associative-fun-table*)
+ (cdr term) bool-flag var-nr))
+ ((assq (car term) *comparison-fun-table*)
+ (normalize-comparison
+ (assq (car term) *comparison-fun-table*)
+ (cdr term) bool-flag var-nr))
+ (else
+ (map (lambda (x) (normalize x bool-flag var-nr)) term))))
+
+
+;;; for-each->do converts a for-each application to a do cycle.
+;;; The aim is to convert a do cycle into the C for cycle later.
+;;;
+;;; NB! here and in the following transformers bool-flag denotes
+;;; whether the current term occurs as a term of boolean type -
+;;; eg, (if (for-each ....) term1 term2). This allows some
+;;; optimizations (although not directly in for-each, of course).
+;;;
+;;; var-nr is a number of the last generated new variable.
+
+
+(define (for-each->do term bool-flag var-nr)
+ (let* ((fun (cadr term))
+ (args (cddr term))
+ (names (map (lambda (x)
+ (set! var-nr (+ 1 var-nr)) (make-new-var var-nr))
+ args )))
+ `(do
+ ,(map (lambda (x y) (list x y (list 'cdr x)))
+ names
+ (map (lambda (x) (normalize x #f (+ 1 var-nr))) args))
+ ,(list (normalize
+ (if (null? (cdr args))
+ (list 'not (list 'pair? (car names)))
+ (list 'not (cons 'and (map (lambda (x)
+ (list 'pair? x))
+ names))))
+ #t var-nr)
+ *unspecified*)
+ ,(cons (normalize fun #f (+ 1 var-nr))
+ (map (lambda (x) (list 'car x)) names)))))
+
+
+;;; map->do converts a map application to a do cycle.
+
+(define (map->do term bool-flag var-nr)
+ (let* ((fun (cadr term))
+ (args (cddr term))
+ (res (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
+ (res-end (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
+ (tmp (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
+ (names (map (lambda (x)
+ (set! var-nr (+ 1 var-nr)) (make-new-var var-nr))
+ args )))
+ `(do
+ (,@(map (lambda (x y) (list x y (list 'cdr x)))
+ names
+ (map (lambda (x) (normalize x #f (+ 1 var-nr))) args))
+ (,res '())
+ (,res-end '())
+ (,tmp '()))
+ ,(list (normalize
+ (if (null? (cdr args))
+ (list 'not (list 'pair? (car names)))
+ (list 'not (cons 'and (map (lambda (x)
+ (list 'pair? x))
+ names))))
+ #t var-nr)
+ res)
+ (set! ,tmp ,(normalize
+ (cons fun (map (lambda (x) (list 'car x)) names))
+ #f (+ 1 var-nr)))
+ (if (null? ,res)
+ (begin (set! ,res (cons ,tmp '()))
+ (set! ,res-end ,res))
+ (begin (set-cdr! ,res-end (cons ,tmp '()))
+ (set! ,res-end (cdr ,res-end)))))))
+
+
+
+(define (normalize-if term bool-flag var-nr)
+ (if (null? (cddr term))
+ (list 'if
+ (normalize (car term) #t var-nr)
+ (normalize (cadr term) bool-flag var-nr)
+ *unspecified*)
+ (list 'if
+ (normalize (car term) #t var-nr)
+ (normalize (cadr term) bool-flag var-nr)
+ (normalize (caddr term) bool-flag var-nr))))
+
+
+(define (normalize-do term bool-flag var-nr)
+ (if (or (null? (car term))
+ (null? (cdar term)))
+ (list* 'do
+ (map (lambda (x) (normalize x #f var-nr))
+ (car term))
+ (cons (normalize (caadr term) #t var-nr)
+ (map (lambda (x) (normalize x #f var-nr))
+ (cdadr term)))
+ (map (lambda (x) (normalize x #f var-nr))
+ (cddr term)))
+ (begin
+ (let* ((actual (filter (lambda (x) (not (null? (cddr x))))
+ (car term)))
+ (non-actual (filter (lambda (x) (null? (cddr x)))
+ (car term)))
+ (vars (map car actual))
+ (inits (map cadr actual))
+ (bodies (map caddr actual))
+ (new-var '())
+ (new-var-pairs '())
+ (new-bodies '()))
+ (do ((part actual (cdr part))
+ (vars-part vars (cdr vars-part))
+ (bodies-part bodies (cdr bodies-part)))
+ ((null? part))
+ (if (inside-term? (car vars-part) (cdr bodies-part))
+ (begin
+ (set! var-nr (+ 1 var-nr))
+ (set! new-var (make-new-var var-nr))
+ (set! new-var-pairs
+ (cons (list new-var (car vars-part))
+ new-var-pairs))
+ (set! bodies-part
+ (cons (car bodies-part)
+ (subst-term new-var
+ (car vars-part)
+ (cdr bodies-part))))
+ (set! new-bodies
+ (cons (car bodies-part) new-bodies)))
+ (begin
+ (set! new-bodies
+ (cons (car bodies-part) new-bodies)))))
+ (if (null? new-var-pairs)
+ (list* 'do
+ (map (lambda (x) (normalize x #f var-nr))
+ (car term))
+ (cons (normalize (caadr term) #t var-nr)
+ (map (lambda (x) (normalize x #f var-nr))
+ (cdadr term)))
+ (map (lambda (x) (normalize x #f var-nr))
+ (cddr term)))
+ (list 'let*
+ (append
+ non-actual
+ (map (lambda (x) (list (car x) *dummy*)) new-var-pairs))
+ (list* 'do
+ (map (lambda (x y z)
+ (list x (normalize y #f var-nr)
+ (normalize z #f var-nr)))
+ vars
+ inits
+ (reverse new-bodies))
+ (cons (normalize (caadr term) #t var-nr)
+ (map (lambda (x) (normalize x #f var-nr))
+ (cdadr term)))
+ (append (map (lambda (x) (normalize x #f var-nr))
+ (cddr term))
+ (map (lambda (x) (cons 'set! x))
+ new-var-pairs)))))))))
+
+
+
+
+;;; normalize-cond is one of the main transformers.
+;;; It converts a cond to the if-ladder, introducing
+;;; lets and new variables where needed.
+;;;
+;;; NB! In the following *and?* and *or?* are special new functions,
+;;; which are considered to be strictly boolean, and can be
+;;; converted directly to corresponding C operators.
+
+(define (normalize-cond term bool-flag var-nr)
+ (cond
+ ((null? term) *unspecified*)
+ ((null? (cdar term))
+ (if bool-flag
+ `(*and?* ,(normalize (caar term) #t var-nr)
+ ,(normalize-cond (cdr term) #t var-nr))
+ (let ((new-var (make-new-var (+ 1 var-nr))))
+ `(let* ((,new-var ,(normalize (caar term) #f (+ 1 var-nr))))
+ (if ,new-var ,new-var
+ ,(normalize-cond (cdr term) #f var-nr))))))
+ ((eq? (cadar term) '=>)
+ (let ((new-var (make-new-var (+ 1 var-nr))))
+ `(let* ((,new-var ,(normalize (caar term) #f (+ 1 var-nr))))
+ (if ,new-var
+ ,(normalize (list (caddar term) new-var)
+ bool-flag (+ 1 var-nr))
+ ,(normalize-cond (cdr term) bool-flag (+ 1 var-nr))))))
+ ((eq? (caar term) 'else)
+ (if (null? (cddar term))
+ (normalize (cadar term) bool-flag var-nr)
+ (normalize (cons 'begin (cdar term)) bool-flag var-nr)))
+ ((null? (cddar term))
+ `(if ,(normalize (caar term) #t var-nr)
+ ,(normalize (cadar term) bool-flag var-nr)
+ ,(normalize-cond (cdr term) bool-flag var-nr)))
+ (else
+ `(if ,(normalize (caar term) #t var-nr)
+ ,(normalize (cons 'begin (cdar term)) bool-flag var-nr)
+ ,(normalize-cond (cdr term) bool-flag var-nr)))))
+
+
+;;; normalize-not creates a c-not (*not?* => !) or a scheme-not (not)
+
+(define (normalize-not lst bool-flag var-nr)
+ (if bool-flag
+ (normalize (cons *not?* lst) #t var-nr)
+ (list 'not (normalize (car lst) #t var-nr))))
+
+;;; normalize-and and normalize-or make some optimizations
+;;; and convert terms to if-ladders of *and?* and *or?*.
+
+(define (normalize-and lst bool-flag var-nr)
+ (cond ((null? lst) #t)
+ ((null? (cdr lst)) (normalize (car lst) bool-flag var-nr))
+ ((and bool-flag (not *lift-and-or-flag*))
+ (normalize (cons *and?* lst) #t var-nr))
+ (else
+ `(if ,(normalize (car lst) #t var-nr)
+ ,(normalize-and (cdr lst) bool-flag var-nr)
+ #f ))))
+
+
+(define (normalize-or lst bool-flag var-nr)
+ (cond ((null? lst) #f)
+ ((null? (cdr lst)) (normalize (car lst) bool-flag var-nr))
+ ((and bool-flag (not *lift-and-or-flag*))
+ (normalize (cons *or?* lst) #t var-nr))
+ (bool-flag
+ `(if ,(normalize (car lst) #t var-nr)
+ #t
+ ,(normalize-or (cdr lst) #t var-nr)))
+ (else
+ (normalize `(cond ,@(map list (butlast lst 1))
+ (else ,(car (my-last-pair lst))))
+ bool-flag var-nr ))))
+
+
+;;; normalize-case does the obvious thing.
+
+(define (normalize-case term bool-flag var-nr)
+ (let* ((new-var (make-new-var (+ 1 var-nr)))
+ (tmp
+ `(let* ((,new-var ,(cadr term)))
+ (cond
+ ,@(normalize-case-aux new-var (cddr term))))))
+ (normalize tmp bool-flag (+ 1 var-nr))))
+
+
+(define (normalize-case-aux var lst)
+ (cond ((null? lst) '())
+ ((eq? (caar lst) 'else) (list (car lst)))
+ ((list? (caar lst))
+ (append (map (lambda (x) `((eqv? (quote ,x) ,var) ,@(cdar lst)))
+ (caar lst))
+ (normalize-case-aux var (cdr lst))))
+ (else (report-error "Bad case clause syntax:" lst))))
+
+
+
+;;; file-opening and calling with normalization assumes a single
+;;; generic file opening two-arg function *open-file-function* and
+;;; corresponding strings for input and output.
+;;; Calling with files is normalized into a let with assuming
+;;; a function *set-current-input-port-function* and a function
+;;; *set-current-output-port-function*
+
+(define (normalize-open-input-file term bool-flag var-nr)
+ (list *open-file-function*
+ (normalize (car term) #f var-nr)
+ *input-file-modifier*))
+
+(define (normalize-open-output-file term bool-flag var-nr)
+ (list *open-file-function*
+ (normalize (car term) #f var-nr)
+ *output-file-modifier*))
+
+(define (normalize-with-input-from-file term bool-flag var-nr)
+ (let* ((new-var1 (make-new-var (+ 1 var-nr)))
+ (new-var2 (make-new-var (+ 2 var-nr)))
+ (new-var3 (make-new-var (+ 3 var-nr))))
+ `(let* ((,new-var1 (,*open-file-function*
+ ,(normalize (car term) #f new-var3)
+ ,*input-file-modifier*))
+ (,new-var2 (,*set-current-input-port-function* ,new-var1))
+ (,new-var3 (,(normalize (cadr term) bool-flag new-var3))))
+ (close-input-port ,new-var1)
+ (,*set-current-input-port-function* ,new-var2)
+ ,new-var3)))
+
+(define (normalize-with-output-to-file term bool-flag var-nr)
+ (let* ((new-var1 (make-new-var (+ 1 var-nr)))
+ (new-var2 (make-new-var (+ 2 var-nr)))
+ (new-var3 (make-new-var (+ 3 var-nr))))
+ `(let* ((,new-var1 (,*open-file-function*
+ ,(normalize (car term) #f new-var3)
+ ,*output-file-modifier*))
+ (,new-var2 (,*set-current-output-port-function* ,new-var1))
+ (,new-var3 (,(normalize (cadr term) bool-flag new-var3))))
+ (,*set-current-output-port-function* ,new-var2)
+ (close-output-port ,new-var1)
+ ,new-var3)))
+
+(define (normalize-call-with-input-file term bool-flag var-nr)
+ (let* ((new-var1 (make-new-var (+ 1 var-nr)))
+ (new-var2 (make-new-var (+ 2 var-nr))))
+ `(let* ((,new-var1 (,*open-file-function*
+ ,(normalize (car term) #f new-var2)
+ ,*input-file-modifier*))
+ (,new-var2 (,(normalize (cadr term) bool-flag new-var2)
+ ,new-var1)))
+ (close-input-port ,new-var1)
+ ,new-var2)))
+
+
+(define (normalize-call-with-output-file term bool-flag var-nr)
+ (let* ((new-var1 (make-new-var (+ 1 var-nr)))
+ (new-var2 (make-new-var (+ 2 var-nr))))
+ `(let* ((,new-var1 (,*open-file-function*
+ ,(normalize (car term) #f new-var2)
+ ,*output-file-modifier*))
+ (,new-var2 (,(normalize (cadr term) bool-flag new-var2)
+ ,new-var1)))
+ (close-output-port ,new-var1)
+ ,new-var2)))
+
+
+;;; The following normalize-comparisons and
+;;; normalize-associative convert associative functions into
+;;; functions of exactly the arity two. List function is replaced
+;;; by a corresponding cons structure.
+
+(define (normalize-list term bool-flag var-nr)
+ (normalize (normalize-list-aux (cdr term)) bool-flag var-nr))
+
+(define (normalize-list-aux lst)
+ (cond ((null? lst) ''())
+ ((null? (cdr lst)) `(cons ,(car lst) '()))
+ (else
+ `(cons ,(car lst)
+ ,(normalize-list-aux (cdr lst))))))
+
+(define (normalize-list-for-c lst)
+ (cond ((null? lst) '())
+ ((null? (cdr lst)) `(cons ,(car lst) ()))
+ (else
+ `(cons ,(car lst)
+ ,(normalize-list-for-c (cdr lst))))))
+
+(define (normalize-comparison data lst bool-flag var-nr)
+ (cond ((null? lst) (report-error "too few args in comparison " (car data)))
+ ((null? (cdr lst))
+ (report-error "too few args in comparison " (car data)))
+ ((null? (cddr lst))
+ (list (car data)
+ (normalize (car lst) #f var-nr)
+ (normalize (cadr lst) #f var-nr)))
+ ;;at least three args left
+ (else (list *and?*
+ (normalize-comparison data (butlast lst 1)
+ #t var-nr)
+ (let* ((rev (reverse lst))
+ (tmp (list
+ (normalize (cadr rev) #t var-nr)
+ (normalize (car rev) #t var-nr))))
+ (cons (car data) tmp))))))
+
+
+(define (normalize-string-append term bool-flag var-nr)
+ (list (car term)
+ (normalize (normalize-list-aux (cdr term)) #f var-nr)))
+
+
+(define (normalize-associative data lst bool-flag var-nr)
+ (cond ((null? lst) (cadr data))
+ ((null? (cdr lst))
+ (list (car data)
+ (cadr data)
+ (normalize (car lst) (boolean? (cadr data)) var-nr)))
+ ((null? (cddr lst))
+ (list (car data)
+ (normalize (car lst) (boolean? (cadr data)) var-nr)
+ (normalize (cadr lst) (boolean? (cadr data)) var-nr)))
+ ;;at least three args left
+ ((boolean? (cadr data)) ; *or?* and *and?*
+ (list (car data)
+ (normalize (car lst) #t var-nr)
+ (normalize-associative data (cdr lst) #t var-nr)))
+ (else
+ (list (car data)
+ (normalize-associative data (butlast lst 1) #f var-nr)
+ (normalize (car (my-last-pair lst)) #f var-nr)))))
+
+
+(define *associative-fun-table*
+ (append
+ (list (cons *or?* '(#f bool)) (cons *and?* '(#t bool)))
+
+ '((append '() lst) ;;; (string-append "" str)
+ (+ 0 num) (- 0 num) (* 1 num) (/ 1 num) (max -99999 num) (min 99999 num)
+ (%+ 0 num) (%- 0 num) (%* 1 num) (%/ 1 num))))
+
+(define *comparison-fun-table*
+ '((= num) (< num) (> num) (<= num) (>= num)
+ (%= num) (%< num) (%> num) (%<= num) (%>= num)
+ (char=? chr) (char<? chr) (char>? chr) (char<=? chr) (char>=? chr)
+ (char-ci=? chr) (char-ci<? chr) (char-ci>? chr)
+ (char-ci<=? chr) (char-ci>=? chr)
+ (string=? str) (string<? str) (string>? str) (string<=? str) (string>=? str)
+ (string-ci=? str) (string-ci<? str) (string-ci>? str)
+ (string-ci<=? str) (string-ci>=? str)))
+
+; pre-4d-version:
+;(define (make-new-var nr)
+; (string->symbol (string-append *new-var-name* (number->string nr))))
+
+; from-4d-version:
+(define (make-new-var nr)
+ (set! *new-vars-nr-for-topfun* (+ 1 *new-vars-nr-for-topfun*))
+ (string->symbol (string-append *new-var-name*
+ (number->string *new-vars-nr-for-topfun*))))
+
+;==================================================================
+;
+; delay transformer
+;
+;=================================================================
+
+
+;;; The following normalizes applications of 'delay'.
+;;; It should be used as a preprocessor to normalizer.
+
+(define (normalize-delay term)
+ (cond ((not (pair? term)) term)
+ ((not (some-in-fun-position? '(delay force) term))
+ term)
+ ((eq? (car term) 'quote) term)
+ ((eq? (car term) 'lambda)
+ `(lambda ,(cadr term) ,@(normalize-delay (cddr term))))
+ ((eq? (car term) 'define)
+ (cons 'define
+ (cons (cadr term)
+ (normalize-delay (cddr term)))))
+ ((and (eq? (car term) 'delay)
+ (pair? (cdr term))
+ (null? (cddr term)))
+ `(,*make-promise-function*
+ (lambda () ,(normalize-delay (cadr term)))))
+ ((and (eq? (car term) 'force)
+ (pair? (cdr term))
+ (null? (cddr term)))
+ `(,*force-function* ,(normalize-delay (cadr term))))
+ (else
+ (map normalize-delay term))))
+
+
+;==================================================================
+;
+; quasiquote transformer
+;
+;=================================================================
+
+
+;;; The following compiles quasiquotes. It should be used as a
+;;; preprocessor to normalizer. It should compile the full
+;;; quasiquote syntax, including nested quasiquotes.
+
+(define (compile-quasiquote term)
+ (cond ((not (pair? term)) term)
+ ((not (occurs-in-function-position? 'quasiquote term)) term)
+ ((eq? (car term) 'quote) term)
+ ((eq? (car term) 'lambda)
+ `(lambda ,(cadr term) ,@(compile-quasiquote (cddr term))))
+ ((eq? (car term) 'define)
+ (cons 'define
+ (cons (cadr term)
+ (compile-quasiquote (cddr term)))))
+ ((eq? (car term) 'quasiquote)
+ (normalize-quasiquote (cadr term) 1))
+ (else
+ (map compile-quasiquote term))))
+
+
+(define (normalize-quasiquote term depth)
+ (cond
+;;; ((not (or (occurs-in-function-position? 'unquote term)
+;;; (occurs-in-function-position? 'unquote-splicing term)))
+;;; `(quote ,term))
+ ((vector? term)
+ `(apply vector ,(normalize-quasiquote (vector->list term) depth)))
+ ((not (pair? term))
+ `(quote ,term))
+ ((and (eq? (car term) 'unquote) (eqv? depth 1))
+ (car (compile-quasiquote (cdr term))))
+ ((not (pair? (car term)))
+ `(cons (quote ,(car term))
+ ,(normalize-quasiquote (cdr term) depth)))
+ ((eq? (caar term) 'unquote)
+ (if (eqv? depth 1)
+ `(cons ,(compile-quasiquote (cadar term))
+ ,(normalize-quasiquote (cdr term) depth))
+ (list 'cons
+ (list 'cons
+ ''unquote
+ (normalize-quasiquote (cdar term) (- depth 1)))
+ (normalize-quasiquote (cdr term) depth))))
+ ((eq? (caar term) 'unquote-splicing)
+ (if (eqv? depth 1)
+ `(append ,(compile-quasiquote (cadar term))
+ ,(normalize-quasiquote (cdr term) depth))
+ (list 'cons
+ (list 'cons
+ ''unquote-splicing
+ (normalize-quasiquote (cdar term) (- depth 1)))
+ (normalize-quasiquote (cdr term) depth))))
+ ((eq? (caar term) 'quasiquote)
+ `(cons ,(normalize-quasiquote (car term) (+ 1 depth))
+ ,(normalize-quasiquote (cdr term) depth)))
+ (else
+ `(cons ,(normalize-quasiquote (car term) depth)
+ ,(normalize-quasiquote (cdr term) depth)))))
+
+
+
+
+(define (occurs-in-function-position? f term)
+ (and (pair? term)
+ (or (and (eq? (car term) f) (list? (cdr term)))
+ (occurs-in-function-position? f (car term))
+ (occurs-in-function-position? f (cdr term)))))
+
+;=============================================================
+;
+; removing topmost surrounding let's
+;
+;===========================================================
+
+
+(define (remove-lambdasurrounding-let def)
+ (if (and (list? def)
+ (eq? 3 (length def))
+ (pair? (caddr def))
+ (or (eq? 'let (car (caddr def)))
+ (eq? 'let* (car (caddr def))))
+ (pair? (cddr (caddr def)))
+ (pair? (caddr (caddr def)))
+ (null? (cdddr (caddr def)))
+ (eq? 'lambda (car (caddr (caddr def)))))
+ (remove-lambdasurrounding-let-aux def)
+ def))
+
+(define (remove-lambdasurrounding-let-aux def)
+ (let* ((letbindings (cadr (caddr def)))
+ (lambdaterm (caddr (caddr def))))
+ (set! *global-vars-list*
+ (append *global-vars-list* (map car letbindings)))
+ (set! *top-actions-list*
+ (append (map (lambda (x)
+ (let ((name (make-constant-name)))
+ (set! *var-make-list*
+ (cons
+ (list 'set! (car x)
+ (list 'scm-gc-protect
+ (list *c-adr* name)))
+ *var-make-list*))
+ (set! *via-interpreter-defined*
+ (cons (car x) *via-interpreter-defined*))
+ (list 'set! (car x) (cadr x))))
+ letbindings)
+ *top-actions-list*))
+ (list (car def) (cadr def) lambdaterm)))
+
+
+
+
+;=============================================================
+;
+; variable renaming
+;
+;============================================================
+
+
+;;; rename-vars performs a very important function: it renames
+;;; vars, removing clashes of bound variable names.
+;;; rename-vars tries to rename as few variables as possible;
+;;; in doing that it takes into account that all variable declarations
+;;; in the term should be liftable to the very top of the term.
+;;;
+;;; After applying rename-vars, all variable bindings in lets can
+;;; (and should) be changed to simple set!s in the corresponding order.
+;;;
+;;; That is, the resulting let is actually a let*, or, better yet,
+;;; (let ((a b) ... (g h)) ...) should be treated
+;;; as (begin (set! a b) ... (set! g h) ...).
+;;; All the variables introduced in such lets should be declared
+;;; as local variables of a pointer type in the corresponding
+;;; c function, and set! should be translated to = in the
+;;; obvious way. Thus the resulting let can be translated to the
+;;; C block, for example.
+;;;
+;;; NB! Different types of lets (including the one in do) are all
+;;; converted to the scheme explained above.
+;;;
+;;; NB! Letrec is not handled fully here, in the sense that when
+;;; we perform lambda-lifting, there are some special complexities
+;;; which must be handled.
+
+
+(define *passed-locvars-list* '())
+
+(define (rename-vars term)
+ (set! *var-nr* 0)
+ (set! *passed-locvars-list* '())
+ (set! *free-vars-list* (all-free-vars term))
+ (rename-vars-aux term '() #t))
+
+
+;;; rename-vars-aux takes a topflag, which is true iff term is NOT yet
+;;; inside some lambdaterm. In that case all the vars bound in let are
+;;; renamed by a global scheme in order to be initialized in the
+;;; initialization function.
+
+(define (rename-vars-aux term env topflag)
+ (cond
+ ((symbol? term)
+ (cond ((assq term env) => cdr)
+ (else term)))
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((eq? 'lambda (car term))
+ `(lambda
+ ,@(rename-vars-aux (cdr term)
+ (make-new-env-lambda
+ (args->list (cadr term))
+ env)
+ #f)))
+ ((eq? 'let (car term))
+ (let ((new-env (make-new-env (map car (cadr term)) env topflag)))
+ `(let
+ ,(map (lambda (x)
+ (list (rename-vars-aux (car x) new-env topflag)
+ (rename-vars-aux (cadr x) env topflag)))
+ (cadr term))
+ ,@(rename-vars-aux (cddr term) new-env topflag))))
+ ((eq? 'do (car term))
+ (let ((new-env (make-new-env (map car (cadr term)) env #f)))
+ `(do
+ ,(map (lambda (x)
+ (cons (rename-vars-aux (car x) new-env #f)
+ (cons (rename-vars-aux (cadr x) env #f)
+ (rename-vars-aux (cddr x)
+ new-env #f))))
+ (cadr term))
+ ,@(rename-vars-aux (cddr term) new-env #f))))
+ ((eq? 'let* (car term))
+ (let ((new-env env)
+ (old-env env)
+ (new-args '()))
+ (do ((part (cadr term) (cdr part)))
+ ((null? part)
+ `(let
+ ,(reverse new-args)
+ ,@(rename-vars-aux (cddr term) new-env topflag)))
+ (set! old-env new-env)
+ (set! new-env (make-new-env (list (caar part)) new-env topflag))
+ (set! new-args
+ (cons (list (rename-vars-aux (caar part) new-env topflag)
+ (rename-vars-aux
+ (cadar part) old-env topflag))
+ new-args )))))
+ ((eq? 'letrec (car term))
+ (let ((new-env (make-new-env (map car (cadr term)) env topflag)))
+ `(letrec ,@(rename-vars-aux (cdr term) new-env topflag))))
+ ((eq? 'define (car term))
+ (map (lambda (x) (rename-vars-aux x env topflag)) term))
+ ((list? term)
+ (map (lambda (x) (rename-vars-aux x env #f)) term))
+ (else (cons (rename-vars-aux (car term) env #f)
+ (rename-vars-aux (cdr term) env #f)))))
+
+
+(define (args->list args)
+ (cond ((symbol? args) (list args))
+ ((list? args)
+ (map (lambda (x) (if (pair? x) (cadr x) x)) args))
+ ((pair? args)
+ (cons (if (pair? (car args)) (cadar args) (car args))
+ (args->list (cdr args))))
+ (else (report-error "Bad argument list:" args))))
+
+
+(define (make-new-env vars env topflag)
+ (let ((name '()))
+ (append (map (lambda (x)
+ (cond
+ ((or (memq x *new-fun-names*)
+ (and (not (assq x env))
+ (not topflag)
+ (not (memq x *keywords*))
+ (not (memq x *primitives*))
+ (not (memq x *top-level-names*))
+ (not (memq x *passed-locvars-list*))
+ (not (memq x *free-vars-list*))))
+ (set! *passed-locvars-list*
+ (cons x *passed-locvars-list*))
+ (cons x x))
+ ((not topflag)
+ (set! *var-nr* (+ 1 *var-nr*))
+ (cons x
+ (string->symbol
+ (string-append
+ (symbol->string x)
+ *local-var-infix*
+ (number->string *var-nr*)))))
+ (else
+ (set! *new-fun-nr* (+ 1 *new-fun-nr*))
+ (cons x
+ (string->symbol
+ (string-append
+ (symbol->string x)
+ *new-fun-infix*
+ (number->string *new-fun-nr*)))))))
+ vars)
+ env )))
+
+(define (make-new-env-lambda vars env)
+ (append (map (lambda (x)
+ (if (or (assq x env)
+ (memq x *keywords*)
+ (memq x *primitives*)
+ (memq x *top-level-names*))
+ (cons x
+ (string->symbol
+ (string-append
+ (symbol->string x)
+ *local-var-infix*
+ (begin (set! *var-nr* (+ 1 *var-nr*))
+ (number->string *var-nr*)))))
+ (cons x x)))
+ vars )
+ env ))
+
+
+;===============================================================
+;
+; define - transformer
+;
+;===============================================================
+
+;;; normalize-defines converts fancy defines into basic ones.
+
+(define (normalize-defines term)
+ (cond
+ ((not (pair? term)) term)
+ ((eq? (car term) 'quote) term)
+ ((eq? (car term) 'define)
+ ;; the coming if removes let in the case:
+ ;; (define foo (let ((bar bar)) ...))
+ ;; (if (and (pair? (cdr term))
+ ;; (pair? (cddr term))
+ ;; (pair? (caddr term))
+ ;; (memq (car (caddr term)) '(let let* letrec))
+ ;; (pair? (cadr (caddr term)))
+ ;; (not (find-if (lambda (x) (not (eq? (car x) (cadr x))))
+ ;; (cadr (caddr term)))))
+ ;; (set! term (cons 'define (cons (cadr term) (cddr (caddr term))))))
+ (if (pair? (cadr term))
+ `(define ,(caadr term)
+ ,(normalize-defines
+ (cons 'lambda (cons (cdadr term) (cddr term)))))
+ `(define ,(cadr term) ,(normalize-defines (caddr term)))))
+ ((and (memq (car term) '(let* letrec))
+ (not (list? (cadr term))))
+ (report-error
+ "In " *current-fun-name* " there is wrong let: " term))
+
+ ;;; the next case rewrites a named let to a letrec, never succeeds.
+ ((begin
+ (if (and (eq? (car term) 'let)
+ (not (null? (cdr term)))
+ (not (null? (cddr term)))
+ (symbol? (cadr term))
+ (not (null? (cadr term))))
+ ;;; a named let
+ (if (find-if (lambda (x)
+ (or (null? x) (not (list? x)) (null? (cdr x))))
+ (caddr term))
+ (report-error
+ *current-fun-name*
+ " contains an incorrect named let: " term)
+ (let ((param (map car (caddr term)))
+ (args (map cadr (caddr term))))
+ (set! term
+ (list 'letrec
+ (list
+ (list (cadr term)
+ (list* 'lambda param (cdddr term))))
+ (cons (cadr term) args))))))
+ #f))
+ ((and (memq (car term) '(lambda let let* letrec do))
+ (pair? (caddr term))
+ (eq? 'define (caaddr term)))
+ (let ((defs (normalize-defines-aux (cddr term)))
+ (other (member-if
+ (lambda (x)
+ (or (not (pair? x)) (not (eq? (car x) 'define))))
+ (cddr term))))
+ (if (not other) (report-error "Body is missing:" term))
+ `(,(car term)
+ ,(normalize-defines (cadr term))
+ ,(normalize-defines (cons 'letrec (cons defs other))))))
+ ((list? term)
+ (map normalize-defines term))
+ (else
+ (cons (normalize-defines (car term))
+ (normalize-defines (cdr term))))))
+
+
+(define (normalize-defines-aux lst)
+ (if (and (not (null? lst)) (pair? (car lst)) (eq? 'define (caar lst)))
+ (cons (cdr (normalize-defines (car lst)))
+ (normalize-defines-aux (cdr lst)))
+ '()))
+
+;=================================================================
+;
+; Global analysis
+;
+;=================================================================
+
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+;
+; analysis for liftability and mutability
+;
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+; lift-analyse-def! takes a def where all the lambdas are renamed
+; (by taking extra let-s with names), vars are renamed and letrecs
+; are ordered.
+;
+; it dest. changes the def body by replacing the leading lambda of
+; all the liftable lambdaterms with the value of *liftable-lambda*
+
+
+(define *local-liftnames* '())
+(define *liftable-lambda* '**liftable-lambda**)
+(define *def-hofname* '())
+
+(define (lift-analyse-def! def)
+ (let* ((funname (cadr def))
+ (lterm (caddr def)))
+ (set! *local-liftnames* '())
+ (set! *def-hofname* funname)
+ (lift-analyse-def-aux! lterm)
+ (if (and (pair? lterm)
+ (not (all-liftable? (cdr lterm))))
+ (set! *not-all-liftable-names*
+ (cons funname *not-all-liftable-names*)))))
+
+
+; lift-analyse-def-aux! term:
+; term is a term
+;
+; all lambdaterms must be named.
+;
+; liftable lambdas are destr. replaced by *liftable-lambda*,
+; their names are added to *local-liftnames*
+;
+
+(define (lift-analyse-def-aux! term)
+ (let* ((name '())
+ (passed '())
+ (tmp '()))
+ (cond
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? 'lambda (car term))
+ (for-each (lambda (x) (lift-analyse-def-aux! x)) (cddr term)))
+;;; ((eq? *liftable-lambda* (car term))
+;;; (for-each (lambda (x) (lift-analyse-def-aux! x)) (cddr term)))
+ ((and (pair? (car term))
+ (eq? 'lambda (caar term)))
+ (for-each lift-analyse-def-aux! (cddar term))
+ (if (all-liftable? (cddar term))
+ (set-car! (car term) *liftable-lambda*))
+ (for-each lift-analyse-def-aux! (cdr term)))
+ ((memq (car term) '(let* let))
+ (for-each lift-analyse-def-aux! (cddr term))
+ (do ((part (reverse (cadr term)) (cdr part)))
+ ((null? part))
+ (set! name (caar part))
+ (lift-analyse-def-aux! (cadar part))
+ (if (and (pair? (cadar part))
+ (eq? 'lambda (caadar part))
+ (all-liftable? (cddr (cadar part)))
+ (liftable-nameocc? name (cddr (cadar part)))
+ (liftable-nameocc? name (cons 'begin passed))
+ (liftable-nameocc? name (cons 'begin (cddr term))))
+ (begin
+ (set! *local-liftnames*
+ (cons name *local-liftnames*))
+ (set-car! (cadar part) *liftable-lambda*)))
+ (set! passed (cons (cadar part) passed))))
+ ((eq? (car term) 'letrec)
+ (for-each lift-analyse-def-aux! (cddr term))
+ (for-each (lambda (el) (lift-analyse-def-aux! (cadr el))) (cadr term))
+ (if (and (every1 (lambda (el)
+ (and (pair? (cadr el))
+ (eq? 'lambda (caadr el))
+ (all-liftable? (cddr (cadr el)))))
+ (cadr term))
+ (every1 (lambda (el)
+ (and (liftable-nameocc? (car el)
+ (cons 'begin (cddr term)))
+ (every1 (lambda (el2)
+ (liftable-nameocc?
+ (car el) (cddr (cadr el2))))
+ (cadr term))))
+ (cadr term)))
+ (for-each (lambda (el)
+ (set! *local-liftnames*
+ (cons (car el) *local-liftnames*))
+ (set-car! (cadr el) *liftable-lambda*))
+ (cadr term))))
+ ((and (liftable-hofname? (car term))
+ (not (eq? (car term) *def-hofname*)))
+ (set! tmp (assq (car term) *liftable-hof-database*))
+ ;; (if tmp (begin (newline) (display "term: ") (display term) (newline)))
+ (if tmp
+ ;; case for top-level def of a higher-order fun:
+ (if (every1 (lambda (x)
+ ;; (newline) (display "x: ") (display x) (newline)
+ (let ((param (car x))
+ (arg (cdr x)))
+ ;; (display "param: ") (display param) (newline)
+ ;; (display "arg: ") (display arg) (newline)
+ (if param
+ (or (and (pair? arg)
+ (or (eq? 'lambda (car arg))
+ (eq? *liftable-lambda*
+ (car arg)))
+ (begin
+ (for-each
+ lift-analyse-def-aux!(cddr arg))
+ ;; (newline) (display "cddr arg:")
+ ;; (display (cddr arg)) (newline)
+ (all-liftable? (cddr arg))))
+ (and (symbol? arg)
+ (memq arg *top-level-names*)
+ (not (modified-fun? arg))))
+ #t)))
+ (map cons (cdr tmp) (cdr term)))
+ (for-each (lambda (param arg)
+ (if (and param
+ (pair? arg)
+ (eq? 'lambda (car arg))
+ (all-liftable? (cddr arg)))
+ (set-car! arg *liftable-lambda*)))
+ (cdr tmp)
+ (cdr term))
+ (let ((name
+ (string->symbol
+ (string-append (symbol->string (car term))
+ *export-hof-postfix*))))
+ (set! *top-level-names*
+ (cons name *top-level-names*))
+ (set-car! term name)))
+ ;; case for map and for-each:
+ (for-each (lambda (arg)
+ (if (and (pair? arg)
+ (eq? 'lambda (car arg)))
+ (set-car! arg *liftable-lambda*)))
+ (cdr term)))
+ (for-each (lambda (x) (lift-analyse-def-aux! x)) (cdr term)))
+ (else
+ (for-each (lambda (x) (lift-analyse-def-aux! x)) term)))))
+
+
+(define (all-liftable? term)
+ (cond ((not (pair? term)) (not (eq? 'lambda term)))
+ ((eq? 'quote (car term)) #t)
+ (else (and (all-liftable? (car term))
+ (all-liftable? (cdr term))))))
+
+(define (guaranteed-all-liftable? term)
+ (cond ((not (pair? term)) (not (eq? 'lambda term)))
+ ((eq? 'quote (car term)) #t)
+ ((and (or (eq? 'map (car term)) (eq? 'for-each (car term))
+ (eq? *map1-function* (car term))
+ (eq? *for-each1-function* (car term)))
+ (pair? (cdr term))
+ (pair? (cadr term)))
+ (and (guaranteed-all-liftable? (cdadr term))
+ (guaranteed-all-liftable? (cddr term))))
+ (else (and (guaranteed-all-liftable? (car term))
+ (guaranteed-all-liftable? (cdr term))))))
+
+(define (lift-unmark-def! term)
+ (cond
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? *liftable-lambda* (car term))
+ (set-car! term 'lambda)
+ (for-each lift-unmark-def! (cdr term)))
+ ((list? term)
+ (for-each lift-unmark-def! term))
+ (else term)))
+
+
+; liftable-nameocc? name term:
+; name a name of some fun,
+; term is the term where the use of name is checked.
+;
+; gives #f iff name is used in the nonliftable context
+
+(define (liftable-nameocc? name term)
+ (cond
+ ((not (pair? term)) #t)
+ ((eq? 'quote (car term)) #t)
+ ((eq? 'lambda (car term))
+ (not (inside-term? name (cddr term))))
+ ((and (memq name (cdr term))
+ (not (liftable-hofname? (car term))))
+ #f)
+ (else
+ (every1 (lambda (x) (liftable-nameocc? name x)) term))))
+
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+;
+; checking liftability of higher-order funs
+;
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define *liftable-hof-primitives*
+ (list *map1-function* *for-each1-function* 'map 'for-each))
+
+(define (liftable-hofname? name)
+ (and (or (memq name *liftable-hof-primitives*)
+ (memq name *liftable-hof-names*))
+ (not (modified-fun? name))))
+
+
+; liftable-hof? lterm name:
+; checks whether lterm with name is a liftable hof
+
+
+(define (liftable-hof? lterm name)
+ (let* ((args (args->list (cadr lterm)))
+ (hof-args (filter-hof-args lterm args)))
+ (if (and (not (null? hof-args))
+ (liftable-nameocc? name (cddr lterm))
+ (not (member-if (lambda (x)
+ (not (liftable-hofvars-usage?
+ x name hof-args args)))
+ (cddr lterm))))
+ (begin
+ (set! *liftable-hof-database*
+ (cons (cons name (map (lambda (x) (if (memq x hof-args) #t #f))
+ args))
+ *liftable-hof-database*))
+ #t)
+ (if (not (null? hof-args))
+ (begin (set! *non-liftable-hof-names*
+ (cons name *non-liftable-hof-names*))
+ #f)
+ #f))))
+
+
+; filter-hof-args term args:
+; filters out the functional args from args
+
+
+(define *found-hof-args* '())
+(define *check-hof-args* '())
+
+(define (filter-hof-args term args)
+ (if (null? args)
+ '()
+ (begin
+ (set! *check-hof-args* args)
+ (set! *found-hof-args* '())
+ (filter-hof-args-aux! term)
+ *found-hof-args*)))
+
+
+(define (filter-hof-args-aux! term)
+ (let* ((tmp '()))
+ (cond
+ ((null? *check-hof-args*))
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? 'lambda (car term))
+ (for-each filter-hof-args-aux! (cddr term)))
+ ((begin (set! tmp (memq (car term) *check-hof-args*))
+ tmp)
+ (set! *found-hof-args* (cons (car tmp) *found-hof-args*))
+ (set! *check-hof-args* (remove-one (car tmp) *check-hof-args*))
+ (for-each filter-hof-args-aux! term))
+ (else
+ (for-each filter-hof-args-aux! term)))))
+
+; liftable-hofvars-usage? term name hof-args:
+; checks that hof-args are used in the term with name only
+; in the function position or as same args to name itself and
+; that the name is not called with lambdaterms at hof-places
+; and that hof-places are exactly the same args.
+; hof-args may also not occur in the inside lambda-terms.
+
+(define (liftable-hofvars-usage? term name hof-args args)
+ (cond
+ ((not (pair? term)) #t)
+ ((eq? 'quote (car term)) #t)
+ ((or (eq? 'lambda (car term)) (eq? *liftable-lambda* (car term)))
+ (not (find-if (lambda (x) (some-inside-term? hof-args x)) (cddr term))))
+ ((eq? name (car term))
+ (every1 (lambda (x)
+ (let ((param (car x))
+ (arg (cdr x)))
+ (if (memq param hof-args)
+ (eq? param arg)
+ (and (not (memq arg hof-args))
+ (not (and (pair? arg) (eq? 'lambda (car arg))))))))
+ (map cons args (cdr term))))
+ (else
+ (and (every1 (lambda (el) (not (memq el hof-args))) (cdr term))
+ (every1 (lambda (x) (liftable-hofvars-usage? x name hof-args args))
+ term)))))
+
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+;
+; checking for redefining of functions
+;
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+(define *keywords*
+ '(=> and begin case cond define delay do else if lambda
+ let let letrec or quasiquote quote set! unquote
+ unquote-splicing))
+
+(define (modified-fun? name)
+ (cond
+ (*all-funs-modified-flag*
+ (or (memq name *primitives*)
+ (memq name *top-level-names*)))
+ (*new-funs-modified-flag*
+ (or (memq name *modified-primitives*)
+ (memq name *top-level-names*)))
+ (else
+ (or (memq name *modified-primitives*)
+ (memq name *modified-top-level-names*)))))
+
+(define *top-level-names* '())
+(define *modified-primitives* '())
+(define *modified-top-level-names* '())
+
+(define (make-top-level-namelist! expr-list)
+ (set! *top-level-names* '())
+ (set! *modified-primitives* '())
+ (set! *modified-top-level-names* '())
+ (set! *check-redefining-passed* '())
+ (make-top-level-namelist-aux! expr-list #f)
+;;; (pretty-print expr-list)
+ (make-top-level-namelist-aux! expr-list #t)
+;;; (pretty-print expr-list)
+ (set! *modified-primitives*
+ (set-difference *modified-primitives* *general-transcedentals*))
+ *top-level-names*)
+
+(define *general-transcedentals*
+ '(sqrt log expt exp sin cos tan asin acos atan sinh cosh tanh asinh tanh
+ asinh acosh atanh))
+
+(define (make-top-level-namelist-aux! expr-list redefining-flag)
+ (if (and (pair? expr-list) (list? expr-list))
+ (for-each
+ (lambda (expr)
+ (cond
+ ((not (pair? expr)))
+ ((not (list? expr)))
+ ((eq? 'quote (car expr)))
+ ((eq? (car expr) 'define)
+ (let ((new (normalize-top-define expr)))
+ (if redefining-flag
+ (check-redefining! new #t)
+ (set! *top-level-names*
+ (cons (cadr new) *top-level-names*)))))
+ ((and (eq? 'set! (car expr))
+ redefining-flag)
+ (check-redefining! expr #t))
+ ((not redefining-flag)
+ (for-each (lambda (x) (make-top-level-namelist-aux! x #f))
+ expr))))
+ expr-list)))
+
+(define (compute-floats-flag! term opsflag)
+ (cond (*floats-flag* #t)
+ ((pair? term)
+ (if (eq? 'quote (car term))
+ (compute-floats-flag! (cdr term) #f)
+ (or (compute-floats-flag! (car term) opsflag)
+ (compute-floats-flag! (cdr term) opsflag))))
+ ((vector? term)
+ (do ((i (- (vector-length term) 1) (- i 1)))
+ ((< i 0) *floats-flag*)
+ (compute-floats-flag! (vector-ref term i) opsflag)))
+ ((number? term)
+ (if (or (not (integer? term))
+ (not (exact? term))
+ (> term most-positive-fixnum)
+ (< term most-negative-fixnum))
+ (begin (set! *floats-flag* term) #t)
+ #f))
+ ((not opsflag) #f)
+ ((symbol? term)
+ (if (memq term *float-recognize-ops*)
+ (begin (set! *floats-flag* term) #t)
+ #f))
+ (else #f)))
+
+
+(define *float-recognize-ops*
+ '($sin $cos $tan $asin $acos $atan $sinh $cosh $tanh $asinh $tanh
+ $asinh $acosh $atanh $sqrt $expt $log $abs $exp
+ sin cos tan asin acos atan sinh cosh tanh asinh tanh
+ asinh acosh atanh))
+
+
+(define *check-redefining-passed* '())
+
+(define (check-redefining! term top-level-flag)
+ (let* ((new '()))
+ (cond
+ ((not (pair? term)))
+ ((not (list? term)))
+ ((eq? 'quote (car term)))
+ ((or (eq? 'set! (car term))
+ (and top-level-flag (eq? 'define (car term))))
+ (if (eq? 'define (car term))
+ (set! new (normalize-top-define term))
+ (set! new term))
+ (if (not (eq? 3 (length term)))
+ (report-error " wrong set! or define syntax: " term))
+ (if (memq (cadr new) *keywords*)
+ (report-error " a keyword is set! or defined: " term))
+ (if (memq (cadr new) *primitives*)
+ (or (memq (cadr new) *modified-primitives*)
+ (set! *modified-primitives*
+ (cons (cadr term) *modified-primitives*))))
+ (if (and (memq (cadr new) *top-level-names*)
+ (not (memq (cadr new) *hobbit-declaration-vars*)))
+ (or (memq (cadr new) *modified-top-level-names*)
+ (if (and (eq? 'define (car new))
+ (not (memq (cadr new) *check-redefining-passed*)))
+ (set! *check-redefining-passed*
+ (cons (cadr new) *check-redefining-passed*))
+ (set! *modified-top-level-names*
+ (cons (cadr new) *modified-top-level-names*)))))
+ (check-redefining! (caddr new) #f))
+ ((eq? 'begin (car term))
+ (for-each (lambda (x) (check-redefining! x #t)) term))
+ (else
+ (for-each (lambda (x) (check-redefining! x #f)) term)))))
+
+
+;=====================================================================
+;
+; Building closures
+;
+;====================================================================
+
+;(define *closure-name-suffix* "_cl")
+;(define *closure-name-nr* 0)
+;(define *closure-vector-name* "clargsv_")
+;(define *closure-vector-name-nr* 0)
+;(define *closurefun-arg* 'closurearg_0)
+;(define *closurefun-arg-car* 'closurearg_car_0)
+
+; The whole closurebuilding process is carried on top-down breadth-first:
+; there is no excplicit recursion. Instead, once a new closurefun def
+; is created, it is put into the list *lifted-closures-to-do*, which
+; is afterwards passed and the lambdaterms inside these new funs are
+; made into closures again, etc, until *lifted-closures-to-do* is empty.
+
+; try-closure-making-def is the topmost closure-builder applied to a def.
+
+(define (try-closure-making-def def)
+ (let* ((body (caddr def)))
+ (set! *letrec-closure-nr* 0)
+ (cond ((not (pair? body)) def)
+ ((eq? 'quote (car body)) def)
+ ((eq? 'lambda (car body)) (try-closure-making-ldef def))
+ (else (report-error "try-closure-making-non-ldef called")))))
+
+; try-closure-making-ldef builds closures for lambdaterm-defs.
+; It is never called from anywhere except try-closure-making-def
+; (the topmost closurebuilder)
+
+(define (try-closure-making-ldef def)
+ (let* ((lterm (caddr def))
+ (lvars (args->list (cadr lterm)))
+ (letvars (collect-local-vars (cddr lterm)))
+ (vars (union lvars letvars))
+ ;; closurevars is the subset of set! <vars> inside lambdas:
+ (closurevars (closure-building-vars (cddr lterm) vars))
+ (vectname (make-closure-vector-name)))
+ (set! *current-fun-name* (cadr def))
+ (if (null? closurevars)
+ ;; no set! closurevars found:
+ (list (car def) (cadr def)
+ (list* (car lterm) (cadr lterm)
+ (map (lambda (x)
+ (cdr (make-closure-making
+ x vars closurevars
+ *closurefun-arg-car* vectname)))
+ (cddr lterm))))
+ ;; in the next case some closurevars were found.
+ (let* ((tmp (make-closure-making
+ (cddr lterm) vars closurevars
+ *closurefun-arg-car* vectname))
+ (varsmapping (car tmp))
+ (newterm (cdr tmp))
+ (initialize-argsv
+ (make-initialize-closureargsv vectname lvars varsmapping)))
+ (if (not (null? varsmapping))
+ (beautify-closure
+ (list
+ (car def)
+ (cadr def)
+ (cons (car lterm)
+ (list (cadr lterm)
+ (cons 'let*
+ (cons (cons (list vectname
+ (list 'make-vector
+ (length closurevars)))
+ '())
+ (append initialize-argsv
+ newterm)))))))
+ (beautify-closure
+ (list
+ (car def)
+ (cadr def)
+ (cons (car lterm)
+ (list (cadr lterm)
+ (append initialize-argsv newterm))))))))))
+
+
+; make-closure-vector-name builds a new vector for these local vars
+; which are passed to (and set! inside) closures.
+; default: clargsv_
+;
+; It is called from try-closure-making-ldef, ..-non-ldef, ...-lterm.
+;
+; The created vector-name is added to *closure-var-vectornames*
+; for later recognition as such.
+
+(define (make-closure-vector-name)
+ (set! *closure-vector-name-nr* (+ 1 *closure-vector-name-nr*))
+ (let ((res (string->symbol
+ (string-append *closure-vector-name*
+ (number->string *closure-vector-name-nr*)))))
+ (if (not (memq res *closure-var-vectornames*))
+ (set! *closure-var-vectornames* (cons res *closure-var-vectornames*)))
+ res))
+
+; make-closure-name adds a suffix (default: _cl (+nr)) to the
+; argument functionname. The returned name will be used as a name
+; of the created closurefunction.
+;
+; called from: make-closure-making-aux and make-trivial-closuremaking
+
+(define (make-closure-name currentfunname)
+ (set! *closure-name-nr* (+ 1 *closure-name-nr*))
+ (string->symbol (string-append (symbol->string currentfunname)
+ *closure-name-suffix*
+ (number->string *closure-name-nr*))))
+
+; make-initialize-closureargsv takes a vectorname
+; (made by make-closure-vector for keeping local vars to be passed),
+; lvars (argument vars of a lambdaterm) and varsmapping
+; (mapping of local vars to be kept in vector 'vectorname' to the
+; elements of this vector)
+;
+; It adds vector-set! to each element of varsmapping and filters
+; out (keeps) exactly these which are in lvars. The resulting
+; sequence of assigments ... (set! (vector-ref clargsv_nrn nrx) x)
+; is inserted into function body after creating vector 'vectorname'
+; in order to use the vector-elements instead of the parametric vars
+; of the lambdaterm.
+;
+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm.
+
+(define (make-initialize-closureargsv vectname lvars varsmapping)
+ (filter-map (lambda (x)
+ (if (memq (car x) lvars)
+ (list 'vector-set! vectname
+ (cdr x) (car x))
+ #f))
+ varsmapping))
+
+; make-trivial-closuremaking is called in case the argument term
+; contains no mutable vars in the environment, ie when it does not have
+; to be a proper closure at all, but just a function without a
+; local environment. It returns just the name of the function, to
+; be inserted into the surrounding procedure at the place of the
+; original lambdaterm.
+;
+; called from: make-closuremaking-aux and try-closure-making-ldef, ...-lterm.
+
+(define (make-trivial-closuremaking term)
+ (cond
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((eq? 'lambda (car term))
+ (let* ((fun-name (make-closure-name *current-fun-name*))
+ (procname (make-closure-scmobj-name fun-name))
+ (newdef (list 'define fun-name term)))
+ (set! *lifted-trivial-closure-names*
+ (cons fun-name *lifted-trivial-closure-names*))
+ (set! *top-level-funs*
+ (cons fun-name *top-level-funs*))
+ (if (not (memq procname *special-c-vars*))
+ (set! *special-c-vars* (cons procname *special-c-vars*)))
+ (set! *lifted-closures-to-do*
+ (cons newdef *lifted-closures-to-do*))
+ procname))
+ ((not (list? term)) term)
+ (else
+ (map (lambda (x) (make-trivial-closuremaking x)) term))))
+
+; - - - - - - - - - proper closure-body-building begins - - - - - - - -
+
+
+; make-closure-making creates the correct body of the closure (inside
+; non-liftable lambdaterm which is used together with the vector
+; of its environment) together with the creation/instantiation code
+; inserted into the surrounding fun at the place of the original lambdaterm.
+;
+; vars is the set of environment vars, closurevars is the set of
+; set! environment vars.
+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm
+
+(define (make-closure-making term vars closurevars vectname clvectname)
+ (let* ((varsnr (length closurevars))
+ (tmp -1)
+ (clvarsmapping (map (lambda (x)
+ (set! tmp (+ 1 tmp)) (cons x tmp))
+ closurevars))
+ (newterm '()))
+ (set! newterm (vars->closureaccess
+ term '() clvarsmapping vectname clvectname))
+ (begin (set! newterm
+ (make-closure-making-aux
+ (cdr newterm) '() vars (map car clvarsmapping)
+ vectname clvectname))
+ (cons clvarsmapping newterm))))
+
+
+(define (make-closure-making-aux
+ term holes vars clvars vectname clvectname)
+ (cond
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((or (eq? 'lambda (car term)) (eq? *liftable-lambda* (car term)))
+ (make-closure-making-aux-lterm
+ term holes vars clvars vectname clvectname))
+ ((not (list? term)) term)
+ ((and (eq? 'set! (car term))
+ (pair? (cdr term))
+ (pair? (cddr term))
+ (pair? (caddr term))
+ ;; if it is not lambda, and is inside-term,
+ ;; then the set! var must be in clvars.
+ (eq? 'lambda (caaddr term))
+ (not (memq (cadr term) clvars))
+ (inside-term? (cadr term) (caddr term)))
+ (make-closure-making-aux-set!
+ term holes vars clvars vectname clvectname))
+ ((and (eq? 'letrec (car term))
+ (pair? (cdr term))
+ ;; if some bound var is inside-nonliftable-term,
+ ;; and some leading fun is not a (nonliftable)lambda,
+ ;; then all the bound vars must be in clvars.
+ (every1 (lambda (el) (eq? 'lambda (caadr el)))
+ (cadr term))
+ (find-if (lambda (el) (not (memq (car el) clvars)))
+ (cadr term)))
+ (make-closure-making-aux-letrec
+ term holes vars clvars vectname clvectname))
+ (else
+ (map (lambda (x)
+ (make-closure-making-aux
+ x holes vars clvars vectname clvectname))
+ term))))
+
+(define (make-closure-making-aux-set!
+ term holes vars clvars vectname clvectname)
+ (let* ((tmp '())
+ (newholes (cons (cadr term) holes)))
+ (set! *letrec-closures* '())
+ (set! *letrec-closure-init* '())
+ (set! tmp
+ (make-closure-making-aux
+ (caddr term) newholes vars clvars vectname clvectname))
+ (list* 'let* *letrec-closures*
+ (append (list (list 'set! (cadr term) tmp))
+ *letrec-closure-init*))))
+
+
+(define (make-closure-making-aux-letrec
+ letterm holes vars clvars vectname clvectname)
+ (let* ((bindings (cadr letterm))
+ (body (cddr letterm))
+ (newbindings '())
+ (newholes (append (map car bindings) holes)))
+ (set! *letrec-closures* '())
+ (set! *letrec-closure-init* '())
+ (set! newbindings
+ (map (lambda (el)
+ (list (car el)
+ (make-closure-making-aux
+ (cadr el) newholes vars clvars vectname clvectname)))
+ bindings))
+ (list* 'let* (append *letrec-closures* newbindings)
+ (append
+ *letrec-closure-init*
+ (map (lambda (x)
+ (make-closure-making-aux
+ x holes vars clvars vectname clvectname))
+ body)))))
+
+; make-closure-making-aux-lterm creates the correct body of the closure (inside
+; non-liftable lambdaterm which is used together with the vector
+; of its environment) together with the creation/instantiation code
+; inserted into the surrounding fun at the place of the original lambdaterm.
+;
+; vars is the set of environment vars, closurevars is the set of
+; set! environment vars.
+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm and
+; recursively from make-closure-making-aux
+
+(define (make-closure-making-aux-lterm
+ lterm holes vars clvars vectname clvectname)
+ (let ((params (args->list (cadr lterm))))
+ ;; filter out the subsets of vars actually occurring in lterm,
+ ;; previously throwing away these which are bound in lambda-args.
+ (or (null? vars)
+ (set! vars
+ (filter-inside-term
+ (filter (lambda (x) (not (memq x params)))
+ vars)
+ (cddr lterm))))
+ (cond
+ ((eq? *liftable-lambda* (car lterm))
+ (list* (car lterm) (cadr lterm)
+ (map (lambda (x)
+ (make-closure-making-aux
+ x holes vars clvars vectname clvectname))
+ (cddr lterm))))
+ ((and (null? vars)
+ (not (some-inside-term? *closure-var-vectornames* (cddr lterm))))
+ ;; trivial case: no closure has to be built, function suffices
+ (make-trivial-closuremaking lterm))
+ (else
+ ;; nontrivial case: closure has to be built, but there are no
+ ;; set! closurevars to be handled.
+ (let* ((fun-name (make-closure-name *current-fun-name*))
+ (definf (make-lifted-closure-fun
+ lterm fun-name vars clvars))
+ (applic (make-lifted-closure-applic definf holes)))
+ (set! *lifted-closure-names*
+ (cons fun-name *lifted-closure-names*))
+ (set! *lifted-closures-to-do*
+ (cons (caddr definf) *lifted-closures-to-do*))
+ applic)))))
+
+; make-lifted-closure-fun builds a body of the lambdaterm which is
+; used as a proper closure.
+;
+; vars is the (nonempty) list of free variables occurring in lterm
+;
+; make-lifted-closure-fun is called only from make-closure-making-aux.
+
+
+(define (make-lifted-closure-fun lterm name vars clvars)
+ (let* ((args (cdr (sort-out-clargs (cadr lterm))))
+ (passed-clargsv-lst
+ (filter-inside-term *closure-var-vectornames* (cddr lterm)))
+ (clargstranslation
+ (make-wrapped-clargs-init
+ passed-clargsv-lst *closurefun-arg-car* 1))
+ (varstranslation
+ (make-wrapped-clargs-init
+ vars *closurefun-arg-car* (+ 1 (length passed-clargsv-lst))))
+ (argstranslation
+ (make-wrapped-args-init
+ args *closurefun-arg* 1)))
+ (list
+ vars
+ passed-clargsv-lst
+ (list 'define
+ name
+ (list 'lambda
+ (list *closurefun-arg*)
+ (cons 'let*
+ (cons (append
+ (list (list *closurefun-arg-car*
+ (list 'car *closurefun-arg*)))
+ clargstranslation
+ varstranslation
+ argstranslation)
+ (cddr lterm))))))))
+
+
+; sort-out-clargs takes the parameters of the function to the used as
+; a closure-body. It splits these into the pair of two lists,
+; the car being all these parameters which are closure-var-vectornames
+; and the cdr being these parameters which are not.
+
+; called only from make-lifted-closure-fun.
+
+(define (sort-out-clargs inargs)
+ (let* ((clargs '())
+ (args '()))
+ (do ((part inargs (cdr part)))
+ ((not (pair? part))
+ (cons (reverse clargs)
+ (append (reverse args) part)))
+ (if (memq (car part) *closure-var-vectornames*)
+ (set! clargs (cons (car part) clargs))
+ (set! args (cons (car part) args))))))
+
+; make-wrapped-clargs-init takes a list of vars which are
+; closure-var-vectornames. It creates a let-initialization-list
+; of the form ((<listel> (vector-ref <closurefun-arg-car> 1) ... (..2) ...)
+
+; called only from make-lifted-closure-fun.
+
+(define (make-wrapped-clargs-init clargs varname nr)
+ (cond
+ ((null? clargs) '())
+ (else
+ (cons (list (car clargs) (list 'vector-ref varname nr))
+ (make-wrapped-clargs-init (cdr clargs) varname (+ 1 nr))))))
+
+
+; make-wrapped-args-init takes a list of vars which are _not_
+; closure-var-vectornames. It creates a let-initialization-list
+; of the form ((<listel> (begin (set! <closurefun-arg> (cdr closurefun-arg>))
+; (car <closurefun-arg>))).
+;
+; called only from make-lifted-closure-fun.
+
+(define (make-wrapped-args-init args varname nr)
+ (cond
+ ((null? args) '())
+ ((not (pair? args))
+ (list (list args (list 'cdr varname))))
+ ((zero? nr)
+ (cons (list (car args)
+ (list 'car varname))
+ (make-wrapped-args-init (cdr args) varname (+ 1 nr))))
+ (else
+ (cons (list (car args)
+ (list 'begin
+ (list 'set! varname (list 'cdr varname))
+ (list 'car varname)))
+ (make-wrapped-args-init (cdr args) varname (+ 1 nr))))))
+
+
+; make-lifted-closure-applic takes a newly built closurefun body def
+; and creates code for creating the closure and initializing the
+; environment-vector-part of the closure.
+;
+; called only from make-closure-making-aux.
+
+(define (make-lifted-closure-applic definf holes)
+ (let* ((vars (car definf))
+ (clvects (cadr definf))
+ (newdef (caddr definf))
+ (funname (cadr newdef))
+ (procname (make-closure-scmobj-name funname))
+ (lterm (caddr newdef))
+ (lbody (cddr lterm))
+ (assignments '())
+ (nr 0)
+ (closurename (string->symbol *new-closure-var*))
+ (letrec-assignments '()))
+ (if (not (null? holes))
+ (begin (set! *letrec-closure-nr* (+ 1 *letrec-closure-nr*))
+ (set! closurename
+ (string->symbol
+ (string-append
+ *new-closure-var*
+ (string-append
+ "_" (number->string *letrec-closure-nr*)))))))
+ (for-each (lambda (x)
+ (set! nr (+ 1 nr))
+ (set! assignments
+ (cons (list 'vector-set! closurename nr x)
+ assignments)))
+ clvects)
+ (for-each (lambda (x)
+ (set! nr (+ 1 nr))
+ (set! assignments
+ (cons (list 'vector-set! closurename nr x)
+ assignments)))
+ vars)
+ (cond ((null? holes) ; closure does not occur in letrec top
+ (if (null? assignments)
+ (list *make-cclo* procname (list *actual-c-int* (+ 1 nr)))
+ `(let* ((,closurename
+ (,*make-cclo*
+ ,procname ,(list *actual-c-int* (+ 1 nr)))))
+ ,@(reverse assignments)
+ ,closurename)))
+ (else
+ (set! letrec-assignments
+ (filter (lambda (x) (member (cadddr x) holes))
+ assignments))
+ (set! assignments
+ (filter (lambda (x) (not (member x letrec-assignments)))
+ assignments))
+ (set! *letrec-closures*
+ (append *letrec-closures*
+ (list (list closurename
+ (list *make-cclo* procname
+ (list *actual-c-int* (+ 1 nr)))))))
+ ; closure occurs in letrec top
+ (set! *letrec-closure-init*
+ (append *letrec-closure-init*
+ (reverse letrec-assignments)))
+ (if (null? assignments)
+ closurename
+ (cons 'begin (append assignments (list closurename))))))))
+
+
+;; - - - - - - - - - proper closure-body-building ends - - - - - - - -
+
+
+(define (make-closure-scmobj-name funname)
+ (let ((res (string->symbol
+ (string-append
+ (symbol->string funname) *closure-proc-suffix*))))
+ (or (memq res *special-c-vars*)
+ (set! *special-c-vars* (cons res *special-c-vars*)))
+ res))
+
+(define (list->conses lst)
+ (if (null? lst)
+ (list 'quote '())
+ (let ((tmp (list->conses (cdr lst))))
+ (list 'cons (car lst) tmp))))
+
+(define (cl-vectorname? symb)
+ (memq symb *closure-var-vectornames*))
+
+;vars->closureaccess takes a term and two mappings of vars to closureaccess.
+; a mapping has the format: (<var> . <nr>)
+;
+; it returns a pair (<flag> . <result-term>) where <flag> is #f iff
+; the term does not contain closurevars.
+;
+; it assumes that vars in let-s, lambda, do have been already renamed
+; so that there are no varname-clashes.
+;
+; called only from make-closure-making and recursively.
+
+(define (vars->closureaccess term varsmap clvarsmap vectname clvectname)
+ (cond
+ ((symbol? term)
+ (set! clvarsmap (assq term clvarsmap))
+ (set! varsmap (assq term varsmap))
+ (cond
+ ((and clvarsmap
+ (not (memq term *closure-var-vectornames*)))
+ (cons #t (list 'vector-ref clvectname (cdr clvarsmap))))
+ ((and varsmap
+ (not (memq term *closure-var-vectornames*)))
+ (cons #t (list 'vector-ref vectname (cdr varsmap))))
+ (else
+ (cons #f term))))
+ ((not (pair? term)) (cons #f term))
+ ((eq? 'quote (car term)) (cons #f term))
+ ((eq? *liftable-lambda* (car term))
+ (let* ((vars (args->list (cadr term)))
+ (newmap (filter (lambda (x) (not (memq (car x) vars))) varsmap))
+ (newclmap (filter (lambda (x) (not (memq (car x) vars))) clvarsmap))
+ (tmp (vars->closureaccess
+ (cddr term) newmap newclmap vectname clvectname)))
+ (cons (car tmp) (list* *liftable-lambda* (cadr term) (cdr tmp)))))
+ ((eq? 'lambda (car term))
+ (let* ((vars (args->list (cadr term)))
+ (newmap (filter (lambda (x) (not (memq (car x) vars))) varsmap))
+ (newclmap (filter (lambda (x) (not (memq (car x) vars))) clvarsmap))
+ (tmp (vars->closureaccess
+ (cddr term) newmap newclmap vectname clvectname)))
+ (if (car tmp) ; closurevars used?
+ ; yes, closurevars used:
+ (cons #t (cons 'lambda
+ (cons (cons clvectname (cadr term))
+ (cdr tmp))))
+ ; no, no closurevars were used:
+ (cons #f term))))
+ (else
+ (let ((tmp (map (lambda (x) (vars->closureaccess
+ x varsmap clvarsmap vectname clvectname))
+ term)))
+ (if (find-if (lambda (x) (car x)) tmp)
+ (cons #t (map cdr tmp))
+ (cons #f (map cdr tmp)))))))
+
+
+; closure-building-vars assumes that vars in the term are renamed
+; so that no varname or varname-funname or varname-syntax
+; conflicts occur.
+; it returns the subset of vars in funvars occurring freely and set!
+; inside lambdaterms in term, plus funvars fi occurring freely in the
+; contexts:
+; (1) (set! fi t), where t=/=(lambda (...)...) and fi occurs
+; inside a non-liftable lambdaterm in t.
+; (2) (letrec (... (fi ti) ...) ...), where ti=/=(lambda (...)...) and
+; at least one of fj bound in letrec occurs inside a non-liftable
+; lambdaterm in a tr body in letrec. NB! If some ti=/=(lambda (...)...),
+; the latter condition is automatically guaranteed by previous lifting
+; analysis.
+
+(define *closure-building-vars* '())
+
+(define (closure-building-vars term funvars)
+ (set! *local-vars* funvars)
+ (set! *closure-building-vars* '())
+ (closure-building-vars-aux! term)
+ (filter (lambda (x) (memq x *closure-building-vars*)) funvars))
+
+(define (closure-building-vars-aux! term)
+ (cond
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? 'lambda (car term))
+ (for-each (lambda (var)
+ (if (and (not (memq var *closure-building-vars*))
+ (not (inside-term? var (cadr term)))
+ (inside-term-set? var (cddr term)))
+ (set! *closure-building-vars*
+ (cons var *closure-building-vars*))))
+ *local-vars*))
+ ((eq? *liftable-lambda* (car term))
+ (for-each closure-building-vars-aux! (cddr term)))
+ ((eq? 'set! (car term))
+ (if (and (pair? (caddr term))
+ (not (eq? 'lambda (car (caddr term))))
+ (inside-nonliftable-term? (cadr term) (caddr term))
+ (not (memq (cadr term) *closure-building-vars*)))
+ (set! *closure-building-vars*
+ (cons (cadr term) *closure-building-vars*)))
+ (for-each closure-building-vars-aux! (cdr term)))
+ ((eq? 'letrec (car term))
+ (if (and (find-if (lambda (x)
+ (and (pair? (cadr x))
+ (not (eq? 'lambda (car (cadr x))))))
+ (cadr term))
+ (find-if (lambda (x)
+ (find-if (lambda (y)
+ (inside-nonliftable-term? (car x) (cadr y)))
+ (cadr term)))
+ (cadr term)))
+ (for-each (lambda (x)
+ (or (memq (car x) *closure-building-vars*)
+ (set! *closure-building-vars*
+ (cons (car x) *closure-building-vars*))))
+ (cadr term)))
+ (for-each closure-building-vars-aux! (cdr term)))
+ (else
+ (for-each closure-building-vars-aux! term))))
+
+
+(define (inside-nonliftable-term? name term)
+ (cond
+ ((not (pair? term)) #f)
+ ((eq? 'quote (car term)) #f)
+ ((eq? 'lambda (car term))
+ (inside-term? name (cddr term)))
+ (else
+ (find-if (lambda (x) (inside-nonliftable-term? name x)) term))))
+
+(define (inside-term-set? x term)
+ (cond ((not (pair? term)) #f)
+ ((eq? 'quote (car term)) #f)
+ ((eq? 'set! (car term))
+ (or (and (pair? (cdr term))
+ (eq? x (cadr term))
+ (pair? (cddr term))
+ (null? (cdddr term)))
+ (inside-term-set? x (cdr term))))
+ (else
+ (or (inside-term-set? x (car term))
+ (inside-term-set? x (cdr term))))))
+
+(define (collect-local-vars term)
+ (set! *local-vars* '())
+ (collect-local-vars-aux term)
+ *local-vars*)
+(define (collect-local-vars-aux term)
+ (cond
+ ((not (pair? term)))
+ ((eq? (car term) 'quote))
+ ((or (eq? (car term) 'let*) (eq? (car term) *op-let*)
+ (eq? (car term) 'let) (eq? (car term) 'letrec))
+ (set! *local-vars*
+ (union (filter-map
+ (lambda (el)
+ (if (and (pair? (cadr el))
+ (eq? *liftable-lambda* (caadr el)))
+ #f
+ (car el)))
+ (cadr term))
+ *local-vars*))
+ (for-each (lambda (x) (collect-local-vars-aux (cadr x))) (cadr term))
+ (for-each (lambda (x) (collect-local-vars-aux x)) (cddr term)))
+ ((eq? (car term) 'do)
+ (set! *local-vars* (union (map car (cadr term)) *local-vars*))
+ (for-each (lambda (x)
+ (for-each (lambda (y) (collect-local-vars-aux y)) (cdr x)))
+ (cadr term))
+ (for-each (lambda (x) (collect-local-vars-aux x)) (caddr term))
+ (for-each (lambda (x) (collect-local-vars-aux x)) (cdddr term)))
+ ((eq? (car term) 'lambda))
+ (else
+ (for-each (lambda (x) (collect-local-vars-aux x)) term))))
+
+; beautify-closure takes a built closure-fun and corrects the
+; following: (let* (... ((vector-ref foo n) bar) ...) ...) is
+; replaced by (let* (...) (vector-set! foo n bar) (let* (...) ...)),
+; (set! (vector-ref foo n) bar) is replaced by (vector-set! foo n bar)
+(define (beautify-closure term)
+ (cond
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((and (eq? 'set! (car term))
+ (pair? (cdr term))
+ (pair? (cadr term))
+ (eq? 'vector-ref (caadr term))
+ (pair? (cdadr term))
+ (pair? (cddr term))
+ (memq (cadadr term) *closure-var-vectornames*))
+ (list 'vector-set!
+ (cadadr term) (caddr (cadr term)) (beautify-closure (caddr term))))
+ ((and (memq (car term) '(let* let letrec))
+ (not (null? (cdr term)))
+ (pair? (cadr term))
+ (find-if (lambda (x) (pair? (car x))) (cadr term)))
+ (beautify-closure-let (car term) (cadr term) (cddr term)))
+ ((list? term)
+ (map beautify-closure term))
+ (else
+ term)))
+(define (beautify-closure-let key bindings rest)
+ (if (null? bindings)
+ (cons 'begin (map beautify-closure rest))
+ (let* ((okpart '()))
+ (do ((part bindings (cdr part)))
+ ((or (null? part)
+ (and (pair? (car part))
+ (pair? (caar part))
+ (eq? 'vector-ref (caaar part))
+ (pair? (cdaar part))
+ (memq (cadaar part) *closure-var-vectornames*)))
+ (if (null? part)
+ (list* key (reverse okpart) (map beautify-closure rest))
+ (list key
+ (reverse okpart)
+ (list 'vector-set! (cadaar part)
+ (caddar (car part))
+ (beautify-closure (cadar part)))
+ (beautify-closure-let key (cdr part) rest))))
+ (set! okpart (cons (list (caar part)
+ (beautify-closure (cadar part)))
+ okpart))))))
+
+
+
+;====================================================================
+;
+; auxiliary functions - a library
+;
+;===================================================================
+
+(define (filter f lst)
+ (cond ((null? lst) '())
+ ((f (car lst)) (cons (car lst) (filter f (cdr lst))))
+ (else (filter f (cdr lst)))))
+
+(define (filter-map f lst)
+ (if (pair? lst)
+ (let ((res (f (car lst))))
+ (if res
+ (cons res (filter-map f (cdr lst)))
+ (filter-map f (cdr lst))))
+ '()))
+
+(define (filter-inside-term lst term)
+ (define *filter-inside-term-res* '())
+ (define (filter-inside-term-aux! lst term)
+ (cond ((not (pair? term))
+ (and (memq term lst)
+ (not (memq term *filter-inside-term-res*))
+ (set! *filter-inside-term-res*
+ (cons term *filter-inside-term-res*))))
+ ((eq? 'quote (car term)))
+ (else (filter-inside-term-aux! lst (car term))
+ (filter-inside-term-aux! lst (cdr term)))))
+ (filter-inside-term-aux! lst term)
+ (filter (lambda (x) (memq x *filter-inside-term-res*)) lst))
+
+(define (inside-term? x term)
+ (cond ((eq? x term) #t)
+ ((not (pair? term)) #f)
+ ((eq? 'quote (car term)) #f)
+ (else (or (inside-term? x (car term))
+ (inside-term? x (cdr term))))))
+
+(define (some-inside-term? obs term)
+ (cond ((memq term obs) #t)
+ ((not (pair? term)) #f)
+ ((eq? 'quote (car term)) #f)
+ (else (or (some-inside-term? obs (car term))
+ (some-inside-term? obs (cdr term))))))
+
+(define (subst-term-equal! what for term)
+ (cond ((not (pair? term)))
+ ((equal? (car term) for)
+ (set-car! term what)
+ (subst-term-equal! what for (cdr term)))
+ ((not (eq? 'quote (car term)))
+ (subst-term-equal! what for (car term))
+ (subst-term-equal! what for (cdr term)))))
+
+(define (subst-term what for term)
+ (cond ((eq? term for) what)
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ (else (cons (subst-term what for (car term))
+ (subst-term what for (cdr term))))))
+
+(define (in-fun-position? x term)
+ (cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)
+ ((not (list? term)) #f)
+ ((eq? x (car term)) #t)
+ (else (find-if (lambda (y) (in-fun-position? x y)) term))))
+
+(define (some-in-fun-position? lst term)
+ (cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)
+ ((not (list? term)) #f)
+ ((memq (car term) lst) #t)
+ (else (find-if (lambda (y) (some-in-fun-position? lst y)) term))))
+
+(define (replaceq what with lst)
+ (cond ((null? lst) '())
+ ((eq? what (car lst)) (cons with (replaceq what with (cdr lst))))
+ (else (cons (car lst) (replaceq what with (cdr lst))))))
+
+;;; Like LAST-PAIR, but works for non-lists.
+(define (my-last-pair lst)
+ (define (my-last-pair-aux lst)
+ (if (pair? (cdr lst))
+ (my-last-pair-aux (cdr lst))
+ lst))
+ (if (not (pair? lst))
+ lst
+ (my-last-pair-aux lst)))
+
+;;; Like REMOVE, but removes at most one element.
+(define (remove-one what from)
+ (cond ((null? from) from)
+ ((eq? what (car from)) (cdr from))
+ (else (cons (car from) (remove-one what (cdr from))))))
+
+;;; Like FIND-IF, but works for non-lists.
+(define (pair-find-if f lst)
+ (if (pair? lst)
+ (if (f (car lst)) (car lst) (pair-find-if f (cdr lst)))
+ (if (f lst) lst #f)))
+
+;;; slib/comlist.scm functions:
+
+(define (find-if f lst)
+ (if (null? lst)
+ #f
+ (if (f (car lst)) (car lst) (find-if f (cdr lst)))))
+
+(define (remove what lst)
+ (cond ((null? lst) '())
+ ((eq? what (car lst)) (remove what (cdr lst)))
+ (else (cons (car lst) (remove what (cdr lst))))))
+
+(define (every1 f lst)
+ (if (null? lst)
+ #t
+ (if (f (car lst)) (every1 f (cdr lst)) #f)))
+
+(define (member-if f lst)
+ (if (null? lst)
+ #f
+ (if (f (car lst)) lst (member-if f (cdr lst)))))
+
+(define (list* obj1 . obj2)
+ (define (list*1 obj)
+ (if (null? (cdr obj))
+ (car obj)
+ (cons (car obj) (list*1 (cdr obj)))))
+ (if (null? obj2)
+ obj1
+ (cons obj1 (list*1 obj2))))
+
+(define (butlast lst n)
+ (letrec
+ ((len (- (length lst) n))
+ (bl (lambda (lst n)
+ (let build-until-zero ((lst lst)
+ (n n)
+ (result '()))
+ (cond ((null? lst) (reverse result))
+ ((positive? n)
+ (build-until-zero
+ (cdr lst) (- n 1) (cons (car lst) result)))
+ (else (reverse result)))))))
+ (bl lst (if (negative? n)
+ (slib:error "negative argument to butlast" n)
+ len))))
+
+(define (union lst1 lst2)
+ (define ans (if (null? lst1) lst2 lst1))
+ (define (adjoin obj lst) (if (memv obj lst) lst (cons obj lst)))
+ (cond ((null? lst2) lst1)
+ (else (for-each (lambda (elt) (set! ans (adjoin elt ans)))
+ lst2)
+ ans)))
+
+(define (set-difference lst1 lst2)
+ (if (null? lst2)
+ lst1
+ (let build-difference ((lst1 lst1)
+ (result '()))
+ (cond ((null? lst1) (reverse result))
+ ((memv (car lst1) lst2) (build-difference (cdr lst1) result))
+ (else (build-difference (cdr lst1) (cons (car lst1) result)))))))
+
+(define (intersection lst1 lst2)
+ (if (null? lst2)
+ lst2
+ (let build-intersection ((lst1 lst1)
+ (result '()))
+ (cond ((null? lst1) (reverse result))
+ ((memv (car lst1) lst2)
+ (build-intersection (cdr lst1) (cons (car lst1) result)))
+ (else
+ (build-intersection (cdr lst1) result))))))
+
+;=========================== END ===============================
diff --git a/hobbit.texi b/hobbit.texi new file mode 100644 index 0000000..3b448fb --- /dev/null +++ b/hobbit.texi @@ -0,0 +1,2273 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename hobbit.info +@settitle hobbit +@include version.txi +@setchapternewpage on +@c Choices for setchapternewpage are {on,off,odd}. +@paragraphindent 0 +@defcodeindex ft +@syncodeindex ft cp +@c %**end of header + +@dircategory The Algorithmic Language Scheme +@direntry +* hobbit: (hobbit). SCM Compiler. +@end direntry + +@iftex +@finalout +@c DL: lose the egregious vertical whitespace, esp. around examples +@c but paras in @defun-like things don't have parindent +@parskip 4pt plus 1pt +@end iftex + +@titlepage +@title Hobbit +@subtitle SCM Compiler +@subtitle Version @value{SCMVERSION} +@author by Tanel Tammet +@author Department of Computing Science +@author Chalmers University of Technology +@author University of Go"teborg +@author S-41296 Go"teborg Sweden + +@page +This Hobbit documentation was converted to texinfo format by Aubrey +Jaffer; and released as part of the SCM @value{SCMVERSION} distribution +@value{SCMDATE}. + +@vskip 0pt plus 1filll +Copyright @copyright{} 1990-1999, 2002 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the author. +@end titlepage + +@node Top, Introduction, (dir), (dir) + +@ifinfo +Hobbit is an optimizing R4RS-Scheme to C compiler written by Tanel +Tammet. + +@menu +* Introduction:: +* Compiling with Hobbit:: +* The Language Compiled:: +* Performance of Compiled Code:: +* Principles of Compilation:: +* About Hobbit:: +@end menu + +Copyright (C) 1990-1999, 2002 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@ignore +Permission is granted to process this file through TeX and print the +results, provided the printed document carries copying permission +notice identical to this one except for the removal of this paragraph +(this paragraph not being relevant to the printed manual). + +@end ignore +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the author. +@end ifinfo + + +@node Introduction, Compiling with Hobbit, Top, Top +@chapter Introduction + +Hobbit is a small optimizing scheme-to-C compiler written in Report 4 +scheme and intended for use together with the SCM scheme interpreter of +A. Jaffer. Hobbit compiles full Report 4 scheme, except that: + +@itemize @bullet +@item +It does not fully conform to the requirement of being properly +tail-recursive: non-mutual tailrecursion is detected, but mutual +tailrecursion is not. +@item +Macros from the Report 4 appendix are not supported (yet): +only the common-lisp-like defmacro is supported. +@end itemize + +Hobbit treats SCM files as a C library and provides integration of +compiled procedures and variables with the SCM interpreter as new +primitives. + +Hobbit compiles scheme files to C files and does not provide anything +else by itself (eg. calling the C compiler, dynamic loading). Such +niceties are described in the next chapter @ref{Compiling And Linking}. + +Hobbit (derived from hobbit5x) is now part of the SCM Scheme +implementation. The most recent information about SCM can be found on +SCM's @dfn{WWW} home page: + +@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html} + +Hobbit4d has also been ported to the Guile Scheme implementation: + +@center @url{http://www.gnu.org/software/guile/anon-cvs.html} + + +@node Compiling with Hobbit, The Language Compiled, Introduction, Top +@chapter Compiling with Hobbit + +@menu +* Compiling And Linking:: +* Error Detection:: +* Hobbit Options:: +* CC Optimizations:: +@end menu + +@node Compiling And Linking, Error Detection, Compiling with Hobbit, Compiling with Hobbit +@section Compiling And Linking + +@code{(require 'compile)} + +@defun hobbit name1.scm name2.scm @dots{} +Invokes the HOBBIT compiler to translate Scheme files +@file{@var{name1}.scm}, @file{@var{name2}.scm}, @dots{} to C files +@file{@var{name1}.c} and @file{@var{name1}.h}. +@end defun + +@defun compile-file name1.scm name2.scm @dots{} +Compiles the HOBBIT translation of @var{name1}.scm, @var{name2}.scm, +@dots{} to a dynamically linkable object file +@var{name1}<object-suffix>, where <object-suffix> is the object file +suffix for your computer (for instance, @file{.so}). @var{name1}.scm +must be in the current directory; @var{name2}.scm, @dots{} may be in +other directories. +@end defun + +@example +cd ~/scm/ +scm -rcompile -e'(compile-file "example.scm")' + +Starting to read example.scm + +Generic (slow) arithmetic assumed: 1.0e-3 found. + +** Pass 1 completed ** +** Pass 2 completed ** +** Pass 3 completed ** +** Pass 4 completed ** +** Pass 5 completed ** +** Pass 6 completed ** + +C source file example.c is built. +C header file example.h is built. + +These top level higher order procedures are not clonable (slow): +(nonkeyword_make-promise map-streams generate-vector runge-kutta-4) +These top level procedures create non-liftable closures (slow): +(nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system) + +; Scheme (linux) script created by SLIB/batch Sun Apr 7 22:49:49 2002 +; ================ Write file with C defines +(delete-file "scmflags.h") +(call-with-output-file + "scmflags.h" + (lambda (fp) + (for-each + (lambda (string) (write-line string fp)) + '("#define IMPLINIT \"Init@value{SCMVERSION}.scm\"" + "#define BIGNUMS" + "#define FLOATS" + "#define ARRAYS" + "#define DLL")))) +; ================ Compile C source files +(system "gcc -O2 -fpic -c -I/usr/local/lib/scm/ example.c") +(system "gcc -shared -o example.so example.o -lm -lc") +(delete-file "example.o") +; ================ Link C object files +(delete-file "slibcat") + +Compilation finished at Sun Apr 7 22:49:50 +@end example + +@defun compile->executable exename name1.scm name2.scm @dots{} +Compiles and links the HOBBIT translation of @var{name1}.scm, +@var{name2}.scm, @dots{} to a SCM executable named @var{exename}. +@var{name1}.scm must be in the current directory; @var{name2}.scm, +@dots{} may be in other directories. +@end defun + +@example +cd ~/scm/ +scm -rcompile -e'(compile->executable "exscm" "example.scm")' + +Starting to read example.scm + +Generic (slow) arithmetic assumed: 1.0e-3 found. + +** Pass 1 completed ** +** Pass 2 completed ** +** Pass 3 completed ** +** Pass 4 completed ** +** Pass 5 completed ** +** Pass 6 completed ** + +C source file example.c is built. +C header file example.h is built. + +These top level higher order procedures are not clonable (slow): +(nonkeyword_make-promise map-streams generate-vector runge-kutta-4) +These top level procedures create non-liftable closures (slow): +(nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system) + +; Scheme (linux) script created by SLIB/batch Sun Apr 7 22:46:31 2002 +; ================ Write file with C defines +(delete-file "scmflags.h") +(call-with-output-file + "scmflags.h" + (lambda (fp) + (for-each + (lambda (string) (write-line string fp)) + '("#define IMPLINIT \"Init@value{SCMVERSION}.scm\"" + "#define COMPILED_INITS init_example();" + "#define CCLO" + "#define FLOATS")))) +; ================ Compile C source files +(system "gcc -O2 -c continue.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c example.c scm.c") +; ================ Link C object files +(system "gcc -rdynamic -o exscm continue.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o example.o scm.o -L/usr/local/lib/scm/ -lm -lc") + +Compilation finished at Sun Apr 7 22:46:44 +@end example + +@emph{Note Bene:} @samp{#define CCLO} must be present in @file{scmfig.h}. + +In order to see calls to the C compiler and linker, do + +@example +(verbose 3) +@end example + +before calling these functions. + + +@node Error Detection, Hobbit Options, Compiling And Linking, Compiling with Hobbit +@section Error Detection + +Error detection during compilation is minimal. In case your scheme code +is syntactically incorrect, hobbit may crash with no sensible error +messages or it may produce incorrect C code. + +Hobbit does not insert any type-checking code into the C output it +produces. Eg, if a hobbit-compiled program applies @samp{car} to a +number, the program will probably crash with no sensible error messages. + +Thus it is strongly suggested to compile only throughly debugged +scheme code. + +Alternatively, it is possible to compile all the primitives into +calls to the SCM procedures doing type-checking. Hobbit will do +this if you tell it to assume that all the primitives may be +redefined. Put + +@example +(define compile-all-proc-redefined #t) +@end example + +anywhere in top level of your scheme code to achieve this. + +@emph{Note Bene:} The compiled code using + +@example +(define compile-all-proc-redefined #t) +@end example + +will typically be much slower than one produced without using + +@example +(define compile-all-proc-redefined #t). +@end example + +All errors caught by hobbit will generate an error message + +@example +@group +COMPILATION ERROR: +@r{<description of the error>} +@end group +@end example + +and hobbit will immediately halt compilation. + + +@node Hobbit Options, CC Optimizations, Error Detection, Compiling with Hobbit +@section Hobbit Options + +@enumerate +@item +Selecting the type of arithmetics. + +By default hobbit assumes that only immediate (ie small, up to 30 bits) +integers are used. It will automatically assume general arithmetics in +case it finds any non-immediate numbers like 1.2 or 10000000000000 or +real-only procedures like @t{$sin} anywhere in the source. + +Another way to make Hobbit assume that generic arithmetic supported +by SCM (ie exact and/or inexact reals, bignums) is also used, is to +put the following line somewhere in your scheme source file: + +@example +(define compile-allnumbers @var{t}) +@end example + +where @var{t} is arbitrary. + +In that case all the arithmetic primitives in all the given source +files will be assumed to be generic. This will make operations +with immediate integers much slower. You can use the special +immediate-integer-only forms of arithmetic procedures to recover: + +@example +@group +%negative? %number? %> %>= %= %<= %< +%positive? %zero? %eqv? %+ %- %* %/ +@end group +@end example + +See @ref{The Language Compiled}. + +@item +Redefinition of procedures. + +By default hobbit assumes that neither primitives nor compiled +procedures are redefined, neither before the compiled program is +initialized, during its work or later via the interpreter. + +Hobbit checks the compiled source and whenever some variable bar is +defined as a procedure, but is later redefined, or @t{set!} is applied +to bar, then hobbit assumes thas this particular variable bar is +redefinable. bar may be a primitive (eg @samp{car}) or a name of a +compiled procedure. + + +@emph{Note Bene:} +According to the Report 4 it is @b{NOT} allowed to use scheme +keywords as variables (you may redefine these as macros defined by +defmacro, though): + +@example +@group +=> and begin case cond define delay do else if lambda +let let letrec or quasiquote quote set! unquote unquote-splicing +@end group +@end example + +If you want to be able to redefine some procedures, eg. @samp{+} and +@samp{baz}, then put both + +@example +@group +(set! + +) +(set! baz baz) +@end group +@end example + +somewhere into your file. + +As a consequence hobbit will generate code for @samp{+} and @samp{baz} +using the run-time values of these variables. This is generally much +slower than using non-redefined @samp{+} and @samp{baz} (especially for +@samp{+}). + +If you want to be able to redefine all the procedures, both primitives +(eg @samp{car}) and the compiled procedures, then put the following into +the compiled file: + +@example +(define compile-all-proc-redefined @var{t}) +@end example + +where @var{t} is arbitrary. + +If you want to be able to redefine all the compiled procedures, but not +the scheme primitives, then put the following into the compiled file: + +@example +(define compile-new-proc-redefined @var{t}) +@end example + +where @var{t} is arbitrary. + +Again, remember that redefinable procedures will be typically much +slower than non-redefinable procedures. + + +@item +Inlined variables and procedures. + +You may inline top-level-defined variables and procedures. +Notice that inlining is DIFFERENT for variables and procedures! + +NEVER inline variables or procedures which are @t{set!} or redefined +anywhere in you program: this will produce wrong code. + +@itemize @bullet +@item +You may declare certain top-level defined variables to be inlined. +For example, if the following variable foo is declared to be inlined +@end itemize + +@example +(define foo 100) +@end example + +then @samp{foo} will be everywhere replaced by @samp{100}. + +To declare some variables foo and bar to be inlined, put a following +definition anywhere into your file: + +@example +(define compile-inline-vars '(foo bar)) +@end example + +Usually it makes sense to inline only these variables whose value +is either a small integer, character or a boolean. + + +@emph{Note Bene:} +Do not use this kind of inlining for inlining procedures! +Use the following for procedures: + +@itemize @bullet +@item +You may declare certain procedures to be inlined. For example, if +the following foo is declared to be inlined +@end itemize + +@example +(define (foo x) (+ x 2)) +@end example + +then any call + +@example +(foo @var{something}) +@end example + +will be replaced by + +@example +(+ @var{something} 2) +@end example + +Inlining is @b{NOT} safe for variable clashes -- in other words, it is +not "hygienic". + +Inlining is @b{NOT} safe for recursive procedures -- if the set of +inlined procedures contains either immediate or mutual (foo calling +bar, bar calling foo) recursion, the compiler will not terminate. +To turn off full inlining (harmful for recursive funs), change +the definition of the *full-inlining-flag* in the section +"compiler options" to the value #f instead of #t. + +To declare some procedures foo and bar to be inlined, put a following +definition anywhere into your file: + +@example +(define compile-inline '(foo bar)) +@end example + +@item +Speeding up vectors: + +Put + +@example +(define compile-stable-vectors '(baz foo)) +@end example + +into your file to declare that baz and foo are vector names defined once +on the top level, and @t{set!} is never applied to them (@t{vector-set!} +is, of course, allowed). This speeds up vector reference to those +vectors by precomputing their location. + +@item +Speeding up and hiding certain global variables: + +Put + +@example +(define compile-uninterned-variables '(bazvar foovar)) +@end example + +into your file to declare that bazvar and foovar are defined on the top +level and they do always have an immediate value, ie a boolean, +immediate (30-bit) integer or a character. Then bazvar and foovar will +@b{NOT} be accessible from the interpreter. They'll be compiled directly +into static C vars and used without an extra C *-operation prefixed to +other global scheme variables. + +@item +Intermediate files + +To see the output of compiler passes, change the following +definition in @file{hobbit.scm}. + +@example +(define *build-intermediate-files* #f) +@end example + +to: + +@example +(define *build-intermediate-files* #t) +@end example + +@item +Name clashes + +It may happen that several originally different scheme variable +names are represented by one and the same C variable. This will +happen, for example, if you have separate variables a-1 and a_1. + +If such (or any other) name clashes occur you may +need to change some control variables in the first sections +of @file{hobbit.scm} (up to the section "global variable defs") or just +rename some variables in your scheme program. + +@item +Other options + +See various control variables in the first sections of @file{hobbit.scm} +(up to section "global variable defs"). +@end enumerate + + + +@node CC Optimizations, , Hobbit Options, Compiling with Hobbit +@section CC Optimizations + +When using the C compiler to compile the C code output by hobbit, always +use strong optimizations (eg. @samp{cc -xO3} for cc on Sun, @samp{gcc +-O2} or @samp{gcc -O3} for gcc). Hobbit does not attempt to do +optimizations of the kind we anticipate from the C compiler, therefore +it often makes a serious difference whether the C compiler is run with a +strong optimization flag or not. + +For the final and fast version of your program you may want to first +recompile the whole scm (scmlit for the version scm4e2) using the +@samp{-DRECKLESS} flag suppressing error checking: the hobbit-compiled +code uses some SCM primitives in the compiled files with the suffix .o, +and a number of these primitives become faster when error checking is +disabled by @samp{-DRECKLESS}. Notice that hobbit never inserts error +checking into the code it produces. + + + +@node The Language Compiled, Performance of Compiled Code, Compiling with Hobbit, Top +@chapter The Language Compiled + +Calls to @code{load} or @code{require} occurring at the top level of a +file being compiled are ignored. Calls to @code{load} or @code{require} +within a procedure are compiled to call (interpreted) @code{load} or +@code{require} as appropriate. + +Several SCM and SLIB extensions to the Scheme report are recognized by +hobbit as Scheme primitives. + +@menu +* Macros:: +* SCM Primitive Procedures:: +* SLIB Logical Procedures:: +* Fast Integer Calculations:: +* Force and Delay:: +* Suggestions for writing fast code:: +@end menu + + +@node Macros, SCM Primitive Procedures, The Language Compiled, The Language Compiled +@section Macros +@c @heading The SCM macro-facility and the SCM extra syntactic form + +The Common-lisp style defmacro implemented in SCM is recognized and +procedures defined by defmacro are expanded during compilation. + +@emph{Note Bene:} any macro used in a compiled file must be also defined +in one of the compiled files. + +@samp{#.@var{<expression>}} is read as the object resulting from the +evaluation of @var{<expression>}. The calculation is performed during +compile time. Thus @var{<expression>} must not contain variables +defined or @t{set!} in the compiled file. + + +@node SCM Primitive Procedures, SLIB Logical Procedures, Macros, The Language Compiled +@section SCM Primitive Procedures +@c @heading The SCM extra primitives + +Real-only versions of transcedental procedures (warning: these +procedures are not compiled directly into the corresponding C library +procedures, but a combination of internal SCM procedures, guaranteeing exact +correspondence with the SCM interpreter while hindering the speed): + +@example +@group +$sqrt $abs $exp $log $sin $cos $tan $asin $acos +$atan $sinh $cosh $tanh $asinh $acosh $atanh $expt +@end group +@end example + +@emph{Note Bene:} These procedures are compiled to faster code than the +corresponding generic versions @t{sqrt}, @t{abs}, @dots{} @t{expt}. + +A selection of other extra primitives in SCM is also recognized as +primitives. eg. @t{get-internal-run-time}, @t{quit}, @t{abort}, +@t{restart}, @t{chdir}, @t{delete-file}, @t{rename-file}. + + +@node SLIB Logical Procedures, Fast Integer Calculations, SCM Primitive Procedures, The Language Compiled +@section SLIB Logical Procedures +@c @heading Bitwise logical procedures from the scheme library + +The following bitwise procedures in the scheme library file +@file{logical.scm} are compiled directly to fast C operations on +immediate integers (small 30-bit integers) (Scheme library funs in the +upper row, C ops below): + +@example +@group + logand logior logxor lognot logsleft logsright + & | ^ ~ << >> +@end group +@end example + +The following alternative names @t{logical:logand}, @t{logical:logior}, +@t{logical:logxor}, @t{logical:lognot}, @t{ash}, @t{logical:ash} are compiled for the +generic case, not immediate-integers-only and are thus much slower. + +Notice that the procedures @t{logsleft}, @t{logsright} are @b{NOT} in +the the library file @file{logical.scm:} the universal procedure @t{ash} +is instead. Procedures @t{ash}, @t{logcount}, @t{integer-length}, +@t{integer-expt}, @t{bit-extract}, @t{ipow-by-squaring}, +@t{logical:ash}, @t{logical:logcount}, @t{logical:integer-length}, +@t{logical:integer-expt}, @t{logical:bit-extract}, +@t{logical:ipow-by-squaring}, in @file{logical.scm} are not primtives +and they are all compiled into calls to interpreted code. + +@t{logsleft} and @t{logsright} are defined for non-compiled use in the +file @file{scmhob.scm} included in the SCM distribution. + + +@node Fast Integer Calculations, Force and Delay, SLIB Logical Procedures, The Language Compiled +@section Fast Integer Calculations +@c @heading Immediate (fast) arithmetics + +The following primitives are for immediate (30-bit) integer-only +arithmetics. The are compiled directly into the corresponding C +operations plus some bitshifts if necessary. They are good for speed in +case the compiled program uses BOTH generic arithmetics (reals, bignums) +and immediate (30-bit) integer arithmetics. These procedures are much +faster than corresponding generic procedures taking also reals and +bignums. There is no point in using these unless the program as a whole +is compiled using generic arithmetics, since otherwise all the +arithmetics procedures are compiled directly into corresponding C +operations anyway. + +@emph{Note Bene:} These primitives are @b{NOT} defined in SCM or its +libraries. For non-compiled use they are defined in the file +@file{scmhob.scm} included in the SCM distribution. + +@example +@group +%negative? %number? %> %>= %= %<= %< +%positive? %zero? %eqv? %+ %- %* %/ +@end group +@end example + +@node Force and Delay, Suggestions for writing fast code, Fast Integer Calculations, The Language Compiled +@section Force and Delay + +The nonessential procedure @code{force} and syntax @code{delay} are +implemented exactly as suggested in the report 4. This implementation +deviates internally from the implementation of @code{force} and +@code{delay} in the SCM interpeter, thus it is incorrect to pass a +promise created by @code{delay} in the compiled code to the @code{force} +used by interpreter, and vice-versa for the promises created by the +interpreter. + + + +@node Suggestions for writing fast code, , Force and Delay, The Language Compiled +@section Suggestions for writing fast code + +The following suggestions may help you to write well-optimizable and +fast code for the hobbit-scm combination. Roughly speaking, the main +points are: + +@itemize +@item +minimizing consing and creation of new vectors and strings +in speed-critical parts, + +@item +minimizing the use of generic (non-integer) arithmetics +in speed-critical parts, + +@item +minimizing the usage of procedures as first-class +objects (very roughly speaking, explicit lambda-terms +and call/cc) in speed-critical parts, + +@item +using special options and fast-compiled primitives of the compiler. +@end itemize + +Here come the details. + +@enumerate +@item +Immediate arithmetics (ie using small, up to 30 bits integers) is much +faster than generic (reals and bignums) arithmetics. If you have to use +generic arithmetic in your program, then try to use special immediate +arithmetics operations @code{%=}, @code{%<=}, @code{%+}, @code{%*}, +@dots{} for speed-critical parts of the program whenever possible. + +Also, if you use bitwise logical operations, try to use the +immediate-integer-only versions + +@example +logand logior logxor lognot logsleft logsright +@end example + +and not @code{logical:logand} or @code{ash}, for example. + +@item +Due to its inner stack-based architecture, the generic (not escape-only) +continuations are very slow in SCM. Thus they are also slow in +compiled code. Try to avoid continuations (calls to the procedure +call-with-current-continuation and calls to the continuations it +produces) in speed-critical parts. + +@item +In speed-critical parts of your program try to avoid using procedures +which are redefined or defined by @t{set!}: + +@example +@group +(set! bar +) +(set! f (lambda (x) (if (zero? x) 1 (* x (f (- x 1)))))) +@end group +@end example + +anywhere in the compiled program. Avoid using compiler flags +(@pxref{Hobbit Options}): + +@example +@group +(define compile-all-proc-redefined @var{t}) +(define compile-new-proc-redefined @var{t}) +@end group +@end example + +@item +Do not use complicated higher-order procedures in speed-critical +parts. By @dfn{complicated} we mean @dfn{not clonable}, where clonability +is defined in the following way (@emph{Note Bene:} the primitives +@samp{map} and @samp{for-each} are considered clonable and do not +inflict a speed penalty). + +A higher-order procedure (HOP for short) is defined as a procedure +with some of its formal arguments occuring in the procedure body in +a function position, that is, as a first element of a list. Such +an argument is called a @dfn{higher-order argument}. + +A HOP @samp{bar} is clonable iff it satisfies the following four +conditions: + +@enumerate +@item +@samp{bar} is defined as + +@example +(define bar (lambda @dots{})) +@end example + +or + +@example +(define (bar @dots{}) @dots{}) +@end example + +on top level and bar is not redefined anywhere. + +@item +the name @samp{bar} occurs inside the body of bar only in a function position +and not inside an internal lambda-term. + +@item +Let f be a higher-order argument of bar. +Any occurrence of f in bar has one of the following two forms: + +@itemize @bullet +@item +f occurs in a function position, +@item +f is passed as an argument to bar and in the call it occurs in the same +position as in the argument list. +@end itemize + +@item +Let f be a higher-order argument of bar. f does not occur inside a +lambda-term occurring in bar. + +Examples: + +If @samp{member-if} is defined on top level and is not redefined +anywhere, then @samp{member-if} is a clonable HOP: + +@example +@group +(define (member-if fn lst) + (if (fn (car lst)) + lst + (member-if fn (cdr lst)) )) +@end group +@end example + +member-if-not is not a clonable HOP (fn occurs in a lambdaterm): + +@example +@group +(define (member-if-not fn lst) + (member (lambda (x) (not (fn x))) lst) ) +@end group +@end example + +show-f is not a clonable HOP (fn occurs in a non-function position +in (display fn)): + +@example +@group +(define (show-f fn x) + (set! x (fn x)) + (display fn) + x) +@end group +@end example + +@item +In speed-critical parts avoid using procedures which return procedures. + +Eg, a procedure + +@example +@group +(define plus + (lambda (x) + (lambda (y) (+ y x)) )) +@end group +@end example + +returns a procedure. + +@item +A generalisation of the previous case 5: + +In speed-critical parts avoid using lambda-terms except in non-@t{set!} +function definitions like + +@example +@group +(define foo (lambda @dots{})), +(let ((x 1) (f (lambda @dots{}))) @dots{}) +(let* ((x 1) (f (lambda @dots{}))) @dots{}) +(let name ((x 1) (f (lambda @dots{}))) @dots{}) +(letrec ((f (lambda @dots{})) (g (lambda @dots{}))) @dots{}) +@end group +@end example + +or as arguments to clonable HOP-s or primitives @t{map} and +@t{for-each}, like + +@example +@group +(let ((x 0)) (map (lambda (y) (set! x (+ 1 x)) (cons x y)) @var{list})) +(member-if (lambda (x) (< x 0)) @var{list}) +@end group +@end example + +where member-if is a clonable HOP. + +Also, avoid using variables with a procedural value anywhere +except in a function position (first element of a list) or +as an argument to a clonable HOP, @t{map} or @t{for-each}. + +Lambda-terms conforming to the current point are said to be liftable. + +Examples: + +@example +(define (bar x) (let ((f car)) (f (f x)))) +@end example + +has @samp{car} in a non-function and non-HOP-argument position in +@code{(f car)}, thus it is slower than + +@example +(define (bar x) (let ((f 1)) (car (car x)))) +@end example + +Similarly, + +@example +@group +(define (bar y z w) + (let ((f (lambda (x) (+ x y)))) + (set! w f) + (cons (f (car z)) + (map f z) ))) +@end group +@end example + +has @samp{f} occurring in a non-function position in @code{(set! w f)}, +thus the lambda-term @code{(lambda (x) (+ x y))} is not liftable and the +upper @samp{bar} is thus slower than the following equivalent @samp{bar} +with a liftable inner lambda-term: + +@example +@group +(define (bar y z w) + (let ((f (lambda (x) (+ x y)))) + (set! w 0) + (cons (f (car z)) + (map f z) ))) +@end group +@end example + +Using a procedure bar defined as + +@example +(define bar (let ((x 1)) (lambda (y) (set! x y) (+ x y)))) +@end example + +is slower than using a procedure bar defined as + +@example +@group +(define *bar-x* 1) +(define bar (lambda (y) (set! *bar-x* y) (+ *bar-x* y))) +@end group +@end example + +since the former definition contains a non-liftable lambda-term. + +@item +Try to minimize the amount of consing in the speed-critical program +fragments, that is, a number of applications of cons, list, @t{map}, +quasiquote (`) and vector->list during the time program is running. +@samp{cons} (called also by @samp{list}, @samp{map} and +@samp{quasiquote}) is translated into a C call to an internal cons +procedure of the SCM interpreter. Excessive consing also means that the +garbage collection happens more often. Do @code{(verbose 3)} to see the +amount of time used by garbage collection while your program is running. + +Try to minimize the amount of creating new vectors, strings and symbols +in the speed-critical program frgaments, that is, a number of +applications of @t{make-vector}, @t{vector}, @t{list->vector}, +@t{make-string}, @t{string-append}, *@t{->string}, @t{string->symbol}. +Creating such objects takes typically much more time than consing. + +@item +The Scheme iteration construction @samp{do} is compiled directly into +the C iteration construction @samp{for}. We can expect that the C compiler +has some knowledge about @samp{for} in the optimization stage, thus it is +probably faster to use @samp{do} for iteration than non-mutual tailrecursion +(which is recognized by hobbit as such and is compiled into a jump to a +beginning of a procedure) and certainly much faster than +non-tail-recursion or mutual tailrecursion (the latter is not recognized +by hobbit as such). + +@item +Declare small nonrecursive programs which do not contain +let-s or lambdaterms as being inlinable. + +Declare globally defined variables which are never @t{set!} or redefined +and whose value is a small integer, character or a boolean, +as being inlinable. @xref{Hobbit Options}. + +@item +If possible, declare vectors as being stable. +@xref{Hobbit Options, Speeding up vectors}. +This gives a minor improvement in speed. + +@item +If possible, declare critical global vars as being uninterned. +@xref{Hobbit Options, Speeding up and hiding certain global variables}. +This gives a minor improvement in speed. Declare the global variables +which are never @t{set!} and have an (unchanged) numeric or boolean +value as being inlined. @xref{Hobbit Options}. +@end enumerate + +In addition, take the following into account: + +@itemize @bullet +@item +When using the C compiler to compile the C code output by hobbit, always +use strong optimizations (eg. @samp{cc -xO3} for cc on Sun, @samp{gcc +-O2} or @samp{gcc -O3} for gcc). Hobbit does not attempt to do +optimizations of the kind we anticipate from the C compiler, therefore +it often makes a big difference if the C compiler is run with a strong +optimization flag or not. + +@item +hobbit does not give proper tailrecursion behaviour for mutual +tailrecursion (foo calling bar, bar calling foo tailrecursively). + +Hobbit guarantees proper tailrecursive behaviour for non-mutual +tailrecursion (foo calling foo tailrecursively), provided that +foo is not redefined anywhere and that foo is not a local function which +occurs also in a non-function and non-clonable-HOP-argument position +(i.e. cases 3 and 6 above). +@end itemize +@end enumerate + + + +@node Performance of Compiled Code, Principles of Compilation, The Language Compiled, Top +@chapter Performance of Compiled Code + + +@menu +* Gain in Speed:: +* Benchmarks:: +* Benchmark Sources:: +@end menu + +@node Gain in Speed, Benchmarks, Performance of Compiled Code, Performance of Compiled Code +@section Gain in Speed + +The author has so far compiled and tested a number of large programs +(theorem provers for various logics and hobbit itself). + +The speedup for the provers was between 25 and 40 times for various +provable formulas. Comparison was made between the provers being +interpreted and compiled with @samp{gcc -O2 -DRECKLESS} on Sparcstation +ELC in both cases. + +The provers were written with care to make the compiled version run fast. +They do not perform excessive consing and they perform very little +arithmetic. + +According to experiments made by A. Jaffer, the compiled form of the +example program @file{pi.scm} was approximately 11 times faster than the +interpreted form. + +As a comparison, his hand-coded C program for the same algorithm of +computing pi was about 12 times faster than the interpreted form. +@file{pi.scm} spends most of of its time in immediate arithmetics, +@t{vector-ref} and @t{vector-set!}. + +P. Kelloma"ki has reported a 20-fold speedup for his generic scheme +debugger. T. Moore has reported a 16-fold speedup for a large gate-level +IC optimizer. + +Self-compilation speeds Hobbit up only ca 10 times. + +However, there are examples where the code compiled by hobbit +runs actually slower than the same code running under interpreter: +this may happen in case the speed of the code relies on non-liftable +closures and proper mutual tailrecursion. See for example the +closure-intensive benchmark CPSTAK in the following table. + +@page +@node Benchmarks, Benchmark Sources, Gain in Speed, Performance of Compiled Code +@section Benchmarks + +We will present a table with the performance of three scheme systems on +a number of benchmarks: interpreted SCM, byte-compiled VSCM and +hobbit-compiled code. The upper 13 benchmarks of the table are the +famous Gabriel benchmarks (originally written for lisp) modified for +scheme by Will Clinger. The lower five benchmarks of the table are +proposed by other people. @dfn{Selfcompile} is the self-compile time +of Hobbit. + + +Hobbit performs well on most of the benchmarks except +CPSTAK and CTAK: CPSTAK is a closure-intensive tailrecursive +benchmark and CTAK is a continuations-intensive benchmark. +Hobbit performs extremely well on these benchmarks which essentially +satisfy the criterias for well-optimizable code outlined in the +section 6 above. + +FFT is real-arithmetic-intensive. + +All times are in seconds. + +SCM 4c0(U) and 1.1.5*(U) (the latter is the newest version of VSCM) +are compiled and run by Matthias Blume on a DecStation 5000 (Ultrix). +VSCM is a bytecode-compiler using continuation-passing style, and is well +optimized for continuations and closures. + +SCM 4e2(S) and Hobbit4b(S) compiled (with @samp{cc -xO3}) and run by +Tanel Tammet on a Sun SS10 (lips.cs.chalmers.se). Hobbit is a +Scheme-to-C compiler for SCM, the code it produces does not do any +checking. SCM and hobbit are not optimized for continuations. Hobbit +is not optimized for closures and proper mutual tailrecursion. + +SCM and Hobbit benchmarks were run giving ca 8 MB of free heap space +before each test. + +@example +@group +Benchmark |SCM 4c0(U) 1.1.5*(U)| SCM 4e2(S) Hobbit4b(S) +----------------|------------------------------------------------ +Deriv | 3.40 3.86 | 2.9 0.18 +Div-iter | 3.45 2.12 | 2.6 0.083 +Div-rec | 3.45 2.55 | 3.5 0.42 +TAK | 1.81 1.71 | 1.4 0.018 +TAKL |14.50 11.32 | 13.8(1.8 in gc) 0.13 +TAKR | 2.20 1.64 | 1.7 1.5 0.018 +Destruct | ? ? | 7.4(1.8 in gc) 0.18 +Boyer | ? ? | 27.(3.8 in gc) 1.9 +CPSTAK | 2.72 2.64 | 2.0 1.92 3.46(2.83 in gc) +CTAK |31.0 4.11 | memory memory +CTAK(7 6 1) | ? ? | 0.83 0.74 +FFT |12.45 15.7 | 11.4 10.8 1.0 +Puzzle | 0.28 0.41 | 0.46(0.22 gc) 0.03 +---------------------------------------------------------------- +(recfib 25) | ? ? | 4.1 0.079 +(recfib 30) | ? ? | 55. (10.in gc) 0.87 +(pi 300 3) | ? ? | 7.4 0.46 +(hanoi 15) | ? ? | 0.68 0.007 +(hanoi 20) | ? ? | 31. (9. in gc) 0.2 +---------------------------------------------------------------- +@end group +@end example + +@page +@node Benchmark Sources, , Benchmarks, Performance of Compiled Code +@section Benchmark Sources +@subheading A selection of (smaller) benchmark sources + +@menu +* Destruct:: +* Recfib:: +* div-iter and div-rec:: +* Hanoi:: +* Tak:: +* Ctak:: +* Takl:: +* Cpstak:: +* Pi:: +@end menu + +@node Destruct, Recfib, Benchmark Sources, Benchmark Sources +@subsection Destruct + +@example +@group +;;;; Destructive operation benchmark +(define (destructive n m) + (let ((l (do ((i 10 (- i 1)) + (a '() (cons '() a))) + ((= i 0) a)))) + (do ((i n (- i 1))) + ((= i 0)) + (if (null? (car l)) + (do ((l l (cdr l))) + ((null? l)) + (or (car l) (set-car! l (cons '() '()))) + (append! (car l) (do ((j m (- j 1)) + (a '() (cons '() a))) + ((= j 0) a)))) + (do ((l1 l (cdr l1)) + (l2 (cdr l) (cdr l2))) + ((null? l2)) + (set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1)) + (a (car l2) (cdr a))) + ((zero? j) a) + (set-car! a i)) + (let ((n (quotient (length (car l1)) 2))) + (cond ((= n 0) (set-car! l1 '()) (car l1)) + (else (do ((j n (- j 1)) + (a (car l1) (cdr a))) + ((= j 1) + (let ((x (cdr a))) + (set-cdr! a '()) x)) + (set-car! a i))))))))))) +;; call: (destructive 600 50) +@end group +@end example + +@need 1500 +@node Recfib, div-iter and div-rec, Destruct, Benchmark Sources +@subsection Recfib + +@example +@group +(define (recfib x) + (if (< x 2) + x + (+ (recfib (- x 1)) + (recfib (- x 2))))) +@end group +@end example + +@need 4000 +@node div-iter and div-rec, Hanoi, Recfib, Benchmark Sources +@subsection div-iter and div-rec + +@example +@group +;;;; Recursive and iterative benchmark divides by 2 using lists of ()'s. +(define (create-n n) + (do ((n n (- n 1)) + (a '() (cons '() a))) + ((= n 0) a))) +(define *ll* (create-n 200)) +(define (iterative-div2 l) + (do ((l l (cddr l)) + (a '() (cons (car l) a))) + ((null? l) a))) +(define (recursive-div2 l) + (cond ((null? l) '()) + (else (cons (car l) (recursive-div2 (cddr l)))))) +(define (test-1 l) + (do ((i 300 (- i 1))) ((= i 0)) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l))) +(define (test-2 l) + (do ((i 300 (- i 1))) ((= i 0)) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l))) +;; for the iterative test call: (test-1 *ll*) +;; for the recursive test call: (test-2 *ll*) +@end group +@end example + +@need 1000 +@node Hanoi, Tak, div-iter and div-rec, Benchmark Sources +@subsection Hanoi + +@example +@group +;;; C optimiser should be able to remove the first recursive call to +;;; move-them. But Solaris 2.4 cc, gcc 2.5.8, and hobbit don't. +(define (hanoi n) + (letrec ((move-them + (lambda (n from to helper) + (if (> n 1) + (begin + (move-them (- n 1) from helper to) + (move-them (- n 1) helper to from)))))) + (move-them n 0 1 2))) +@end group +@end example + +@page +@node Tak, Ctak, Hanoi, Benchmark Sources +@subsection Tak + +@example +@group +;;;; A vanilla version of the TAKeuchi function +(define (tak x y z) + (if (not (< y x)) + z + (tak (tak (- x 1) y z) + (tak (- y 1) z x) + (tak (- z 1) x y)))) +;; call: (tak 18 12 6) +@end group +@end example + +@need 2000 +@node Ctak, Takl, Tak, Benchmark Sources +@subsection Ctak + +@example +@group +;;;; A version of the TAK function that uses continuations +(define (ctak x y z) + (call-with-current-continuation + (lambda (k) + (ctak-aux k x y z)))) + +(define (ctak-aux k x y z) + (cond ((not (< y x)) (k z)) + (else (call-with-current-continuation + (ctak-aux + k + (call-with-current-continuation + (lambda (k) (ctak-aux k (- x 1) y z))) + (call-with-current-continuation + (lambda (k) (ctak-aux k (- y 1) z x))) + (call-with-current-continuation + (lambda (k) (ctak-aux k (- z 1) x y)))))))) + +(define (id x) x) + +(define (mb-test r x y z) + (if (zero? r) + (ctak x y z) + (id (mb-test (- r 1) x y z)))) +;;; call: (ctak 18 12 6) +@end group +@end example + +@need 2000 +@node Takl, Cpstak, Ctak, Benchmark Sources +@subsection Takl + +@example +@group +;;;; The TAKeuchi function using lists as counters. +(define (listn n) + (if (not (= 0 n)) + (cons n (listn (- n 1))) + '())) + +(define l18 (listn 18)) +(define l12 (listn 12)) +(define l6 (listn 6)) + +(define (mas x y z) + (if (not (shorterp y x)) + z + (mas (mas (cdr x) y z) + (mas (cdr y) z x) + (mas (cdr z) x y)))) + +(define (shorterp x y) + (and (pair? y) (or (null? x) (shorterp (cdr x) (cdr y))))) +;; call: (mas l18 l12 l6) +@end group +@end example + +@need 2000 +@node Cpstak, Pi, Takl, Benchmark Sources +@subsection Cpstak + +@example +@group +;;;; A continuation-passing version of the TAK benchmark. +(define (cpstak x y z) + (define (tak x y z k) + (if (not (< y x)) + (k z) + (tak (- x 1) + y + z + (lambda (v1) + (tak (- y 1) + z + x + (lambda (v2) + (tak (- z 1) + x + y + (lambda (v3) + (tak v1 v2 v3 k))))))))) + (tak x y z (lambda (a) a))) +;;; call: (cpstak 18 12 6) +@end group +@end example + +@need 4000 +@node Pi, , Cpstak, Benchmark Sources +@subsection Pi + +@example +@group +(define (pi n . args) + (let* ((d (car args)) + (r (do ((s 1 (* 10 s)) + (i 0 (+ 1 i))) + ((>= i d) s))) + (n (+ (quotient n d) 1)) + (m (quotient (* n d 3322) 1000)) + (a (make-vector (+ 1 m) 2))) + (vector-set! a m 4) + (do ((j 1 (+ 1 j)) + (q 0 0) + (b 2 (remainder q r))) + ((> j n)) + (do ((k m (- k 1))) + ((zero? k)) + (set! q (+ q (* (vector-ref a k) r))) + (let ((t (+ 1 (* 2 k)))) + (vector-set! a k (remainder q t)) + (set! q (* k (quotient q t))))) + (let ((s (number->string (+ b (quotient q r))))) + (do ((l (string-length s) (+ 1 l))) + ((>= l d) (display s)) + (display #\0))) + (if (zero? (modulo j 10)) (newline) (display #\ ))) + (newline))) +@end group +@end example + + +@node Principles of Compilation, About Hobbit, Performance of Compiled Code, Top +@chapter Principles of Compilation + +@menu +* Macro-Expansion and Analysis:: Pass 1 +* Building Closures:: Pass 2 +* Lambda-lifting:: Pass 3 +* Statement-lifting:: Pass 4 +* Higher-order Arglists:: Pass 5 +* Typing and Constants:: Pass 6 +@end menu + +@node Macro-Expansion and Analysis, Building Closures, Principles of Compilation, Principles of Compilation +@section Expansion and Analysis + + +@enumerate +@item +Macros defined by defmacro and all the quasiquotes +are expanded and compiled into equivalent form without macros +and quasiquotes. + +For example, `(a , x) will be converted to (cons 'a (cons x '())). + +@item +Define-s with the nonessential syntax like + +@example +(define (foo x) @dots{}) +@end example + +are converted to @t{define}s with the essential syntax + +@example +(define foo (lambda (x) @dots{})) +@end example + +Non-top-level @t{define}s are converted into equivalent +@t{letrec}-s. + +@item +Variables are renamed to avoid name clashes, so that any local +variable may have a whole procedure as its scope. This renaming +also converts let-s to let*-s. Variables which do not introduce +potential name clashes are not renamed. For example, + +@example +@group +(define (foo x y) + (let ((x y) + (z x)) + (let* ((x (+ z x))) + x))) +@end group +@end example + +is converted to + +@example +@group +(define foo + (lambda (x y) + (let* ((x__1 y) + (z x) + (x__2 (+ z x__1))) + x__2))) +@end group +@end example + +@item +In case the set of procedures defined in one @t{letrec} is actually not +wholly mutually recursive (eg, f1 calls f2, but f2 does not call f1, or +there are three procedures, f1, f2, f3 so that f1 and f2 are mutually +recursive but f3 is not called from f1 or f2 and it does not call them, +etc), it is possible to minimize the number of additional variables +passed to procedures. + +Thus @t{letrec}-s are split into ordered chunks using dependency +analysis and topological sorting, to reduce the number of mutually +passed variables. Wherever possible, @t{letrec}-s are replaced by +@t{let*}-s inside these chunks. + + +@item +Normalization is performed. This converts a majority of scheme +control procedures like cond, case, or, and into equivalent +terms using a small set of primitives. New variables may be +introduced in this phase. + +In case a procedure like or or and occurs in the place where its value +is treated as a boolean (eg. first argument of if), it is converted +into an analogous boolean-returning procedure, which will finally +be represented by an analogous C procedure (eg. || or &&). + +Associative procedures are converted into structures of corresponding +nonassociative procedures. List is converted to a structure of cons-s. + +Map and @t{for-each} with more than two arguments are converted into an +equivalent do-cycle. @t{map}-s and @t{for-each}-s with two arguments are +treated as if they were defined in the compiled file -- the definitions +@t{map1} and @t{for-each1} are automatically included, if needed. + +There is an option in @file{hobbit.scm} to make all @t{map}-s and +@t{for-each}-s be converted into equivalent do-loops, avoiding the use +of @t{map1} and/or @t{for-each1} altogether. + + +@item +Code is analysed for determining which primitive names and +compiled procedure names are assumed to be redefinable. + +@item +Analysing HOP clonability: hobbit will find a list of clonable +HOP-s with information about higher-order arguments. + +Criterias for HOP clonability are given in the section 6.4. + + +@item +Analysis of liftability: hobbit will determine which lambda-terms +have to be built as real closures (implemented as a vector where the +first element is a pointer to a function and the rest contain values +of environment variables or environment blocks of surrounding code) +and which lambda-terms are liftable. + +Liftability analysis follows the criterias given in section 6.5 and +6.6. +@end enumerate + + +@node Building Closures, Lambda-lifting, Macro-Expansion and Analysis, Principles of Compilation +@section Building Closures + + +Here Hobbit produces code for creating real closures for all the +lambda-terms which are not marked as being liftable by the previous +liftability analysis. + +Global variables (eg x-glob) are translated as pointers (locations) to +SCM objects and used via a fetch: *x_glob (or a fetch +macro GLOBAL(x-glob) which translates to *x_glob). + +While producing closures hobbit tries to minimize the indirection +levels necessary. Generally a local variable x may have to be translated +to an element of a vector of local variables built in the procedure +creating x. If x occurs in a non-liftable closure, the whole vector +of local variables is passed to a closure. + +Such a translation using a local vector will only take place if either x +is @t{set!} inside a non-liftable lambda-term or x is a name of a +recursively defined non-liftable function, and the definition of x is +irregular. The definition of x is irregular if x is given the +non-liftable recursive value @var{t} by extra computation, eg as + +@example +(set! x (let ((u 1)) (lambda (y) (display u) (x (+ u 1))))) +@end example + +and not as a simple lambdaterm: + +@example +(set! x (lambda (y) (display x) (x (+ y 1)))) +@end example + +In all the other cases a local scheme variable x is translated +directly to a local C variable x having the type SCM (a 32-bit +integer). If such an x occurs in a non-liftable closure, then +only its value is passed to a closure via the closure-vector. +In case the directly-translated variable x is passed to a liftable +lambda-term where it is @t{set!}, then x is passed indirectly by +using its address &x. In the lifted lambda-term it is then accessed via *. + +If all the variables x1, @dots{}, xn created in a procedure can be +translated directly as C variables, then the procedure does not create a +special vector for (a subset of) local variables. + +An application (foo @dots{}) is generally translated to C by an internal +apply of the SCM interpreter: +apply(GLOBAL(foo), @dots{}). Using an internal apply is much slower than +using direct a C function call, since: + +@itemize @bullet +@item +there is an extra fetch by GLOBAL(foo), +@item +internal apply performs some computations, +@item +the arguments of foo are passed as a list constructed during + application: that is, there is a lot of expensive consing every + time foo is applied via an internal apply. +@end itemize + +However, in case foo is either a name of a non-redefined primitive or a +name of a non-redefined liftable procedure, the application is +translated to C directly without the extra layer of calling apply: +foo(@dots{}). + +Sometimes lambda-lifting generates the case that some variable +x is accessed not directly, but by *x. See the next section. + +Undefined procedures are assumed to be defined via interpreter +and are called using an internal apply. + +@node Lambda-lifting, Statement-lifting, Building Closures, Principles of Compilation +@section Lambda-lifting + + +When this pass starts, all the real (nonliftable) closures have been +translated to closure-creating code. The remaining lambda-terms +are all liftable. + +Lambda-lifting is performed. That is, all procedures defined inside +some other procedure (eg. in @t{letrec}) and unnamed lambda-terms are +made top-level procedure definitions. Any N variables not bound in such +procedures which were bound in the surrounding procedure are given as +extra N first parameters of the procedure, and whenever the procedure is +called, the values of these variables are given as extra N first +arguments. + +For example: + +@example +@group +(define foo + (lambda (x y) + (letrec ((bar (lambda (u) (+ u x)))) + (bar y) ))) +@end group +@end example + +is converted to + +@example +@group +(define foo + (lambda (x y) + (foo-fn1 x y) )) + +(define foo-fn1 + (lambda (x u) + (+ u x) )) +@end group +@end example + +The case of mutually recursive definitions in @t{letrec} needs special +treatment -- all free variables in mutually recursive funs have, in +general, to be passed to each of those funs. For example, in + +@example +@group +(define (foo x y z i) + (letrec ((f1 (lambda (u) (if x (+ (f2 u) 1)))) + (f2 (lambda (v) (if (zero? v) 1 (f1 z)))) ) + (f2 i) )) +@end group +@end example + +the procedure f1 contains a free variable x and the procedure f2 +contains a free variable z. Lambda-lifted f1 and f2 must +each get both of these variables: + +@example +@group +(define (foo x y z i) + (foo-fn2 x z i) ) + +(define foo-fn1 + (lambda (x z u) (if x (+ (foo-fn2 x z u) 1))) ) + +(define foo-fn2 + (lambda (x z v) (if (zero? v) 1 (foo-fn1 x z z))) ) +@end group +@end example + +Recall that hobbit has already done dependency analysis and has +split the original @t{letrec} into smaller chunks according to this +analysis: see pass 1. + +Whenever the value of some free variable is modified by @t{set!} in +the procedure, this variable is passed by reference instead. +This is not directly possible in scheme, but it is possible in C. + +@example +@group +(define foo + (lambda (x y z) + (letrec ((bar (lambda (u) (set! z (+ u x z))))) + (bar y) + z))) +@end group +@end example + +is converted to incorrect scheme: + +@example +@group +(define foo + (lambda (x y z) + (foo-fn1 x (**c-adr** z) y) + z)) + +(define foo-fn1 + (lambda (x (**c-adr** z) u) + (set! (**c-fetch** z) (+ u x (**c-fetch** z))) )) +@end group +@end example + +The last two will finally be compiled into correct C as: + +@example +@group +SCM foo(x, y, z) +SCM x, y, z; +@{ + foo_fn1(x, &z, y); + return z; +@} + +SCM foo_fn1(x, z, u) +SCM x, u; +SCM *z; +@{ + return (*z = (u + x) + *z); +@} +@end group +@end example + + + +@node Statement-lifting, Higher-order Arglists, Lambda-lifting, Principles of Compilation +@section Statement-lifting + +As the scheme do-construction is compiled into C for, but for cannot +occur in all places in C (it is a statement), then if the do in a +scheme procedure occurs in a place which will not be a statement +in C, the whole do-term is lifted out into a new top-level +procedure analogously to lambda-lifting. Any statement-lifted +parts of some procedure foo are called foo_aux@var{n}, where @var{n} +is a number. + +The special C-ish procedure **return** is pushed into a scheme term as far +as possible to extend the scope of statements in the resulting +C program. For example, + +@example +@group +(define foo + (lambda (x y) + (if x (+ 1 y) (+ 2 y)) )) +@end group +@end example + +is converted to + +@example +@group +(define foo + (lambda (x y) + (if x (**return** (+ 1 y)) (**return** (+ 2 y))) )) +@end group +@end example + +Immediate tailrecursion (foo calling foo tailrecursively) is +recognized and converted into an assignment of new values to args and +a jump to the beginning of the procedure body. + + +@node Higher-order Arglists, Typing and Constants, Statement-lifting, Principles of Compilation +@section Higher-order Arglists + +All procedures taking a list argument are converted into ordinary +non-list taking procedures and they are called with the list-making +calls inserted. For example, + +@example +@group +(define foo + (lambda (x . y) + (cons x (reverse y)) )) +@end group +@end example + +is converted to + +@example +@group +(define foo + (lambda (x y) + (cons x (reverse y)) )) +@end group +@end example + +and any call to foo will make a list for a variable y. For example, + +@example +(foo 1 2 3) +@end example + +is converted to + +@example +(foo 1 (cons 2 (cons 3 '()))). +@end example + +All higher-order procedure calls where an argument-term contains +unbound variables will generate a new instance (provided it +has not been created already) of this higher-order procedure, +carrying the right amount of free variables inside to right +places. + +For example, if there is a following definition: + +@example +@group +(define (member-if fn lst) + (if (fn (car lst)) + lst + (member-if fn (cdr lst)) )) +@end group +@end example + +and a call + +@example +(member-if (lambda (x) (eq? x y)) lst), +@end example + +a new instance of member-if is created (if an analogous one +has not been created before): + +@example +@group +(define (member-if_inst1 tmp fn lst) + (if (fn tmp (car lst)) + lst + (member-if_inst1 tmp fn (cdr lst)) )) +@end group +@end example + +and the call is converted to + +@example +(member-if_inst1 y foo lst) +@end example + +and a top-level @t{define} + +@example +(define (foo y x) (eq? x y)) +@end example + +In addition, if the higher-order procedure is to be exported, +an additional instance is created, which uses apply to +call all argument-procedures, assuming they are defined via interpreter. +The exportable higher-order procedure will have a name @var{fun}_exporthof, +where @var{fun} is the name of the original procedure. + + +@node Typing and Constants, , Higher-order Arglists, Principles of Compilation +@section Typing and Constants + +All C<->Scheme conversions for immediate objects like numbers, +booleans and characters are introduced. Internal apply +is used for undefined procedures. Some optimizations are performed +to decrease the amount of C<->Scheme object conversions. + +All vector, pair and string constants are replaced by new +variables. These variables are instantiated to the right +values by init_@var{foo*}. + +Procedures foo which are to be exported (made accesible to the +interpreter), and which have an arity different from one of the +following five templates: x, (), (x), (x y), (x y z), are made +accessible via an additional procedure foo_wrapper taking a single +list argument. + +@subheading C Code Generation + +More or less straightforward. + +The type conversion between C objects and immediate Scheme objects of +the type boolean, char and num is performed by macros. The scheme +object @t{'()} is represented by the macro object EOL. + +@subheading Intermediate files + +Experiment yourself by defining: + +@example +(define *build-intermediate-files* #t) +@end example + +instead of the default: + +@example +(define *build-intermediate-files* #f). +@end example + + +@node About Hobbit, , Principles of Compilation, Top +@chapter About Hobbit + +@menu +* The Aims of Developing Hobbit:: +* Manifest:: +* Author and Contributors:: +* Future Improvements:: +* Release History:: +@end menu + +@node The Aims of Developing Hobbit, Manifest, About Hobbit, About Hobbit +@section The Aims of Developing Hobbit + +@enumerate +@item +Producing maximally fast C code from simple scheme code. + +By @dfn{simple} we mean code which does not rely on procedures +returning procedures (closures) and nontrivial forms of +higher-order procedures. All the latter are also compiled, +but the optimizations specially target simple code fragments. +Hobbit performs global optimization in order to locate such fragments. + +@item +Producing C code which would preserve as much original scheme +code structure as possible, to enable using the output C code +by a human programmer (eg. for introducing special optimizations +possible in C). Also, this will hopefully help the C compiler +to find better optimizations. +@end enumerate + + +@node Manifest, Author and Contributors, The Aims of Developing Hobbit, About Hobbit +@section Manifest + +@multitable @columnfractions .2 .8 +@item @file{hobbit.scm} +@tab the hobbit compiler. +@item @file{scmhob.scm} +@tab the file defining some additional procedures recognized +by hobbit as primitives. Use it with the interpreter only. +@item @file{scmhob.h} +@tab the common headerfile for hobbit-compiled C files. +@item @file{hobbit.texi} +@tab documentation for hobbit. +@end multitable + + +@node Author and Contributors, Future Improvements, Manifest, About Hobbit +@section Author and Contributors + +@quotation +Tanel Tammet@* +Department of Computing Science@* +Chalmers University of Technology@* +University of Go"teborg@* +S-41296 Go"teborg Sweden +@end quotation + +A. Jaffer (jaffer @@ alum.mit.edu), the author of SCM, has been of major +help with a number of suggestions and hacks, especially concerning the +interface between compiled code and the SCM interpreter. + +Several people have helped with suggestions and detailed bug reports, +e.g. David J. Fiander (davidf@@mks.com), Gordon Oulsnam +(STCS8004@@IRUCCVAX.UCC.IE), Pertti Kelloma"ki (pk@@cs.tut.fi), +Dominique de Waleffe (ddw2@@sunbim.be) Terry Moore (tmm@@databook.com), +Marshall Abrams (ab2r@@midway.uchicago.edu). Georgy K. Bronnikov +(goga@@bronnikov.msk.su), Bernard Urban (Bernard.URBAN@@meteo.fr), +Charlie Xiaoli Huang, Tom Lord (lord@@cygnus.com), +NMICHAEL@@us.oracle.com, Lee Iverson (leei@@ai.sri.com), Burt +Leavenworth (EDLSOFT@@aol.com). + + +@page +@node Future Improvements, Release History, Author and Contributors, About Hobbit +@section Future Improvements + +@enumerate +@item +Optimisations: + +@itemize +@item +the calls to internal apply: we'd like to avoid the excessive consing of +always building the list of arguments. +@item +speeding up the creation of a vector for assignable closure-variables +@item +several peephole optimisations. +@end itemize + +@item +Improve Variable creation and naming to avoid C function name clashes. + +@item +Report 4 macros. + +@item +Better error-checking. + +@item +Better liftability analysis. + +@item +More tailrecursion recognition. + +@item +Better numeric optimizations. + +@item +Fast real-only arithmetics: $eqv, $=, $>, $+, $*, etc. +@end enumerate + + +@node Release History, , Future Improvements, About Hobbit +@section Release History + +@quotation +[In February 2002, hobbit5x was integrated into the SCM distribution. +Changes since then are recorded in @file{scm/ChangeLog}.] +@end quotation + +@table @asis +@item hobbit4d: +@itemize @bullet +@item +the incorrect translation of char>?, char-ci>?, char>=?, char-ci>=? +string>?, string-ci>?, string-ci>=?, string>=? reported by +Burt Leavenworth (EDLSOFT@@aol.com) was fixed. +@item +the name clash bug for new variables new_varN occurring in +non-liftable closures (reported by Lee Iverson (leei@@ai.sri.com)) +was fixed. +@item +the major COPYRIGHT change: differently from all the previous +versions of Hobbit, hobbit4d is Free Software. +@end itemize + +@item hobbit4c: +@itemize @bullet +@item +a liftability-analysis bug for @t{for-each} and @t{map} reported +by Lee Iverson (leei@@ai.sri.com) has been fixed. +@item +The output C code does not contain the unnecessary ;-s on +separate lines any more. +@end itemize + +@item hobbit4b: +The following bugs have been fixed: +@itemize @bullet +@item +Erroneous treatment of [ and ] inside symbols, +reported by A. Jaffer (jaffer @@ alum.mit.edu). +@item +A bug in the liftability analysis, +reported by A. Jaffer (jaffer @@ alum.mit.edu). +@item +A bug occurring in case arguments are evaluated right-to-left, +which happens with Hobbit compiled by gcc on Linux. +Reported and patched by George K. Bronnikov (goga@@bronnikov.msk.su) +@item +A closure-building bug sometimes leading to a serious loss of +efficiency (liftability not recognized), +reported by NMICHAEL@@us.oracle.com. +@item +A bug in the liftability analysis (non-liftable lambda-term +inside a liftable lambda-term) +reported by Lee Iverson (leei@@ai.sri.com) +@end itemize + +@item hobbit4a: +Several bugs found in version4x are fixed. + +@item hobbit4x (not public): +@itemize @bullet +@item +A major overhaul: Hobbit is now able to compile full scheme, +not just the fast liftable-clonable fragment. + +The optimizations done by the earlier versions are preserved. + +@item +Numerous bugs found in earlier versions have been fixed. +@end itemize + +@item hobbit3d: +bugs found in the version 3c are fixed. + +@item hobbit3c: +@itemize @bullet +@item +the form + +@example +(define foo (let ((x1 <t1>) @dots{} (xn <tn>)) (lambda @dots{}))) +@end example + +is now supported for all terms <ti> except procedures defined +in the compiled files. +@item +macros are partially supported by doing a preprocessing pass using the +procedures pprint-filter-file and defmacro:expand* defined +in slib. +@item +the file @file{scmhob.scm} defining hobbit-recognized nonstandard +procedures is created. +@item +the documentation is improved (thanks go to Aubrey for suggestions). +@end itemize + +@item hobbit3b: +@itemize @bullet +@item +Aubrey fixed some problems with the version 3. +@item +It is now OK to define procedures "by name" on top level. +@item +It is now OK to apply "apply", etc to procedures defined +in the compiled file. Compiled procedures may now be passed +to procedures not defined but still called in the compiled files. +@end itemize + +@item hobbit3: +@itemize @bullet +@item +Generic arithmetic supported by SCM (exact and inexact reals, +bignums) is made available. +@item +The #. special syntactic form of SCM is made available. +@item +Procedures with chars are compiled open-coded, making them faster. +@item +The bug concerning strings containing an embedded \nl char +is corrected (thanks to Terry Moore, (tmm@@databook.com)). +@item +The special declaration compile-stable-vectors for optimizing +vector access is introduced. +@item +Source code may contain top-level computations, top-level +loads are ignored. +@item +The bug causing "or" to (sometimes) lose tailrecursiveness is corrected. +@item +Hobbit now allows the following very special form: + +@example +(define foo (let ((bar bar)) (lambda @dots{}))) +@end example + +Notice @code{(bar bar)}. See the section 5 above. It will produce wrong +code if bar is redefined. + +There were several versions of the 2-series, like 2.x, which were +not made public. The changes introduced are present in the version 3. +@end itemize + +@item hobbit2: +@itemize @bullet +@item +The following bitwise procedures in the scheme library file +@file{logical.scm} are compiled directly to C +(Scheme library funs in the upper row, C ops below): + +@example +@group +logand logior logxor lognot logsleft logsright + & | ^ ~ << >> +@end group +@end example + +Notice that the procedures @t{logsleft}, @t{logsright} are @b{NOT} in +the the library file @file{logical.scm}: the universal procedure @t{ash} +is instead. Procedures @t{ash}, @t{logcount}, @t{integer-length}, +@t{integer-expt}, @t{bit-extract} in @file{logical.scm} are not +recognized by hobbit. +@end itemize + +@item hobbit1a3 (not public): +@itemize @bullet +@item +the @t{letrec}-sorting bug often resulting in not recognizing procedures +defined in @t{letrec} (or local @t{define}s) has been corrected. +@item +the primitives @t{string} and @t{vector} are now compiled correctly. +@end itemize + +@item hobbit1a2 (not public): +@itemize @bullet +@item +any fixed arity procedure (including primitives) may be passed to any +higher-order procedure by name. Variable arity procedures (eg +primitives @t{list}, @t{+}, @t{display} and defined funs like +@code{(define (foo x . y) x)}) must not be passed to new defined +higher-order funs. +@item +some optimizations have been introduced for calls to @t{map} +and @t{for-each}. +@item +(map list x y) bug has been corrected. +@item +Corrected self-compilation name clash between call_cc and call-cc. +@end itemize + +@item hobbit1a1 (not public): +@itemize @bullet +@item +named let is supported. +@item +the inlining bug is fixed: all procedures declared to be +inlined are fully inlined, except when the flag +*full-inlining-flag* is defined as #f. +@item +the @t{letrec} (or in-procedure define) bug where local procedure +names were not recognized, is fixed. +@item +documentation says explicitly that definitions like + +@example +(define foo (let ((x 0)) (lambda (y) @dots{}))) +@end example + +are assumed to be closure-returning procedures and are prohibited. +@item +documentation allows more liberty with passing procedures to +higher-order funs by dropping the general requirement that only unnamed +lambda-terms may be passed. Still, primitives and list-taking +procedures may not be passed by name. +@item +documentation prohibits passing lambda-terms with free variables to +recursive calls of higher-order procedures in the definition of a +higher-order procedure. +@end itemize + +@item hobbit1: +the first release +@end table + + +@contents +@bye @@ -17,26 +17,26 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. @@ -44,8 +44,7 @@ ;;; Author: Aubrey Jaffer. (define (go-script) - (cond ((not *script*)) - ((< 1 (- (length *argv*) *optind*)) + (cond ((< 1 (- (length *argv*) *optind*)) (apply inc2scm (list-tail *argv* *optind*))) (else (display "\ @@ -151,8 +150,9 @@ Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ... filename "\\n\");") (for-each - (lambda (name) (fprintf cport " pSl(\"%s\", %s);\\n" - (schemeify-name pre name) name)) + (lambda (name) + (fprintf cport "#ifdef %s\\n pSl(\"%s\", %s);\\n#endif\\n" + name (schemeify-name pre name) name)) (call-with-input-file filename extract-defineds))) filenames) (fprintf cport "}\\n"))) @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -70,8 +70,11 @@ SCM stat2scm P((struct stat *stat_temp)); #ifdef __FreeBSD__ # include <unistd.h> #endif +#ifdef __OpenBSD__ +# include <unistd.h> +#endif /* added by Denys Duchier */ -#ifdef __svr4__ +#ifdef __SVR4 # include <sys/types.h> # include <unistd.h> #endif @@ -81,6 +84,12 @@ SCM stat2scm P((struct stat *stat_temp)); #ifdef GO32 # include <unistd.h> #endif +#ifdef __osf__ +# include <unistd.h> +#endif +#ifdef __MACH__ +# include <unistd.h> +#endif #ifndef STDC_HEADERS int chdir P((const char *path)); @@ -198,6 +207,20 @@ SCM file_set_position(port, pos) { SCM ans; ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos); +#ifndef RECKLESS + if (TRACKED & SCM_PORTFLAGS(port)) { + if (INUM0==pos) { + int i = SCM_PORTNUM(port); + scm_port_table[i].line = 1L; + scm_port_table[i].col = 1; + } + else { + if (2 <= verbose) + scm_warn("Setting file position for tracked port: ", "", port); + SCM_PORTFLAGS(port) &= (~TRACKED); + } + } +#endif CLRDY(port); /* Clear ungetted char */ SYSCALL(ans = (fseek(STREAM(port), INUM(pos), 0)) ? BOOL_F : BOOL_T;); #ifdef HAVE_PIPE @@ -217,8 +240,9 @@ SCM reopen_file(filename, modes, port) char cmodes[4]; long flags; ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_reopen_file); - ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_reopen_file); + ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_reopen_file); flags = mode_bits(CHARS(modes), cmodes); + ASSERT(flags, modes, ARG2, s_reopen_file); DEFER_INTS; ASSERT(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file); SCM_OPENCALL(f = freopen(CHARS(filename), cmodes, STREAM(port))); @@ -227,14 +251,13 @@ SCM reopen_file(filename, modes, port) return BOOL_F; } else { - SETSTREAM(port, f); SCM_PORTFLAGS(port) = flags; - CAR(port) = scm_port_entry(tc16_fport, flags); + SCM_SETFLAGS(port, flags); if (BUF0 & flags) i_setbuf0(port); + SCM_PORTDATA(port) = filename; } ALLOW_INTS; - SCM_PORTDATA(port) = filename; return port; } @@ -250,19 +273,25 @@ SCM l_dup(oldpt, modes) FILE *f; SCM newpt; ASSERT(NIMP(oldpt) && OPFPORTP(oldpt), oldpt, ARG1, s_dup); - ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_dup); + ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_dup); flags = mode_bits(CHARS(modes), cmodes); + ASSERT(flags, modes, ARG2, s_dup); NEWCELL(newpt); DEFER_INTS; SCM_OPENCALL(tfd = dup(fileno(STREAM(oldpt)))); if (-1==tfd) {ALLOW_INTS;return BOOL_F;}; SYSCALL(f = fdopen(tfd, cmodes);); if (!f) { + int lerrno = errno; close(tfd); + errno = lerrno; +# ifdef EINVAL + if (lerrno==EINVAL) wta(modes, (char *)ARG2, s_dup); +# endif wta(MAKINUM(tfd), (char *)NALLOC, s_port_type); } - SETSTREAM(newpt, f); - CAR(newpt) = scm_port_entry(tc16_fport, flags); + newpt = scm_port_entry(f, tc16_fport, flags); + SCM_PORTDATA(newpt) = SCM_PORTDATA(oldpt); if (BUF0 & flags) i_setbuf0(newpt); ALLOW_INTS; @@ -690,6 +719,49 @@ static iproc subr2s[] = { #endif {0, 0}}; +#include <fcntl.h> /* for O_RDONLY, O_RDWR, O_EXCL */ +#ifdef O_EXCL +SCM scm_try_create_file(fname, modes, perms) + SCM fname, modes, perms; +{ + SCM port; + FILE *f; + char cmodes[4]; + long flags; + int fd, fdflags = O_CREAT | O_EXCL; +# ifdef S_IROTH + mode_t cperms = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; +# else + int cperms = 0666; +# endif + ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_try_create_file); + ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_try_create_file); + if (NNULLP(perms)) { + perms = CAR(perms); + ASSERT(INUMP(perms), perms, ARG3, s_try_create_file); +# ifdef S_IROTH + cperms = (mode_t)INUM(perms); +# else + cperms = INUM(perms); +# endif + } + flags = mode_bits(CHARS(modes), cmodes); + ASSERT(flags, modes, ARG2, s_try_create_file); + fdflags |= (RDNG & flags) ? O_RDWR : O_WRONLY; + DEFER_INTS; + SCM_OPENCALL(fd = open(CHARS(fname), fdflags, cperms)); + if (fd >= 0 && (f = fdopen(fd, cmodes))) { + port = scm_port_entry(f, tc16_fport, flags); + if (BUF0 & flags) i_setbuf0(port); + SCM_PORTDATA(port) = fname; + } + else + port = BOOL_F; + ALLOW_INTS; + return port; +} +#endif + static iproc subr2os[] = { {s_file_set_pos, file_set_position}, {s_read_line1, read_line1}, @@ -702,6 +774,9 @@ void init_ioext() init_iprocs(subr1s, tc7_subr_1); init_iprocs(subr2os, tc7_subr_2o); init_iprocs(subr2s, tc7_subr_2); +#ifdef O_EXCL + make_subr(s_try_create_file, tc7_lsubr_2, scm_try_create_file); +#endif make_subr(s_reopen_file, tc7_subr_3, reopen_file); #ifndef THINK_C # ifndef MCH_AMIGA @@ -733,6 +808,7 @@ void init_ioext() add_feature("i/o-extensions"); add_feature("line-i/o"); scm_ldstr("\n\ +(define (file-exists? path) (access path \"r\"))\n\ (define (directory-for-each proc dirname . args)\n\ (define dir (opendir (if (symbol? dirname)\n\ (symbol->string dirname)\n\ diff --git a/keysymdef.scm b/keysymdef.scm new file mode 100644 index 0000000..d35fcc7 --- /dev/null +++ b/keysymdef.scm @@ -0,0 +1,674 @@ +;;inc2scm extracted #define values from /usr/include/X11/keysym.h +;;inc2scm extracted #define values from /usr/include/X11/keysymdef.h +(define XK:VoidSymbol 16777215) +(define XK:BackSpace 65288) +(define XK:Tab 65289) +(define XK:Linefeed 65290) +(define XK:Clear 65291) +(define XK:Return 65293) +(define XK:Pause 65299) +(define XK:Scroll-Lock 65300) +(define XK:Sys-Req 65301) +(define XK:Escape 65307) +(define XK:Delete 65535) +(define XK:Multi-key 65312) +(define XK:Codeinput 65335) +(define XK:SingleCandidate 65340) +(define XK:MultipleCandidate 65341) +(define XK:PreviousCandidate 65342) +(define XK:Kanji 65313) +(define XK:Muhenkan 65314) +(define XK:Henkan-Mode 65315) +(define XK:Henkan 65315) +(define XK:Romaji 65316) +(define XK:Hiragana 65317) +(define XK:Katakana 65318) +(define XK:Hiragana-Katakana 65319) +(define XK:Zenkaku 65320) +(define XK:Hankaku 65321) +(define XK:Zenkaku-Hankaku 65322) +(define XK:Touroku 65323) +(define XK:Massyo 65324) +(define XK:Kana-Lock 65325) +(define XK:Kana-Shift 65326) +(define XK:Eisu-Shift 65327) +(define XK:Eisu-toggle 65328) +(define XK:Kanji-Bangou 65335) +(define XK:Zen-Koho 65341) +(define XK:Mae-Koho 65342) +(define XK:Home 65360) +(define XK:Left 65361) +(define XK:Up 65362) +(define XK:Right 65363) +(define XK:Down 65364) +(define XK:Prior 65365) +(define XK:Page-Up 65365) +(define XK:Next 65366) +(define XK:Page-Down 65366) +(define XK:End 65367) +(define XK:Begin 65368) +(define XK:Select 65376) +(define XK:Print 65377) +(define XK:Execute 65378) +(define XK:Insert 65379) +(define XK:Undo 65381) +(define XK:Redo 65382) +(define XK:Menu 65383) +(define XK:Find 65384) +(define XK:Cancel 65385) +(define XK:Help 65386) +(define XK:Break 65387) +(define XK:Mode-switch 65406) +(define XK:script-switch 65406) +(define XK:Num-Lock 65407) +(define XK:KP-Space 65408) +(define XK:KP-Tab 65417) +(define XK:KP-Enter 65421) +(define XK:KP-F1 65425) +(define XK:KP-F2 65426) +(define XK:KP-F3 65427) +(define XK:KP-F4 65428) +(define XK:KP-Home 65429) +(define XK:KP-Left 65430) +(define XK:KP-Up 65431) +(define XK:KP-Right 65432) +(define XK:KP-Down 65433) +(define XK:KP-Prior 65434) +(define XK:KP-Page-Up 65434) +(define XK:KP-Next 65435) +(define XK:KP-Page-Down 65435) +(define XK:KP-End 65436) +(define XK:KP-Begin 65437) +(define XK:KP-Insert 65438) +(define XK:KP-Delete 65439) +(define XK:KP-Equal 65469) +(define XK:KP-Multiply 65450) +(define XK:KP-Add 65451) +(define XK:KP-Separator 65452) +(define XK:KP-Subtract 65453) +(define XK:KP-Decimal 65454) +(define XK:KP-Divide 65455) +(define XK:KP-0 65456) +(define XK:KP-1 65457) +(define XK:KP-2 65458) +(define XK:KP-3 65459) +(define XK:KP-4 65460) +(define XK:KP-5 65461) +(define XK:KP-6 65462) +(define XK:KP-7 65463) +(define XK:KP-8 65464) +(define XK:KP-9 65465) +(define XK:F1 65470) +(define XK:F2 65471) +(define XK:F3 65472) +(define XK:F4 65473) +(define XK:F5 65474) +(define XK:F6 65475) +(define XK:F7 65476) +(define XK:F8 65477) +(define XK:F9 65478) +(define XK:F10 65479) +(define XK:F11 65480) +(define XK:L1 65480) +(define XK:F12 65481) +(define XK:L2 65481) +(define XK:F13 65482) +(define XK:L3 65482) +(define XK:F14 65483) +(define XK:L4 65483) +(define XK:F15 65484) +(define XK:L5 65484) +(define XK:F16 65485) +(define XK:L6 65485) +(define XK:F17 65486) +(define XK:L7 65486) +(define XK:F18 65487) +(define XK:L8 65487) +(define XK:F19 65488) +(define XK:L9 65488) +(define XK:F20 65489) +(define XK:L10 65489) +(define XK:F21 65490) +(define XK:R1 65490) +(define XK:F22 65491) +(define XK:R2 65491) +(define XK:F23 65492) +(define XK:R3 65492) +(define XK:F24 65493) +(define XK:R4 65493) +(define XK:F25 65494) +(define XK:R5 65494) +(define XK:F26 65495) +(define XK:R6 65495) +(define XK:F27 65496) +(define XK:R7 65496) +(define XK:F28 65497) +(define XK:R8 65497) +(define XK:F29 65498) +(define XK:R9 65498) +(define XK:F30 65499) +(define XK:R10 65499) +(define XK:F31 65500) +(define XK:R11 65500) +(define XK:F32 65501) +(define XK:R12 65501) +(define XK:F33 65502) +(define XK:R13 65502) +(define XK:F34 65503) +(define XK:R14 65503) +(define XK:F35 65504) +(define XK:R15 65504) +(define XK:Shift-L 65505) +(define XK:Shift-R 65506) +(define XK:Control-L 65507) +(define XK:Control-R 65508) +(define XK:Caps-Lock 65509) +(define XK:Shift-Lock 65510) +(define XK:Meta-L 65511) +(define XK:Meta-R 65512) +(define XK:Alt-L 65513) +(define XK:Alt-R 65514) +(define XK:Super-L 65515) +(define XK:Super-R 65516) +(define XK:Hyper-L 65517) +(define XK:Hyper-R 65518) +(define XK:ISO-Lock 65025) +(define XK:ISO-Level2-Latch 65026) +(define XK:ISO-Level3-Shift 65027) +(define XK:ISO-Level3-Latch 65028) +(define XK:ISO-Level3-Lock 65029) +(define XK:ISO-Group-Shift 65406) +(define XK:ISO-Group-Latch 65030) +(define XK:ISO-Group-Lock 65031) +(define XK:ISO-Next-Group 65032) +(define XK:ISO-Next-Group-Lock 65033) +(define XK:ISO-Prev-Group 65034) +(define XK:ISO-Prev-Group-Lock 65035) +(define XK:ISO-First-Group 65036) +(define XK:ISO-First-Group-Lock 65037) +(define XK:ISO-Last-Group 65038) +(define XK:ISO-Last-Group-Lock 65039) +(define XK:ISO-Left-Tab 65056) +(define XK:ISO-Move-Line-Up 65057) +(define XK:ISO-Move-Line-Down 65058) +(define XK:ISO-Partial-Line-Up 65059) +(define XK:ISO-Partial-Line-Down 65060) +(define XK:ISO-Partial-Space-Left 65061) +(define XK:ISO-Partial-Space-Right 65062) +(define XK:ISO-Set-Margin-Left 65063) +(define XK:ISO-Set-Margin-Right 65064) +(define XK:ISO-Release-Margin-Left 65065) +(define XK:ISO-Release-Margin-Right 65066) +(define XK:ISO-Release-Both-Margins 65067) +(define XK:ISO-Fast-Cursor-Left 65068) +(define XK:ISO-Fast-Cursor-Right 65069) +(define XK:ISO-Fast-Cursor-Up 65070) +(define XK:ISO-Fast-Cursor-Down 65071) +(define XK:ISO-Continuous-Underline 65072) +(define XK:ISO-Discontinuous-Underline 65073) +(define XK:ISO-Emphasize 65074) +(define XK:ISO-Center-Object 65075) +(define XK:ISO-Enter 65076) +(define XK:dead-grave 65104) +(define XK:dead-acute 65105) +(define XK:dead-circumflex 65106) +(define XK:dead-tilde 65107) +(define XK:dead-macron 65108) +(define XK:dead-breve 65109) +(define XK:dead-abovedot 65110) +(define XK:dead-diaeresis 65111) +(define XK:dead-abovering 65112) +(define XK:dead-doubleacute 65113) +(define XK:dead-caron 65114) +(define XK:dead-cedilla 65115) +(define XK:dead-ogonek 65116) +(define XK:dead-iota 65117) +(define XK:dead-voiced-sound 65118) +(define XK:dead-semivoiced-sound 65119) +(define XK:dead-belowdot 65120) +(define XK:First-Virtual-Screen 65232) +(define XK:Prev-Virtual-Screen 65233) +(define XK:Next-Virtual-Screen 65234) +(define XK:Last-Virtual-Screen 65236) +(define XK:Terminate-Server 65237) +(define XK:AccessX-Enable 65136) +(define XK:AccessX-Feedback-Enable 65137) +(define XK:RepeatKeys-Enable 65138) +(define XK:SlowKeys-Enable 65139) +(define XK:BounceKeys-Enable 65140) +(define XK:StickyKeys-Enable 65141) +(define XK:MouseKeys-Enable 65142) +(define XK:MouseKeys-Accel-Enable 65143) +(define XK:Overlay1-Enable 65144) +(define XK:Overlay2-Enable 65145) +(define XK:AudibleBell-Enable 65146) +(define XK:Pointer-Left 65248) +(define XK:Pointer-Right 65249) +(define XK:Pointer-Up 65250) +(define XK:Pointer-Down 65251) +(define XK:Pointer-UpLeft 65252) +(define XK:Pointer-UpRight 65253) +(define XK:Pointer-DownLeft 65254) +(define XK:Pointer-DownRight 65255) +(define XK:Pointer-Button-Dflt 65256) +(define XK:Pointer-Button1 65257) +(define XK:Pointer-Button2 65258) +(define XK:Pointer-Button3 65259) +(define XK:Pointer-Button4 65260) +(define XK:Pointer-Button5 65261) +(define XK:Pointer-DblClick-Dflt 65262) +(define XK:Pointer-DblClick1 65263) +(define XK:Pointer-DblClick2 65264) +(define XK:Pointer-DblClick3 65265) +(define XK:Pointer-DblClick4 65266) +(define XK:Pointer-DblClick5 65267) +(define XK:Pointer-Drag-Dflt 65268) +(define XK:Pointer-Drag1 65269) +(define XK:Pointer-Drag2 65270) +(define XK:Pointer-Drag3 65271) +(define XK:Pointer-Drag4 65272) +(define XK:Pointer-Drag5 65277) +(define XK:Pointer-EnableKeys 65273) +(define XK:Pointer-Accelerate 65274) +(define XK:Pointer-DfltBtnNext 65275) +(define XK:Pointer-DfltBtnPrev 65276) +(define XK:space 32) +(define XK:exclam 33) +(define XK:quotedbl 34) +(define XK:numbersign 35) +(define XK:dollar 36) +(define XK:percent 37) +(define XK:ampersand 38) +(define XK:apostrophe 39) +(define XK:quoteright 39) +(define XK:parenleft 40) +(define XK:parenright 41) +(define XK:asterisk 42) +(define XK:plus 43) +(define XK:comma 44) +(define XK:minus 45) +(define XK:period 46) +(define XK:slash 47) +(define XK:0 48) +(define XK:1 49) +(define XK:2 50) +(define XK:3 51) +(define XK:4 52) +(define XK:5 53) +(define XK:6 54) +(define XK:7 55) +(define XK:8 56) +(define XK:9 57) +(define XK:colon 58) +(define XK:semicolon 59) +(define XK:less 60) +(define XK:equal 61) +(define XK:greater 62) +(define XK:question 63) +(define XK:at 64) +(define XK:A 65) +(define XK:B 66) +(define XK:C 67) +(define XK:D 68) +(define XK:E 69) +(define XK:F 70) +(define XK:G 71) +(define XK:H 72) +(define XK:I 73) +(define XK:J 74) +(define XK:K 75) +(define XK:L 76) +(define XK:M 77) +(define XK:N 78) +(define XK:O 79) +(define XK:P 80) +(define XK:Q 81) +(define XK:R 82) +(define XK:S 83) +(define XK:T 84) +(define XK:U 85) +(define XK:V 86) +(define XK:W 87) +(define XK:X 88) +(define XK:Y 89) +(define XK:Z 90) +(define XK:bracketleft 91) +(define XK:backslash 92) +(define XK:bracketright 93) +(define XK:asciicircum 94) +(define XK:underscore 95) +(define XK:grave 96) +(define XK:quoteleft 96) +(define XK:a 97) +(define XK:b 98) +(define XK:c 99) +(define XK:d 100) +(define XK:e 101) +(define XK:f 102) +(define XK:g 103) +(define XK:h 104) +(define XK:i 105) +(define XK:j 106) +(define XK:k 107) +(define XK:l 108) +(define XK:m 109) +(define XK:n 110) +(define XK:o 111) +(define XK:p 112) +(define XK:q 113) +(define XK:r 114) +(define XK:s 115) +(define XK:t 116) +(define XK:u 117) +(define XK:v 118) +(define XK:w 119) +(define XK:x 120) +(define XK:y 121) +(define XK:z 122) +(define XK:braceleft 123) +(define XK:bar 124) +(define XK:braceright 125) +(define XK:asciitilde 126) +(define XK:nobreakspace 160) +(define XK:exclamdown 161) +(define XK:cent 162) +(define XK:sterling 163) +(define XK:currency 164) +(define XK:yen 165) +(define XK:brokenbar 166) +(define XK:section 167) +(define XK:diaeresis 168) +(define XK:copyright 169) +(define XK:ordfeminine 170) +(define XK:guillemotleft 171) +(define XK:notsign 172) +(define XK:hyphen 173) +(define XK:registered 174) +(define XK:macron 175) +(define XK:degree 176) +(define XK:plusminus 177) +(define XK:twosuperior 178) +(define XK:threesuperior 179) +(define XK:acute 180) +(define XK:mu 181) +(define XK:paragraph 182) +(define XK:periodcentered 183) +(define XK:cedilla 184) +(define XK:onesuperior 185) +(define XK:masculine 186) +(define XK:guillemotright 187) +(define XK:onequarter 188) +(define XK:onehalf 189) +(define XK:threequarters 190) +(define XK:questiondown 191) +(define XK:Agrave 192) +(define XK:Aacute 193) +(define XK:Acircumflex 194) +(define XK:Atilde 195) +(define XK:Adiaeresis 196) +(define XK:Aring 197) +(define XK:AE 198) +(define XK:Ccedilla 199) +(define XK:Egrave 200) +(define XK:Eacute 201) +(define XK:Ecircumflex 202) +(define XK:Ediaeresis 203) +(define XK:Igrave 204) +(define XK:Iacute 205) +(define XK:Icircumflex 206) +(define XK:Idiaeresis 207) +(define XK:ETH 208) +(define XK:Eth 208) +(define XK:Ntilde 209) +(define XK:Ograve 210) +(define XK:Oacute 211) +(define XK:Ocircumflex 212) +(define XK:Otilde 213) +(define XK:Odiaeresis 214) +(define XK:multiply 215) +(define XK:Ooblique 216) +(define XK:Ugrave 217) +(define XK:Uacute 218) +(define XK:Ucircumflex 219) +(define XK:Udiaeresis 220) +(define XK:Yacute 221) +(define XK:THORN 222) +(define XK:Thorn 222) +(define XK:ssharp 223) +(define XK:agrave 224) +(define XK:aacute 225) +(define XK:acircumflex 226) +(define XK:atilde 227) +(define XK:adiaeresis 228) +(define XK:aring 229) +(define XK:ae 230) +(define XK:ccedilla 231) +(define XK:egrave 232) +(define XK:eacute 233) +(define XK:ecircumflex 234) +(define XK:ediaeresis 235) +(define XK:igrave 236) +(define XK:iacute 237) +(define XK:icircumflex 238) +(define XK:idiaeresis 239) +(define XK:eth 240) +(define XK:ntilde 241) +(define XK:ograve 242) +(define XK:oacute 243) +(define XK:ocircumflex 244) +(define XK:otilde 245) +(define XK:odiaeresis 246) +(define XK:division 247) +(define XK:oslash 248) +(define XK:ugrave 249) +(define XK:uacute 250) +(define XK:ucircumflex 251) +(define XK:udiaeresis 252) +(define XK:yacute 253) +(define XK:thorn 254) +(define XK:ydiaeresis 255) +(define XK:Aogonek 417) +(define XK:breve 418) +(define XK:Lstroke 419) +(define XK:Lcaron 421) +(define XK:Sacute 422) +(define XK:Scaron 425) +(define XK:Scedilla 426) +(define XK:Tcaron 427) +(define XK:Zacute 428) +(define XK:Zcaron 430) +(define XK:Zabovedot 431) +(define XK:aogonek 433) +(define XK:ogonek 434) +(define XK:lstroke 435) +(define XK:lcaron 437) +(define XK:sacute 438) +(define XK:caron 439) +(define XK:scaron 441) +(define XK:scedilla 442) +(define XK:tcaron 443) +(define XK:zacute 444) +(define XK:doubleacute 445) +(define XK:zcaron 446) +(define XK:zabovedot 447) +(define XK:Racute 448) +(define XK:Abreve 451) +(define XK:Lacute 453) +(define XK:Cacute 454) +(define XK:Ccaron 456) +(define XK:Eogonek 458) +(define XK:Ecaron 460) +(define XK:Dcaron 463) +(define XK:Dstroke 464) +(define XK:Nacute 465) +(define XK:Ncaron 466) +(define XK:Odoubleacute 469) +(define XK:Rcaron 472) +(define XK:Uring 473) +(define XK:Udoubleacute 475) +(define XK:Tcedilla 478) +(define XK:racute 480) +(define XK:abreve 483) +(define XK:lacute 485) +(define XK:cacute 486) +(define XK:ccaron 488) +(define XK:eogonek 490) +(define XK:ecaron 492) +(define XK:dcaron 495) +(define XK:dstroke 496) +(define XK:nacute 497) +(define XK:ncaron 498) +(define XK:odoubleacute 501) +(define XK:udoubleacute 507) +(define XK:rcaron 504) +(define XK:uring 505) +(define XK:tcedilla 510) +(define XK:abovedot 511) +(define XK:Hstroke 673) +(define XK:Hcircumflex 678) +(define XK:Iabovedot 681) +(define XK:Gbreve 683) +(define XK:Jcircumflex 684) +(define XK:hstroke 689) +(define XK:hcircumflex 694) +(define XK:idotless 697) +(define XK:gbreve 699) +(define XK:jcircumflex 700) +(define XK:Cabovedot 709) +(define XK:Ccircumflex 710) +(define XK:Gabovedot 725) +(define XK:Gcircumflex 728) +(define XK:Ubreve 733) +(define XK:Scircumflex 734) +(define XK:cabovedot 741) +(define XK:ccircumflex 742) +(define XK:gabovedot 757) +(define XK:gcircumflex 760) +(define XK:ubreve 765) +(define XK:scircumflex 766) +(define XK:kra 930) +(define XK:kappa 930) +(define XK:Rcedilla 931) +(define XK:Itilde 933) +(define XK:Lcedilla 934) +(define XK:Emacron 938) +(define XK:Gcedilla 939) +(define XK:Tslash 940) +(define XK:rcedilla 947) +(define XK:itilde 949) +(define XK:lcedilla 950) +(define XK:emacron 954) +(define XK:gcedilla 955) +(define XK:tslash 956) +(define XK:ENG 957) +(define XK:eng 959) +(define XK:Amacron 960) +(define XK:Iogonek 967) +(define XK:Eabovedot 972) +(define XK:Imacron 975) +(define XK:Ncedilla 977) +(define XK:Omacron 978) +(define XK:Kcedilla 979) +(define XK:Uogonek 985) +(define XK:Utilde 989) +(define XK:Umacron 990) +(define XK:amacron 992) +(define XK:iogonek 999) +(define XK:eabovedot 1004) +(define XK:imacron 1007) +(define XK:ncedilla 1009) +(define XK:omacron 1010) +(define XK:kcedilla 1011) +(define XK:uogonek 1017) +(define XK:utilde 1021) +(define XK:umacron 1022) +(define XK:OE 5052) +(define XK:oe 5053) +(define XK:Ydiaeresis 5054) +(define XK:Greek-ALPHAaccent 1953) +(define XK:Greek-EPSILONaccent 1954) +(define XK:Greek-ETAaccent 1955) +(define XK:Greek-IOTAaccent 1956) +(define XK:Greek-IOTAdiaeresis 1957) +(define XK:Greek-OMICRONaccent 1959) +(define XK:Greek-UPSILONaccent 1960) +(define XK:Greek-UPSILONdieresis 1961) +(define XK:Greek-OMEGAaccent 1963) +(define XK:Greek-accentdieresis 1966) +(define XK:Greek-horizbar 1967) +(define XK:Greek-alphaaccent 1969) +(define XK:Greek-epsilonaccent 1970) +(define XK:Greek-etaaccent 1971) +(define XK:Greek-iotaaccent 1972) +(define XK:Greek-iotadieresis 1973) +(define XK:Greek-iotaaccentdieresis 1974) +(define XK:Greek-omicronaccent 1975) +(define XK:Greek-upsilonaccent 1976) +(define XK:Greek-upsilondieresis 1977) +(define XK:Greek-upsilonaccentdieresis 1978) +(define XK:Greek-omegaaccent 1979) +(define XK:Greek-ALPHA 1985) +(define XK:Greek-BETA 1986) +(define XK:Greek-GAMMA 1987) +(define XK:Greek-DELTA 1988) +(define XK:Greek-EPSILON 1989) +(define XK:Greek-ZETA 1990) +(define XK:Greek-ETA 1991) +(define XK:Greek-THETA 1992) +(define XK:Greek-IOTA 1993) +(define XK:Greek-KAPPA 1994) +(define XK:Greek-LAMDA 1995) +(define XK:Greek-LAMBDA 1995) +(define XK:Greek-MU 1996) +(define XK:Greek-NU 1997) +(define XK:Greek-XI 1998) +(define XK:Greek-OMICRON 1999) +(define XK:Greek-PI 2000) +(define XK:Greek-RHO 2001) +(define XK:Greek-SIGMA 2002) +(define XK:Greek-TAU 2004) +(define XK:Greek-UPSILON 2005) +(define XK:Greek-PHI 2006) +(define XK:Greek-CHI 2007) +(define XK:Greek-PSI 2008) +(define XK:Greek-OMEGA 2009) +(define XK:Greek-alpha 2017) +(define XK:Greek-beta 2018) +(define XK:Greek-gamma 2019) +(define XK:Greek-delta 2020) +(define XK:Greek-epsilon 2021) +(define XK:Greek-zeta 2022) +(define XK:Greek-eta 2023) +(define XK:Greek-theta 2024) +(define XK:Greek-iota 2025) +(define XK:Greek-kappa 2026) +(define XK:Greek-lamda 2027) +(define XK:Greek-lambda 2027) +(define XK:Greek-mu 2028) +(define XK:Greek-nu 2029) +(define XK:Greek-xi 2030) +(define XK:Greek-omicron 2031) +(define XK:Greek-pi 2032) +(define XK:Greek-rho 2033) +(define XK:Greek-sigma 2034) +(define XK:Greek-finalsmallsigma 2035) +(define XK:Greek-tau 2036) +(define XK:Greek-upsilon 2037) +(define XK:Greek-phi 2038) +(define XK:Greek-chi 2039) +(define XK:Greek-psi 2040) +(define XK:Greek-omega 2041) +(define XK:Greek-switch 65406) +(define XK:EcuSign 8352) +(define XK:ColonSign 8353) +(define XK:CruzeiroSign 8354) +(define XK:FFrancSign 8355) +(define XK:LiraSign 8356) +(define XK:MillSign 8357) +(define XK:NairaSign 8358) +(define XK:PesetaSign 8359) +(define XK:RupeeSign 8360) +(define XK:WonSign 8361) +(define XK:NewSheqelSign 8362) +(define XK:DongSign 8363) +(define XK:EuroSign 8364) diff --git a/mkimpcat.scm b/mkimpcat.scm index 2f6c13a..f94f949 100644 --- a/mkimpcat.scm +++ b/mkimpcat.scm @@ -15,52 +15,57 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. ;;;; "mkimpcat.scm" Build SCM-specific catalog for SLIB. ;;; Author: Aubrey Jaffer. -(define (installation-vicinity) "/usr/lib/scm/") - -(let ((catname "implcat")) - (call-with-output-file (in-vicinity (implementation-vicinity) catname) +(let ((catname "implcat") + (iv (implementation-vicinity))) + (define (in-implementation-vicinity . paths) (apply in-vicinity iv paths)) + (call-with-output-file (in-implementation-vicinity catname) (lambda (op) (define (display* . args) (for-each (lambda (arg) (display arg op)) args) (newline op)) - (define wb:vicinity (string-append (installation-vicinity) "../wb/")) - (define x-scm:vicinity - (string-append (installation-vicinity) "../xscm-2.01/")) - (define (add-link feature ofile . libs) - (cond ((file-exists? ofile) - ;; remove #f from libs list - (set! libs (let rem ((l libs)) - (cond ((null? l) l) - ((car l) (cons (car l) (rem (cdr l)))) - (else (rem (cdr l)))))) + (define (in-wb-vicinity . paths) (apply in-vicinity iv "../wb/" paths)) + (define (in-xscm-vicinity . paths) (apply in-vicinity iv "../xscm-2.01/" paths)) + (define (add-link feature . libs) + (define syms '()) + ;; remove #f from libs list + (set! libs (let rem ((l libs)) + (cond ((null? l) l) + ((symbol? (car l)) + (set! syms (cons (car l) syms)) + (rem (cdr l))) + ((car l) (cons (car l) (rem (cdr l)))) + (else (rem (cdr l)))))) + (cond ((file-exists? (car libs)) (display " " op) - (write (cons feature (cons 'compiled (cons ofile libs))) op) + (write + (cons feature (cons 'compiled (append syms libs))) + op) (newline op) #t) (else #f))) @@ -74,95 +79,86 @@ (display* "(") (begin (cond ((add-link 'i/o-extensions - (in-vicinity (installation-vicinity) "ioext" - link:able-suffix) + (in-implementation-vicinity "ioext" link:able-suffix) (usr:lib "c")) (add-alias 'directory-for-each 'i/o-extensions) (add-alias 'line-i/o 'i/o-extensions) (add-alias 'pipe 'i/o-extensions))) (cond ((add-link 'rev2-procedures - (in-vicinity (installation-vicinity) "sc2" - link:able-suffix)) - (add-alias 'rev3-procedures 'rev2-procedures))) + (in-implementation-vicinity "sc2" + link:able-suffix)))) (cond ((or (add-link 'db - (in-vicinity wb:vicinity "db.so")) + (in-wb-vicinity "db.so")) (add-link 'db - (in-vicinity wb:vicinity "db" link:able-suffix) - (in-vicinity wb:vicinity "handle" link:able-suffix) - (in-vicinity wb:vicinity "blink" link:able-suffix) - (in-vicinity wb:vicinity "prev" link:able-suffix) - (in-vicinity wb:vicinity "ent" link:able-suffix) - (in-vicinity wb:vicinity "sys" link:able-suffix) - (in-vicinity wb:vicinity "del" link:able-suffix) - (in-vicinity wb:vicinity "stats" link:able-suffix) - (in-vicinity wb:vicinity "blkio" link:able-suffix) - (in-vicinity wb:vicinity "scan" link:able-suffix) + (in-wb-vicinity "db" link:able-suffix) + (in-wb-vicinity "handle" link:able-suffix) + (in-wb-vicinity "blink" link:able-suffix) + (in-wb-vicinity "prev" link:able-suffix) + (in-wb-vicinity "ent" link:able-suffix) + (in-wb-vicinity "sys" link:able-suffix) + (in-wb-vicinity "del" link:able-suffix) + (in-wb-vicinity "stats" link:able-suffix) + (in-wb-vicinity "blkio" link:able-suffix) + (in-wb-vicinity "scan" link:able-suffix) (usr:lib "c"))) (add-source 'wb-table - (in-vicinity wb:vicinity "wbtab")) + (in-wb-vicinity "wbtab")) (add-alias 'wb 'db))) + (cond ((add-link 'mysql + (in-implementation-vicinity "database" + link:able-suffix) + ;;(usr:lib "mysqlclient") ;? + ))) (cond ((add-link 'stringvector - (in-vicinity x-scm:vicinity "strvec" link:able-suffix)) - (add-source 'x11 (in-vicinity x-scm:vicinity "x11")) - (add-source 'xevent(in-vicinity x-scm:vicinity "xevent")) - (add-source 'xt (in-vicinity x-scm:vicinity "xt")) - (add-source 'xm (in-vicinity x-scm:vicinity "xm")) - (add-source 'xmsubs(in-vicinity x-scm:vicinity "xmsubs")) - (add-source 'xaw (in-vicinity x-scm:vicinity "xaw")) - (add-source 'xpm (in-vicinity x-scm:vicinity "xpm")))) + (in-xscm-vicinity "strvec" link:able-suffix)) + (add-source 'x11 (in-xscm-vicinity "x11")) + (add-source 'xevent(in-xscm-vicinity "xevent")) + (add-source 'xt (in-xscm-vicinity "xt")) + (add-source 'xm (in-xscm-vicinity "xm")) + (add-source 'xmsubs(in-xscm-vicinity "xmsubs")) + (add-source 'xaw (in-xscm-vicinity "xaw")) + (add-source 'xpm (in-xscm-vicinity "xpm")))) (add-link 'turtle-graphics - (in-vicinity (installation-vicinity) "turtlegr" - link:able-suffix) + (in-implementation-vicinity "turtlegr" link:able-suffix) (x:lib "X11") (usr:lib "m") (usr:lib "c")) (add-link 'Xlib - (in-vicinity (installation-vicinity) "x" - link:able-suffix) + (in-implementation-vicinity "x" link:able-suffix) (x:lib "X11") (usr:lib "c")) (add-link 'curses - (in-vicinity (installation-vicinity) "crs" - link:able-suffix) + (in-implementation-vicinity "crs" link:able-suffix) (usr:lib "ncurses") ;;(usr:lib "curses") ;;(usr:lib "termcap") (usr:lib "c")) (add-link 'edit-line - (in-vicinity (installation-vicinity) "edline" - link:able-suffix) + (in-implementation-vicinity "edline" link:able-suffix) (usr:lib "readline") (usr:lib "termcap") (usr:lib "c")) (add-link 'regex - (in-vicinity (installation-vicinity) "rgx" - link:able-suffix) + (in-implementation-vicinity "rgx" link:able-suffix) (usr:lib "c")) (add-link 'unix - (in-vicinity (installation-vicinity) "unix" - link:able-suffix) - (in-vicinity (installation-vicinity) "ioext" - link:able-suffix) + 'i/o-extensions + (in-implementation-vicinity "unix" link:able-suffix) (usr:lib "c")) (add-link 'posix - (in-vicinity (installation-vicinity) "posix" - link:able-suffix) + (in-implementation-vicinity "posix" link:able-suffix) (usr:lib "c")) (add-link 'socket - (in-vicinity (installation-vicinity) "socket" - link:able-suffix) + (in-implementation-vicinity "socket" link:able-suffix) (usr:lib "c")) (add-link 'record - (in-vicinity (installation-vicinity) "record" - link:able-suffix)) + (in-implementation-vicinity "record" link:able-suffix)) (add-link 'generalized-c-arguments - (in-vicinity (installation-vicinity) "gsubr" - link:able-suffix)) + (in-implementation-vicinity "gsubr" link:able-suffix)) (add-link 'array-for-each - (in-vicinity (installation-vicinity) "ramap" - link:able-suffix)) + (in-implementation-vicinity "ramap" link:able-suffix)) ) (display* ")") ) @@ -182,21 +178,19 @@ (begin ;; Simple associations -- OK for all modes of dynamic-linking (display* "(") - (add-alias 'hobbit (in-vicinity (installation-vicinity) "hobbit")) - (add-alias 'scmhob (in-vicinity (installation-vicinity) "scmhob")) - (add-alias 'regex-case - (in-vicinity (installation-vicinity) "rgxcase")) - (add-alias 'url-filename - (in-vicinity (installation-vicinity) "urlfile")) - (add-source 'disarm (in-vicinity - (installation-vicinity) + (add-alias '2rs 'r2rs) + (add-alias '3rs 'r3rs) + (add-alias '4rs 'r4rs) + (add-alias '5rs 'r5rs) + (add-alias 'hobbit (in-implementation-vicinity "hobbit")) + (add-alias 'scmhob (in-implementation-vicinity "scmhob")) + (add-alias 'regex-case (in-implementation-vicinity "rgxcase")) + (add-alias 'url-filename (in-implementation-vicinity "urlfile")) + (add-source 'disarm (in-implementation-vicinity (string-append "disarm" (scheme-file-suffix)))) - (add-source 'build (in-vicinity - (implementation-vicinity) - (string-append "build" (scheme-file-suffix)))) - - ;; (add-alias 'impl:callback '(identity)) - + (add-source 'build (in-implementation-vicinity "build")) + (add-source 'compile (in-implementation-vicinity + (string-append "compile" (scheme-file-suffix)))) (display* ")") ) @@ -205,7 +199,7 @@ (display* "#.(if (defined? renamed-identifier)") (display* " '(") (display " " op) - (add-source 'macro (in-vicinity (installation-vicinity) "Macro")) + (add-source 'macro (in-implementation-vicinity "Macro")) (display* " )") (display* " '())") ) @@ -4,11 +4,11 @@ # for alpha release, "b" for beta release, "c", and so on), and the # trailing number is the patchlevel. */ # /* This next line sets VERSION when included from the Makefile */ -VERSION=5d2 +VERSION=5d6 #endif #ifndef SCMVERSION -# define SCMVERSION "5d2" +# define SCMVERSION "5d6" #endif #ifdef nosve # define INIT_FILE_NAME "Init"SCMVERSION"_scm"; diff --git a/platform.txi b/platform.txi deleted file mode 100644 index bae415d..0000000 --- a/platform.txi +++ /dev/null @@ -1,43 +0,0 @@ -Table: platform -name processor operating-system compiler -#f processor-family operating-system #f -symbol processor-family operating-system symbol -symbol atom symbol symbol -================= ================= ================= ================= -*unknown* *unknown* unix cc -acorn-unixlib acorn *unknown* cc -aix powerpc aix cc -alpha alpha osf1 cc -alpha-elf alpha unix cc -alpha-linux alpha linux gcc -amiga-aztec m68000 amiga cc -amiga-dice-c m68000 amiga dcc -amiga-gcc m68000 amiga gcc -amiga-sas m68000 amiga lc -atari-st-gcc m68000 atari.st gcc -atari-st-turbo-c m68000 atari.st tcc -borland-c 8086 ms-dos bcc -cygwin32 i386 unix gcc -djgpp i386 ms-dos gcc -freebsd i386 unix cc -gcc *unknown* unix gcc -highc i386 ms-dos hc386 -hp-ux hp-risc hp-ux cc -irix mips irix gcc -linux i386 linux gcc -linux-aout i386 linux gcc -microsoft-c 8086 ms-dos cl -microsoft-c-nt i386 ms-dos cl -microsoft-quick-c 8086 ms-dos qcl -ms-dos 8086 ms-dos cc -os/2-cset i386 os/2 icc -os/2-emx i386 os/2 gcc -sunos sparc sunos cc -svr4 *unknown* unix cc -svr4-gcc-sun-ld sparc sunos gcc -turbo-c 8086 ms-dos tcc -unicos cray unicos cc -unix *unknown* unix cc -vms vax vms cc -vms-gcc vax vms gcc -watcom-9.0 i386 ms-dos wcc386p @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -60,11 +60,14 @@ # else # ifdef linux # include <unistd.h> +# else +# ifdef __OpenBSD__ +# include <unistd.h> +# endif # endif # endif #endif - /* Only the superuser can successfully execute this call */ static char s_chown[] = "chown"; SCM l_chown(path, owner, group) SCM path, owner, group; @@ -94,6 +97,7 @@ SCM l_pipe() FILE *f_rd, *f_wt; SCM p_rd, p_wt; NEWCELL(p_rd); NEWCELL(p_wt); + DEFER_INTS; SYSCALL(ret = pipe(fd);); if (ret) {ALLOW_INTS; return BOOL_F;} SYSCALL(f_rd = fdopen(fd[0], "r");); @@ -108,10 +112,8 @@ SCM l_pipe() close(fd[1]); wta(UNDEFINED, (char *)NALLOC, s_port_type); } - CAR(p_rd) = scm_port_entry(tc16_fport, mode_bits("r", (char *)0)); - CAR(p_wt) = scm_port_entry(tc16_fport, mode_bits("w", (char *)0)); - SETSTREAM(p_rd, f_rd); - SETSTREAM(p_wt, f_wt); + p_rd = scm_port_entry(f_rd, tc16_fport, mode_bits("r", (char *)0)); + p_wt = scm_port_entry(f_wt, tc16_fport, mode_bits("w", (char *)0)); ALLOW_INTS; return cons(p_rd, p_wt); } @@ -123,24 +125,18 @@ SCM open_pipe(pipestr, modes) FILE *f; register SCM z; ASSERT(NIMP(pipestr) && STRINGP(pipestr), pipestr, ARG1, s_op_pipe); - ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_op_pipe); + ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_op_pipe); NEWCELL(z); /* DEFER_INTS, SYSCALL, and ALLOW_INTS are probably paranoid here*/ DEFER_INTS; ignore_signals(); SCM_OPENCALL(f = popen(CHARS(pipestr), CHARS(modes))); unignore_signals(); - if (!f) { - ALLOW_INTS; - return BOOL_F; - } - else { - CAR(z) = scm_port_entry(tc16_pipe, - OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG)); - SETSTREAM(z, f); - } + z = f ? + scm_port_entry(f, tc16_pipe, + OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG)) : + BOOL_F; ALLOW_INTS; - SCM_PORTDATA(z) = pipestr; return z; } @@ -156,8 +152,9 @@ SCM scm_getgroups() strings are now checked for null termination during gc. The length needs not be exactly right */ grps = must_malloc_cell((0L + ngroups) * sizeof(gid_t), - MAKE_LENGTH(((0L + ngroups) * sizeof(gid_t))/sizeof(long), tc7_uvect), - scm_s_getgroups); + MAKE_LENGTH(((0L + ngroups) * sizeof(gid_t))/sizeof(long), + tc7_uvect), + scm_s_getgroups); ALLOW_INTS; { gid_t *groups = (gid_t *)CHARS(grps); @@ -261,6 +258,10 @@ SCM l_getppid() return MAKINUM(0L+getppid()); } +SCM scm_getlogin() +{ + return makfrom0str(getlogin()); +} SCM l_getuid() { return MAKINUM(0L+getuid()); @@ -350,6 +351,7 @@ static iproc subr0s[] = { {"pipe", l_pipe}, {scm_s_getgroups, scm_getgroups}, {"getppid", l_getppid}, + {"getlogin", scm_getlogin}, {"getuid", l_getuid}, {"getgid", l_getgid}, #ifndef LACK_E_IDs @@ -403,5 +405,8 @@ void init_posix() scm_ldstr("\n\ (define (open-input-pipe cmd) (open-pipe cmd \"r\"))\n\ (define (open-output-pipe cmd) (open-pipe cmd \"w\"))\n\ +(define getlogin\n\ + (let ((getlogin getlogin))\n\ + (lambda () (or (getlogin) (getenv \"USER\") (getenv \"LOGNAME\")))))\n\ "); } diff --git a/r4rstest.scm b/r4rstest.scm index bc3f2f7..3683f0d 100644 --- a/r4rstest.scm +++ b/r4rstest.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by the @@ -184,9 +184,11 @@ (test 34 'letrec x) (test 10 'letrec (letrec ((x 3)) (define x 10) x)) (test 34 'letrec x) +(define (s x) (if x (let () (set! s x) (set! x s)))) (SECTION 4 2 3) (define x 0) -(test 6 'begin (begin (set! x 5) (+ x 1))) +(test 6 'begin (begin (set! x (begin (begin 5))) + (begin ((begin +) (begin x) (begin (begin 1)))))) (SECTION 4 2 4) (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) (i 0 (+ i 1))) @@ -241,16 +243,31 @@ (define first car) (test 1 'define (first '(1 2))) (define old-+ +) -(define + (lambda (x y) (list y x))) -(test '(3 6) add3 6) +(begin (begin (begin) + (begin (begin (begin) (define + (lambda (x y) (list y x))) + (begin))) + (begin)) + (begin) + (begin (begin (begin) (test '(3 6) add3 6) + (begin)))) (set! + old-+) (test 9 add3 6) +(begin) +(begin (begin)) +(begin (begin (begin (begin)))) (SECTION 5 2 2) (test 45 'define - (let ((x 5)) - (define foo (lambda (y) (bar x y))) - (define bar (lambda (a b) (+ (* a b) a))) - (foo (+ x 3)))) + (let ((x 5)) + (begin (begin (begin) + (begin (begin (begin) (define foo (lambda (y) (bar x y))) + (begin))) + (begin)) + (begin) + (begin) + (begin (define bar (lambda (a b) (+ (* a b) a)))) + (begin)) + (begin) + (begin (foo (+ x 3))))) (define x 34) (define (foo) (define x 5) x) (test 5 foo) @@ -523,6 +540,8 @@ (test 1 remainder 13 -4) (test -1 modulo -13 -4) (test -1 remainder -13 -4) +(test 0 modulo 0 86400) +(test 0 modulo 0 -86400) (define (divtest n1 n2) (= n1 (+ (* n2 (quotient n1 n2)) (remainder n1 n2)))) @@ -551,7 +570,6 @@ (define f0.8 (string->number "0.8")) (define f1.0 (string->number "1.0")) (define wto write-test-obj) - (define dto display-test-obj) (define lto load-test-obj) (newline) (display ";testing inexact numbers; ") @@ -571,20 +589,21 @@ (test f4.0 round f4.5) (test 1 expt 0 0) (test 0 expt 0 1) + (test (atan 1) atan 1 1) (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. - (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) (test #t call-with-output-file "tmp3" (lambda (test-file) (write-char #\; test-file) - (display write-test-obj test-file) + (display #\; test-file) + (display ";" test-file) + (write write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (output-port? test-file))) (check-test-file "tmp3") (set! write-test-obj wto) - (set! display-test-obj dto) (set! load-test-obj lto) (let ((x (string->number "4195835.0")) (y (string->number "3145727.0"))) @@ -707,13 +726,29 @@ (test 0 modulo 2177452800 -86400) (test 0 modulo 2177452800 86400) (test 0 modulo -2177452800 -86400) + (test 0 modulo 0 -2177452800) (test #t 'remainder (tb 281474976710655325431 65535)) (test #t 'remainder (tb 281474976710655325430 65535)) + (SECTION 6 5 8) (test 281474976710655325431 string->number "281474976710655325431") (test "281474976710655325431" number->string 281474976710655325431) (report-errs)) +(define (test-numeric-predicates) + (let* ((big-ex (expt 2 90)) + (big-inex (exact->inexact big-ex))) + (newline) + (display ";testing bignum-inexact comparisons;") + (newline) + (SECTION 6 5 5) + (test #f = (+ big-ex 1) big-inex (- big-ex 1)) + (test #f = big-inex (+ big-ex 1) (- big-ex 1)) + (test #t < (- (inexact->exact big-inex) 1) + big-inex + (+ (inexact->exact big-inex) 1)))) + + (SECTION 6 5 9) (test "0" number->string 0) (test "100" number->string 100) @@ -734,6 +769,10 @@ (test #f string->number "3.3I") (test #f string->number "-") (test #f string->number "+") +(test #t 'string->number (or (not (string->number "80000000" 16)) + (positive? (string->number "80000000" 16)))) +(test #t 'string->number (or (not (string->number "-80000000" 16)) + (negative? (string->number "-80000000" 16)))) (SECTION 6 6) (test #t eqv? '#\ #\Space) @@ -980,6 +1019,9 @@ (test '(b e h) map cadr '((a b) (d e) (g h))) (test '(5 7 9) map + '(1 2 3) '(4 5 6)) +(test '(1 2 3) map + '(1 2 3)) +(test '(1 2 3) map * '(1 2 3)) +(test '(-1 -2 -3) map - '(1 2 3)) (test '#(0 1 4 9 16) 'for-each (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) @@ -1097,21 +1139,23 @@ (test #t eof-object? (read-char test-file)) (input-port? test-file)))) (test #\; read-char test-file) - (test display-test-obj read test-file) + (test #\; read-char test-file) + (test #\; read-char test-file) + (test write-test-obj read test-file) (test load-test-obj read test-file) (close-input-port test-file)) (SECTION 6 10 3) (define write-test-obj - '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) -(define display-test-obj - '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) + '(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) (define load-test-obj (list 'define 'foo (list 'quote write-test-obj))) (test #t call-with-output-file "tmp1" (lambda (test-file) (write-char #\; test-file) - (display write-test-obj test-file) + (display #\; test-file) + (display ";" test-file) + (write write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (output-port? test-file))) @@ -1119,7 +1163,9 @@ (define test-file (open-output-file "tmp2")) (write-char #\; test-file) -(display write-test-obj test-file) +(display #\; test-file) +(display ";" test-file) +(write write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (test #t output-port? test-file) @@ -1145,13 +1191,18 @@ (report-errs)) (report-errs) -(cond ((and (string->number "0.0") (inexact? (string->number "0.0"))) - (test-inexact) - (test-inexact-printing))) +(let ((have-inexacts? + (and (string->number "0.0") (inexact? (string->number "0.0")))) + (have-bignums? + (let ((n (string->number "281474976710655325431"))) + (and n (exact? n))))) + (cond (have-inexacts? + (test-inexact) + (test-inexact-printing))) + (if have-bignums? (test-bignum)) + (if (and have-inexacts? have-bignums?) + (test-numeric-predicates))) -(let ((n (string->number "281474976710655325431"))) - (if (and n (exact? n)) - (test-bignum))) (newline) (display "To fully test continuations, Scheme 4, and DELAY/FORCE do:") (newline) @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -115,7 +115,7 @@ int ra_matchp(ra0, ras) ra1 = CAR(ras); switch (IMP(ra1) ? 0 : TYP7(ra1)) { default: scalar: - CAR(ras) = sc2array(ra1,ra0,EOL); break; + CAR(ras) = sc2array(ra1, ra0, EOL); break; case tc7_vector: case tcs_uves: if (1 != ndim) return 0; @@ -304,11 +304,11 @@ static int racp(src, dst) for (; n-- > 0; i_s += inc_s, i_d += inc_d) aset(dst, cvref(src, i_s, UNDEFINED), MAKINUM(i_d)); break; - case tc7_string: if (tc7_string != TYP7(dst)) goto gencase; + case tc7_string: if (tc7_string != TYP7(src)) goto gencase; for (; n-- > 0; i_s += inc_s, i_d += inc_d) CHARS(dst)[i_d] = CHARS(src)[i_s]; break; - case tc7_bvect: if (tc7_bvect != TYP7(dst)) goto gencase; + case tc7_bvect: if (tc7_bvect != TYP7(src)) goto gencase; if (1==inc_d && 1==inc_s && i_s%LONG_BIT==i_d%LONG_BIT && n>=LONG_BIT) { long *sv = (long *)VELTS(src); long *dv = (long *)VELTS(dst); @@ -502,7 +502,7 @@ SCM ura_write(ra, port) SCM ra, port; { if (NIMP(ra) && ARRAYP(ra)) - return uve_write(ra2contig(ra,1), port); + return uve_write(ra2contig(ra, 1), port); else return uve_write(ra, port); } @@ -1081,7 +1081,7 @@ static int ramap(ra0, proc, ras) if (argc >= 5) { heap_ve = make_vector(MAKINUM(2*argc), BOOL_F); rav = VELTS(heap_ve); - argv = &(rav[n]); + argv = &(rav[argc]); } for (k = 0; k < argc; k++) { rav[k] = CAR(ras); @@ -1276,23 +1276,22 @@ SCM array_map(ra0, proc, lra) SCM ra0, proc, lra; { long narg = ilength(lra); - ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_map); tail: +#ifndef RECKLESS + scm_arity_check(proc, narg, s_array_map); +#endif switch TYP7(proc) { - wna: wta(UNDEFINED, (char *)WNA, s_array_map); default: gencase: - ASRTGO(scm_arity_check(proc, narg, s_array_map), wna); ramapc(ramap, proc, ra0, lra, s_array_map); return UNSPECIFIED; - case tc7_subr_1: ASRTGO(1==narg, wna); + case tc7_subr_1: ramapc(ramap_1, proc, ra0, lra, s_array_map); return UNSPECIFIED; - case tc7_subr_2: ASRTGO(2==narg, wna); - case tc7_subr_2o: ASRTGO(2>=narg, wna); + case tc7_subr_2: + case tc7_subr_2o: ramapc(ramap_2o, proc, ra0, lra, s_array_map); return UNSPECIFIED; case tc7_cxr: if (! SUBRF(proc)) goto gencase; - ASRTGO(1==narg, wna); ramapc(ramap_cxr, proc, ra0, lra, s_array_map); return UNSPECIFIED; case tc7_rpsubr: { @@ -1361,8 +1360,9 @@ SCM array_map(ra0, proc, lra) #if 1 /* def CCLO */ case tc7_specfun: if (tc16_cclo==TYP16(proc)) { - lra = cons(sc2array(proc,ra0,EOL), lra); + lra = cons(sc2array(proc, ra0, EOL), lra); proc = CCLO_SUBR(proc); + narg++; goto tail; } goto gencase; @@ -1381,7 +1381,7 @@ static int rafe(ra0, proc, ras) if (argc >= 5) { heap_ve = make_vector(MAKINUM(2*argc), BOOL_F); rav = VELTS(heap_ve); - argv = &(rav[n]); + argv = &(rav[argc]); } rav[0] = ra0; for (k = 1; k < argc; k++) { @@ -1402,7 +1402,6 @@ SCM array_for_each(proc, ra0, lra) SCM proc, ra0, lra; { long narg = ilength(lra) + 1; - ASSERT(BOOL_T==procedurep(proc), proc, ARG1, s_array_for_each); tail: #ifndef RECKLESS scm_arity_check(proc, narg, s_array_for_each); @@ -1435,7 +1434,6 @@ SCM array_imap(ra, proc) long *indv = &auto_indv[0]; sizet i; ASSERT(NIMP(ra), ra, ARG1, s_array_imap); - ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_imap); i = INUM(array_rank(ra)); #ifndef RECKLESS scm_arity_check(proc, i+0L, s_array_imap); @@ -1676,7 +1674,7 @@ void init_ramap() add_feature(s_array_for_each); scm_ldstr("\n\ (define (array-indexes ra)\n\ - (let ((ra0 (apply make-array '() (array-shape ra))))\n\ + (let ((ra0 (apply create-array '#() (array-shape ra))))\n\ (array-index-map! ra0 list)\n\ ra0))\n\ "); @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -130,18 +130,19 @@ SCM rec_constr(rtd, flds) while (i--) REC_IND_SET(indices, i, i+1); } else { - ASSERT(NIMP(flds) && CONSP(flds), flds, ARG2, s_rec_constr); - indices = MAKE_REC_INDS(ilength(flds)); + i = ilength(flds); + ASSERT(i>=0, flds, ARG2, s_rec_constr); + indices = MAKE_REC_INDS(i); for(i = 0; NIMP(flds); i++, flds = CDR(flds)) { fld = CAR(flds); ASSERT(NIMP(fld) && SYMBOLP(fld), fld, ARG2, s_rec_constr); flst = RTD_FIELDS(rtd); for (j = 0; ; j++, flst = CDR(flst)) { + ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr); if (fld==CAR(flst)) { REC_IND_SET(indices, i, j+1); break; } - ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr); } } } @@ -165,7 +166,7 @@ static void rec_error(arg, pos, what, rtd, i) } else mesg = st_append(cons2(mesg, recname, EOL)); - everr(UNDEFINED, EOL, arg, pos, CHARS(mesg)); + wta(arg, pos, CHARS(mesg)); } #endif static char s_rec_constr1[] = "record constructor: "; @@ -259,9 +260,9 @@ SCM makrectyp(name, fields) { SCM n, argv[2]; #ifndef RECKLESS - if(ilength(fields) < 0) + if (ilength(fields) < 0) errout: wta(fields, (char *)ARG2, s_makrectyp); - for (n=fields; NIMP(n); n = CDR(n)) + for (n = fields; NIMP(n); n = CDR(n)) if (!SYMBOLP(CAR(n))) goto errout; #endif argv[0] = name; @@ -274,7 +275,7 @@ SCM rec_prinset(rtd, printer) SCM rtd, printer; { ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_prinset); - ASSERT(BOOL_F==printer || scm_arity_check(printer, 2L, (char *)0), + ASSERT(BOOL_F==printer || scm_arity_check(printer, 3L, (char *)0), printer, ARG2, s_rec_prinset); RTD_PRINTER(rtd) = printer; return UNSPECIFIED; @@ -291,7 +292,7 @@ static SCM markrec(ptr) static sizet freerec(ptr) CELLPTR ptr; { - must_free(CHARS(ptr), sizeof(SCM)*NUMDIGS(ptr)); + must_free(CHARS((SCM)ptr), sizeof(SCM)*NUMDIGS((SCM)ptr)); return 0; } static int recprin1(exp, port, writing) @@ -299,16 +300,30 @@ static int recprin1(exp, port, writing) int writing; { SCM names, printer = RTD_PRINTER(REC_RTD(exp)); + SCM argv[3]; sizet i; if NIMP(printer) { - SCM argv[2]; argv[0] = exp; argv[1] = port; - return scm_cvapply(printer, 2L, argv); + argv[2] = writing ? BOOL_T : BOOL_F; + /* A writing value of 2 means we are printing an error message. + An error in a record printer at this time will result in a + fatal recursive error. */ + if (2 != writing) { + if (NFALSEP(scm_cvapply(printer, 3L, argv))) + return 1; + } + else { + lputs("\n; Ignoring record-printer: ", cur_errp); + } } names = RTD_FIELDS(REC_RTD(exp)); lputs("#s(", port); iprin1(RTD_NAME(REC_RTD(exp)), port, 0); + if (writing) { + lputc(':', port); + intprint(((long)REC_RTD(exp))>>1, 16, port); + } for (i = 1; i < NUMDIGS(exp); i++) { lputc(' ', port); iprin1(CAR(names), port, 0); @@ -329,6 +344,24 @@ static int recprin1(exp, port, writing) */ return 1; } + +static SCM f_rtdprin1; +SCM rec_rtdprin1(rtd, port, writing_p) + SCM rtd, port, writing_p; +{ + lputs("#s(record-type ", port); + iprin1(RTD_NAME(rtd), port, 0); + lputc(':', port); + intprint(((long)rtd)>>1, 16, port); + lputs(" fields ", port); + iprin1(RTD_FIELDS(rtd), port, 0); + if (NIMP(RTD_PRINTER(rtd))) + lputs(" P)", port); + else + lputc(')', port); + return BOOL_T; +} + SCM recequal(rec0, rec1) SCM rec0, rec1; { @@ -360,13 +393,14 @@ void init_record() SCM the_rtd, rtd_name = makfrom0str("record-type"); SCM rtd_fields = cons2(i_name, i_fields, cons(i_printer, EOL)); tc16_record = newsmob(&recsmob); + f_rtdprin1 = make_subr(" rtdprin1", tc7_subr_3, rec_rtdprin1); DEFER_INTS; the_rtd = must_malloc_cell(4L * sizeof(SCM), MAKE_NUMDIGS(4L, tc16_record), s_record); REC_RTD(the_rtd) = the_rtd; RTD_NAME(the_rtd) = rtd_name; RTD_FIELDS(the_rtd) = rtd_fields; - RTD_PRINTER(the_rtd) = BOOL_F; + RTD_PRINTER(the_rtd) = f_rtdprin1; ALLOW_INTS; the_rtd_rtd = the_rtd; /* Protected by make-record-type */ f_rec_pred1 = make_subr(" record-predicate-procedure", tc7_subr_2, rec_pred1); @@ -1,4 +1,4 @@ -/* Copyright (C) 1990-1999 Free Software Foundation, Inc. +/* Copyright (C) 1990-2002 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -53,6 +53,15 @@ void scm_fill_freelist P((void)); # include <sys/types.h> #endif +#ifdef __OpenBSD__ +# include <ctype.h> +# include <unistd.h> +#endif + +#ifdef PLAN9 +# include <ctype.h> +#endif + #ifdef ARM_ULIB # include <termio.h> int set_erase() @@ -62,7 +71,7 @@ int set_erase() ioctl(0, TCGETA, &tin); tin.c_cc[VERASE] = '\010'; - ioctl(0, TCSETA,&tin); + ioctl(0, TCSETA, &tin); return(0); } #endif @@ -122,8 +131,11 @@ char *isymnames[] = { /* NUM_ISPCSYMS ISPCSYMS here */ "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda", "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!", - "#@define", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay", - "#@quasiquote", "#@unquote", "#@unquote-splicing", "#@else", "#@=>", + "#@funcall", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay", + "#@quasiquote", "#@eval-for-apply", "#@let-syntax", "#@acro-call", + "#<line>", "#@define", + "#@unquote", "#@unquote-splicing", "#@else", "#@=>", "#@values-token", + "#@keyword", /* user visible ISYMS */ /* other keywords */ /* Flags */ @@ -138,9 +150,13 @@ static char s_freshline[] = "freshline"; static char s_eofin[] = "end of file in "; static char s_unknown_sharp[] = "unknown # object"; -static SCM lreadr P((SCM tok_buf, SCM port)); -static SCM lreadparen P((SCM tok_buf, SCM port, char *name)); +static SCM lread1 P((SCM port, int nump, char *what)); +static SCM lreadr P((SCM tok_buf, SCM port, int nump)); +static SCM lreadpr P((SCM tok_buf, SCM port, int nump)); +static SCM lreadparen P((SCM tok_buf, SCM port, int nump, char *name)); +static SCM lread_rec P((SCM tok_buf, SCM port)); static sizet read_token P((int ic, SCM tok_buf, SCM port)); +static void err_head P((char *str)); void intprint(n, radix, port) long n; @@ -196,7 +212,7 @@ void iprlist(hdr, exp, tlr, port, writing) void iprin1(exp, port, writing) SCM exp; SCM port; -int writing; + int writing; { register long i; taloop: @@ -219,6 +235,11 @@ taloop: intprint(i, -8, port); else lputc((int)i, port); } + else if (SCM_LINUMP(exp)) { + lputs("#<line ", port); + intprint(SCM_LINUM(exp), -10, port); + lputc('>', port); + } else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *)))) lputs(ISYMCHARS(exp), port); else if ILOCP(exp) { @@ -247,14 +268,29 @@ taloop: break; } switch TYP7(exp) { + case (127 & IM_LET): + if (CAR(exp) != IM_LET) { + lputs("(#@call ", port); + exp = CDR(exp); + iprin1(CAR(exp), port, writing); + iprlist(" ", CAR(CDR(exp)), ')', port, writing); + break; + } + /* else fall through */ + case (127 & IM_AND): case (127 & IM_BEGIN): case (127 & IM_CASE): + case (127 & IM_COND): case (127 & IM_DO): case (127 & IM_IF): + case (127 & IM_LAMBDA): case (127 & IM_LETSTAR): + case (127 & IM_LETREC): case (127 & IM_OR): case (127 & IM_QUOTE): + case (127 & IM_SET): case (127 & IM_FUNCALL): + case tcs_cons_inum: + case tcs_cons_iloc: + case tcs_cons_chflag: case tcs_cons_gloc: - case tcs_cons_imcar: case tcs_cons_nimcar: iprlist("(", exp, ')', port, writing); break; case tcs_closures: - exp = CODE(exp); - iprlist("#<CLOSURE ", exp, '>', port, writing); + scm_princlosure(exp, port, writing); break; case tc7_string: if (writing) { @@ -363,7 +399,9 @@ static int input_waiting(f) # else # ifndef macintosh # ifndef ARM_ULIB -# include <sys/ioctl.h> +# ifndef PLAN9 +# include <sys/ioctl.h> +# endif # endif # endif # endif @@ -408,7 +446,7 @@ SCM char_readyp(port) SCM port; { if UNBNDP(port) port = cur_inp; - else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp); + ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp); if (CRDYP(port) || !(BUF0 & SCM_PORTFLAGS(port))) return BOOL_T; return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F; } @@ -417,7 +455,11 @@ SCM char_readyp(port) # include <pc.h> #endif #ifndef HAVE_SELECT -# include <time.h> +# ifdef PLAN9 +# define kbhit() 0 +# else +# include <time.h> +# endif #endif #ifdef __STDC__ # define timet time_t @@ -520,11 +562,46 @@ SCM eof_objectp(x) return (EOF_VAL==x) ? BOOL_T : BOOL_F; } +static SCM *loc_broken_pipe = 0; +/* returning non-zero means try again. */ +int scm_io_error(port, what) + SCM port; + char *what; +{ +#ifdef HAVE_PIPE +# ifdef EPIPE + if (EPIPE==errno) { + if (verbose > 2) { + err_head("WARNING"); + lputs(";;", cur_errp); + lputs(what, cur_errp); + lputs(": closing pipe ", cur_errp); + iprin1(port, cur_errp, 1); + newline(cur_errp); + } + close_port(port); + if (*loc_broken_pipe && NIMP(*loc_broken_pipe)) + apply(*loc_broken_pipe, port, listofnull); + return 0; + } +# endif +#endif + if (SCM_INTERRUPTED(errno)) { + errno = 0; + return !0; + } + wta(port, what, "Input/Output"); + return 0; /* squelch warning */ +} + +static char s_fflush[] = "fflush"; void lfflush(port) /* internal SCM call */ SCM port; { sizet i = PTOBNUM(port); - (ptobs[i].fflush)(STREAM(port)); + while ((ptobs[i].fflush)(STREAM(port)) && + scm_io_error(port, s_fflush)) + ; } static char s_flush[] = "force-output"; SCM lflush(port) /* user accessible as force-output */ @@ -534,7 +611,9 @@ SCM lflush(port) /* user accessible as force-output */ else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush); { sizet i = PTOBNUM(port); - SYSCALL((ptobs[i].fflush)(STREAM(port));); + while ((ptobs[i].fflush)(STREAM(port)) && + scm_io_error(port, s_fflush)) + ; return UNSPECIFIED; } } @@ -545,11 +624,6 @@ SCM lwrite(obj, port) if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write); iprin1(obj, port, 1); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); -# endif -#endif return UNSPECIFIED; } SCM display(obj, port) @@ -558,11 +632,6 @@ SCM display(obj, port) if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display); iprin1(obj, port, 0); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); -# endif -#endif return UNSPECIFIED; } SCM newline(port) @@ -571,13 +640,7 @@ SCM newline(port) if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline); lputc('\n', port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); - else -# endif -#endif - if (port==cur_outp) lfflush(port); + if (port==cur_outp) lfflush(port); return UNSPECIFIED; } SCM write_char(chr, port) @@ -587,11 +650,6 @@ SCM write_char(chr, port) else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char); ASSERT(ICHRP(chr), chr, ARG1, s_write_char); lputc((int)ICHR(chr), port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); -# endif -#endif return UNSPECIFIED; } SCM scm_freshline(port) @@ -601,13 +659,7 @@ SCM scm_freshline(port) else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline); if (INUM0==scm_port_col(port)) return UNSPECIFIED; lputc('\n', port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); - else -# endif -#endif - if (port==cur_outp) lfflush(port); + if (port==cur_outp) lfflush(port); return UNSPECIFIED; } @@ -616,13 +668,15 @@ void lputc(c, port) SCM port; { sizet i = PTOBNUM(port); - SYSCALL((ptobs[i].fputc)(c, STREAM(port));); + while (EOF==(ptobs[i].fputc)(c, STREAM(port)) && + scm_io_error(port, "fputc")) + ; if (CRDY & CAR(port)) { i = SCM_PORTNUM(port); switch (c) { case LINE_INCREMENTORS: scm_port_table[i].line++; - scm_port_table[i].col = 0; + scm_port_table[i].col = 1; break; default: scm_port_table[i].col++; @@ -635,7 +689,9 @@ void lputs(s, port) { sizet i = PTOBNUM(port); ASSERT(s, INUM0, ARG1, "lputs"); - SYSCALL((ptobs[i].fputs)(s, STREAM(port));); + while (EOF==(ptobs[i].fputs)(s, STREAM(port)) && + scm_io_error(port, "fputs")) + ; if (CRDY & CAR(port)) { sizet j; i = SCM_PORTNUM(port); @@ -643,7 +699,7 @@ void lputs(s, port) switch (s[j]) { case LINE_INCREMENTORS: scm_port_table[i].line++; - scm_port_table[i].col = 0; + scm_port_table[i].col = 1; break; default: scm_port_table[i].col++; @@ -658,8 +714,9 @@ sizet lfwrite(ptr, size, nitems, port) SCM port; { sizet ret, i = PTOBNUM(port); - SYSCALL(ret = (ptobs[i].fwrite) - (ptr, size, nitems, STREAM(port));); + do { + ret = (ptobs[i].fwrite)(ptr, size, nitems, STREAM(port)); + } while(nitems != ret && scm_io_error(port, "fwrite")); if (CRDY & CAR(port)) { sizet j; i = SCM_PORTNUM(port); @@ -667,7 +724,7 @@ sizet lfwrite(ptr, size, nitems, port) switch (ptr[j]) { case LINE_INCREMENTORS: scm_port_table[i].line++; - scm_port_table[i].col = 0; + scm_port_table[i].col = 1; break; default: scm_port_table[i].col++; @@ -682,7 +739,7 @@ int lgetc(port) { FILE *f; int c; - sizet i, j; + int i, j = -1; if (CRDY & CAR(port)) { j = SCM_PORTNUM(port); c = scm_port_table[j].unread; @@ -699,12 +756,13 @@ int lgetc(port) #else SYSCALL(c = (ptobs[i].fgetc)(f);); #endif - if (CRDY & CAR(port)) { /* CRDY overloaded !!*/ + if (j > -1) { + /* This means that CRDY is set, note that CRDY is overloaded */ switch (c) { case LINE_INCREMENTORS: scm_port_table[j].line++; scm_port_table[j].colprev = scm_port_table[j].col; - scm_port_table[j].col = 0; + scm_port_table[j].col = 1; break; default: scm_port_table[j].col++; @@ -716,9 +774,14 @@ void lungetc(c, port) int c; SCM port; { + int i = PTOBNUM(port); /* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/ - scm_port_table[SCM_PORTNUM(port)].unread = c; - CAR(port) |= CRDY; + if (ptobs[i].ungetc) + (ptobs[i].ungetc)(c, port); + else { + scm_port_table[SCM_PORTNUM(port)].unread = c; + CAR(port) |= CRDY; + } } SCM scm_read_char(port) @@ -726,7 +789,7 @@ SCM scm_read_char(port) { int c; if UNBNDP(port) port = cur_inp; - else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); + ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); c = lgetc(port); if (EOF==c) return EOF_VAL; return MAKICHR(c); @@ -772,26 +835,36 @@ static int flush_ws(port) SCM lread(port) SCM port; { + return lread1(port, 0, s_read); +} +static SCM lread1(port, nump, what) + SCM port; + int nump; + char *what; +{ int c; SCM tok_buf; if UNBNDP(port) port = cur_inp; - else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read); + ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, what); do { c = flush_ws(port); if (EOF==c) return EOF_VAL; lungetc(c, port); tok_buf = makstr(30L); - } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port))); + } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port, nump))); return tok_buf; } static SCM *loc_readsharp = 0, *loc_readsharpc = 0; -static SCM lreadpr(tok_buf, port) +static SCM lreadpr(tok_buf, port, nump) SCM tok_buf; SCM port; + int nump; { int c; sizet j; SCM p; + if (2==nump) + return lread_rec(tok_buf, port); tryagain: c = flush_ws(port); switch (c) { @@ -800,13 +873,15 @@ tryagain: case '[': #endif case '(': - return lreadparen(tok_buf, port, s_list); + return lreadparen(tok_buf, port, nump, s_list); #ifdef BRACKETS_AS_PARENS case ']': #endif case ')': return UNDEFINED; /* goto tryagain; */ - case '\'': return cons2(i_quote, lreadr(tok_buf, port), EOL); - case '`': return cons2(i_quasiquote, lreadr(tok_buf, port), EOL); + case '\'': return cons2(i_quote, + lreadr(tok_buf, port, nump), EOL); + case '`': return cons2(i_quasiquote, + lreadr(tok_buf, port, nump), EOL); case ',': c = lgetc(port); if ('@'==c) p = i_uq_splicing; @@ -814,7 +889,7 @@ tryagain: lungetc(c, port); p = i_unquote; } - return cons2(p, lreadr(tok_buf, port), EOL); + return cons2(p, lreadr(tok_buf, port, nump), EOL); case '#': c = lgetc(port); switch (c) { @@ -822,7 +897,7 @@ tryagain: case '[': #endif case '(': - p = lreadparen(tok_buf, port, s_vector); + p = lreadparen(tok_buf, port, nump, s_vector); return NULLP(p) ? nullvect : vector(p); case 't': case 'T': return BOOL_T; case 'f': case 'F': return BOOL_F; @@ -928,18 +1003,42 @@ tok: return CAR(p); } } -static SCM lreadr(tok_buf, port) +static SCM lreadr(tok_buf, port, nump) SCM tok_buf; SCM port; + int nump; { - SCM ans = lreadpr(tok_buf, port); + SCM ans = lreadpr(tok_buf, port, nump); switch (ans) { case UNDEFINED: - scm_warn("unexpected \")\"", ""); - return lreadpr(tok_buf, port); + scm_warn("unexpected \")\"", "", port); + return lreadpr(tok_buf, port, nump); } return ans; } +static SCM lread_rec(tok_buf, port) + SCM tok_buf; + SCM port; +{ + SCM line, form; + int c = flush_ws(port); + switch(c) { + default: + lungetc(c, port); + line = scm_port_line(port); + form = lreadpr(tok_buf, port, 1); + if (NFALSEP(line) && NIMP(form) && + (CONSP(form) || VECTORP(form))) { + return cons(SCM_MAKE_LINUM(INUM(line)), form); + } + return form; +#ifdef BRACKETS_AS_PARENS + case ']': +#endif + case ')': return UNDEFINED; + case EOF: return EOF_VAL; + } +} #ifdef _UNICOS _Pragma("noopt"); /* # pragma _CRI noopt */ @@ -977,25 +1076,26 @@ static sizet read_token(ic, tok_buf, port) _Pragma("opt"); /* # pragma _CRI opt */ #endif -static SCM lreadparen(tok_buf, port, name) +static SCM lreadparen(tok_buf, port, nump, name) SCM tok_buf; SCM port; + int nump; char *name; { - SCM lst, fst, tmp = lreadpr(tok_buf, port); + SCM lst, fst, tmp = lreadpr(tok_buf, port, nump ? 2 : 0); if (UNDEFINED==tmp) return EOL; if (i_dot==tmp) { - fst = lreadr(tok_buf, port); + fst = lreadr(tok_buf, port, nump ? 1 : 0); closeit: - tmp = lreadpr(tok_buf, port); + tmp = lreadpr(tok_buf, port, 0); if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name); return fst; } fst = lst = cons(tmp, EOL); - while (UNDEFINED != (tmp = lreadpr(tok_buf, port))) { + while (UNDEFINED != (tmp = lreadpr(tok_buf, port, nump ? 2 : 0))) { if (EOF_VAL==tmp) wta(lst, s_eofin, s_list); if (i_dot==tmp) { - CDR(lst) = lreadr(tok_buf, port); + CDR(lst) = lreadr(tok_buf, port, nump ? 1 : 0); goto closeit; } lst = (CDR(lst) = cons(tmp, EOL)); @@ -1006,6 +1106,18 @@ static SCM lreadparen(tok_buf, port, name) /* These procedures implement synchronization primitives. Processors with an atomic test-and-set instruction can use it here (and not DEFER_INTS). */ +char s_swapcar[] = "swap-car!"; +SCM swapcar(pair, value) + SCM pair, value; +{ + SCM ret; + ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_swapcar); + DEFER_INTS; + ret = CAR(pair); + CAR(pair) = value; + ALLOW_INTS; + return ret; +} char s_tryarb[] = "try-arbiter"; char s_relarb[] = "release-arbiter"; long tc16_arbiter; @@ -1074,16 +1186,17 @@ struct errdesc errmsgs[] = { void (* deferred_proc) P((void)) = 0; char *errjmp_bad = "init"; int ints_disabled = 1; -static int errjmp_recursive = 0; unsigned long SIG_deferred = 0; -SCM err_exp, err_env; -char *err_pos, *err_s_subr; -cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL}; -cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL}; -SCM *loc_errobj = (SCM *)&tmp_errobj; -SCM *loc_loadpath = (SCM *)&tmp_loadpath; int scm_verbose = 1; /* Low so that monitor info won't be */ /* printed while in init_storage. (BOOM) */ +static int errjmp_recursive = 0; +static int errobj_codep; +static SCM err_exp, err_env; +static char *err_pos, *err_s_subr; +static cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL}; +static cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL}; +SCM *loc_errobj = (SCM *)&tmp_errobj; +SCM *loc_loadpath = (SCM *)&tmp_loadpath; long cells_allocated = 0, lcells_allocated = 0, mallocated = 0, lmallocated = 0, rt = 0, gc_rt, gc_time_taken; @@ -1113,6 +1226,7 @@ int handle_it(i) if NIMP(proc) { /* Save environment stack, in case it moves when applying proc. Do an ecache gc to protect contents of stack. */ + SCM estk, *estk_ptr, env, env_tmp; DEFER_INTS; #ifndef NO_ENV_CACHE @@ -1142,23 +1256,35 @@ int handle_it(i) } static char s_eval_string[] = "eval-string"; static char s_load_string[] = "load-string"; +static SCM i_eval_string = 0; SCM scm_eval_string(str) SCM str; { + SCM env = EOL; +#ifdef SCM_ENV_FILENAME + if (i_eval_string) + env = scm_env_addprop(SCM_ENV_FILENAME, i_eval_string, env); +#endif str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string); str = lread(str); - return EVAL(str, (SCM)EOL); + return EVAL(str, env, EOL); } +static SCM i_load_string = 0; SCM scm_load_string(str) SCM str; { + SCM env = EOL; +#ifdef SCM_ENV_FILENAME + if (i_load_string) + env = scm_env_addprop(SCM_ENV_FILENAME, i_load_string, env); +#endif ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, s_load_string); str = mkstrport(INUM0, str, OPN | RDNG, s_load_string); while(1) { SCM form = lread(str); if (EOF_VAL==form) break; - SIDEVAL(form, EOL); + SIDEVAL(form, env, EOL); } return BOOL_T; } @@ -1191,10 +1317,10 @@ SCM scm_top_level(initpath, toplvl_fun) SCM proc = CDR(intern(name, (sizet)strlen(name))); if NIMP(proc) apply(proc, EOL, EOL); }} - if ((i = errmsgs[i-WNA].parent_err)) goto drloop; + i = errmsgs[i-WNA].parent_err; + if (i) goto drloop; case 1: /* from everr() */ def_err_response(); - dowinds(EOL); goto reset_toplvl; case 0: exitval = MAKINUM(EXIT_SUCCESS); @@ -1205,6 +1331,7 @@ SCM scm_top_level(initpath, toplvl_fun) SIG_deferred = 0; deferred_proc = 0; ints_disabled = 0; + scm_init_INITS(); if (dumped) { lcells_allocated = cells_allocated; lmallocated = mallocated; @@ -1224,13 +1351,13 @@ SCM scm_top_level(initpath, toplvl_fun) } case -2: /* abrt */ reset_toplvl: - dowinds(EOL); ints_disabled = 1; errjmp_bad = (char *)0; errjmp_recursive = 0; lflush(sys_errp); SIG_deferred = 0; deferred_proc = 0; + gc_hook_active = 0; scm_estk_reset(0); /* Closing the loading file turned out to be a bad idea. */ @@ -1249,12 +1376,12 @@ SCM scm_top_level(initpath, toplvl_fun) *loc_loadpath = BOOL_F; loadports = EOL; ints_disabled = 0; + dowinds(EOL); ret = toplvl_fun(); /* typically repl() */ if INUMP(ret) exitval = ret; err_pos = (char *)EXIT; i = EXIT; goto drloop; /* encountered EOF on stdin */ - def_err_response(); case -1: /* quit */ dowinds(EOL); if (MAKINUM(EXIT_SUCCESS) != exitval) { @@ -1301,6 +1428,7 @@ SCM scm_port_line(port) lnum = scm_port_table[SCM_PORTNUM(port)].line; switch (CGETUN(port)) { default: + case EOF: /* no ungetted char */ break; case LINE_INCREMENTORS: lnum--; @@ -1312,7 +1440,7 @@ static char s_port_col[] = "port-column"; SCM scm_port_col(port) SCM port; { - short col; + long col; ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_col); if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F; col = scm_port_table[SCM_PORTNUM(port)].col; @@ -1320,6 +1448,8 @@ SCM scm_port_col(port) default: col--; break; + case EOF: /* no ungetted char */ + break; case LINE_INCREMENTORS: col = scm_port_table[SCM_PORTNUM(port)].colprev; break; @@ -1344,15 +1474,13 @@ SCM prog_args() } extern char s_heap[]; -extern sizet hplim_ind; -extern CELLPTR *hplims; void growth_mon(obj, size, units, grewp) char *obj; long size; char *units; int grewp; { - if (verbose>2) + if (verbose > 2) { lputs((grewp ? "; grew " : "; shrank "), sys_errp); lputs(obj, sys_errp); @@ -1360,18 +1488,18 @@ void growth_mon(obj, size, units, grewp) intprint(size, -10, sys_errp); lputc(' ', sys_errp); lputs(units, sys_errp); - if ((verbose>4) && (obj==s_heap)) heap_report(); - lputs("\n", sys_errp); + if ((verbose > 4) && (obj==s_heap)) heap_report(); + lputs("\n; ", sys_errp); } } void gc_start(what) char *what; { - if (verbose>3 && FPORTP(cur_errp)) { + if (verbose > 4) { lputs(";GC(", sys_errp); lputs(what, sys_errp); - lputs(")", sys_errp); + lputs(") ", sys_errp); } scm_gcs++; gc_rt = INUM(my_time()); @@ -1384,10 +1512,9 @@ void gc_end() { gc_rt = INUM(my_time()) - gc_rt; gc_time_taken = gc_time_taken + gc_rt; - if (verbose>3) { - if (!FPORTP(cur_errp)) lputs(";GC ", sys_errp); + if (verbose > 4) { intprint(time_in_msec(gc_rt), -10, sys_errp); - lputs(" cpu mSec, ", sys_errp); + lputs(".ms cpu, ", sys_errp); intprint(gc_cells_collected, -10, sys_errp); lputs(" cells, ", sys_errp); intprint(gc_malloc_collected, -10, sys_errp); @@ -1410,21 +1537,21 @@ void scm_egc_end() } void repl_report() { - if (verbose>1) { + if (verbose > 2) { lfflush(cur_outp); lputs(";Evaluation took ", cur_errp); intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp); - lputs(" mSec (", cur_errp); + lputs(".ms (", cur_errp); intprint(time_in_msec(gc_time_taken), -10, cur_errp); - lputs(" in gc) ", cur_errp); + lputs(".ms in gc) ", cur_errp); intprint(cells_allocated - lcells_allocated, -10, cur_errp); lputs(" cells work, ", cur_errp); scm_env_work += scm_ecache_len - scm_ecache_index; intprint(scm_env_work, -10, cur_errp); lputs(" env, ", cur_errp); intprint(mallocated - lmallocated, -10, cur_errp); - lputs(" bytes other\n", cur_errp); - if (verbose>2) { + lputs(".B other\n", cur_errp); + if (verbose > 3) { lputc(';', cur_errp); intprint(scm_gcs, -10, cur_errp); lputs( " gc, ", cur_errp); @@ -1449,7 +1576,7 @@ void init_sbrk() } void scm_brk_report() { - unsigned long scm_curbrk = sbrk(0), + unsigned long scm_curbrk = (unsigned long)sbrk(0), dif1 = ((dumped ? scm_dumped_brk : scm_curbrk) - scm_init_brk)/1024, dif2 = (scm_curbrk - scm_dumped_brk)/1024; @@ -1464,10 +1591,10 @@ void scm_brk_report() lputs("; ", cur_errp); intprint(dif1, 10, cur_errp); if (dumped) { - lputs(dif2<0 ? " - " : " + ", cur_errp); - intprint(dif2<0 ? -dif2 : dif2, 10, cur_errp); + lputs(dif2 < 0 ? " - " : " + ", cur_errp); + intprint(dif2 < 0 ? -dif2 : dif2, 10, cur_errp); } - lputs(" kb\n", cur_errp); + lputs(".kiB\n", cur_errp); } #endif SCM lroom(opt) @@ -1478,7 +1605,7 @@ SCM lroom(opt) intprint(heap_cells, -10, cur_errp); lputs(" cells in use, ", cur_errp); intprint(mallocated, -10, cur_errp); - lputs(" bytes allocated (of ", cur_errp); + lputs(".B allocated (of ", cur_errp); intprint(mtrigger, 10, cur_errp); lputs(")\n", cur_errp); if (!UNBNDP(opt)) { @@ -1486,30 +1613,12 @@ SCM lroom(opt) if (scm_init_brk) scm_brk_report(); #endif scm_ecache_report(); - heap_report(); - lputc('\n', cur_errp); + heap_report(); lputc('\n', cur_errp); + gra_report(); stack_report(); } return UNSPECIFIED; } -void heap_report() -{ - sizet i = 0; - lputs(";; heap segments:", sys_errp); - while(i < hplim_ind) { - { - long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]); - lputs("\n; 0x", sys_errp); - intprint((long)hplims[i++], -16, sys_errp); - lputs(" - 0x", sys_errp); - intprint((long)hplims[i++], -16, sys_errp); - lputs("; ", sys_errp); - intprint(seg_cells, 10, sys_errp); - lputs(" cells; ", sys_errp); - intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp); - lputs(" kb", sys_errp); - }} -} void scm_ecache_report() { intprint(scm_estk_size, 10 , cur_errp); @@ -1521,12 +1630,12 @@ void scm_ecache_report() } void exit_report() { - if (verbose>2) { + if (verbose > 2) { lputs(";Totals: ", cur_errp); intprint(time_in_msec(INUM(my_time())), -10, cur_errp); - lputs(" mSec my time, ", cur_errp); + lputs(".ms my time, ", cur_errp); intprint(time_in_msec(INUM(your_time())), -10, cur_errp); - lputs(" mSec your time\n", cur_errp); + lputs(".ms your time\n", cur_errp); } } @@ -1541,11 +1650,13 @@ SCM prolixity(arg) return MAKINUM(old); } +static SCM i_repl; SCM repl() { SCM x; + SCM env = EOL; /* scm_env_addprop(SCM_ENV_FILENAME, i_repl, EOL); */ int c; - if OPINPORTP(cur_inp) { + if (OPINPORTP(cur_inp) && OPOUTPORTP(cur_outp)) { repl_report(); while(1) { if OPOUTPORTP(cur_inp) { /* This case for curses window */ @@ -1579,10 +1690,27 @@ SCM repl() {lfflush(cur_outp); newline(cur_inp);} else newline(cur_outp); #endif - x = EVAL(x, (SCM)EOL); + if (NIMP(x)) { + x = CONSP(x) ? + scm_eval_values(x, env, (SCM)EOL) : + cons(EVAL(x, env, (SCM)EOL), EOL); + } + else + x = cons(x, EOL); repl_report(); - iprin1(x, cur_outp, 1); - lputc('\n', cur_outp); + if (IMP(x)) + {if (verbose > 2) lputs(";;no values\n", cur_outp);} + else if (IMP(CDR(x))) { + iprin1(CAR(x), cur_outp, 1); + lputc('\n', cur_outp); + } + else + while (NIMP(x)) { + lputc(' ', cur_outp); + iprin1(CAR(x), cur_outp, 1); + lputc('\n', cur_outp); + x = CDR(x); + } } } return UNSPECIFIED; @@ -1623,10 +1751,10 @@ SCM scm_unexec(newpath) #ifdef CAREFUL_INTS ints_infot *ints_info = 0; static void ints_viol_iprin(num) - long num; + int num; { char num_buf[INTBUFLEN]; - sizet i = iint2str(num, 10, num_buf); + sizet i = iint2str(num+0L, 10, num_buf); num_buf[i] = 0; fputs(num_buf, stderr); } @@ -1640,7 +1768,7 @@ void ints_viol(info, sense) fputs(": ints already ", stderr); fputs(sense ? "dis" : "en", stderr); fputs("abled (", stderr); - ints_viol_iprin((long)ints_disabled); + ints_viol_iprin(ints_disabled); fputs(")\n", stderr); if (ints_info) { fputs(ints_info->fname, stderr); @@ -1657,7 +1785,7 @@ void ints_warn(str1, str2, fname, linum) fputs(fname, stderr); fputc(':', stderr); ints_viol_iprin(linum); - fputs(" :uprotected call to ", stderr); + fputs(": unprotected call to ", stderr); fputs(str1, stderr); if (str2) { fputs(" (", stderr); @@ -1668,22 +1796,43 @@ void ints_warn(str1, str2, fname, linum) } #endif -SCM tryload(filename) - SCM filename; +#ifdef CAUTIOUS +static SCM f_read_numbered; +static char s_read_numbered[] = "read-numbered"; +SCM scm_read_numbered(port) + SCM port; +{ + return lread1(port, 2, s_read_numbered); +} +#endif + +SCM tryload(filename, reader) + SCM filename, reader; { ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load); + if (FALSEP(reader)) reader = UNDEFINED; +#ifndef RECKLESS + if (!UNBNDP(reader)) scm_arity_check(reader, 1L, s_load); +#endif { SCM oloadpath = *loc_loadpath; SCM oloadports = loadports; SCM form, port; + SCM env = EOL; port = open_file(filename, makfromstr("r?", (sizet)2*sizeof(char))); if FALSEP(port) return port; *loc_loadpath = filename; loadports = cons(port, loadports); +#ifdef SCM_ENV_FILENAME + env = scm_env_addprop(SCM_ENV_FILENAME, filename, env); +#endif while(1) { - form = lread(port); + if (UNBNDP(reader)) + form = lread(port); + else + form = scm_cvapply(reader, 1L, &port); if (EOF_VAL==form) break; - SIDEVAL(form, EOL); + SIDEVAL(form, env, EOL); } close_port(port); loadports = oloadports; @@ -1692,68 +1841,34 @@ SCM tryload(filename) return BOOL_T; } -#ifdef CAUTIOUS -static long num_frames(estk, i) - SCM estk; - int i; +void scm_line_msg(file, linum, port) + SCM file, linum, port; { - long n = 0; - while NIMP(estk) { - n += (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN; - i = INUM(SCM_ESTK_PARENT_INDEX(estk)); - estk = SCM_ESTK_PARENT(estk); + iprin1(file, port, 1); + if (SCM_LINUMP(linum)) { + lputs(", line ", port); + intprint(SCM_LINUM(linum), -10, port); } - return n; -} - -extern SCM scm_trace; -SCM scm_stack_trace() -{ - SCM ste, lste, estk = scm_estk; - int i = (scm_estk_ptr - VELTS(scm_estk)); - int n, nf = num_frames(estk, i); - int ellip = 0, nbrk1 = 7, nbrk2 = nf - 5; - if (nf <= 0) return BOOL_F; - nf = 0; - lputs("\n;STACK TRACE", cur_errp); - if (NIMP(scm_trace) && (scm_trace != scm_estk_ptr[2])) - if (reset_safeport(sys_safep, 65, cur_errp)) { - /* The usual C setjmp, not SCM's setjump. */ - if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { - lputs("\n+; ", sys_safep); - iprin1(scm_trace, sys_safep, 1); - } - } - lste = UNDEFINED; - while NIMP(estk) { - n = (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN; - for (; n > 0; n--) { - if (nf <= nbrk1 || nf >= nbrk2) { - ste = VELTS(estk)[SCM_ESTK_BASE + n*SCM_ESTK_FRLEN + 2]; - if (ste != lste) { - lste = ste; - if (reset_safeport(sys_safep, 65, cur_errp)) { - /* The usual C setjmp, not SCM's setjump. */ - if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { - lputc('\n', cur_errp); - intprint(nf, -10, sys_safep); - lputs("; ", sys_safep); - iprin1(ste, sys_safep, 1); - } - } - else if (! ellip++) - lputs("\n...", cur_errp); - } - } - nf++; + lputs(": ", port); +} +void scm_err_line(what, file, linum, port) + char *what; + SCM file, linum, port; +{ + lputs(what, port); + if (NIMP(file) && STRINGP(file)) + scm_line_msg(file, linum, port); +#ifdef CAUTIOUS + else { + SCM env = scm_env_getprop(SCM_ENV_FILENAME, scm_trace_env); + if (NIMP(env)) { + file = CAR(env); + scm_check_linum(scm_trace, &linum); + scm_line_msg(file, linum, port); } - i = INUM(SCM_ESTK_PARENT_INDEX(estk)); - estk = SCM_ESTK_PARENT(estk); } - lputc('\n', cur_errp); - return BOOL_T; -} #endif +} static void err_head(str) char *str; @@ -1761,11 +1876,10 @@ static void err_head(str) SCM lps; int oerrno = errno; exitval = MAKINUM(EXIT_FAILURE); - if NIMP(cur_outp) lfflush(cur_outp); - lputc('\n', cur_errp); + if (NIMP(cur_outp) && OPOUTPORTP(cur_outp)) lfflush(cur_outp); for (lps = loadports; NIMP(lps); lps = CDR(lps)) { - if (lps != loadports) - lputs("\n ;loaded from ", cur_errp); + lputs(lps==loadports ? "\n;While loading " : "\n ;loaded from ", + cur_errp); iprin1(scm_port_filename(CAR(lps)), cur_errp, 1); lputs(", line ", cur_errp); iprin1(scm_port_line(CAR(lps)), cur_errp, 1); @@ -1779,17 +1893,22 @@ static void err_head(str) if (errno>0) perror(str); fflush(stderr); } -void scm_warn(str1, str2) +void scm_warn(str1, str2, obj) char *str1, *str2; + SCM obj; { err_head("WARNING"); - lputs("WARNING: ", cur_errp); + scm_err_line("WARNING: ", UNDEFINED, UNDEFINED, cur_errp); lputs(str1, cur_errp); - if (str2) { + if (str2 && *str2) { lputs(str2, cur_errp); lputc('\n', cur_errp); - lfflush(cur_errp); } + if (!UNBNDP(obj)) { + iprin1(obj, cur_errp, 1); + lputc('\n', cur_errp); + } + lfflush(cur_errp); } SCM lerrno(arg) @@ -1812,25 +1931,41 @@ SCM lperror(arg) } static void def_err_response() { - SCM env = err_env, obj = *loc_errobj; + SCM file, env = err_env, obj = *loc_errobj; + SCM linum = UNDEFINED; + int badport = IMP(cur_errp) || !OPOUTPORTP(cur_errp); + int writing = 2; /* Value of 2 used only for printing error messages */ + int codep = errobj_codep; DEFER_INTS; - if (errjmp_recursive++) { + if (badport || (errjmp_recursive++)) { + if (IMP(def_errp) || !OPOUTPORTP(def_errp)) exit(EXIT_FAILURE); lputs("RECURSIVE ERROR: ", def_errp); - if (TYP16(cur_errp)==tc16_sfport) { + if (badport || TYP16(cur_errp)==tc16_sfport) { + lputs("reverting from ", def_errp); + iprin1(cur_errp, def_errp, 2); + lputs("to default error port\n", def_errp); cur_errp = def_errp; errjmp_recursive = 0; - lputs("reverting to default error port\n", def_errp); } else exit(EXIT_FAILURE); } +#ifdef SCM_ENV_FILENAME + file = scm_env_getprop(SCM_ENV_FILENAME, env); + if (NIMP(file)) file = CAR(file); + else file = UNDEFINED; +#else + file = BOOL_F; +#endif + if (codep) obj = scm_check_linum(obj, &linum); + err_exp = scm_check_linum(err_exp, UNBNDP(linum) ? &linum : 0L); err_head("ERROR"); + scm_err_line("ERROR: ", file, linum, cur_errp); if (err_s_subr && *err_s_subr) { - lputs("ERROR: ", cur_errp); lputs(err_s_subr, cur_errp); lputs(": ", cur_errp); } if (!err_pos) return; /* Already been printed */ - if (err_pos==(char *)ARG1 && UNBNDP(*loc_errobj)) err_pos = (char *)WNA; + if (err_pos==(char *)ARG1 && UNBNDP(obj)) err_pos = (char *)WNA; #ifdef nosve if ((~0x1fL) & (short)err_pos) lputs(err_pos, cur_errp); else if (WNA > (short)err_pos) { @@ -1850,40 +1985,26 @@ static void def_err_response() if (!UNBNDP(obj)) if (reset_safeport(sys_safep, 55, cur_errp)) if (0==setjmp(SAFEP_JMPBUF(sys_safep))) - iprin1(obj, sys_safep, 1); + if (codep) scm_princode(obj, EOL, sys_safep, writing); + else iprin1(obj, sys_safep, writing); if UNBNDP(err_exp) goto getout; if NIMP(err_exp) { if (reset_safeport(sys_safep, 55, cur_errp)) if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { lputs("\n; in expression: ", cur_errp); - if NCONSP(err_exp) - iprin1(err_exp, sys_safep, 1); + if (NCONSP(err_exp)) scm_princode(err_exp, env, sys_safep, writing); else if (UNDEFINED==CDR(err_exp)) - iprin1(CAR(err_exp), sys_safep, 1); - else iprlist("(... ", err_exp, ')', sys_safep, 1); + iprin1(CAR(err_exp), sys_safep, writing); + else { + if (UNBNDP(env)) iprlist("(... ", err_exp, ')', sys_safep, writing); + else scm_princode(err_exp, env, sys_safep, writing); + } } } - if (NIMP(env) && ENVP(env)) { - if (scm_env==env) { - lputs("\n; in expand-time environment: ", cur_errp); - iprin1(env, cur_errp, 1); - } - env = CDR(env); - } - if (NULLP(env)) - lputs("\n; in top level environment.", cur_errp); - else { - lputs("\n; in scope:", cur_errp); - while NNULLP(env) { - lputc('\n', cur_errp); - lputs("; ", cur_errp); - iprin1(CAR(CAR(env)), cur_errp, 1); - env = CDR(env); - } - } + scm_scope_trace(env); getout: #ifdef CAUTIOUS - scm_stack_trace(); + scm_stack_trace(UNDEFINED); #endif lputc('\n', cur_errp); lfflush(cur_errp); @@ -1902,15 +2023,17 @@ static void def_err_response() errno = 0; ALLOW_INTS; } -void everr(exp, env, arg, pos, s_subr) +void everr(exp, env, arg, pos, s_subr, codep) SCM exp, env, arg; char *pos, *s_subr; + int codep; { err_exp = exp; err_env = env; *loc_errobj = arg; err_pos = pos; err_s_subr = s_subr; + errobj_codep = codep; if (errjmp_bad || errjmp_recursive) def_err_response(); longjump(CONT(rootcont)->jmpbuf, (~0x1fL) & (long)pos || (WNA > (long)pos) ? @@ -1919,9 +2042,23 @@ void everr(exp, env, arg, pos, s_subr) } void wta(arg, pos, s_subr) SCM arg; -char *pos, *s_subr; + char *pos, *s_subr; { - everr(UNDEFINED, EOL, arg, pos, s_subr); +#ifndef RECKLESS + everr(scm_trace, scm_trace_env, arg, pos, s_subr, 0); +#else + everr(UNDEFINED, EOL, arg, pos, s_subr, 0); +#endif +} +void scm_experr(arg, pos, s_subr) + SCM arg; + char *pos, *s_subr; +{ +#ifndef RECKLESS + everr(scm_trace, scm_trace_env, arg, pos, s_subr, !0); +#else + everr(UNDEFINED, EOL, arg, pos, s_subr, !0); +#endif } SCM cur_input_port() { @@ -1988,16 +2125,12 @@ static iproc subr0s[] = { {"line-number", line_num}, {"abort", abrt}, {s_restart, restart}, -#ifdef CAUTIOUS - {"stack-trace", scm_stack_trace}, -#endif {0, 0}}; static iproc subr1s[] = { {s_cur_inp, set_inp}, {s_cur_outp, set_outp}, {s_cur_errp, set_errp}, - {s_tryload, tryload}, {s_load_string, scm_load_string}, {s_eval_string, scm_eval_string}, {s_perror, lperror}, @@ -2028,6 +2161,7 @@ static iproc subr2os[] = { {s_write, lwrite}, {s_display, display}, {s_write_char, write_char}, + {s_tryload, tryload}, #ifdef CAN_DUMP {s_unexec, scm_unexec}, #endif @@ -2040,17 +2174,26 @@ void init_repl( iverbose ) int iverbose; { sysintern(s_ccl, MAKINUM(CHAR_CODE_LIMIT)); + i_repl = CAR(sysintern("repl", UNDEFINED)); loc_errobj = &CDR(sysintern("errobj", UNDEFINED)); loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F)); loc_readsharp = &CDR(sysintern("read:sharp", UNDEFINED)); loc_readsharpc = &CDR(sysintern("read:sharp-char", UNDEFINED)); + loc_broken_pipe = &CDR(sysintern("broken-pipe", UNDEFINED)); scm_verbose = iverbose; init_iprocs(subr0s, tc7_subr_0); init_iprocs(subr1os, tc7_subr_1o); init_iprocs(subr1s, tc7_subr_1); init_iprocs(subr2os, tc7_subr_2o); +#ifdef CAUTIOUS + f_read_numbered = + make_subr(s_read_numbered, tc7_subr_1, scm_read_numbered); +#endif add_feature(s_char_readyp); + make_subr(s_swapcar, tc7_subr_2, swapcar); make_subr(s_wfi, tc7_lsubr, wait_for_input); + i_eval_string = CAR(sysintern(s_eval_string, UNDEFINED)); + i_load_string = CAR(sysintern(s_load_string, UNDEFINED)); #ifdef CAN_DUMP add_feature("dump"); scm_ldstr("\ diff --git a/requires.scm b/requires.scm index bd4b8bf..97d7cdd 100644 --- a/requires.scm +++ b/requires.scm @@ -2,12 +2,12 @@ (set! library-vicinity (let* ((vl (case (software-type) - ((AMIGA) '(#\: #\/)) - ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) - ((MACOS THINKC) '(#\:)) - ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT) '(#\/)) - ((VMS) '(#\: #\])))) + ((AMIGA) '(#\: #\/)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((MACOS THINKC) '(#\:)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT PLAN9) '(#\/)) + ((VMS) '(#\: #\])))) (iv (implementation-vicinity)) (vc (and (positive? (string-length iv)) (string-ref iv (+ -1 (string-length iv))))) @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -55,7 +55,7 @@ #endif static char rcsid[] = - "$Id: rgx.c,v 1.12 1999/09/07 16:55:54 jaffer Exp $"; + "$Id: rgx.c,v 1.15 2002/04/13 20:41:02 jaffer Exp $"; #ifdef HAVE_ALLOCA # include <alloca.h> @@ -121,13 +121,13 @@ typedef struct regex_info { sizet fregex(ptr) CELLPTR ptr; { - regfree(RGX(ptr)); + regfree(RGX((SCM)ptr)); #ifndef _GNU_SOURCE /* options are null => we compiled the anchored pattern */ - if (RGX_INFO(ptr)->options==0) - regfree(RGX2(ptr)); + if (RGX_INFO((SCM)ptr)->options==0) + regfree(RGX2((SCM)ptr)); #endif - must_free(CHARS(ptr), (sizet)LENGTH(ptr)); + must_free(CHARS((SCM)ptr), (sizet)LENGTH((SCM)ptr)); return 0; } @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -85,7 +85,7 @@ unsigned char num2uchar(num, pos, s_caller) char *pos, *s_caller; { unsigned long res = INUM(num); - ASSERT(INUMP(num) && (255L >= res),num,pos,s_caller); + ASSERT(INUMP(num) && (255L >= res), num, pos, s_caller); return (unsigned char) res; } unsigned short num2ushort(num, pos, s_caller) @@ -93,7 +93,7 @@ unsigned short num2ushort(num, pos, s_caller) char *pos, *s_caller; { unsigned long res = INUM(num); - ASSERT(INUMP(num) && (65535L >= res),num,pos,s_caller); + ASSERT(INUMP(num) && (65535L >= res), num, pos, s_caller); return (unsigned short) res; } unsigned long num2ulong(num, pos, s_caller) @@ -251,7 +251,7 @@ SCM scm_evstr(str) { SCM lsym; NEWCELL(lsym); - SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol); + SETLENGTH(lsym, strlen(str), tc7_ssymbol); SETCHARS(lsym, str); return scm_eval_string(lsym); } @@ -260,7 +260,7 @@ void scm_ldstr(str) { SCM lsym; NEWCELL(lsym); - SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol); + SETLENGTH(lsym, strlen(str), tc7_ssymbol); SETCHARS(lsym, str); scm_load_string(lsym); } @@ -269,7 +269,7 @@ int scm_ldfile(path) { SCM name = makfrom0str(path); *loc_errobj = name; - return BOOL_F==tryload(name); + return BOOL_F==tryload(name, UNDEFINED); } int scm_ldprog(path) char *path; @@ -381,15 +381,14 @@ unsigned long scm_base_addr(v, s_name) } #endif /* ARRAYS */ +extern sizet hplim_ind; +extern CELLPTR *hplims; + /* scm_cell_p() returns !0 if the SCM argument `x' is cell-aligned and points into a valid heap segment. This code is duplicated from mark_locations() and obunhash() in "sys.c", which means that changes to these routines must be coordinated. */ -#include "continue.h" -extern sizet hplim_ind; -extern CELLPTR *hplims; - int scm_cell_p(x) SCM x; { @@ -413,6 +412,21 @@ int scm_cell_p(x) return 0; } +long scm_protidx = 0; + +SCM scm_gc_protect(obj) + SCM obj; +{ + long len; + ASSERT(NIMP(scm_uprotects), MAKINUM(20), NALLOC, "protects"); + if IMP(obj) return obj; + len = LENGTH(scm_uprotects); + if (scm_protidx >= len) resizuve(scm_uprotects, MAKINUM(len + (len>>2))); + VELTS(scm_uprotects)[scm_protidx++] = obj; + return obj; +} + void init_rope() { + scm_uprotects = make_vector(MAKINUM(20), UNDEFINED); } @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -45,11 +45,19 @@ #include "scm.h" #ifdef FLOATS -# include <math.h> +# ifndef PLAN9 +# include <math.h> +# endif static double big2scaldbl P((SCM b, int expt)); static SCM bigdblop P((int op, SCM b, double re, double im)); static SCM inex_divbigbig P((SCM a, SCM b)); +static int apx_log10 P((double x)); +static double lpow10 P((double x, int n)); +static sizet idbl2str P((double f, char *a)); +static sizet iflo2str P((SCM flt, char *str)); +static void add1 P((double f, double *fsum)); +static long scm_twos_power P((SCM n)); static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar", s_magnitude[] = "magnitude", s_angle[] = "angle", @@ -83,7 +91,13 @@ static char s_intexpt[] = "integer-expt"; /*** NUMBERS -> STRINGS ***/ #ifdef FLOATS -static int dbl_mant_dig; +# ifndef DBL_MANT_DIG +# define DBL_MANT_DIG dbl_mant_dig +# endif +static int dbl_mant_dig = 0; +static double max_dbl_int; /* Integers less than or equal to max_dbl_int + are representable exactly as doubles. */ +static double dbl_eps; double dbl_prec(x) double x; { @@ -91,10 +105,10 @@ double dbl_prec(x) double frac = frexp(x, &expt); # ifdef DBL_MIN_EXP if (0.0==x || expt < DBL_MIN_EXP) /* gradual underflow */ - return ldexp(1.0, -dbl_mant_dig) * ldexp(1.0, DBL_MIN_EXP); + return ldexp(1.0, -DBL_MANT_DIG) * ldexp(1.0, DBL_MIN_EXP); # endif - if (1.0==frac) return ldexp(1.0, expt - dbl_mant_dig + 1); - return ldexp(1.0, expt - dbl_mant_dig); + if (1.0==frac) return ldexp(1.0, expt - DBL_MANT_DIG + 1); + return ldexp(1.0, expt - DBL_MANT_DIG); } static double llog2 = 0.3010299956639812; /* log10(2) */ @@ -130,7 +144,7 @@ static double lpow10(x, n) /* DBL2STR_FUZZ is a somewhat arbitrary guard against round off error in scaling f and fprec. */ -#define DBL2STR_FUZZ 0.9 +# define DBL2STR_FUZZ 0.9 int dblprec; static sizet idbl2str(f, a) double f; @@ -479,14 +493,23 @@ SCM istr2int(str, len, radix) if (c >= radix) return BOOL_F; /* bad digit for radix */ ln = n; n = n * radix - c; - /* Negation is a workaround for HP700 cc bug */ - if (n > ln || (-n > -MOST_NEGATIVE_FIXNUM)) goto ovfl; + if (n > ln +# ifdef hpux + || (-n > -MOST_NEGATIVE_FIXNUM) /* workaround for HP700 cc bug */ +# endif + ) goto ovfl; break; default: return BOOL_F; /* not a digit */ } } while (i < len); - if (!lead_neg) if ((n = -n) > MOST_POSITIVE_FIXNUM) goto ovfl; + if (lead_neg) { + if (n < MOST_NEGATIVE_FIXNUM) goto ovfl; + } + else { + if (n < -MOST_POSITIVE_FIXNUM) goto ovfl; + n = -n; + } return MAKINUM(n); ovfl: /* overflow scheme integer */ return BOOL_F; @@ -494,6 +517,34 @@ SCM istr2int(str, len, radix) #endif #ifdef FLOATS +# ifdef BIGDIG +static char twostab[] = {4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0}; +static long scm_twos_power(n) + SCM n; +{ + long d, c = 0; + int d4; +# ifdef BIGDIG + if NINUMP(n) { + BIGDIG *ds; + int i = 0; + ds = BDIGITS(n); + while (0==(d = ds[i++])) c += BITSPERDIG; + goto out; + } +# endif + d = INUM(n); + if (0==d) return 0; + out: + do { + d4 = 15 & d; + c += twostab[d4]; + d >>= 4; + } while (0==d4); + return c; +} +# endif /* def BIGDIG */ + SCM istr2flo(str, len, radix) register char *str; register long len; @@ -965,6 +1016,29 @@ SCM numberp(x) return BOOL_F; } #ifdef FLOATS +# ifdef BIGDIG +int scm_bigdblcomp(b, d) + SCM b; + double d; +{ + sizet dlen, blen; + int dneg = d < 0 ? 1 : 0; + int bneg = BIGSIGN(b) ? 1 : 0; + if (bneg < dneg) return -1; + if (bneg > dneg) return 1; + frexp(d, &dlen); + blen = INUM(scm_intlength(b)); + if (blen > dlen) return dneg ? 1 : -1; + if (blen < dlen) return dneg ? -1 : 1; + if ((blen <= DBL_MANT_DIG) || (blen - scm_twos_power(b)) <= DBL_MANT_DIG) { + double bd = big2dbl(b); + if (bd > d) return -1; + if (bd < d) return 1; + return 0; + } + return bigcomp(b, dbl2big(d)); +} +# endif SCM realp(x) SCM x; { @@ -1018,7 +1092,8 @@ SCM eqp(x, y) if BIGP(y) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; ASRTGO(INEXP(y), bady); bigreal: - return (REALP(y) && (big2dbl(x)==REALPART(y))) ? BOOL_T : BOOL_F; + return (REALP(y) && (0==scm_bigdblcomp(x, REALPART(y)))) ? + BOOL_T : BOOL_F; } ASRTGO(INEXP(x), badx); # else @@ -1091,7 +1166,7 @@ SCM lessp(x, y) ASRTGO(NIMP(y), bady); if BIGP(y) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F; ASRTGO(REALP(y), bady); - return (big2dbl(x) < REALPART(y)) ? BOOL_T : BOOL_F; + return (1==scm_bigdblcomp(x, REALPART(y))) ? BOOL_T : BOOL_F; } ASRTGO(REALP(x), badx); # else @@ -1100,7 +1175,7 @@ SCM lessp(x, y) if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return (REALPART(x) < big2dbl(y)) ? BOOL_T : BOOL_F; + if BIGP(y) return (-1==scm_bigdblcomp(y, REALPART(x))) ? BOOL_T : BOOL_F; ASRTGO(REALP(y), bady); # else ASRTGO(NIMP(y) && REALP(y), bady); @@ -1248,10 +1323,12 @@ SCM negativep(x) return (x < INUM0) ? BOOL_T : BOOL_F; } +static char s_exactprob[] = "not representable as inexact"; SCM lmax(x, y) SCM x, y; { #ifdef FLOATS + SCM t; double z; #endif if UNBNDP(y) { @@ -1270,8 +1347,11 @@ SCM lmax(x, y) ASRTGO(NIMP(y), bady); if BIGP(y) return (1==bigcomp(x, y)) ? y : x; ASRTGO(REALP(y), bady); + big_dbl: + if (-1 != scm_bigdblcomp(x, REALPART(y))) return y; z = big2dbl(x); - return (z < REALPART(y)) ? y : makdbl(z, 0.0); + ASSERT(0==scm_bigdblcomp(x, z), x, s_exactprob, s_max); + return makdbl(z, 0.0); } ASRTGO(REALP(x), badx); # else @@ -1280,7 +1360,9 @@ SCM lmax(x, y) if INUMP(y) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return (REALPART(x) < (z = big2dbl(y))) ? makdbl(z, 0.0) : x; + if BIGP(y) { + t = y; y = x; x = t; goto big_dbl; + } ASRTGO(REALP(y), bady); # else ASRTGO(NIMP(y) && REALP(y), bady); @@ -1330,6 +1412,7 @@ SCM lmin(x, y) SCM x, y; { #ifdef FLOATS + SCM t; double z; #endif if UNBNDP(y) { @@ -1348,8 +1431,11 @@ SCM lmin(x, y) ASRTGO(NIMP(y), bady); if BIGP(y) return (-1==bigcomp(x, y)) ? y : x; ASRTGO(REALP(y), bady); + big_dbl: + if (1 != scm_bigdblcomp(x, REALPART(y))) return y; z = big2dbl(x); - return (z > REALPART(y)) ? y : makdbl(z, 0.0); + ASSERT(0==scm_bigdblcomp(x, z), x, s_exactprob, s_min); + return makdbl(z, 0.0); } ASRTGO(REALP(x), badx); # else @@ -1358,7 +1444,9 @@ SCM lmin(x, y) if INUMP(y) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return (REALPART(x) > (z = big2dbl(y))) ? makdbl(z, 0.0) : x; + if BIGP(y) { + t = y; y = x; x = t; goto big_dbl; + } ASRTGO(REALP(y), bady); # else ASRTGO(NIMP(y) && REALP(y), bady); @@ -1960,6 +2048,10 @@ SCM scm_intexpt(z1, z2) SCM z1, z2; { SCM acc = MAKINUM(1L); + int recip = 0; +#ifdef FLOATS + double dacc, dz1; +#endif #ifdef BIGDIG if (INUM0==z1 || acc==z1) return z1; else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; @@ -1968,18 +2060,17 @@ SCM scm_intexpt(z1, z2) z2 = INUM(z2); if (z2 < 0) { z2 = -z2; - z1 = divide(z1, UNDEFINED); + recip = 1; /* z1 = divide(z1, UNDEFINED); */ } if INUMP(z1) { long tmp, iacc = 1, iz1 = INUM(z1); +#ifdef FLOATS + if (recip) { dz1 = iz1; goto flocase; } +#endif while (1) { if (0==z2) { acc = long2num(iacc); -#ifndef RECKLESS - if (FALSEP(z1)) - errout: wta(UNDEFINED, (char *)OVFLOW, s_intexpt); -#endif - return acc; + break; } if (1==z2) { tmp = iacc*iz1; @@ -1991,8 +2082,7 @@ SCM scm_intexpt(z1, z2) goto gencase; } acc = long2num(tmp); - ASRTGO(NFALSEP(acc), errout); - return acc; + break; } if (z2 & 1) { tmp = iacc*iz1; @@ -2005,28 +2095,37 @@ SCM scm_intexpt(z1, z2) iz1 = tmp; z2 >>= 1; } +#ifndef RECKLESS + if (FALSEP(acc)) + errout: wta(UNDEFINED, (char *)OVFLOW, s_intexpt); +#endif + goto ret; } ASSERT(NIMP(z1), z1, ARG1, s_intexpt); -#ifdef FLOATS /* Move to scl.c ? */ +#ifdef FLOATS if REALP(z1) { - double dacc = 1.0, dz1 = REALPART(z1); + dz1 = REALPART(z1); + flocase: + dacc = 1.0; while(1) { - if (0==z2) return makdbl(dacc, 0.0); - if (1==z2) return makdbl(dacc*dz1, 0.0); + if (0==z2) break; + if (1==z2) {dacc = dacc*dz1; break;} if (z2 & 1) dacc = dacc*dz1; dz1 = dz1*dz1; z2 >>= 1; } + return makdbl(recip ? 1.0/dacc : dacc, 0.0); } #endif gencase: while(1) { - if (0==z2) return acc; - if (1==z2) return product(acc, z1); + if (0==z2) break; + if (1==z2) {acc = product(acc, z1); break;} if (z2 & 1) acc = product(acc, z1); z1 = product(z1, z1); z2 >>= 1; } + ret: return recip ? divide(acc, UNDEFINED) : acc; } #ifdef FLOATS @@ -2242,8 +2341,11 @@ SCM in2ex(z) # ifdef BIGDIG { double u = floor(REALPART(z)+0.5); - if ((u <= MOST_POSITIVE_FIXNUM) && (-u <= -MOST_NEGATIVE_FIXNUM)) { - /* Negation is a workaround for HP700 cc bug */ + if ((u <= MOST_POSITIVE_FIXNUM) +# ifdef hpux + && (-u <= -MOST_NEGATIVE_FIXNUM) /* workaround for HP700 cc bug */ +# endif + ) { SCM ans = MAKINUM((long)u); if (INUM(ans)==(long)u) return ans; } @@ -2349,6 +2451,8 @@ static SCM bigdblop(op, b, re, im) } case '\\': return makdbl(ldexp(re/bm, -i), 0.0==im ? 0.0 : ldexp(im/bm, -i)); + default: + return UNSPECIFIED; } } static SCM inex_divbigbig(a, b) @@ -2371,6 +2475,64 @@ static SCM inex_divbigbig(a, b) } return makdbl(r, 0.0); } + +static char s_dfloat_parts[] = "double-float-parts"; +SCM scm_dfloat_parts(f) + SCM f; +{ + int expt, ndig = DBL_MANT_DIG; + double mant = frexp(num2dbl(f, (char *)ARG1, s_dfloat_parts), &expt); +# ifdef DBL_MIN_EXP + if (expt < DBL_MIN_EXP) + ndig -= DBL_MIN_EXP - expt; +# endif + mant *= ldexp(1.0, ndig); + expt -= ndig; + return scm_values(dbl2big(mant), MAKINUM(expt), EOL, s_dfloat_parts); +} +static char s_make_dfloat[] = "make-double-float"; +SCM scm_make_dfloat(mant, expt) + SCM mant, expt; +{ + double dmant = num2dbl(mant, (char *)ARG1, s_make_dfloat); + int e = INUM(expt); + ASSERT(INUMP(expt), expt, ARG2, s_make_dfloat); + ASSERT((dmant < 0 ? -dmant : dmant)<=max_dbl_int, mant, + OUTOFRANGE, s_make_dfloat); + return makdbl(ldexp(dmant, e), 0.0); +} +static char s_next_dfloat[] = "next-double-float"; +SCM scm_next_dfloat(f1, f2) + SCM f1, f2; +{ + int e, neg = 0; + double d1 = num2dbl(f1, (char *)ARG1, s_next_dfloat); + double dif = num2dbl(f2, (char *)ARG2, s_next_dfloat) - d1; + double d = frexp(d1, &e), eps = dbl_eps; + if (d1 < 0) {neg = 1; dif = -dif; d = -d;} + if (dif > 0) { +# ifdef DBL_MIN_EXP + if (e < DBL_MIN_EXP) + eps = ldexp(eps, DBL_MIN_EXP - e); + else if (0.0==d) + eps = ldexp(1.0, DBL_MIN_EXP - DBL_MANT_DIG); +# endif + d = ldexp(d + eps, e); + } + else if (dif < 0) { +# ifdef DBL_MIN_EXP + if (e < DBL_MIN_EXP) + eps = ldexp(eps, DBL_MIN_EXP - e); + else if (0.0==d) + eps = ldexp(-1.0, DBL_MIN_EXP - DBL_MANT_DIG); +# endif + if (0.5==d) eps *= 0.5; + d = ldexp(d - eps, e); + } + else if (0.0==dif) + return f1; + return makdbl(neg ? -d : d, 0.0); +} # endif #endif @@ -2490,6 +2652,9 @@ static iproc subr1s[] = { {s_angle, angle}, {s_in2ex, in2ex}, {s_ex2in, ex2in}, +# ifdef BIGDIG + {s_dfloat_parts, scm_dfloat_parts}, +# endif #else {"real?", numberp}, {"rational?", numberp}, @@ -2524,6 +2689,10 @@ static iproc subr2s[] = { {s_makpolar, makpolar}, {s_atan2, latan2}, {s_expt, expt}, +# ifdef BIGDIG + {s_make_dfloat, scm_make_dfloat}, + {s_next_dfloat, scm_next_dfloat}, +# endif #endif #ifdef INUMS_ONLY {s_memv, memq}, @@ -2634,7 +2803,7 @@ void init_scl() # ifdef DBL_MANT_DIG dbl_mant_dig = DBL_MANT_DIG; # else - { + if (!DBL_MANT_DIG) { /* means we #defined it. */ double fsum = 0.0, eps = 1.0; int i = 0; while (fsum != 1.0) { @@ -2645,5 +2814,9 @@ void init_scl() dbl_mant_dig = i; } # endif /* DBL_MANT_DIG */ + max_dbl_int = pow(2.0, dbl_mant_dig - 1.0); + max_dbl_int = max_dbl_int + (max_dbl_int - 1.0); + dbl_eps = ldexp(1.0, -dbl_mant_dig); + sysintern("double-float-mantissa-length", MAKINUM(DBL_MANT_DIG)); #endif } @@ -1,5 +1,5 @@ .\" dummy line -.TH SCM "Dec 5 1998" +.TH SCM "Jan 4 2000" .UC 4 .SH NAME scm \- a Scheme Language Interpreter @@ -8,30 +8,40 @@ scm \- a Scheme Language Interpreter [-a .I kbytes ] -[-ibvqmu] -[-p -.I number +[-muvqib] +[--version] +[--help] +.br +[[-]-no-init-file] [-p +.I int +] [-r +.I feature +] [-h +.I feature +] +.br +[-d +.I filename +] [-f +.I filename +] [-l +.I filename ] +.br [-c .I expression -] -[-e +] [-e .I expression ] -[-f -.I filename +[-o +.I dumpname ] -[-l -.I filename -] -[-d +.br +[-- | - | -s] [ .I filename +] [ +.I arguments ... ] -[-r -.I feature -] -[-- | - | -s] -[filename] [arguments ...] .br .sp 0.3 .SH DESCRIPTION @@ -47,6 +57,8 @@ to "Init.scm" in the source directory. Unless the option .I -no-init-file +or +.I --no-init-file occurs in the command line, "Init.scm" checks to see if there is file "ScmInit.scm" in the path specified by the environment variable HOME (or in the current directory if HOME is undefined). If it finds such @@ -94,6 +106,10 @@ is 2, 3, 4, or 5 will require the features neccessary to support R2RS, R3RS, R4RS, or R5RS, respectively. .TP +.BI -h feature +provides +.I feature. +.TP .BI -l filename .TP .BI -f filename @@ -111,6 +127,18 @@ If contains initialization code, it will be run when the database is opened. .TP +.BI -o dumpname +saves the current SCM session as the executable program +.I dumpname. +This option works only in SCM builds supporting +.BI dump. + +If options appear on the command line after +.I -o dumpname, +then the saved session will continue with processing those options +when it is invoked. Otherwise the (new) command line is processed as +usual when the saved image is invoked. +.TP .BI -p level sets the prolixity (verboseness) to .I level. @@ -295,9 +323,9 @@ enhancements, internal representations, and how to extend or include .I scm in other programs. .SH AUTHORS -Aubrey Jaffer (jaffer @ ai.mit.edu) +Aubrey Jaffer (jaffer @ alum.mit.edu) .br -Radey Shouman (Radey.Shouman @ splashtech.com) +Radey Shouman (shouman @ ne.mediaone.net) .SH BUGS .SH SEE ALSO The SCM home-page: @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -42,7 +42,11 @@ /* "scm.c" Initialization and interrupt code. Author: Aubrey Jaffer */ -#include <signal.h> +#ifdef PLAN9 +# define signal(a,b) 0/* no signals in Plan 9 */ +#else +# include <signal.h> +#endif #include "scm.h" #include "patchlvl.h" @@ -62,7 +66,10 @@ # ifdef SVR4 # include <unistd.h> # endif -# ifdef __amigados__ +# ifdef __OpenBSD__ +# include <unistd.h> +# endif +# ifdef __amigaos__ # include <unistd.h> # endif #endif @@ -91,6 +98,7 @@ void init_tables P((void)); void init_time P((void)); void init_types P((void)); void init_unif P((void)); +void init_debug P((void)); void reset_time P((void)); void final_repl P((void)); @@ -103,12 +111,27 @@ This is free software, and you are welcome to redistribute it\n\ under certain conditions; type `(terms)' for details.\n", stderr); } +void scm_init_INITS() +{ + if (!dumped) { +#ifdef INITS + INITS; /* call initialization of extension files */ +#endif + } +} SCM scm_init_extensions() { #ifdef COMPILED_INITS COMPILED_INITS; /* initialize statically linked add-ons */ #endif init_user_scm(); +#ifndef HAVE_DYNL + /* No more init_*s, so trim gra[]s */ + scm_trim_gra(&subrs_gra); + scm_trim_gra(&ptobs_gra); + scm_trim_gra(&smobs_gra); + scm_trim_gra(&finals_gra); +#endif return UNSPECIFIED; } @@ -166,6 +189,10 @@ void process_signals() } mask <<= 1; } + if (gc_hook_pending) { + gc_hook_pending = 0; + scm_gc_hook(); + } deferred_proc = 0; } static char s_unksig[] = "unknown signal"; @@ -239,52 +266,40 @@ SCM lalarm(i) # ifdef SIGPROF # include <sys/time.h> static char s_setitimer[] = "setitimer"; -static SCM setitimer_iv[3]; +static struct {SCM sym; int which;} setitimer_tab[3] = { + {UNDEFINED, 0}, {UNDEFINED, 0}, {UNDEFINED, 0}}; /* VALUE and INTERVAL are milliseconds */ SCM scm_setitimer(which, value, interval) SCM which, value, interval; { struct itimerval tval, oval; int w; -# ifdef ITIMER_REAL - if (which==setitimer_iv[0]) { - w = ITIMER_REAL; - goto doit; - } -# endif -# ifdef ITIMER_VIRTUAL - if (which==setitimer_iv[1]) { - w = ITIMER_VIRTUAL; - goto doit; - } -# endif -# ifdef ITIMER_PROF - if (which==setitimer_iv[2]) { - w = ITIMER_PROF; - goto doit; + int i = sizeof(setitimer_tab)/sizeof(setitimer_tab[0]); + while (i--) { + if (which==setitimer_tab[i].sym) { + w = setitimer_tab[i].which; + if (BOOL_T==value) + SYSCALL(w = getitimer(w, &oval);); + else { + if (BOOL_F==value) value = INUM0; + ASSERT(INUMP(value), value, ARG2, s_setitimer); + if (BOOL_F==interval) interval = INUM0; + ASSERT(INUMP(interval), interval, ARG3, s_setitimer); + tval.it_value.tv_sec = INUM(value) / 1000; + tval.it_value.tv_usec = (INUM(value) % 1000)*1000; + tval.it_interval.tv_sec = INUM(interval) / 1000; + tval.it_interval.tv_usec = (INUM(interval) % 1000)*1000; + SYSCALL(w = setitimer(w, &tval, &oval);); + } + if (w) return BOOL_F; + return cons2(MAKINUM(oval.it_value.tv_usec/1000 + + oval.it_value.tv_sec*1000), + MAKINUM(oval.it_interval.tv_usec/1000 + + oval.it_interval.tv_sec*1000), + EOL); + } } -# endif return BOOL_F; - doit: - if (BOOL_T==value) - SYSCALL(w = getitimer(w, &oval);); - else { - if (BOOL_F==value) value = INUM0; - ASSERT(INUMP(value), value, ARG2, s_setitimer); - if (BOOL_F==interval) interval = INUM0; - ASSERT(INUMP(interval), interval, ARG3, s_setitimer); - tval.it_value.tv_sec = INUM(value) / 1000; - tval.it_value.tv_usec = (INUM(value) % 1000)*1000; - tval.it_interval.tv_sec = INUM(interval) / 1000; - tval.it_interval.tv_usec = (INUM(interval) % 1000)*1000; - SYSCALL(w = setitimer(w, &tval, &oval);); - } - if (w) return BOOL_F; - return cons2(MAKINUM(oval.it_value.tv_usec/1000 + - oval.it_value.tv_sec*1000), - MAKINUM(oval.it_interval.tv_usec/1000 + - oval.it_interval.tv_sec*1000), - EOL); } # endif # ifndef AMIGA @@ -301,6 +316,9 @@ SCM l_pause() #ifdef _WIN32 # include <windows.h> #endif +#ifdef __IBMC__ +# include <os2.h> +#endif #ifndef AMIGA # ifndef _Windows static char s_sleep[] = "sleep"; @@ -313,9 +331,13 @@ SCM l_sleep(i) SYSCALL(sleep(INUM(i));); # else # ifdef _WIN32 - Sleep(INUM(i)); + Sleep(INUM(i) * 1000); # else +# ifdef __IBMC__ + DosSleep(INUM(i) * 1000); +# else SYSCALL(j = sleep(INUM(i));); +# endif # endif # endif return MAKINUM(j); @@ -323,36 +345,60 @@ SCM l_sleep(i) # endif #endif +#ifdef PLAN9 +int raise(sig) + int sig; +{ + char *str; + int len; + char ibuf[12]; + char pidbuf[32]; + int fd; + int res; + sprint(ibuf, "%ld", sig); + len = strlen(ibuf); + sprint(pidbuf, "/proc/%d/note", getpid()); + fd = open(pidbuf, OWRITE); + res = write(fd, ibuf, len); + close (fd); + return res==len; +} +#endif + #ifndef _WIN32 # ifndef sun # ifndef THINK_C +# ifndef __TURBOC__ +# ifdef STDC_HEADERS +# ifndef __MWERKS__ +# ifndef __IBMC__ +# ifndef PLAN9 +# define LACK_RAISE +# endif +# endif +# endif +# endif +# endif +# endif +# endif +#endif /* int raise P((int sig)); */ static char s_raise[] = "raise"; SCM l_raise(sig) SCM sig; { ASSERT(INUMP(sig), sig, ARG1, s_raise); -# ifdef vms +#ifdef LACK_RAISE +# ifdef vms return MAKINUM(gsignal((int)INUM(sig))); -# else -# ifndef __TURBOC__ -# ifdef STDC_HEADERS -# ifndef __MWERKS__ +# else return kill(getpid (), (int)INUM(sig)) ? BOOL_F : BOOL_T; -# else - return raise((int)INUM(sig)) ? BOOL_F : BOOL_T; -# endif -# else - return raise((int)INUM(sig)) ? BOOL_F : BOOL_T; -# endif -# else - return raise((int)INUM(sig)) ? BOOL_F : BOOL_T; -# endif -# endif -} -# endif # endif +#else + return raise((int)INUM(sig)) ? BOOL_F : BOOL_T; #endif +} + #ifdef TICKS unsigned int tick_count = 0, ticken = 0; SCM *loc_tick_signal; @@ -404,23 +450,20 @@ void init_scm(iverbose, buf0stdin, init_heap_size) if (!dumped) { init_features(); init_subrs(); - init_io(); init_scl(); - init_eval(); + init_unif(); init_time(); + init_io(); + init_eval(); /* call to scm_evstr switches INTS discipline */ + init_debug(); + init_rope(); init_repl(iverbose); - init_unif(); } else reset_time(); #ifdef HAVE_DYNL /* init_dynl() must check dumped to avoid redefining subrs */ init_dynl(); #endif - if (!dumped) { -#ifdef INITS - INITS; /* call initialization of extension files */ -#endif - } } static void init_sig1(scm_err, signo, handler) @@ -436,7 +479,9 @@ static void init_sig1(scm_err, signo, handler) } void init_signals() { +#ifdef SIGINT init_sig1(INT_SIGNAL, SIGINT, scmable_signal); +#endif #ifdef SIGHUP init_sig1(HUP_SIGNAL, SIGHUP, scmable_signal); #endif @@ -532,9 +577,10 @@ void restore_signals() # ifndef SIGPROF alarm(0); /* kill any pending ALRM interrupts */ # else - i = sizeof(setitimer_iv)/sizeof(SCM); + i = sizeof(setitimer_tab)/sizeof(setitimer_tab[0]); while (i--) - scm_setitimer(setitimer_iv[i], BOOL_F, BOOL_F); + if (NIMP(setitimer_tab[i].sym)) + scm_setitimer(setitimer_tab[i].sym, BOOL_F, BOOL_F); # endif #endif i = NUM_SIGNALS; @@ -567,7 +613,7 @@ void scm_init_from_argv(argc, argv, script_arg, iverbose, buf0stdin) break; } while (* ++str); } - init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in Kb */ + init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in kB */ progargs = EOL; progargs = makfromstrs(argc, argv); sysintern("*script*", script_arg ? makfrom0str(script_arg) : BOOL_F); @@ -578,6 +624,7 @@ void final_scm(freeall) #ifdef TICKS ticken = 0; #endif + scm_run_finalizers(!0); #ifdef FINALS FINALS; /* call shutdown of extensions files */ #endif /* for compatability with older modules */ @@ -590,6 +637,14 @@ void final_scm(freeall) if (freeall) free_storage(); /* free all allocated memory */ } +#ifdef PLAN9 +# define SYSTNAME "plan9" +# define DIRSEP "/" +#endif +#ifdef __MACH__ +# define SYSTNAME "unix" +# define DIRSEP "/" +#endif #ifdef __CYGWIN32__ # define SYSTNAME "unix" # define DIRSEP "/" @@ -597,7 +652,7 @@ void final_scm(freeall) #ifdef vms # define SYSTNAME "vms" #endif -#ifdef unix +#ifdef HAVE_UNIX # define DIRSEP "/" # ifndef MSDOS /* DJGPP defines both */ # define SYSTNAME "unix" @@ -613,7 +668,7 @@ void final_scm(freeall) #else # ifdef MSDOS # define SYSTNAME "ms-dos" -# ifndef unix +# ifndef HAVE_UNIX # define DIRSEP "\\" # endif # endif @@ -642,17 +697,13 @@ void final_scm(freeall) # define SYSTNAME "atarist" # define DIRSEP "\\" #endif -#ifdef mach -# define SYSTNAME "mach" -# define DIRSEP "/" -#endif #ifdef ARM_ULIB # define SYSTNAME "acorn" #endif #ifdef nosve # define DIRSEP "." #endif -#ifdef __amigados__ +#ifdef __amigaos__ # define SYSTNAME "amiga" # define DIRSEP "/" #endif @@ -667,6 +718,36 @@ SCM softtype() #endif } +#ifdef PLAN9 +/* This code is adapted from /sys/src/ape/lib/ap/plan9/isatty.c. */ +int isatty (int fd) +{ + Dir d1, d2; + char buf[40]; + int t; + if (dirfstat(fd, &d1) < 0) return 0; + if (strncmp(d1.name, "ptty", 4) == 0) return 1; + if (dirstat("/dev/cons", &d2) < 0) return 0; + /* If we came in through con, /dev/cons is probably #d/0, which won't + * match stdin. Opening #d/0 and fstating it gives the values of the + * underlying channel */ + if (d2.type == 'd') { + strcpy(buf, "#d/"); + strcpy(buf+3, d2.name); + if ((t = open(buf, 0)) < 0) return 0; + if (dirfstat(t, &d2) < 0) { + close(t); + return 0; + } + close(t); + } + return (d1.type == d2.type) && (d1.dev == d2.dev); +} + +/* A temporary hack: give SCM our own errno. */ +int errno; +#endif + int init_buf0(inport) FILE *inport; { @@ -719,7 +800,7 @@ char *scm_find_execpath(argc, argv, script_arg) { char *exepath = 0; #ifndef macintosh -# ifdef unix +# ifdef HAVE_UNIX # ifndef MSDOS if (script_arg) exepath = script_find_executable(script_arg); # endif @@ -730,6 +811,26 @@ char *scm_find_execpath(argc, argv, script_arg) return exepath; } +#ifdef PLAN9 +int system(command) + const char *command; +{ + int sts; + int pid = fork(); + if (pid) { + Waitmsg wm; + sts = -1; + while (wait(&wm) != -1) { + if (pid==atoi(wm.pid)) { + sts = 0; + break; + } + } + } else sts = execl("/bin/rc", "/bin/rc", "-c", command, nil); + return sts; +} +#endif + #ifndef _Windows char s_system[] = "system"; SCM lsystem(cmd) @@ -838,9 +939,18 @@ void init_features() #ifdef SIGALRM # ifdef SIGPROF make_subr(s_setitimer, tc7_subr_3, scm_setitimer); - setitimer_iv[0] = CAR(sysintern("real", UNDEFINED)); - setitimer_iv[1] = CAR(sysintern("virtual", UNDEFINED)); - setitimer_iv[2] = CAR(sysintern("profile", UNDEFINED)); +# ifdef ITIMER_REAL + setitimer_tab[0].sym = CAR(sysintern("real", UNDEFINED)); + setitimer_tab[0].which = ITIMER_REAL; +# endif +# ifdef ITIMER_VIRTUAL + setitimer_tab[1].sym = CAR(sysintern("virtual", UNDEFINED)); + setitimer_tab[1].which = ITIMER_VIRTUAL; +# endif +# ifdef ITIMER_PROF + setitimer_tab[2].sym = CAR(sysintern("profile", UNDEFINED)); + setitimer_tab[2].which = ITIMER_PROF; +# endif # endif #endif #ifdef TICKS @@ -856,5 +966,5 @@ void init_features() #ifdef vms add_feature(s_ed); #endif - sysintern("*scm-version*", makfrom0str(SCMVERSION)); + sysintern("*scm-version*", CAR(sysintern(SCMVERSION, UNDEFINED))); } @@ -1,49 +1,50 @@ -SCM(Dec 5 1998) SCM(Dec 5 1998) +SCM(Jan 4 2000) SCM(Jan 4 2000) NAME scm - a Scheme Language Interpreter SYNOPSIS - scm [-a kbytes ] [-ibvqmu] [-p number ] [-c expression ] - [-e expression ] [-f filename ] [-l filename ] [-d file- - name ] [-r feature ] [-- | - | -s] [filename] [arguments - ...] + scm [-a kbytes ] [-muvqib] [--version] [--help] + [[-]-no-init-file] [-p int ] [-r feature ] [-h feature ] + [-d filename ] [-f filename ] [-l filename ] + [-c expression ] [-e expression ] [-o dumpname ] + [-- | - | -s] [ filename ] [ arguments ... ] DESCRIPTION Scm is a Scheme interpreter. - Upon startup scm loads the file specified by by the envi- - ronment variable SCM_INIT_PATH or by the parameter + Upon startup scm loads the file specified by by the envi- + ronment variable SCM_INIT_PATH or by the parameter IMPLINIT in the makefile (or scmfig.h) if SCM_INIT_PATH is - not defined. The makefiles attempt to set IMPLINIT to + not defined. The makefiles attempt to set IMPLINIT to "Init.scm" in the source directory. - Unless the option -no-init-file occurs in the command - line, "Init.scm" checks to see if there is file - "ScmInit.scm" in the path specified by the environment - variable HOME (or in the current directory if HOME is + Unless the option -no-init-file or --no-init-file occurs + in the command line, "Init.scm" checks to see if there is + file "ScmInit.scm" in the path specified by the environ- + ment variable HOME (or in the current directory if HOME is undefined). If it finds such a file it is loaded. - "Init.scm" then looks for command input from one of three - sources: From an option on the command line, from a file + "Init.scm" then looks for command input from one of three + sources: From an option on the command line, from a file named on the command line, or from standard input. OPTIONS - The options are processed in the order specified on the + The options are processed in the order specified on the command line. -akbytes - specifies that scm should allocate an initial heap- + specifies that scm should allocate an initial heap- size of kbytes. This option, if present, must be the first on the command line. -no-init-file - Inhibits the loading of "ScmInit.scm" as described + Inhibits the loading of "ScmInit.scm" as described above. -eexpression @@ -51,13 +52,12 @@ OPTIONS -cexpression specifies that the scheme expression expression is to be evaluated. These options are inspired by perl and - sh respectively. On Amiga systems the entire option - and argument need to be enclosed in qoutes. For + sh respectively. On Amiga systems the entire option + and argument need to be enclosed in qoutes. For instance "-e(newline)". -rfeature requires feature. This will load a file from SLIB if - that feature is not already supported. If feature is @@ -67,103 +67,118 @@ OPTIONS -SCM(Dec 5 1998) SCM(Dec 5 1998) +SCM(Jan 4 2000) SCM(Jan 4 2000) - 2, 3, 4, or 5 scm will require the features necces- - sary to support R2RS, R3RS, R4RS, or R5RS, respec- + that feature is not already supported. If feature is + 2, 3, 4, or 5 scm will require the features necces- + sary to support R2RS, R3RS, R4RS, or R5RS, respec- tively. + -hfeature + provides feature. + -lfilename -ffilename loads filename. Scm will load the first (unoptioned) - file named on the command line if no -c, -e, -f, -l, + file named on the command line if no -c, -e, -f, -l, or -s option preceeds it. -dfilename - opens (read-only) the extended relational database - filename. If filename contains initialization code, + opens (read-only) the extended relational database + filename. If filename contains initialization code, it will be run when the database is opened. + -odumpname + saves the current SCM session as the executable pro- + gram dumpname. This option works only in SCM builds + supporting dump. + + If options appear on the command line after -o dump- + name, then the saved session will continue with pro- + cessing those options when it is invoked. Otherwise + the (new) command line is processed as usual when the + saved image is invoked. + -plevel - sets the prolixity (verboseness) to level. This is + sets the prolixity (verboseness) to level. This is the same as the scm command (verobse level ). -v (verbose mode) specifies that scm will print prompts, - evaluation times, notice of loading files, and - garbage collection statistics. This is the same as + evaluation times, notice of loading files, and + garbage collection statistics. This is the same as -p3. - -q (quiet mode) specifies that scm will print no extra + -q (quiet mode) specifies that scm will print no extra information. This is the same as -p0. - -m specifies that subsequent loads, evaluations, and + -m specifies that subsequent loads, evaluations, and user interactions will be with R4RS macro capability. To use a specific R4RS macro implementation from SLIB (instead of SLIB's default) put -r macropackage before -m on the command line. - -u specifies that subsequent loads, evaluations, and + -u specifies that subsequent loads, evaluations, and user interactions will be without R4RS macro capabil- ity. R4RS macro capability can be restored by a sub- sequent -m on the command line or from Scheme code. - -i specifies that scm should run interactively. That - means that scm will not terminate until the (quit) or - (exit) command is given, even if there are errors. - It also sets the prolixity level to 2 if it is less - than 2. This will print prompts, evaluation times, - and notice of loading files. The prolixity level can - be set by subsequent options. If scm is started from - a tty, it will assume that it should be interactive - unless given a subsequent -b option. - -b specifies that scm should run non-interactively. - That means that scm will terminate after processing - the command line or if there are errors. - -s specifies, by analogy with sh, that further options + 2 - 2 +SCM(Jan 4 2000) SCM(Jan 4 2000) -SCM(Dec 5 1998) SCM(Dec 5 1998) + -i specifies that scm should run interactively. That + means that scm will not terminate until the (quit) or + (exit) command is given, even if there are errors. + It also sets the prolixity level to 2 if it is less + than 2. This will print prompts, evaluation times, + and notice of loading files. The prolixity level can + be set by subsequent options. If scm is started from + a tty, it will assume that it should be interactive + unless given a subsequent -b option. + -b specifies that scm should run non-interactively. + That means that scm will terminate after processing + the command line or if there are errors. + -s specifies, by analogy with sh, that further options are to be treated as program aguments. - - -- specifies that there are no more options on the + - -- specifies that there are no more options on the command line. ENVIRONMENT VARIABLES SCM_INIT_PATH - is the pathname where scm will look for its initial- - ization code. The default is the file "Init.scm" in + is the pathname where scm will look for its initial- + ization code. The default is the file "Init.scm" in the source directory. SCHEME_LIBRARY_PATH is the SLIB Scheme library directory. - HOME is the directory where "Init.scm" will look for the + HOME is the directory where "Init.scm" will look for the user initialization file "ScmInit.scm". SCHEME VARIABLES *argv* contains the list of arguments to the program. - *argv* can change during argument processing. This - list is suitable for use as an argument to SLIB + *argv* can change during argument processing. This + list is suitable for use as an argument to SLIB getopt. *R4RS-macro* controls whether loading and interaction support R4RS macros. Define this in "ScmInit.scm" or files speci- - fied on the command line. This can be overridden by + fied on the command line. This can be overridden by subsequent -m and -u options. *interactive* @@ -173,39 +188,41 @@ SCHEME VARIABLES subsequent -i and -b options. EXAMPLES - % scm foo.scm arg1 arg2 arg3 - Load and execute the contents of foo.scm. Parameters - arg1 arg2 and arg3 are stored in the global list - *argv*. - % scm -f foo.scm arg1 arg2 arg3 - The same. - % scm -s foo.scm arg1 arg2 - Set *argv* to ("foo.scm" "arg1" "arg2") and enter - interactive session. - % scm -e '(display (list-ref *argv* *optind*))' bar - Print ``bar'' - % scm -rpretty-print -r format -i - Load pretty-print and format and enter interactive + + 3 - 3 +SCM(Jan 4 2000) SCM(Jan 4 2000) + % scm foo.scm arg1 arg2 arg3 + Load and execute the contents of foo.scm. Parameters + arg1 arg2 and arg3 are stored in the global list + *argv*. -SCM(Dec 5 1998) SCM(Dec 5 1998) + % scm -f foo.scm arg1 arg2 arg3 + The same. + + % scm -s foo.scm arg1 arg2 + Set *argv* to ("foo.scm" "arg1" "arg2") and enter + interactive session. + % scm -e '(display (list-ref *argv* *optind*))' bar + Print ``bar'' + % scm -rpretty-print -r format -i + Load pretty-print and format and enter interactive mode. % scm -r5 - Load dynamic-wind, values, and R4RS macros and enter + Load dynamic-wind, values, and R4RS macros and enter interactive (with macros) mode. % scm -r5 -r4 @@ -213,73 +230,73 @@ SCM(Dec 5 1998) SCM(Dec 5 1998) loaded. FEATURES - Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, - Unicos, VMS, Unix and similar systems. Support for ASCII + Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, + Unicos, VMS, Unix and similar systems. Support for ASCII and EBCDIC character sets. - Conforms to Revised^5 Report on the Algorithmic Language + Conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Support for SICP, R2RS, R3RS, and R4RS scheme code. Many Common Lisp functions: logand, logor, logxor, lognot, - ash, logcount, integer-length, bit-extract, defmacro, - macroexpand, macroexpand1, gentemp, defvar, force-output, - software-type, get-decoded-time, get-internal-run-time, + ash, logcount, integer-length, bit-extract, defmacro, + macroexpand, macroexpand1, gentemp, defvar, force-output, + software-type, get-decoded-time, get-internal-run-time, get-internal-real-time, delete-file, rename-file, copy- tree, acons, and eval. - Char-code-limit, most-positive-fixnum, most-negative- - fixnum, and internal-time-units-per-second constants. + Char-code-limit, most-positive-fixnum, most-negative- + fixnum, and internal-time-units-per-second constants. *Features* and *load-pathname* variables. - Arrays and bit-vectors. String ports and software emula- - tion ports. I/O extensions providing most of ANSI C and + Arrays and bit-vectors. String ports and software emula- + tion ports. I/O extensions providing most of ANSI C and POSIX.1 facilities. - User definable responses to interrupts and errors, Pro- - cess-syncronization primitives, String regular expression - matching, and the CURSES screen management package. + User definable responses to interrupts and errors, Pro- + cess-syncronization primitives, String regular expression - Available add-on packages including an interactive debug- - ger, database, X-window graphics, BGI graphics, Motif, and - Open-Windows packages. - A compiler (HOBBIT, available separately) and dynamic - linking of compiled modules. - Setable levels of monitoring and timing information - printed interactively (the `verbose' function). Restart, - quit, and exec. + 4 -FILES - scm.texi - Texinfo documentation of scm enhancements, internal - representations, and how to extend or include scm - 4 +SCM(Jan 4 2000) SCM(Jan 4 2000) + matching, and the CURSES screen management package. + Available add-on packages including an interactive debug- + ger, database, X-window graphics, BGI graphics, Motif, and + Open-Windows packages. -SCM(Dec 5 1998) SCM(Dec 5 1998) + A compiler (HOBBIT, available separately) and dynamic + linking of compiled modules. + Setable levels of monitoring and timing information + printed interactively (the `verbose' function). Restart, + quit, and exec. +FILES + scm.texi + Texinfo documentation of scm enhancements, internal + representations, and how to extend or include scm in other programs. AUTHORS - Aubrey Jaffer (jaffer @ ai.mit.edu) - Radey Shouman (Radey.Shouman @ splashtech.com) + Aubrey Jaffer (jaffer @ alum.mit.edu) + Radey Shouman (shouman @ ne.mediaone.net) BUGS SEE ALSO The SCM home-page: http://swissnet.ai.mit.edu/~jaffer/SCM.html - The Scheme specifications for details on specific proce- + The Scheme specifications for details on specific proce- dures (http://swissnet.ai.mit.edu/ftpdir/scheme-reports/) or @@ -308,23 +325,6 @@ SEE ALSO - - - - - - - - - - - - - - - - - 5 @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -51,6 +51,16 @@ extern "C" { # endif #endif +#ifdef PLAN9 +# include <u.h> +# include <libc.h> +/* Simple imitation of some Unix system calls */ +# define exit(val) exits("") +# define getcwd getwd +/* we have our own isatty */ +int isatty (int); +#endif + typedef long SCM; typedef struct {SCM car, cdr;} cell; typedef struct {long sname;SCM (*cproc)();} subr; @@ -100,15 +110,17 @@ typedef struct { int (*fflush)P((FILE *stream)); int (*fgetc)P((FILE *p)); int (*fclose)P((FILE *p)); + int (*ungetc)P((int c, SCM p)); } ptobfuns; typedef struct { + SCM data; + SCM port; long flags; - int unread; long line; + int unread; short col; short colprev; - SCM data; } port_info; typedef struct { @@ -143,16 +155,13 @@ typedef struct {SCM type;double *real;} dbl; #define ICHR(x) ((unsigned char)((x)>>8)) #define MAKICHR(x) (((x)<<8)+0xf4L) -#define ILOCP(n) ((0xff & (int)(n))==0xfc) #define ILOC00 (0x000000fcL) -#define IDINC (0x00100000L) -#define ICDR (0x00080000L) -#define IFRINC (0x00000100L) -#define IDSTMSK (-IDINC) -#define MAKILOC(if, id) (ILOC00 + (((long)id)<<20) + (((long)if)<<8)) -#define IFRAME(n) ((int)((ICDR-IFRINC)>>8) & ((int)(n)>>8)) -#define IDIST(n) (((unsigned long)(n))>>20) +#define ILOCP(n) ((0xff & (int)(n))==(int)ILOC00) +#define MAKILOC(if, id) (ILOC00 + (((long)id)<<8) + (((long)if)<<16)) +#define IDIST(n) (((int)(n)>>8) & 0x7f) +#define IFRAME(n) (((int)(n)>>16)) #define ICDRP(n) (ICDR & (n)) +#define ICDR (1L<<15) /* ISYMP tests for ISPCSYM and ISYM */ #define ISYMP(n) ((0x187 & (int)(n))==4) @@ -165,6 +174,9 @@ typedef struct {SCM type;double *real;} dbl; #define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) #define MAKISYM(n) (((n)<<9)+0x74L) #define MAKIFLAG(n) (((n)<<9)+0x174L) +/* This is to make the print representation of some evaluated code, + as in backtraces, make a little more sense. */ +#define MAKSPCSYM2(work, look) ((127L & (work)) | ((127L<<9) & (look))) extern char *isymnames[]; #define NUM_ISPCSYM 14 @@ -181,7 +193,7 @@ extern char *isymnames[]; #define IM_OR MAKSPCSYM(10) #define IM_QUOTE MAKSPCSYM(11) #define IM_SET MAKSPCSYM(12) -#define IM_DEFINE MAKSPCSYM(13) +#define IM_FUNCALL MAKSPCSYM(13) #define s_and (ISYMCHARS(IM_AND)+2) #define s_begin (ISYMCHARS(IM_BEGIN)+2) @@ -199,23 +211,38 @@ extern char *isymnames[]; #define s_define (ISYMCHARS(IM_DEFINE)+2) #define s_delay (ISYMCHARS(IM_DELAY)+2) #define s_quasiquote (ISYMCHARS(IM_QUASIQUOTE)+2) +#define s_let_syntax (ISYMCHARS(IM_LET_SYNTAX)+2) extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; #define s_apply (ISYMCHARS(IM_APPLY)+2) -/* each symbol defined here must have a unique number which */ - /* corresponds to it's position in isymnames[] in sys.c */ +/* each symbol defined here must have a unique number which + corresponds to it's position in isymnames[] in repl.c */ + /* These are used for dispatch in eval.c */ #define IM_APPLY MAKISYM(14) #define IM_FARLOC_CAR MAKISYM(15) #define IM_FARLOC_CDR MAKISYM(16) #define IM_DELAY MAKISYM(17) #define IM_QUASIQUOTE MAKISYM(18) -#define IM_UNQUOTE MAKISYM(19) -#define IM_UQ_SPLICING MAKISYM(20) -#define IM_ELSE MAKISYM(21) -#define IM_ARROW MAKISYM(22) - -#define NUM_ISYMS 23 +#define IM_EVAL_FOR_APPLY MAKISYM(19) +#define IM_LET_SYNTAX MAKISYM(20) +#define IM_ACRO_CALL MAKISYM(21) +#define IM_LINUM MAKISYM(22) +#define IM_DEFINE MAKISYM(23) + + /* These are not used for dispatch. */ +#define IM_UNQUOTE MAKISYM(24) +#define IM_UQ_SPLICING MAKISYM(25) +#define IM_ELSE MAKISYM(26) +#define IM_ARROW MAKISYM(27) +#define IM_VALUES_TOKEN MAKISYM(28) +#define IM_KEYWORD MAKISYM(29) + +#define SCM_MAKE_LINUM(n) (IM_LINUM | ((unsigned long)(n))<<16) +#define SCM_LINUM(x) ((unsigned long)(x)>>16) +#define SCM_LINUMP(x) ((0xffffL & (x))==IM_LINUM) + +#define NUM_ISYMS 30 #define BOOL_F MAKIFLAG(NUM_ISYMS+0) #define BOOL_T MAKIFLAG(NUM_ISYMS+1) @@ -267,6 +294,7 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; #define CONSP(x) (!NCONSP(x)) #define ECONSP(x) (CONSP(x) || (1==TYP3(x))) #define NECONSP(x) (NCONSP(x) && (1 != TYP3(x))) +#define SCM_GLOCP(x) (tc3_cons_gloc==(7 & (int)(x))) #define CAR(x) (((cell *)(SCM2PTR(x)))->car) #define CDR(x) (((cell *)(SCM2PTR(x)))->cdr) @@ -280,16 +308,39 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; #define GCENV ENV #define ARGC(x) ((6L & CDR(x))>>1) #ifdef CAUTIOUS -# define SCM_ESTK_FRLEN 3 +# define SCM_ESTK_FRLEN 4 #else -# define SCM_ESTK_FRLEN 2 +# define SCM_ESTK_FRLEN 3 #endif #define SCM_ESTK_BASE 4 #define SCM_ESTK_PARENT(v) (VELTS(v)[0]) #define SCM_ESTK_PARENT_WRITABLEP(v) (VELTS(v)[1]) #define SCM_ESTK_PARENT_INDEX(v) (VELTS(v)[2]) -extern long tc16_env; +extern long tc16_env, tc16_ident; #define ENVP(x) (tc16_env==TYP16(x)) +#define SCM_ENV_FORMALS CAR +#ifdef MACRO +# define M_IDENTP(x) (tc16_ident==TYP16(x)) +# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x)) +# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x)) +# define IDENT_PARENT(x) (M_IDENT_LEXP(x) ? CAR(CDR(x)) : CDR(x)) +# define IDENT_ENV(x) (M_IDENT_LEXP(x) ? CDR(CDR(x)) : BOOL_F) +#else +# define IDENTP SYMBOLP +# define M_IDENTP(x) (0) +#endif + + /* markers for various static environment frame types */ + /* FIXME these need to be exported somehow to Scheme */ +#ifdef CAUTIOUS +# define SCM_ENV_FILENAME MAKINUM(1) +# define SCM_ENV_PROCNAME MAKINUM(2) +#endif +#define SCM_ENV_DOC MAKINUM(3) +#define SCM_ENV_ANNOTATION MAKINUM(4) +#define SCM_ENV_CONSTANT MAKINUM(5) +#define SCM_ENV_SYNTAX MAKINUM(6) +#define SCM_ENV_END MAKINUM(7) #define PORTP(x) (TYP7(x)==tc7_port) #define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN)) @@ -354,7 +405,7 @@ extern long tc16_env; #define MAKE_NUMDIGS(v, t) ((((v)+0L)<<16)+(t)) #define SETNUMDIGS(x, v, t) CAR(x) = MAKE_NUMDIGS(v, t) -#define SNAME(x) ((char *)(subr_table[NUMDIGS(x)].name)) +#define SNAME(x) ((char *)(subrs[NUMDIGS(x)].name)) #define SUBRF(x) (((subr *)(SCM2PTR(x)))->cproc) #define DSUBRF(x) (((dsubr *)(SCM2PTR(x)))->dproc) #define CCLO_SUBR(x) (VELTS(x)[0]) @@ -392,26 +443,37 @@ extern long tc16_array; #define SMOBNUM(x) (0x0ff & (CAR(x)>>8)) #define PTOBNUM(x) (0x0ff & (CAR(x)>>8)) #define SCM_PORTNUM(x) ((int)(((unsigned long)CAR(x))>>20)) +#define SCM_PORTNUM_MAX ((int)((0x7fffUL<<20)>>20)) #define SCM_PORTFLAGS(x) (scm_port_table[SCM_PORTNUM(x)].flags) #define SCM_PORTDATA(x) (scm_port_table[SCM_PORTNUM(x)].data) +#define SCM_SETFLAGS(x, flags) (CAR(x) = (CAR(x) & ~0x0f0000L) | (flags)) +/* This is used (only) for closing ports. */ +#define SCM_SET_PTOBNUM(x, typ) (CAR(x)=(typ)|(CAR(x) & ~0x0ffffL)) #define DIGITS '0':case '1':case '2':case '3':case '4':\ case '5':case '6':case '7':case '8':case '9' /* Aggregated types for dispatch in switch statements. */ -#define tcs_cons_imcar 2:case 4:case 6:case 10:\ - case 12:case 14:case 18:case 20:\ - case 22:case 26:case 28:case 30:\ - case 34:case 36:case 38:case 42:\ - case 44:case 46:case 50:case 52:\ - case 54:case 58:case 60:case 62:\ - case 66:case 68:case 70:case 74:\ - case 76:case 78:case 82:case 84:\ - case 86:case 90:case 92:case 94:\ - case 98:case 100:case 102:case 106:\ - case 108:case 110:case 114:case 116:\ - case 118:case 122:case 124:case 126 +#define tcs_cons_inum 2: case 6:case 10:case 14:\ + case 18:case 22:case 26:case 30:\ + case 34:case 38:case 42:case 46:\ + case 50:case 54:case 58:case 62:\ + case 66:case 70:case 74:case 78:\ + case 82:case 86:case 90:case 94:\ + case 98:case 102:case 106:case 110:\ + case 114:case 118:case 122:case 126 +#define tcs_cons_iloc 124 +#define tcs_cons_ispcsym 4:case 12:case 20:case 28:\ + case 36:case 44:case 52:case 60:\ + case 68:case 76:case 84:case 92:\ + case 100:case 108 +#define tcs_cons_chflag 116 /* char *or* flag */ +#define tcs_cons_imcar tcs_cons_inum:\ + case tcs_cons_iloc:\ + case tcs_cons_ispcsym:\ + case tcs_cons_chflag + #define tcs_cons_nimcar 0:case 8:case 16:case 24:\ case 32:case 40:case 48:case 56:\ case 64:case 72:case 80:case 88:\ @@ -438,6 +500,7 @@ extern long tc16_array; #define tc3_cons_imcar 2:case 4:case 6 #define tc3_cons_gloc 1 #define tc3_closure 3 +#define tc3_tc7_types 5:case 7 #define tc7_ssymbol 5 #define tc7_msymbol 7 @@ -477,6 +540,8 @@ extern long tc16_array; #define tc16_call_cc (tc7_specfun | (1L<<8)) #define tc16_cclo (tc7_specfun | (2L<<8)) #define tc16_eval (tc7_specfun | (3L<<8)) +#define tc16_values (tc7_specfun | (4L<<8)) +#define tc16_call_wv (tc7_specfun | (5L<<8)) #define tc16_flo 0x017f #define tc_flo 0x017fL @@ -489,17 +554,21 @@ extern long tc16_array; #define tc16_bigpos 0x027f #define tc16_bigneg 0x037f + /* The first four flags fit in the car of a port cell, remaining + flags only in the port table */ #define OPN (1L<<16) #define RDNG (2L<<16) #define WRTNG (4L<<16) #define CRDY (8L<<16) + #define TRACKED (16L<<16) #define BINARY (32L<<16) #define BUF0 (64L<<16) +#define EXCLUSIVE (128L<<16) /* LSB is used for gc mark */ -extern scm_gra subr_table_gra; -#define subr_table ((subr_info *)(subr_table_gra.elts)) +extern scm_gra subrs_gra; +#define subrs ((subr_info *)(subrs_gra.elts)) /* extern sizet numsmob, numptob; extern smobfuns *smobs; extern ptobfuns *ptobs; @@ -517,30 +586,32 @@ extern port_info *scm_port_table; #define tc16_strport (tc7_port + 2*256L) #define tc16_sfport (tc7_port + 3*256L) extern long tc16_dir; +extern long tc16_clport; extern SCM sys_protects[]; -#define cur_inp sys_protects[0] -#define cur_outp sys_protects[1] -#define cur_errp sys_protects[2] -#define def_inp sys_protects[3] -#define def_outp sys_protects[4] -#define def_errp sys_protects[5] -#define sys_errp sys_protects[6] -#define sys_safep sys_protects[7] -#define listofnull sys_protects[8] -#define undefineds sys_protects[9] -#define nullvect sys_protects[10] -#define nullstr sys_protects[11] -#define progargs sys_protects[12] -#define loadports sys_protects[13] -#define rootcont sys_protects[14] -#define dynwinds sys_protects[15] -#ifdef FLOATS -# define flo0 sys_protects[16] -# define NUM_PROTECTS 17 -#else -# define NUM_PROTECTS 16 -#endif +#define cur_inp sys_protects[0] +#define cur_outp sys_protects[1] +#define cur_errp sys_protects[2] +#define def_inp sys_protects[3] +#define def_outp sys_protects[4] +#define def_errp sys_protects[5] +#define sys_errp sys_protects[6] +#define sys_safep sys_protects[7] +#define listofnull sys_protects[8] +#define undefineds sys_protects[9] +#define nullvect sys_protects[10] +#define nullstr sys_protects[11] +#define progargs sys_protects[12] +#define loadports sys_protects[13] +#define rootcont sys_protects[14] +#define dynwinds sys_protects[15] +#define list_unspecified sys_protects[16] +#define f_evapply sys_protects[17] +#define eval_env sys_protects[18] +#define f_apply_closure sys_protects[19] +#define flo0 sys_protects[20] +#define scm_uprotects sys_protects[21] +#define NUM_PROTECTS 22 /* now for connects between source files */ @@ -565,7 +636,7 @@ extern SCM *loc_loadpath; extern SCM *loc_errobj; extern SCM loadport; extern char *errjmp_bad; -extern int ints_disabled, output_deferred; +extern int ints_disabled, output_deferred, gc_hook_pending, gc_hook_active; extern unsigned long SIG_deferred; extern SCM exitval; extern int cursinit; @@ -593,6 +664,8 @@ extern char s_close_port[]; #define s_port_type (s_close_port+6) extern char s_call_cc[]; #define s_cont (s_call_cc+18) +extern char s_try_create_file[]; +extern char s_badenv[]; /* function prototypes */ @@ -618,24 +691,47 @@ SCM lflush P((SCM port)); void scm_init_gra P((scm_gra *gra, sizet eltsize, sizet len, sizet maxlen, char *what)); int scm_grow_gra P((scm_gra *gra, char *elt)); +void scm_trim_gra P((scm_gra *gra)); void scm_free_gra P((scm_gra *gra)); long newsmob P((smobfuns *smob)); long newptob P((ptobfuns *ptob)); -SCM scm_port_entry P((long ptype, long flags)); +SCM scm_port_entry P((FILE *stream, long ptype, long flags)); +SCM scm_open_ports P((void)); void prinport P((SCM exp, SCM port, char *type)); SCM repl P((void)); +void repl_report P((void)); void growth_mon P((char *obj, long size, char *units, int grewp)); void gc_start P((char *what)); void gc_end P((void)); void gc_mark P((SCM p)); +void scm_gc_hook P((void)); +SCM scm_gc_protect P((SCM obj)); +SCM scm_add_finalizer P((SCM value, SCM finalizer)); +void scm_run_finalizers P((int exiting)); void scm_egc_start P((void)); void scm_egc_end P((void)); void heap_report P((void)); +void gra_report P((void)); void exit_report P((void)); void stack_report P((void)); +SCM scm_stack_trace P((SCM contin)); +SCM scm_scope_trace P((SCM env)); +SCM scm_frame_trace P((SCM contin, SCM nf)); +SCM scm_frame2env P((SCM contin, SCM nf)); +SCM scm_frame_eval P((SCM contin, SCM nf, SCM expr)); void iprin1 P((SCM exp, SCM port, int writing)); void intprint P((long n, int radix, SCM port)); void iprlist P((char *hdr, SCM exp, int tlr, SCM port, int writing)); +SCM scm_env_lookup P((SCM var, SCM stenv)); +SCM scm_env_rlookup P((SCM addr, SCM stenv, char *what)); +SCM scm_env_getprop P((SCM prop, SCM env)); +SCM scm_env_addprop P((SCM prop, SCM val, SCM env)); +long num_frames P((SCM estk, int i)); +SCM *estk_frame P((SCM estk, int i, int nf)); +SCM *cont_frame P((SCM contin, int nf)); +SCM stacktrace1 P((SCM estk, int i)); +void scm_princode P((SCM code, SCM env, SCM port, int writing)); +void scm_princlosure P((SCM proc, SCM port, int writing)); void lputc P((int c, SCM port)); void lputs P((char *s, SCM port)); sizet lfwrite P((char *ptr, sizet size, sizet nitems, SCM port)); @@ -648,6 +744,7 @@ SCM my_time P((void)); SCM your_time P((void)); void init_iprocs P((iproc *subra, int type)); +void final_scm P((int)); void init_sbrk P((void)); int init_buf0 P((FILE *inport)); void scm_init_from_argv P((int argc, char **argv, char *script_arg, @@ -659,6 +756,7 @@ void free_storage P((void)); char *dld_find_executable P((const char* command)); char *scm_find_execpath P((int argc, char **argv, char *script_arg)); void init_scm P((int iverbose, int buf0stdin, long init_heap_size)); +void scm_init_INITS P((void)); SCM scm_init_extensions P((void)); void init_user_scm P((void)); void ignore_signals P((void)); @@ -670,16 +768,17 @@ SCM markcdr P((SCM ptr)); #define mark0 (0) /*SCM mark0 P((SCM ptr)); */ SCM equal0 P((SCM ptr1, SCM ptr2)); sizet free0 P((CELLPTR ptr)); -void scm_warn P((char *str1, char *str2)); -void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr)); +void scm_warn P((char *str1, char *str2, SCM obj)); +void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr, int codep)); void wta P((SCM arg, char *pos, char *s_subr)); +void scm_experr P((SCM arg, char *pos, char *s_subr)); SCM intern P((char *name, sizet len)); SCM sysintern P((const char *name, SCM val)); SCM sym2vcell P((SCM sym)); SCM makstr P((long len)); SCM scm_maksubr P((const char *name, int type, SCM (*fcn)())); SCM make_subr P((const char *name, int type, SCM (*fcn)())); -SCM make_synt P((const char *name, SCM (*macroizer)(), SCM (*fcn)())); +SCM make_synt P((const char *name, long flags, SCM (*fcn)())); SCM make_gsubr P((const char *name, int req, int opt, int rst, SCM (*fcn)())); SCM closure P((SCM code, int nargs)); @@ -688,12 +787,14 @@ SCM force P((SCM x)); SCM makarb P((SCM name)); SCM tryarb P((SCM arb)); SCM relarb P((SCM arb)); -SCM ceval P((SCM x, SCM env)); +SCM ceval P((SCM x, SCM static_env, SCM env)); +SCM scm_wrapcode P((SCM code, SCM env)); +SCM scm_current_env P((void)); SCM prolixity P((SCM arg)); SCM gc_for_newcell P((void)); void gc_for_open_files P((void)); SCM gc P((SCM arg)); -SCM tryload P((SCM filename)); +SCM tryload P((SCM filename, SCM reader)); SCM acons P((SCM w, SCM x, SCM y)); SCM cons2 P((SCM w, SCM x, SCM y)); SCM resizuve P((SCM vect, SCM len)); @@ -725,6 +826,9 @@ SCM exactp P((SCM x)); SCM inexactp P((SCM x)); SCM eqp P((SCM x, SCM y)); SCM lessp P((SCM x, SCM y)); +SCM greaterp P((SCM x, SCM y)); +SCM leqp P((SCM x, SCM y)); +SCM greqp P((SCM x, SCM y)); SCM zerop P((SCM z)); SCM positivep P((SCM x)); SCM negativep P((SCM x)); @@ -811,11 +915,16 @@ SCM map P((SCM proc, SCM arg1, SCM args)); SCM scm_make_cont P((void)); SCM copytree P((SCM obj)); SCM eval P((SCM obj)); +SCM scm_values P((SCM arg1, SCM arg2, SCM rest, char *what)); +SCM scm_eval_values P((SCM x, SCM static_env, SCM env)); SCM identp P((SCM obj)); SCM ident2sym P((SCM id)); SCM ident_eqp P((SCM id1, SCM id2, SCM env)); +int scm_nullenv_p P((SCM env)); SCM env2tree P((SCM env)); SCM renamed_ident P((SCM id, SCM env)); +SCM scm_check_linum P((SCM x, SCM *linum)); +SCM scm_add_linum P((SCM linum, SCM x)); SCM input_portp P((SCM x)); SCM output_portp P((SCM x)); SCM cur_input_port P((void)); @@ -829,6 +938,7 @@ SCM lread P((SCM port)); SCM scm_read_char P((SCM port)); SCM peek_char P((SCM port)); SCM eof_objectp P((SCM x)); +int scm_io_error P((SCM port, char *what)); SCM lwrite P((SCM obj, SCM port)); SCM display P((SCM obj, SCM port)); SCM newline P((SCM port)); @@ -837,11 +947,14 @@ SCM file_position P((SCM port)); SCM file_set_position P((SCM port, SCM pos)); SCM scm_port_line P((SCM port)); SCM scm_port_col P((SCM port)); +void scm_line_msg P((SCM file, SCM linum, SCM port)); +void scm_err_line P((char *what, SCM file, SCM linum, SCM port)); SCM lgetenv P((SCM nam)); SCM prog_args P((void)); SCM makacro P((SCM code)); SCM makmacro P((SCM code)); SCM makmmacro P((SCM code)); +SCM makidmacro P((SCM code)); void poll_routine P((void)); void tick_signal P((void)); void stack_check P((void)); @@ -941,6 +1054,7 @@ long pseudolong P((long x)); #endif int bigcomp P((SCM x, SCM y)); SCM bigequal P((SCM x, SCM y)); +int scm_bigdblcomp P((SCM b, double d)); /* "script.c" functions */ char * scm_cat_path P((char *str1, const char *str2, long n)); @@ -956,9 +1070,9 @@ void scm_ecache_report P((void)); void scm_estk_reset P((sizet size)); void scm_env_cons P((SCM x, SCM y)); void scm_env_cons2 P((SCM w, SCM x, SCM y)); -void scm_env_cons_tmp P((SCM x)); -void scm_env_v2lst P((int argc, SCM *argv)); -void scm_extend_env P((SCM names)); +void scm_env_cons3 P((SCM v, SCM w, SCM x, SCM y)); +void scm_env_v2lst P((long argc, SCM *argv)); +void scm_extend_env P((void)); void scm_egc P((void)); /* Global state for environment cache */ @@ -968,8 +1082,11 @@ extern SCM scm_env, scm_env_tmp; extern SCM scm_egc_roots[]; extern VOLATILE long scm_egc_root_index; extern SCM scm_estk; -extern SCM *scm_estk_v, *scm_estk_ptr; +extern SCM *scm_estk_v, *scm_estk_ptr; extern long scm_estk_size; +#ifndef RECKLESS +extern SCM scm_trace, scm_trace_env; +#endif #ifdef RECKLESS # define ASSERT(_cond, _arg, _pos, _subr) ; @@ -1001,8 +1118,8 @@ extern long scm_estk_size; #define VTALRM_SIGNAL 19 #define PROF_SIGNAL 20 -#define EVAL(x, env) (IMP(x)?(x):ceval((x), (env))) -#define SIDEVAL(x, env) if NIMP(x) ceval((x), (env)) +#define EVAL(x, env, venv) (IMP(x)?(x):ceval((x), (SCM)(env), (SCM)(venv))) +#define SIDEVAL(x, env, venv) if NIMP(x) ceval((x), (SCM)(env), (SCM)(venv)) #define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\ else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}} @@ -1,5 +1,4 @@ -This is Info file scm.info, produced by Makeinfo version 1.68 from the -input file scm.texi. +This is scm.info, produced by makeinfo version 4.0 from scm.texi. INFO-DIR-SECTION The Algorithmic Language Scheme START-INFO-DIR-ENTRY @@ -9,11 +8,11 @@ END-INFO-DIR-ENTRY File: scm.info, Node: Top, Next: Overview, Prev: (dir), Up: (dir) -This manual documents the SCM Scheme implementation. SCM version | -5d2 was released December 1999. The most recent information about SCM | -can be found on SCM's "WWW" home page: | +This manual documents the SCM Scheme implementation. SCM version +5d6 was released April 2002. The most recent information about SCM can | +be found on SCM's "WWW" home page: | - `http://swissnet.ai.mit.edu/~jaffer/SCM.html' + <http://swissnet.ai.mit.edu/~jaffer/SCM.html> Copyright (C) 1990-1999 Free Software Foundation @@ -52,82 +51,13 @@ machine independent platform for [JACAL], a symbolic algebra system. * Menu: -* Copying:: * SCM Features:: * SCM Authors:: +* Copying:: * Bibliography:: -File: scm.info, Node: Copying, Next: SCM Features, Prev: Overview, Up: Overview - -Copying -======= - - COPYRIGHT (c) 1989 BY - - PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. - - ALL RIGHTS RESERVED - -Permission to use, copy, modify, distribute and sell this software and -its documentation for any purpose and without fee is hereby granted, -provided that the above copyright notice appear in all copies and that -both that copyright notice and this permission notice appear in -supporting documentation, and that the name of Paradigm Associates Inc -not be used in advertising or publicity pertaining to distribution of -the software without specific, written prior permission. - -PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, -INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO -EVENT SHALL PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR -CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF -USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR -OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR -PERFORMANCE OF THIS SOFTWARE. - -gjc@paradigm.com - Phone: 617-492-6079 - -Paradigm Associates Inc -29 Putnam Ave, Suite 6 -Cambridge, MA 02138 - - Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 - - Free Software Foundation, Inc. - - 59 Temple Place, Suite 330, Boston, MA 02111, USA - -Permission to use, copy, modify, distribute, and sell this software and -its documentation for any purpose is hereby granted without fee, -provided that the above copyright notice appear in all copies and that -both that copyright notice and this permission notice appear in -supporting documentation. - - NO WARRANTY - -BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR -THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER -EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE -ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH -YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL -NECESSARY SERVICING, REPAIR OR CORRECTION. - -IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR -DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL -DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM -(INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED -INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF -THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR -OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. - - -File: scm.info, Node: SCM Features, Next: SCM Authors, Prev: Copying, Up: Overview +File: scm.info, Node: SCM Features, Next: SCM Authors, Prev: Overview, Up: Overview Features ======== @@ -177,16 +107,16 @@ Features function). `Restart', `quit', and `exec'. -File: scm.info, Node: SCM Authors, Next: Bibliography, Prev: SCM Features, Up: Overview +File: scm.info, Node: SCM Authors, Next: Copying, Prev: SCM Features, Up: Overview Authors ======= -Aubrey Jaffer (jaffer @ ai.mit.edu) +Aubrey Jaffer (jaffer @ alum.mit.edu) | Most of SCM. Radey Shouman - Arrays. `gsubr's, compiled closures, records, Ecache, syntax-rules + Arrays, `gsubr's, compiled closures, records, Ecache, syntax-rules macros, and "safeport"s. Jerry D. Hedden @@ -200,13 +130,87 @@ George Carrette "Siod", written by George Carrette, was the starting point for SCM. The major innovations taken from Siod are the evaluator's use of the C-stack and being able to garbage collect off the C-stack - (*note Garbage Collection::.). + (*note Garbage Collection::). There are many other contributors to SCM. They are acknowledged in the file `ChangeLog', a log of changes that have been made to scm. -File: scm.info, Node: Bibliography, Prev: SCM Authors, Up: Overview +File: scm.info, Node: Copying, Next: Bibliography, Prev: SCM Authors, Up: Overview + +Copyright +========= + +Authors have assigned their SCM copyrights to: + + + Free Software Foundation, Inc. + + 59 Temple Place, Suite 330, Boston, MA 02111, USA + +Permission to use, copy, modify, distribute, and sell this software and +its documentation for any purpose is hereby granted without fee, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation. + + NO WARRANTY + +BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR +THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER +EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE +ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH +YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL +NECESSARY SERVICING, REPAIR OR CORRECTION. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR +DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL +DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM +(INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED +INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF +THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR +OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + +SIOD copyright +============== + + + COPYRIGHT (c) 1989 BY + + PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. + + ALL RIGHTS RESERVED + +Permission to use, copy, modify, distribute and sell this software and +its documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation, and that the name of Paradigm Associates Inc +not be used in advertising or publicity pertaining to distribution of +the software without specific, written prior permission. + +PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, +INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO +EVENT SHALL PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR +CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF +USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. + +gjc@paradigm.com + Phone: 617-492-6079 + +Paradigm Associates Inc +29 Putnam Ave, Suite 6 +Cambridge, MA 02138 + + +File: scm.info, Node: Bibliography, Prev: Copying, Up: Overview Bibliography ============ @@ -215,15 +219,6 @@ Bibliography `IEEE Standard 1178-1990. IEEE Standard for the Scheme Programming Language.' IEEE, New York, 1991. -[Simply] - Brian Harvey and Matthew Wright. `Simply Scheme: Introducing - Computer Science' MIT Press, 1994 ISBN 0-262-08226-8 - -[SICP] - Harold Abelson and Gerald Jay Sussman with Julie Sussman. - `Structure and Interpretation of Computer Programs.' MIT Press, - Cambridge, 1985. - [R4RS] William Clinger and Jonathan Rees, Editors. Revised(4) Report on the Algorithmic Language Scheme. `ACM Lisp Pointers' Volume IV, @@ -243,19 +238,28 @@ Bibliography William Clinger Hygienic Macros Through Explicit Renaming `Lisp Pointers' Volume IV, Number 4 (December 1991), pp 17-23. -[GUILE] - Tom Lord. The Guile Architecture for Ubiquitous Computing. - `Usenix Symposium on Tcl/Tk', 1995. +[SICP] + Harold Abelson and Gerald Jay Sussman with Julie Sussman. + `Structure and Interpretation of Computer Programs.' MIT Press, + Cambridge, 1985. + +[Simply] + Brian Harvey and Matthew Wright. `Simply Scheme: Introducing + Computer Science' MIT Press, 1994 ISBN 0-262-08226-8 + +[SchemePrimer] + $B8$;tBg(B(Dai Inukai) `$BF~Lg(BScheme' + 1999$BG/(B12$B7n=iHG(B ISBN4-87966-954-7 [SLIB] Todd R. Eigenschink, Dave Love, and Aubrey Jaffer. SLIB, The - Portable Scheme Library. Version 2c5, Jan 1999. + Portable Scheme Library. Version 2c8, June 2000. *Note Top: (slib)Top. [JACAL] - Aubrey Jaffer. JACAL Symbolic Mathematics System. Version 1a9, - Jan 1999. + Aubrey Jaffer. JACAL Symbolic Mathematics System. Version 1b0, + Sep 1999. *Note Top: (jacal)Top. @@ -297,36 +301,25 @@ Making SCM ========== The SCM distribution has "Makefile" which contains rules for making -"scmlit", a "bare-bones" version of SCM sufficient for running -`build.scm'. `build.scm' is used to compile (or create scripts to -compile) full featured versions. +"scmlit", a "bare-bones" version of SCM sufficient for running `build'. +`build' is used to compile (or create scripts to compile) full +featured versions. Makefiles are not portable to the majority of platforms. If `Makefile' works for you, good; If not, I don't want to hear about it. If you -need to compile SCM without build.scm, there are several ways to -proceed: +need to compile SCM without build, there are several ways to proceed: - * Use SCM on a different platform to run `build.scm' to create a - script to build SCM; + * Use the build (http://swissnet.ai.mit.edu/~jaffer/buildscm.html) + web page to create custom batch scripts for compiling SCM. + + * Use SCM on a different platform to run `build' to create a script + to build SCM; - * Use another implementation of Scheme to run `build.scm' to create a + * Use another implementation of Scheme to run `build' to create a script to build SCM; * Create your own script or `Makefile'. - * Buy a SCM executable from jaffer @ ai.mit.edu. See the end of the - `ANNOUNCE' file in the distribution for details. - - * Use scmconfig (From: bos@scrg.cs.tcd.ie): - - Build and install scripts using GNU "autoconf" are available from - `scmconfig4e3.tar.gz' in the distribution directories. See - `README.unix' in `scmconfig4e3.tar.gz' for further instructions. - - *Note:* The last release of scmconfig (4e3) was on March 20, 1996. - I am moving it to the OLD subdirectory until someone submits an - update. - File: scm.info, Node: SLIB, Next: Building SCM, Prev: Making SCM, Up: Installing SCM @@ -335,22 +328,22 @@ SLIB [SLIB] is a portable Scheme library meant to provide compatibility and utility functions for all standard Scheme implementations. Although -SLIB is not *neccessary* to run SCM, I strongly suggest you obtain and +SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and install it. Bug reports about running SCM without SLIB have very low priority. SLIB is available from the same sites as SCM: - * swissnet.ai.mit.edu:/pub/scm/slib2c7.tar.gz | + * swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz | - * ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz | + * ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz | - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz | + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz | -Unpack SLIB (`tar xzf slib2c7.tar.gz' or `unzip -ao slib2c7.zip') in an | +Unpack SLIB (`tar xzf slib2d4.tar.gz' or `unzip -ao slib2d4.zip') in an | appropriate directory for your system; both `tar' and `unzip' will create the directory `slib'. Then create a file `require.scm' in the SCM "implementation-vicinity" -(this is the same directory as where the file `Init5d2.scm' is | +(this is the same directory as where the file `Init5d6.scm' is | installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") @@ -379,11 +372,12 @@ File: scm.info, Node: Building SCM, Next: Installing Dynamic Linking, Prev: S Building SCM ============ -The file "build.scm" builds and runs a relational database of how to -compile and link SCM executables. It has information for most platforms -which SCM has been ported to (of which I have been notified). Some of -this information is old, incorrect, or incomplete. Send corrections and -additions to jaffer @ ai.mit.edu. +The file "build" loads the file "build.scm", which constructs a +relational database of how to compile and link SCM executables. +`build.scm' has information for the platforms which SCM has been ported +to (of which I have been notified). Some of this information is old, +incorrect, or incomplete. Send corrections and additions to jaffer @ +ai.mit.edu. * Menu: @@ -397,57 +391,56 @@ File: scm.info, Node: Invoking Build, Next: Build Options, Prev: Building SCM Invoking Build -------------- -The *all* method will also work for MS-DOS and unix. Use the *all* -method if you encounter problems with `build.scm'. +The _all_ method will also work for MS-DOS and unix. Use the _all_ +method if you encounter problems with `build'. MS-DOS From the SCM source directory, type `build' followed by up to 9 command line arguments. unix - From the SCM source directory, type `./build.scm' followed by - command line arguments. + From the SCM source directory, type `./build' followed by command + line arguments. -*all* +_all_ From the SCM source directory, start `scm' or `scmlit' and type - `(load "build.scm")'. Alternatively, start `scm' or `scmlit' with - the command line argument `-ilbuild'. + `(load "build")'. Alternatively, start `scm' or `scmlit' with the + command line argument `-ilbuild'. Invoking build without the `-F' option will build or create a shell script with the `arrays', `inexact', and `bignums' options as defaults. - bash$ ./build.scm + bash$ ./build -| - #!/bin/sh + #! /bin/sh + # unix (linux) script created by SLIB/batch | + # ================ Write file with C defines | rm -f scmflags.h - echo '#define IMPLINIT "/home/jaffer/scm/Init5d2.scm"'>>scmflags.h | + echo '#define IMPLINIT "Init5d6.scm"'>>scmflags.h | echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h - gcc -O2 -c continue.c scm.c findexec.c script.c time.c repl.c scl.c \ - eval.c sys.c subr.c unif.c rope.c - gcc -rdynamic -o scm continue.o scm.o findexec.o script.o time.o \ - repl.o scl.o eval.o sys.o subr.o unif.o rope.o -lm -lc + # ================ Compile C source files | + gcc -O2 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c + # ================ Link C object files | + gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc To cross compile for another platform, invoke build with the `-p' or `--platform=' option. This will create a script for the platform named in the `-p' or `--platform=' option. - bash$ ./build.scm -p vms + bash$ ./build -o scmlit -p darwin -F lit | -| - $DELETE scmflags.h - $CREATE scmflags.h - $DECK - #define IMPLINIT "/home/jaffer/scm/Init5d2.scm" | - #define BIGNUMS - #define FLOATS - #define ARRAYS - $EOD - $ cc continue scm findexec script time repl scl eval sys subr unif rope - $ macro setjump - $ link continue,scm,findexec,script,time,repl,scl,eval,sys,subr,unif,rope,setjump,sys$input/opt - -lc,sys$share:vaxcrtl/share - $RENAME continue.exe scm.exe + #! /bin/sh | + # unix (darwin) script created by SLIB/batch | + # ================ Write file with C defines | + rm -f scmflags.h | + echo '#define IMPLINIT "Init5d6.scm"'>>scmflags.h | + # ================ Compile C source files | + cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c + # ================ Link C object files | + mv -f scmlit scmlit~ | + cc -o scmlit continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o File: scm.info, Node: Build Options, Next: Compiling and Linking Custom Files, Prev: Invoking Build, Up: Building SCM @@ -463,45 +456,48 @@ the SCM command line options. - Build Option: --platform=PLATFORM-NAME specifies that the compilation should be for a computer/operating-system combination called PLATFORM-NAME. - *Note:* The case of PLATFORM-NAME is distinguised. The current + _Note:_ The case of PLATFORM-NAME is distinguised. The current PLATFORM-NAMEs are all lower-case. The platforms defined by table "platform" in `build.scm' are: - Table: platform - name processor operating-system compiler - () processor-family operating-system () | - symbol processor-family operating-system symbol - symbol atom symbol symbol - ================= ================= ================= ================= + Table: platform | + name processor operating-system compiler | + #f processor-family operating-system #f | + symbol processor-family operating-system symbol | + symbol atom symbol symbol | + ================= ================= ================= ================= | *unknown* *unknown* unix cc | acorn-unixlib acorn *unknown* cc | aix powerpc aix cc | - alpha alpha osf1 cc + alpha alpha osf1 cc | alpha-elf alpha unix cc | - alpha-linux alpha linux gcc + alpha-linux alpha linux gcc | amiga-aztec m68000 amiga cc | amiga-dice-c m68000 amiga dcc | - amiga-gcc m68000 amiga gcc + amiga-gcc m68000 amiga gcc | amiga-sas m68000 amiga lc | - atari-st-gcc m68000 atari.st gcc + atari-st-gcc m68000 atari.st gcc | atari-st-turbo-c m68000 atari.st tcc | borland-c 8086 ms-dos bcc | - cygwin32 i386 unix gcc - djgpp i386 ms-dos gcc - freebsd i386 unix cc - gcc *unknown* unix gcc + cygwin32 i386 unix gcc | + darwin powerpc unix cc | + djgpp i386 ms-dos gcc | + freebsd i386 unix cc | + gcc *unknown* unix gcc | highc i386 ms-dos hc386 | hp-ux hp-risc hp-ux cc | - irix mips irix gcc - linux i386 linux gcc - linux-aout i386 linux gcc + irix mips irix gcc | + linux i386 linux gcc | + linux-aout i386 linux gcc | microsoft-c 8086 ms-dos cl | microsoft-c-nt i386 ms-dos cl | microsoft-quick-c 8086 ms-dos qcl | ms-dos 8086 ms-dos cc | + openbsd *unknown* unix gcc | os/2-cset i386 os/2 icc | - os/2-emx i386 os/2 gcc + os/2-emx i386 os/2 gcc | + plan9-8 i386 plan9 8c | sunos sparc sunos cc | svr4 *unknown* unix cc | svr4-gcc-sun-ld sparc sunos gcc | @@ -509,7 +505,7 @@ the SCM command line options. unicos cray unicos cc | unix *unknown* unix cc | vms vax vms cc | - vms-gcc vax vms gcc + vms-gcc vax vms gcc | watcom-9.0 i386 ms-dos wcc386p | - Build Option: -o FILENAME @@ -543,9 +539,9 @@ the SCM command line options. - Build Option: -s PATHNAME - Build Option: --scheme-initial=PATHNAME specifies that PATHNAME should be the default location of the SCM - initialization file `Init5d2.scm'. SCM tries several likely | + initialization file `Init5d6.scm'. SCM tries several likely | locations before resorting to PATHNAME (*note File-System - Habitat::.). If not specified, the current directory (where build + Habitat::). If not specified, the current directory (where build is building) is used. - Build Option: -c PATHNAME ... @@ -590,7 +586,7 @@ the SCM command line options. * vms - * amigados + * amigaos (was amigados) | * system @@ -611,23 +607,23 @@ the SCM command line options. specifies to build the given features into the executable. The defined features are: - "array" | - Alias for ARRAYS | - | - "array-for-each" | - array-map! and array-for-each (arrays must also be featured). | - | - "arrays" | - Use if you want arrays, uniform-arrays and uniform-vectors. | - | - "bignums" | - Large precision integers. | - | - "careful-interrupt-masking" | - Define this for extra checking of interrupt masking and some | - simple checks for proper use of malloc and free. This is for | - debugging C code in `sys.c', `eval.c', `repl.c' and makes the | - interpreter several times slower than usual. | + "array" + Alias for ARRAYS + + "array-for-each" + array-map! and array-for-each (arrays must also be featured). + + "arrays" + Use if you want arrays, uniform-arrays and uniform-vectors. + + "bignums" + Large precision integers. + + "careful-interrupt-masking" + Define this for extra checking of interrupt masking and some + simple checks for proper use of malloc and free. This is for + debugging C code in `sys.c', `eval.c', `repl.c' and makes the + interpreter several times slower than usual. "cautious" Normally, the number of arguments arguments to interpreted @@ -638,125 +634,125 @@ the SCM command line options. always check the number of arguments to interpreted closures define feature `cautious'. - "cheap-continuations" | - If you only need straight stack continuations, executables | - compile with this feature will run faster and use less | - storage than not having it. Machines with unusual stacks | - *need* this. Also, if you incorporate new C code into scm | - which uses VMS system services or library routines (which | - need to unwind the stack in an ordrly manner) you may need to | - use this feature. | + "cheap-continuations" + If you only need straight stack continuations, executables + compile with this feature will run faster and use less + storage than not having it. Machines with unusual stacks + _need_ this. Also, if you incorporate new C code into scm + which uses VMS system services or library routines (which + need to unwind the stack in an ordrly manner) you may need to + use this feature. - "compiled-closure" | - Use if you want to use compiled closures. | + "compiled-closure" + Use if you want to use compiled closures. - "curses" | - For the "curses" screen management package. | + "curses" + For the "curses" screen management package. - "debug" | - Turns on the features `cautious', | - `careful-interrupt-masking', and `stack-limit'; uses `-g' | - flags for debugging SCM source code. | + "debug" + Turns on the features `cautious', + `careful-interrupt-masking', and `stack-limit'; uses `-g' + flags for debugging SCM source code. - "dump" | - Convert a running scheme program into an executable file. | + "dump" + Convert a running scheme program into an executable file. - "dynamic-linking" | - Be able to load compiled files while running. | + "dynamic-linking" + Be able to load compiled files while running. - "edit-line" | - interface to the editline or GNU readline library. | + "edit-line" + interface to the editline or GNU readline library. "engineering-notation" Use if you want floats to display in engineering notation (exponents always multiples of 3) instead of scientific notation. - "generalized-c-arguments" | - `make_gsubr' for arbitrary (< 11) arguments to C functions. | + "generalized-c-arguments" + `make_gsubr' for arbitrary (< 11) arguments to C functions. - "i/o-extensions" | - Commonly available I/O extensions: "exec", line I/O, file | - positioning, file delete and rename, and directory functions. | + "i/o-extensions" + Commonly available I/O extensions: "exec", line I/O, file + positioning, file delete and rename, and directory functions. - "inexact" | - Use if you want floating point numbers. | + "inexact" + Use if you want floating point numbers. - "lit" | - Lightweight - no features | + "lit" + Lightweight - no features - "macro" | - C level support for hygienic and referentially transparent | - macros (syntax-rules macros). | - | - "mysql" | - Client connections to the mysql databases. | - | - "no-heap-shrink" | - Use if you want segments of unused heap to not be freed up | - after garbage collection. This may increase time in GC for | - *very* large working sets. | - | - "none" | - No features | - | - "posix" | - Posix functions available on all "Unix-like" systems. fork | - and process functions, user and group IDs, file permissions, | - and "link". | - | - "reckless" | - If your scheme code runs without any errors you can disable | - almost all error checking by compiling all files with | - `reckless'. | + "macro" + C level support for hygienic and referentially transparent + macros (syntax-rules macros). + + "mysql" + Client connections to the mysql databases. + + "no-heap-shrink" + Use if you want segments of unused heap to not be freed up + after garbage collection. This may increase time in GC for + *very* large working sets. + + "none" + No features + + "posix" + Posix functions available on all "Unix-like" systems. fork + and process functions, user and group IDs, file permissions, + and "link". + + "reckless" + If your scheme code runs without any errors you can disable + almost all error checking by compiling all files with + `reckless'. "record" The Record package provides a facility for user to define their own record data types. See SLIB for documentation. - "regex" | - String regular expression matching. | + "regex" + String regular expression matching. - "rev2-procedures" | - These procedures were specified in the `Revised^2 Report on | - Scheme' but not in `R4RS'. | + "rev2-procedures" + These procedures were specified in the `Revised^2 Report on + Scheme' but not in `R4RS'. - "sicp" | - Use if you want to run code from: | + "sicp" + Use if you want to run code from: - Harold Abelson and Gerald Jay Sussman with Julie Sussman. | - `Structure and Interpretation of Computer Programs.' The MIT | - Press, Cambridge, Massachusetts, USA, 1985. | + Harold Abelson and Gerald Jay Sussman with Julie Sussman. + `Structure and Interpretation of Computer Programs.' The MIT + Press, Cambridge, Massachusetts, USA, 1985. - Differences from R5RS are: | - * (eq? '() '#f) | + Differences from R5RS are: + * (eq? '() '#f) - * (define a 25) returns the symbol a. | + * (define a 25) returns the symbol a. - * (set! a 36) returns 36. | + * (set! a 36) returns 36. - "single-precision-only" | - Use if you want all inexact real numbers to be single | - precision. This only has an effect if SINGLES is also | - defined (which is the default). This does not affect complex | - numbers. | + "single-precision-only" + Use if you want all inexact real numbers to be single + precision. This only has an effect if SINGLES is also + defined (which is the default). This does not affect complex + numbers. "socket" BSD "socket" interface. - "stack-limit" | - Use to enable checking for stack overflow. Define value of | - the C preprocessor variable STACK_LIMIT to be the size to | - which SCM should allow the stack to grow. STACK_LIMIT should | - be less than the maximum size the hardware can support, as | - not every routine checks the stack. | - | - "tick-interrupts" | - Use if you want the ticks and ticks-interrupt functions. | - | - "turtlegr" | - "Turtle" graphics calls for both Borland-C and X11 from | - sjm@ee.tut.fi. | + "stack-limit" + Use to enable checking for stack overflow. Define value of + the C preprocessor variable STACK_LIMIT to be the size to + which SCM should allow the stack to grow. STACK_LIMIT should + be less than the maximum size the hardware can support, as + not every routine checks the stack. + + "tick-interrupts" + Use if you want the ticks and ticks-interrupt functions. + + "turtlegr" + "Turtle" graphics calls for both Borland-C and X11 from + sjm@ee.tut.fi. "unix" Those unix features which have not made it into the Posix @@ -765,11 +761,11 @@ the SCM command line options. "windows" Microsoft Windows executable. - "x" | - Alias for Xlib feature. | + "x" + Alias for Xlib feature. - "xlib" | - Interface to Xlib graphics routines. | + "xlib" + Interface to Xlib graphics routines. @@ -785,16 +781,16 @@ A correspondent asks: functions we want access to). Would this involve changing build.scm or the Makefile or both? -(*note Changing Scm::. has instructions describing the C code format). +(*note Changing Scm:: has instructions describing the C code format). Suppose a C file "foo.c" has functions you wish to add to SCM. To compile and link your file at compile time, use the `-c' and `-i' options to build: bash$ build -c foo.c -i init_foo -| - #!/bin/sh + #! /bin/sh rm -f scmflags.h - echo '#define IMPLINIT "/home/jaffer/scm/Init5d2.scm"'>>scmflags.h | + echo '#define IMPLINIT "/home/jaffer/scm/Init5d6.scm"'>>scmflags.h | echo '#define COMPILED_INITS init_foo();'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h @@ -808,9 +804,9 @@ To make a dynamically loadable object file use the `-t dll' option: bash$ build -t dll -c foo.c -| - #!/bin/sh + #! /bin/sh rm -f scmflags.h - echo '#define IMPLINIT "/home/jaffer/scm/Init5d2.scm"'>>scmflags.h | + echo '#define IMPLINIT "/home/jaffer/scm/Init5d6.scm"'>>scmflags.h | echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -874,7 +870,7 @@ The SLIB module "catalog" can be extended to define other `mkimpcat.scm'. Within `mkimpcat.scm', the following procedures are defined. - - Function: add-link FEATURE OBJECT-FILE LIB1 ... + - Function: add-link feature object-file lib1 ... FEATURE should be a symbol. OBJECT-FILE should be a string naming a file containing compiled "object-code". Each LIBn argument should be either a string naming a library file or `#f'. @@ -895,7 +891,7 @@ defined. link:able-suffix)) - - Function: add-alias ALIAS FEATURE + - Function: add-alias alias feature ALIAS and FEATURE are symbols. The procedure `add-alias' registers ALIAS as an alias for FEATURE. An unspecified value is returned. @@ -903,7 +899,7 @@ defined. `add-alias' causes `(require 'ALIAS)' to behave like `(require 'FEATURE)'. - - Function: add-source FEATURE FILENAME + - Function: add-source feature filename FEATURE is a symbol. FILENAME is a string naming a file containing Scheme source code. The procedure `add-source' registers FEATURE so that the first time `require' is called with @@ -920,7 +916,7 @@ Saving Images ============= In SCM, the ability to save running program images is called "dump" -(*note Dump::.). In order to make `dump' available to SCM, build with +(*note Dump::). In order to make `dump' available to SCM, build with feature `dump'. `dump'ed executables are compatible with dynamic linking. @@ -948,7 +944,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of ------- ---------- ARM_ULIB Huw Rogers free unix library for acorn archimedes AZTEC_C Aztec_C 5.2a - __CYGWIN__ Cygwin | + __CYGWIN__ Cygwin _DCC Dice C on AMIGA __GNUC__ Gnu CC (and DJGPP) __EMX__ Gnu C port (gcc/emx 0.8e) to OS/2 2.0 @@ -966,8 +962,9 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of __ZTC__ Zortech C _AIX AIX operating system + __APPLE__ Apple Darwin | AMIGA SAS/C 5.10 or Dice C on AMIGA - __amigados__ Gnu CC on AMIGA + __amigaos__ Gnu CC on AMIGA | atarist ATARI-ST under Gnu CC __FreeBSD__ FreeBSD GNUDOS DJGPP (obsolete in version 1.08) @@ -976,11 +973,12 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of linux Linux macintosh Macintosh (THINK_C and __MWERKS__ define) MCH_AMIGA Aztec_c 5.2a on AMIGA + __MACH__ Apple Darwin | MSDOS Microsoft C 5.10 and 6.00A __MSDOS__ Turbo C, Borland C, and DJGPP nosve Control Data NOS/VE SVR2 System V Revision 2. - __svr4__ SunOS + __SVR4 SunOS THINK_C developement environment for the Macintosh ultrix VAX with ULTRIX operating system. unix most Unix and similar systems and DJGPP (!?) @@ -991,7 +989,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of vax11c VAX C compiler VAX11 VAX C compiler _Windows Borland C 3.1 compiling for Windows - _WIN32 MS VisualC++ 4.2 and Cygwin (Win32 API) | + _WIN32 MS VisualC++ 4.2 and Cygwin (Win32 API) vms (and VMS) VAX-11 C under VMS. __alpha DEC Alpha processor @@ -1000,6 +998,8 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of __i386__ DJGPP i386 DJGPP MULTIMAX Encore computer + ppc PowerPC | + __ppc__ PowerPC | pyr Pyramid 9810 processor __sgi__ Silicon Graphics Inc. sparc SPARC processor @@ -1013,32 +1013,32 @@ File: scm.info, Node: Problems Compiling, Next: Problems Linking, Prev: Autom Problems Compiling ================== -FILE PROBLEM / MESSAGE HOW TO FIX -*.c include file not found. Correct the status of - STDC_HEADERS in scmfig.h. - fix #include statement or add - #define for system type to - scmfig.h. -*.c Function should return a value. Ignore. - Parameter is never used. - Condition is always false. - Unreachable code in function. -scm.c assignment between incompatible Change SIGRETTYPE in scm.c. - types. -time.c CLK_TCK redefined. incompatablility between - <stdlib.h> and <sys/types.h>. - Remove STDC_HEADERS in scmfig.h. - Edit <sys/types.h> to remove - incompatability. -subr.c Possibly incorrect assignment Ignore. - in function lgcd. -sys.c statement not reached. Ignore. - constant in conditional - expression. -sys.c undeclared, outside of #undef STDC_HEADERS in scmfig.h. - functions. -scl.c syntax error. #define SYSTNAME to your system - type in scl.c (softtype). +FILE PROBLEM / MESSAGE HOW TO FIX +*.c include file not found. Correct the status of + STDC_HEADERS in scmfig.h. + fix #include statement or add + #define for system type to + scmfig.h. +*.c Function should return a value. Ignore. + Parameter is never used. + Condition is always false. + Unreachable code in function. +scm.c assignment between incompatible Change SIGRETTYPE in scm.c. + types. +time.c CLK_TCK redefined. incompatablility between + <stdlib.h> and <sys/types.h>. + Remove STDC_HEADERS in scmfig.h. + Edit <sys/types.h> to remove + incompatability. +subr.c Possibly incorrect assignment Ignore. + in function lgcd. +sys.c statement not reached. Ignore. + constant in conditional + expression. +sys.c undeclared, outside of #undef STDC_HEADERS in scmfig.h. + functions. +scl.c syntax error. #define SYSTNAME to your system + type in scl.c (softtype). File: scm.info, Node: Problems Linking, Next: Problems Running, Prev: Problems Compiling, Up: Installing SCM @@ -1046,8 +1046,8 @@ File: scm.info, Node: Problems Linking, Next: Problems Running, Prev: Problem Problems Linking ================ -PROBLEM HOW TO FIX -_sin etc. missing. Uncomment LIBS in makefile. +PROBLEM HOW TO FIX +_sin etc. missing. Uncomment LIBS in makefile. File: scm.info, Node: Problems Running, Next: Testing, Prev: Problems Linking, Up: Installing SCM @@ -1055,38 +1055,38 @@ File: scm.info, Node: Problems Running, Next: Testing, Prev: Problems Linking Problems Running ================ -PROBLEM HOW TO FIX -Opening message and then machine Change memory model option to C -crashes. compiler (or makefile). - Make sure sizet definition is - correct in scmfig.h. - Reduce the size of HEAP_SEG_SIZE in - setjump.h. -Input hangs. #define NOSETBUF -ERROR: heap: need larger initial. Increase initial heap allocation - using -a<kb> or INIT_HEAP_SIZE. -ERROR: Could not allocate. Check sizet definition. - Use 32 bit compiler mode. - Don't try to run as subproccess. -remove <FLAG> in scmfig.h and Do so and recompile files. -recompile scm. -add <FLAG> in scmfig.h and -recompile scm. -ERROR: Init5d2.scm not found. Assign correct IMPLINIT in makefile | - or scmfig.h. - Define environment variable - SCM_INIT_PATH to be the full - pathname of Init5d2.scm. | -WARNING: require.scm not found. Define environment variable - SCHEME_LIBRARY_PATH to be the full - pathname of the scheme library - [SLIB]. - Change library-vicinity in - Init5d2.scm to point to library or | - remove. - Make sure the value of - (library-vicinity) has a trailing - file separator (like / or \). +PROBLEM HOW TO FIX +Opening message and then machine Change memory model option to C +crashes. compiler (or makefile). + Make sure sizet definition is + correct in scmfig.h. + Reduce the size of HEAP_SEG_SIZE in + setjump.h. +Input hangs. #define NOSETBUF +ERROR: heap: need larger initial. Increase initial heap allocation + using -a<kb> or INIT_HEAP_SIZE. +ERROR: Could not allocate. Check sizet definition. + Use 32 bit compiler mode. + Don't try to run as subproccess. +remove <FLAG> in scmfig.h and Do so and recompile files. +recompile scm. +add <FLAG> in scmfig.h and +recompile scm. +ERROR: Init5d6.scm not found. Assign correct IMPLINIT in makefile | + or scmfig.h. + Define environment variable + SCM_INIT_PATH to be the full + pathname of Init5d6.scm. | +WARNING: require.scm not found. Define environment variable + SCHEME_LIBRARY_PATH to be the full + pathname of the scheme library + [SLIB]. + Change library-vicinity in + Init5d6.scm to point to library or | + remove. + Make sure the value of + (library-vicinity) has a trailing + file separator (like / or \). File: scm.info, Node: Testing, Next: Reporting Problems, Prev: Problems Running, Up: Installing SCM @@ -1114,13 +1114,13 @@ of pi. > (load "pi") ;loading "pi" ;done loading "pi.scm" - ;Evaluation took 20 mSec (0 in gc) 767 cells work, 233 bytes other + ;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B other | #<unspecified> > (pi 100 5) 00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 70679 - ;Evaluation took 550 mSec (60 in gc) 36976 cells work, 1548 bytes other + ;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other | #<unspecified> Loading `bench.scm' will compute and display performance statistics of @@ -1128,34 +1128,34 @@ SCM running `pi.scm'. `make bench' or `make benchlit' appends the performance report to the file `BenchLog', facilitating tracking effects of changes to SCM on performance. -PROBLEM HOW TO FIX -Runs some and then machine crashes. See above under machine crashes. -Runs some and then ERROR: ... Remove optimization option to C -(after a GC has happened). compiler and recompile. - #define SHORT_ALIGN in `scmfig.h'. -Some symbol names print incorrectly. Change memory model option to C - compiler (or makefile). - Check that HEAP_SEG_SIZE fits - within sizet. - Increase size of HEAP_SEG_SIZE (or - INIT_HEAP_SIZE if it is smaller - than HEAP_SEG_SIZE). -ERROR: Rogue pointer in Heap. See above under machine crashes. -Newlines don't appear correctly in Check file mode (define OPEN_... in -output files. `Init5d2.scm'). | -Spaces or control characters appear Check character defines in -in symbol names. `scmfig.h'. -Negative numbers turn positive. Check SRS in `scmfig.h'. -VMS: Couldn't unwind stack. #define CHEAP_CONTIUATIONS in - `scmfig.h'. -VAX: botched longjmp. +PROBLEM HOW TO FIX +Runs some and then machine crashes. See above under machine crashes. +Runs some and then ERROR: ... Remove optimization option to C +(after a GC has happened). compiler and recompile. + #define SHORT_ALIGN in `scmfig.h'. +Some symbol names print incorrectly. Change memory model option to C + compiler (or makefile). + Check that HEAP_SEG_SIZE fits + within sizet. + Increase size of HEAP_SEG_SIZE (or + INIT_HEAP_SIZE if it is smaller + than HEAP_SEG_SIZE). +ERROR: Rogue pointer in Heap. See above under machine crashes. +Newlines don't appear correctly in Check file mode (define OPEN_... in +output files. `Init5d6.scm'). | +Spaces or control characters appear Check character defines in +in symbol names. `scmfig.h'. +Negative numbers turn positive. Check SRS in `scmfig.h'. +VMS: Couldn't unwind stack. #define CHEAP_CONTIUATIONS in + `scmfig.h'. +VAX: botched longjmp. Sparc(SUN-4) heap is growing out of control You are experiencing a GC problem peculiar to the Sparc. The problem is that SCM doesn't know how to clear register windows. Every location which is not reused still gets marked at GC time. This causes lots of stuff which should be collected to not be. - This will be a problem with any *conservative* GC until we find + This will be a problem with any _conservative_ GC until we find what instruction will clear the register windows. This problem is exacerbated by using lots of call-with-current-continuations. @@ -1167,8 +1167,8 @@ Reporting Problems Reported problems and solutions are grouped under Compiling, Linking, Running, and Testing. If you don't find your problem listed there, you -can send a bug report to `jaffer @ ai.mit.edu'. The bug report should -include: +can send a bug report to `jaffer @ alum.mit.edu'. The bug report | +should include: | 1. The version of SCM (printed when SCM is invoked with no arguments). @@ -1211,10 +1211,11 @@ File: scm.info, Node: Invoking SCM, Next: SCM Options, Prev: Operational Feat Invoking SCM ============ -scm [-a kbytes] [-ibvqmu] [-p number] - [-c expression] [-e expression] [-f filename] - [-l filename] [-r feature] [-- | - | -s] - [filename] [arguments ...] + scm [-a kbytes] [-muvbiq] [-version] [-help] + [[-]-no-init-file] [-p int] [-r feature] [-h feature] + [-d filename] [-f filename] [-l filename] + [-c expression] [-e expression] [-o dumpname] + [-- | - | -s] [filename] [arguments ...] Upon startup `scm' loads the file specified by by the environment variable SCM_INIT_PATH. @@ -1222,7 +1223,7 @@ variable SCM_INIT_PATH. If SCM_INIT_PATH is not defined or if the file it names is not present, `scm' tries to find the directory containing the executable file. If it is able to locate the executable, `scm' looks for the initialization -file (usually `Init5d2.scm') in platform-dependent directories relative | +file (usually `Init5d6.scm') in platform-dependent directories relative | to this directory. See *Note File-System Habitat:: for a blow-by-blow description. @@ -1231,12 +1232,12 @@ compile parameter IMPLINIT (defined in the makefile or `scmfig.h') is tried. Unless the option `-no-init-file' or `--no-init-file' occurs in the -command line, `Init5d2.scm' checks to see if there is file | +command line, `Init5d6.scm' checks to see if there is file | `ScmInit.scm' in the path specified by the environment variable HOME -(or in the current directory if HOME is undefined). If it finds such a +(or in the current directory if HOME is undefined). If it finds such a file it is loaded. -`Init5d2.scm' then looks for command input from one of three sources: | +`Init5d6.scm' then looks for command input from one of three sources: | From an option on the command line, from a file named on the command line, or from standard input. @@ -1253,9 +1254,9 @@ Options The options are processed in the order specified on the command line. - - Command Option: -a KB - specifies that `scm' should allocate an initial heapsize of KB - kilobytes. This option, if present, must be the first on the + - Command Option: -a k | + specifies that `scm' should allocate an initial heapsize of K | + kilobytes. This option, if present, must be the first on the command line. If not specified, the default is `INIT_HEAP_SIZE' in source file `setjump.h' which the distribution sets at `25000*sizeof(cell)'. @@ -1264,28 +1265,51 @@ The options are processed in the order specified on the command line. - Command Option: --no-init-file Inhibits the loading of `ScmInit.scm' as described above. - - Command Option: -e EXPRESSION - - Command Option: -c EXPRESSION - specifies that the scheme expression EXPRESSION is to be - evaluated. These options are inspired by `perl' and `sh' - respectively. On Amiga systems the entire option and argument need - to be enclosed in quotes. For instance `"-e(newline)"'. - - - Command Option: -r FEATURE - requires FEATURE. This will load a file from [SLIB] if that - FEATURE is not already supported. If FEATURE is 2, 3, 4, or 5 - `scm' will require the features neccessary to support [R2RS], - [R3RS], [R4RS], or [R5RS], respectively. - - - Command Option: -l FILENAME - - Command Option: -f FILENAME - loads FILENAME. `Scm' will load the first (unoptioned) file named + - Command Option: --help + prints usage information and URI; then exit. + + - Command Option: --version + prints version information and exit. + + - Command Option: -r feature + requires FEATURE. This will load a file from [SLIB] if that + FEATURE is not already provided. If FEATURE is 2, 2rs, r2rs, 3, | + 3rs, r3rs, 4, 4rs, r4rs, 5, 5rs, or r5rs; `scm' will require the | + features neccessary to support [R2RS], [R3RS], [R4RS], or [R5RS], | + respectively. | + + - Command Option: -h feature + provides FEATURE. + + - Command Option: -l filename + - Command Option: -f filename + loads FILENAME. `Scm' will load the first (unoptioned) file named on the command line if no `-c', `-e', `-f', `-l', or `-s' option preceeds it. - - Command Option: -p LEVEL - sets the prolixity (verboseness) to LEVEL. This is the same as the - `scm' command (verobse LEVEL). + - Command Option: -d filename + Loads SLIB `databases' feature and opens FILENAME as a database. | + + - Command Option: -e expression + - Command Option: -c expression + specifies that the scheme expression EXPRESSION is to be + evaluated. These options are inspired by `perl' and `sh' + respectively. On Amiga systems the entire option and argument + need to be enclosed in quotes. For instance `"-e(newline)"'. + + - Command Option: -o dumpname + saves the current SCM session as the executable program `dumpname'. + This option works only in SCM builds supporting `dump' (*note + Dump::). + + If options appear on the command line after `-o DUMPNAME', then + the saved session will continue with processing those options when + it is invoked. Otherwise the (new) command line is processed as + usual when the saved image is invoked. + + - Command Option: -p level + sets the prolixity (verboseness) to LEVEL. This is the same as + the `scm' command (verobse LEVEL). - Command Option: -v (verbose mode) specifies that `scm' will print prompts, evaluation @@ -1298,7 +1322,7 @@ The options are processed in the order specified on the command line. - Command Option: -m specifies that subsequent loads, evaluations, and user - interactions will be with syntax-rules macro capability. To use a + interactions will be with syntax-rules macro capability. To use a specific syntax-rules macro implementation from [SLIB] (instead of [SLIB]'s default) put `-r' MACROPACKAGE before `-m' on the command line. @@ -1306,21 +1330,21 @@ The options are processed in the order specified on the command line. - Command Option: -u specifies that subsequent loads, evaluations, and user interactions will be without syntax-rules macro capability. - syntax-rules macro capability can be restored by a subsequent `-m' + Syntax-rules macro capability can be restored by a subsequent `-m' on the command line or from Scheme code. - Command Option: -i - specifies that `scm' should run interactively. That means that + specifies that `scm' should run interactively. That means that `scm' will not terminate until the `(quit)' or `(exit)' command is - given, even if there are errors. It also sets the prolixity level - to 2 if it is less than 2. This will print prompts, evaluation - times, and notice of loading files. The prolixity level can be set - by subsequent options. If `scm' is started from a tty, it will - assume that it should be interactive unless given a subsequent `-b' - option. + given, even if there are errors. It also sets the prolixity level + to 2 if it is less than 2. This will print prompts, evaluation + times, and notice of loading files. The prolixity level can be + set by subsequent options. If `scm' is started from a tty, it + will assume that it should be interactive unless given a + subsequent `-b' option. - Command Option: -b - specifies that `scm' should run non-interactively. That means that + specifies that `scm' should run non-interactively. That means that `scm' will terminate after processing the command line or if there are errors. @@ -1332,25 +1356,6 @@ The options are processed in the order specified on the command line. - Command Option: -- specifies that there are no more options on the command line. - - Command Option: -d FILENAME - loads SLIB database-utilities and opens FILENAME as a database. - - - Command Option: -o FILENAME - saves the current SCM session as the executable program `filename'. - This option works only in SCM builds supporting `dump' (*note - Dump::.). - - If options appear on the command line after `-o FILENAME', then - the saved session will continue with processing those options when - it is invoked. Otherwise the (new) command line is processed as - usual when the saved image is invoked. - - - Command Option: --help - prints usage information and URL; then exit. - - - Command Option: --version - prints version information and exit. - File: scm.info, Node: Invocation Examples, Next: SCM Variables, Prev: SCM Options, Up: Operational Features @@ -1391,13 +1396,13 @@ Environment Variables - Environment Variable: SCM_INIT_PATH is the pathname where `scm' will look for its initialization code. - The default is the file `Init5d2.scm' in the source directory. | + The default is the file `Init5d6.scm' in the source directory. | - Environment Variable: SCHEME_LIBRARY_PATH is the [SLIB] Scheme library directory. - Environment Variable: HOME - is the directory where `Init5d2.scm' will look for the user | + is the directory where `Init5d6.scm' will look for the user | initialization file `ScmInit.scm'. - Environment Variable: EDITOR @@ -1408,20 +1413,20 @@ Scheme Variables ================ - Variable: *argv* - contains the list of arguments to the program. `*argv*' can change - during argument processing. This list is suitable for use as an + contains the list of arguments to the program. `*argv*' can change + during argument processing. This list is suitable for use as an argument to [SLIB] `getopt'. - - Variable: *R4RS-macro* + - Variable: *syntax-rules* | controls whether loading and interaction support syntax-rules - macros. Define this in `ScmInit.scm' or files specified on the - command line. This can be overridden by subsequent `-m' and `-u' + macros. Define this in `ScmInit.scm' or files specified on the + command line. This can be overridden by subsequent `-m' and `-u' options. - Variable: *interactive* controls interactivity as explained for the `-i' and `-b' options. Define this in `ScmInit.scm' or files specified on the command - line. This can be overridden by subsequent `-i' and `-b' options. + line. This can be overridden by subsequent `-i' and `-b' options. File: scm.info, Node: SCM Session, Next: Editing Scheme Code, Prev: SCM Variables, Up: Operational Features @@ -1440,13 +1445,18 @@ SCM Session form and resumes the top level read-eval-print loop. - Function: quit - - Function: quit N + - Function: quit n - Function: exit - - Function: exit N + - Function: exit n Aliases for `exit' (*note exit: (slib)System.). On many systems, SCM can also tail-call another program. *Note execp: I/O-Extensions. + - Callback procedure: boot-tail dumped? | + `boot-tail' is called by `scm_top_level' just before entering | + interactive top-level. If `boot-tail' calls `quit', then | + interactive top-level is not entered. | + | - Function: program-arguments Returns a list of strings of the arguments scm was called with. @@ -1463,11 +1473,11 @@ File: scm.info, Node: Editing Scheme Code, Next: Debugging Scheme Code, Prev: Editing Scheme Code =================== - - Function: ed ARG1 ... + - Function: ed arg1 ... The value of the environment variable `EDITOR' (or just `ed' if it isn't defined) is invoked as a command with arguments ARG1 .... - - Function: ed FILENAME + - Function: ed filename If SCM is compiled under VMS `ed' will invoke the editor with a single the single argument FILENAME. @@ -1476,11 +1486,11 @@ Gnu Emacs: files ending in .scm are automatically put into scheme-mode. EMACS for MS-DOS and MS-Windows systems is available (free) from: - `http://simtel.coast.net/SimTel/gnu/demacs.html' + <http://simtel.coast.net/SimTel/gnu/demacs.html> If your Emacs can run a process in a buffer you can use the Emacs -command `M-x run-scheme' with SCM. Otherwise, use the emacs command -`M-x suspend-emacs'; or see "other systems" below. + command `M-x run-scheme' with SCM. Otherwise, use the emacs + command `M-x suspend-emacs'; or see "other systems" below. Epsilon (MS-DOS): There is lisp (and scheme) mode available by use of the package @@ -1499,7 +1509,7 @@ Epsilon (MS-DOS): other systems: Define the environment variable `EDITOR' to be the name of the - editing program you use. The SCM procedure `(ed arg1 ...)' will + editing program you use. The SCM procedure `(ed arg1 ...)' will invoke your editor and return to SCM when you exit the editor. The following definition is convenient: @@ -1515,7 +1525,7 @@ Debugging Scheme Code ===================== The `cautious' and `stack-limit' options of `build' (*note Build -Options::.) support debugging in Scheme. +Options::) support debugging in Scheme. "CAUTIOUS" If SCM is built with the `CAUTIOUS' flag, then when an error @@ -1548,7 +1558,7 @@ Options::.) support debugging in Scheme. There are several SLIB macros which so useful that SCM automatically loads the appropriate module from SLIB if they are invoked. - - Macro: trace PROC1 ... + - Macro: trace proc1 ... Traces the top-level named procedures given as arguments. - Macro: trace @@ -1556,7 +1566,7 @@ loads the appropriate module from SLIB if they are invoked. identifiers are traced (even if those identifiers have been redefined) and returns a list of the traced identifiers. - - Macro: untrace PROC1 ... + - Macro: untrace proc1 ... Turns tracing off for its arguments. - Macro: untrace @@ -1565,7 +1575,7 @@ loads the appropriate module from SLIB if they are invoked. The routines I use most frequently for debugging are: - - Procedure: print ARG1 ... + - Procedure: print arg1 ... `Print' writes all its arguments, separated by spaces. `Print' outputs a `newline' at the end and returns the value of the last argument. @@ -1573,7 +1583,7 @@ The routines I use most frequently for debugging are: One can just insert `(print '<proc-name>' and `)' around an expression in order to see its value as a program operates. - - Syntax: print-args NAME1 ... + - Syntax: print-args name1 ... Writes NAME1 ... (separated by spaces) and then writes the values of the closest lexical bindings enclosing the call to `Print-args'. @@ -1591,8 +1601,8 @@ When `trace' is not sufficient to find program flow problems, SLIB-PSD, the Portable Scheme Debugger offers source code debugging from GNU Emacs. PSD runs slowly, so start by instrumenting only a few functions at a time. - http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz | - ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz + swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz @@ -1613,7 +1623,7 @@ response code in C. The following common error and conditions are handled by C code. Those with callback names after them can also be handled by Scheme code -(*note Interrupts::.). If the callback identifier is not defined at top +(*note Interrupts::). If the callback identifier is not defined at top level, the default error handler (C code) is invoked. There are many other error messages which are not treated specially. @@ -1682,13 +1692,13 @@ other error messages which are not treated specially. current form, prints a message explaining the error, and resumes the top level read-eval-print loop. The value of ERROBJ is the offending object if appropriate. The builtin procedure `error' - does *not* set ERROBJ. + does _not_ set ERROBJ. `errno' and `perror' report ANSI C errors encountered during a call to a system or library function. - Function: errno - - Function: errno N + - Function: errno n With no argument returns the current value of the system variable `errno'. When given an argument, `errno' sets the system variable `errno' to N and returns the previous value of `errno'. `(errno @@ -1696,7 +1706,7 @@ a system or library function. `try-load' returns `#f' since this occurs when the file could not be opened. - - Function: perror STRING + - Function: perror string Prints on standard error output the argument STRING, a colon, followed by a space, the error message corresponding to the current value of `errno' and a newline. The value returned is unspecified. @@ -1704,15 +1714,15 @@ a system or library function. `warn' and `error' provide a uniform way for Scheme code to signal warnings and errors. - - Function: warn ARG1 ARG2 ARG3 ... + - Function: warn arg1 arg2 arg3 ... Alias for *Note slib:warn: (slib)System. Outputs an error message - containing the arguments. `warn' is defined in `Init5d2.scm'. | + containing the arguments. `warn' is defined in `Init5d6.scm'. | - - Function: error ARG1 ARG2 ARG3 ... + - Function: error arg1 arg2 arg3 ... Alias for *Note slib:error: (slib)System. Outputs an error message containing the arguments, aborts evaluation of the current form and resumes the top level read-eval-print loop. `Error' is - defined in `Init5d2.scm'. | + defined in `Init5d6.scm'. | If SCM is built with the `CAUTIOUS' flag, then when an error occurs, a "stack trace" of certain pending calls are printed as part of the @@ -1730,7 +1740,7 @@ with Lisp systems. - Function: stack-trace Prints information describing the stack of partially evaluated expressions. `stack-trace' returns `#t' if any lines were printed - and `#f' otherwise. See `Init5d2.scm' for an example of the use | + and `#f' otherwise. See `Init5d6.scm' for an example of the use | of `stack-trace'. @@ -1755,7 +1765,7 @@ a convenient aid to locating bugs and untested expressions. * The names of identifiers which are not lexiallly bound but defined at top-level have #@ prepended. -For instance, `open-input-file' is defined as follows in `Init5d2.scm': | +For instance, `open-input-file' is defined as follows in `Init5d6.scm': | (define (open-input-file str) (or (open-file str OPEN_READ) @@ -1802,9 +1812,9 @@ Internal State The variable *INTERACTIVE* determines whether the SCM session is interactive, or should quit after the command line is processed. *INTERACTIVE* is controlled directly by the command-line options - `-b', `-i', and `-s' (*note Invoking SCM::.). If none of these + `-b', `-i', and `-s' (*note Invoking SCM::). If none of these options are specified, the rules to determine interactivity are - more complicated; see `Init5d2.scm' for details. | + more complicated; see `Init5d6.scm' for details. | - Function: abort Resumes the top level Read-Eval-Print loop. @@ -1815,16 +1825,16 @@ Internal State those files have changed, those changes will be reflected in the new session. - *Note:* When running a saved executable (*note Dump::.), `restart' + _Note:_ When running a saved executable (*note Dump::), `restart' is redefined to be `exec-self'. - Function: exec-self Exits and immediately re-invokes the same executable with the same arguments. If the executable file has been changed or replaced - since the beginning of the current session, the *new* executable + since the beginning of the current session, the _new_ executable will be invoked. This differentiates `exec-self' from `restart'. - - Function: verbose N + - Function: verbose n Controls how much monitoring information is printed. If N is: 0 @@ -1834,37 +1844,38 @@ Internal State a prompt is printed. >= 2 - the CPU time is printed after each top level form evaluated. + messages bracketing file loading are printed. | >= 3 - messages about heap growth are printed. + the CPU time is printed after each top level form evaluated; | + notifications of heap growth printed. | >= 4 - garbage collection (*note Garbage Collection::.) messages are - printed. + a garbage collection summary is printed after each top level | + form evaluated; | >= 5 - a warning will be printed for each top-level symbol which is - defined more than one time. + a message for each GC (*note Garbage Collection::) is printed; | + warnings issued for top-level symbols redefined. | - Function: gc Scans all of SCM objects and reclaims for further use those that are no longer accessible. - Function: room - - Function: room #T + - Function: room #t Prints out statistics about SCM's current use of storage. `(room #t)' also gives the hexadecimal heap segment and stack bounds. - Constant: *scm-version* - Contains the version string (e.g. `5d2') of SCM. | + Contains the version string (e.g. `5d6') of SCM. | Executable path --------------- In order to dump a saved executable or to dynamically-link using DLD, SCM must know where its executable file is. Sometimes SCM (*note -Executable Pathname::.) guesses incorrectly the location of the +Executable Pathname::) guesses incorrectly the location of the currently running executable. In that case, the correct path can be set by calling `execpath' with the pathname. @@ -1873,8 +1884,8 @@ by calling `execpath' with the pathname. file whose invocation the currently running session is, or #f if the path is not set. - - Function: execpath #F - - Function: execpath NEWPATH + - Function: execpath #f + - Function: execpath newpath Sets the path to `#f' or NEWPATH, respectively. The old path is returned. @@ -1908,7 +1919,7 @@ file has (different) meanings to SCM and the operating system permissions) whose first two characters are `#!'. The INTERPRETER argument must be the pathname of the program to process the rest of the file. The directories named by environment variable `PATH' - are *not* searched to find INTERPRETER. + are _not_ searched to find INTERPRETER. When executing a shell-script, the operating system invokes INTERPRETER with a single argument encapsulating the rest of the @@ -1932,7 +1943,7 @@ file has (different) meanings to SCM and the operating system `\' substitution; this will only take place if INTERPRETER is a SCM or SCSH interpreter. - - Read syntax: #! IGNORED !# + - Read syntax: #! ignored !# When the first two characters of the file being loaded are `#!' and a `\' is present before a newline in the file, all characters up to `!#' will be ignored by SCM `read'. @@ -1940,7 +1951,7 @@ file has (different) meanings to SCM and the operating system This combination of interpretatons allows SCM source files to be used as POSIX shell-scripts if the first line is: - #!/usr/local/bin/scm \ + #! /usr/local/bin/scm \ The following Scheme-Script prints factorial of its argument: @@ -2013,7 +2024,7 @@ following syntax for <PROGRAM>.BAT files. Once the INTERPRETER executable path is found, arguments are processed in the manner of scheme-shell, with the all the text after the `\' taken as part of the meta-argument. More precisely, - `#!' calls INTERPRETER with any options on the second line of the + `#!' calls INTERPRETER with any options on the second line of the Scheme-Script up to `!#', the name of the Scheme-Script file, and then any of at most 8 arguments given on the command line invoking this Scheme-Script. @@ -2036,7 +2047,7 @@ Scheme-scripts suffer from two drawbacks: programs are moved. The following approach solves these problems at the expense of slower -startup. Make `#!/bin/sh' the first line and prepend every subsequent +startup. Make `#! /bin/sh' the first line and prepend every subsequent line to be executed by the shell with `:;'. The last line to be executed by the shell should contain an "exec" command; `exec' tail-calls its argument. @@ -2096,6 +2107,7 @@ The Language * Interrupts:: and exceptions * Process Synchronization:: Because interrupts are preemptive * Files and Ports:: +* Line Numbers:: | * Soft Ports:: Emulate I/O devices * Syntax Extensions:: * Low Level Syntactic Hooks:: @@ -2108,7 +2120,7 @@ Standards Compliance ==================== Scm conforms to the `IEEE Standard 1178-1990. IEEE Standard for the -Scheme Programming Language.' (*note Bibliography::.), and `Revised(5) +Scheme Programming Language.' (*note Bibliography::), and `Revised(5) Report on the Algorithmic Language Scheme'. *Note Top: (r5rs)Top. All the required features of these specifications are supported. Many of the optional features are supported as well. @@ -2227,7 +2239,7 @@ File: scm.info, Node: Miscellaneous Procedures, Next: Time, Prev: Standards C Miscellaneous Procedures ======================== - - Function: try-load FILENAME + - Function: try-load filename If the string FILENAME names an existing file, the try-load procedure reads Scheme source code expressions and definitions from the file and evaluates them sequentially and returns `#t'. @@ -2237,37 +2249,39 @@ Miscellaneous Procedures - Variable: *load-pathname* Is set to the pathname given as argument to `load', `try-load', - and `dyn:link' (*note Compiling And Linking::.). - `*load-pathname*' is used to compute the value of *Note - program-vicinity: (slib)Vicinity. + and `dyn:link' (*note Compiling And Linking: (hobbit)Compiling And | + Linking.). `*load-pathname*' is used to compute the value of | + *Note program-vicinity: (slib)Vicinity. | - Function: line-number Returns the current line number of the file currently being loaded. - - Function: port-filename PORT | - Returns the filename PORT was opened with. If PORT is not open to | - a file the result is unspecified. | - | - - Function: port-line PORT | - - Function: port-column PORT | - If PORT is a tracked port, return the current line (column) number, | - otherwise return `#f'. Line numbers begin with 1, the column | - number is zero if there are no characters on the current line. | - | - - Function: eval OBJ + - Function: port-filename port + Returns the filename PORT was opened with. If PORT is not open to + a file the result is unspecified. + + - Function: port-line port + - Function: port-column port + If PORT is a tracked port, return the current line (column) number, + otherwise return `#f'. Line and column numbers begin with 1. The + column number applies to the next character to be read; if that + character is a newline, then the column number will be one more + than the length of the line. + + - Function: eval obj Alias for *Note eval: (slib)System. - - Function: eval-string STR + - Function: eval-string str Returns the result of reading an expression from STR and evaluating it. `eval-string' does not change `*load-pathname*' or `line-number'. - - Function: load-string STR + - Function: load-string str Reads and evaluates all the expressions from STR. As with `load', the value returned is unspecified. `load-string' does not change `*load-pathname*' or `line-number'. - - Function: vector-set-length! OBJECT LENGTH + - Function: vector-set-length! object length Change the length of string, vector, bit-vector, or uniform-array OBJECT to LENGTH. If this shortens OBJECT then the remaining contents are lost. If it enlarges OBJECT then the contents of the @@ -2275,23 +2289,23 @@ Miscellaneous Procedures It is an error to change the length of literal datums. The new object is returned. - - Function: copy-tree OBJ - - Function: @copy-tree OBJ + - Function: copy-tree obj + - Function: @copy-tree obj *Note copy-tree: (slib)Tree Operations. This extends the SLIB version by also copying vectors. Use `@copy-tree' if you depend on this feature; `copy-tree' could get redefined. - - Function: acons OBJ1 OBJ2 OBJ3 + - Function: acons obj1 obj2 obj3 Returns (cons (cons obj1 obj2) obj3). The expression (set! a-list (acons key datum a-list)) adds a new association to a-list. - Function: terms This command displays the GNU General Public License. - - Function: list-file FILENAME + - Function: list-file filename Displays the text contents of FILENAME. - - Procedure: print ARG1 ... + - Procedure: print arg1 ... `Print' writes all its arguments, separated by spaces. `Print' outputs a `newline' at the end and returns the value of the last argument. @@ -2330,7 +2344,7 @@ File: scm.info, Node: Interrupts, Next: Process Synchronization, Prev: Time, Interrupts ========== - - Function: ticks N + - Function: ticks n Returns the number of ticks remaining till the next tick interrupt. Ticks are an arbitrary unit of evaluation. Ticks can vary greatly in the amount of time they represent. @@ -2347,15 +2361,15 @@ Interrupts should (abort) or some other action which does not return if it does not want processing to continue. - - Function: alarm SECS + - Function: alarm secs Returns the number of seconds remaining till the next alarm interrupt. If SECS is 0, any alarm request is canceled. Otherwise an `alarm-interrupt' will be signaled SECS from the current time. ALARM is not supported on all systems. - - Function: milli-alarm MILLISECS INTERVAL - - Function: virtual-alarm MILLISECS INTERVAL - - Function: profile-alarm MILLISECS INTERVAL + - Function: milli-alarm millisecs interval + - Function: virtual-alarm millisecs interval + - Function: profile-alarm millisecs interval `milli-alarm' is similar to `alarm', except that the first argument MILLISECS, and the return value are measured in milliseconds rather than seconds. If the optional argument @@ -2403,35 +2417,93 @@ Interrupts To unestablish a response for an error set the handler symbol to `#f'. For instance, `(set! could-not-open #f)'. + - Callback procedure: gc-hook ... | + Allows a Scheme procedure to be run shortly after each garbage | + collection. This procedure will not be run recursively. If it | + runs long enough to cause a garbage collection before returning a | + warning will be printed. | + | + - Function: add-finalizer object finalizer | + OBJECT may be any garbage collected object, that is, any object | + other than an immediate integer, character, or special token such | + as `#f' or `#t', *Note Immediates::. FINALIZER is a thunk, or | + procedure taking no arguments. | + | + FINALIZER will be invoked asynchronously exactly once some time | + after OBJECT becomes eligible for garbage collection. A reference | + to OBJECT in the environment of FINALIZER will not prevent | + finalization, but will delay the reclamation of OBJECT at least | + until the next garbage collection. A reference to OBJECT in some | + other object's finalizer will necessarily prevent finalization | + until both objects are eligible for garbage collection. | + | + Finalizers are not run in any predictable order. All finalizers | + will be run by the time the program ends. | + | + This facility was based on the paper by Simon Peyton Jones, et al, | + "Stretching the storage manager: weak pointers and stable names in | + Haskell", Proc. 11th International Workshop on the Implementation | + of Functional Languages, The Netherlands, September 7-10 1999, | + Springer-Verlag LNCS. | + | + | File: scm.info, Node: Process Synchronization, Next: Files and Ports, Prev: Interrupts, Up: The Language Process Synchronization ======================= - - Function: make-arbiter NAME +An "exchanger" is a procedure of one argument regulating mutually | +exclusive access to a resource. When a exchanger is called, its current | +content is returned, while being replaced by its argument in an atomic | +operation. | + | + - Function: make-exchanger obj | + Returns a new exchanger with the argument OBJ as its initial | + content. | + | + (define queue (make-exchanger (list a))) | + | + A queue implemented as an exchanger holding a list can be | + protected from reentrant execution thus: | + | + (define (pop queue) | + (let ((lst #f)) | + (dynamic-wind | + (lambda () (set! lst (queue #f))) | + (lambda () (and lst (not (null? lst)) | + (let ((ret (car lst))) | + (set! lst (cdr lst)) | + ret))) | + (lambda () (and lst (queue lst)))))) | + | + (pop queue) => a | + | + (pop queue) => #f | + | + - Function: make-arbiter name Returns an object of type arbiter and name NAME. Its state is initially unlocked. - - Function: try-arbiter ARBITER + - Function: try-arbiter arbiter Returns `#t' and locks ARBITER if ARBITER was unlocked. Otherwise, returns `#f'. - - Function: release-arbiter ARBITER + - Function: release-arbiter arbiter Returns `#t' and unlocks ARBITER if ARBITER was locked. Otherwise, returns `#f'. -File: scm.info, Node: Files and Ports, Next: Soft Ports, Prev: Process Synchronization, Up: The Language - +File: scm.info, Node: Files and Ports, Next: Line Numbers, Prev: Process Synchronization, Up: The Language + | Files and Ports =============== These procedures generalize and extend the standard capabilities in *Note Ports: (r5rs)Ports. - - Function: open-file STRING MODES - - Function: try-open-file STRING MODES + - Function: open-file string modes + - Function: try-open-file string modes Returns a port capable of receiving or delivering characters as specified by the MODES string. If a file cannot be opened `#f' is returned. @@ -2447,34 +2519,44 @@ These procedures generalize and extend the standard capabilities in Contain modes strings specifying that a file is to be opened for reading, writing, and both reading and writing respectively. - - Function: _ionbf MODESTR - Returns a version of MODESTR which when `open-file' is called with | - it as the second argument will return an unbuffered port. A - non-file input-port must be unbuffered in order for `char-ready?' | - and `wait-for-input' to work correctly on it. The initial value of | - `(current-input-port)' is unbuffered if the platform supports it. | + Both input and output functions can be used with io-ports. An end | + of file must be read or a file-set-position done on the port | + between a read operation and a write operation or vice-versa. | | - - Function: _tracked MODESTR | + - Function: _ionbf modestr + Returns a version of MODESTR which when `open-file' is called with + it as the second argument will return an unbuffered port. An | + input-port must be unbuffered in order for `char-ready?' and | + `wait-for-input' to work correctly on it. The initial value of | + `(current-input-port)' is unbuffered if the platform supports it. + + - Function: _tracked modestr + Returns a version of MODESTR which when `open-file' is called with + it as the second argument will return a tracked port. A tracked + port maintains current line and column numbers, which may be + queried with `port-line' and `port-column'. + + - Function: _exclusive modestr | Returns a version of MODESTR which when `open-file' is called with | - it as the second argument will return a tracked port. A tracked | - port maintains current line and column numbers, which may be | - queried with `port_line' and `port_column'. | - - - Function: close-port PORT + it as the second argument will return a port only if the named file | + does not already exist. This functionality is provided by calling | + `try-create-file' *Note I/O-Extensions::, which is not available | + for all platforms. | + | + - Function: port-closed? port | + Returns #t if PORT is closed. | + | + - Function: port-type obj | + If OBJ is not a port returns false, otherwise returns a symbol | + describing the port type, for example string or pipe. | + | + - Function: close-port port Closes PORT. The same as close-input-port and close-output-port. - - - Function: open-io-file FILENAME - - Function: close-io-port PORT - These functions are analogous to the standard scheme file - functions. The ports are open to FILENAME in read/write mode. - Both input and output functions can be used with io-ports. An end - of file must be read or a file-set-position done on the port - between a read operation and a write operation or vice-versa. - + | - Function: current-error-port Returns the current port to which diagnostic output is directed. - - Function: with-error-to-file STRING THUNK + - Function: with-error-to-file string thunk THUNK must be a procedure of no arguments, and string must be a string naming a file. The file is opened for output, an output port connected to it is made the default value returned by @@ -2483,15 +2565,23 @@ These procedures generalize and extend the standard capabilities in default is restored. With-error-to-file returns the value yielded by THUNK. - - Function: with-input-from-port PORT THUNK - - Function: with-output-to-port PORT THUNK - - Function: with-error-to-port PORT THUNK + - Function: with-input-from-port port thunk + - Function: with-output-to-port port thunk + - Function: with-error-to-port port thunk These routines differ from with-input-from-file, with-output-to-file, and with-error-to-file in that the first argument is a port, rather than a string naming a file. + - Function: call-with-outputs thunk proc + Calls the THUNK procedure while the current-output-port and + current-error-port are directed to string-ports. If THUNK + returns, the PROC procedure is called with the output-string, the + error-string, and the value returned by THUNK. If THUNK does not + return a value (perhaps because of error), PROC is called with + just the output-string and the error-string as arguments. + - procedure: char-ready? - - procedure: char-ready? PORT + - procedure: char-ready? port Returns `#t' if a character is ready on the input PORT and returns `#f' otherwise. If `char-ready?' returns `#t' then the next `read-char' operation on the given PORT is guaranteed not to hang. @@ -2499,44 +2589,103 @@ These procedures generalize and extend the standard capabilities in PORT may be omitted, in which case it defaults to the value returned by `current-input-port'. - *Rationale:* `Char-ready?' exists to make it possible for a + _Rationale:_ `Char-ready?' exists to make it possible for a program to accept characters from interactive ports without getting stuck waiting for input. Any input editors associated with such ports must ensure that characters whose existence has - been asserted by `char-ready?' cannot be rubbed out. If + been asserted by `char-ready?' cannot be rubbed out. If `char-ready?' were to return `#f' at end of file, a port at end of file would be indistinguishable from an interactive port that has no ready characters. - - procedure: wait-for-input X - - procedure: wait-for-input X PORT1 ... + - procedure: wait-for-input x + - procedure: wait-for-input x port1 ... Returns a list those ports PORT1 ... which are `char-ready?'. If none of PORT1 ... become `char-ready?' within the time interval of X seconds, then #f is returned. The PORT1 ... arguments may be omitted, in which case they default to the list of the value returned by `current-input-port'. - - Function: isatty? PORT + - Function: isatty? port Returns `#t' if PORT is input or output to a serial non-file device. - - Function: freshline PORT | - Outputs a newline to optional argument PORT unless the current | - output column number of PORT is known to be zero, ie output will | - start at the beginning of a new line. PORT defaults to | - `current-output-port'. If PORT is not a tracked port `freshline' | - is equivalent to `newline'. | + - Function: freshline port + Outputs a newline to optional argument PORT unless the current + output column number of PORT is known to be zero, ie output will + start at the beginning of a new line. PORT defaults to + `current-output-port'. If PORT is not a tracked port `freshline' + is equivalent to `newline'. + + - Function: open-ports | + Returns a list of all currently open ports, excluding string ports, | + see *Note String Ports: (slib)String Ports. This may be useful | + after a fork *Note Posix Extensions::, or for debugging. Bear in | + mind that ports that would be closed by gc will be kept open by a | + reference to this list. | | -File: scm.info, Node: Soft Ports, Next: Syntax Extensions, Prev: Files and Ports, Up: The Language - +File: scm.info, Node: Line Numbers, Next: Soft Ports, Prev: Files and Ports, Up: The Language + | +Line Numbers | +============ | + | +Scheme code define by load may optionally contain line number | +information. Currently this information is used only for reporting | +expansion time errors, but in the future run-time error messages may | +also include line number information. | + | + - Function: try-load pathname reader | + This is the primitive for loading, PATHNAME is the name of a file | + containing Scheme code, and optional argument READER is a function | + of one argument, a port. READER should read and return Scheme | + code as list structure. The default value is `read', which is | + used if READER is not supplied or is false. | + | +Line number objects are disjoint from integers or other Scheme types. | +When evaluated or loaded as Scheme code, an s-expression containing a | +line-number in the car is equivalent to the cdr of the s-expression. A | +pair consisting of a line-number in the car and a vector in the cdr is | +equivalent to the vector. The meaning of s-expressions with | +line-numbers in other positions is undefined. | + | + - Function: read-numbered port | + Behaves like `read', except that every s-expression read will be | + replaced with a cons of a line-number object and the sexp actually | + read. This replacement is done only if PORT is a tracked port See | + *Note Files and Ports::. | + | + - Function: integer->line-number int | + Returns a line-number object with value INT. INT should be an | + exact non-negative integer. | + | + - Function: line-number->integer linum | + Returns the value of line-number object LINUM as an integer. | + | + - Function: line-number? obj | + Returns true if and only if OBJ is a line-number object. | + | + - Variable: *load-reader* | + - Variable: *slib-load-reader* | + The value of `*load-reader*' should be a value acceptable as the | + second argument to `try-load' (note that #f is acceptable). This | + value will be used to read code during calls to `scm:load'. The | + value of `*slib-load-reader*' will similarly be used during calls | + to `slib:load' and `require'. | + | + In order to disable all line-numbering, it is sufficient to set! | + `*load-reader*' and `*slib-load-reader*' to #f. | + | + +File: scm.info, Node: Soft Ports, Next: Syntax Extensions, Prev: Line Numbers, Up: The Language + | Soft Ports ========== A "soft-port" is a port based on a vector of procedures capable of accepting or delivering characters. It allows emulation of I/O ports. - - Function: make-soft-port VECTOR MODES + - Function: make-soft-port vector modes Returns a port capable of receiving or delivering characters as specified by the MODES string (*note open-file: Files and Ports.). VECTOR must be a vector of length 6. Its components are as @@ -2561,6 +2710,9 @@ accepting or delivering characters. It allows emulation of I/O ports. (r5rs)Input.) it indicates that the port has reached end-of-file. For example: + If it is necessary to explicitly close the port when it is garbage | + collected, (*note add-finalizer: Interrupts.). | + | (define stdout (current-output-port)) (define p (make-soft-port (vector @@ -2579,7 +2731,7 @@ File: scm.info, Node: Syntax Extensions, Next: Low Level Syntactic Hooks, Pre Syntax Extensions ================= - - procedure: procedure-documentation PROC + - procedure: procedure-documentation proc Returns the documentation string of PROC if it exists, or `#f' if not. @@ -2595,18 +2747,18 @@ Syntax Extensions => #<unspecified> (procedure-documentation square) => "Return the square of X." - - Function: comment STRING1 ... | - Appends STRING1 ... to the strings given as arguments to previous | - calls `comment'. | - | - - Function: comment | - Returns the (appended) strings given as arguments to previous calls | - `comment' and empties the current string collection. | - | - - Read syntax: #;text-till-end-of-line | - Behaves as `(comment "TEXT-TILL-END-OF-LINE")'. | - | - - Read syntax: #. EXPRESSION + - Function: comment string1 ... + Appends STRING1 ... to the strings given as arguments to previous + calls `comment'. + + - Function: comment + Returns the (appended) strings given as arguments to previous calls + `comment' and empties the current string collection. + + - Read syntax: #;text-till-end-of-line + Behaves as `(comment "TEXT-TILL-END-OF-LINE")'. + + - Read syntax: #. expression Is read as the object resulting from the evaluation of EXPRESSION. This substitution occurs even inside quoted structure. @@ -2617,7 +2769,7 @@ Syntax Extensions #.(define foo 9) => #<unspecified> '(#.foo #.(+ foo foo)) => (9 18) - - Read syntax: #+ FEATURE FORM + - Read syntax: #+ feature form If feature is `provided?' (by `*features*') then FORM is read as a scheme expression. If not, then FORM is treated as whitespace. @@ -2627,19 +2779,19 @@ Syntax Extensions For more information on `provided?' and `*features*', *Note Require: (slib)Require. - - Read syntax: #- FEATURE FORM + - Read syntax: #- feature form is equivalent to `#+(not feature) expression'. - - Read syntax: #' FORM + - Read syntax: #' form is equivalent to FORM (for compatibility with common-lisp). - - Read syntax: #| ANY THING |# + - Read syntax: #| any thing |# Is a balanced comment. Everything up to the matching `|#' is ignored by the `read'. Nested `#|...|#' can occur inside ANY THING. A similar read syntax "#!" (exclamation rather than vertical bar) is -supported for Posix shell-scripts (*note Scripting::.). +supported for Posix shell-scripts (*note Scripting::). - Read syntax: #\token If TOKEN is a sequence of two or more digits, then this syntax is @@ -2650,31 +2802,31 @@ supported for Posix shell-scripts (*note Scripting::.). followed by a character, then a meta character is read. `c-' and `m-' prefixes may be combined. - - Special Form: defined? SYMBOL + - Special Form: defined? symbol Equivalent to `#t' if SYMBOL is a syntactic keyword (such as `if') or a symbol with a value in the top level environment (*note Variables and regions: (r5rs)Variables and regions.). Otherwise equivalent to `#f'. - - Special Form: defvar IDENTIFIER INITIAL-VALUE + - Special Form: defvar identifier initial-value If IDENTIFIER is unbound in the top level environment, then IDENTIFIER is `define'd to the result of evaluating the form INITIAL-VALUE as if the `defvar' form were instead the form `(define identifier initial-value)' . If IDENTIFIER already has a - value, then INITIAL-VALUE is *not* evaluated and IDENTIFIER's + value, then INITIAL-VALUE is _not_ evaluated and IDENTIFIER's value is not changed. `defconst' is valid only when used at top-level. - - Special Form: defconst IDENTIFIER VALUE + - Special Form: defconst identifier value If IDENTIFIER is unbound in the top level environment, then IDENTIFIER is `define'd to the result of evaluating the form VALUE as if the `defconst' form were instead the form `(define identifier value)' . If IDENTIFIER already has a value, then - VALUE is *not* evaluated, IDENTIFIER's value is not changed, and + VALUE is _not_ evaluated, IDENTIFIER's value is not changed, and an error is signaled. `defconst' is valid only when used at top-level. - - Special Form: set! (VARIABLE1 VARIABLE2 ...) <expression> + - Special Form: set! (variable1 variable2 ...) <expression> The identifiers VARIABLE1, VARIABLE2, ... must be bound either in some region enclosing the `set!' expression or at top level. @@ -2685,12 +2837,12 @@ supported for Posix shell-scripts (*note Scripting::.). (define x 2) (define y 3) (+ x y) => 5 - (set! (x y) (list 4 5)) => *unspecified* + (set! (x y) (list 4 5)) => _unspecified_ (+ x y) => 9 - - Special Form: casev KEY CLAUSE1 CLAUSE2 ... - `casev' is an extension of standard Scheme `case': Each CLAUSE of - a `casev' statement must have as first element a list containing + - Special Form: qase key clause1 clause2 ... | + `qase' is an extension of standard Scheme `case': Each CLAUSE of a | + `qase' statement must have as first element a list containing | elements which are: * literal datums, or @@ -2700,7 +2852,7 @@ supported for Posix shell-scripts (*note Scripting::.). * a comma followed by an at-sign (@) followed by the name of a symbolic constant whose value is a list. - A `casev' statement is equivalent to a `case' statement in which + A `qase' statement is equivalent to a `case' statement in which | these symbolic constants preceded by commas have been replaced by the values of the constants, and all symbolic constants preceded by comma-at-signs have been replaced by the elements of the list @@ -2709,19 +2861,19 @@ supported for Posix shell-scripts (*note Scripting::.). unquoted expressions must be "symbolic constants". Symbolic constants are defined using `defconst', their values are - substituted in the head of each `casev' clause during macro + substituted in the head of each `qase' clause during macro | expansion. `defconst' constants should be defined before use. - `casev' can be substituted for any correct use of `case'. + `qase' can be substituted for any correct use of `case'. | (defconst unit '1) (defconst semivowels '(w y)) - (casev (* 2 3) + (qase (* 2 3) | ((2 3 5 7) 'prime) ((,unit 4 6 8 9) 'composite)) ==> composite - (casev (car '(c d)) + (qase (car '(c d)) | ((a) 'a) - ((b) 'b)) ==> *unspecified* - (casev (car '(c d)) + ((b) 'b)) ==> _unspecified_ + (qase (car '(c d)) | ((a e i o u) 'vowel) ((,@semivowels) 'semivowel) (else 'consonant)) ==> consonant @@ -2731,13 +2883,85 @@ SCM also supports the following constructs from Common Lisp: `defmacro', `macroexpand', `macroexpand-1', and `gentemp'. *Note Defmacro: (slib)Defmacro. +SCM `defmacro' is extended over that described for SLIB: + + (defmacro (macro-name . arguments) body) + +is equivalent to + + (defmacro macro-name arguments body) + +As in Common Lisp, an element of the formal argument list for +`defmacro' may be a possibly nested list, in which case the +corresponding actual argument must be a list with as many members as the +formal argument. Rest arguments are indicated by improper lists, as in +Scheme. It is an error if the actual argument list does not have the +tree structure required by the formal argument list. + +For example: + + (defmacro (let1 ((name value)) . body) + `((lambda (,name) ,@body) ,value)) + + (let1 ((x (foo))) (print x) x) == ((lambda (x) (print x) x) (foo)) + + (let1 not legal syntax) error--> not "does not match" ((name value)) + +SCM supports [R5RS] `syntax-rules' macros *Note Macros: (r5rs)Macros. + +The pattern language is extended by the syntax `(... <obj>)', which is | +identical to `<obj>' except that ellipses in `<obj>' are treated as | +ordinary identifiers in a template, or as literals in a pattern. In | +particular, `(... ...)' quotes the ellipsis token `...' in a pattern or | +template. | + +For example: + (define-syntax check-tree + (syntax-rules () + ((_ (?pattern (... ...)) ?obj) + (let loop ((obj ?obj)) + (or (null? obj) + (and (pair? obj) + (check-tree ?pattern (car obj)) + (loop (cdr obj)))))) + ((_ (?first . ?rest) ?obj) + (let ((obj ?obj)) + (and (pair? obj) + (check-tree ?first (car obj)) + (check-tree ?rest (cdr obj))))) + ((_ ?atom ?obj) #t))) + + (check-tree ((a b) ...) '((1 2) (3 4) (5 6))) => #t + + (check-tree ((a b) ...) '((1 2) (3 4) not-a-2list) => #f + +Note that although the ellipsis is matched as a literal token in the +defined macro it is not included in the literals list for +`syntax-rules'. + +The pattern language is also extended to support identifier macros. A +reference to an identifier macro keyword that is not the first +identifier in a form may expand into Scheme code, rather than raising a +"keyword as variable" error. The pattern for expansion of such a bare +macro keyword is a single identifier, as in other syntax rules the +identifier is ignored. + +For example: + (define-syntax eight + (syntax-rules () + (_ 8))) + + (+ 3 eight) => 11 + (eight) => ERROR + (set! eight 9) => ERROR + File: scm.info, Node: Low Level Syntactic Hooks, Next: Syntactic Hooks for Hygienic Macros, Prev: Syntax Extensions, Up: The Language Low Level Syntactic Hooks ========================= - - Callback procedure: read:sharp C PORT + - Callback procedure: read:sharp c port If a <#> followed by a character (for a non-standard syntax) is encountered by `read', `read' will call the value of the symbol `read:sharp' with arguments the character and the port being read @@ -2747,7 +2971,7 @@ Low Level Syntactic Hooks whitespace. `#<unspecified>' is the value returned by the expression `(if #f #f)'. - - Callback procedure: read:sharp-char TOKEN + - Callback procedure: read:sharp-char token If the sequence <#\> followed by a non-standard character name is encountered by `read', `read' will call the value of the symbol `read:sharp-char' with the token (a string of length at least two) @@ -2755,19 +2979,20 @@ Low Level Syntactic Hooks be the value of `read' for this expression, otherwise an error will be signaled. -*Note:* When adding new <#> syntaxes, have your code save the previous +_Note:_ When adding new <#> syntaxes, have your code save the previous value of `read:sharp' or `read:sharp-char' when defining it. Call this saved value if an invocation's syntax is not recognized. This will allow `#+', `#-', `#!', and *Note Uniform Array::s to still be supported (as they use `read:sharp'). - - Function: procedure->syntax PROC + - Function: procedure->syntax proc Returns a "macro" which, when a symbol defined to this value appears as the first symbol in an expression, returns the result of applying PROC to the expression and the environment. - - Function: procedure->macro PROC - - Function: procedure->memoizing-macro PROC + - Function: procedure->macro proc + - Function: procedure->memoizing-macro proc + - Function: procedure->identifier-macro Returns a "macro" which, when a symbol defined to this value appears as the first symbol in an expression, evaluates the result of applying PROC to the expression and the environment. The value @@ -2775,30 +3000,72 @@ supported (as they use `read:sharp'). `PROCEDURE->MEMOIZING-MACRO' replaces the form passed to PROC. For example: - (define trace + (defsyntax trace | (procedure->macro (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) (trace foo) == (set! foo (tracef foo 'foo)). - - Function: environment->tree ENV - An "environment" is an opaque object representing lexical bindings. - `environment->tree' returns a representation of the environment - ENV as a list of environment frames. There are 2 types of - environment frames: + `PROCEDURE->IDENTIFIER-MACRO' is similar to + `PROCEDURE->MEMOIZING-MACRO' except that PROC is also called in + case the symbol bound to the macro appears in an expression but + _not_ as the first symbol, that is, when it looks like a variable + reference. In that case, the form passed to PROC is a single + identifier. + + + - Special Form: defsyntax name expr | + Defines NAME as a macro keyword bound to the result of evaluating | + EXPR, which should be a macro. Using `define' for this purpose | + may not result in NAME being interpreted as a macro keyword. | + | +An "environment" is a list of frames representing lexical bindings. | +Only the names and scope of the bindings are included in environments | +passed to macro expanders - run-time values are not included. | + | +There are several types of environment frames: | - `((lambda (variable1 ...) ...) value1 ...)' - `(let ((variable1 value1) (variable2 value2) ...) ...)' - `(letrec ((variable1 value1) ...) ...)' - result in a single enviroment frame: - ((variable1 ...) value1 ...) +`((lambda (variable1 ...) ...) value1 ...)' +`(let ((variable1 value1) (variable2 value2) ...) ...)' +`(letrec ((variable1 value1) ...) ...)' + result in a single enviroment frame: + | + (variable1 variable2 ...) | - `(let ((variable1 value1)) ...)' - `(let* ((variable1 value1) ...) ...)' - result in an environment frame for each variable: - (variable1 . value1) (variable2 . value2) ... +`(let ((variable1 value1)) ...)' +`(let* ((variable1 value1) ...) ...)' + result in an environment frame for each variable: + | + variable1 variable2 ... | + | +`(let-syntax ((key1 macro1) (key2 macro2)) ...)' | +`(letrec-syntax ((key1 value1) (key2 value2)) ...)' | + Lexically bound macros result in environment frames consisting of | + a marker and an alist of keywords and macro objects: | + | + (<env-syntax-marker> (key1 . value1) (key2 . value2)) | + Currently <env-syntax-marker> is the integer 6. | + | +`line numbers' | + Line numbers (*note Line Numbers::) may be included in the | + environment as frame entries to indicate the line number on which | + a function is defined. They are ignored for variable lookup. | + | + #<line 8> | + | +`miscellaneous' | + Debugging information is stored in environments in a plist format: | + Any exact integer stored as an environment frame may be followed | + by any value. The two frame entries are ignored when doing | + variable lookup. Load file names, procedure names, and closure | + documentation strings are stored in this format. | + | + <env-filename-marker> "foo.scm" <env-procedure-name-marker> foo ... | + | + Currently <env-filename-marker> is the integer 1 and | + <env-procedure-name-marker> the integer 2. | - - Special Form: @apply PROCEDURE ARGUMENT-LIST + - Special Form: @apply procedure argument-list Returns the result of applying PROCEDURE to ARGUMENT-LIST. `@apply' differs from `apply' when the identifiers bound by the closure being applied are `set!'; setting affects ARGUMENT-LIST. @@ -2810,13 +3077,6 @@ supported (as they use `read:sharp'). Thus a mutable environment can be treated as both a list and local bindings. - - Special Form: @call-with-current-continuation PROCEDURE - Returns the result of applying PROCEDURE to the current - continuation. A "continuation" is a SCM object of type `contin' - (*note Continuations::.). The procedure - `(call-with-current-continuation PROCEDURE)' is defined to have - the same effect as `(@call-with-current-continuation procedure)'. - File: scm.info, Node: Syntactic Hooks for Hygienic Macros, Prev: Low Level Syntactic Hooks, Up: The Language @@ -2827,9 +3087,9 @@ SCM provides a synthetic identifier type for efficient implementation of hygienic macros (for example, `syntax-rules' *note Macros: (r5rs)Macros.) A synthetic identifier may be inserted in Scheme code by a macro expander in any context where a symbol would normally be used. -Collectively, symbols and synthetic identifiers are *identifiers*. +Collectively, symbols and synthetic identifiers are _identifiers_. - - Function: identifier? OBJ + - Function: identifier? obj Returns `#t' if OBJ is a symbol or a synthetic identifier, and `#f' otherwise. @@ -2842,7 +3102,7 @@ environment which has been passed to a "macro expander" (a procedure passed as an argument to `procedure->macro', `procedure->memoizing-macro', or `procedure->syntax'). - - Function: renamed-identifier PARENT ENV + - Function: renamed-identifier parent env Returns a synthetic identifier. PARENT must be an identifier, and ENV must either be `#f' or a lexical environment passed to a macro expander. `renamed-identifier' returns a distinct object for each @@ -2853,7 +3113,7 @@ identifier, those data are used during variable lookup. If a synthetic identifier is inserted as quoted data then during macro expansion it will be repeatedly replaced by its parent, until a symbol is obtained. - - Function: identifier->symbol ID + - Function: identifier->symbol id Returns the symbol obtained by recursively extracting the parent of ID, which must be an identifier. @@ -2868,7 +3128,8 @@ Use of synthetic identifiers If an identifier returned by this version of `gentemp' is inserted in a binding position as the name of a variable then it is guaranteed that -no other identifier may denote that variable. If an identifier +no other identifier (except one produced by passing the first to +`renamed-identifier') may denote that variable. If an identifier returned by `gentemp' is inserted free, then it will denote the top-level value bound to its parent, the symbol named "An unlikely variable". This behavior, of course, is meant to be put to good use: @@ -2890,31 +3151,25 @@ In other words, we can avoid capturing `foo'. If a lexical environment is passed as the second argument to `renamed-identifier' then if the identifier is inserted free its parent will be looked up in that environment, rather than in the top-level -environment. The use of such an identifier *must* be restricted to the +environment. The use of such an identifier _must_ be restricted to the lexical scope of its environment. There is another restriction imposed for implementation convenience: Macros passing their lexical environments to `renamed-identifier' may -be lexically bound only by the special forms `@let-syntax' or -`@letrec-syntax'. No error is signaled if this restriction is not met, +be lexically bound only by the special forms `let-syntax' or | +`letrec-syntax'. No error is signaled if this restriction is not met, | but synthetic identifier lookup will not work properly. - - - Special Form: @let-syntax - - Special Form: @letrec-syntax - Behave as `let' and `letrec', but may also put extra information - in the lexical environment so that `renamed-identifier' will work - properly during expansion of the macros bound by these forms. - + | In order to maintain referential transparency it is necessary to determine whether two identifiers have the same denotation. With synthetic identifiers it is not necessary that two identifiers be `eq?' in order to denote the same binding. - - Function: identifier-equal? ID1 ID2 ENV + - Function: identifier-equal? id1 id2 env Returns `#t' if identifiers ID1 and ID2 denote the same binding in - lexical environment ENV, and `#f' otherwise. ENV must be a + lexical environment ENV, and `#f' otherwise. ENV must either be a lexical environment passed to a macro transformer during macro - expansion. + expansion or the empty list. For example, (define top-level-foo? @@ -2928,13 +3183,13 @@ in order to denote the same binding. (let ((foo 'local)) (top-level-foo? foo)) => #f - - Function: @macroexpand1 EXPR ENV + - Function: @macroexpand1 expr env If the `car' of EXPR denotes a macro in ENV, then if that macro is a primitive, EXPR will be returned, if the macro was defined in Scheme, then a macro expansion will be returned. If the `car' of EXPR does not denote a macro, the `#f' is returned. - - Function: extended-environment NAMES VALUES ENV + - Function: extended-environment names values env Returns a new environment object, equivalent to ENV, which must either be an environment object or null, extended by one frame. NAMES must be an identifier, or an improper list of identifiers, @@ -2944,13 +3199,13 @@ in order to denote the same binding. list then VALS may be, respectively, any object or an improper list of objects. - - Special Form: syntax-quote OBJ + - Special Form: syntax-quote obj Synthetic identifiers are converted to their parent symbols by `quote' and `quasiquote' so that literal data in macro definitions will be properly transcribed. `syntax-quote' behaves like `quote', but preserves synthetic identifier intact. - - Special Form: the-macro MAC + - Special Form: the-macro mac `the-macro' is the simplest of all possible macro transformers: MAC may be a syntactic keyword (macro name) or an expression evaluating to a macro, otherwise an error is signaled. MAC is @@ -2963,18 +3218,18 @@ in order to denote the same binding. ;; code that will continue to work even if LET is redefined. ...) - - Special Form: renaming-transformer PROC + - Special Form: renaming-transformer proc A low-level "explicit renaming" macro facility very similar to that proposed by W. Clinger [Exrename] is supported. Syntax may be defined in `define-syntax', `let-syntax', and `letrec-syntax' using `renaming-transformer' instead of `syntax-rules'. PROC should evaluate to a procedure accepting three arguments: EXPR, - RENAME, and COMPARE. EXPR is a representation of Scheme code to be - expanded, as list structure. RENAME is a procedure accepting an - identifier and returning an identifier renamed in the definition - environment of the new syntax. COMPARE accepts two identifiers - and returns true if and only if both denote the same binding in - the usage environment of the new syntax. + RENAME, and COMPARE. EXPR is a representation of Scheme code to + be expanded, as list structure. RENAME is a procedure accepting + an identifier and returning an identifier renamed in the + definition environment of the new syntax. COMPARE accepts two + identifiers and returns true if and only if both denote the same + binding in the usage environment of the new syntax. File: scm.info, Node: Packages, Next: The Implementation, Prev: The Language, Up: Top @@ -2983,14 +3238,15 @@ Packages ******** * Menu: - -* Compiling And Linking:: Hobbit + | * Dynamic Linking:: * Dump:: Create Fast-Booting Executables * Numeric:: Numeric Language Extensions * Arrays:: As in APL +* Records:: Define new aggregate data types | * I/O-Extensions:: i/o-extensions * Posix Extensions:: posix +* Unix Extensions:: non-posix unix | * Regular Expression Pattern Matching:: regex * Line Editing:: edit-line * Curses:: Screen Control @@ -2999,57 +3255,11 @@ Packages * Menu: * Xlib: (Xlibscm). X Window Graphics. +* Hobbit: (hobbit). Scheme-to-C Compiler. | -File: scm.info, Node: Compiling And Linking, Next: Dynamic Linking, Prev: Packages, Up: Packages - -Compiling And Linking -===================== - - - Function: compile-file NAME1 NAME2 ... - If the HOBBIT compiler is installed in the - `(implementation-vicinity)', compiles the files NAME1 NAME2 ... to - an object file name NAME1<object-suffix>, where <object-suffix> is - the object file suffix for your computer (for instance, `.o'). - NAME1 must be in the current directory; NAME2 ... can be in other - directories. - - - Function: link-named-scm NAME MODULE1 ... - Creates a new SCM executable with name NAME. NAME will include - the object modules MODULE1 ... which can be produced with - `compile-file'. - - cd ~/scm/ - scm -e'(link-named-scm"cute""cube")' - (delete-file "scmflags.h") - (call-with-output-file - "scmflags.h" - (lambda (fp) - (for-each - (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"/home/jaffer/scm/Init5d2.scm\"" | - "#define COMPILED_INITS init_cube();" - "#define BIGNUMS" - "#define FLOATS" - "#define ARRAYS")))) - (system "gcc -Wall -O2 -c continue.c findexec.c time.c - repl.c scl.c eval.c sys.c subr.c unif.c rope.c scm.c") - ... - scm.c: In function `scm_init_extensions': - scm.c:95: warning: implicit declaration of function `init_cube' - scm.c: In function `scm_cat_path': - scm.c:589: warning: implicit declaration of function `realloc' - scm.c:594: warning: implicit declaration of function `malloc' - scm.c: In function `scm_try_path': - scm.c:612: warning: implicit declaration of function `free' - (system "cc -o cute continue.o findexec.o time.o repl.o scl.o - eval.o sys.o subr.o unif.o rope.o scm.o cube.o -lm -lc") - - Compilation finished at Sun Jul 21 00:59:17 - - -File: scm.info, Node: Dynamic Linking, Next: Dump, Prev: Compiling And Linking, Up: Packages - +File: scm.info, Node: Dynamic Linking, Next: Dump, Prev: Packages, Up: Packages + | Dynamic Linking =============== @@ -3057,24 +3267,24 @@ If SCM has been compiled with `dynl.c' then the additional properties of load and ([SLIB]) require specified here are supported. The `require' form is preferred. - - Function: require FEATURE + - Function: require feature If the symbol FEATURE has not already been given as an argument to `require', then the object and library files associated with FEATURE will be dynamically-linked, and an unspecified value returned. If FEATURE is not found in `*catalog*', then an error is signaled. - - Function: usr:lib LIB + - Function: usr:lib lib Returns the pathname of the C library named LIB. For example: `(usr:lib "m")' returns `"/usr/lib/libm.a"', the path of the C math library. - - Function: x:lib LIB + - Function: x:lib lib Returns the pathname of the X library named LIB. For example: `(x:lib "X11")' returns `"/usr/X11/lib/libX11.sa"', the path of the X11 library. - - Function: load FILENAME LIB1 ... + - Function: load filename lib1 ... In addition to the [R5RS] requirement of loading Scheme expressions if FILENAME is a Scheme source file, `load' will also dynamically load/link object files (produced by `compile-file', for @@ -3103,7 +3313,7 @@ of load and ([SLIB]) require specified here are supported. The or (require 'turtle-graphics) And the string regular expression (*note Regular Expression - Pattern Matching::.) package is linked by: + Pattern Matching::) package is linked by: (load (in-vicinity (implementation-vicinity) "rgx") (usr:lib "c")) or @@ -3113,7 +3323,7 @@ The following functions comprise the low-level Scheme interface to dynamic linking. See the file `Link.scm' in the SCM distribution for an example of their use. - - Function: dyn:link FILENAME + - Function: dyn:link filename FILENAME should be a string naming an "object" or "archive" file, the result of C-compiling. The `dyn:link' procedure links and loads FILENAME into the current SCM session. If successfull, @@ -3121,7 +3331,7 @@ an example of their use. second argument to `dyn:call'. If not successful, `#f' is returned. - - Function: dyn:call NAME LINK-TOKEN + - Function: dyn:call name link-token LINK-TOKEN should be the value returned by a call to `dyn:link'. NAME should be the name of C function of no arguments defined in the file named FILENAME which was succesfully `dyn:link'ed in the @@ -3133,7 +3343,7 @@ an example of their use. SCM object files. The init_... function then makes the identifiers defined in the file accessible as Scheme procedures. - - Function: dyn:main-call NAME LINK-TOKEN ARG1 ... + - Function: dyn:main-call name link-token arg1 ... LINK-TOKEN should be the value returned by a call to `dyn:link'. NAME should be the name of C function of 2 arguments, `(int argc, char **argv)', defined in the file named FILENAME which was @@ -3145,10 +3355,10 @@ an example of their use. `dyn:main-call' can be used to call a `main' procedure from SCM. For example, I link in and `dyn:main-call' a large C program, the - low level routines of which callback (*note Callbacks::.) into SCM + low level routines of which callback (*note Callbacks::) into SCM (which emulates PCI hardware). - - Function: dyn:unlink LINK-TOKEN + - Function: dyn:unlink link-token LINK-TOKEN should be the value returned by a call to `dyn:link'. The `dyn:unlink' procedure removes the previously loaded file from the current SCM session. If successful, `dyn:unlink' returns @@ -3170,10 +3380,10 @@ There are constraints on which sessions are savable using `dump' * Saved continuations are invalid in subsequent invocations; they cause segmentation faults and other unpleasant side effects. - * Although DLD (*note Dynamic Linking::.) can be used to load - compiled modules both before and after dumping, `SUN_DL' ELF - systems can load compiled modules only after dumping. This can be - worked around by compiling in those features you wish to `dump'. + * Although DLD (*note Dynamic Linking::) can be used to load compiled + modules both before and after dumping, `SUN_DL' ELF systems can + load compiled modules only after dumping. This can be worked + around by compiling in those features you wish to `dump'. * Ports (other than `current-input-port', `current-output-port', `current-error-port'), X windows, etc. are invalid in subsequent @@ -3186,17 +3396,17 @@ There are constraints on which sessions are savable using `dump' * `Dump' can be called from the command line. - - Function: dump NEWPATH - - Function: dump NEWPATH #F - - Function: dump NEWPATH #T - - Function: dump NEWPATH THUNK + - Function: dump newpath + - Function: dump newpath #f + - Function: dump newpath #t + - Function: dump newpath thunk * Calls `gc'. * Creates an executable program named NEWPATH which continues the state of the current SCM session when invoked. The optional argument THUNK, if provided, should be a procedure - of no arguments. This procedure will be called in the - restored executable. + of no arguments; BOOT-TAIL will be set to this procedure, | + causing it to be called in the restored executable. | If the optional argument is missing or a boolean, SCM's standard command line processing will be called in the @@ -3216,18 +3426,15 @@ There are constraints on which sessions are savable using `dump' *INTERACTIVE*. `dump' returns an unspecified value. When a dumped executable is invoked, the variable *INTERACTIVE* (*note -Internal State::.) has the value it possessed when `dump' created it. +Internal State::) has the value it possessed when `dump' created it. Calling `dump' with a single argument sets *INTERACTIVE* to `#f', which is the state it has at the beginning of command line processing. The procedure `program-arguments' returns the command line arguments for the curent invocation. More specifically, `program-arguments' for -the restored session are *not* saved from the dumping session. Command +the restored session are _not_ saved from the dumping session. Command line processing is done on the value of the identifier `*argv*'. - -The thunk `boot-tail' is called by SCM to process command line -arguments. `dump' sets `boot-tail' to the THUNK it is called with. - + | The following example shows how to create `rscm', which is like regular scm, but which loads faster and has the `random' package alreadly provided. @@ -3244,7 +3451,7 @@ provided. bash$ This task can also be accomplished using the `-o' command line option -(*note SCM Options::.). +(*note SCM Options::). bash$ scm -rrandom -o rscm > (quit) @@ -3268,53 +3475,63 @@ Numeric - Constant: most-negative-fixnum The immediate integer closest to negative infinity. + - Constant: $pi + - Constant: pi + The ratio of the circumference to the diameter of a circle. + These procedures augment the standard capabilities in *Note Numerical operations: (r5rs)Numerical operations. - - Function: sinh Z - - Function: cosh Z - - Function: tanh Z + - Function: pi* z + `(* pi Z)' + + - Function: pi/ z + `(/ pi Z)' + + - Function: sinh z + - Function: cosh z + - Function: tanh z Return the hyperbolic sine, cosine, and tangent of Z - - Function: asinh Z - - Function: acosh Z - - Function: atanh Z + - Function: asinh z + - Function: acosh z + - Function: atanh z Return the inverse hyperbolic sine, cosine, and tangent of Z - - Function: $sqrt X - - Function: $abs X - - Function: $exp X - - Function: $log X - - Function: $sin X - - Function: $cos X - - Function: $tan X - - Function: $asin X - - Function: $acos X - - Function: $atan X - - Function: $sinh X - - Function: $cosh X - - Function: $tanh X - - Function: $asinh X - - Function: $acosh X - - Function: $atanh X + - Function: $sqrt x + - Function: $abs x + - Function: $exp x + - Function: $log x + - Function: $sin x + - Function: $cos x + - Function: $tan x + - Function: $asin x + - Function: $acos x + - Function: $atan x + - Function: $sinh x + - Function: $cosh x + - Function: $tanh x + - Function: $asinh x + - Function: $acosh x + - Function: $atanh x Real-only versions of these popular functions. The argument X must be a real number. It is an error if the value which should be - returned by a call to these procedures is *not* real. + returned by a call to these procedures is _not_ real. - - Function: $log10 X + - Function: $log10 x Real-only base 10 logarithm. - - Function: $atan2 Y X + - Function: $atan2 y x Computes `(angle (make-rectangular x y))' for real numbers Y and X. - - Function: $expt X1 X2 + - Function: $expt x1 x2 Returns real number X1 raised to the real power X2. It is an error if the value which should be returned by a call to `$expt' is not real. -File: scm.info, Node: Arrays, Next: I/O-Extensions, Prev: Numeric, Up: Packages - +File: scm.info, Node: Arrays, Next: Records, Prev: Numeric, Up: Packages + | Arrays ====== @@ -3350,24 +3567,24 @@ indices expressed as a two element list, or an upper bound expressed as a single integer. So (make-array 'foo 3 3) == (make-array 'foo '(0 2) '(0 2)) - - Function: array? OBJ + - Function: array? obj Returns `#t' if the OBJ is an array, and `#f' if not. - - Function: make-array INITIAL-VALUE BOUND1 BOUND2 ... + - Function: make-array initial-value bound1 bound2 ... Creates and returns an array that has as many dimensions as there are BOUNDs and fills it with INITIAL-VALUE. - - Function: array-ref ARRAY INDEX1 INDEX2 ... + - Function: array-ref array index1 index2 ... Returns the INDEX1, INDEX2, ...'th element of ARRAY. - - Function: array-in-bounds? ARRAY INDEX1 INDEX2 ... + - Function: array-in-bounds? array index1 index2 ... Returns `#t' if its arguments would be acceptable to ARRAY-REF. - - Function: array-set! ARRAY NEW-VALUE INDEX1 INDEX2 ... + - Function: array-set! array new-value index1 index2 ... Sets the INDEX1, INDEX2, ...'th element of ARRAY to NEW-VALUE. The value returned by `array-set!' is unspecified. - - Function: make-shared-array ARRAY MAPPER BOUND1 BOUND2 ... + - Function: make-shared-array array mapper bound1 bound2 ... `make-shared-array' can be used to create shared subarrays of other arrays. The MAPPER is a function that translates coordinates in the new array into coordinates in the old array. A MAPPER must be @@ -3382,7 +3599,7 @@ a single integer. So (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) (array-ref freds-center 0 0) => foo - - Function: transpose-array ARRAY DIM0 DIM1 ... + - Function: transpose-array array dim0 dim1 ... Returns an array sharing contents with ARRAY, but with dimensions arranged in a different order. There must be one DIM argument for each dimension of ARRAY. DIM0, DIM1, ... should be integers @@ -3400,7 +3617,7 @@ a single integer. So (transpose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) => #2A((a 4) (b 5) (c 6)) - - Function: enclose-array ARRAY DIM0 DIM1 ... + - Function: enclose-array array dim0 dim1 ... DIM0, DIM1 ... should be nonnegative integers less than the rank of ARRAY. ENCLOSE-ARRAY returns an array resembling an array of shared arrays. The dimensions of each shared array are the same @@ -3421,51 +3638,50 @@ a single integer. So (enclose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) => #<enclosed-array #2A((a 1) (d 4)) #2A((b 2) (e 5)) #2A((c 3) (f 6))> - - Function: array-shape ARRAY + - Function: array-shape array Returns a list of inclusive bounds of integers. (array-shape (make-array 'foo '(-1 3) 5)) => ((-1 3) (0 4)) - - Function: array-dimensions ARRAY + - Function: array-dimensions array `Array-dimensions' is similar to `array-shape' but replaces - elements with a `0' minimum with one greater than the maximum. So: + elements with a `0' minimum with one greater than the maximum. So: (array-dimensions (make-array 'foo '(-1 3) 5)) => ((-1 3) 5) - - Function: array-rank OBJ + - Function: array-rank obj Returns the number of dimensions of OBJ. If OBJ is not an array, `0' is returned. - - Function: array->list ARRAY + - Function: array->list array Returns a list consisting of all the elements, in order, of ARRAY. In the case of a rank-0 array, returns the single element. - - Function: array-copy! SOURCE DESTINATION + - Function: array-copy! source destination Copies every element from vector or array SOURCE to the corresponding element of DESTINATION. DESTINATION must have the same rank as SOURCE, and be at least as large in each dimension. The order of copying is unspecified. - - Function: serial-array-copy! SOURCE DESTINATION + - Function: serial-array-copy! source destination Same as `array-copy!' but guaranteed to copy in row-major order. - - Function: array-fill! ARRAY FILL + - Function: array-fill! array fill Stores FILL in every element of ARRAY. The value returned is unspecified. - - Function: array-equal? ARRAY0 ARRAY1 ... + - Function: array-equal? array0 array1 ... Returns `#t' iff all arguments are arrays with the same shape, the same type, and have corresponding elements which are either `equal?' or `array-equal?'. This function differs from `equal?' in that a one dimensional shared array may be ARRAY-EQUAL? but not EQUAL? to a vector or uniform vector. - - Function: array-contents ARRAY - - Function: array-contents ARRAY STRICT + - Function: array-contents array + - Function: array-contents array strict If ARRAY may be "unrolled" into a one dimensional shared array without changing their order (last subscript changing fastest), then `array-contents' returns that shared array, otherwise it - returns `#f'. All arrays made by MAKE-ARRAY and - MAKE-UNIFORM-ARRAY may be unrolled, some arrays made by - MAKE-SHARED-ARRAY may not be. + returns `#f'. All arrays made by MAKE-ARRAY and CREATE-ARRAY may | + be unrolled, some arrays made by MAKE-SHARED-ARRAY may not be. | If the optional argument STRICT is provided, a shared array will be returned only if its elements are stored internally contiguous @@ -3479,7 +3695,7 @@ Array Mapping `(require 'array-for-each)' - - Function: array-map! ARRAY0 PROC ARRAY1 ... + - Function: array-map! array0 proc array1 ... If ARRAY1, ... are arrays, they must have the same number of dimensions as ARRAY0 and have a range for each index which includes the range for the corresponding index in ARRAY0. If they @@ -3491,15 +3707,15 @@ Array Mapping unspecified. - - Function: serial-array-map! ARRAY0 PROC ARRAY1 ... + - Function: serial-array-map! array0 proc array1 ... Same as ARRAY-MAP!, but guaranteed to apply PROC in row-major order. - - Function: array-for-each PROC ARRAY0 ... + - Function: array-for-each proc array0 ... PROC is applied to each tuple of elements of ARRAY0 ... in row-major order. The value returned is unspecified. - - Function: array-index-map! ARRAY PROC + - Function: array-index-map! array proc applies PROC to the indices of each element of ARRAY in turn, storing the result in the corresponding element. The value returned and the order of application are unspecified. @@ -3511,11 +3727,11 @@ Array Mapping ra)) Another example: (define (apl:index-generator n) - (let ((v (make-uniform-vector n 1))) + (let ((v (make-vector n 1))) | (array-index-map! v (lambda (i) i)) v)) - - Function: scalar->array SCALAR ARRAY PROTOTYPE + - Function: scalar->array scalar array prototype Returns a uniform array of the same shape as ARRAY, having only one shared element, which is `eqv?' to SCALAR. If the optional argument PROTOTYPE is supplied it will be used as the prototype @@ -3535,59 +3751,51 @@ same type. Uniform vectors occupy less storage than conventional vectors. Uniform Array procedures also work on vectors, uniform-vectors, bit-vectors, and strings. -PROTOTYPE arguments in the following procedures are interpreted -according to the table: - - prototype type display prefix - - #t boolean (bit-vector) #At - #\a char (string) #A\ - integer >0 unsigned integer #Au - integer <0 signed integer #Ae - 1.0 float (single precision) #Aif - 1/3 double (double precision float) #Aid - +i complex (double precision) #Aic - () conventional vector #A +SLIB now supports uniform arrys. The primary array creation procedure | +is `create-array', detailed in *Note Arrays: (slib)Arrays. | Unshared uniform character 0-based arrays of rank 1 (dimension) are equivalent to (and can't be distinguished from) strings. - (make-uniform-array #\a 3) => "$q2" + (create-array "" 3) => "$q2" | Unshared uniform boolean 0-based arrays of rank 1 (dimension) are equivalent to (and can't be distinguished from) *Note bit-vectors: Bit Vectors. - (make-uniform-array #t 3) => #*000 + (create-array '#at() 3) => #*000 | == #At(#f #f #f) => #*000 == #1At(#f #f #f) => #*000 -Other uniform vectors are written in a form similar to that of general -arrays, except that one or more modifying characters are put between -the #\A character and the contents list. For example, `'#Ae(3 5 9)' -returns a uniform vector of signed integers. +PROTOTYPE arguments in the following procedures are interpreted | +according to the table: | - - Function: uniform-vector-ref UVE INDEX - Returns the element at the INDEX element in UVE. - - - Function: uniform-vector-set! UVE INDEX NEW-VALUE - Sets the element at the INDEX element in UVE to NEW-VALUE. The - value returned by `uniform-vector-set!' is unspecified. + prototype type display prefix | + + () conventional vector #a | + +64i complex (double precision) #ac64 | + 64.0 double (double precision) #ar64 | + 32.0 float (single precision) #ar32 | + 32 unsigned integer (32-bit) #au32 | + -32 signed integer (32-bit) #as32 | + -16 signed integer (16-bit) #as16 | + #\a char (string) #a\ | + #t boolean (bit-vector) #at | + | +Other uniform vectors are written in a form similar to that of general | +arrays, except that one or more modifying characters are put between the | +#\A character and the contents list. For example, `'#As32(3 5 9)' | +returns a uniform vector of signed integers. | - - Function: array? OBJ PROTOTYPE + - Function: array? obj prototype Returns `#t' if the OBJ is an array of type corresponding to PROTOTYPE, and `#f' if not. - - - Function: make-uniform-array PROTOTYPE BOUND1 BOUND2 ... - Creates and returns a uniform array of type corresponding to - PROTOTYPE that has as many dimensions as there are BOUNDs. - - - Function: array-prototype ARRAY + | + - Function: array-prototype array Returns an object that would produce an array of the same type as - ARRAY, if used as the PROTOTYPE for `make-uniform-array'. + ARRAY, if used as the PROTOTYPE for `list->uniform-array'. | - - Function: list->uniform-array RANK PROT LST - - Function: list->uniform-vector PROT LST + - Function: list->uniform-array rank prot lst | Returns a uniform array of the type indicated by prototype PROT with elements the same as those of LST. Elements must be of the appropriate type, no coercions are done. @@ -3600,26 +3808,19 @@ returns a uniform vector of signed integers. If RANK is zero, LST, which need not be a list, is the single element of the returned array. - - Function: uniform-vector-fill! UVE FILL + - Function: uniform-vector-fill! uve fill Stores FILL in every element of UVE. The value returned is unspecified. - - - Function: uniform-vector-length UVE - Returns the number of elements in UVE. - - - Function: dimensions->uniform-array DIMS PROTOTYPE FILL - - Function: dimensions->uniform-array DIMS PROTOTYPE - - Function: make-uniform-vector LENGTH PROTOTYPE FILL - - Function: make-uniform-vector LENGTH PROTOTYPE + | + - Function: dimensions->uniform-array dims prototype fill + - Function: dimensions->uniform-array dims prototype | Creates and returns a uniform array or vector of type corresponding to PROTOTYPE with dimensions DIMS or length LENGTH. If the FILL argument is supplied, the returned array is filled with this value. - - Function: uniform-array-read! URA - - Function: uniform-array-read! URA PORT - - Function: uniform-vector-read! UVE - - Function: uniform-vector-read! UVE PORT + - Function: uniform-array-read! ura + - Function: uniform-array-read! ura port | Attempts to read all elements of URA, in lexicographic order, as binary objects from PORT. If an end of file is encountered during uniform-array-read! the objects up to that point only are put into @@ -3630,16 +3831,14 @@ returns a uniform vector of signed integers. may be omitted, in which case it defaults to the value returned by `(current-input-port)'. - - Function: uniform-array-write URA - - Function: uniform-array-write URA PORT - - Function: uniform-vector-write UVE - - Function: uniform-vector-write UVE PORT - Writes all elements of URA as binary objects to PORT. The number - of of objects actually written is returned. PORT may be omitted, + - Function: uniform-array-write ura + - Function: uniform-array-write ura port | + Writes all elements of URA as binary objects to PORT. The number + of of objects actually written is returned. PORT may be omitted, in which case it defaults to the value returned by `(current-output-port)'. - - Function: logaref ARRAY INDEX1 INDEX2 ... + - Function: logaref array index1 index2 ... If an INDEX is provided for each dimension of ARRAY returns the INDEX1, INDEX2, ...'th element of ARRAY. If one more INDEX is provided, then the last index specifies bit position of the @@ -3651,7 +3850,7 @@ returns a uniform vector of signed integers. (logaref '#(#b1101 #b0010) 0 1) => #f (logaref '#2((#b1101 #b0010)) 0 0) => #b1101 - - Function: logaset! ARRAY VAL INDEX1 INDEX2 ... + - Function: logaset! array val index1 index2 ... If an INDEX is provided for each dimension of ARRAY sets the INDEX1, INDEX2, ...'th element of ARRAY to VAL. If one more INDEX is provided, then the last index specifies bit position of the @@ -3674,18 +3873,18 @@ prefixed by `#*'. Some of these operations will eventually be generalized to other uniform-arrays. - - Function: bit-count BOOL BV + - Function: bit-count bool bv Returns the number occurrences of BOOL in BV. - - Function: bit-position BOOL BV K + - Function: bit-position bool bv k Returns the minimum index of an occurrence of BOOL in BV which is at least K. If no BOOL occurs within the specified range `#f' is returned. - - Function: bit-invert! BV + - Function: bit-invert! bv Modifies BV by replacing each element with its negation. - - Function: bit-set*! BV UVE BOOL + - Function: bit-set*! bv uve bool If uve is a bit-vector BV and uve must be of the same length. If BOOL is `#t', uve is OR'ed into BV; If BOOL is `#f', the inversion of uve is AND'ed into BV. @@ -3696,25 +3895,47 @@ uniform-arrays. The return value is unspecified. - - Function: bit-count* BV UVE BOOL + - Function: bit-count* bv uve bool Returns (bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). BV is not modified. -File: scm.info, Node: I/O-Extensions, Next: Posix Extensions, Prev: Arrays, Up: Packages - +File: scm.info, Node: Records, Next: I/O-Extensions, Prev: Arrays, Up: Packages + | +Records | +======= | + | +SCM provides user-definable datatypes with the same interface as SLIB, | +see *Note Records: (slib)Records, with the following extension. | + | + - Function: record-printer-set! rtd printer | + Causes records of type RTD to be printed in a user-specified | + format. RTD must be a record type descriptor returned by | + `make-record-type', PRINTER a procedure accepting three arguments: | + the record to be printed, the port to print to, and a boolean | + which is true if the record is being written on behalf of `write' | + and false if for `display'. If PRINTER returns #f, the default | + record printer will be called. | + | + A PRINTER value of #f means use the default printer. | + | + Only the default printer will be used when printing error messages. | + | + +File: scm.info, Node: I/O-Extensions, Next: Posix Extensions, Prev: Records, Up: Packages + | I/O-Extensions ============== If `'i/o-extensions' is provided (by linking in `ioext.o'), *Note Line I/O: (slib)Line I/O, and the following functions are defined: - - Function: stat <PORT-OR-STRING> + - Function: stat <port-or-string> Returns a vector of integers describing the argument. The argument - can be either a string or an open input port. If the argument is an - open port then the returned vector describes the file to which the - port is opened; If the argument is a string then the returned + can be either a string or an open input port. If the argument is + an open port then the returned vector describes the file to which + the port is opened; If the argument is a string then the returned vector describes the file named by that string. If there exists no file with the name string, or if the file cannot be accessed `#f' is returned. The elements of the returned vector are as @@ -3756,60 +3977,67 @@ I/O: (slib)Line I/O, and the following functions are defined: - Function: getpid Returns the process ID of the current process. - - Function: file-position PORT + - Function: file-position port Returns the current position of the character in PORT which will next be read or written. If PORT is not open to a file the result is unspecified. - - Function: file-set-position PORT INTEGER + - Function: file-set-position port integer Sets the current position in PORT which will next be read or written. If PORT is not open to a file the action of `file-set-position' is unspecified. The result of `file-set-position' is unspecified. - - Function: reopen-file FILENAME MODES PORT + - Function: try-create-file name modes perms | + If the file with name NAME already exists, return `#f', otherwise | + try to create and open the file like `try-open-file', *Note Files + and Ports::. If the optional integer argument PERMS is provided, | + it is used as the permissions of the new file (modified by the | + current umask). | + | + - Function: reopen-file filename modes port Closes port PORT and reopens it with FILENAME and MODES. `reopen-file' returns `#t' if successful, `#f' if not. - - Function: duplicate-port PORT MODES + - Function: duplicate-port port modes Creates and returns a "duplicate" port from PORT. Duplicate - *unbuffered* ports share one file position. MODES are as for + _unbuffered_ ports share one file position. MODES are as for *Note open-file: Files and Ports. - - Function: redirect-port! FROM-PORT TO-PORT + - Function: redirect-port! from-port to-port Closes TO-PORT and makes TO-PORT be a duplicate of FROM-PORT. `redirect-port!' returns TO-PORT if successful, `#f' if not. If unsuccessful, TO-PORT is not closed. - - Function: opendir DIRNAME + - Function: opendir dirname Returns a "directory" object corresponding to the file system directory named DIRNAME. If unsuccessful, returns `#f'. - - Function: readdir DIR + - Function: readdir dir Returns the string name of the next entry from the directory DIR. If there are no more entries in the directory, `readdir' returns a `#f'. - - Function: rewinddir DIR + - Function: rewinddir dir Reinitializes DIR so that the next call to `readdir' with DIR will return the first entry in the directory again. - - Function: closedir DIR + - Function: closedir dir Closes DIR and returns `#t'. If DIR is already closed,, `closedir' returns a `#f'. - - Function: directory-for-each PROC DIRECTORY + - Function: directory-for-each proc directory The LISTs must be lists, and PROC must be a procedure taking one argument. `Directory-For-Each' applies PROC to the (string) name of each file in DIRECTORY. The dynamic order in which PROC is applied to the elements of the LISTs is unspecified. The value returned by `directory-for-each' is unspecified. - - Function: directory-for-each PROC DIRECTORY PRED + - Function: directory-for-each proc directory pred Applies PROC only to those filenames for which the procedure PRED returns a non-false value. - - Function: directory-for-each PROC DIRECTORY MATCH + - Function: directory-for-each proc directory match Applies PROC only to those filenames for which `(filename:match?? MATCH)' would return a non-false value (*note Filenames: (slib)Filenames.). @@ -3822,9 +4050,9 @@ I/O: (slib)Line I/O, and the following functions are defined: "Link.scm" "Macro.scm" "Transcen.scm" - "Init5d2.scm" | + "Init5d6.scm" | - - Function: mkdir PATH MODE + - Function: mkdir path mode The `mkdir' function creates a new, empty directory whose name is PATH. The integer argument MODE specifies the file permissions for the new directory. *Note The Mode Bits for Access Permission: @@ -3833,12 +4061,12 @@ I/O: (slib)Line I/O, and the following functions are defined: `mkdir' returns if successful, `#f' if not. - - Function: rmdir PATH + - Function: rmdir path The `rmdir' function deletes the directory PATH. The directory must be empty before it can be removed. `rmdir' returns if successful, `#f' if not. - - Function: chdir FILENAME + - Function: chdir filename Changes the current directory to FILENAME. If FILENAME does not exist or is not a directory, `#f' is returned. Otherwise, `#t' is returned. @@ -3848,33 +4076,33 @@ I/O: (slib)Line I/O, and the following functions are defined: name representing the current working directory. If this string cannot be obtained, `#f' is returned. - - Function: rename-file OLDFILENAME NEWFILENAME + - Function: rename-file oldfilename newfilename Renames the file specified by OLDFILENAME to NEWFILENAME. If the renaming is successful, `#t' is returned. Otherwise, `#f' is returned. - - Function: chmod FILE MODE + - Function: chmod file mode The function `chmod' sets the access permission bits for the file named by FILE to MODE. The FILE argument may be a string containing the filename or a port open to the file. `chmod' returns if successful, `#f' if not. - - Function: utime PATHNAME ACCTIME MODTIME + - Function: utime pathname acctime modtime Sets the file times associated with the file named PATHNAME to have access time ACCTIME and modification time MODTIME. `utime' returns if successful, `#f' if not. - - Function: umask MODE + - Function: umask mode The function `umask' sets the file creation mask of the current process to MASK, and returns the previous value of the file creation mask. - - Function: fileno PORT + - Function: fileno port Returns the integer file descriptor associated with the port PORT. If an error is detected, `#f' is returned. - - Function: access PATHNAME HOW + - Function: access pathname how Returns `#t' if the file named by PATHNAME can be accessed in the way specified by the HOW argument. The HOW argument can be the `logior' of the flags: @@ -3900,8 +4128,8 @@ I/O: (slib)Line I/O, and the following functions are defined: <r> File-is-readable? - - Function: execl COMMAND ARG0 ... - - Function: execlp COMMAND ARG0 ... + - Function: execl command arg0 ... + - Function: execlp command arg0 ... Transfers control to program COMMAND called with arguments ARG0 .... For `execl', COMMAND must be an exact pathname of an executable file. `execlp' searches for COMMAND in the list of @@ -3911,13 +4139,13 @@ I/O: (slib)Line I/O, and the following functions are defined: If successful, this procedure does not return. Otherwise an error message is printed and the integer `errno' is returned. - - Function: execv COMMAND ARGLIST - - Function: execvp COMMAND ARGLIST + - Function: execv command arglist + - Function: execvp command arglist Like `execl' and `execlp' except that the set of arguments to COMMAND is ARGLIST. - - Function: putenv STRING - adds or removes definitions from the "environment". If the STRING + - Function: putenv string + adds or removes definitions from the "environment". If the STRING is of the form `NAME=VALUE', the definition is added to the environment. Otherwise, the STRING is interpreted as the name of an environment variable, and any definition for this variable in @@ -3935,32 +4163,40 @@ I/O: (slib)Line I/O, and the following functions are defined: (slib)System Interface.). -File: scm.info, Node: Posix Extensions, Next: Regular Expression Pattern Matching, Prev: I/O-Extensions, Up: Packages - +File: scm.info, Node: Posix Extensions, Next: Unix Extensions, Prev: I/O-Extensions, Up: Packages + | Posix Extensions ================ If `'posix' is provided (by linking in `posix.o'), the following functions are defined: - - Function: open-pipe STRING MODES + - Function: open-pipe string modes If the string MODES contains an <r>, returns an input port capable of delivering characters from the standard output of the system command STRING. Otherwise, returns an output port capable of receiving characters which become the standard input of the system command STRING. If a pipe cannot be created `#f' is returned. - - Function: open-input-pipe STRING + - Function: open-input-pipe string Returns an input port capable of delivering characters from the standard output of the system command STRING. If a pipe cannot be created `#f' is returned. - - Function: open-output-pipe STRING + - Function: open-output-pipe string Returns an output port capable of receiving characters which become the standard input of the system command STRING. If a pipe cannot be created `#f' is returned. - - Function: close-port PIPE + - Function: broken-pipe port | + If this function is defined at top level, it will be called when an | + output pipe is closed from the other side (this is the condition | + under which a SIGPIPE is sent). The already closed PORT will be | + passed so that any necessary cleanup may be done. An error is not | + signaled when output to a pipe fails in this way, but any further | + output to the closed pipe will cause an error to be signaled. | + | + - Function: close-port pipe Closes the PIPE, rendering it incapable of delivering or accepting characters. This routine has no effect if the pipe has already been closed. The value returned is unspecified. @@ -3982,6 +4218,11 @@ Persona. Returns the process ID of the parent of the current process. For a process's own ID *Note getpid: I/O-Extensions. + - Function: getlogin | + Returns the (login) name of the user logged in on the controlling | + terminal of the process, or #f if this information cannot be | + determined. | + | - Function: getuid Returns the real user ID of this process. @@ -3994,23 +4235,23 @@ Persona. - Function: geteuid Returns the effective user ID of this process. - - Function: setuid ID + - Function: setuid id Sets the real user ID of this process to ID. Returns `#t' if successful, `#f' if not. - - Function: setgid ID + - Function: setgid id Sets the real group ID of this process to ID. Returns `#t' if successful, `#f' if not. - - Function: setegid ID + - Function: setegid id Sets the effective group ID of this process to ID. Returns `#t' if successful, `#f' if not. - - Function: seteuid ID + - Function: seteuid id Sets the effective user ID of this process to ID. Returns `#t' if successful, `#f' if not. - - Function: kill PID SIG + - Function: kill pid sig The `kill' function sends the signal SIGNUM to the process or process group specified by PID. Besides the signals listed in *Note Standard Signals: (libc)Standard Signals, SIGNUM can also @@ -4049,7 +4290,7 @@ Persona. There's no way you can tell which of the processes got the signal or whether all of them did. - - Function: waitpid PID OPTIONS + - Function: waitpid pid options The `waitpid' function suspends execution of the current process until a child as specified by the PID argument has exited, or until a signal is delivered whose action is to terminate the @@ -4088,12 +4329,14 @@ Persona. 3. Which means both of the above. - The return value is normally the process ID of the child process - whose status is reported. If the `WNOHANG' option was specified - and no child process is waiting to be noticed, the value is zero. - A value of `#f' is returned in case of error and `errno' is set. - For information about the `errno' codes *Note Process Completion: - (GNU C Library)Process Completion. + The return value normally is the exit status of the child process, + including the exit value along with flags indicating whether a + coredump was generated or the child terminated as a result of a + signal. If the `WNOHANG' option was specified and no child + process is waiting to be noticed, the value is zero. A value of + `#f' is returned in case of error and `errno' is set. For + information about the `errno' codes *Note Process Completion: (GNU + C Library)Process Completion. - Function: uname You can use the `uname' procedure to find out some information @@ -4116,8 +4359,8 @@ Persona. Some examples are `"i386-ANYTHING"', `"m68k-hp"', `"sparc-sun"', `"m68k-sun"', `"m68k-sony"' and `"mips-dec"'. - - Function: getpw NAME - - Function: getpw UID + - Function: getpw name + - Function: getpw uid - Function: getpw Returns a vector of information for the entry for `NAME', `UID', or the next entry if no argument is given. The information is: @@ -4140,15 +4383,15 @@ Persona. user logs in, or `#f', indicating that the system default should be used. - - Function: setpwent #T + - Function: setpwent #t Rewinds the pw entry table back to the begining. - - Function: setpwent #F + - Function: setpwent #f - Function: setpwent Closes the pw table. - - Function: getgr NAME - - Function: getgr UID + - Function: getgr name + - Function: getgr uid - Function: getgr Returns a vector of information for the entry for `NAME', `UID', or the next entry if no argument is given. The information is: @@ -4161,75 +4404,78 @@ Persona. 3. A list of (string) names of users in the group. - - Function: setgrent #T + - Function: setgrent #t Rewinds the group entry table back to the begining. - - Function: setgrent #F + - Function: setgrent #f - Function: setgrent Closes the group table. - Function: getgroups Returns a vector of all the supplementary group IDs of the process. - - Function: link OLDNAME NEWNAME + - Function: link oldname newname The `link' function makes a new link to the existing file named by OLDNAME, under the new name NEWNAME. `link' returns a value of `#t' if it is successful and `#f' on failure. - - Function: chown FILENAME OWNER GROUP + - Function: chown filename owner group The `chown' function changes the owner of the file FILENAME to OWNER, and its group owner to GROUP. `chown' returns a value of `#t' if it is successful and `#f' on failure. - - Function: ttyname PORT + - Function: ttyname port If port PORT is associated with a terminal device, returns a string containing the file name of termainal device; otherwise `#f'. + +File: scm.info, Node: Unix Extensions, Next: Regular Expression Pattern Matching, Prev: Posix Extensions, Up: Packages + | Unix Extensions =============== If `'unix' is provided (by linking in `unix.o'), the following functions are defined: -These "priveledged" and symbolic link functions are not in Posix: +These "privileged" and symbolic link functions are not in Posix: | - - Function: symlink OLDNAME NEWNAME + - Function: symlink oldname newname The `symlink' function makes a symbolic link to OLDNAME named NEWNAME. `symlink' returns a value of `#t' if it is successful and `#f' on failure. - - Function: readlink FILENAME + - Function: readlink filename Returns the value of the symbolic link FILENAME or `#f' for failure. - - Function: lstat FILENAME + - Function: lstat filename The `lstat' function is like `stat', except that it does not follow symbolic links. If FILENAME is the name of a symbolic link, `lstat' returns information about the link itself; otherwise, `lstat' works like `stat'. *Note I/O-Extensions::. - - Function: nice INCREMENT + - Function: nice increment Increment the priority of the current process by INCREMENT. `chown' returns a value of `#t' if it is successful and `#f' on failure. - - Function: acct FILENAME + - Function: acct filename When called with the name of an exisitng file as argument, - accounting is turned on, records for each terminating pro-cess are + accounting is turned on, records for each terminating process are | appended to FILENAME as it terminates. An argument of `#f' causes accounting to be turned off. `acct' returns a value of `#t' if it is successful and `#f' on failure. - - Function: mknod FILENAME MODE DEV + - Function: mknod filename mode dev The `mknod' function makes a special file with name FILENAME and modes MODE for device number DEV. @@ -4242,8 +4488,8 @@ These "priveledged" and symbolic link functions are not in Posix: actual writing is done. The value returned is unspecified. -File: scm.info, Node: Regular Expression Pattern Matching, Next: Line Editing, Prev: Posix Extensions, Up: Packages - +File: scm.info, Node: Regular Expression Pattern Matching, Next: Line Editing, Prev: Unix Extensions, Up: Packages + | Regular Expression Pattern Matching =================================== @@ -4258,15 +4504,14 @@ description of regular expressions, *Note syntax: (regex)syntax. `regerror'. FLAGS in `regcomp' is a string of option letters used to control - the compilation of the regular expression. The letters may consist - of: + the compilation of the regular expression. The letters may + consist of: `n' newlines won't be matched by `.' or hat lists; ( `[^...]' ) `i' - ignore case. - only when compiled with _GNU_SOURCE: + ignore case.only when compiled with _GNU_SOURCE: `0' allows dot to match a null character. @@ -4323,14 +4568,14 @@ description of regular expressions, *Note syntax: (regex)syntax. The character position at which to begin the search or match. If absent, the default is zero. - *Compiled _GNU_SOURCE and using GNU libregex only:* + _Compiled _GNU_SOURCE and using GNU libregex only:_ When searching, if START is negative, the absolute value of START will be used as the start location and reverse searching will be performed. LEN The search is allowed to examine only the first LEN - characters of STRING. If absent, the entire string may be + characters of STRING. If absent, the entire string may be examined. - Function: string-split RE STRING @@ -4389,7 +4634,7 @@ line-editing mode will be entered. - Function: line-editing Returns the current edited line port or `#f'. - - Function: line-editing BOOL + - Function: line-editing bool If BOOL is false, exits line-editing mode and returns the previous value of `(line-editing)'. If BOOL is true, sets the current input and output ports to an edited line port and returns the @@ -4436,14 +4681,14 @@ These routines set options within curses that deal with output. All options are initially `#f', unless otherwise stated. It is not necessary to turn these options off before calling `endwin'. - - Function: clearok WIN BF + - Function: clearok win bf If enabled (BF is `#t'), the next call to `force-output' or `refresh' with WIN will clear the screen completely and redraw the entire screen from scratch. This is useful when the contents of the screen are uncertain, or in some cases for a more pleasing visual effect. - - Function: idlok WIN BF + - Function: idlok win bf If enabled (BF is `#t'), curses will consider using the hardware "insert/delete-line" feature of terminals so equipped. If disabled (BF is `#f'), curses will very seldom use this feature. @@ -4457,7 +4702,7 @@ necessary to turn these options off before calling `endwin'. "insert/delete-line" cannot be used, curses will redraw the changed portions of all lines. - - Function: leaveok WIN BF + - Function: leaveok win bf Normally, the hardware cursor is left at the location of the window cursor being refreshed. This option allows the cursor to be left wherever the update happens to leave it. It is useful for @@ -4465,7 +4710,7 @@ necessary to turn these options off before calling `endwin'. need for cursor motions. If possible, the cursor is made invisible when this option is enabled. - - Function: scrollok WIN BF + - Function: scrollok win bf This option controls what happens when the cursor of window WIN is moved off the edge of the window or scrolling region, either from a newline on the bottom line, or typing the last character of the @@ -4475,12 +4720,12 @@ necessary to turn these options off before calling `endwin'. window WIN, and then the physical terminal and window WIN are scrolled up one line. - *Note:* in order to get the physical scrolling effect on the + _Note:_ in order to get the physical scrolling effect on the terminal, it is also necessary to call `idlok'. - - Function: nodelay WIN BF + - Function: nodelay win bf This option causes wgetch to be a non-blocking call. If no input - is ready, wgetch will return an eof-object. If disabled, wgetch + is ready, wgetch will return an eof-object. If disabled, wgetch will hang until a key is pressed. @@ -4507,7 +4752,7 @@ routines. It is not necessary to turn these options off before calling `cbreak' or `nocbreak' explicitly. Most interactive programs using curses will set `CBREAK' mode. - *Note:* `cbreak' overrides `raw'. For a discussion of how these + _Note:_ `cbreak' overrides `raw'. For a discussion of how these routines interact with `echo' and `noecho' *Note read-char: Input. - Function: raw @@ -4553,14 +4798,14 @@ File: scm.info, Node: Window Manipulation, Next: Output, Prev: Terminal Mode Window Manipulation ------------------- - - Function: newwin NLINES NCOLS BEGY BEGX + - Function: newwin nlines ncols begy begx Create and return a new window with the given number of lines (or rows), NLINES, and columns, NCOLS. The upper left corner of the window is at line BEGY, column BEGX. If either NLINES or NCOLS is 0, they will be set to the value of `LINES'-BEGY and `COLS'-BEGX. A new full-screen window is created by calling `newwin(0,0,0,0)'. - - Function: subwin ORIG NLINES NCOLS BEGY BEGX + - Function: subwin orig nlines ncols begy begx Create and return a pointer to a new window with the given number of lines (or rows), NLINES, and columns, NCOLS. The window is at position (BEGY, BEGX) on the screen. This position is relative to @@ -4570,13 +4815,13 @@ Window Manipulation necessary to call `touchwin' or `touchline' on ORIG before calling `force-output'. - - Function: close-port WIN + - Function: close-port win Deletes the window WIN, freeing up all memory associated with it. In the case of sub-windows, they should be deleted before the main window WIN. - Function: refresh - - Function: force-output WIN + - Function: force-output win These routines are called to write output to the terminal, as most other routines merely manipulate data structures. `force-output' copies the window WIN to the physical terminal screen, taking into @@ -4587,21 +4832,21 @@ Window Manipulation `refresh', the number of characters output to the terminal is returned. - - Function: mvwin WIN Y X + - Function: mvwin win y x Move the window WIN so that the upper left corner will be at position (Y, X). If the move would cause the window WIN to be off the screen, it is an error and the window WIN is not moved. - - Function: overlay SRCWIN DSTWIN - - Function: overwrite SRCWIN DSTWIN + - Function: overlay srcwin dstwin + - Function: overwrite srcwin dstwin These routines overlay SRCWIN on top of DSTWIN; that is, all text in SRCWIN is copied into DSTWIN. SRCWIN and DSTWIN need not be the same size; only text where the two windows overlap is copied. The difference is that `overlay' is non-destructive (blanks are not copied), while `overwrite' is destructive. - - Function: touchwin WIN - - Function: touchline WIN START COUNT + - Function: touchwin win + - Function: touchline win start count Throw away all optimization information about which parts of the window WIN have been touched, by pretending that the entire window WIN has been drawn on. This is sometimes necessary when using @@ -4611,7 +4856,7 @@ Window Manipulation pretends that COUNT lines have been changed, beginning with line START. - - Function: wmove WIN Y X + - Function: wmove win y x The cursor associated with the window WIN is moved to line (row) Y, column X. This does not move the physical cursor of the terminal until `refresh' (or `force-output') is called. The position @@ -4626,10 +4871,10 @@ Output These routines are used to "draw" text on windows - - Function: display CH WIN - - Function: display STR WIN - - Function: wadd WIN CH - - Function: wadd WIN STR + - Function: display ch win + - Function: display str win + - Function: wadd win ch + - Function: wadd win str The character CH or characters in STR are put into the window WIN at the current cursor position of the window and the position of WIN's cursor is advanced. At the right margin, an automatic @@ -4652,51 +4897,51 @@ These routines are used to "draw" text on windows can be copied from one place to another using inch and display. See `standout', below. - *Note:* For `wadd' CH can be an integer and will insert the + _Note:_ For `wadd' CH can be an integer and will insert the character of the corresponding value. - - Function: werase WIN + - Function: werase win This routine copies blanks to every position in the window WIN. - - Function: wclear WIN + - Function: wclear win This routine is like `werase', but it also calls *Note clearok: Output Options Setting, arranging that the screen will be cleared completely on the next call to `refresh' or `force-output' for window WIN, and repainted from scratch. - - Function: wclrtobot WIN + - Function: wclrtobot win All lines below the cursor in window WIN are erased. Also, the current line to the right of the cursor, inclusive, is erased. - - Function: wclrtoeol WIN + - Function: wclrtoeol win The current line to the right of the cursor, inclusive, is erased. - - Function: wdelch WIN + - Function: wdelch win The character under the cursor in the window WIN is deleted. All characters to the right on the same line are moved to the left one position and the last character on the line is filled with a blank. The cursor position does not change. This does not imply use of the hardware "delete-character" feature. - - Function: wdeleteln WIN + - Function: wdeleteln win The line under the cursor in the window WIN is deleted. All lines below the current line are moved up one line. The bottom line WIN is cleared. The cursor position does not change. This does not imply use of the hardware "deleteline" feature. - - Function: winsch WIN CH + - Function: winsch win ch The character CH is inserted before the character under the cursor. All characters to the right are moved one <SPC> to the right, possibly losing the rightmost character of the line. The cursor position does not change . This does not imply use of the hardware "insertcharacter" feature. - - Function: winsertln WIN + - Function: winsertln win A blank line is inserted above the current line and the bottom line is lost. This does not imply use of the hardware "insert-line" feature. - - Function: scroll WIN + - Function: scroll win The window WIN is scrolled up one line. This involves moving the lines in WIN's data structure. As an optimization, if WIN is stdscr and the scrolling region is the entire window, the physical @@ -4708,7 +4953,7 @@ File: scm.info, Node: Input, Next: Curses Miscellany, Prev: Output, Up: Curs Input ----- - - Function: read-char WIN + - Function: read-char win A character is read from the terminal associated with the window WIN. Depending on the setting of `cbreak', this will be after one character (`CBREAK' mode), or after the first newline (`NOCBREAK' @@ -4720,12 +4965,12 @@ Input on the state of the terminal driver when each character is typed, the program may produce undesirable results. - - Function: winch WIN + - Function: winch win The character, of type chtype, at the current position in window WIN is returned. If any attributes are set for that position, their values will be OR'ed into the value returned. - - Function: getyx WIN + - Function: getyx win A list of the y and x coordinates of the cursor position of the window WIN is returned @@ -4735,8 +4980,8 @@ File: scm.info, Node: Curses Miscellany, Prev: Input, Up: Curses Curses Miscellany ----------------- - - Function: wstandout WIN - - Function: wstandend WIN + - Function: wstandout win + - Function: wstandend win These functions set the current attributes of the window WIN. The current attributes of WIN are applied to all characters that are written into it. Attributes are a property of the character, and @@ -4749,16 +4994,16 @@ Curses Miscellany visibly different from other text. `wstandend' turns off the attributes. - - Function: box WIN VERTCH HORCH + - Function: box win vertch horch A box is drawn around the edge of the window WIN. VERTCH and HORCH are the characters the box is to be drawn with. If VERTCH and HORCH are 0, then appropriate default characters, `ACS_VLINE' and `ACS_HLINE', will be used. - *Note:* VERTCH and HORCH can be an integers and will insert the + _Note:_ VERTCH and HORCH can be an integers and will insert the character (with attributes) of the corresponding values. - - Function: unctrl C + - Function: unctrl c This macro expands to a character string which is a printable representation of the character C. Control characters are displayed in the `C-x' notation. Printing characters are displayed @@ -4790,7 +5035,7 @@ Host Data, Network, Protocol, and Service Inquiries - Constant: af_unix Integer family codes for Internet and Unix sockets, respectively. - - Function: gethost HOST-SPEC + - Function: gethost host-spec - Function: gethost Returns a vector of information for the entry for `HOST-SPEC' or the next entry if `HOST-SPEC' isn't given. The information is: @@ -4805,7 +5050,7 @@ Host Data, Network, Protocol, and Service Inquiries 4. list of integer addresses - - Function: sethostent STAY-OPEN + - Function: sethostent stay-open - Function: sethostent Rewinds the host entry table back to the begining if given an argument. If the argument STAY-OPEN is `#f' queries will be be @@ -4813,7 +5058,7 @@ Host Data, Network, Protocol, and Service Inquiries will be used. When called without an argument, the host table is closed. - - Function: getnet NAME-OR-NUMBER + - Function: getnet name-or-number - Function: getnet Returns a vector of information for the entry for NAME-OR-NUMBER or the next entry if an argument isn't given. The information is: @@ -4826,14 +5071,14 @@ Host Data, Network, Protocol, and Service Inquiries 3. integer network number - - Function: setnetent STAY-OPEN + - Function: setnetent stay-open - Function: setnetent Rewinds the network entry table back to the begining if given an argument. If the argument STAY-OPEN is `#f' the table will be closed between calls to getnet. Otherwise, the table stays open. When called without an argument, the network table is closed. - - Function: getproto NAME-OR-NUMBER + - Function: getproto name-or-number - Function: getproto Returns a vector of information for the entry for NAME-OR-NUMBER or the next entry if an argument isn't given. The information is: @@ -4844,7 +5089,7 @@ Host Data, Network, Protocol, and Service Inquiries 3. integer protocol number - - Function: setprotoent STAY-OPEN + - Function: setprotoent stay-open - Function: setprotoent Rewinds the protocol entry table back to the begining if given an argument. If the argument STAY-OPEN is `#f' the table will be @@ -4852,7 +5097,7 @@ Host Data, Network, Protocol, and Service Inquiries open. When called without an argument, the protocol table is closed. - - Function: getserv NAME-OR-PORT-NUMBER PROTOCOL + - Function: getserv name-or-port-number protocol - Function: getserv Returns a vector of information for the entry for NAME-OR-PORT-NUMBER and PROTOCOL or the next entry if arguments @@ -4866,7 +5111,7 @@ Host Data, Network, Protocol, and Service Inquiries 3. protocol - - Function: setservent STAY-OPEN + - Function: setservent stay-open - Function: setservent Rewinds the service entry table back to the begining if given an argument. If the argument STAY-OPEN is `#f' the table will be @@ -4879,43 +5124,43 @@ File: scm.info, Node: Internet Addresses and Socket Names, Next: Socket, Prev Internet Addresses and Socket Names ----------------------------------- - - Function: inet:string->address STRING + - Function: inet:string->address string Returns the host address number (integer) for host STRING or `#f' if not found. - - Function: inet:address->string ADDRESS + - Function: inet:address->string address Converts an internet (integer) address to a string in numbers and dots notation. - - Function: inet:network ADDRESS + - Function: inet:network address Returns the network number (integer) specified from ADDRESS or `#f' if not found. - - Function: inet:local-network-address ADDRESS + - Function: inet:local-network-address address Returns the integer for the address of ADDRESS within its local network or `#f' if not found. - - Function: inet:make-address NETWORK LOCAL-ADDRESS + - Function: inet:make-address network local-address Returns the Internet address of LOCAL-ADDRESS in NETWORK. The type "socket-name" is used for inquiries about open sockets in the following procedures: - - Function: getsockname SOCKET + - Function: getsockname socket Returns the socket-name of SOCKET. Returns `#f' if unsuccessful or SOCKET is closed. - - Function: getpeername SOCKET + - Function: getpeername socket Returns the socket-name of the socket connected to SOCKET. Returns `#f' if unsuccessful or SOCKET is closed. - - Function: socket-name:family SOCKET-NAME + - Function: socket-name:family socket-name Returns the integer code for the family of SOCKET-NAME. - - Function: socket-name:port-number SOCKET-NAME + - Function: socket-name:port-number socket-name Returns the integer port number of SOCKET-NAME. - - Function: socket-name:address SOCKET-NAME + - Function: socket-name:address socket-name Returns the integer Internet address for SOCKET-NAME. @@ -4931,8 +5176,8 @@ buffered ports you can (assuming sock-port is a socket i/o port): (define i-port (duplicate-port sock-port "r")) (define o-port (duplicate-port sock-port "w")) - - Function: make-stream-socket FAMILY - - Function: make-stream-socket FAMILY PROTOCOL + - Function: make-stream-socket family + - Function: make-stream-socket family protocol Returns a `SOCK_STREAM' socket of type FAMILY using PROTOCOL. If FAMILY has the value `AF_INET', `SO_REUSEADDR' will be set. The integer argument PROTOCOL corresponds to the integer protocol @@ -4941,8 +5186,8 @@ buffered ports you can (assuming sock-port is a socket i/o port): specified FAMILY is used. SCM sockets look like ports opened for neither reading nor writing. - - Function: make-stream-socketpair FAMILY - - Function: make-stream-socketpair FAMILY PROTOCOL + - Function: make-stream-socketpair family + - Function: make-stream-socketpair family protocol Returns a pair (cons) of connected `SOCK_STREAM' (socket) ports of type FAMILY using PROTOCOL. Many systems support only socketpairs of the `af-unix' FAMILY. The integer argument PROTOCOL @@ -4950,7 +5195,7 @@ buffered ports you can (assuming sock-port is a socket i/o port): elements) from (getproto). If the PROTOCOL argument is not supplied, the default (0) for the specified FAMILY is used. - - Function: socket:shutdown SOCKET HOW + - Function: socket:shutdown socket how Makes SOCKET no longer respond to some or all operations depending on the integer argument HOW: @@ -4962,34 +5207,34 @@ buffered ports you can (assuming sock-port is a socket i/o port): `Socket:shutdown' returns SOCKET if successful, `#f' if not. - - Function: socket:connect INET-SOCKET HOST-NUMBER PORT-NUMBER - - Function: socket:connect UNIX-SOCKET PATHNAME + - Function: socket:connect inet-socket host-number port-number + - Function: socket:connect unix-socket pathname Returns SOCKET (changed to a read/write port) connected to the Internet socket on host HOST-NUMBER, port PORT-NUMBER or the Unix socket specified by PATHNAME. Returns `#f' if not successful. - - Function: socket:bind INET-SOCKET PORT-NUMBER - - Function: socket:bind UNIX-SOCKET PATHNAME + - Function: socket:bind inet-socket port-number + - Function: socket:bind unix-socket pathname Returns INET-SOCKET bound to the integer PORT-NUMBER or the UNIX-SOCKET bound to new socket in the file system at location - PATHNAME. Returns `#f' if not successful. Binding a UNIX-SOCKET + PATHNAME. Returns `#f' if not successful. Binding a UNIX-SOCKET creates a socket in the file system that must be deleted by the caller when it is no longer needed (using `delete-file'). - - Function: socket:listen SOCKET BACKLOG + - Function: socket:listen socket backlog The bound (*note bind: Socket.) SOCKET is readied to accept connections. The positive integer BACKLOG specifies how many pending connections will be allowed before further connection requests are refused. Returns SOCKET (changed to a read-only port) if successful, `#f' if not. - - Function: char-ready? LISTEN-SOCKET + - Function: char-ready? listen-socket The input port returned by a successful call to `socket:listen' can be polled for connections by `char-ready?' (*note char-ready?: Files and Ports.). This avoids blocking on connections by `socket:accept'. - - Function: socket:accept SOCKET + - Function: socket:accept socket Accepts a connection on a bound, listening SOCKET. Returns an input/output port for the connection. @@ -5124,8 +5369,8 @@ An "immediate" is a data type contained in type `SCM' (`long int'). The type codes distinguishing immediate types from each other vary in length, but reside in the low order bits. - - Macro: IMP X - - Macro: NIMP X + - Macro: IMP x + - Macro: NIMP x Return non-zero if the `SCM' object X is an immediate or non-immediate type, respectively. @@ -5134,15 +5379,15 @@ length, but reside in the low order bits. the second to low order bit position. The high order 30 bits are used for the integer's value. - - Macro: INUMP X - - Macro: NINUMP X + - Macro: INUMP x + - Macro: NINUMP x Return non-zero if the `SCM' X is an immediate integer or not an immediate integer, respectively. - - Macro: INUM X + - Macro: INUM x Returns the C `long integer' corresponding to `SCM' X. - - Macro: MAKINUM X + - Macro: MAKINUM x Returns the `SCM' inum corresponding to C `long integer' x. - Immediate Constant: INUM0 @@ -5161,13 +5406,13 @@ length, but reside in the low order bits. - Immediate: ichr characters. - - Macro: ICHRP X + - Macro: ICHRP x Return non-zero if the `SCM' object X is a character. - - Macro: ICHR X + - Macro: ICHR x Returns corresponding `unsigned char'. - - Macro: MAKICHR X + - Macro: MAKICHR x Given `char' X, returns `SCM' character. @@ -5196,27 +5441,27 @@ length, but reside in the low order bits. values are not specified. - - Macro: IFLAGP N + - Macro: IFLAGP n Returns non-zero if N is an ispcsym, isym or iflag. - - Macro: ISYMP N + - Macro: ISYMP n Returns non-zero if N is an ispcsym or isym. - - Macro: ISYMNUM N + - Macro: ISYMNUM n Given ispcsym, isym, or iflag N, returns its index in the C array `isymnames[]'. - - Macro: ISYMCHARS N + - Macro: ISYMCHARS n Given ispcsym, isym, or iflag N, returns its `char *' representation (from `isymnames[]'). - - Macro: MAKSPCSYM N + - Macro: MAKSPCSYM n Returns `SCM' ispcsym N. - - Macro: MAKISYM N + - Macro: MAKISYM n Returns `SCM' iisym N. - - Macro: MAKIFLAG N + - Macro: MAKIFLAG n Returns `SCM' iflag N. - Variable: isymnames @@ -5247,7 +5492,7 @@ length, but reside in the low order bits. completeness). Since cells are always 8 byte aligned, a pointer to a cell has the low order 3 bits `0'. - There is one exception to this rule, *CAR Immediate*s, described + There is one exception to this rule, _CAR Immediate_s, described next. A "CAR Immediate" is an Immediate point which can only occur in the @@ -5265,7 +5510,7 @@ object. The rest of `CAR' and `CDR' hold object data. The number after `tc' specifies how many bits are in the type code. For instance, `tc7' indicates that the type code is 7 bits. - - Macro: NEWCELL X + - Macro: NEWCELL x Allocates a new cell and stores a pointer to it in `SCM' local variable X. @@ -5275,20 +5520,20 @@ after `tc' specifies how many bits are in the type code. For instance, All of the C macros decribed in this section assume that their argument is of type `SCM' and points to a cell (`CELLPTR'). - - Macro: CAR X - - Macro: CDR X + - Macro: CAR x + - Macro: CDR x Returns the `car' and `cdr' of cell X, respectively. - - Macro: TYP3 X - - Macro: TYP7 X - - Macro: TYP16 X + - Macro: TYP3 x + - Macro: TYP7 x + - Macro: TYP16 x Returns the 3, 7, and 16 bit type code of a cell. - Cell: tc3_cons scheme cons-cell returned by (cons arg1 arg2). - - Macro: CONSP X - - Macro: NCONSP X + - Macro: CONSP x + - Macro: NCONSP x Returns non-zero if X is a `tc3_cons' or isn't, respectively. - Cell: tc3_closure @@ -5301,15 +5546,15 @@ is of type `SCM' and points to a cell (`CELLPTR'). encoding precludes an immediate value for the `CDR': In the case of an empty environment all bits above 2 in the `CDR' are zero. - - Macro: CLOSUREP X + - Macro: CLOSUREP x Returns non-zero if X is a `tc3_closure'. - - Macro: CODE X - - Macro: ENV X + - Macro: CODE x + - Macro: ENV x Returns the code body or environment of closure X, respectively. - - Macro: ARGC X + - Macro: ARGC x Returns the a lower bound on the number of required arguments to closure X, it cannot exceed 3. @@ -5329,13 +5574,13 @@ memory allocated by `malloc'. - Header: tc7_vector scheme vector. - - Macro: VECTORP X - - Macro: NVECTORP X + - Macro: VECTORP x + - Macro: NVECTORP x Returns non-zero if X is a `tc7_vector' or if not, respectively. - - Macro: VELTS X - - Macro: LENGTH X + - Macro: VELTS x + - Macro: LENGTH x Returns the C array of `SCM's holding the elements of vector X or its length, respectively. @@ -5345,26 +5590,26 @@ memory allocated by `malloc'. - Header: tc7_msymbol `malloc'ed scheme symbol (can be GCed) - - Macro: SYMBOLP X + - Macro: SYMBOLP x Returns non-zero if X is a `tc7_ssymbol' or `tc7_msymbol'. - - Macro: CHARS X - - Macro: UCHARS X - - Macro: LENGTH X + - Macro: CHARS x + - Macro: UCHARS x + - Macro: LENGTH x Returns the C array of `char's or as `unsigned char's holding the elements of symbol X or its length, respectively. - Header: tc7_string scheme string - - Macro: STRINGP X - - Macro: NSTRINGP X + - Macro: STRINGP x + - Macro: NSTRINGP x Returns non-zero if X is a `tc7_string' or isn't, respectively. - - Macro: CHARS X - - Macro: UCHARS X - - Macro: LENGTH X + - Macro: CHARS x + - Macro: UCHARS x + - Macro: LENGTH x Returns the C array of `char's or as `unsigned char's holding the elements of string X or its length, respectively. @@ -5377,6 +5622,9 @@ memory allocated by `malloc'. - Header: tc7_uvect uniform vector of non-negative integers + - Header: tc7_svect | + uniform vector of short integers | + | - Header: tc7_fvect uniform vector of short inexact real numbers @@ -5406,12 +5654,12 @@ memory allocated by `malloc'. invocation is currently not tail recursive when given 2 or more arguments. - - Function: makcclo PROC LEN - makes a closure from the *subr* PROC with LEN-1 extra + - Function: makcclo proc len + makes a closure from the _subr_ PROC with LEN-1 extra locations for `SCM' data. Elements of a CCLO are referenced using `VELTS(cclo)[n]' just as for vectors. - - Macro: CCLO_LENGTH CCLO + - Macro: CCLO_LENGTH cclo Expands to the length of CCLO. @@ -5487,7 +5735,7 @@ Ptob Cells A "ptob" is a port object, capable of delivering or accepting characters. *Note Ports: (r5rs)Ports. Unlike the types described so far, new varieties of ptobs can be defined dynamically (*note Defining -Ptobs::.). These are the initial ptobs: +Ptobs::). These are the initial ptobs: - ptob: tc16_inport input port. @@ -5508,33 +5756,32 @@ Ptobs::.). These are the initial ptobs: String port created by `cwos()' or `cwis()'. - ptob: tc16_sfport - Software (virtual) port created by `mksfpt()' (*note Soft - Ports::.). - - - Macro: PORTP X - - Macro: OPPORTP X - - Macro: OPINPORTP X - - Macro: OPOUTPORTP X - - Macro: INPORTP X - - Macro: OUTPORTP X + Software (virtual) port created by `mksfpt()' (*note Soft Ports::). + + - Macro: PORTP x + - Macro: OPPORTP x + - Macro: OPINPORTP x + - Macro: OPOUTPORTP x + - Macro: INPORTP x + - Macro: OUTPORTP x Returns non-zero if X is a port, open port, open input-port, open output-port, input-port, or output-port, respectively. - - Macro: OPENP X - - Macro: CLOSEDP X + - Macro: OPENP x + - Macro: CLOSEDP x Returns non-zero if port X is open or closed, respectively. - - Macro: STREAM X + - Macro: STREAM x Returns the `FILE *' stream for port X. Ports which are particularly well behaved are called "fport"s. Advanced operations like `file-position' and `reopen-file' only work for fports. - - Macro: FPORTP X - - Macro: OPFPORTP X - - Macro: OPINFPORTP X - - Macro: OPOUTFPORTP X + - Macro: FPORTP x + - Macro: OPFPORTP x + - Macro: OPINFPORTP x + - Macro: OPOUTFPORTP x Returns non-zero if X is a port, open port, open input-port, or open output-port, respectively. @@ -5550,7 +5797,7 @@ of the `CAR' can be used for sub-type or other information. The `CDR' contains data of size long and is often a pointer to allocated memory. Like ptobs, new varieties of smobs can be defined dynamically (*note -Defining Smobs::.). These are the initial smobs: +Defining Smobs::). These are the initial smobs: - smob: tc_free_cell unused cell on the freelist. @@ -5590,7 +5837,7 @@ Defining Smobs::.). These are the initial smobs: Why only 4800 digits? The simple multiplication algorithm SCM uses is O(n^2); this means the number of processor instructions - required to perform a multiplication is *some multiple* of the + required to perform a multiplication is _some multiple_ of the product of the number of digits of the two multiplicands. digits * digits ==> operations @@ -5604,7 +5851,7 @@ Defining Smobs::.). These are the initial smobs: should obtain a package which specializes in number-theoretical calculations: - `ftp://megrez.math.u-bordeaux.fr/pub/pari/' + <ftp://megrez.math.u-bordeaux.fr/pub/pari/> - smob: tc16_promise @@ -5620,9 +5867,9 @@ Defining Smobs::.). These are the initial smobs: multi-dimensional array. *Note Arrays::. This type implements both conventional arrays (those with - arbitrary data as elements *note Conventional Arrays::.) and + arbitrary data as elements *note Conventional Arrays::) and uniform arrays (those with elements of a uniform type *note - Uniform Array::.). + Uniform Array::). Conventional Arrays have a pointer to a vector for their `CDR'. Uniform Arrays have a pointer to a Uniform Vector type (string, @@ -5661,7 +5908,7 @@ bvect .........long length....G0010101 ..........long *words........... ivect .........long length....G0011101 ..........long *words........... uvect .........long length....G0011111 ......unsigned long *words...... spare G0100101 - spare G0100111 +svect .........long length....G0100111 ........ short *words........... | fvect .........long length....G0101101 .........float *words........... dvect .........long length....G0101111 ........double *words........... cvect .........long length....G0110101 ........double *words........... @@ -5765,11 +6012,11 @@ during garbage collection. Special C macros are defined in `scm.h' to allow easy manipulation when GC bits are possibly set. `CAR', `TYP3', and `TYP7' can be used on GC marked cells as they are. - - Macro: GCCDR X + - Macro: GCCDR x Returns the CDR of a cons cell, even if that cell has been GC marked. - - Macro: GCTYP16 X + - Macro: GCTYP16 x Returns the 16 bit type code of a cell. We need to (recursively) mark only a few objects in order to assure that @@ -5837,7 +6084,7 @@ optimize the allocation and garbage collection of environments. The optimizations are based on certain facts and assumptions: The SCM evaluator creates many environments with short lifetimes and -these account of a *large portion* of the total number of objects +these account of a _large portion_ of the total number of objects allocated. The general purpose allocator allocates objects from a freelist, and @@ -5933,8 +6180,8 @@ Signals handlers immediately reestablish themselves by a call to `signal()'. - - Function: int_signal SIG - - Function: alrm_signal SIG + - Function: int_signal sig + - Function: alrm_signal sig The low level handlers for `SIGINT' and `SIGALRM'. If an interrupt handler is defined when the interrupt is received, the @@ -5968,7 +6215,7 @@ File: scm.info, Node: C Macros, Next: Changing Scm, Prev: Signals, Up: Opera C Macros -------- - - Macro: ASSERT COND ARG POS SUBR + - Macro: ASSERT cond arg pos subr signals an error if the expression (COND) is 0. ARG is the offending object, SUBR is the string naming the subr, and POS indicates the position or type of error. POS can be one of @@ -6013,7 +6260,7 @@ C Macros defined. An error condition can still be signaled in this case with a call to `wta(arg, pos, subr)'. - - Macro: ASRTGO COND LABEL + - Macro: ASRTGO cond label `goto' LABEL if the expression (COND) is 0. Like `ASSERT', `ASRTGO' does is not active if the flag `RECKLESS' is defined. @@ -6024,7 +6271,7 @@ Changing Scm ------------ When writing C-code for SCM, a precaution is recommended. If your -routine allocates a non-cons cell which will *not* be incorporated into +routine allocates a non-cons cell which will _not_ be incorporated into a `SCM' object which is returned, you need to make sure that a `SCM' variable in your routine points to that cell as long as part of it might be referenced by your code. @@ -6039,7 +6286,7 @@ or put this assignment somewhere in your routine: SCM_dummy1 = (SCM) &foo; `SCM_dummy' variables are not currently defined. Passing the address -of the local `SCM' variable to *any* procedure also protects it. The +of the local `SCM' variable to _any_ procedure also protects it. The procedure `scm_protect_temp' is provided for this purpose. Also, if you maintain a static pointer to some (non-immediate) `SCM' @@ -6106,7 +6353,7 @@ To add a package of new procedures to scm (see `crs.c' for example): 7. put any scheme code which needs to be run as part of your package into `Ifoo.scm'. - 8. put an `if' into `Init5d2.scm' which loads `Ifoo.scm' if your | + 8. put an `if' into `Init5d6.scm' which loads `Ifoo.scm' if your | package is included: (if (defined? twiddle-bits!) @@ -6120,7 +6367,7 @@ To add a package of new procedures to scm (see `crs.c' for example): 9. put documentation of the new procedures into `foo.doc' 10. add lines to your `Makefile' to compile and link SCM with your - object file. Add a `init_foo\(\)\;' to the `INITS=...' line at + object file. Add a `init_foo\(\)\;' to the `INITS=...' line at the beginning of the makefile. These steps should allow your package to be linked into SCM with a @@ -6154,7 +6401,7 @@ The SCM interpreter directly recognizes subrs taking small numbers of arguments. In order to create subrs taking larger numbers of arguments use: - - Function: make_gsubr NAME REQ OPT REST FCN + - Function: make_gsubr name req opt rest fcn returns a cclo (compiled closure) object of name `char *' NAME which takes `int' REQ required arguments, `int' OPT optional arguments, and a list of rest arguments if `int' REST is 1 (0 for @@ -6221,7 +6468,7 @@ following lines need to be added to your code: mark) and returns type `SCM' which will then be marked. If no further objects need to be marked then return an immediate object such as `BOOL_F'. The smob cell itself will already - have been marked. *Note:* This is different from SCM + have been marked. _Note:_ This is different from SCM versions prior to 5c5. Only additional data specific to a smob type need be marked by `smob.mark'. @@ -6247,9 +6494,10 @@ following lines need to be added to your code: is the smob object. The second, of type `SCM', is the stream on which to write the result. The third, of type int, is 1 if the object should be `write'n, 0 if it should be - `display'ed. This function should return non-zero if it - printed, and zero otherwise (in which case a hexadecimal - number will be printed). + `display'ed, and 2 if it should be `write'n for an error | + report. This function should return non-zero if it printed, | + and zero otherwise (in which case a hexadecimal number will | + be printed). | `smob.equalp' is 0 or a function of 2 `SCM' arguments. Both of these @@ -6314,7 +6562,7 @@ following functions are provided for that purpose: - Function: char * must_malloc (long LEN, char *WHAT) LEN is the number of bytes that should be allocated, WHAT is a string to be used in error or gc messages. `must_malloc' returns - a pointer to newly allocated memory. `must_malloc_cell' returns a + a pointer to newly allocated memory. `must_malloc_cell' returns a newly allocated cell whose `car' is C and whose `cdr' is a pointer to newly allocated memory. @@ -6329,14 +6577,16 @@ following functions are provided for that purpose: address of a block of memory of length OLEN allocated by `must_malloc' and returns the address of a block of length LEN. - The contents of the reallocated block will be unchanged up the the + The contents of the reallocated block will be unchanged up to the minimum of the old and new sizes. WHAT is a pointer to a string used for error and gc messages. `must_malloc', `must_malloc_cell', `must_realloc', and `must_realloc_cell' must be called with interrupts deferred *Note -Signals::. +Signals::. `must_realloc' and `must_realloc_cell' must not be called | +during initialization (non-zero errjmp_bad) - the initial allocations | +must be large enough. | - Function: void must_free (char *PTR, sizet LEN) `must_free' is used to free a block of memory allocated by the @@ -6366,8 +6616,8 @@ module. - Variable: char *execpath This string is the pathname of the executable file being run. This variable can be examined and set from Scheme (*note Internal - State::.). EXECPATH must be set to executable's path in order to - use DUMP (*note Dump::.) or DLD. + State::). EXECPATH must be set to executable's path in order to + use DUMP (*note Dump::) or DLD. Rename main() and arrange your code to call it with an ARGV which sets up SCM as you want it. @@ -6382,7 +6632,7 @@ descriptions of the functions which main() calls. - Function: char * scm_find_execpath (int ARGC, char **ARGV, char *SCRIPT_ARG) ARGC and ARGV are as described in main(). SCRIPT_ARG is the - pathname of the SCSH-style script (*note Scripting::.) being + pathname of the SCSH-style script (*note Scripting::) being invoked; 0 otherwise. `scm_find_execpath' returns the pathname of the executable being run; if `scm_find_execpath' cannot determine the pathname, then it returns 0. @@ -6403,7 +6653,7 @@ SCM, then you can replace `scm_find_implpath'. environment variable is defined, its value will be returned from `scm_find_implpath'. Otherwise find_impl_file() is called with the arguments EXECPATH, GENERIC_NAME (default "scm"), INIT_FILE_NAME - (default "Init5d2_scm"), and the directory separator string | + (default "Init5d6_scm"), and the directory separator string | DIRSEP. If find_impl_file() returns 0 and IMPLINIT is defined, then a copy of the string IMPLINIT is returned. @@ -6468,7 +6718,7 @@ handle interrupts and signals. You can call indivdual Scheme procedures from C code in the TOPLVL_FUN argument passed to scm_top_level(), or from module subrs (registered by -an `init_' function, *note Changing Scm::.). +an `init_' function, *note Changing Scm::). Use `apply' to call Scheme procedures from your C code. For example: @@ -6481,7 +6731,7 @@ Use `apply' to call Scheme procedures from your C code. For example: retval = apply(func, cons(mksproc(srvproc), args), EOL); Functions for loading Scheme files and evaluating Scheme code given as -C strings are described in the next section, (*note Callbacks::.). +C strings are described in the next section, (*note Callbacks::). Here is a minimal embedding program `libtest.c': @@ -6515,7 +6765,7 @@ Here is a minimal embedding program `libtest.c': fprintf(stderr, "dld_find_executable(%s): %s\n", argv[0], execpath); implpath = find_impl_file(execpath, "scm", INIT_FILE_NAME, dirsep); fprintf(stderr, "implpath: %s\n", implpath); - scm_init_from_argv(argc, argv, 0, 0); + scm_init_from_argv(argc, argv, 0L, 0, 0); retval = scm_top_level(implpath, user_main); @@ -6525,7 +6775,7 @@ Here is a minimal embedding program `libtest.c': -| dld_find_executable(./libtest): /home/jaffer/scm/libtest - implpath: /home/jaffer/scm/Init5d2.scm | + implpath: /home/jaffer/scm/Init5d6.scm | This is init_user_scm hello world @@ -6541,7 +6791,7 @@ The source code for these routines are found in `rope.c'. - Function: int scm_ldfile (char *FILE) Loads the Scheme source file FILE. Returns 0 if successful, non-0 if not. This function is used to load SCM's initialization file - `Init5d2.scm'. | + `Init5d6.scm'. | - Function: int scm_ldprog (char *FILE) Loads the Scheme source file `(in-vicinity (program-vicinity) @@ -6610,7 +6860,7 @@ code. Most are defined in `rope.c'. NUM and strings POS and S_CALLER. For a listing of useful predefined POS macros, *Note C Macros::. - *Note:* Inexact numbers are accepted only by `num2long' and + _Note:_ Inexact numbers are accepted only by `num2long' and `num2ulong' (for when `SCM' is compiled without bignums). To convert inexact numbers to exact numbers, *Note inexact->exact: (r5rs)Numerical operations. @@ -6622,9 +6872,9 @@ code. Most are defined in `rope.c'. messages from error calls by `scm_addr'. `scm_addr' is useful for performing C operations on strings or - other uniform arrays (*note Uniform Array::.). + other uniform arrays (*note Uniform Array::). - *Note:* While you use a pointer returned from `scm_addr' you must + _Note:_ While you use a pointer returned from `scm_addr' you must keep a pointer to the associated `SCM' object in a stack allocated variable or GC-protected location in order to assure that SCM does not reuse that storage before you are done with it. @@ -6698,7 +6948,7 @@ conflicts. "root" `CONTINUATION's have additional storage (immediately following) to contain a copy of part of the stack. - *Note:* On systems with nonlinear stack disciplines (multiple + _Note:_ On systems with nonlinear stack disciplines (multiple stacks or non-contiguous stack frames) copying the stack will not work properly. These systems need to #define `CHEAP_CONTINUATIONS' in `scmfig.h'. @@ -6763,7 +7013,7 @@ Evaluation ---------- SCM uses its type representations to speed evaluation. All of the -`subr' types (*note Subr Cells::.) are `tc7' types. Since the `tc7' +`subr' types (*note Subr Cells::) are `tc7' types. Since the `tc7' field is in the low order bit position of the `CAR' it can be retrieved and dispatched on quickly by dereferencing the SCM pointer pointing to it and masking the result. @@ -6776,7 +7026,7 @@ to occupy the same bits as `tc7'. All the `isym's occur only in the If the `CAR' of a expression to evaluate is not immediate, then it may be a symbol. If so, the first time it is encountered it will be -converted to an immediate type `ILOC' or `GLOC' (*note Immediates::.). +converted to an immediate type `ILOC' or `GLOC' (*note Immediates::). The codes for `ILOC' and `GLOC' lower 7 bits distinguish them from all the other types we have discussed. @@ -6846,8 +7096,8 @@ argument checks for closures are made only when the function position will be checked only the first time it is evaluated because it will then be replaced with an `ILOC' or `GLOC'. - - Macro: EVAL EXPRESSION ENV - - Macro: SIDEVAL EXPRESSION ENV + - Macro: EVAL expression env + - Macro: SIDEVAL expression env `EVAL' Returns the result of evaluating EXPRESSION in ENV. `SIDEVAL' evaluates EXPRESSION in ENV when the value of the expression is not used. @@ -6912,8 +7162,8 @@ needed. Given the pathname of this executable (EXEC_PATH), test for the existence of INITNAME in the implementation-vicinity of this program. Return a newly allocated string of the path if - successful, 0 if not. The SEP argument is a *null-terminated - string* of the character used to separate directory components. + successful, 0 if not. The SEP argument is a _null-terminated + string_ of the character used to separate directory components. * One convention is to install the support files for an executable program in the same directory as the program. This possibility is @@ -6953,13 +7203,13 @@ File: scm.info, Node: Executable Pathname, Next: Script Support, Prev: File-S Executable Pathname ------------------- -For purposes of finding `Init5d2.scm', dumping an executable, and | +For purposes of finding `Init5d6.scm', dumping an executable, and | dynamic linking, a SCM session needs the pathname of its executable image. When a program is executed by MS-DOS, the full pathname of that executable is available in `argv[0]'. This value can be passed -directly to `find_impl_file' (*note File-System Habitat::.). +directly to `find_impl_file' (*note File-System Habitat::). In order to find the habitat for a unix program, we first need to know the full pathname for the associated executable file. @@ -7034,7 +7284,7 @@ Improvements To Make names. Provide a file full of #define's to provide backward compatability. - * `lgcd()' *needs* to generate at most one bignum, but currently + * `lgcd()' _needs_ to generate at most one bignum, but currently generates more. * `divide()' could use shifts instead of multiply and divide when @@ -7066,6 +7316,7 @@ Improvements To Make gets set which tells the interpreter to instead always look up the values of the associated symbols. + * Menu: * Finishing Dynamic Linking:: @@ -7108,7 +7359,7 @@ with a VMS system needs to finish and debug it. PSECT_ATTR=the_heap,NOSHR,LCL PSECT_ATTR=the_environment,NOSHR,LCL - *Notice:* The "psect" (Program Section) attributes. + _Notice:_ The "psect" (Program Section) attributes. `LCL' means to keep the name local to the shared library. You almost always want to do that for a good clean library. @@ -7173,7 +7424,7 @@ with a VMS system needs to finish and debug it. off <C-c> or other interrupt handling while you are inside most `lib$' calls. - As far as the generation of all the `UNIVERSAL=...' declarations. + As far as the generation of all the `UNIVERSAL=...' declarations. Well, you could do well to have that automatically generated from the public `LISPRTL.H' file, of course. @@ -7272,7 +7523,7 @@ Windows NT: nointerrupt(iflag); return(retval);} - * *Note:* in VMS the linker and dynamic loader is case sensitive, but + * _Note:_ in VMS the linker and dynamic loader is case sensitive, but all the language compilers, including C, will by default upper-case external symbols for use by the linker, although the debugger gets its own symbols and case sensitivity is language mode dependant. @@ -7280,7 +7531,7 @@ Windows NT: and device names, which are case canonicalizing like in the Symbolics filesystem. - * *Also:* All this WINDOWS NT stuff will work in MS-DOS MS-Windows + * _Also:_ All this WINDOWS NT stuff will work in MS-DOS MS-Windows 3.1 too, by a method of compiling and linking under Windows NT, and then copying various files over to MS-DOS/WINDOWS. @@ -7299,7 +7550,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * #+: Syntax Extensions. * #-: Syntax Extensions. * #.: Syntax Extensions. -* #;text-till-end-of-line: Syntax Extensions. | +* #;text-till-end-of-line: Syntax Extensions. * #\token: Syntax Extensions. * #|: Syntax Extensions. * $abs: Numeric. @@ -7349,6 +7600,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * -e: SCM Options. * -f: SCM Options. * -F: Build Options. +* -h <1>: SCM Options. * -h: Build Options. * -i <1>: SCM Options. * -i: Build Options. @@ -7370,19 +7622,18 @@ This is an alphabetical list of all the procedures and macros in SCM. * -v: SCM Options. * -w: Build Options. * @apply: Low Level Syntactic Hooks. -* @call-with-current-continuation: Low Level Syntactic Hooks. -* @copy-tree: Miscellaneous Procedures. -* @let-syntax: Syntactic Hooks for Hygienic Macros. -* @letrec-syntax: Syntactic Hooks for Hygienic Macros. +* @copy-tree: Miscellaneous Procedures. | * @macroexpand1: Syntactic Hooks for Hygienic Macros. +* _exclusive: Files and Ports. | * _ionbf: Files and Ports. -* _tracked: Files and Ports. | +* _tracked: Files and Ports. * abort: Internal State. * access: I/O-Extensions. -* acct: Posix Extensions. +* acct: Unix Extensions. | * acons: Miscellaneous Procedures. * acosh: Numeric. * add-alias: Configure Module Catalog. +* add-finalizer: Interrupts. | * add-link: Configure Module Catalog. * add-source: Configure Module Catalog. * alarm: Interrupts. @@ -7417,9 +7668,12 @@ This is an alphabetical list of all the procedures and macros in SCM. * bit-invert!: Bit Vectors. * bit-position: Bit Vectors. * bit-set*!: Bit Vectors. +* boot-tail <1>: Dump. | +* boot-tail: SCM Session. | * box: Curses Miscellany. -* CAR: Cells. -* casev: Syntax Extensions. +* broken-pipe: Posix Extensions. | +* call-with-outputs: Files and Ports. +* CAR: Cells. | * cbreak: Terminal Mode Setting. * CCLO_LENGTH: Header Cells. * CDR: Cells. @@ -7432,8 +7686,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * CHEAP_CONTINUATIONS: Continuations. * chmod: I/O-Extensions. * chown: Posix Extensions. -* clearok: Output Options Setting. -* close-io-port: Files and Ports. +* clearok: Output Options Setting. | * close-port <1>: Window Manipulation. * close-port <2>: Posix Extensions. * close-port: Files and Ports. @@ -7442,7 +7695,6 @@ This is an alphabetical list of all the procedures and macros in SCM. * CLOSUREP: Cells. * CODE: Cells. * comment: Syntax Extensions. | -* compile-file: Compiling And Linking. * CONSP: Cells. * copy-tree: Miscellaneous Procedures. * cosh: Numeric. @@ -7455,6 +7707,8 @@ This is an alphabetical list of all the procedures and macros in SCM. * defconst: Syntax Extensions. * DEFER_INTS: Signals. * defined?: Syntax Extensions. +* defmacro: Syntax Extensions. +* defsyntax: Low Level Syntactic Hooks. | * defvar: Syntax Extensions. * dimensions->uniform-array: Uniform Array. * directory-for-each: I/O-Extensions. @@ -7471,8 +7725,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * enclose-array: Conventional Arrays. * end-of-program: Interrupts. * endwin: Curses. -* ENV: Cells. -* environment->tree: Low Level Syntactic Hooks. +* ENV: Cells. | * errno: Errors. * error: Errors. * eval: Evaluation. @@ -7496,11 +7749,13 @@ This is an alphabetical list of all the procedures and macros in SCM. * fork: Posix Extensions. * FPORTP: Ptob Cells. * free_continuation: Continuations. -* freshline: Files and Ports. | +* freshline: Files and Ports. * gc: Internal State. +* gc-hook: Interrupts. | * gc_mark: Marking Cells. * GCCDR: Marking Cells. * GCTYP16: Marking Cells. +* gentemp: Syntax Extensions. * get-internal-real-time: Time. * get-internal-run-time: Time. * getcwd: I/O-Extensions. @@ -7510,6 +7765,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * getgr: Posix Extensions. * getgroups: Posix Extensions. * gethost: Host Data. +* getlogin: Posix Extensions. | * getnet: Host Data. * getpeername: Internet Addresses and Socket Names. * getpid: I/O-Extensions. @@ -7541,6 +7797,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * initscr: Curses. * INPORTP: Ptob Cells. * int_signal: Signals. +* integer->line-number: Line Numbers. | * INUM: Immediates. * INUMP: Immediates. * isatty?: Files and Ports. @@ -7552,10 +7809,10 @@ This is an alphabetical list of all the procedures and macros in SCM. * LENGTH: Header Cells. * line-editing: Line Editing. * line-number: Miscellaneous Procedures. -* link: Posix Extensions. -* link-named-scm: Compiling And Linking. -* list->uniform-array: Uniform Array. -* list->uniform-vector: Uniform Array. +* line-number->integer: Line Numbers. | +* line-number?: Line Numbers. | +* link: Posix Extensions. | +* list->uniform-array: Uniform Array. | * list-file: Miscellaneous Procedures. * load: Dynamic Linking. * load-string: Miscellaneous Procedures. @@ -7563,19 +7820,20 @@ This is an alphabetical list of all the procedures and macros in SCM. * logaset!: Uniform Array. * long: Type Conversions. * long2num: Type Conversions. -* lstat: Posix Extensions. +* lstat: Unix Extensions. | +* macroexpand: Syntax Extensions. +* macroexpand-1: Syntax Extensions. * main: Embedding SCM. * makargvfrmstrs: Type Conversions. * makcclo: Header Cells. * make-arbiter: Process Synchronization. * make-array: Conventional Arrays. * make-edited-line-port: Line Editing. +* make-exchanger: Process Synchronization. | * make-shared-array: Conventional Arrays. * make-soft-port: Soft Ports. * make-stream-socket: Socket. -* make-stream-socketpair: Socket. -* make-uniform-array: Uniform Array. -* make-uniform-vector: Uniform Array. +* make-stream-socketpair: Socket. | * make_continuation: Continuations. * make_gsubr: Defining Subrs. * make_root_continuation: Continuations. @@ -7590,7 +7848,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * mark_locations: Marking Cells. * milli-alarm: Interrupts. * mkdir: I/O-Extensions. -* mknod: Posix Extensions. +* mknod: Unix Extensions. | * must_free: Allocating memory. * must_free_argv: Type Conversions. * must_malloc: Allocating memory. @@ -7601,7 +7859,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * NCONSP: Cells. * NEWCELL: Cells. * newwin: Window Manipulation. -* nice: Posix Extensions. +* nice: Unix Extensions. | * NIMP: Immediates. * NINUMP: Immediates. * nl: Terminal Mode Setting. @@ -7614,10 +7872,10 @@ This is an alphabetical list of all the procedures and macros in SCM. * num2long: Type Conversions. * NVECTORP: Header Cells. * open-file: Files and Ports. -* open-input-pipe: Posix Extensions. -* open-io-file: Files and Ports. +* open-input-pipe: Posix Extensions. | * open-output-pipe: Posix Extensions. * open-pipe: Posix Extensions. +* open-ports: Files and Ports. | * opendir: I/O-Extensions. * OPENP: Ptob Cells. * OPFPORTP: Ptob Cells. @@ -7631,14 +7889,19 @@ This is an alphabetical list of all the procedures and macros in SCM. * overlay: Window Manipulation. * overwrite: Window Manipulation. * perror: Errors. +* pi*: Numeric. +* pi/: Numeric. * pipe: Posix Extensions. -* port-column: Miscellaneous Procedures. | -* port-filename: Miscellaneous Procedures. | -* port-line: Miscellaneous Procedures. | +* port-closed?: Files and Ports. | +* port-column: Miscellaneous Procedures. +* port-filename: Miscellaneous Procedures. +* port-line: Miscellaneous Procedures. +* port-type: Files and Ports. | * PORTP: Ptob Cells. * print <1>: Miscellaneous Procedures. * print: Debugging Scheme Code. * print-args: Debugging Scheme Code. +* procedure->identifier-macro: Low Level Syntactic Hooks. * procedure->macro: Low Level Syntactic Hooks. * procedure->memoizing-macro: Low Level Syntactic Hooks. * procedure->syntax: Low Level Syntactic Hooks. @@ -7647,14 +7910,17 @@ This is an alphabetical list of all the procedures and macros in SCM. * profile-alarm-interrupt: Interrupts. * program-arguments: SCM Session. * putenv: I/O-Extensions. +* qase: Syntax Extensions. | * quit: SCM Session. * raw: Terminal Mode Setting. * read-char <1>: Input. * read-char: Files and Ports. +* read-numbered: Line Numbers. | * read:sharp: Low Level Syntactic Hooks. * read:sharp-char: Low Level Syntactic Hooks. * readdir: I/O-Extensions. -* readlink: Posix Extensions. +* readlink: Unix Extensions. | +* record-printer-set!: Records. | * redirect-port!: I/O-Extensions. * refresh: Window Manipulation. * regcomp: Regular Expression Pattern Matching. @@ -7728,9 +7994,10 @@ This is an alphabetical list of all the procedures and macros in SCM. * STRINGP: Header Cells. * subwin: Window Manipulation. * SYMBOLP: Header Cells. -* symlink: Posix Extensions. -* sync: Posix Extensions. +* symlink: Unix Extensions. | +* sync: Unix Extensions. | * syntax-quote: Syntactic Hooks for Hygienic Macros. +* syntax-rules: Syntax Extensions. * tanh: Numeric. * terms: Miscellaneous Procedures. * the-macro: Syntactic Hooks for Hygienic Macros. @@ -7742,6 +8009,8 @@ This is an alphabetical list of all the procedures and macros in SCM. * trace: Debugging Scheme Code. * transpose-array: Conventional Arrays. * try-arbiter: Process Synchronization. +* try-create-file: I/O-Extensions. | +* try-load <1>: Line Numbers. | * try-load: Miscellaneous Procedures. * try-open-file: Files and Ports. * ttyname: Posix Extensions. @@ -7755,12 +8024,7 @@ This is an alphabetical list of all the procedures and macros in SCM. * unctrl: Curses Miscellany. * uniform-array-read!: Uniform Array. * uniform-array-write: Uniform Array. -* uniform-vector-fill!: Uniform Array. -* uniform-vector-length: Uniform Array. -* uniform-vector-read!: Uniform Array. -* uniform-vector-ref: Uniform Array. -* uniform-vector-set!: Uniform Array. -* uniform-vector-write: Uniform Array. +* uniform-vector-fill!: Uniform Array. | * untrace: Debugging Scheme Code. * user-interrupt: Interrupts. * usr:lib: Dynamic Linking. @@ -7802,13 +8066,16 @@ This is an alphabetical list of all the global variables in SCM. * Menu: +* $pi: Numeric. * *argv*: SCM Variables. * *execpath: Embedding SCM. * *interactive* <1>: Internal State. * *interactive*: SCM Variables. * *load-pathname*: Miscellaneous Procedures. -* *R4RS-macro*: SCM Variables. +* *load-reader*: Line Numbers. | * *scm-version*: Internal State. +* *slib-load-reader*: Line Numbers. | +* *syntax-rules*: SCM Variables. | * af_inet: Host Data. * af_unix: Host Data. * BOOL_F: Immediates. @@ -7828,6 +8095,7 @@ This is an alphabetical list of all the global variables in SCM. * open_both: Files and Ports. * open_read: Files and Ports. * open_write: Files and Ports. +* pi: Numeric. * SCHEME_LIBRARY_PATH: SCM Variables. * SCM_INIT_PATH: SCM Variables. * symhash: Evaluation. @@ -7911,6 +8179,7 @@ This is an alphabetical list of data types and feature names in SCM. * tc7_subr_2: Subr Cells. * tc7_subr_2o: Subr Cells. * tc7_subr_3: Subr Cells. +* tc7_svect: Header Cells. | * tc7_uvect: Header Cells. * tc7_vector: Header Cells. * tc_dblc: Smob Cells. @@ -7926,174 +8195,189 @@ Concept Index * Menu: -* !#: MS-DOS Compatible Scripts. | -* !#.exe: MS-DOS Compatible Scripts. | -* #!: MS-DOS Compatible Scripts. | -* #!.bat: MS-DOS Compatible Scripts. | -* array <1>: Conventional Arrays. | -* array: Build Options. | -* array-for-each: Build Options. | -* arrays: Build Options. | -* bignums: Build Options. | +* !#: MS-DOS Compatible Scripts. +* !#.exe: MS-DOS Compatible Scripts. +* #!: MS-DOS Compatible Scripts. +* #!.bat: MS-DOS Compatible Scripts. +* array <1>: Conventional Arrays. +* array: Build Options. +* array-for-each: Build Options. +* arrays: Build Options. +* bignums: Build Options. * callbacks: Callbacks. -* careful-interrupt-masking: Build Options. | -* cautious: Build Options. | -* cheap-continuations: Build Options. | -* compiled-closure: Build Options. | +* careful-interrupt-masking: Build Options. +* cautious: Build Options. +* cheap-continuations: Build Options. +* compiled-closure: Build Options. * continuations: Continuations. -* curses: Build Options. | -* debug: Build Options. | +* curses: Build Options. +* debug: Build Options. * documentation string: Syntax Extensions. -* dump: Build Options. | -* dynamic-linking: Build Options. | -* edit-line: Build Options. | +* dump: Build Options. +* dynamic-linking: Build Options. +* ecache: Memory Management for Environments. | +* edit-line: Build Options. * Embedding SCM: Embedding SCM. -* engineering-notation: Build Options. | -* Exrename: Bibliography. | +* engineering-notation: Build Options. +* environments: Memory Management for Environments. | +* exchanger: Process Synchronization. | +* Exrename: Bibliography. * Extending Scm: Compiling and Linking Custom Files. * foo.c: Compiling and Linking Custom Files. -* generalized-c-arguments: Build Options. | -* GUILE: Bibliography. | -* i/o-extensions: Build Options. | -* IEEE: Bibliography. | -* inexact: Build Options. | -* JACAL: Bibliography. | -* lit: Build Options. | -* macro: Build Options. | -* mysql: Build Options. | -* no-heap-shrink: Build Options. | -* none: Build Options. | -* posix: Build Options. | -* R4RS: Bibliography. | -* R5RS: Bibliography. | -* reckless: Build Options. | -* record: Build Options. | -* regex: Build Options. | -* rev2-procedures: Build Options. | -* SICP: Build Options. | -* sicp: Build Options. | -* SICP: Bibliography. | +* generalized-c-arguments: Build Options. +* graphics: Packages. +* hobbit: Packages. | +* i/o-extensions: Build Options. +* IEEE: Bibliography. +* inexact: Build Options. +* JACAL: Bibliography. +* lit: Build Options. +* macro: Build Options. +* memory management: Memory Management for Environments. | +* mysql: Build Options. +* no-heap-shrink: Build Options. +* NO_ENV_CACHE: Memory Management for Environments. | +* none: Build Options. +* posix: Build Options. +* R4RS: Bibliography. +* R5RS: Bibliography. +* reckless: Build Options. +* record: Build Options. +* regex: Build Options. +* rev2-procedures: Build Options. +* SchemePrimer: Bibliography. +* SICP: Build Options. +* sicp: Build Options. +* SICP: Bibliography. * signals: Signals. -* Simply: Bibliography. | -* single-precision-only: Build Options. | -* SLIB: Bibliography. | -* socket: Build Options. | -* stack-limit: Build Options. | -* tick-interrupts: Build Options. | -* turtlegr: Build Options. | -* unix: Build Options. | -* windows: Build Options. | -* x: Build Options. | -* xlib: Build Options. | +* Simply: Bibliography. +* single-precision-only: Build Options. +* SLIB: Bibliography. +* socket: Build Options. +* stack-limit: Build Options. +* tick-interrupts: Build Options. +* turtlegr: Build Options. +* unix: Build Options. +* windows: Build Options. +* X: Packages. +* x <1>: Packages. +* x: Build Options. +* xlib: Packages. +* Xlib: Packages. +* xlib: Build Options. +* xlibscm: Packages. +* Xlibscm: Packages. Tag Table: -Node: Top229 -Node: Overview1521 -Node: Copying1832 -Node: SCM Features4894 -Node: SCM Authors6905 -Node: Bibliography7805 -Node: Installing SCM9676 -Node: Making SCM10191 -Node: SLIB11531 -Node: Building SCM13549 -Node: Invoking Build14091 -Node: Build Options16112 -Node: Compiling and Linking Custom Files33008 -Node: Installing Dynamic Linking34986 -Node: Configure Module Catalog36770 -Node: Saving Images38767 -Node: Automatic C Preprocessor Definitions39443 -Node: Problems Compiling42659 -Node: Problems Linking44785 -Node: Problems Running45087 -Node: Testing47643 -Node: Reporting Problems50980 -Node: Operational Features51823 -Node: Invoking SCM52187 -Node: SCM Options53748 -Node: Invocation Examples57904 -Node: SCM Variables58856 -Node: SCM Session60306 -Node: Editing Scheme Code61429 -Node: Debugging Scheme Code63563 -Node: Errors67202 -Node: Memoized Expressions71502 -Node: Internal State73866 -Node: Scripting76918 -Node: Unix Scheme Scripts77212 -Node: MS-DOS Compatible Scripts80423 -Node: Unix Shell Scripts82236 -Node: The Language84425 -Node: Standards Compliance85000 -Node: Miscellaneous Procedures87415 -Node: Time90765 -Node: Interrupts91759 -Node: Process Synchronization95369 -Node: Files and Ports95909 -Node: Soft Ports101092 -Node: Syntax Extensions102768 -Node: Low Level Syntactic Hooks109753 -Node: Syntactic Hooks for Hygienic Macros113664 -Node: Packages120817 -Node: Compiling And Linking121493 -Node: Dynamic Linking123530 -Node: Dump128154 -Node: Numeric132264 -Node: Arrays133820 -Node: Conventional Arrays134037 -Node: Array Mapping140675 -Node: Uniform Array142909 -Node: Bit Vectors148821 -Node: I/O-Extensions150086 -Node: Posix Extensions158379 -Node: Regular Expression Pattern Matching169109 -Node: Line Editing173064 -Node: Curses174410 -Node: Output Options Setting175333 -Node: Terminal Mode Setting177981 -Node: Window Manipulation181059 -Node: Output184519 -Node: Input188145 -Node: Curses Miscellany189172 -Node: Sockets190596 -Node: Host Data190920 -Node: Internet Addresses and Socket Names194068 -Node: Socket195602 -Node: The Implementation202838 -Node: Data Types203097 -Node: Immediates203918 -Node: Cells208254 -Node: Header Cells210346 -Node: Subr Cells213327 -Node: Ptob Cells215545 -Node: Smob Cells217091 -Node: Data Type Representations220290 -Node: Operations224909 -Node: Garbage Collection225495 -Node: Marking Cells226116 -Node: Sweeping the Heap228218 -Node: Memory Management for Environments229163 -Node: Signals233720 -Node: C Macros235264 -Node: Changing Scm236387 -Node: Defining Subrs240660 -Node: Defining Smobs242537 -Node: Defining Ptobs245521 -Node: Allocating memory246698 -Node: Embedding SCM248860 -Node: Callbacks256514 -Node: Type Conversions258317 -Node: Continuations261874 -Node: Evaluation266088 -Node: Program Self-Knowledge271253 -Node: File-System Habitat271499 -Node: Executable Pathname275099 -Node: Script Support276718 -Node: Improvements To Make278036 -Node: Finishing Dynamic Linking280067 -Node: Index287814 +Node: Top203 +Node: Overview1481 +Node: SCM Features1792 +Node: SCM Authors3804 +Node: Copying4742 +Node: Bibliography7831 +Node: Installing SCM9699 +Node: Making SCM10214 +Node: SLIB11131 +Node: Building SCM13149 +Node: Invoking Build13723 +Node: Build Options16516 +Node: Compiling and Linking Custom Files29598 +Node: Installing Dynamic Linking31577 +Node: Configure Module Catalog33361 +Node: Saving Images35358 +Node: Automatic C Preprocessor Definitions36033 +Node: Problems Compiling39541 +Node: Problems Linking41194 +Node: Problems Running41459 +Node: Testing43567 +Node: Reporting Problems46654 +Node: Operational Features47577 +Node: Invoking SCM47941 +Node: SCM Options49585 +Node: Invocation Examples54026 +Node: SCM Variables54978 +Node: SCM Session56487 +Node: Editing Scheme Code58010 +Node: Debugging Scheme Code60153 +Node: Errors63776 +Node: Memoized Expressions68075 +Node: Internal State70439 +Node: Scripting73727 +Node: Unix Scheme Scripts74021 +Node: MS-DOS Compatible Scripts77233 +Node: Unix Shell Scripts79045 +Node: The Language81235 +Node: Standards Compliance81890 +Node: Miscellaneous Procedures84304 +Node: Time87460 +Node: Interrupts88454 +Node: Process Synchronization94464 +Node: Files and Ports97244 +Node: Line Numbers104204 +Node: Soft Ports108304 +Node: Syntax Extensions110296 +Node: Low Level Syntactic Hooks119654 +Node: Syntactic Hooks for Hygienic Macros126507 +Node: Packages133588 +Node: Dynamic Linking134544 +Node: Dump139232 +Node: Numeric143350 +Node: Arrays145077 +Node: Conventional Arrays145366 +Node: Array Mapping152015 +Node: Uniform Array154278 +Node: Bit Vectors160302 +Node: Records161567 +Node: I/O-Extensions163253 +Node: Posix Extensions172179 +Node: Unix Extensions182353 +Node: Regular Expression Pattern Matching184358 +Node: Line Editing188387 +Node: Curses189733 +Node: Output Options Setting190656 +Node: Terminal Mode Setting193305 +Node: Window Manipulation196383 +Node: Output199843 +Node: Input203469 +Node: Curses Miscellany204496 +Node: Sockets205920 +Node: Host Data206244 +Node: Internet Addresses and Socket Names209392 +Node: Socket210926 +Node: The Implementation218163 +Node: Data Types218422 +Node: Immediates219243 +Node: Cells223579 +Node: Header Cells225671 +Node: Subr Cells228892 +Node: Ptob Cells231110 +Node: Smob Cells232649 +Node: Data Type Representations235845 +Node: Operations240503 +Node: Garbage Collection241089 +Node: Marking Cells241710 +Node: Sweeping the Heap243812 +Node: Memory Management for Environments244757 +Node: Signals249314 +Node: C Macros250858 +Node: Changing Scm251981 +Node: Defining Subrs256253 +Node: Defining Smobs258130 +Node: Defining Ptobs261265 +Node: Allocating memory262442 +Node: Embedding SCM264833 +Node: Callbacks272486 +Node: Type Conversions274289 +Node: Continuations277845 +Node: Evaluation282059 +Node: Program Self-Knowledge287222 +Node: File-System Habitat287468 +Node: Executable Pathname291068 +Node: Script Support292686 +Node: Improvements To Make294004 +Node: Finishing Dynamic Linking296036 +Node: Index303782 End Tag Table diff --git a/scm.spec b/scm.spec new file mode 100644 index 0000000..4be109c --- /dev/null +++ b/scm.spec @@ -0,0 +1,168 @@ +%define name scm +%define version 5d6 +%define release 1 +%define implpath %{prefix}/lib/scm +# rpm seems to require all on one line, bleah. +%define features cautious bignums arrays inexact dump dynamic-linking macro engineering-notation + +Name: %{name} +Release: %{release} +Version: %{version} +Packager: Radey Shouman <shouman@ne.mediaone.net> + +Copyright: GPL +Vendor: Aubrey Jaffer <agj @ alum.mit.edu> +Group: Development/Languages +Provides: scm +Requires: slib + +Summary: SCM Scheme implementation. +Source: ftp://swissnet.ai.mit.edu/pub/scm/scm%{version}.zip +URL: http://swissnet.ai.mit.edu/~jaffer/SCM.html +BuildRoot: %{_tmppath}/%{name}%{version} +Prefix: /usr + +%description +Scm conforms to Revised^5 Report on the Algorithmic Language Scheme and +the IEEE P1178 specification. Scm provides a machine independent +platform for JACAL, a symbolic algebra system. + +This distribution requires libdl.so from the glibc-devel package and the +slib Scheme library package. If your machine lacks XFree86 or readline, +install with --nodeps. + +%define __os_install_post /usr/lib/rpm/brp-compress + +%prep +rm -rf /var/tmp/%{name}%{version} +%setup -n scm -c -T +cd .. +unzip $RPM_SOURCE_DIR/scm%{version}.zip + +%build +# SLIB is required to build SCM. +if [ -n "$SCHEME_LIBRARY_PATH" ]; then + echo using SLIB $SCHEME_LIBRARY_PATH +elif [ -d /usr/share/slib ]; then + export SCHEME_LIBRARY_PATH=/usr/share/slib/ +elif [ -d /usr/lib/slib ]; then + export SCHEME_LIBRARY_PATH=/usr/lib/slib/ +fi +make scmlit +make clean +export PATH=.:$PATH # to get scmlit in the path. + +# Build the executable. +./build -h system -o udscm5 -l debug -s %{implpath} -F %{features} +echo "(quit)" | ./udscm5 -no-init-file -r5 -o scm +make check + +# Build dlls +make x.so +./build -h system -F curses -t dll +./build -h system -t dll -c sc2.c rgx.c record.c gsubr.c ioext.c posix.c \ + unix.c socket.c ramap.c +./build -h system -F edit-line -t dll +./build -h system -F x -t dll + +# Build libscm.a static library +./build -h system -F cautious bignums arrays inexact dynamic-linking -t lib + +%install +mkdir -p ${RPM_BUILD_ROOT}%{prefix}/bin +mkdir -p ${RPM_BUILD_ROOT}%{prefix}/lib/scm +mkdir -p ${RPM_BUILD_ROOT}%{prefix}/man/man1 +make prefix=${RPM_BUILD_ROOT}%{prefix}/ install +make prefix=${RPM_BUILD_ROOT}%{prefix}/ installlib +rm -f ${RPM_BUILD_ROOT}%{prefix}/bin/scm +cp udscm5 ${RPM_BUILD_ROOT}%{prefix}/bin/ + +# Assume SLIB is in /usr/share/slib, as installed by the slib rpm. +cat > ${RPM_BUILD_ROOT}%{prefix}/lib/scm/require.scm <<EOF +(set! library-vicinity (lambda () "%{prefix}/share/slib/")) +EOF + +mkdir -p ${RPM_BUILD_ROOT}%{prefix}/info/ +gzip *.info +cp *.info.gz ${RPM_BUILD_ROOT}%{prefix}/info/ + +%clean +rm -rf $RPM_BUILD_ROOT + +%post +/sbin/install-info /usr/info/scm.info.gz /usr/info/dir +/sbin/install-info /usr/info/hobbit.info.gz /usr/info/dir +/sbin/install-info /usr/info/Xlibscm.info.gz /usr/info/dir +echo "(quit)" | %{prefix}/bin/udscm5 -no-init-file -r5 -o %{prefix}/bin/scm +ln -s %{prefix}/bin/scm /usr/local/bin/scm +ln -s %{prefix}/lib/scm /usr/local/lib/ +/usr/bin/scm -c "(require 'new-catalog)" + +%verifyscript +cp -f %{prefix}/lib/scm/r4rstest.scm /tmp/ +(cd /tmp + %{prefix}/bin/scm -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)') + +%preun +rm -f %{prefix}/lib/scm/slibcat %{prefix}/lib/scm/implcat +if [ -L /usr/local/bin/scm ] && \ + ls -l /usr/local/bin/scm | grep -q "> %{prefix}/bin/scm"; then + rm -f /usr/local/bin/scm +fi +if [ -L /usr/local/lib/scm ] && \ + ls -l /usr/local/lib/scm | grep -q "> %{prefix}/lib/scm"; then + rm -f /usr/local/lib/scm +fi +rm -f %{prefix}/bin/scm + +%files +%defattr(-, root, root) +%{prefix}/bin/scmlit +%{prefix}/bin/udscm5 +%dir %{prefix}/lib/scm +# No wildcards here because we need to segregate files by package. +%{prefix}/lib/scm/crs.so +%{prefix}/lib/scm/gsubr.so +%{prefix}/lib/scm/posix.so +%{prefix}/lib/scm/record.so +%{prefix}/lib/scm/sc2.so +%{prefix}/lib/scm/unix.so +%{prefix}/lib/scm/ioext.so +%{prefix}/lib/scm/ramap.so +%{prefix}/lib/scm/socket.so +%{prefix}/lib/scm/rgx.so +%{prefix}/lib/scm/Init%{version}.scm +%{prefix}/lib/scm/require.scm +%{prefix}/lib/scm/Macexp.scm +%{prefix}/lib/scm/Macro.scm +%{prefix}/lib/scm/Tscript.scm +%{prefix}/lib/scm/Transcen.scm +%{prefix}/lib/scm/mkimpcat.scm +%{prefix}/lib/scm/Link.scm +%{prefix}/lib/scm/compile.scm +%{prefix}/lib/scm/hobbit.scm +%{prefix}/lib/scm/scmhob.scm +%{prefix}/lib/scm/scmhob.h +%{prefix}/lib/scm/build.scm +%{prefix}/lib/scm/build +%{prefix}/lib/scm/Iedline.scm +%{prefix}/lib/scm/edline.so +%{prefix}/lib/scm/x.so +%{prefix}/lib/scm/xevent.scm +%{prefix}/lib/scm/xatoms.scm +%{prefix}/lib/scm/x11.scm +%{prefix}/lib/scm/keysymdef.scm +%{prefix}/lib/scm/r4rstest.scm +/usr/info/Xlibscm.info.gz +/usr/info/hobbit.info.gz +/usr/info/scm.info.gz +/usr/man/man1/scm.1.gz + +%{prefix}/lib/libscm.a +%{prefix}/include/scm.h +%{prefix}/include/scmfig.h +%{prefix}/include/scmflags.h + +%doc ANNOUNCE COPYING QUICKREF README ChangeLog + +%changelog @@ -114,86 +114,13 @@ home page: @end iftex @menu -* Copying:: * SCM Features:: * SCM Authors:: +* Copying:: * Bibliography:: @end menu -@node Copying, SCM Features, Overview, Overview -@section Copying - -@center COPYRIGHT (c) 1989 BY -@center PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. -@center ALL RIGHTS RESERVED - -@noindent -Permission to use, copy, modify, distribute and sell this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all copies -and that both that copyright notice and this permission notice appear -in supporting documentation, and that the name of Paradigm Associates -Inc not be used in advertising or publicity pertaining to distribution -of the software without specific, written prior permission. - -@noindent -PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL -PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, -ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -SOFTWARE. - -@noindent -gjc@@paradigm.com -@flushright -Phone: 617-492-6079 -@end flushright -@flushleft -Paradigm Associates Inc -29 Putnam Ave, Suite 6 -Cambridge, MA 02138 -@end flushleft - -@sp 2 - -@center Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 -@center Free Software Foundation, Inc. -@center 59 Temple Place, Suite 330, Boston, MA 02111, USA - -@noindent -Permission to use, copy, modify, distribute, and sell this software and -its documentation for any purpose is hereby granted without fee, -provided that the above copyright notice appear in all copies and that -both that copyright notice and this permission notice appear in -supporting documentation. - -@center NO WARRANTY - -@noindent -BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR -THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER -EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE -ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH -YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL -NECESSARY SERVICING, REPAIR OR CORRECTION. - -@noindent -IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR -DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL -DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM -(INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED -INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF -THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR -OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. - -@node SCM Features, SCM Authors, Copying, Overview +@node SCM Features, SCM Authors, Overview, Overview @section Features @itemize @bullet @@ -243,14 +170,14 @@ timing information printed interactively (the @code{verbose} function). @code{Restart}, @code{quit}, and @code{exec}. @end itemize -@node SCM Authors, Bibliography, SCM Features, Overview +@node SCM Authors, Copying, SCM Features, Overview @section Authors @table @b -@item Aubrey Jaffer (jaffer @@ ai.mit.edu) +@item Aubrey Jaffer (jaffer @@ alum.mit.edu) Most of SCM. @item Radey Shouman -Arrays. @code{gsubr}s, compiled closures, records, Ecache, syntax-rules +Arrays, @code{gsubr}s, compiled closures, records, Ecache, syntax-rules macros, and @dfn{safeport}s. @item Jerry D. Hedden Real and Complex functions. Fast mixed type arithmetics. @@ -268,33 +195,94 @@ C-stack and being able to garbage collect off the C-stack There are many other contributors to SCM. They are acknowledged in the file @file{ChangeLog}, a log of changes that have been made to scm. -@node Bibliography, , SCM Authors, Overview +@node Copying, Bibliography, SCM Authors, Overview +@section Copyright + +@noindent +Authors have assigned their SCM copyrights to: +@sp 1 + +@center Free Software Foundation, Inc. +@center 59 Temple Place, Suite 330, Boston, MA 02111, USA + +@noindent +Permission to use, copy, modify, distribute, and sell this software and +its documentation for any purpose is hereby granted without fee, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation. + +@center NO WARRANTY + +@noindent +BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR +THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER +EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE +ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH +YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL +NECESSARY SERVICING, REPAIR OR CORRECTION. + +@noindent +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR +DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL +DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM +(INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED +INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF +THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR +OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + + +@heading SIOD copyright +@sp 1 + +@center COPYRIGHT (c) 1989 BY +@center PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. +@center ALL RIGHTS RESERVED + +@noindent +Permission to use, copy, modify, distribute and sell this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all copies +and that both that copyright notice and this permission notice appear +in supporting documentation, and that the name of Paradigm Associates +Inc not be used in advertising or publicity pertaining to distribution +of the software without specific, written prior permission. + +@noindent +PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +SOFTWARE. + +@noindent +gjc@@paradigm.com +@flushright +Phone: 617-492-6079 +@end flushright +@flushleft +Paradigm Associates Inc +29 Putnam Ave, Suite 6 +Cambridge, MA 02138 +@end flushleft + +@node Bibliography, , Copying, Overview @section Bibliography @table @asis + @item [IEEE] @cindex IEEE @cite{IEEE Standard 1178-1990. IEEE Standard for the Scheme Programming Language.} IEEE, New York, 1991. -@item [Simply] -@cindex Simply -Brian Harvey and Matthew Wright. -@ifset html -<A HREF="http://HTTP.CS.Berkeley.EDU/~bh/simply-toc.html"> -@end ifset -@cite{Simply Scheme: Introducing Computer Science} -@ifset html -</A> -@end ifset -MIT Press, 1994 ISBN 0-262-08226-8 - -@item [SICP] -@cindex SICP -Harold Abelson and Gerald Jay Sussman with Julie Sussman. -@cite{Structure and Interpretation of Computer Programs.} -MIT Press, Cambridge, 1985. - @item [R4RS] @cindex R4RS William Clinger and Jonathan Rees, Editors. @@ -345,17 +333,46 @@ Hygienic Macros Through Explicit Renaming @cite{Lisp Pointers} Volume IV, Number 4 (December 1991), pp 17-23. -@item [GUILE] -@cindex GUILE -Tom Lord. +@item [SICP] +@cindex SICP +Harold Abelson and Gerald Jay Sussman with Julie Sussman. +@cite{Structure and Interpretation of Computer Programs.} +MIT Press, Cambridge, 1985. + +@item [Simply] +@cindex Simply +Brian Harvey and Matthew Wright. +@ifset html +<A HREF="http://HTTP.CS.Berkeley.EDU/~bh/simply-toc.html"> +@end ifset +@cite{Simply Scheme: Introducing Computer Science} +@ifset html +</A> +@end ifset +MIT Press, 1994 ISBN 0-262-08226-8 + +@item [SchemePrimer] +@cindex SchemePrimer +$B8$;tBg(B(Dai Inukai) @ifset html -<A HREF="http://www.cygnus.com/library/ctr/guile.html"> +<A HREF="http://www.shuwasystem.co.jp/SchemePrimer/"> @end ifset -The Guile Architecture for Ubiquitous Computing. +@cite{$BF~Lg(BScheme} @ifset html </A> @end ifset -@cite{Usenix Symposium on Tcl/Tk}, 1995. +1999$BG/(B12$B7n=iHG(B ISBN4-87966-954-7 + +@c @item [GUILE] +@c @cindex GUILE +@c Free Software Foundation +@c @ifset html +@c <A HREF="http://www.gnu.org/software/guile/guile.html"> +@c @end ifset +@c Guile: Project GNU's extension language +@c @ifset html +@c </A> +@c @end ifset @item [SLIB] @cindex SLIB @@ -367,7 +384,7 @@ SLIB, The Portable Scheme Library. @ifset html </A> @end ifset -Version 2c5, Jan 1999. +Version 2c8, June 2000. @ifinfo @ref{Top, , , slib, SLIB}. @@ -383,7 +400,7 @@ JACAL Symbolic Mathematics System. @ifset html </A> @end ifset -Version 1a9, Jan 1999. +Version 1b0, Sep 1999. @ifinfo @ref{Top, , , jacal, JACAL}. @@ -424,40 +441,29 @@ Documentation of the Xlib - SCM Language X Interface. The SCM distribution has @dfn{Makefile} which contains rules for making @dfn{scmlit}, a ``bare-bones'' version of SCM sufficient for running -@file{build.scm}. @file{build.scm} is used to compile (or create -scripts to compile) full featured versions. +@file{build}. @file{build} is used to compile (or create scripts to +compile) full featured versions. Makefiles are not portable to the majority of platforms. If @file{Makefile} works for you, good; If not, I don't want to hear about -it. If you need to compile SCM without build.scm, there are several -ways to proceed: +it. If you need to compile SCM without build, there are several ways to +proceed: @itemize @bullet @item -Use SCM on a different platform to run @file{build.scm} to create a -script to build SCM; +Use the @uref{http://swissnet.ai.mit.edu/~jaffer/buildscm.html, build} +web page to create custom batch scripts for compiling SCM. @item -Use another implementation of Scheme to run @file{build.scm} to create a -script to build SCM; +Use SCM on a different platform to run @file{build} to create a script +to build SCM; @item -Create your own script or @file{Makefile}. - -@item -Buy a SCM executable from jaffer @@ ai.mit.edu. See the end of the -@file{ANNOUNCE} file in the distribution for details. +Use another implementation of Scheme to run @file{build} to create a +script to build SCM; @item -Use scmconfig (From: bos@@scrg.cs.tcd.ie): - -Build and install scripts using GNU @dfn{autoconf} are available from -@file{scmconfig4e3.tar.gz} in the distribution directories. See -@file{README.unix} in @file{scmconfig4e3.tar.gz} for further -instructions. - -@emph{Note:} The last release of scmconfig (4e3) was on March 20, 1996. -I am moving it to the OLD subdirectory until someone submits an update. +Create your own script or @file{Makefile}. @end itemize @@ -474,34 +480,34 @@ low priority. SLIB is available from the same sites as SCM: @ifclear html @itemize @bullet @item -swissnet.ai.mit.edu:/pub/scm/slib2c7.tar.gz +swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz @item -ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz +ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz @item -ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz +ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz @end itemize @end ifclear @ifset html @itemize @bullet @item -<A HREF="http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip"> -http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip +<A HREF="http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip"> +http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip </A> @item -<A HREF="ftp://ftp.gnu.org/pub/gnu/jacal/slib2c7.tar.gz"> -ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz +<A HREF="ftp://ftp.gnu.org/pub/gnu/jacal/slib2d4.tar.gz"> +ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz </A> @item -<A HREF="ftp://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2c7.tar.gz"> -ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2c7.tar.gz +<A HREF="ftp://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2d4.tar.gz"> +ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2d4.tar.gz </A> @end itemize @end ifset @noindent -Unpack SLIB (@samp{tar xzf slib2c7.tar.gz} or @samp{unzip -ao -slib2c7.zip}) in an appropriate directory for your system; both +Unpack SLIB (@samp{tar xzf slib2d4.tar.gz} or @samp{unzip -ao +slib2d4.zip}) in an appropriate directory for your system; both @code{tar} and @code{unzip} will create the directory @file{slib}. @noindent @@ -541,11 +547,12 @@ absolute pathnames are recommended. @node Building SCM, Installing Dynamic Linking, SLIB, Installing SCM @section Building SCM -The file @dfn{build.scm} builds and runs a relational database of how to -compile and link SCM executables. It has information for most platforms -which SCM has been ported to (of which I have been notified). Some of -this information is old, incorrect, or incomplete. Send corrections and -additions to jaffer @@ ai.mit.edu. +The file @dfn{build} loads the file @dfn{build.scm}, which constructs a +relational database of how to compile and link SCM executables. +@file{build.scm} has information for the platforms which SCM has been +ported to (of which I have been notified). Some of this information is +old, incorrect, or incomplete. Send corrections and additions to jaffer +@@ ai.mit.edu. @menu * Invoking Build:: @@ -558,7 +565,7 @@ additions to jaffer @@ ai.mit.edu. @noindent The @emph{all} method will also work for MS-DOS and unix. Use -the @emph{all} method if you encounter problems with @file{build.scm}. +the @emph{all} method if you encounter problems with @file{build}. @table @asis @item MS-DOS @@ -566,12 +573,12 @@ From the SCM source directory, type @samp{build} followed by up to 9 command line arguments. @item unix -From the SCM source directory, type @samp{./build.scm} followed by command +From the SCM source directory, type @samp{./build} followed by command line arguments. @item @emph{all} From the SCM source directory, start @samp{scm} or @samp{scmlit} and -type @code{(load "build.scm")}. Alternatively, start @samp{scm} or +type @code{(load "build")}. Alternatively, start @samp{scm} or @samp{scmlit} with the command line argument @samp{-ilbuild}. @end table @@ -582,18 +589,20 @@ script with the @code{arrays}, @code{inexact}, and @code{bignums} options as defaults. @example -bash$ ./build.scm +bash$ ./build @print{} -#!/bin/sh +#! /bin/sh +# unix (linux) script created by SLIB/batch +# ================ Write file with C defines rm -f scmflags.h -echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h +echo '#define IMPLINIT "Init@value{SCMVERSION}.scm"'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h -gcc -O2 -c continue.c scm.c findexec.c script.c time.c repl.c scl.c \ - eval.c sys.c subr.c unif.c rope.c -gcc -rdynamic -o scm continue.o scm.o findexec.o script.o time.o \ - repl.o scl.o eval.o sys.o subr.o unif.o rope.o -lm -lc +# ================ Compile C source files +gcc -O2 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c +# ================ Link C object files +gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc @end example @noindent @@ -602,21 +611,18 @@ or @samp{--platform=} option. This will create a script for the platform named in the @samp{-p} or @samp{--platform=} option. @example -bash$ ./build.scm -p vms +bash$ ./build -o scmlit -p darwin -F lit @print{} -$DELETE scmflags.h -$CREATE scmflags.h -$DECK -#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm" -#define BIGNUMS -#define FLOATS -#define ARRAYS -$EOD -$ cc continue scm findexec script time repl scl eval sys subr unif rope -$ macro setjump -$ link continue,scm,findexec,script,time,repl,scl,eval,sys,subr,unif,rope,setjump,sys$input/opt - -lc,sys$share:vaxcrtl/share -$RENAME continue.exe scm.exe +#! /bin/sh +# unix (darwin) script created by SLIB/batch +# ================ Write file with C defines +rm -f scmflags.h +echo '#define IMPLINIT "Init@value{SCMVERSION}.scm"'>>scmflags.h +# ================ Compile C source files +cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c +# ================ Link C object files +mv -f scmlit scmlit~ +cc -o scmlit continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o @end example @@ -731,7 +737,7 @@ dos @item vms @item -amigados +amigaos (was amigados) @item system @@ -789,7 +795,7 @@ compile and link your file at compile time, use the @samp{-c} and @example bash$ build -c foo.c -i init_foo @print{} -#!/bin/sh +#! /bin/sh rm -f scmflags.h echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h echo '#define COMPILED_INITS init_foo();'>>scmflags.h @@ -808,7 +814,7 @@ To make a dynamically loadable object file use the @code{-t dll} option: @example bash$ build -t dll -c foo.c @print{} -#!/bin/sh +#! /bin/sh rm -f scmflags.h echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h @@ -987,8 +993,9 @@ __WATCOMC__ Watcom C on MS-DOS __ZTC__ Zortech C _AIX AIX operating system +__APPLE__ Apple Darwin AMIGA SAS/C 5.10 or Dice C on AMIGA -__amigados__ Gnu CC on AMIGA +__amigaos__ Gnu CC on AMIGA atarist ATARI-ST under Gnu CC __FreeBSD__ FreeBSD GNUDOS DJGPP (obsolete in version 1.08) @@ -997,11 +1004,12 @@ hpux HP-UX linux Linux macintosh Macintosh (THINK_C and __MWERKS__ define) MCH_AMIGA Aztec_c 5.2a on AMIGA +__MACH__ Apple Darwin MSDOS Microsoft C 5.10 and 6.00A __MSDOS__ Turbo C, Borland C, and DJGPP nosve Control Data NOS/VE SVR2 System V Revision 2. -__svr4__ SunOS +__SVR4 SunOS THINK_C developement environment for the Macintosh ultrix VAX with ULTRIX operating system. unix most Unix and similar systems and DJGPP (!?) @@ -1021,6 +1029,8 @@ hp9000s800 HP RISC processor __i386__ DJGPP i386 DJGPP MULTIMAX Encore computer +ppc PowerPC +__ppc__ PowerPC pyr Pyramid 9810 processor __sgi__ Silicon Graphics Inc. sparc SPARC processor @@ -1159,13 +1169,13 @@ digits of pi. > (load "pi") ;loading "pi" ;done loading "pi.scm" -;Evaluation took 20 mSec (0 in gc) 767 cells work, 233 bytes other +;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B other #<unspecified> > (pi 100 5) 00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 70679 -;Evaluation took 550 mSec (60 in gc) 36976 cells work, 1548 bytes other +;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other #<unspecified> @end example @@ -1220,7 +1230,7 @@ call-with-current-continuations. @noindent Reported problems and solutions are grouped under Compiling, Linking, Running, and Testing. If you don't find your problem listed there, you -can send a bug report to @code{jaffer @@ ai.mit.edu}. The bug report +can send a bug report to @code{jaffer @@ alum.mit.edu}. The bug report should include: @enumerate @@ -1262,10 +1272,11 @@ vendor is recommended. @section Invoking SCM @example -@exdent @b{ scm } [-a @i{kbytes}] [-ibvqmu] [-p @i{number}] -@w{[-c @i{expression}]} @w{[-e @i{expression}]} @w{[-f @i{filename}]} -@w{[-l @i{filename}]} @w{[-r @i{feature}]} @w{[-- | - | -s]} -@w{[@i{filename}]} @w{[@i{arguments} @dots{}]} +@exdent @b{ scm } [-a @i{kbytes}] [-muvbiq] @w{[--version]} @w{[--help]} +@w{[[-]-no-init-file]} @w{[-p @i{int}]} @w{[-r @i{feature}]} @w{[-h @i{feature}]} +@w{[-d @i{filename}]} @w{[-f @i{filename}]} @w{[-l @i{filename}]} +@w{[-c @i{expression}]} @w{[-e @i{expression}]} @w{[-o @i{dumpname}]} +@w{[-- | - | -s]} @w{[@i{filename}]} @w{[@i{arguments} @dots{}]} @end example @noindent @@ -1291,7 +1302,7 @@ Unless the option @code{-no-init-file} or @code{--no-init-file} occurs in the command line, @file{Init@value{SCMVERSION}.scm} checks to see if there is file @file{ScmInit.scm} in the path specified by the environment variable @var{HOME} (or in the current directory if -@var{HOME} is undefined). If it finds such a file it is loaded. +@var{HOME} is undefined). If it finds such a file it is loaded. @noindent @file{Init@value{SCMVERSION}.scm} then looks for command input from one @@ -1311,12 +1322,12 @@ Extensions, #!}. @noindent The options are processed in the order specified on the command line. -@deffn {Command Option} -a kb -specifies that @code{scm} should allocate an initial heapsize of -@var{kb} kilobytes. This option, if present, must be the first on -the command line. If not specified, the default is -@code{INIT_HEAP_SIZE} in source file @file{setjump.h} which the -distribution sets at @code{25000*sizeof(cell)}. +@deffn {Command Option} -a k +specifies that @code{scm} should allocate an initial heapsize of @var{k} +kilobytes. This option, if present, must be the first on the command +line. If not specified, the default is @code{INIT_HEAP_SIZE} in source +file @file{setjump.h} which the distribution sets at +@code{25000*sizeof(cell)}. @end deffn @deffn {Command Option} -no-init-file @@ -1324,72 +1335,101 @@ distribution sets at @code{25000*sizeof(cell)}. Inhibits the loading of @file{ScmInit.scm} as described above. @end deffn -@deffn {Command Option} -e expression -@deffnx {Command Option} -c expression -specifies that the scheme expression @var{expression} is to be -evaluated. These options are inspired by @code{perl} and @code{sh} -respectively. On Amiga systems the entire option and argument need to be -enclosed in quotes. For instance @samp{"-e(newline)"}. +@deffn {Command Option} ---help +prints usage information and URI; then exit. +@end deffn + +@deffn {Command Option} ---version +prints version information and exit. @end deffn @deffn {Command Option} -r feature -requires @var{feature}. This will load a file from [SLIB] if that -@var{feature} is not already supported. If @var{feature} is 2, 3, 4, or -5 @code{scm} will require the features neccessary to support [R2RS], -[R3RS], [R4RS], or [R5RS], respectively. +requires @var{feature}. This will load a file from [SLIB] if that +@var{feature} is not already provided. If @var{feature} is 2, 2rs, +r2rs, 3, 3rs, r3rs, 4, 4rs, r4rs, 5, 5rs, or r5rs; @code{scm} will +require the features neccessary to support [R2RS], [R3RS], [R4RS], or +[R5RS], respectively. +@end deffn + +@deffn {Command Option} -h feature +provides @var{feature}. @end deffn @deffn {Command Option} -l filename @deffnx {Command Option} -f filename -loads @var{filename}. @code{Scm} will load the first (unoptioned) file +loads @var{filename}. @code{Scm} will load the first (unoptioned) file named on the command line if no @code{-c}, @code{-e}, @code{-f}, @code{-l}, or @code{-s} option preceeds it. @end deffn +@deffn {Command Option} -d filename +Loads SLIB @code{databases} feature and opens @var{filename} as a +database. +@end deffn + +@deffn {Command Option} -e expression +@deffnx {Command Option} -c expression +specifies that the scheme expression @var{expression} is to be +evaluated. These options are inspired by @code{perl} and @code{sh} +respectively. On Amiga systems the entire option and argument need to be +enclosed in quotes. For instance @samp{"-e(newline)"}. +@end deffn + +@deffn {Command Option} -o dumpname +saves the current SCM session as the executable program @file{dumpname}. +This option works only in SCM builds supporting @code{dump} +(@pxref{Dump}). + +If options appear on the command line after @samp{-o @var{dumpname}}, +then the saved session will continue with processing those options when +it is invoked. Otherwise the (new) command line is processed as usual +when the saved image is invoked. +@end deffn + @deffn {Command Option} -p level -sets the prolixity (verboseness) to @var{level}. This is the same as +sets the prolixity (verboseness) to @var{level}. This is the same as the @code{scm} command (verobse @var{level}). @end deffn @deffn {Command Option} -v (verbose mode) specifies that @code{scm} will print prompts, evaluation -times, notice of loading files, and garbage collection statistics. This +times, notice of loading files, and garbage collection statistics. This is the same as @code{-p3}. @end deffn @deffn {Command Option} -q (quiet mode) specifies that @code{scm} will print no extra -information. This is the same as @code{-p0}. +information. This is the same as @code{-p0}. @end deffn @deffn {Command Option} -m specifies that subsequent loads, evaluations, and user interactions will -be with syntax-rules macro capability. To use a specific syntax-rules +be with syntax-rules macro capability. To use a specific syntax-rules macro implementation from [SLIB] (instead of [SLIB]'s default) put @code{-r} @var{macropackage} before @code{-m} on the command line. @end deffn @deffn {Command Option} -u specifies that subsequent loads, evaluations, and user interactions will -be without syntax-rules macro capability. syntax-rules macro capability +be without syntax-rules macro capability. Syntax-rules macro capability can be restored by a subsequent @code{-m} on the command line or from Scheme code. @end deffn @deffn {Command Option} -i -specifies that @code{scm} should run interactively. That means that +specifies that @code{scm} should run interactively. That means that @code{scm} will not terminate until the @code{(quit)} or @code{(exit)} -command is given, even if there are errors. It also sets the prolixity -level to 2 if it is less than 2. This will print prompts, evaluation -times, and notice of loading files. The prolixity level can be set by -subsequent options. If @code{scm} is started from a tty, it will assume +command is given, even if there are errors. It also sets the prolixity +level to 2 if it is less than 2. This will print prompts, evaluation +times, and notice of loading files. The prolixity level can be set by +subsequent options. If @code{scm} is started from a tty, it will assume that it should be interactive unless given a subsequent @code{-b} option. @end deffn @deffn {Command Option} -b -specifies that @code{scm} should run non-interactively. That means that +specifies that @code{scm} should run non-interactively. That means that @code{scm} will terminate after processing the command line or if there are errors. @end deffn @@ -1404,29 +1444,6 @@ treated as program aguments. specifies that there are no more options on the command line. @end deffn -@deffn {Command Option} -d filename -loads SLIB database-utilities and opens @var{filename} as a database. -@end deffn - -@deffn {Command Option} -o filename -saves the current SCM session as the executable program @file{filename}. -This option works only in SCM builds supporting @code{dump} -(@pxref{Dump}). - -If options appear on the command line after @samp{-o @var{filename}}, -then the saved session will continue with processing those options when -it is invoked. Otherwise the (new) command line is processed as usual -when the saved image is invoked. -@end deffn - -@deffn {Command Option} ---help -prints usage information and URL; then exit. -@end deffn - -@deffn {Command Option} ---version -prints version information and exit. -@end deffn - @node Invocation Examples, SCM Variables, SCM Options, Operational Features @section Invocation Examples @@ -1464,7 +1481,7 @@ Like above but @code{rev4-optional-procedures} are also loaded. @defvr {Environment Variable} SCM_INIT_PATH is the pathname where @code{scm} will look for its initialization -code. The default is the file @file{Init@value{SCMVERSION}.scm} in the +code. The default is the file @file{Init@value{SCMVERSION}.scm} in the source directory. @end defvr @@ -1485,22 +1502,22 @@ is not defined, the default is @samp{ed}. @section Scheme Variables @defvar *argv* -contains the list of arguments to the program. @code{*argv*} can change -during argument processing. This list is suitable for use as an argument +contains the list of arguments to the program. @code{*argv*} can change +during argument processing. This list is suitable for use as an argument to [SLIB] @code{getopt}. @end defvar -@defvar *R4RS-macro* +@defvar *syntax-rules* controls whether loading and interaction support syntax-rules -macros. Define this in @file{ScmInit.scm} or files specified on the -command line. This can be overridden by subsequent @code{-m} and +macros. Define this in @file{ScmInit.scm} or files specified on the +command line. This can be overridden by subsequent @code{-m} and @code{-u} options. @end defvar @defvar *interactive* controls interactivity as explained for the @code{-i} and @code{-b} -options. Define this in @file{ScmInit.scm} or files specified on the -command line. This can be overridden by subsequent @code{-i} and +options. Define this in @file{ScmInit.scm} or files specified on the +command line. This can be overridden by subsequent @code{-i} and @code{-b} options. @end defvar @@ -1529,6 +1546,12 @@ systems, SCM can also tail-call another program. @xref{I/O-Extensions, execp}. @end defun +@deffn {Callback procedure} boot-tail dumped? +@code{boot-tail} is called by @code{scm_top_level} just before entering +interactive top-level. If @code{boot-tail} calls @code{quit}, then +interactive top-level is not entered. +@end deffn + @defun program-arguments Returns a list of strings of the arguments scm was called with. @end defun @@ -1699,7 +1722,7 @@ GNU Emacs. PSD runs slowly, so start by instrumenting only a few functions at a time. @lisp http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz -ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz +swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz @end lisp @@ -1953,14 +1976,16 @@ no prompt or information is printed. @item >= 1 a prompt is printed. @item >= 2 -the CPU time is printed after each top level form evaluated. +messages bracketing file loading are printed. @item >= 3 -messages about heap growth are printed. +the CPU time is printed after each top level form evaluated; +notifications of heap growth printed. @item >= 4 -garbage collection (@pxref{Garbage Collection}) messages are printed. +a garbage collection summary is printed after each top level form +evaluated; @item >= 5 -a warning will be printed for each top-level symbol which is defined -more than one time. +a message for each GC (@pxref{Garbage Collection}) is printed; +warnings issued for top-level symbols redefined. @end table @end defun @@ -2070,7 +2095,7 @@ This combination of interpretatons allows SCM source files to be used as POSIX shell-scripts if the first line is: @example -#!/usr/local/bin/scm \ +#! /usr/local/bin/scm \ @end example @noindent @@ -2189,7 +2214,7 @@ moved. @noindent The following approach solves these problems at the expense of slower -startup. Make @samp{#!/bin/sh} the first line and prepend every +startup. Make @samp{#! /bin/sh} the first line and prepend every subsequent line to be executed by the shell with @code{:;}. The last line to be executed by the shell should contain an @dfn{exec} command; @code{exec} tail-calls its argument. @@ -2253,6 +2278,7 @@ http://swissnet.ai.mit.edu/~jaffer/SLIB.html * Interrupts:: and exceptions * Process Synchronization:: Because interrupts are preemptive * Files and Ports:: +* Line Numbers:: * Soft Ports:: Emulate I/O devices * Syntax Extensions:: * Low Level Syntactic Hooks:: @@ -2396,9 +2422,10 @@ values returned by @code{current-input-port} and @defvar *load-pathname* Is set to the pathname given as argument to @code{load}, -@code{try-load}, and @code{dyn:link} (@pxref{Compiling And Linking}). -@code{*load-pathname*} is used to compute the value of @ref{Vicinity, -program-vicinity, , slib, SLIB}. +@code{try-load}, and @code{dyn:link} +(@pxref{Compiling And Linking, , , hobbit, Hobbit}). +@code{*load-pathname*} is used to compute the value of +@ref{Vicinity, program-vicinity, , slib, SLIB}. @end defvar @defun line-number @@ -2413,8 +2440,10 @@ not open to a file the result is unspecified. @defun port-line port @defunx port-column port If @var{port} is a tracked port, return the current line (column) number, -otherwise return @code{#f}. Line numbers begin with 1, the column number is -zero if there are no characters on the current line. +otherwise return @code{#f}. Line and column numbers begin with 1. +The column number applies to the next character to be read; if that +character is a newline, then the column number will be one more than +the length of the line. @end defun @defun eval obj @@ -2581,9 +2610,77 @@ To unestablish a response for an error set the handler symbol to @code{#f}. For instance, @code{(set! could-not-open #f)}. @end deffn +@deffn {Callback procedure} gc-hook @dots{} +Allows a Scheme procedure to be run shortly after each garbage collection. +This procedure will not be run recursively. If it runs long enough +to cause a garbage collection before returning a warning will be +printed. +@end deffn + +@defun add-finalizer object finalizer +@var{object} may be any garbage collected object, that is, any object +other than an immediate integer, character, or special token such +as @code{#f} or @code{#t}, @xref{Immediates}. @var{finalizer} is +a thunk, or procedure taking no arguments. + +@var{finalizer} will be invoked asynchronously exactly once some time +after @var{object} becomes eligible for garbage collection. A reference +to @var{object} in the environment of @var{finalizer} will not prevent +finalization, but will delay the reclamation of @var{object} at least +until the next garbage collection. A reference to @var{object} in some +other object's finalizer will necessarily prevent finalization until both +objects are eligible for garbage collection. + +Finalizers are not run in any predictable order. All finalizers will be +run by the time the program ends. + +This facility was based on the paper by Simon Peyton Jones, et al, +``Stretching the storage manager: weak pointers and stable names in +Haskell'', Proc. 11th International Workshop on the Implementation of +Functional Languages, The Netherlands, September 7-10 1999, +Springer-Verlag LNCS. + +@end defun + @node Process Synchronization, Files and Ports, Interrupts, The Language @section Process Synchronization +@noindent +An @dfn{exchanger} is a procedure of one argument regulating mutually +@cindex exchanger +exclusive access to a resource. When a exchanger is called, its current +content is returned, while being replaced by its argument in an atomic +operation. + +@defun make-exchanger obj + +Returns a new exchanger with the argument @var{obj} as its initial +content. + +@example +(define queue (make-exchanger (list a))) +@end example + +A queue implemented as an exchanger holding a list can be protected from +reentrant execution thus: + +@example +(define (pop queue) + (let ((lst #f)) + (dynamic-wind + (lambda () (set! lst (queue #f))) + (lambda () (and lst (not (null? lst)) + (let ((ret (car lst))) + (set! lst (cdr lst)) + ret))) + (lambda () (and lst (queue lst)))))) + +(pop queue) @result{} a + +(pop queue) @result{} #f +@end example +@end defun + @defun make-arbiter name Returns an object of type arbiter and name @var{name}. Its state is @@ -2602,7 +2699,7 @@ Returns @code{#t} and unlocks @var{arbiter} if @var{arbiter} was locked. Otherwise, returns @code{#f}. @end defun -@node Files and Ports, Soft Ports, Process Synchronization, The Language +@node Files and Ports, Line Numbers, Process Synchronization, The Language @section Files and Ports @noindent @@ -2626,12 +2723,16 @@ Internal functions opening files @dfn{callback} to the SCM function @defvrx Constant open_both Contain modes strings specifying that a file is to be opened for reading, writing, and both reading and writing respectively. + +Both input and output functions can be used with io-ports. An end of +file must be read or a file-set-position done on the port between a read +operation and a write operation or vice-versa. @end defvr @defun _ionbf modestr Returns a version of @var{modestr} which when @code{open-file} is called -with it as the second argument will return an unbuffered port. A -non-file input-port must be unbuffered in order for @code{char-ready?} and +with it as the second argument will return an unbuffered port. An +input-port must be unbuffered in order for @code{char-ready?} and @code{wait-for-input} to work correctly on it. The initial value of @code{(current-input-port)} is unbuffered if the platform supports it. @end defun @@ -2640,20 +2741,28 @@ non-file input-port must be unbuffered in order for @code{char-ready?} and Returns a version of @var{modestr} which when @code{open-file} is called with it as the second argument will return a tracked port. A tracked port maintains current line and column numbers, which may be queried -with @code{port_line} and @code{port_column}. +with @code{port-line} and @code{port-column}. @end defun -@defun close-port port -Closes @var{port}. The same as close-input-port and close-output-port. +@defun _exclusive modestr +Returns a version of @var{modestr} which when @code{open-file} is called +with it as the second argument will return a port only if the named file +does not already exist. This functionality is provided by calling +@code{try-create-file} @xref{I/O-Extensions}, which is not available +for all platforms. +@end defun + +@defun port-closed? port +Returns #t if @var{port} is closed. @end defun -@defun open-io-file filename -@defunx close-io-port port -These functions are analogous to the standard scheme file functions. -The ports are open to @var{filename} in read/write mode. Both input and -output functions can be used with io-ports. An end of file must be read -or a file-set-position done on the port between a read operation and a -write operation or vice-versa. +@defun port-type obj +If @var{obj} is not a port returns false, otherwise returns +a symbol describing the port type, for example string or pipe. +@end defun + +@defun close-port port +Closes @var{port}. The same as close-input-port and close-output-port. @end defun @defun current-error-port @@ -2677,6 +2786,15 @@ and with-error-to-file in that the first argument is a port, rather than a string naming a file. @end defun +@defun call-with-outputs thunk proc +Calls the @var{thunk} procedure while the current-output-port and +current-error-port are directed to string-ports. If @var{thunk} +returns, the @var{proc} procedure is called with the output-string, the +error-string, and the value returned by @var{thunk}. If @var{thunk} +does not return a value (perhaps because of error), @var{proc} is called +with just the output-string and the error-string as arguments. +@end defun + @deffn {procedure} char-ready? @deffnx {procedure} char-ready? port @@ -2726,12 +2844,76 @@ Returns @code{#t} if @var{port} is input or output to a serial non-file device. Outputs a newline to optional argument @var{port} unless the current output column number of @var{port} is known to be zero, ie output will start at the beginning of a new line. @var{port} defaults to -@code{current-output-port}. If @var{port} is not a tracked port +@code{current-output-port}. If @var{port} is not a tracked port @code{freshline} is equivalent to @code{newline}. @end defun +@defun open-ports +Returns a list of all currently open ports, excluding string ports, +see @xref{String Ports, , , slib, SLIB}. This may be useful after +a fork @xref{Posix Extensions}, or for debugging. Bear in mind that +ports that would be closed by gc will be kept open by a reference to +this list. +@end defun + + +@node Line Numbers, Soft Ports, Files and Ports, The Language +@section Line Numbers + +Scheme code define by load may optionally contain line number +information. Currently this information is used only for reporting +expansion time errors, but in the future run-time error messages may +also include line number information. + +@defun try-load pathname reader +This is the primitive for loading, @var{pathname} is the name of +a file containing Scheme code, and optional argument @var{reader} is +a function of one argument, a port. @var{reader} should read and +return Scheme code as list structure. The default value is @code{read}, +which is used if @var{reader} is not supplied or is false. +@end defun + +Line number objects are disjoint from integers or other Scheme types. +When evaluated or loaded as Scheme code, an s-expression containing a +line-number in the car is equivalent to the cdr of the s-expression. A +pair consisting of a line-number in the car and a vector in the cdr is +equivalent to the vector. The meaning of s-expressions with +line-numbers in other positions is undefined. -@node Soft Ports, Syntax Extensions, Files and Ports, The Language +@defun read-numbered port +Behaves like @code{read}, except that every s-expression read will be +replaced with a cons of a line-number object and the sexp actually read. +This replacement is done only if @var{port} is a tracked port +See @xref{Files and Ports}. +@end defun + +@defun integer->line-number int +Returns a line-number object with value @var{int}. @var{int} should +be an exact non-negative integer. +@end defun + +@defun line-number->integer linum +Returns the value of line-number object @var{linum} as an integer. +@end defun + +@defun line-number? obj +Returns true if and only if @var{obj} is a line-number object. +@end defun + +@defvar *load-reader* +@defvarx *slib-load-reader* +The value of @code{*load-reader*} should be a value acceptable as +the second argument to @code{try-load} (note that #f is acceptable). +This value will be used to read code during calls to @code{scm:load}. +The value of @code{*slib-load-reader*} will similarly be used during +calls to @code{slib:load} and @code{require}. + +In order to disable all line-numbering, it is sufficient to set! +@code{*load-reader*} and @code{*slib-load-reader*} to #f. +@end defvar + + +@node Soft Ports, Syntax Extensions, Line Numbers, The Language @section Soft Ports @noindent @@ -2766,6 +2948,9 @@ If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, eof-object?, ,r5rs, Revised(5) Scheme}) it indicates that the port has reached end-of-file. For example: +If it is necessary to explicitly close the port when it is garbage +collected, (@pxref{Interrupts, add-finalizer}). + @example (define stdout (current-output-port)) (define p (make-soft-port @@ -2917,9 +3102,9 @@ is bound. The result of the @samp{set!} expression is unspecified. @end example @end defspec -@defspec casev key clause1 clause2 @dots{} -@code{casev} is an extension of standard Scheme @code{case}: Each -@var{clause} of a @code{casev} statement must have as first element a +@defspec qase key clause1 clause2 @dots{} +@code{qase} is an extension of standard Scheme @code{case}: Each +@var{clause} of a @code{qase} statement must have as first element a list containing elements which are: @itemize @bullet @@ -2932,7 +3117,7 @@ a comma followed by an at-sign (@@) followed by the name of a symbolic constant whose value is a list. @end itemize -A @code{casev} statement is equivalent to a @code{case} statement in +A @code{qase} statement is equivalent to a @code{case} statement in which these symbolic constants preceded by commas have been replaced by the values of the constants, and all symbolic constants preceded by comma-at-signs have been replaced by the elements of the list values of @@ -2941,20 +3126,20 @@ similar to that of @code{quasiquote} except that the unquoted expressions must be @dfn{symbolic constants}. Symbolic constants are defined using @code{defconst}, their values are -substituted in the head of each @code{casev} clause during macro +substituted in the head of each @code{qase} clause during macro expansion. @code{defconst} constants should be defined before use. -@code{casev} can be substituted for any correct use of @code{case}. +@code{qase} can be substituted for any correct use of @code{case}. @format @t{(defconst unit '1) (defconst semivowels '(w y)) -(casev (* 2 3) +(qase (* 2 3) ((2 3 5 7) 'prime) ((,unit 4 6 8 9) 'composite)) ==> composite -(casev (car '(c d)) +(qase (car '(c d)) ((a) 'a) ((b) 'b)) ==> @emph{unspecified} -(casev (car '(c d)) +(qase (car '(c d)) ((a e i o u) 'vowel) ((,@@semivowels) 'semivowel) (else 'consonant)) ==> consonant @@ -2964,10 +3149,97 @@ expansion. @code{defconst} constants should be defined before use. @end defspec @noindent +@findex defmacro +@findex macroexpand +@findex macroexpand-1 +@findex gentemp SCM also supports the following constructs from Common Lisp: @code{defmacro}, @code{macroexpand}, @code{macroexpand-1}, and @code{gentemp}. @xref{Defmacro, , , slib, SLIB}. +SCM @code{defmacro} is extended over that described for SLIB: + +@lisp +(defmacro (macro-name . arguments) body) +@end lisp + +is equivalent to + +@lisp +(defmacro macro-name arguments body) +@end lisp + +As in Common Lisp, an element of the formal argument list for +@code{defmacro} may be a possibly nested list, in which case the +corresponding actual argument must be a list with as many members as the +formal argument. Rest arguments are indicated by improper lists, as in +Scheme. It is an error if the actual argument list does not have the +tree structure required by the formal argument list. + +For example: + +@lisp +(defmacro (let1 ((name value)) . body) + `((lambda (,name) ,@@body) ,value)) + +(let1 ((x (foo))) (print x) x) @equiv{} ((lambda (x) (print x) x) (foo)) + +(let1 not legal syntax) @error{} not "does not match" ((name value)) +@end lisp + +@findex syntax-rules +SCM supports [R5RS] @code{syntax-rules} macros +@xref{Macros, , ,r5rs, Revised(5) Scheme}. + +The pattern language is extended by the syntax @code{(... <obj>)}, which +is identical to @code{<obj>} except that ellipses in @code{<obj>} are +treated as ordinary identifiers in a template, or as literals in a +pattern. In particular, @code{(... ...)} quotes the ellipsis token +@code{...} in a pattern or template. + +For example: +@lisp +(define-syntax check-tree + (syntax-rules () + ((_ (?pattern (... ...)) ?obj) + (let loop ((obj ?obj)) + (or (null? obj) + (and (pair? obj) + (check-tree ?pattern (car obj)) + (loop (cdr obj)))))) + ((_ (?first . ?rest) ?obj) + (let ((obj ?obj)) + (and (pair? obj) + (check-tree ?first (car obj)) + (check-tree ?rest (cdr obj))))) + ((_ ?atom ?obj) #t))) + +(check-tree ((a b) ...) '((1 2) (3 4) (5 6))) @result{} #t + +(check-tree ((a b) ...) '((1 2) (3 4) not-a-2list) @result{} #f +@end lisp + +Note that although the ellipsis is matched as a literal token in the +defined macro it is not included in the literals list for +@code{syntax-rules}. + +The pattern language is also extended to support identifier macros. A +reference to an identifier macro keyword that is not the first +identifier in a form may expand into Scheme code, rather than raising a +``keyword as variable'' error. The pattern for expansion of such a bare +macro keyword is a single identifier, as in other syntax rules the +identifier is ignored. + +For example: +@lisp +(define-syntax eight + (syntax-rules () + (_ 8))) + +(+ 3 eight) @result{} 11 +(eight) @result{} ERROR +(set! eight 9) @result{} ERROR +@end lisp @node Low Level Syntactic Hooks, Syntactic Hooks for Hygienic Macros, Syntax Extensions, The Language @section Low Level Syntactic Hooks @@ -2998,7 +3270,6 @@ defining it. Call this saved value if an invocation's syntax is not recognized. This will allow @code{#+}, @code{#-}, @code{#!}, and @ref{Uniform Array}s to still be supported (as they use @code{read:sharp}). - @defun procedure->syntax proc Returns a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, returns the result of applying @@ -3007,6 +3278,7 @@ as the first symbol in an expression, returns the result of applying @defun procedure->macro proc @defunx procedure->memoizing-macro proc +@defunx procedure->identifier-macro Returns a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, evaluates the result of applying @var{proc} to the expression and the environment. The value returned @@ -3015,19 +3287,34 @@ from @var{proc} which has been passed to @var{proc}. For example: @example -(define trace +(defsyntax trace (procedure->macro (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) (trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). @end example + +@code{PROCEDURE->IDENTIFIER-MACRO} is similar to +@code{PROCEDURE->MEMOIZING-MACRO} except that @var{proc} is also +called in case the symbol bound to the macro appears in an expression +but @emph{not} as the first symbol, that is, when it looks like a +variable reference. In that case, the form passed to @var{proc} is +a single identifier. + @end defun -@defun environment->tree env -An @dfn{environment} is an opaque object representing lexical bindings. -@code{environment->tree} returns a representation of the environment -@var{env} as a list of environment frames. There are 2 types of -environment frames: +@defspec defsyntax name expr +Defines @var{name} as a macro keyword bound to the result of evaluating +@var{expr}, which should be a macro. Using @code{define} for this +purpose may not result in @var{name} being interpreted as a macro +keyword. +@end defspec + +An @dfn{environment} is a list of frames representing lexical bindings. +Only the names and scope of the bindings are included in environments +passed to macro expanders -- run-time values are not included. + +There are several types of environment frames: @table @code @item ((lambda (variable1 @dots{}) @dots{}) value1 @dots{}) @@ -3035,17 +3322,58 @@ environment frames: @itemx (letrec ((variable1 value1) @dots{}) @dots{}) result in a single enviroment frame: @example -((variable1 @dots{}) value1 @dots{}) + +(variable1 variable2 @dots{}) + @end example @item (let ((variable1 value1)) @dots{}) @itemx (let* ((variable1 value1) @dots{}) @dots{}) result in an environment frame for each variable: @example -(variable1 . value1) (variable2 . value2) @dots{} + +variable1 variable2 @dots{} + @end example + +@item (let-syntax ((key1 macro1) (key2 macro2)) @dots{}) +@itemx (letrec-syntax ((key1 value1) (key2 value2)) @dots{}) +Lexically bound macros result in environment frames consisting of +a marker and an alist of keywords and macro objects: +@example + +(<env-syntax-marker> (key1 . value1) (key2 . value2)) + +@end example +Currently <env-syntax-marker> is the integer 6. + +@item line numbers +Line numbers (@pxref{Line Numbers}) may be included in the environment +as frame entries to indicate the line number on which a function is +defined. They are ignored for variable lookup. +@example + +#<line 8> + +@end example + +@item miscellaneous +Debugging information is stored in environments in a plist format: Any +exact integer stored as an environment frame may be followed by any +value. The two frame entries are ignored when doing variable lookup. +Load file names, procedure names, and closure documentation strings +are stored in this format. +@example + +<env-filename-marker> "foo.scm" <env-procedure-name-marker> foo @dots{} + +@end example + +Currently <env-filename-marker> is the integer 1 and +<env-procedure-name-marker> the integer 2. + + @end table -@end defun @defspec @@apply procedure argument-list Returns the result of applying @var{procedure} to @var{argument-list}. @@ -3063,15 +3391,6 @@ Thus a mutable environment can be treated as both a list and local bindings. @end defspec -@defspec @@call-with-current-continuation procedure -Returns the result of applying @var{procedure} to the current -continuation. A @dfn{continuation} is a SCM object of type -@code{contin} (@pxref{Continuations}). The procedure -@code{(call-with-current-continuation @var{procedure})} is defined to -have the same effect as @code{(@@call-with-current-continuation -procedure)}. -@end defspec - @node Syntactic Hooks for Hygienic Macros, , Low Level Syntactic Hooks, The Language @section Syntactic Hooks for Hygienic Macros @@ -3124,7 +3443,8 @@ Returns the symbol obtained by recursively extracting the parent of If an identifier returned by this version of @code{gentemp} is inserted in a binding position as the name of a variable then it is guaranteed -that no other identifier may denote that variable. If an identifier +that no other identifier (except one produced by passing the first to +@code{renamed-identifier}) may denote that variable. If an identifier returned by @code{gentemp} is inserted free, then it will denote the top-level value bound to its parent, the symbol named ``An unlikely variable''. This behavior, of course, is meant to be put to good use: @@ -3155,17 +3475,10 @@ be restricted to the lexical scope of its environment. There is another restriction imposed for implementation convenience: Macros passing their lexical environments to @code{renamed-identifier} -may be lexically bound only by the special forms @code{@@let-syntax} or -@code{@@letrec-syntax}. No error is signaled if this restriction is not +may be lexically bound only by the special forms @code{let-syntax} or +@code{letrec-syntax}. No error is signaled if this restriction is not met, but synthetic identifier lookup will not work properly. -@defspec @@let-syntax -@defspecx @@letrec-syntax -Behave as @code{let} and @code{letrec}, but may also put extra -information in the lexical environment so that @code{renamed-identifier} -will work properly during expansion of the macros bound by these forms. -@end defspec - In order to maintain referential transparency it is necessary to determine whether two identifiers have the same denotation. With synthetic identifiers it is not necessary that two identifiers be @@ -3174,8 +3487,8 @@ synthetic identifiers it is not necessary that two identifiers be @defun identifier-equal? id1 id2 env Returns @code{#t} if identifiers @var{id1} and @var{id2} denote the same binding in lexical environment @var{env}, and @code{#f} otherwise. -@var{env} must be a lexical environment passed to a macro transformer -during macro expansion. +@var{env} must either be a lexical environment passed to a macro transformer +during macro expansion or the empty list. For example, @lisp @@ -3240,7 +3553,7 @@ proposed by W. Clinger [Exrename] is supported. Syntax may be defined in @code{define-syntax}, @code{let-syntax}, and @code{letrec-syntax} using @code{renaming-transformer} instead of @code{syntax-rules}. @var{proc} should evaluate to a procedure accepting three arguments: -@var{expr}, @var{rename}, and @var{compare}. @var{expr} is a +@var{expr}, @var{rename}, and @var{compare}. @var{expr} is a representation of Scheme code to be expanded, as list structure. @var{rename} is a procedure accepting an identifier and returning an identifier renamed in the definition environment of the new syntax. @@ -3252,72 +3565,47 @@ both denote the same binding in the usage environment of the new syntax. @chapter Packages @menu -* Compiling And Linking:: Hobbit * Dynamic Linking:: * Dump:: Create Fast-Booting Executables * Numeric:: Numeric Language Extensions * Arrays:: As in APL +* Records:: Define new aggregate data types * I/O-Extensions:: i/o-extensions * Posix Extensions:: posix +* Unix Extensions:: non-posix unix * Regular Expression Pattern Matching:: regex * Line Editing:: edit-line * Curses:: Screen Control * Sockets:: Cruise the Net @end menu +@cindex Xlib +@cindex Xlibscm +@cindex xlib +@cindex xlibscm +@cindex x +@cindex X +@cindex graphics +@cindex hobbit @menu * Xlib: (Xlibscm). X Window Graphics. +* Hobbit: (hobbit). Scheme-to-C Compiler. @end menu -@node Compiling And Linking, Dynamic Linking, Packages, Packages -@section Compiling And Linking - -@defun compile-file name1 name2 @dots{} -If the HOBBIT compiler is installed in the -@code{(implementation-vicinity)}, compiles the files @var{name1} -@var{name2} @dots{} to an object file name @var{name1}<object-suffix>, -where <object-suffix> is the object file suffix for your computer (for -instance, @file{.o}). @var{name1} must be in the current directory; -@var{name2} @dots{} can be in other directories. -@end defun +@iftex +@section hobbit -@defun link-named-scm name module1 @dots{} -Creates a new SCM executable with name @var{name}. @var{name} will -include the object modules @var{module1} @dots{} which can be produced -with @code{compile-file}. +@ifset html +<A HREF="hobbit_toc.html"> +@code{(require 'compile)} -@example -cd ~/scm/ -scm -e'(link-named-scm"cute""cube")' -(delete-file "scmflags.h") -(call-with-output-file - "scmflags.h" - (lambda (fp) - (for-each - (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"/home/jaffer/scm/Init@value{SCMVERSION}.scm\"" - "#define COMPILED_INITS init_cube();" - "#define BIGNUMS" - "#define FLOATS" - "#define ARRAYS")))) -(system "gcc -Wall -O2 -c continue.c findexec.c time.c - repl.c scl.c eval.c sys.c subr.c unif.c rope.c scm.c") -@dots{} -scm.c: In function `scm_init_extensions': -scm.c:95: warning: implicit declaration of function `init_cube' -scm.c: In function `scm_cat_path': -scm.c:589: warning: implicit declaration of function `realloc' -scm.c:594: warning: implicit declaration of function `malloc' -scm.c: In function `scm_try_path': -scm.c:612: warning: implicit declaration of function `free' -(system "cc -o cute continue.o findexec.o time.o repl.o scl.o - eval.o sys.o subr.o unif.o rope.o scm.o cube.o -lm -lc") - -Compilation finished at Sun Jul 21 00:59:17 -@end example -@end defun +@dfn{hobbit} +</A> +is a SCM->C compiler. +@end ifset +@end iftex -@node Dynamic Linking, Dump, Compiling And Linking, Packages +@node Dynamic Linking, Dump, Packages, Packages @section Dynamic Linking @noindent @@ -3492,10 +3780,12 @@ dump is the last expression in that file. @item Calls @code{gc}. @item +@findex boot-tail Creates an executable program named @var{newpath} which continues the state of the current SCM session when invoked. The optional argument -@var{thunk}, if provided, should be a procedure of no arguments. This -procedure will be called in the restored executable. +@var{thunk}, if provided, should be a procedure of no arguments; +@var{boot-tail} will be set to this procedure, causing it to be called +in the restored executable. If the optional argument is missing or a boolean, SCM's standard command line processing will be called in the restored executable. @@ -3527,10 +3817,6 @@ arguments for the curent invocation. More specifically, from the dumping session. Command line processing is done on the value of the identifier @code{*argv*}. -The thunk @code{boot-tail} is called by SCM to process command line -arguments. @code{dump} sets @code{boot-tail} to the @var{thunk} it is -called with. - The following example shows how to create @samp{rscm}, which is like regular scm, but which loads faster and has the @samp{random} package alreadly provided. @@ -3574,10 +3860,23 @@ The immediate integer closest to positive infinity. The immediate integer closest to negative infinity. @end defvr +@defvr Constant $pi +@defvrx Constant pi +The ratio of the circumference to the diameter of a circle. +@end defvr + @noindent These procedures augment the standard capabilities in @ref{Numerical operations, , ,r5rs, Revised(5) Scheme}. +@defun pi* z +@code{(* pi @var{z})} +@end defun + +@defun pi/ z +@code{(/ pi @var{z})} +@end defun + @defun sinh z @defunx cosh z @defunx tanh z @@ -3627,7 +3926,7 @@ an error if the value which should be returned by a call to @code{$expt} is not real. @end defun -@node Arrays, I/O-Extensions, Numeric, Packages +@node Arrays, Records, Numeric, Packages @section Arrays @menu @@ -3765,7 +4064,7 @@ Returns a list of inclusive bounds of integers. @defun array-dimensions array @code{Array-dimensions} is similar to @code{array-shape} but replaces -elements with a @code{0} minimum with one greater than the maximum. So: +elements with a @code{0} minimum with one greater than the maximum. So: @example (array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5) @end example @@ -3811,7 +4110,7 @@ If @var{array} may be @dfn{unrolled} into a one dimensional shared array without changing their order (last subscript changing fastest), then @code{array-contents} returns that shared array, otherwise it returns @code{#f}. All arrays made by @var{make-array} and -@var{make-uniform-array} may be unrolled, some arrays made by +@var{create-array} may be unrolled, some arrays made by @var{make-shared-array} may not be. If the optional argument @var{strict} is provided, a shared array will @@ -3864,7 +4163,7 @@ One can implement @var{array-indexes} as Another example: @example (define (apl:index-generator n) - (let ((v (make-uniform-vector n 1))) + (let ((v (make-vector n 1))) (array-index-map! v (lambda (i) i)) v)) @end example @@ -3880,6 +4179,7 @@ a conventional array if it is not. This function is used internally by @code{array-map!} and friends to handle scalar arguments. @end defun + @node Uniform Array, Bit Vectors, Array Mapping, Arrays @subsection Uniform Array @@ -3889,28 +4189,14 @@ the same type. Uniform vectors occupy less storage than conventional vectors. Uniform Array procedures also work on vectors, uniform-vectors, bit-vectors, and strings. -@noindent -@var{prototype} arguments in the following procedures are interpreted -according to the table: - -@example -prototype type display prefix - -#t boolean (bit-vector) #At -#\a char (string) #A\ -integer >0 unsigned integer #Au -integer <0 signed integer #Ae -1.0 float (single precision) #Aif -1/3 double (double precision float) #Aid -+i complex (double precision) #Aic -() conventional vector #A -@end example +SLIB now supports uniform arrys. The primary array creation procedure +is @code{create-array}, detailed in @xref{Arrays, , , slib, SLIB}. @noindent Unshared uniform character 0-based arrays of rank 1 (dimension) are equivalent to (and can't be distinguished from) strings. @example -(make-uniform-array #\a 3) @result{} "$q2" +(create-array "" 3) @result{} "$q2" @end example @noindent @@ -3918,7 +4204,7 @@ Unshared uniform boolean 0-based arrays of rank 1 (dimension) are equivalent to (and can't be distinguished from) @ref{Bit Vectors, bit-vectors}. @example -(make-uniform-array #t 3) @result{} #*000 +(create-array '#at() 3) @result{} #*000 @equiv{} #At(#f #f #f) @result{} #*000 @equiv{} @@ -3926,39 +4212,41 @@ bit-vectors}. @end example @noindent -Other uniform vectors are written in a form similar to that of general -arrays, except that one or more modifying characters are put between -the #\A character and the contents list. For example, @code{'#Ae(3 5 9)} -returns a uniform vector of signed integers. +@var{prototype} arguments in the following procedures are interpreted +according to the table: -@defun uniform-vector-ref uve index -Returns the element at the @var{index} element in @var{uve}. -@end defun +@example +prototype type display prefix + +() conventional vector #a ++64i complex (double precision) #ac64 +64.0 double (double precision) #ar64 +32.0 float (single precision) #ar32 +32 unsigned integer (32-bit) #au32 +-32 signed integer (32-bit) #as32 +-16 signed integer (16-bit) #as16 +#\a char (string) #a\ +#t boolean (bit-vector) #at +@end example -@defun uniform-vector-set! uve index new-value -Sets the element at the @var{index} element in @var{uve} to -@var{new-value}. The value returned by @code{uniform-vector-set!} is -unspecified. -@end defun +@noindent +Other uniform vectors are written in a form similar to that of general +arrays, except that one or more modifying characters are put between the +#\A character and the contents list. For example, @code{'#As32(3 5 9)} +returns a uniform vector of signed integers. @defun array? obj prototype Returns @code{#t} if the @var{obj} is an array of type corresponding to @var{prototype}, and @code{#f} if not. @end defun -@defun make-uniform-array prototype bound1 bound2 @dots{} -Creates and returns a uniform array of type corresponding to -@var{prototype} that has as many dimensions as there are @var{bound}s. -@end defun - @defun array-prototype array Returns an object that would produce an array of the same type as @var{array}, if used as the @var{prototype} for -@code{make-uniform-array}. +@code{list->uniform-array}. @end defun @defun list->uniform-array rank prot lst -@defunx list->uniform-vector prot lst Returns a uniform array of the type indicated by prototype @var{prot} with elements the same as those of @var{lst}. Elements must be of the appropriate type, no coercions are done. @@ -3977,14 +4265,8 @@ Stores @var{fill} in every element of @var{uve}. The value returned is unspecified. @end defun -@defun uniform-vector-length uve -Returns the number of elements in @var{uve}. -@end defun - @defun dimensions->uniform-array dims prototype fill @defunx dimensions->uniform-array dims prototype -@defunx make-uniform-vector length prototype fill -@defunx make-uniform-vector length prototype Creates and returns a uniform array or vector of type corresponding to @var{prototype} with dimensions @var{dims} or length @var{length}. If the @var{fill} argument is supplied, the returned array is filled with @@ -3993,8 +4275,6 @@ this value. @defun uniform-array-read! ura @defunx uniform-array-read! ura port -@defunx uniform-vector-read! uve -@defunx uniform-vector-read! uve port Attempts to read all elements of @var{ura}, in lexicographic order, as binary objects from @var{port}. If an end of file is encountered during uniform-array-read! the objects up to that point only are put into @var{ura} @@ -4008,10 +4288,8 @@ returned by @code{(current-input-port)}. @defun uniform-array-write ura @defunx uniform-array-write ura port -@defunx uniform-vector-write uve -@defunx uniform-vector-write uve port -Writes all elements of @var{ura} as binary objects to @var{port}. The -number of of objects actually written is returned. @var{port} may be +Writes all elements of @var{ura} as binary objects to @var{port}. The +number of of objects actually written is returned. @var{port} may be omitted, in which case it defaults to the value returned by @code{(current-output-port)}. @end defun @@ -4043,7 +4321,6 @@ if the array element is not an exact integer or if @var{val} is not boolean. @end defun - @node Bit Vectors, , Uniform Array, Arrays @subsection Bit Vectors @@ -4093,8 +4370,26 @@ Returns @var{bv} is not modified. @end defun +@node Records, I/O-Extensions, Arrays, Packages +@section Records + +SCM provides user-definable datatypes with the same interface as SLIB, +see @xref{Records, , , slib, SLIB}, with the following extension. + +@defun record-printer-set! rtd printer +Causes records of type @var{rtd} to be printed in a user-specified format. +@var{rtd} must be a record type descriptor returned by @code{make-record-type}, +@var{printer} a procedure accepting three arguments: the record to be printed, +the port to print to, and a boolean which is true if the record is being +written on behalf of @code{write} and false if for @code{display}. +If @var{printer} returns #f, the default record printer will be called. -@node I/O-Extensions, Posix Extensions, Arrays, Packages +A @var{printer} value of #f means use the default printer. + +Only the default printer will be used when printing error messages. +@end defun + +@node I/O-Extensions, Posix Extensions, Records, Packages @section I/O-Extensions @noindent @@ -4103,7 +4398,7 @@ If @code{'i/o-extensions} is provided (by linking in @file{ioext.o}), @defun stat <port-or-string> Returns a vector of integers describing the argument. The argument -can be either a string or an open input port. If the argument is an +can be either a string or an open input port. If the argument is an open port then the returned vector describes the file to which the port is opened; If the argument is a string then the returned vector describes the file named by that string. If there exists no file with @@ -4154,6 +4449,14 @@ written. If @var{port} is not open to a file the action of @code{file-set-position} is unspecified. @end defun +@defun try-create-file name modes perms +If the file with name @var{name} already exists, return @code{#f}, +otherwise try to create and open the file like @code{try-open-file}, +@xref{Files and Ports}. If the optional integer argument @var{perms} is +provided, it is used as the permissions of the new file (modified by +the current umask). +@end defun + @defun reopen-file filename modes port Closes port @var{port} and reopens it with @var{filename} and @var{modes}. @code{reopen-file} returns @code{#t} if successful, @@ -4333,7 +4636,7 @@ Like @code{execl} and @code{execlp} except that the set of arguments to @end defun @defun putenv string -adds or removes definitions from the @dfn{environment}. If the +adds or removes definitions from the @dfn{environment}. If the @var{string} is of the form @samp{NAME=VALUE}, the definition is added to the environment. Otherwise, the @var{string} is interpreted as the name of an environment variable, and any definition for this variable in @@ -4351,7 +4654,7 @@ To access environment variables, use @code{getenv} (@pxref{System Interface, getenv, , slib, SLIB}). @end defun -@node Posix Extensions, Regular Expression Pattern Matching, I/O-Extensions, Packages +@node Posix Extensions, Unix Extensions, I/O-Extensions, Packages @section Posix Extensions @noindent @@ -4379,6 +4682,15 @@ the standard input of the system command @var{string}. If a pipe cannot be created @code{#f} is returned. @end defun +@defun broken-pipe port +If this function is defined at top level, it will be called when an +output pipe is closed from the other side (this is the condition under +which a SIGPIPE is sent). The already closed @var{port} will be passed +so that any necessary cleanup may be done. An error is not signaled +when output to a pipe fails in this way, but any further output to +the closed pipe will cause an error to be signaled. +@end defun + @defun close-port pipe Closes the @var{pipe}, rendering it incapable of delivering or accepting characters. This routine has no effect if the pipe has already been @@ -4406,6 +4718,11 @@ Returns the process ID of the parent of the current process. For a process's own ID @xref{I/O-Extensions, getpid}. @end defun +@defun getlogin +Returns the (login) name of the user logged in on the controlling +terminal of the process, or #f if this information cannot be determined. +@end defun + @defun getuid Returns the real user ID of this process. @end defun @@ -4531,12 +4848,13 @@ stopped, and whose status has not been reported. Which means both of the above. @end enumerate -The return value is normally the process ID of the child process whose -status is reported. If the @code{WNOHANG} option was specified and no -child process is waiting to be noticed, the value is zero. A value of -@code{#f} is returned in case of error and @code{errno} is set. For -information about the @code{errno} codes @xref{Process Completion, , , -GNU C Library, libc}. +The return value normally is the exit status of the child process, +including the exit value along with flags indicating whether a coredump +was generated or the child terminated as a result of a signal. If the +@code{WNOHANG} option was specified and no child process is waiting to +be noticed, the value is zero. A value of @code{#f} is returned in case +of error and @code{errno} is set. For information about the +@code{errno} codes @xref{Process Completion, , , GNU C Library, libc}. @end defun @defun uname @@ -4653,6 +4971,7 @@ string containing the file name of termainal device; otherwise @code{#f}. @end defun +@node Unix Extensions, Regular Expression Pattern Matching, Posix Extensions, Packages @section Unix Extensions @noindent @@ -4660,7 +4979,7 @@ If @code{'unix} is provided (by linking in @file{unix.o}), the following functions are defined: @noindent -These @dfn{priveledged} and symbolic link functions are not in Posix: +These @dfn{privileged} and symbolic link functions are not in Posix: @defun symlink oldname newname The @code{symlink} function makes a symbolic link to @var{oldname} named @@ -4690,7 +5009,7 @@ Increment the priority of the current process by @var{increment}. @defun acct filename When called with the name of an exisitng file as argument, accounting is -turned on, records for each terminating pro-cess are appended to +turned on, records for each terminating process are appended to @var{filename} as it terminates. An argument of @code{#f} causes accounting to be turned off. @@ -4712,7 +5031,8 @@ sync() only schedules the writes, so it may return before the actual writing is done. The value returned is unspecified. @end defun -@node Regular Expression Pattern Matching, Line Editing, Posix Extensions, Packages + +@node Regular Expression Pattern Matching, Line Editing, Unix Extensions, Packages @section Regular Expression Pattern Matching These functions are defined in @file{rgx.c} using a POSIX or GNU @@ -4728,7 +5048,7 @@ expression, or an integer error code suitable as an argument to @code{regerror}. @var{flags} in @code{regcomp} is a string of option letters used to -control the compilation of the regular expression. The letters may +control the compilation of the regular expression. The letters may consist of: @table @samp @@ -4796,7 +5116,7 @@ a list of a string and a set of option letters. @item string The string to be operated upon. @item start -The character position at which to begin the search or match. If absent, +The character position at which to begin the search or match. If absent, the default is zero. @exdent @emph{Compiled _GNU_SOURCE and using GNU libregex only:} @@ -4807,7 +5127,7 @@ will be performed. @item len The search is allowed to examine only the first @var{len} characters of -@var{string}. If absent, the entire string may be examined. +@var{string}. If absent, the entire string may be examined. @end table @end defun @@ -4981,7 +5301,7 @@ terminal, it is also necessary to call @code{idlok}. @defun nodelay win bf This option causes wgetch to be a non-blocking call. If no input is -ready, wgetch will return an eof-object. If disabled, wgetch will hang +ready, wgetch will return an eof-object. If disabled, wgetch will hang until a key is pressed. @end defun @@ -5528,7 +5848,7 @@ successful. @defunx socket:bind unix-socket pathname Returns @var{inet-socket} bound to the integer @var{port-number} or the @var{unix-socket} bound to new socket in the file system at location -@var{pathname}. Returns @code{#f} if not successful. Binding a +@var{pathname}. Returns @code{#f} if not successful. Binding a @var{unix-socket} creates a socket in the file system that must be deleted by the caller when it is no longer needed (using @code{delete-file}). @@ -6011,6 +6331,10 @@ uniform vector of integers uniform vector of non-negative integers @end deftp +@deftp Header tc7_svect +uniform vector of short integers +@end deftp + @deftp Header tc7_fvect uniform vector of short inexact real numbers @end deftp @@ -6343,7 +6667,7 @@ bvect .........long length....G0010101 ..........long *words........... ivect .........long length....G0011101 ..........long *words........... uvect .........long length....G0011111 ......unsigned long *words...... spare G0100101 - spare G0100111 +svect .........long length....G0100111 ........ short *words........... fvect .........long length....G0101101 .........float *words........... dvect .........long length....G0101111 ........double *words........... cvect .........long length....G0110101 ........double *words........... @@ -6459,7 +6783,7 @@ unmarked, gc_mark sets the mark bit in @var{obj}, then calls @code{gc_mark()} is tail-called (looped). @end deftypefun -@deftypefun void mark_locations (STACKITEM @var{x[]}, sizet @var{len})) +@deftypefun void mark_locations (STACKITEM @var{x}[], sizet @var{len})) The function @code{mark_locations} is used for marking segments of C-stack or saved segments of C-stack (marked continuations). The argument @var{len} is the size of the stack in units of size @@ -6499,6 +6823,9 @@ object is freed. If the type header of smob is collected, the smob's @node Memory Management for Environments, Signals, Garbage Collection, Operations @subsection Memory Management for Environments +@cindex memory management +@cindex environments +@cindex ecache @itemize @bullet @item @dfn{Ecache} was designed and implemented by Radey Shouman. @@ -6592,6 +6919,7 @@ and swept almost like any ordinary segment of the general purpose heap. The only difference is that pairs from the copying heap that become free during a sweep phase are not added to the freelist. +@cindex NO_ENV_CACHE The environment cache is disabled by adding @code{#define NO_ENV_CACHE} to @file{eval.c}; all environment cells are then allocated from the regular heap. @@ -6958,9 +7286,10 @@ free0(ptr) is provided which does not free any storage and returns 0. is 0 or a function of 3 arguments. The first, of type @code{SCM}, is the smob object. The second, of type @code{SCM}, is the stream on which to write the result. The third, of type int, is 1 if the object should -be @code{write}n, 0 if it should be @code{display}ed. This function -should return non-zero if it printed, and zero otherwise (in which case -a hexadecimal number will be printed). +be @code{write}n, 0 if it should be @code{display}ed, and 2 if it should +be @code{write}n for an error report. This function should return non-zero +if it printed, and zero otherwise (in which case a hexadecimal number will +be printed). @item smob.equalp is 0 or a function of 2 @code{SCM} arguments. Both of these arguments will be of type @code{tc16@i{foo}}. This function should return @@ -7024,7 +7353,7 @@ The following functions are provided for that purpose: @deftypefunx {char *} must_malloc (long @var{len}, char *@var{what}) @var{len} is the number of bytes that should be allocated, @var{what} is a string to be used in error or gc messages. @code{must_malloc} returns -a pointer to newly allocated memory. @code{must_malloc_cell} returns a +a pointer to newly allocated memory. @code{must_malloc_cell} returns a newly allocated cell whose @code{car} is @var{c} and whose @code{cdr} is a pointer to newly allocated memory. @end deftypefun @@ -7039,7 +7368,7 @@ argument @var{where} the address of a block of memory of length @var{olen} allocated by @code{must_malloc} and returns the address of a block of length @var{len}. -The contents of the reallocated block will be unchanged up the the +The contents of the reallocated block will be unchanged up to the minimum of the old and new sizes. @var{what} is a pointer to a string used for error and gc messages. @@ -7047,7 +7376,9 @@ minimum of the old and new sizes. @code{must_malloc}, @code{must_malloc_cell}, @code{must_realloc}, and @code{must_realloc_cell} must be called with interrupts deferred -@xref{Signals}. +@xref{Signals}. @code{must_realloc} and @code{must_realloc_cell} must +not be called during initialization (non-zero errjmp_bad) -- the initial +allocations must be large enough. @deftypefun void must_free (char *@var{ptr}, sizet @var{len}) @code{must_free} is used to free a block of memory allocated by the @@ -7251,7 +7582,7 @@ int main(argc, argv) fprintf(stderr, "dld_find_executable(%s): %s\n", argv[0], execpath); implpath = find_impl_file(execpath, "scm", INIT_FILE_NAME, dirsep); fprintf(stderr, "implpath: %s\n", implpath); - scm_init_from_argv(argc, argv, 0, 0); + scm_init_from_argv(argc, argv, 0L, 0, 0); retval = scm_top_level(implpath, user_main); diff --git a/scm5d6.info b/scm5d6.info new file mode 100644 index 0000000..7dbf40d --- /dev/null +++ b/scm5d6.info @@ -0,0 +1,8382 @@ +This is scm.info, produced by makeinfo version 4.3 from scm.texi. + +INFO-DIR-SECTION The Algorithmic Language Scheme +START-INFO-DIR-ENTRY +* SCM: (scm). A Scheme interpreter. +END-INFO-DIR-ENTRY + + +File: scm.info, Node: Top, Next: Overview, Prev: (dir), Up: (dir) + +This manual documents the SCM Scheme implementation. SCM version +5d6 was released May 2002. The most recent information about SCM can +be found on SCM's "WWW" home page: + + <http://swissnet.ai.mit.edu/~jaffer/SCM.html> + +Copyright (C) 1990-1999 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation +approved by the author. + +* Menu: + +* Overview:: +* Installing SCM:: +* Operational Features:: +* The Language:: Reference. +* Packages:: Optional Capabilities. +* The Implementation:: How it works. +* Index:: + + +File: scm.info, Node: Overview, Next: Installing SCM, Prev: Top, Up: Top + +Overview +******** + +Scm is a portable Scheme implementation written in C. Scm provides a +machine independent platform for [JACAL], a symbolic algebra system. + +* Menu: + +* SCM Features:: +* SCM Authors:: +* Copying:: +* Bibliography:: + + +File: scm.info, Node: SCM Features, Next: SCM Authors, Prev: Overview, Up: Overview + +Features +======== + + * Conforms to Revised^5 Report on the Algorithmic Language Scheme + [R5RS] and the [IEEE] P1178 specification. + + * Support for [SICP], [R2RS], [R3RS], and [R5RS] scheme code. + + * Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, + VMS, Unix and similar systems. Supports ASCII and EBCDIC + character sets. + + * Is fully documented in TeXinfo form, allowing documentation to be + generated in info, TeX, html, nroff, and troff formats. + + * Supports inexact real and complex numbers, 30 bit immediate + integers and large precision integers. + + * Many Common Lisp functions: `logand', `logor', `logxor', `lognot', + `ash', `logcount', `integer-length', `bit-extract', `defmacro', + `macroexpand', `macroexpand1', `gentemp', `defvar', `force-output', + `software-type', `get-decoded-time', `get-internal-run-time', + `get-internal-real-time', `delete-file', `rename-file', + `copy-tree', `acons', and `eval'. + + * `Char-code-limit', `most-positive-fixnum', `most-negative-fixnum', + `and internal-time-units-per-second' constants. `*Features*' and + `*load-pathname*' variables. + + * Arrays and bit-vectors. String ports and software emulation ports. + I/O extensions providing ANSI C and POSIX.1 facilities. + + * Interfaces to standard libraries including REGEX string regular + expression matching and the CURSES screen management package. + + * Available add-on packages including an interactive debugger, + database, X-window graphics, BGI graphics, Motif, and Open-Windows + packages. + + * A compiler (HOBBIT, available separately) and dynamic linking of + compiled modules. + + * User definable responses to interrupts and errors, + Process-syncronization primitives. Setable levels of monitoring + and timing information printed interactively (the `verbose' + function). `Restart', `quit', and `exec'. + + +File: scm.info, Node: SCM Authors, Next: Copying, Prev: SCM Features, Up: Overview + +Authors +======= + +Aubrey Jaffer (jaffer @ alum.mit.edu) + Most of SCM. + +Radey Shouman + Arrays, `gsubr's, compiled closures, records, Ecache, syntax-rules + macros, and "safeport"s. + +Jerry D. Hedden + Real and Complex functions. Fast mixed type arithmetics. + +Hugh Secker-Walker + Syntax checking and memoization of special forms by evaluator. + Storage allocation strategy and parameters. + +George Carrette + "Siod", written by George Carrette, was the starting point for SCM. + The major innovations taken from Siod are the evaluator's use of + the C-stack and being able to garbage collect off the C-stack + (*note Garbage Collection::). + +There are many other contributors to SCM. They are acknowledged in the +file `ChangeLog', a log of changes that have been made to scm. + + +File: scm.info, Node: Copying, Next: Bibliography, Prev: SCM Authors, Up: Overview + +Copyright +========= + +Authors have assigned their SCM copyrights to: + + Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111, USA + +Permission to use, copy, modify, distribute, and sell this software and +its documentation for any purpose is hereby granted without fee, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation. + + NO WARRANTY + +BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR +THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER +EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE +ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH +YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL +NECESSARY SERVICING, REPAIR OR CORRECTION. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR +DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL +DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM +(INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED +INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF +THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR +OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + +SIOD copyright +============== + + + COPYRIGHT (c) 1989 BY + PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. + ALL RIGHTS RESERVED + +Permission to use, copy, modify, distribute and sell this software and +its documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation, and that the name of Paradigm Associates Inc +not be used in advertising or publicity pertaining to distribution of +the software without specific, written prior permission. + +PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, +INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO +EVENT SHALL PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR +CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF +USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. + +gjc@paradigm.com + Phone: 617-492-6079 + +Paradigm Associates Inc +29 Putnam Ave, Suite 6 +Cambridge, MA 02138 + + +File: scm.info, Node: Bibliography, Prev: Copying, Up: Overview + +Bibliography +============ + +[IEEE] + `IEEE Standard 1178-1990. IEEE Standard for the Scheme + Programming Language.' IEEE, New York, 1991. + +[R4RS] + William Clinger and Jonathan Rees, Editors. Revised(4) Report on + the Algorithmic Language Scheme. `ACM Lisp Pointers' Volume IV, + Number 3 (July-September 1991), pp. 1-55. + + *Note Top: (r4rs)Top. + +[R5RS] + Richard Kelsey and William Clinger and Jonathan (Rees, editors) + Revised(5) Report on the Algorithmic Language Scheme. + `Higher-Order and Symbolic Computation' Volume 11, Number 1 (1998), + pp. 7-105, and `ACM SIGPLAN Notices' 33(9), September 1998. + + *Note Top: (r5rs)Top. + +[Exrename] + William Clinger Hygienic Macros Through Explicit Renaming `Lisp + Pointers' Volume IV, Number 4 (December 1991), pp 17-23. + +[SICP] + Harold Abelson and Gerald Jay Sussman with Julie Sussman. + `Structure and Interpretation of Computer Programs.' MIT Press, + Cambridge, 1985. + +[Simply] + Brian Harvey and Matthew Wright. `Simply Scheme: Introducing + Computer Science' MIT Press, 1994 ISBN 0-262-08226-8 + +[SchemePrimer] + $B8$;tBg(B(Dai Inukai) `$BF~Lg(BScheme' + 1999$BG/(B12$B7n=iHG(B ISBN4-87966-954-7 + +[SLIB] + Todd R. Eigenschink, Dave Love, and Aubrey Jaffer. SLIB, The + Portable Scheme Library. Version 2c8, June 2000. + + *Note Top: (slib)Top. + +[JACAL] + Aubrey Jaffer. JACAL Symbolic Mathematics System. Version 1b0, + Sep 1999. + + *Note Top: (jacal)Top. + +`scm.texi' +`scm.info' + Documentation of `scm' extensions (beyond Scheme standards). + Documentation on the internal representation and how to extend or + include `scm' in other programs. + +`Xlibscm.texi' +`Xlibscm.info' + Documentation of the Xlib - SCM Language X Interface. + + +File: scm.info, Node: Installing SCM, Next: Operational Features, Prev: Overview, Up: Top + +Installing SCM +************** + +* Menu: + +* Making SCM:: Bootstrapping. +* SLIB:: REQUIREd reading. +* Building SCM:: +* Installing Dynamic Linking:: +* Configure Module Catalog:: +* Saving Images:: Make Fast-Booting Executables +* Automatic C Preprocessor Definitions:: +* Problems Compiling:: +* Problems Linking:: +* Problems Running:: +* Testing:: +* Reporting Problems:: + + +File: scm.info, Node: Making SCM, Next: SLIB, Prev: Installing SCM, Up: Installing SCM + +Making SCM +========== + +The SCM distribution has "Makefile" which contains rules for making +"scmlit", a "bare-bones" version of SCM sufficient for running `build'. +`build' is used to compile (or create scripts to compile) full +featured versions. + +Makefiles are not portable to the majority of platforms. If `Makefile' +works for you, good; If not, I don't want to hear about it. If you +need to compile SCM without build, there are several ways to proceed: + + * Use the build (http://swissnet.ai.mit.edu/~jaffer/buildscm.html) + web page to create custom batch scripts for compiling SCM. + + * Use SCM on a different platform to run `build' to create a script + to build SCM; + + * Use another implementation of Scheme to run `build' to create a + script to build SCM; + + * Create your own script or `Makefile'. + + +File: scm.info, Node: SLIB, Next: Building SCM, Prev: Making SCM, Up: Installing SCM + +SLIB +==== + +[SLIB] is a portable Scheme library meant to provide compatibility and +utility functions for all standard Scheme implementations. Although +SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and +install it. Bug reports about running SCM without SLIB have very low +priority. SLIB is available from the same sites as SCM: + + * swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz + + * ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz + + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz + +Unpack SLIB (`tar xzf slib2d4.tar.gz' or `unzip -ao slib2d4.zip') in an +appropriate directory for your system; both `tar' and `unzip' will +create the directory `slib'. + +Then create a file `require.scm' in the SCM "implementation-vicinity" +(this is the same directory as where the file `Init5d6.scm' is +installed). `require.scm' should have the contents: + + (define (library-vicinity) "/usr/local/lib/slib/") + (load (in-vicinity (library-vicinity) "require")) + +where the pathname string `/usr/local/lib/slib/' is to be replaced by +the pathname into which you installed SLIB. Absolute pathnames are +recommended here; if you use a relative pathname, SLIB can get confused +when the working directory is changed (*note chmod: I/O-Extensions.). +The way to specify a relative pathname is to append it to the +implementation-vicinity, which is absolute: + + (define library-vicinity + (let ((lv (string-append (implementation-vicinity) "../slib/"))) + (lambda () lv))) + (load (in-vicinity (library-vicinity) "require")) + +Alternatively, you can set the (shell) environment variable +`SCHEME_LIBRARY_PATH' to the pathname of the SLIB directory (*note +SCHEME_LIBRARY_PATH: SCM Variables.). If set, the environment variable +overrides `require.scm'. Again, absolute pathnames are recommended. + + +File: scm.info, Node: Building SCM, Next: Installing Dynamic Linking, Prev: SLIB, Up: Installing SCM + +Building SCM +============ + +The file "build" loads the file "build.scm", which constructs a +relational database of how to compile and link SCM executables. +`build.scm' has information for the platforms which SCM has been ported +to (of which I have been notified). Some of this information is old, +incorrect, or incomplete. Send corrections and additions to jaffer @ +ai.mit.edu. + +* Menu: + +* Invoking Build:: +* Build Options:: +* Compiling and Linking Custom Files:: + + +File: scm.info, Node: Invoking Build, Next: Build Options, Prev: Building SCM, Up: Building SCM + +Invoking Build +-------------- + +The _all_ method will also work for MS-DOS and unix. Use the _all_ +method if you encounter problems with `build'. + +MS-DOS + From the SCM source directory, type `build' followed by up to 9 + command line arguments. + +unix + From the SCM source directory, type `./build' followed by command + line arguments. + +_all_ + From the SCM source directory, start `scm' or `scmlit' and type + `(load "build")'. Alternatively, start `scm' or `scmlit' with the + command line argument `-ilbuild'. + +Invoking build without the `-F' option will build or create a shell +script with the `arrays', `inexact', and `bignums' options as defaults. + + bash$ ./build + -| + #! /bin/sh + # unix (linux) script created by SLIB/batch + # ================ Write file with C defines + rm -f scmflags.h + echo '#define IMPLINIT "Init5d6.scm"'>>scmflags.h + echo '#define BIGNUMS'>>scmflags.h + echo '#define FLOATS'>>scmflags.h + echo '#define ARRAYS'>>scmflags.h + # ================ Compile C source files + gcc -O2 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c + # ================ Link C object files + gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc + +To cross compile for another platform, invoke build with the `-p' or +`--platform=' option. This will create a script for the platform named +in the `-p' or `--platform=' option. + + bash$ ./build -o scmlit -p darwin -F lit + -| + #! /bin/sh + # unix (darwin) script created by SLIB/batch + # ================ Write file with C defines + rm -f scmflags.h + echo '#define IMPLINIT "Init5d6.scm"'>>scmflags.h + # ================ Compile C source files + cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c + # ================ Link C object files + mv -f scmlit scmlit~ + cc -o scmlit continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o + + +File: scm.info, Node: Build Options, Next: Compiling and Linking Custom Files, Prev: Invoking Build, Up: Building SCM + +Build Options +------------- + +The options to "build" specify what, where, and how to build a SCM +program or dynamically linked module. These options are unrelated to +the SCM command line options. + + - Build Option: -p PLATFORM-NAME + - Build Option: --platform=PLATFORM-NAME + specifies that the compilation should be for a + computer/operating-system combination called PLATFORM-NAME. + _Note:_ The case of PLATFORM-NAME is distinguised. The current + PLATFORM-NAMEs are all lower-case. + + The platforms defined by table "platform" in `build.scm' are: + + Table: platform + name processor operating-system compiler + #f processor-family operating-system #f + symbol processor-family operating-system symbol + symbol atom symbol symbol + ================= ================= ================= ================= + *unknown* *unknown* unix cc + acorn-unixlib acorn *unknown* cc + aix powerpc aix cc + alpha alpha osf1 cc + alpha-elf alpha unix cc + alpha-linux alpha linux gcc + amiga-aztec m68000 amiga cc + amiga-dice-c m68000 amiga dcc + amiga-gcc m68000 amiga gcc + amiga-sas m68000 amiga lc + atari-st-gcc m68000 atari.st gcc + atari-st-turbo-c m68000 atari.st tcc + borland-c 8086 ms-dos bcc + cygwin32 i386 unix gcc + darwin powerpc unix cc + djgpp i386 ms-dos gcc + freebsd i386 unix cc + gcc *unknown* unix gcc + highc i386 ms-dos hc386 + hp-ux hp-risc hp-ux cc + irix mips irix gcc + linux i386 linux gcc + linux-aout i386 linux gcc + microsoft-c 8086 ms-dos cl + microsoft-c-nt i386 ms-dos cl + microsoft-quick-c 8086 ms-dos qcl + ms-dos 8086 ms-dos cc + openbsd *unknown* unix gcc + os/2-cset i386 os/2 icc + os/2-emx i386 os/2 gcc + sunos sparc sunos cc + svr4 *unknown* unix cc + svr4-gcc-sun-ld sparc sunos gcc + turbo-c 8086 ms-dos tcc + unicos cray unicos cc + unix *unknown* unix cc + vms vax vms cc + vms-gcc vax vms gcc + watcom-9.0 i386 ms-dos wcc386p + + - Build Option: -o FILENAME + - Build Option: --outname=FILENAME + specifies that the compilation should produce an executable or + object name of FILENAME. The default is `scm'. Executable + suffixes will be added if neccessary, e.g. `scm' => `scm.exe'. + + - Build Option: -l LIBNAME ... + - Build Option: --libraries=LIBNAME + specifies that the LIBNAME should be linked with the executable + produced. If compile flags or include directories (`-I') are + needed, they are automatically supplied for compilations. The `c' + library is always included. SCM "features" specify any libraries + they need; so you shouldn't need this option often. + + - Build Option: -D DEFINITION ... + - Build Option: --defines=DEFINITION + specifies that the DEFINITION should be made in any C source + compilations. If compile flags or include directories (`-I') are + needed, they are automatically supplied for compilations. SCM + "features" specify any flags they need; so you shouldn't need this + option often. + + - Build Option: --compiler-options=FLAG + specifies that that FLAG will be put on compiler command-lines. + + - Build Option: --linker-options=FLAG + specifies that that FLAG will be put on linker command-lines. + + - Build Option: -s PATHNAME + - Build Option: --scheme-initial=PATHNAME + specifies that PATHNAME should be the default location of the SCM + initialization file `Init5d6.scm'. SCM tries several likely + locations before resorting to PATHNAME (*note File-System + Habitat::). If not specified, the current directory (where build + is building) is used. + + - Build Option: -c PATHNAME ... + - Build Option: --c-source-files=PATHNAME + specifies that the C source files PATHNAME ... are to be compiled. + + - Build Option: -j PATHNAME ... + - Build Option: --object-files=PATHNAME + specifies that the object files PATHNAME ... are to be linked. + + - Build Option: -i CALL ... + - Build Option: --initialization=CALL + specifies that the C functions CALL ... are to be invoked during + initialization. + + - Build Option: -t BUILD-WHAT + - Build Option: --type=BUILD-WHAT + specifies in general terms what sort of thing to build. The + choices are: + `exe' + executable program. + + `lib' + library module. + + `dlls' + archived dynamically linked library object files. + + `dll' + dynamically linked library object file. + + The default is to build an executable. + + - Build Option: -h BATCH-SYNTAX + - Build Option: -batch-dialect=BATCH-SYNTAX + specifies how to build. The default is to create a batch file for + the host system. The SLIB file `batch.scm' knows how to create + batch files for: + * unix + + * dos + + * vms + + * amigaos (was amigados) + + * system + + This option executes the compilation and linking commands + through the use of the `system' procedure. + + * *unknown* + + This option outputs Scheme code. + + - Build Option: -w BATCH-FILENAME + - Build Option: -script-name=BATCH-FILENAME + specifies where to write the build script. The default is to + display it on `(current-output-port)'. + + - Build Option: -F FEATURE ... + - Build Option: --features=FEATURE + specifies to build the given features into the executable. The + defined features are: + + "array" + Alias for ARRAYS + + "array-for-each" + array-map! and array-for-each (arrays must also be featured). + + "arrays" + Use if you want arrays, uniform-arrays and uniform-vectors. + + "bignums" + Large precision integers. + + "careful-interrupt-masking" + Define this for extra checking of interrupt masking and some + simple checks for proper use of malloc and free. This is for + debugging C code in `sys.c', `eval.c', `repl.c' and makes the + interpreter several times slower than usual. + + "cautious" + Normally, the number of arguments arguments to interpreted + closures (from LAMBDA) are checked if the function part of a + form is not a symbol or only the first time the form is + executed if the function part is a symbol. defining + `reckless' disables any checking. If you want to have SCM + always check the number of arguments to interpreted closures + define feature `cautious'. + + "cheap-continuations" + If you only need straight stack continuations, executables + compile with this feature will run faster and use less + storage than not having it. Machines with unusual stacks + _need_ this. Also, if you incorporate new C code into scm + which uses VMS system services or library routines (which + need to unwind the stack in an ordrly manner) you may need to + use this feature. + + "compiled-closure" + Use if you want to use compiled closures. + + "curses" + For the "curses" screen management package. + + "debug" + Turns on the features `cautious', + `careful-interrupt-masking', and `stack-limit'; uses `-g' + flags for debugging SCM source code. + + "dump" + Convert a running scheme program into an executable file. + + "dynamic-linking" + Be able to load compiled files while running. + + "edit-line" + interface to the editline or GNU readline library. + + "engineering-notation" + Use if you want floats to display in engineering notation + (exponents always multiples of 3) instead of scientific + notation. + + "generalized-c-arguments" + `make_gsubr' for arbitrary (< 11) arguments to C functions. + + "i/o-extensions" + Commonly available I/O extensions: "exec", line I/O, file + positioning, file delete and rename, and directory functions. + + "inexact" + Use if you want floating point numbers. + + "lit" + Lightweight - no features + + "macro" + C level support for hygienic and referentially transparent + macros (syntax-rules macros). + + "mysql" + Client connections to the mysql databases. + + "no-heap-shrink" + Use if you want segments of unused heap to not be freed up + after garbage collection. This may increase time in GC for + *very* large working sets. + + "none" + No features + + "posix" + Posix functions available on all "Unix-like" systems. fork + and process functions, user and group IDs, file permissions, + and "link". + + "reckless" + If your scheme code runs without any errors you can disable + almost all error checking by compiling all files with + `reckless'. + + "record" + The Record package provides a facility for user to define + their own record data types. See SLIB for documentation. + + "regex" + String regular expression matching. + + "rev2-procedures" + These procedures were specified in the `Revised^2 Report on + Scheme' but not in `R4RS'. + + "sicp" + Use if you want to run code from: + + Harold Abelson and Gerald Jay Sussman with Julie Sussman. + `Structure and Interpretation of Computer Programs.' The MIT + Press, Cambridge, Massachusetts, USA, 1985. + + Differences from R5RS are: + * (eq? '() '#f) + + * (define a 25) returns the symbol a. + + * (set! a 36) returns 36. + + "single-precision-only" + Use if you want all inexact real numbers to be single + precision. This only has an effect if SINGLES is also + defined (which is the default). This does not affect complex + numbers. + + "socket" + BSD "socket" interface. + + "stack-limit" + Use to enable checking for stack overflow. Define value of + the C preprocessor variable STACK_LIMIT to be the size to + which SCM should allow the stack to grow. STACK_LIMIT should + be less than the maximum size the hardware can support, as + not every routine checks the stack. + + "tick-interrupts" + Use if you want the ticks and ticks-interrupt functions. + + "turtlegr" + "Turtle" graphics calls for both Borland-C and X11 from + sjm@ee.tut.fi. + + "unix" + Those unix features which have not made it into the Posix + specs: nice, acct, lstat, readlink, symlink, mknod and sync. + + "windows" + Microsoft Windows executable. + + "x" + Alias for Xlib feature. + + "xlib" + Interface to Xlib graphics routines. + + + +File: scm.info, Node: Compiling and Linking Custom Files, Prev: Build Options, Up: Building SCM + +Compiling and Linking Custom Files +---------------------------------- + +A correspondent asks: + + How can we link in our own c files to the SCM interpreter so that + we can add our own functionality? (e.g. we have a bunch of tcp + functions we want access to). Would this involve changing + build.scm or the Makefile or both? + +(*note Changing Scm:: has instructions describing the C code format). +Suppose a C file "foo.c" has functions you wish to add to SCM. To +compile and link your file at compile time, use the `-c' and `-i' +options to build: + + bash$ build -c foo.c -i init_foo + -| + #! /bin/sh + rm -f scmflags.h + echo '#define IMPLINIT "/home/jaffer/scm/Init5d6.scm"'>>scmflags.h + echo '#define COMPILED_INITS init_foo();'>>scmflags.h + echo '#define BIGNUMS'>>scmflags.h + echo '#define FLOATS'>>scmflags.h + echo '#define ARRAYS'>>scmflags.h + gcc -O2 -c continue.c scm.c findexec.c script.c time.c repl.c scl.c \ + eval.c sys.c subr.c unif.c rope.c foo.c + gcc -rdynamic -o scm continue.o scm.o findexec.o script.o time.o \ + repl.o scl.o eval.o sys.o subr.o unif.o rope.o foo.o -lm -lc + +To make a dynamically loadable object file use the `-t dll' option: + + bash$ build -t dll -c foo.c + -| + #! /bin/sh + rm -f scmflags.h + echo '#define IMPLINIT "/home/jaffer/scm/Init5d6.scm"'>>scmflags.h + echo '#define BIGNUMS'>>scmflags.h + echo '#define FLOATS'>>scmflags.h + echo '#define ARRAYS'>>scmflags.h + echo '#define DLL'>>scmflags.h + gcc -O2 -fpic -c foo.c + gcc -shared -o foo.so foo.o -lm -lc + +Once `foo.c' compiles correctly (and your SCM build supports +dynamic-loading), you can load the compiled file with the Scheme command +`(load "./foo.so")'. See *Note Configure Module Catalog:: for how to +add a compiled dll file to SLIB's catalog. + + +File: scm.info, Node: Installing Dynamic Linking, Next: Configure Module Catalog, Prev: Building SCM, Up: Installing SCM + +Installing Dynamic Linking +========================== + +Dynamic linking has not been ported to all platforms. Operating systems +in the BSD family (a.out binary format) can usually be ported to "DLD". +The "dl" library (`#define SUN_DL' for SCM) was a proposed POSIX +standard and may be available on other machines with "COFF" binary +format. For notes about porting to MS-Windows and finishing the port +to VMS *Note Finishing Dynamic Linking::. + +"DLD" is a library package of C functions that performs "dynamic link +editing" on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), +SPARCstation (SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST. It is +available from: + + * ftp.gnu.org:pub/gnu/dld-3.3.tar.gz + +These notes about using libdl on SunOS are from `gcc.info': + + On a Sun, linking using GNU CC fails to find a shared library and + reports that the library doesn't exist at all. + + This happens if you are using the GNU linker, because it does only + static linking and looks only for unshared libraries. If you have + a shared library with no unshared counterpart, the GNU linker + won't find anything. + + We hope to make a linker which supports Sun shared libraries, but + please don't ask when it will be finished-we don't know. + + Sun forgot to include a static version of `libdl.a' with some + versions of SunOS (mainly 4.1). This results in undefined symbols + when linking static binaries (that is, if you use `-static'). If + you see undefined symbols `_dlclose', `_dlsym' or `_dlopen' when + linking, compile and link against the file `mit/util/misc/dlsym.c' + from the MIT version of X windows. + + +File: scm.info, Node: Configure Module Catalog, Next: Saving Images, Prev: Installing Dynamic Linking, Up: Installing SCM + +Configure Module Catalog +======================== + +The SLIB module "catalog" can be extended to define other +`require'-able packages by adding calls to the Scheme source file +`mkimpcat.scm'. Within `mkimpcat.scm', the following procedures are +defined. + + - Function: add-link feature object-file lib1 ... + FEATURE should be a symbol. OBJECT-FILE should be a string naming + a file containing compiled "object-code". Each LIBn argument + should be either a string naming a library file or `#f'. + + If OBJECT-FILE exists, the `add-link' procedure registers symbol + FEATURE so that the first time `require' is called with the symbol + FEATURE as its argument, OBJECT-FILE and the LIB1 ... are + dynamically linked into the executing SCM session. + + If OBJECT-FILE exists, `add-link' returns `#t', otherwise it + returns `#f'. + + For example, to install a compiled dll `foo', add these lines to + `mkimpcat.scm': + + (add-link 'foo + (in-vicinity (implementation-vicinity) "foo" + link:able-suffix)) + + + - Function: add-alias alias feature + ALIAS and FEATURE are symbols. The procedure `add-alias' + registers ALIAS as an alias for FEATURE. An unspecified value is + returned. + + `add-alias' causes `(require 'ALIAS)' to behave like `(require + 'FEATURE)'. + + - Function: add-source feature filename + FEATURE is a symbol. FILENAME is a string naming a file + containing Scheme source code. The procedure `add-source' + registers FEATURE so that the first time `require' is called with + the symbol FEATURE as its argument, the file FILENAME will be + `load'ed. An unspecified value is returned. + +Remember to delete the file `slibcat' after modifying the file +`mkimpcat.scm' in order to force SLIB to rebuild its cache. + + +File: scm.info, Node: Saving Images, Next: Automatic C Preprocessor Definitions, Prev: Configure Module Catalog, Up: Installing SCM + +Saving Images +============= + +In SCM, the ability to save running program images is called "dump" +(*note Dump::). In order to make `dump' available to SCM, build with +feature `dump'. `dump'ed executables are compatible with dynamic +linking. + +Most of the code for "dump" is taken from `emacs-19.34/src/unex*.c'. +No modifications to the emacs source code were required to use +`unexelf.c'. Dump has not been ported to all platforms. If `unexec.c' +or `unexelf.c' don't work for you, try using the appropriate `unex*.c' +file from emacs. + + +File: scm.info, Node: Automatic C Preprocessor Definitions, Next: Problems Compiling, Prev: Saving Images, Up: Installing SCM + +Automatic C Preprocessor Definitions +==================================== + +These `#defines' are automatically provided by preprocessors of various +C compilers. SCM uses the presence or absence of these definitions to +configure "include file" locations and aliases for library functions. +If the definition(s) corresponding to your system type is missing as +your system is configured, add `-DFLAG' to the compilation command +lines or add a `#define FLAG' line to `scmfig.h' or the beginning of +`scmfig.h'. + + #define Platforms: + ------- ---------- + ARM_ULIB Huw Rogers free unix library for acorn archimedes + AZTEC_C Aztec_C 5.2a + __CYGWIN__ Cygwin + _DCC Dice C on AMIGA + __GNUC__ Gnu CC (and DJGPP) + __EMX__ Gnu C port (gcc/emx 0.8e) to OS/2 2.0 + __HIGHC__ MetaWare High C + __IBMC__ C-Set++ on OS/2 2.1 + _MSC_VER MS VisualC++ 4.2 + MWC Mark Williams C on COHERENT + __MWERKS__ Metrowerks Compiler; Macintosh and WIN32 (?) + _POSIX_SOURCE ?? + _QC Microsoft QuickC + __STDC__ ANSI C compliant + __TURBOC__ Turbo C and Borland C + __USE_POSIX ?? + __WATCOMC__ Watcom C on MS-DOS + __ZTC__ Zortech C + + _AIX AIX operating system + __APPLE__ Apple Darwin + AMIGA SAS/C 5.10 or Dice C on AMIGA + __amigaos__ Gnu CC on AMIGA + atarist ATARI-ST under Gnu CC + __FreeBSD__ FreeBSD + GNUDOS DJGPP (obsolete in version 1.08) + __GO32__ DJGPP (future?) + hpux HP-UX + linux Linux + macintosh Macintosh (THINK_C and __MWERKS__ define) + MCH_AMIGA Aztec_c 5.2a on AMIGA + __MACH__ Apple Darwin + MSDOS Microsoft C 5.10 and 6.00A + __MSDOS__ Turbo C, Borland C, and DJGPP + nosve Control Data NOS/VE + SVR2 System V Revision 2. + __SVR4 SunOS + THINK_C developement environment for the Macintosh + ultrix VAX with ULTRIX operating system. + unix most Unix and similar systems and DJGPP (!?) + __unix__ Gnu CC and DJGPP + _UNICOS Cray operating system + vaxc VAX C compiler + VAXC VAX C compiler + vax11c VAX C compiler + VAX11 VAX C compiler + _Windows Borland C 3.1 compiling for Windows + _WIN32 MS VisualC++ 4.2 and Cygwin (Win32 API) + vms (and VMS) VAX-11 C under VMS. + + __alpha DEC Alpha processor + __alpha__ DEC Alpha processor + hp9000s800 HP RISC processor + __i386__ DJGPP + i386 DJGPP + MULTIMAX Encore computer + ppc PowerPC + __ppc__ PowerPC + pyr Pyramid 9810 processor + __sgi__ Silicon Graphics Inc. + sparc SPARC processor + sequent Sequent computer + tahoe CCI Tahoe processor + vax VAX processor + + +File: scm.info, Node: Problems Compiling, Next: Problems Linking, Prev: Automatic C Preprocessor Definitions, Up: Installing SCM + +Problems Compiling +================== + +FILE PROBLEM / MESSAGE HOW TO FIX +*.c include file not found. Correct the status of + STDC_HEADERS in scmfig.h. + fix #include statement or add + #define for system type to + scmfig.h. +*.c Function should return a value. Ignore. + Parameter is never used. + Condition is always false. + Unreachable code in function. +scm.c assignment between incompatible Change SIGRETTYPE in scm.c. + types. +time.c CLK_TCK redefined. incompatablility between + <stdlib.h> and <sys/types.h>. + Remove STDC_HEADERS in scmfig.h. + Edit <sys/types.h> to remove + incompatability. +subr.c Possibly incorrect assignment Ignore. + in function lgcd. +sys.c statement not reached. Ignore. + constant in conditional + expression. +sys.c undeclared, outside of #undef STDC_HEADERS in scmfig.h. + functions. +scl.c syntax error. #define SYSTNAME to your system + type in scl.c (softtype). + + +File: scm.info, Node: Problems Linking, Next: Problems Running, Prev: Problems Compiling, Up: Installing SCM + +Problems Linking +================ + +PROBLEM HOW TO FIX +_sin etc. missing. Uncomment LIBS in makefile. + + +File: scm.info, Node: Problems Running, Next: Testing, Prev: Problems Linking, Up: Installing SCM + +Problems Running +================ + +PROBLEM HOW TO FIX +Opening message and then machine Change memory model option to C +crashes. compiler (or makefile). + Make sure sizet definition is + correct in scmfig.h. + Reduce the size of HEAP_SEG_SIZE in + setjump.h. +Input hangs. #define NOSETBUF +ERROR: heap: need larger initial. Increase initial heap allocation + using -a<kb> or INIT_HEAP_SIZE. +ERROR: Could not allocate. Check sizet definition. + Use 32 bit compiler mode. + Don't try to run as subproccess. +remove <FLAG> in scmfig.h and Do so and recompile files. +recompile scm. +add <FLAG> in scmfig.h and +recompile scm. +ERROR: Init5d6.scm not found. Assign correct IMPLINIT in makefile + or scmfig.h. + Define environment variable + SCM_INIT_PATH to be the full + pathname of Init5d6.scm. +WARNING: require.scm not found. Define environment variable + SCHEME_LIBRARY_PATH to be the full + pathname of the scheme library + [SLIB]. + Change library-vicinity in + Init5d6.scm to point to library or + remove. + Make sure the value of + (library-vicinity) has a trailing + file separator (like / or \). + + +File: scm.info, Node: Testing, Next: Reporting Problems, Prev: Problems Running, Up: Installing SCM + +Testing +======= + +Loading `r4rstest.scm' in the distribution will run an [R4RS] +conformance test on `scm'. + + > (load "r4rstest.scm") + -| + ;loading "r4rstest.scm" + SECTION(2 1) + SECTION(3 4) + #<primitive-procedure boolean?> + #<primitive-procedure char?> + #<primitive-procedure null?> + #<primitive-procedure number?> + ... + +Loading `pi.scm' in the distribution will enable you to compute digits +of pi. + + > (load "pi") + ;loading "pi" + ;done loading "pi.scm" + ;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B other + #<unspecified> + > (pi 100 5) + 00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 + 37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 + 70679 + ;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other + #<unspecified> + +Loading `bench.scm' will compute and display performance statistics of +SCM running `pi.scm'. `make bench' or `make benchlit' appends the +performance report to the file `BenchLog', facilitating tracking +effects of changes to SCM on performance. + +PROBLEM HOW TO FIX +Runs some and then machine crashes. See above under machine crashes. +Runs some and then ERROR: ... Remove optimization option to C +(after a GC has happened). compiler and recompile. + #define SHORT_ALIGN in `scmfig.h'. +Some symbol names print incorrectly. Change memory model option to C + compiler (or makefile). + Check that HEAP_SEG_SIZE fits + within sizet. + Increase size of HEAP_SEG_SIZE (or + INIT_HEAP_SIZE if it is smaller + than HEAP_SEG_SIZE). +ERROR: Rogue pointer in Heap. See above under machine crashes. +Newlines don't appear correctly in Check file mode (define OPEN_... in +output files. `Init5d6.scm'). +Spaces or control characters appear Check character defines in +in symbol names. `scmfig.h'. +Negative numbers turn positive. Check SRS in `scmfig.h'. +VMS: Couldn't unwind stack. #define CHEAP_CONTIUATIONS in + `scmfig.h'. +VAX: botched longjmp. + +Sparc(SUN-4) heap is growing out of control + You are experiencing a GC problem peculiar to the Sparc. The + problem is that SCM doesn't know how to clear register windows. + Every location which is not reused still gets marked at GC time. + This causes lots of stuff which should be collected to not be. + This will be a problem with any _conservative_ GC until we find + what instruction will clear the register windows. This problem is + exacerbated by using lots of call-with-current-continuations. + + +File: scm.info, Node: Reporting Problems, Prev: Testing, Up: Installing SCM + +Reporting Problems +================== + +Reported problems and solutions are grouped under Compiling, Linking, +Running, and Testing. If you don't find your problem listed there, you +can send a bug report to `jaffer @ alum.mit.edu'. The bug report +should include: + + 1. The version of SCM (printed when SCM is invoked with no arguments). + + 2. The type of computer you are using. + + 3. The name and version of your computer's operating system. + + 4. The values of the environment variables `SCM_INIT_PATH' and + `SCHEME_LIBRARY_PATH'. + + 5. The name and version of your C compiler. + + 6. If you are using an executable from a distribution, the name, + vendor, and date of that distribution. In this case, + corresponding with the vendor is recommended. + + +File: scm.info, Node: Operational Features, Next: The Language, Prev: Installing SCM, Up: Top + +Operational Features +******************** + +* Menu: + +* Invoking SCM:: +* SCM Options:: +* Invocation Examples:: +* SCM Variables:: +* SCM Session:: +* Editing Scheme Code:: +* Debugging Scheme Code:: +* Errors:: +* Memoized Expressions:: +* Internal State:: +* Scripting:: + + +File: scm.info, Node: Invoking SCM, Next: SCM Options, Prev: Operational Features, Up: Operational Features + +Invoking SCM +============ + + scm [-a kbytes] [-muvbiq] [-version] [-help] + [[-]-no-init-file] [-p int] [-r feature] [-h feature] + [-d filename] [-f filename] [-l filename] + [-c expression] [-e expression] [-o dumpname] + [-- | - | -s] [filename] [arguments ...] + +Upon startup `scm' loads the file specified by by the environment +variable SCM_INIT_PATH. + +If SCM_INIT_PATH is not defined or if the file it names is not present, +`scm' tries to find the directory containing the executable file. If +it is able to locate the executable, `scm' looks for the initialization +file (usually `Init5d6.scm') in platform-dependent directories relative +to this directory. See *Note File-System Habitat:: for a blow-by-blow +description. + +As a last resort (if initialization file cannot be located), the C +compile parameter IMPLINIT (defined in the makefile or `scmfig.h') is +tried. + +Unless the option `-no-init-file' or `--no-init-file' occurs in the +command line, `Init5d6.scm' checks to see if there is file +`ScmInit.scm' in the path specified by the environment variable HOME +(or in the current directory if HOME is undefined). If it finds such a +file it is loaded. + +`Init5d6.scm' then looks for command input from one of three sources: +From an option on the command line, from a file named on the command +line, or from standard input. + +This explanation applies to SCMLIT or other builds of SCM. + +Scheme-code files can also invoke SCM and its variants. *Note #!: +Syntax Extensions. + + +File: scm.info, Node: SCM Options, Next: Invocation Examples, Prev: Invoking SCM, Up: Operational Features + +Options +======= + +The options are processed in the order specified on the command line. + + - Command Option: -a k + specifies that `scm' should allocate an initial heapsize of K + kilobytes. This option, if present, must be the first on the + command line. If not specified, the default is `INIT_HEAP_SIZE' + in source file `setjump.h' which the distribution sets at + `25000*sizeof(cell)'. + + - Command Option: -no-init-file + - Command Option: --no-init-file + Inhibits the loading of `ScmInit.scm' as described above. + + - Command Option: --help + prints usage information and URI; then exit. + + - Command Option: --version + prints version information and exit. + + - Command Option: -r feature + requires FEATURE. This will load a file from [SLIB] if that + FEATURE is not already provided. If FEATURE is 2, 2rs, r2rs, 3, + 3rs, r3rs, 4, 4rs, r4rs, 5, 5rs, or r5rs; `scm' will require the + features neccessary to support [R2RS], [R3RS], [R4RS], or [R5RS], + respectively. + + - Command Option: -h feature + provides FEATURE. + + - Command Option: -l filename + - Command Option: -f filename + loads FILENAME. `Scm' will load the first (unoptioned) file named + on the command line if no `-c', `-e', `-f', `-l', or `-s' option + preceeds it. + + - Command Option: -d filename + Loads SLIB `databases' feature and opens FILENAME as a database. + + - Command Option: -e expression + - Command Option: -c expression + specifies that the scheme expression EXPRESSION is to be + evaluated. These options are inspired by `perl' and `sh' + respectively. On Amiga systems the entire option and argument + need to be enclosed in quotes. For instance `"-e(newline)"'. + + - Command Option: -o dumpname + saves the current SCM session as the executable program `dumpname'. + This option works only in SCM builds supporting `dump' (*note + Dump::). + + If options appear on the command line after `-o DUMPNAME', then + the saved session will continue with processing those options when + it is invoked. Otherwise the (new) command line is processed as + usual when the saved image is invoked. + + - Command Option: -p level + sets the prolixity (verboseness) to LEVEL. This is the same as + the `scm' command (verobse LEVEL). + + - Command Option: -v + (verbose mode) specifies that `scm' will print prompts, evaluation + times, notice of loading files, and garbage collection statistics. + This is the same as `-p3'. + + - Command Option: -q + (quiet mode) specifies that `scm' will print no extra information. + This is the same as `-p0'. + + - Command Option: -m + specifies that subsequent loads, evaluations, and user + interactions will be with syntax-rules macro capability. To use a + specific syntax-rules macro implementation from [SLIB] (instead of + [SLIB]'s default) put `-r' MACROPACKAGE before `-m' on the command + line. + + - Command Option: -u + specifies that subsequent loads, evaluations, and user + interactions will be without syntax-rules macro capability. + Syntax-rules macro capability can be restored by a subsequent `-m' + on the command line or from Scheme code. + + - Command Option: -i + specifies that `scm' should run interactively. That means that + `scm' will not terminate until the `(quit)' or `(exit)' command is + given, even if there are errors. It also sets the prolixity level + to 2 if it is less than 2. This will print prompts, evaluation + times, and notice of loading files. The prolixity level can be + set by subsequent options. If `scm' is started from a tty, it + will assume that it should be interactive unless given a + subsequent `-b' option. + + - Command Option: -b + specifies that `scm' should run non-interactively. That means that + `scm' will terminate after processing the command line or if there + are errors. + + - Command Option: -s + specifies, by analogy with `sh', that further options are to be + treated as program aguments. + + - Command Option: - + - Command Option: -- + specifies that there are no more options on the command line. + + +File: scm.info, Node: Invocation Examples, Next: SCM Variables, Prev: SCM Options, Up: Operational Features + +Invocation Examples +=================== + +`% scm foo.scm' + Loads and executes the contents of `foo.scm' and then enters + interactive session. + +`% scm -f foo.scm arg1 arg2 arg3' + Parameters `arg1', `arg2', and `arg3' are stored in the global + list `*argv*'; Loads and executes the contents of `foo.scm' and + exits. + +`% scm -s foo.scm arg1 arg2' + Sets *argv* to `("foo.scm" "arg1" "arg2")' and enters interactive + session. + +`% scm -e `(write (list-ref *argv* *optind*))' bar' + Prints `"bar"'. + +`% scm -rpretty-print -r format -i' + Loads `pretty-print' and `format' and enters interactive session. + +`% scm -r5' + Loads `dynamic-wind', `values', and syntax-rules macros and enters + interactive (with macros) session. + +`% scm -r5 -r4' + Like above but `rev4-optional-procedures' are also loaded. + + +File: scm.info, Node: SCM Variables, Next: SCM Session, Prev: Invocation Examples, Up: Operational Features + +Environment Variables +===================== + + - Environment Variable: SCM_INIT_PATH + is the pathname where `scm' will look for its initialization code. + The default is the file `Init5d6.scm' in the source directory. + + - Environment Variable: SCHEME_LIBRARY_PATH + is the [SLIB] Scheme library directory. + + - Environment Variable: HOME + is the directory where `Init5d6.scm' will look for the user + initialization file `ScmInit.scm'. + + - Environment Variable: EDITOR + is the name of the program which `ed' will call. If EDITOR is not + defined, the default is `ed'. + +Scheme Variables +================ + + - Variable: *argv* + contains the list of arguments to the program. `*argv*' can change + during argument processing. This list is suitable for use as an + argument to [SLIB] `getopt'. + + - Variable: *syntax-rules* + controls whether loading and interaction support syntax-rules + macros. Define this in `ScmInit.scm' or files specified on the + command line. This can be overridden by subsequent `-m' and `-u' + options. + + - Variable: *interactive* + controls interactivity as explained for the `-i' and `-b' options. + Define this in `ScmInit.scm' or files specified on the command + line. This can be overridden by subsequent `-i' and `-b' options. + + +File: scm.info, Node: SCM Session, Next: Editing Scheme Code, Prev: SCM Variables, Up: Operational Features + +SCM Session +=========== + + * Options, file loading and features can be specified from the + command line. *Note System interface: (scm)System interface. + *Note Require: (slib)Require. + + * Typing the end-of-file character at the top level session (while + SCM is not waiting for parenthesis closure) causes SCM to exit. + + * Typing the interrupt character aborts evaluation of the current + form and resumes the top level read-eval-print loop. + + - Function: quit + - Function: quit n + - Function: exit + - Function: exit n + Aliases for `exit' (*note exit: (slib)System.). On many systems, + SCM can also tail-call another program. *Note execp: + I/O-Extensions. + + - Callback procedure: boot-tail dumped? + `boot-tail' is called by `scm_top_level' just before entering + interactive top-level. If `boot-tail' calls `quit', then + interactive top-level is not entered. + + - Function: program-arguments + Returns a list of strings of the arguments scm was called with. + +For documentation of the procedures `getenv' and `system' *Note System +Interface: (slib)System Interface. + + - Function: vms-debug + If SCM is compiled under VMS this `vms-debug' will invoke the VMS + debugger. + + +File: scm.info, Node: Editing Scheme Code, Next: Debugging Scheme Code, Prev: SCM Session, Up: Operational Features + +Editing Scheme Code +=================== + + - Function: ed arg1 ... + The value of the environment variable `EDITOR' (or just `ed' if it + isn't defined) is invoked as a command with arguments ARG1 .... + + - Function: ed filename + If SCM is compiled under VMS `ed' will invoke the editor with a + single the single argument FILENAME. + +Gnu Emacs: + Editing of Scheme code is supported by emacs. Buffers holding + files ending in .scm are automatically put into scheme-mode. + EMACS for MS-DOS and MS-Windows systems is available (free) from: + + <http://simtel.coast.net/SimTel/gnu/demacs.html> + If your Emacs can + run a process in a buffer you can use the Emacs command `M-x + run-scheme' with SCM. Otherwise, use the emacs command `M-x + suspend-emacs'; or see "other systems" below. + +Epsilon (MS-DOS): + There is lisp (and scheme) mode available by use of the package + `LISP.E'. It offers several different indentation formats. With + this package, buffers holding files ending in `.L', `.LSP', `.S', + and `.SCM' (my modification) are automatically put into lisp-mode. + + It is possible to run a process in a buffer under Epsilon. With + Epsilon 5.0 the command line options `-e512 -m0' are neccessary to + manage RAM properly. It has been reported that when compiling SCM + with Turbo C, you need to `#define NOSETBUF' for proper operation + in a process buffer with Epsilon 5.0. + + One can also call out to an editor from SCM if RAM is at a + premium; See "under other systems" below. + +other systems: + Define the environment variable `EDITOR' to be the name of the + editing program you use. The SCM procedure `(ed arg1 ...)' will + invoke your editor and return to SCM when you exit the editor. The + following definition is convenient: + + (define (e) (ed "work.scm") (load "work.scm")) + + Typing `(e)' will invoke the editor with the file of interest. + After editing, the modified file will be loaded. + + +File: scm.info, Node: Debugging Scheme Code, Next: Errors, Prev: Editing Scheme Code, Up: Operational Features + +Debugging Scheme Code +===================== + +The `cautious' and `stack-limit' options of `build' (*note Build +Options::) support debugging in Scheme. + +"CAUTIOUS" + If SCM is built with the `CAUTIOUS' flag, then when an error + occurs, a "stack trace" of certain pending calls are printed as + part of the default error response. A (memoized) expression and + newline are printed for each partially evaluated combination whose + procedure is not builtin. See *Note Memoized Expressions:: for + how to read memoized expressions. + + Also as the result of the `CAUTIOUS' flag, both `error' and + `user-interrupt' (invoked by <C-c>) to print stack traces and + conclude by calling `breakpoint' (*note Breakpoints: + (slib)Breakpoints.) instead of aborting to top level. Under + either condition, program execution can be resumed by `(continue)'. + + In this configuration one can interrupt a running Scheme program + with <C-c>, inspect or modify top-level values, trace or untrace + procedures, and continue execution with `(continue)'. + +"STACK_LIMIT" + If SCM is built with the `STACK_LIMIT' flag, the interpreter will + check stack size periodically. If the size of stack exceeds a + certain amount (default is `HEAP_SEG_SIZE/2'), SCM generates a + `segment violation' interrupt. + + The usefulness of `STACK_LIMIT' depends on the user. I don't use + it; but the user I added this feature for got primarily this type + of error. + +There are several SLIB macros which so useful that SCM automatically +loads the appropriate module from SLIB if they are invoked. + + - Macro: trace proc1 ... + Traces the top-level named procedures given as arguments. + + - Macro: trace + With no arguments, makes sure that all the currently traced + identifiers are traced (even if those identifiers have been + redefined) and returns a list of the traced identifiers. + + - Macro: untrace proc1 ... + Turns tracing off for its arguments. + + - Macro: untrace + With no arguments, untraces all currently traced identifiers and + returns a list of these formerly traced identifiers. + +The routines I use most frequently for debugging are: + + - Procedure: print arg1 ... + `Print' writes all its arguments, separated by spaces. `Print' + outputs a `newline' at the end and returns the value of the last + argument. + + One can just insert `(print '<proc-name>' and `)' around an + expression in order to see its value as a program operates. + + - Syntax: print-args name1 ... + Writes NAME1 ... (separated by spaces) and then writes the values + of the closest lexical bindings enclosing the call to `Print-args'. + + (define (foo a b) (print-args foo) (+ a b)) + (foo 3 6) + -| In foo: a = 3; b = 6; + => 9 + +Sometimes more elaborate measures are needed to print values in a useful +manner. When the values to be printed may have very large (or infinite) +external representations, *Note Quick Print: (slib)Quick Print, can be +used. + +When `trace' is not sufficient to find program flow problems, SLIB-PSD, +the Portable Scheme Debugger offers source code debugging from GNU +Emacs. PSD runs slowly, so start by instrumenting only a few functions +at a time. + http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz + swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz + + +File: scm.info, Node: Errors, Next: Memoized Expressions, Prev: Debugging Scheme Code, Up: Operational Features + +Errors +====== + +A computer-language implementation designer faces choices of how +reflexive to make the implementation in handling exceptions and errors; +that is, how much of the error and exception routines should be written +in the language itself. The design of a portable implementation is +further constrained by the need to have (almost) all errors print +meaningful messages, even when the implementation itself is not +functioning correctly. Therefore, SCM implements much of its error +response code in C. + +The following common error and conditions are handled by C code. Those +with callback names after them can also be handled by Scheme code +(*note Interrupts::). If the callback identifier is not defined at top +level, the default error handler (C code) is invoked. There are many +other error messages which are not treated specially. + +"ARGn" + Wrong type in argument + +"ARG1" + Wrong type in argument 1 + +"ARG2" + Wrong type in argument 2 + +"ARG3" + Wrong type in argument 3 + +"ARG4" + Wrong type in argument 4 + +"ARG5" + Wrong type in argument 5 + +"WNA" + Wrong number of args + +"OVFLOW" + numerical overflow + +"OUTOFRANGE" + Argument out of range + +"NALLOC" + `(out-of-storage)' + +"THRASH" + GC is `(thrashing)' + +"EXIT" + `(end-of-program)' + +"HUP_SIGNAL" + `(hang-up)' + +"INT_SIGNAL" + `(user-interrupt)' + +"FPE_SIGNAL" + `(arithmetic-error)' + +"BUS_SIGNAL" + bus error + +"SEGV_SIGNAL" + segment violation + +"ALRM_SIGNAL" + `(alarm-interrupt)' + +"VTALRM_SIGNAL" + `(virtual-alarm-interrupt)' + +"PROF_SIGNAL" + `(profile-alarm-interrupt)' + + - Variable: errobj + When SCM encounters a non-fatal error, it aborts evaluation of the + current form, prints a message explaining the error, and resumes + the top level read-eval-print loop. The value of ERROBJ is the + offending object if appropriate. The builtin procedure `error' + does _not_ set ERROBJ. + +`errno' and `perror' report ANSI C errors encountered during a call to +a system or library function. + + - Function: errno + - Function: errno n + With no argument returns the current value of the system variable + `errno'. When given an argument, `errno' sets the system variable + `errno' to N and returns the previous value of `errno'. `(errno + 0)' will clear outstanding errors. This is recommended after + `try-load' returns `#f' since this occurs when the file could not + be opened. + + - Function: perror string + Prints on standard error output the argument STRING, a colon, + followed by a space, the error message corresponding to the current + value of `errno' and a newline. The value returned is unspecified. + +`warn' and `error' provide a uniform way for Scheme code to signal +warnings and errors. + + - Function: warn arg1 arg2 arg3 ... + Alias for *Note slib:warn: (slib)System. Outputs an error message + containing the arguments. `warn' is defined in `Init5d6.scm'. + + - Function: error arg1 arg2 arg3 ... + Alias for *Note slib:error: (slib)System. Outputs an error + message containing the arguments, aborts evaluation of the current + form and resumes the top level read-eval-print loop. `Error' is + defined in `Init5d6.scm'. + +If SCM is built with the `CAUTIOUS' flag, then when an error occurs, a +"stack trace" of certain pending calls are printed as part of the +default error response. A (memoized) expression and newline are +printed for each partially evaluated combination whose procedure is not +builtin. See *Note Memoized Expressions:: for how to read memoized +expressions. + +Also as the result of the `CAUTIOUS' flag, both `error' and +`user-interrupt' (invoked by <C-c>) are defined to print stack traces +and conclude by calling `breakpoint' (*note Breakpoints: +(slib)Breakpoints.). This allows the user to interract with SCM as +with Lisp systems. + + - Function: stack-trace + Prints information describing the stack of partially evaluated + expressions. `stack-trace' returns `#t' if any lines were printed + and `#f' otherwise. See `Init5d6.scm' for an example of the use + of `stack-trace'. + + +File: scm.info, Node: Memoized Expressions, Next: Internal State, Prev: Errors, Up: Operational Features + +Memoized Expressions +==================== + +SCM memoizes the address of each occurence of an identifier's value when +first encountering it in a source expression. Subsequent executions of +that memoized expression is faster because the memoized reference +encodes where in the top-level or local environment its value is. + +When procedures are displayed, the memoized locations appear in a format +different from references which have not yet been executed. I find this +a convenient aid to locating bugs and untested expressions. + + * The names of memoized lexically bound identifiers are replaced with + #@<m>-<n>, where <m> is the number of binding contours back and + <n> is the index of the value in that binding countour. + + * The names of identifiers which are not lexiallly bound but defined + at top-level have #@ prepended. + +For instance, `open-input-file' is defined as follows in `Init5d6.scm': + + (define (open-input-file str) + (or (open-file str OPEN_READ) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))) + +If `open-input-file' has not yet been used, the displayed procedure is +similar to the original definition (lines wrapped for readability): + + open-input-file => + #<CLOSURE (str) (or (open-file str open_read) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))> + +If we open a file using `open-input-file', the sections of code used +become memoized: + + (open-input-file "r4rstest.scm") => #<input-port 3> + open-input-file => + #<CLOSURE (str) (#@or (#@open-file #@0+0 #@open_read) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))> + +If we cause `open-input-file' to execute other sections of code, they +too become memoized: + + (open-input-file "foo.scm") => + + ERROR: No such file or directory + ERROR: OPEN-INPUT-FILE couldn't open file "foo.scm" + + open-input-file => + #<CLOSURE (str) (#@or (#@open-file #@0+0 #@open_read) + (#@and (#@procedure? #@could-not-open) (could-not-open) #f) + (#@error "OPEN-INPUT-FILE couldn't open file " #@0+0))> + + +File: scm.info, Node: Internal State, Next: Scripting, Prev: Memoized Expressions, Up: Operational Features + +Internal State +============== + + - Variable: *interactive* + The variable *INTERACTIVE* determines whether the SCM session is + interactive, or should quit after the command line is processed. + *INTERACTIVE* is controlled directly by the command-line options + `-b', `-i', and `-s' (*note Invoking SCM::). If none of these + options are specified, the rules to determine interactivity are + more complicated; see `Init5d6.scm' for details. + + - Function: abort + Resumes the top level Read-Eval-Print loop. + + - Function: restart + Restarts the SCM program with the same arguments as it was + originally invoked. All `-l' loaded files are loaded again; If + those files have changed, those changes will be reflected in the + new session. + + _Note:_ When running a saved executable (*note Dump::), `restart' + is redefined to be `exec-self'. + + - Function: exec-self + Exits and immediately re-invokes the same executable with the same + arguments. If the executable file has been changed or replaced + since the beginning of the current session, the _new_ executable + will be invoked. This differentiates `exec-self' from `restart'. + + - Function: verbose n + Controls how much monitoring information is printed. If N is: + + 0 + no prompt or information is printed. + + >= 1 + a prompt is printed. + + >= 2 + messages bracketing file loading are printed. + + >= 3 + the CPU time is printed after each top level form evaluated; + notifications of heap growth printed. + + >= 4 + a garbage collection summary is printed after each top level + form evaluated; + + >= 5 + a message for each GC (*note Garbage Collection::) is printed; + warnings issued for top-level symbols redefined. + + - Function: gc + Scans all of SCM objects and reclaims for further use those that + are no longer accessible. + + - Function: room + - Function: room #t + Prints out statistics about SCM's current use of storage. `(room + #t)' also gives the hexadecimal heap segment and stack bounds. + + - Constant: *scm-version* + Contains the version string (e.g. `5d6') of SCM. + +Executable path +--------------- + +In order to dump a saved executable or to dynamically-link using DLD, +SCM must know where its executable file is. Sometimes SCM (*note +Executable Pathname::) guesses incorrectly the location of the +currently running executable. In that case, the correct path can be set +by calling `execpath' with the pathname. + + - Function: execpath + Returns the path (string) which SCM uses to find the executable + file whose invocation the currently running session is, or #f if + the path is not set. + + - Function: execpath #f + - Function: execpath newpath + Sets the path to `#f' or NEWPATH, respectively. The old path is + returned. + +For other configuration constants and procedures *Note Configuration: +(slib)Configuration. + + +File: scm.info, Node: Scripting, Prev: Internal State, Up: Operational Features + +Scripting +========= + +* Menu: + +* Unix Scheme Scripts:: From Olin Shivers' Scheme Shell +* MS-DOS Compatible Scripts:: Run in MS-DOS and Unix +* Unix Shell Scripts:: Use /bin/sh to run Scheme + + +File: scm.info, Node: Unix Scheme Scripts, Next: MS-DOS Compatible Scripts, Prev: Scripting, Up: Scripting + +Unix Scheme Scripts +------------------- + +In reading this section, keep in mind that the first line of a script +file has (different) meanings to SCM and the operating system +(`execve'). + + - file: #! interpreter \ ... + On unix systems, a "Shell-Script" is a file (with execute + permissions) whose first two characters are `#!'. The INTERPRETER + argument must be the pathname of the program to process the rest + of the file. The directories named by environment variable `PATH' + are _not_ searched to find INTERPRETER. + + When executing a shell-script, the operating system invokes + INTERPRETER with a single argument encapsulating the rest of the + first line's contents (if if not just whitespace), the pathname of + the Scheme Script file, and then any arguments which the + shell-script was invoked with. + + Put one space character between `#!' and the first character of + INTERPRETER (`/'). The INTERPRETER name is followed by ` \'; SCM + substitutes the second line of FILE for `\' (and the rest of the + line), then appends any arguments given on the command line + invoking this Scheme-Script. + + When SCM executes the script, the Scheme variable *SCRIPT* will be + set to the script pathname. The last argument before `!#' on the + second line should be `-'; SCM will load the script file, preserve + the unprocessed arguments, and set *ARGV* to a list of the script + pathname and the unprocessed arguments. + + Note that the interpreter, not the operating system, provides the + `\' substitution; this will only take place if INTERPRETER is a + SCM or SCSH interpreter. + + - Read syntax: #! ignored !# + When the first two characters of the file being loaded are `#!' and + a `\' is present before a newline in the file, all characters up + to `!#' will be ignored by SCM `read'. + +This combination of interpretatons allows SCM source files to be used as +POSIX shell-scripts if the first line is: + + #! /usr/local/bin/scm \ + +The following Scheme-Script prints factorial of its argument: + + #! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 + - !# + ; -*-scheme-*- + (define (go-script) + (cond ((not *script*)) + ((and (= 1 (- (length *argv*) *optind*)) + (string->number (list-ref *argv* *optind*))) + => (lambda (n) (print (fact n)))) + (else + (print *argv*) + (display "\ + Usage: fact n + Returns the factorial of N. + + http://swissnet.ai.mit.edu/~jaffer/SLIB.html + " + (current-error-port)) + (exit #f)))) + + (define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n))))) + (go-script) + + ./fact 32 + => + 263130836933693530167218012160000000 + +If the wrong number of arguments is given, `fact' prints its ARGV with +usage information. + + ./fact 3 2 + -| + ("./fact" "3" "2") + Usage: fact n + Returns the factorial of N. + + http://swissnet.ai.mit.edu/~jaffer/SLIB.html + + +File: scm.info, Node: MS-DOS Compatible Scripts, Next: Unix Shell Scripts, Prev: Unix Scheme Scripts, Up: Scripting + +MS-DOS Compatible Scripts +------------------------- + +It turns out that we can create scheme-scripts which run both under unix +and MS-DOS. To implement this, I have written the MS-DOS programs: +`#!.bat' and `!#.exe'. + +With these two programs installed in a `PATH' directory, we have the +following syntax for <PROGRAM>.BAT files. + + - file: #! interpreter \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 + The first two characters of the Scheme-Script are `#!'. The + INTERPRETER can be either a unix style program path (using `/' + between filename components) or a DOS program name or path. The + rest of the first line of the Scheme-Script should be literally + `\ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9', as shown. + + If INTERPRETER has `/' in it, INTERPRETER is converted to a DOS + style filename (`/' => `\'). + + In looking for an executable named INTERPRETER, `#!' first checks + this (converted) filename; if INTERPRETER doesn't exist, it then + tries to find a program named like the string starting after the + last `\' (or `/') in INTERPRETER. When searching for executables, + `#!' tries all directories named by environment variable `PATH'. + + Once the INTERPRETER executable path is found, arguments are + processed in the manner of scheme-shell, with the all the text + after the `\' taken as part of the meta-argument. More precisely, + `#!' calls INTERPRETER with any options on the second line of the + Scheme-Script up to `!#', the name of the Scheme-Script file, and + then any of at most 8 arguments given on the command line invoking + this Scheme-Script. + +The previous example Scheme-Script works in both MS-DOS and unix +systems. + + +File: scm.info, Node: Unix Shell Scripts, Prev: MS-DOS Compatible Scripts, Up: Scripting + +Unix Shell Scripts +------------------ + +Scheme-scripts suffer from two drawbacks: + * Some Unixes limit the length of the `#!' interpreter line to the + size of an object file header, which can be as small as 32 bytes. + + * A full, explicit pathname must be specified, perhaps requiring + more than 32 bytes and making scripts vulnerable to breakage when + programs are moved. + +The following approach solves these problems at the expense of slower +startup. Make `#! /bin/sh' the first line and prepend every subsequent +line to be executed by the shell with `:;'. The last line to be +executed by the shell should contain an "exec" command; `exec' +tail-calls its argument. + +`/bin/sh' is thus invoked with the name of the script file, which it +executes as a *sh script. Usually the second line starts `:;exec scm +-f$0', which executes scm, which in turn loads the script file. When +SCM loads the script file, it ignores the first and second lines, and +evaluates the rest of the file as Scheme source code. + +The second line of the script file does not have the length restriction +mentioned above. Also, `/bin/sh' searches the directories listed in +the `PATH' environment variable for `scm', eliminating the need to use +absolute locations in order to invoke a program. + +The following example additionally sets *SCRIPT* to the script +argument, making it compatible with the scheme code of the previous +example. + + #! /bin/sh + :;exec scm -e"(set! *script* \"$0\")" -l$0 $* + + (define (go-script) + (cond ((not *script*)) + ((and (= 1 (- (length *argv*) *optind*)) + (string->number (list-ref *argv* *optind*))) + => (lambda (n) (print (fact n)))) + (else + (print *argv*) + (display "\ + Usage: fact n + Returns the factorial of N. + + http://swissnet.ai.mit.edu/~jaffer/SLIB.html + " + (current-error-port)) + (exit #f)))) + + (define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n))))) + + (go-script) + + ./fact 6 + => 720 + + +File: scm.info, Node: The Language, Next: Packages, Prev: Operational Features, Up: Top + +The Language +************ + +* Menu: + +* Standards Compliance:: Links to sections in [R5RS] and [SLIB] +* Miscellaneous Procedures:: +* Time:: Both real time and processor time +* Interrupts:: and exceptions +* Process Synchronization:: Because interrupts are preemptive +* Files and Ports:: +* Line Numbers:: +* Soft Ports:: Emulate I/O devices +* Syntax Extensions:: +* Low Level Syntactic Hooks:: +* Syntactic Hooks for Hygienic Macros:: + + +File: scm.info, Node: Standards Compliance, Next: Miscellaneous Procedures, Prev: The Language, Up: The Language + +Standards Compliance +==================== + +Scm conforms to the `IEEE Standard 1178-1990. IEEE Standard for the +Scheme Programming Language.' (*note Bibliography::), and `Revised(5) +Report on the Algorithmic Language Scheme'. *Note Top: (r5rs)Top. All +the required features of these specifications are supported. Many of +the optional features are supported as well. + +Optionals of [R5RS] Supported by SCM +------------------------------------ + +`-' and `/' of more than 2 arguments +`exp' +`log' +`sin' +`cos' +`tan' +`asin' +`acos' +`atan' +`sqrt' +`expt' +`make-rectangular' +`make-polar' +`real-part' +`imag-part' +`magnitude' +`angle' +`exact->inexact' +`inexact->exact' + *Note Numerical operations: (r5rs)Numerical operations. + +`with-input-from-file' +`with-output-to-file' + *Note Ports: (r5rs)Ports. + +`load' +`transcript-on' +`transcript-off' + *Note System interface: (r5rs)System interface. + +Optionals of [R5RS] not Supported by SCM +---------------------------------------- + +`numerator' +`denominator' +`rationalize' + *Note Numerical operations: (r5rs)Numerical operations. + +[SLIB] Features of SCM and SCMLIT +--------------------------------- + +`delay' +`full-continuation' +`ieee-p1178' +`object-hash' +`rev4-report' +`source' + See SLIB file `Template.scm'. + +`current-time' + *Note Time: (slib)Time. + +`defmacro' + *Note Defmacro: (slib)Defmacro. + +`getenv' +`system' + *Note System Interface: (slib)System Interface. + +`hash' + *Note Hashing: (slib)Hashing. + +`logical' + *Note Bit-Twiddling: (slib)Bit-Twiddling. + +`multiarg-apply' + *Note Multi-argument Apply: (slib)Multi-argument Apply. + +`multiarg/and-' + *Note Multi-argument / and -: (slib)Multi-argument / and -. + +`rev4-optional-procedures' + *Note Rev4 Optional Procedures: (slib)Rev4 Optional Procedures. + +`string-port' + *Note String Ports: (slib)String Ports. + +`tmpnam' + *Note Input/Output: (slib)Input/Output. + +`transcript' + *Note Transcripts: (slib)Transcripts. + +`vicinity' + *Note Vicinity: (slib)Vicinity. + +`with-file' + *Note With-File: (slib)With-File. + +[SLIB] Features of SCM +---------------------- + +`array' + *Note Arrays: (slib)Arrays. + +`array-for-each' + *Note Array Mapping: (slib)Array Mapping. + +`bignum' +`complex' +`inexact' +`rational' +`real' + *Note Require: (slib)Require. + + +File: scm.info, Node: Miscellaneous Procedures, Next: Time, Prev: Standards Compliance, Up: The Language + +Miscellaneous Procedures +======================== + + - Function: try-load filename + If the string FILENAME names an existing file, the try-load + procedure reads Scheme source code expressions and definitions + from the file and evaluates them sequentially and returns `#t'. + If not, try-load returns `#f'. The try-load procedure does not + affect the values returned by `current-input-port' and + `current-output-port'. + + - Variable: *load-pathname* + Is set to the pathname given as argument to `load', `try-load', + and `dyn:link' (*note Compiling And Linking: (hobbit)Compiling And + Linking.). `*load-pathname*' is used to compute the value of + *Note program-vicinity: (slib)Vicinity. + + - Function: line-number + Returns the current line number of the file currently being loaded. + + - Function: port-filename port + Returns the filename PORT was opened with. If PORT is not open to + a file the result is unspecified. + + - Function: port-line port + - Function: port-column port + If PORT is a tracked port, return the current line (column) number, + otherwise return `#f'. Line and column numbers begin with 1. The + column number applies to the next character to be read; if that + character is a newline, then the column number will be one more + than the length of the line. + + - Function: eval obj + Alias for *Note eval: (slib)System. + + - Function: eval-string str + Returns the result of reading an expression from STR and + evaluating it. `eval-string' does not change `*load-pathname*' or + `line-number'. + + - Function: load-string str + Reads and evaluates all the expressions from STR. As with `load', + the value returned is unspecified. `load-string' does not change + `*load-pathname*' or `line-number'. + + - Function: vector-set-length! object length + Change the length of string, vector, bit-vector, or uniform-array + OBJECT to LENGTH. If this shortens OBJECT then the remaining + contents are lost. If it enlarges OBJECT then the contents of the + extended part are undefined but the original part is unchanged. + It is an error to change the length of literal datums. The new + object is returned. + + - Function: copy-tree obj + - Function: @copy-tree obj + *Note copy-tree: (slib)Tree Operations. This extends the SLIB + version by also copying vectors. Use `@copy-tree' if you depend + on this feature; `copy-tree' could get redefined. + + - Function: acons obj1 obj2 obj3 + Returns (cons (cons obj1 obj2) obj3). The expression (set! a-list + (acons key datum a-list)) adds a new association to a-list. + + - Function: terms + This command displays the GNU General Public License. + + - Function: list-file filename + Displays the text contents of FILENAME. + + - Procedure: print arg1 ... + `Print' writes all its arguments, separated by spaces. `Print' + outputs a `newline' at the end and returns the value of the last + argument. + + +File: scm.info, Node: Time, Next: Interrupts, Prev: Miscellaneous Procedures, Up: The Language + +Time +==== + + - Constant: internal-time-units-per-second + Is the integer number of internal time units in a second. + + - Function: get-internal-run-time + Returns the integer run time in internal time units from an + unspecified starting time. The difference of two calls to + `get-internal-run-time' divided by + `internal-time-units-per-second' will give elapsed run time in + seconds. + + - Function: get-internal-real-time + Returns the integer time in internal time units from an unspecified + starting time. The difference of two calls to + `get-internal-real-time' divided by + `interal-time-units-per-second' will give elapsed real time in + seconds. + + - Function: current-time + Returns the time since 00:00:00 GMT, January 1, 1970, measured in + seconds. *Note current-time: (slib)Time. `current-time' is used + in *Note Time: (slib)Time. + + +File: scm.info, Node: Interrupts, Next: Process Synchronization, Prev: Time, Up: The Language + +Interrupts +========== + + - Function: ticks n + Returns the number of ticks remaining till the next tick interrupt. + Ticks are an arbitrary unit of evaluation. Ticks can vary greatly + in the amount of time they represent. + + If N is 0, any ticks request is canceled. Otherwise a + `ticks-interrupt' will be signaled N from the current time. + `ticks' is supported if SCM is compiled with the `ticks' flag + defined. + + - Callback procedure: ticks-interrupt ... + Establishes a response for tick interrupts. Another tick + interrupt will not occur unless `ticks' is called again. Program + execution will resume if the handler returns. This procedure + should (abort) or some other action which does not return if it + does not want processing to continue. + + - Function: alarm secs + Returns the number of seconds remaining till the next alarm + interrupt. If SECS is 0, any alarm request is canceled. + Otherwise an `alarm-interrupt' will be signaled SECS from the + current time. ALARM is not supported on all systems. + + - Function: milli-alarm millisecs interval + - Function: virtual-alarm millisecs interval + - Function: profile-alarm millisecs interval + `milli-alarm' is similar to `alarm', except that the first + argument MILLISECS, and the return value are measured in + milliseconds rather than seconds. If the optional argument + INTERVAL is supplied then alarm interrupts will be scheduled every + INTERVAL milliseconds until turned off by a call to `milli-alarm' + or `alarm'. + + `virtual-alarm' and `profile-alarm' are similar. `virtual-alarm' + decrements process execution time rather than real time, and + causes `SIGVTALRM' to be signaled. `profile-alarm' decrements + both process execution time and system execution time on behalf + of the process, and causes `SIGPROF' to be signaled. + + `milli-alarm', `virtual-alarm', and `profile-alarm' are supported + only on systems providing the `setitimer' system call. + + - Callback procedure: user-interrupt ... + - Callback procedure: alarm-interrupt ... + - Callback procedure: virtual-alarm-interrupt ... + - Callback procedure: profile-alarm-interrupt ... + Establishes a response for `SIGINT' (control-C interrupt) and + `SIGALRM', `SIGVTALRM', and `SIGPROF' interrupts. Program + execution will resume if the handler returns. This procedure + should `(abort)' or some other action which does not return if it + does not want processing to continue after it returns. + + Interrupt handlers are disabled during execution `system' and `ed' + procedures. + + To unestablish a response for an interrupt set the handler symbol + to `#f'. For instance, `(set! user-interrupt #f)'. + + - Callback procedure: out-of-storage ... + - Callback procedure: could-not-open ... + - Callback procedure: end-of-program ... + - Callback procedure: hang-up ... + - Callback procedure: arithmetic-error ... + Establishes a response for storage allocation error, file opening + error, end of program, SIGHUP (hang up interrupt) and arithmetic + errors respectively. This procedure should (abort) or some other + action which does not return if it does not want the default error + message to also be displayed. If no procedure is defined for + HANG-UP then END-OF-PROGRAM (if defined) will be called. + + To unestablish a response for an error set the handler symbol to + `#f'. For instance, `(set! could-not-open #f)'. + + - Callback procedure: gc-hook ... + Allows a Scheme procedure to be run shortly after each garbage + collection. This procedure will not be run recursively. If it + runs long enough to cause a garbage collection before returning a + warning will be printed. + + - Function: add-finalizer object finalizer + OBJECT may be any garbage collected object, that is, any object + other than an immediate integer, character, or special token such + as `#f' or `#t', *Note Immediates::. FINALIZER is a thunk, or + procedure taking no arguments. + + FINALIZER will be invoked asynchronously exactly once some time + after OBJECT becomes eligible for garbage collection. A reference + to OBJECT in the environment of FINALIZER will not prevent + finalization, but will delay the reclamation of OBJECT at least + until the next garbage collection. A reference to OBJECT in some + other object's finalizer will necessarily prevent finalization + until both objects are eligible for garbage collection. + + Finalizers are not run in any predictable order. All finalizers + will be run by the time the program ends. + + This facility was based on the paper by Simon Peyton Jones, et al, + "Stretching the storage manager: weak pointers and stable names in + Haskell", Proc. 11th International Workshop on the Implementation + of Functional Languages, The Netherlands, September 7-10 1999, + Springer-Verlag LNCS. + + + +File: scm.info, Node: Process Synchronization, Next: Files and Ports, Prev: Interrupts, Up: The Language + +Process Synchronization +======================= + +An "exchanger" is a procedure of one argument regulating mutually +exclusive access to a resource. When a exchanger is called, its current +content is returned, while being replaced by its argument in an atomic +operation. + + - Function: make-exchanger obj + Returns a new exchanger with the argument OBJ as its initial + content. + + (define queue (make-exchanger (list a))) + + A queue implemented as an exchanger holding a list can be + protected from reentrant execution thus: + + (define (pop queue) + (let ((lst #f)) + (dynamic-wind + (lambda () (set! lst (queue #f))) + (lambda () (and lst (not (null? lst)) + (let ((ret (car lst))) + (set! lst (cdr lst)) + ret))) + (lambda () (and lst (queue lst)))))) + + (pop queue) => a + + (pop queue) => #f + + - Function: make-arbiter name + Returns an object of type arbiter and name NAME. Its state is + initially unlocked. + + - Function: try-arbiter arbiter + Returns `#t' and locks ARBITER if ARBITER was unlocked. + Otherwise, returns `#f'. + + - Function: release-arbiter arbiter + Returns `#t' and unlocks ARBITER if ARBITER was locked. + Otherwise, returns `#f'. + + +File: scm.info, Node: Files and Ports, Next: Line Numbers, Prev: Process Synchronization, Up: The Language + +Files and Ports +=============== + +These procedures generalize and extend the standard capabilities in +*Note Ports: (r5rs)Ports. + + - Function: open-file string modes + - Function: try-open-file string modes + Returns a port capable of receiving or delivering characters as + specified by the MODES string. If a file cannot be opened `#f' is + returned. + + Internal functions opening files "callback" to the SCM function + `open-file'. You can extend `open-file' by redefining it. + `try-open-file' is the primitive procedure; Do not redefine + `try-open-file'! + + - Constant: open_read + - Constant: open_write + - Constant: open_both + Contain modes strings specifying that a file is to be opened for + reading, writing, and both reading and writing respectively. + + Both input and output functions can be used with io-ports. An end + of file must be read or a file-set-position done on the port + between a read operation and a write operation or vice-versa. + + - Function: _ionbf modestr + Returns a version of MODESTR which when `open-file' is called with + it as the second argument will return an unbuffered port. An + input-port must be unbuffered in order for `char-ready?' and + `wait-for-input' to work correctly on it. The initial value of + `(current-input-port)' is unbuffered if the platform supports it. + + - Function: _tracked modestr + Returns a version of MODESTR which when `open-file' is called with + it as the second argument will return a tracked port. A tracked + port maintains current line and column numbers, which may be + queried with `port-line' and `port-column'. + + - Function: _exclusive modestr + Returns a version of MODESTR which when `open-file' is called with + it as the second argument will return a port only if the named file + does not already exist. This functionality is provided by calling + `try-create-file' *Note I/O-Extensions::, which is not available + for all platforms. + + - Function: port-closed? port + Returns #t if PORT is closed. + + - Function: port-type obj + If OBJ is not a port returns false, otherwise returns a symbol + describing the port type, for example string or pipe. + + - Function: close-port port + Closes PORT. The same as close-input-port and close-output-port. + + - Function: current-error-port + Returns the current port to which diagnostic output is directed. + + - Function: with-error-to-file string thunk + THUNK must be a procedure of no arguments, and string must be a + string naming a file. The file is opened for output, an output + port connected to it is made the default value returned by + current-error-port, and the THUNK is called with no arguments. + When the thunk returns, the port is closed and the previous + default is restored. With-error-to-file returns the value yielded + by THUNK. + + - Function: with-input-from-port port thunk + - Function: with-output-to-port port thunk + - Function: with-error-to-port port thunk + These routines differ from with-input-from-file, + with-output-to-file, and with-error-to-file in that the first + argument is a port, rather than a string naming a file. + + - Function: call-with-outputs thunk proc + Calls the THUNK procedure while the current-output-port and + current-error-port are directed to string-ports. If THUNK + returns, the PROC procedure is called with the output-string, the + error-string, and the value returned by THUNK. If THUNK does not + return a value (perhaps because of error), PROC is called with + just the output-string and the error-string as arguments. + + - procedure: char-ready? + - procedure: char-ready? port + Returns `#t' if a character is ready on the input PORT and returns + `#f' otherwise. If `char-ready?' returns `#t' then the next + `read-char' operation on the given PORT is guaranteed not to hang. + If the PORT is at end of file then `char-ready?' returns `#t'. + PORT may be omitted, in which case it defaults to the value + returned by `current-input-port'. + + _Rationale:_ `Char-ready?' exists to make it possible for a + program to accept characters from interactive ports without + getting stuck waiting for input. Any input editors associated + with such ports must ensure that characters whose existence has + been asserted by `char-ready?' cannot be rubbed out. If + `char-ready?' were to return `#f' at end of file, a port at end of + file would be indistinguishable from an interactive port that has + no ready characters. + + - procedure: wait-for-input x + - procedure: wait-for-input x port1 ... + Returns a list those ports PORT1 ... which are `char-ready?'. If + none of PORT1 ... become `char-ready?' within the time interval of + X seconds, then #f is returned. The PORT1 ... arguments may be + omitted, in which case they default to the list of the value + returned by `current-input-port'. + + - Function: isatty? port + Returns `#t' if PORT is input or output to a serial non-file + device. + + - Function: freshline port + Outputs a newline to optional argument PORT unless the current + output column number of PORT is known to be zero, ie output will + start at the beginning of a new line. PORT defaults to + `current-output-port'. If PORT is not a tracked port `freshline' + is equivalent to `newline'. + + - Function: open-ports + Returns a list of all currently open ports, excluding string ports, + see *Note String Ports: (slib)String Ports. This may be useful + after a fork *Note Posix Extensions::, or for debugging. Bear in + mind that ports that would be closed by gc will be kept open by a + reference to this list. + + +File: scm.info, Node: Line Numbers, Next: Soft Ports, Prev: Files and Ports, Up: The Language + +Line Numbers +============ + +Scheme code define by load may optionally contain line number +information. Currently this information is used only for reporting +expansion time errors, but in the future run-time error messages may +also include line number information. + + - Function: try-load pathname reader + This is the primitive for loading, PATHNAME is the name of a file + containing Scheme code, and optional argument READER is a function + of one argument, a port. READER should read and return Scheme + code as list structure. The default value is `read', which is + used if READER is not supplied or is false. + +Line number objects are disjoint from integers or other Scheme types. +When evaluated or loaded as Scheme code, an s-expression containing a +line-number in the car is equivalent to the cdr of the s-expression. A +pair consisting of a line-number in the car and a vector in the cdr is +equivalent to the vector. The meaning of s-expressions with +line-numbers in other positions is undefined. + + - Function: read-numbered port + Behaves like `read', except that every s-expression read will be + replaced with a cons of a line-number object and the sexp actually + read. This replacement is done only if PORT is a tracked port See + *Note Files and Ports::. + + - Function: integer->line-number int + Returns a line-number object with value INT. INT should be an + exact non-negative integer. + + - Function: line-number->integer linum + Returns the value of line-number object LINUM as an integer. + + - Function: line-number? obj + Returns true if and only if OBJ is a line-number object. + + - Variable: *load-reader* + - Variable: *slib-load-reader* + The value of `*load-reader*' should be a value acceptable as the + second argument to `try-load' (note that #f is acceptable). This + value will be used to read code during calls to `scm:load'. The + value of `*slib-load-reader*' will similarly be used during calls + to `slib:load' and `require'. + + In order to disable all line-numbering, it is sufficient to set! + `*load-reader*' and `*slib-load-reader*' to #f. + + +File: scm.info, Node: Soft Ports, Next: Syntax Extensions, Prev: Line Numbers, Up: The Language + +Soft Ports +========== + +A "soft-port" is a port based on a vector of procedures capable of +accepting or delivering characters. It allows emulation of I/O ports. + + - Function: make-soft-port vector modes + Returns a port capable of receiving or delivering characters as + specified by the MODES string (*note open-file: Files and Ports.). + VECTOR must be a vector of length 6. Its components are as + follows: + + 0. procedure accepting one character for output + + 1. procedure accepting a string for output + + 2. thunk for flushing output + + 3. thunk for getting one character + + 4. thunk for closing port (not by garbage collection) + + For an output-only port only elements 0, 1, 2, and 4 need be + procedures. For an input-only port only elements 3 and 4 need be + procedures. Thunks 2 and 4 can instead be `#f' if there is no + useful operation for them to perform. + + If thunk 3 returns `#f' or an `eof-object' (*note eof-object?: + (r5rs)Input.) it indicates that the port has reached end-of-file. + For example: + + If it is necessary to explicitly close the port when it is garbage + collected, (*note add-finalizer: Interrupts.). + + (define stdout (current-output-port)) + (define p (make-soft-port + (vector + (lambda (c) (write c stdout)) + (lambda (s) (display s stdout)) + (lambda () (display "." stdout)) + (lambda () (char-upcase (read-char))) + (lambda () (display "@" stdout))) + "rw")) + + (write p p) => #<input-output-soft#\space45d10#\> + + +File: scm.info, Node: Syntax Extensions, Next: Low Level Syntactic Hooks, Prev: Soft Ports, Up: The Language + +Syntax Extensions +================= + + - procedure: procedure-documentation proc + Returns the documentation string of PROC if it exists, or `#f' if + not. + + If the body of a `lambda' (or the definition of a procedure) has + more than one expression, and the first expression (preceeding any + internal definitions) is a string, then that string is the + "documentation string" of that procedure. + + (procedure-documentation (lambda (x) "Identity" x)) => "Identity" + (define (square x) + "Return the square of X." + (* x x)) + => #<unspecified> + (procedure-documentation square) => "Return the square of X." + + - Function: comment string1 ... + Appends STRING1 ... to the strings given as arguments to previous + calls `comment'. + + - Function: comment + Returns the (appended) strings given as arguments to previous calls + `comment' and empties the current string collection. + + - Read syntax: #;text-till-end-of-line + Behaves as `(comment "TEXT-TILL-END-OF-LINE")'. + + - Read syntax: #. expression + Is read as the object resulting from the evaluation of EXPRESSION. + This substitution occurs even inside quoted structure. + + In order to allow compiled code to work with `#.' it is good + practice to define those symbols used inside of EXPRESSION with + `#.(define ...)'. For example: + + #.(define foo 9) => #<unspecified> + '(#.foo #.(+ foo foo)) => (9 18) + + - Read syntax: #+ feature form + If feature is `provided?' (by `*features*') then FORM is read as a + scheme expression. If not, then FORM is treated as whitespace. + + Feature is a boolean expression composed of symbols and `and', + `or', and `not' of boolean expressions. + + For more information on `provided?' and `*features*', *Note + Require: (slib)Require. + + - Read syntax: #- feature form + is equivalent to `#+(not feature) expression'. + + - Read syntax: #' form + is equivalent to FORM (for compatibility with common-lisp). + + - Read syntax: #| any thing |# + Is a balanced comment. Everything up to the matching `|#' is + ignored by the `read'. Nested `#|...|#' can occur inside ANY + THING. + +A similar read syntax "#!" (exclamation rather than vertical bar) is +supported for Posix shell-scripts (*note Scripting::). + + - Read syntax: #\token + If TOKEN is a sequence of two or more digits, then this syntax is + equivalent to `#.(integer->char (string->number token 8))'. + + If TOKEN is `C-', `c-', or `^' followed by a character, then this + syntax is read as a control character. If TOKEN is `M-' or `m-' + followed by a character, then a meta character is read. `c-' and + `m-' prefixes may be combined. + + - Special Form: defined? symbol + Equivalent to `#t' if SYMBOL is a syntactic keyword (such as `if') + or a symbol with a value in the top level environment (*note + Variables and regions: (r5rs)Variables and regions.). Otherwise + equivalent to `#f'. + + - Special Form: defvar identifier initial-value + If IDENTIFIER is unbound in the top level environment, then + IDENTIFIER is `define'd to the result of evaluating the form + INITIAL-VALUE as if the `defvar' form were instead the form + `(define identifier initial-value)' . If IDENTIFIER already has a + value, then INITIAL-VALUE is _not_ evaluated and IDENTIFIER's + value is not changed. `defconst' is valid only when used at + top-level. + + - Special Form: defconst identifier value + If IDENTIFIER is unbound in the top level environment, then + IDENTIFIER is `define'd to the result of evaluating the form VALUE + as if the `defconst' form were instead the form `(define + identifier value)' . If IDENTIFIER already has a value, then + VALUE is _not_ evaluated, IDENTIFIER's value is not changed, and + an error is signaled. `defconst' is valid only when used at + top-level. + + - Special Form: set! (variable1 variable2 ...) <expression> + The identifiers VARIABLE1, VARIABLE2, ... must be bound either in + some region enclosing the `set!' expression or at top level. + + <Expression> is evaluated, and the elements of the resulting list + are stored in the locations to which each corresponding VARIABLE + is bound. The result of the `set!' expression is unspecified. + + (define x 2) + (define y 3) + (+ x y) => 5 + (set! (x y) (list 4 5)) => _unspecified_ + (+ x y) => 9 + + - Special Form: qase key clause1 clause2 ... + `qase' is an extension of standard Scheme `case': Each CLAUSE of a + `qase' statement must have as first element a list containing + elements which are: + + * literal datums, or + + * a comma followed by the name of a symbolic constant, or + + * a comma followed by an at-sign (@) followed by the name of a + symbolic constant whose value is a list. + + A `qase' statement is equivalent to a `case' statement in which + these symbolic constants preceded by commas have been replaced by + the values of the constants, and all symbolic constants preceded by + comma-at-signs have been replaced by the elements of the list + values of the constants. This use of comma, (or, equivalently, + `unquote') is similar to that of `quasiquote' except that the + unquoted expressions must be "symbolic constants". + + Symbolic constants are defined using `defconst', their values are + substituted in the head of each `qase' clause during macro + expansion. `defconst' constants should be defined before use. + `qase' can be substituted for any correct use of `case'. + + (defconst unit '1) + (defconst semivowels '(w y)) + (qase (* 2 3) + ((2 3 5 7) 'prime) + ((,unit 4 6 8 9) 'composite)) ==> composite + (qase (car '(c d)) + ((a) 'a) + ((b) 'b)) ==> _unspecified_ + (qase (car '(c d)) + ((a e i o u) 'vowel) + ((,@semivowels) 'semivowel) + (else 'consonant)) ==> consonant + + +SCM also supports the following constructs from Common Lisp: +`defmacro', `macroexpand', `macroexpand-1', and `gentemp'. *Note +Defmacro: (slib)Defmacro. + +SCM `defmacro' is extended over that described for SLIB: + + (defmacro (macro-name . arguments) body) + +is equivalent to + + (defmacro macro-name arguments body) + +As in Common Lisp, an element of the formal argument list for +`defmacro' may be a possibly nested list, in which case the +corresponding actual argument must be a list with as many members as the +formal argument. Rest arguments are indicated by improper lists, as in +Scheme. It is an error if the actual argument list does not have the +tree structure required by the formal argument list. + +For example: + + (defmacro (let1 ((name value)) . body) + `((lambda (,name) ,@body) ,value)) + + (let1 ((x (foo))) (print x) x) == ((lambda (x) (print x) x) (foo)) + + (let1 not legal syntax) error--> not "does not match" ((name value)) + +SCM supports [R5RS] `syntax-rules' macros *Note Macros: (r5rs)Macros. + +The pattern language is extended by the syntax `(... <obj>)', which is +identical to `<obj>' except that ellipses in `<obj>' are treated as +ordinary identifiers in a template, or as literals in a pattern. In +particular, `(... ...)' quotes the ellipsis token `...' in a pattern or +template. + +For example: + (define-syntax check-tree + (syntax-rules () + ((_ (?pattern (... ...)) ?obj) + (let loop ((obj ?obj)) + (or (null? obj) + (and (pair? obj) + (check-tree ?pattern (car obj)) + (loop (cdr obj)))))) + ((_ (?first . ?rest) ?obj) + (let ((obj ?obj)) + (and (pair? obj) + (check-tree ?first (car obj)) + (check-tree ?rest (cdr obj))))) + ((_ ?atom ?obj) #t))) + + (check-tree ((a b) ...) '((1 2) (3 4) (5 6))) => #t + + (check-tree ((a b) ...) '((1 2) (3 4) not-a-2list) => #f + +Note that although the ellipsis is matched as a literal token in the +defined macro it is not included in the literals list for +`syntax-rules'. + +The pattern language is also extended to support identifier macros. A +reference to an identifier macro keyword that is not the first +identifier in a form may expand into Scheme code, rather than raising a +"keyword as variable" error. The pattern for expansion of such a bare +macro keyword is a single identifier, as in other syntax rules the +identifier is ignored. + +For example: + (define-syntax eight + (syntax-rules () + (_ 8))) + + (+ 3 eight) => 11 + (eight) => ERROR + (set! eight 9) => ERROR + + +File: scm.info, Node: Low Level Syntactic Hooks, Next: Syntactic Hooks for Hygienic Macros, Prev: Syntax Extensions, Up: The Language + +Low Level Syntactic Hooks +========================= + + - Callback procedure: read:sharp c port + If a <#> followed by a character (for a non-standard syntax) is + encountered by `read', `read' will call the value of the symbol + `read:sharp' with arguments the character and the port being read + from. The value returned by this function will be the value of + `read' for this expression unless the function returns + `#<unspecified>' in which case the expression will be treated as + whitespace. `#<unspecified>' is the value returned by the + expression `(if #f #f)'. + + - Callback procedure: read:sharp-char token + If the sequence <#\> followed by a non-standard character name is + encountered by `read', `read' will call the value of the symbol + `read:sharp-char' with the token (a string of length at least two) + as argument. If the value returned is a character, then that will + be the value of `read' for this expression, otherwise an error + will be signaled. + +_Note:_ When adding new <#> syntaxes, have your code save the previous +value of `read:sharp' or `read:sharp-char' when defining it. Call this +saved value if an invocation's syntax is not recognized. This will +allow `#+', `#-', `#!', and *Note Uniform Array::s to still be +supported (as they use `read:sharp'). + + - Function: procedure->syntax proc + Returns a "macro" which, when a symbol defined to this value + appears as the first symbol in an expression, returns the result + of applying PROC to the expression and the environment. + + - Function: procedure->macro proc + - Function: procedure->memoizing-macro proc + - Function: procedure->identifier-macro + Returns a "macro" which, when a symbol defined to this value + appears as the first symbol in an expression, evaluates the result + of applying PROC to the expression and the environment. The value + returned from PROC which has been passed to + `PROCEDURE->MEMOIZING-MACRO' replaces the form passed to PROC. + For example: + + (defsyntax trace + (procedure->macro + (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) + + (trace foo) == (set! foo (tracef foo 'foo)). + + `PROCEDURE->IDENTIFIER-MACRO' is similar to + `PROCEDURE->MEMOIZING-MACRO' except that PROC is also called in + case the symbol bound to the macro appears in an expression but + _not_ as the first symbol, that is, when it looks like a variable + reference. In that case, the form passed to PROC is a single + identifier. + + + - Special Form: defsyntax name expr + Defines NAME as a macro keyword bound to the result of evaluating + EXPR, which should be a macro. Using `define' for this purpose + may not result in NAME being interpreted as a macro keyword. + +An "environment" is a list of frames representing lexical bindings. +Only the names and scope of the bindings are included in environments +passed to macro expanders - run-time values are not included. + +There are several types of environment frames: + +`((lambda (variable1 ...) ...) value1 ...)' +`(let ((variable1 value1) (variable2 value2) ...) ...)' +`(letrec ((variable1 value1) ...) ...)' + result in a single enviroment frame: + + (variable1 variable2 ...) + +`(let ((variable1 value1)) ...)' +`(let* ((variable1 value1) ...) ...)' + result in an environment frame for each variable: + + variable1 variable2 ... + +`(let-syntax ((key1 macro1) (key2 macro2)) ...)' +`(letrec-syntax ((key1 value1) (key2 value2)) ...)' + Lexically bound macros result in environment frames consisting of + a marker and an alist of keywords and macro objects: + + (<env-syntax-marker> (key1 . value1) (key2 . value2)) + Currently <env-syntax-marker> is the integer 6. + +`line numbers' + Line numbers (*note Line Numbers::) may be included in the + environment as frame entries to indicate the line number on which + a function is defined. They are ignored for variable lookup. + + #<line 8> + +`miscellaneous' + Debugging information is stored in environments in a plist format: + Any exact integer stored as an environment frame may be followed + by any value. The two frame entries are ignored when doing + variable lookup. Load file names, procedure names, and closure + documentation strings are stored in this format. + + <env-filename-marker> "foo.scm" <env-procedure-name-marker> foo ... + + Currently <env-filename-marker> is the integer 1 and + <env-procedure-name-marker> the integer 2. + + - Special Form: @apply procedure argument-list + Returns the result of applying PROCEDURE to ARGUMENT-LIST. + `@apply' differs from `apply' when the identifiers bound by the + closure being applied are `set!'; setting affects ARGUMENT-LIST. + + (define lst (list 'a 'b 'c)) + (@apply (lambda (v1 v2 v3) (set! v1 (cons v2 v3))) lst) + lst => ((b . c) b c) + + Thus a mutable environment can be treated as both a list and local + bindings. + + +File: scm.info, Node: Syntactic Hooks for Hygienic Macros, Prev: Low Level Syntactic Hooks, Up: The Language + +Syntactic Hooks for Hygienic Macros +=================================== + +SCM provides a synthetic identifier type for efficient implementation of +hygienic macros (for example, `syntax-rules' *note Macros: +(r5rs)Macros.) A synthetic identifier may be inserted in Scheme code by +a macro expander in any context where a symbol would normally be used. +Collectively, symbols and synthetic identifiers are _identifiers_. + + - Function: identifier? obj + Returns `#t' if OBJ is a symbol or a synthetic identifier, and + `#f' otherwise. + +If it is necessary to distinguish between symbols and synthetic +identifiers, use the predicate `symbol?'. + +A synthetic identifier includes two data: a parent, which is an +identifier, and an environment, which is either `#f' or a lexical +environment which has been passed to a "macro expander" (a procedure +passed as an argument to `procedure->macro', +`procedure->memoizing-macro', or `procedure->syntax'). + + - Function: renamed-identifier parent env + Returns a synthetic identifier. PARENT must be an identifier, and + ENV must either be `#f' or a lexical environment passed to a macro + expander. `renamed-identifier' returns a distinct object for each + call, even if passed identical arguments. + +There is no direct way to access all of the data internal to a synthetic +identifier, those data are used during variable lookup. If a synthetic +identifier is inserted as quoted data then during macro expansion it +will be repeatedly replaced by its parent, until a symbol is obtained. + + - Function: identifier->symbol id + Returns the symbol obtained by recursively extracting the parent of + ID, which must be an identifier. + +Use of synthetic identifiers +---------------------------- + +`renamed-identifier' may be used as a replacement for `gentemp': + (define gentemp + (let ((name (string->symbol "An unlikely variable"))) + (lambda () + (renamed-identifier name #f)))) + +If an identifier returned by this version of `gentemp' is inserted in a +binding position as the name of a variable then it is guaranteed that +no other identifier (except one produced by passing the first to +`renamed-identifier') may denote that variable. If an identifier +returned by `gentemp' is inserted free, then it will denote the +top-level value bound to its parent, the symbol named "An unlikely +variable". This behavior, of course, is meant to be put to good use: + + (define top-level-foo + (procedure->memoizing-macro + (lambda (exp env) + (renamed-identifier 'foo #f)))) + +Defines a macro which may always be used to refer to the top-level +binding of `foo'. + + (define foo 'top-level) + (let ((foo 'local)) + (top-level-foo)) => top-level + +In other words, we can avoid capturing `foo'. + +If a lexical environment is passed as the second argument to +`renamed-identifier' then if the identifier is inserted free its parent +will be looked up in that environment, rather than in the top-level +environment. The use of such an identifier _must_ be restricted to the +lexical scope of its environment. + +There is another restriction imposed for implementation convenience: +Macros passing their lexical environments to `renamed-identifier' may +be lexically bound only by the special forms `let-syntax' or +`letrec-syntax'. No error is signaled if this restriction is not met, +but synthetic identifier lookup will not work properly. + +In order to maintain referential transparency it is necessary to +determine whether two identifiers have the same denotation. With +synthetic identifiers it is not necessary that two identifiers be `eq?' +in order to denote the same binding. + + - Function: identifier-equal? id1 id2 env + Returns `#t' if identifiers ID1 and ID2 denote the same binding in + lexical environment ENV, and `#f' otherwise. ENV must either be a + lexical environment passed to a macro transformer during macro + expansion or the empty list. + + For example, + (define top-level-foo? + (procedure->memoizing-macro + (let ((foo-name (renamed-identifier 'foo #f))) + (lambda (exp env) + (identifier-equal? (cadr exp) foo-name env))))) + + (top-level-foo? foo) => #t + + (let ((foo 'local)) + (top-level-foo? foo)) => #f + + - Function: @macroexpand1 expr env + If the `car' of EXPR denotes a macro in ENV, then if that macro is + a primitive, EXPR will be returned, if the macro was defined in + Scheme, then a macro expansion will be returned. If the `car' of + EXPR does not denote a macro, the `#f' is returned. + + - Function: extended-environment names values env + Returns a new environment object, equivalent to ENV, which must + either be an environment object or null, extended by one frame. + NAMES must be an identifier, or an improper list of identifiers, + usable as a formals list in a `lambda' expression. VALUES must be + a list of objects long enough to provide a binding for each of the + identifiers in NAMES. If NAMES is an identifier or an improper + list then VALS may be, respectively, any object or an improper + list of objects. + + - Special Form: syntax-quote obj + Synthetic identifiers are converted to their parent symbols by + `quote' and `quasiquote' so that literal data in macro definitions + will be properly transcribed. `syntax-quote' behaves like + `quote', but preserves synthetic identifier intact. + + - Special Form: the-macro mac + `the-macro' is the simplest of all possible macro transformers: + MAC may be a syntactic keyword (macro name) or an expression + evaluating to a macro, otherwise an error is signaled. MAC is + evaluated and returned once only, after which the same memoizied + value is returned. + + `the-macro' may be used to protect local copies of macros against + redefinition, for example: + (@let-syntax ((let (the-macro let))) + ;; code that will continue to work even if LET is redefined. + ...) + + - Special Form: renaming-transformer proc + A low-level "explicit renaming" macro facility very similar to that + proposed by W. Clinger [Exrename] is supported. Syntax may be + defined in `define-syntax', `let-syntax', and `letrec-syntax' + using `renaming-transformer' instead of `syntax-rules'. PROC + should evaluate to a procedure accepting three arguments: EXPR, + RENAME, and COMPARE. EXPR is a representation of Scheme code to + be expanded, as list structure. RENAME is a procedure accepting + an identifier and returning an identifier renamed in the + definition environment of the new syntax. COMPARE accepts two + identifiers and returns true if and only if both denote the same + binding in the usage environment of the new syntax. + + +File: scm.info, Node: Packages, Next: The Implementation, Prev: The Language, Up: Top + +Packages +******** + +* Menu: + +* Dynamic Linking:: +* Dump:: Create Fast-Booting Executables +* Numeric:: Numeric Language Extensions +* Arrays:: As in APL +* Records:: Define new aggregate data types +* I/O-Extensions:: i/o-extensions +* Posix Extensions:: posix +* Unix Extensions:: non-posix unix +* Regular Expression Pattern Matching:: regex +* Line Editing:: edit-line +* Curses:: Screen Control +* Sockets:: Cruise the Net + +* Menu: + +* Xlib: (Xlibscm). X Window Graphics. +* Hobbit: (hobbit). Scheme-to-C Compiler. + + +File: scm.info, Node: Dynamic Linking, Next: Dump, Prev: Packages, Up: Packages + +Dynamic Linking +=============== + +If SCM has been compiled with `dynl.c' then the additional properties +of load and ([SLIB]) require specified here are supported. The +`require' form is preferred. + + - Function: require feature + If the symbol FEATURE has not already been given as an argument to + `require', then the object and library files associated with + FEATURE will be dynamically-linked, and an unspecified value + returned. If FEATURE is not found in `*catalog*', then an error + is signaled. + + - Function: usr:lib lib + Returns the pathname of the C library named LIB. For example: + `(usr:lib "m")' returns `"/usr/lib/libm.a"', the path of the C + math library. + + - Function: x:lib lib + Returns the pathname of the X library named LIB. For example: + `(x:lib "X11")' returns `"/usr/X11/lib/libX11.sa"', the path of + the X11 library. + + - Function: load filename lib1 ... + In addition to the [R5RS] requirement of loading Scheme + expressions if FILENAME is a Scheme source file, `load' will also + dynamically load/link object files (produced by `compile-file', for + instance). The object-suffix need not be given to load. For + example, + + (load (in-vicinity (implementation-vicinity) "sc2")) + or (load (in-vicinity (implementation-vicinity) "sc2.o")) + or (require 'rev2-procedures) + or (require 'rev3-procedures) + + will load/link `sc2.o' if it exists. + + The LIB1 ... pathnames specify additional libraries which may be + needed for object files not produced by the Hobbit compiler. For + instance, crs is linked on Linux by + + (load (in-vicinity (implementation-vicinity) "crs.o") + (usr:lib "ncurses") (usr:lib "c")) + or (require 'curses) + + Turtlegr graphics library is linked by: + + (load (in-vicinity (implementation-vicinity) "turtlegr") + (usr:lib "X11") (usr:lib "c") (usr:lib "m")) + or (require 'turtle-graphics) + + And the string regular expression (*note Regular Expression + Pattern Matching::) package is linked by: + + (load (in-vicinity (implementation-vicinity) "rgx") (usr:lib "c")) + or + (require 'regex) + +The following functions comprise the low-level Scheme interface to +dynamic linking. See the file `Link.scm' in the SCM distribution for +an example of their use. + + - Function: dyn:link filename + FILENAME should be a string naming an "object" or "archive" file, + the result of C-compiling. The `dyn:link' procedure links and + loads FILENAME into the current SCM session. If successfull, + `dyn:link' returns a "link-token" suitable for passing as the + second argument to `dyn:call'. If not successful, `#f' is + returned. + + - Function: dyn:call name link-token + LINK-TOKEN should be the value returned by a call to `dyn:link'. + NAME should be the name of C function of no arguments defined in + the file named FILENAME which was succesfully `dyn:link'ed in the + current SCM session. The `dyn:call' procedure calls the C + function corresponding to NAME. If successful, `dyn:call' returns + `#t'; If not successful, `#f' is returned. + + `dyn:call' is used to call the "init_..." function after loading + SCM object files. The init_... function then makes the + identifiers defined in the file accessible as Scheme procedures. + + - Function: dyn:main-call name link-token arg1 ... + LINK-TOKEN should be the value returned by a call to `dyn:link'. + NAME should be the name of C function of 2 arguments, `(int argc, + char **argv)', defined in the file named FILENAME which was + succesfully `dyn:link'ed in the current SCM session. The + `dyn:main-call' procedure calls the C function corresponding to + NAME with `argv' style arguments, such as are given to C `main' + functions. If successful, `dyn:main-call' returns the integer + returned from the call to NAME. + + `dyn:main-call' can be used to call a `main' procedure from SCM. + For example, I link in and `dyn:main-call' a large C program, the + low level routines of which callback (*note Callbacks::) into SCM + (which emulates PCI hardware). + + - Function: dyn:unlink link-token + LINK-TOKEN should be the value returned by a call to `dyn:link'. + The `dyn:unlink' procedure removes the previously loaded file from + the current SCM session. If successful, `dyn:unlink' returns + `#t'; If not successful, `#f' is returned. + + +File: scm.info, Node: Dump, Next: Numeric, Prev: Dynamic Linking, Up: Packages + +Dump +==== + +"Dump", (also known as "unexec"), saves the continuation of an entire +SCM session to an executable file, which can then be invoked as a +program. Dumped executables start very quickly, since no Scheme code +has to be loaded. + +There are constraints on which sessions are savable using `dump' + + * Saved continuations are invalid in subsequent invocations; they + cause segmentation faults and other unpleasant side effects. + + * Although DLD (*note Dynamic Linking::) can be used to load compiled + modules both before and after dumping, `SUN_DL' ELF systems can + load compiled modules only after dumping. This can be worked + around by compiling in those features you wish to `dump'. + + * Ports (other than `current-input-port', `current-output-port', + `current-error-port'), X windows, etc. are invalid in subsequent + invocations. + + This restriction could be removed; *Note Improvements To Make::. + + * `Dump' should only be called from a loading file when the call to + dump is the last expression in that file. + + * `Dump' can be called from the command line. + + - Function: dump newpath + - Function: dump newpath #f + - Function: dump newpath #t + - Function: dump newpath thunk + * Calls `gc'. + + * Creates an executable program named NEWPATH which continues + the state of the current SCM session when invoked. The + optional argument THUNK, if provided, should be a procedure + of no arguments; BOOT-TAIL will be set to this procedure, + causing it to be called in the restored executable. + + If the optional argument is missing or a boolean, SCM's + standard command line processing will be called in the + restored executable. + + If the second argument to `dump' is `#t', argument processing + will continue from the command line passed to the dumping + session. If the second argument is missing or `#f' then the + command line arguments of the restoring invocation will be + processed. + + * Resumes the top level Read-Eval-Print loop. This is done + instead of continuing normally to avoid creating a saved + continuation in the dumped executable. + + `dump' may set the values of `boot-tail', `*argv*', `restart', and + *INTERACTIVE*. `dump' returns an unspecified value. + +When a dumped executable is invoked, the variable *INTERACTIVE* (*note +Internal State::) has the value it possessed when `dump' created it. +Calling `dump' with a single argument sets *INTERACTIVE* to `#f', which +is the state it has at the beginning of command line processing. + +The procedure `program-arguments' returns the command line arguments +for the curent invocation. More specifically, `program-arguments' for +the restored session are _not_ saved from the dumping session. Command +line processing is done on the value of the identifier `*argv*'. + +The following example shows how to create `rscm', which is like regular +scm, but which loads faster and has the `random' package alreadly +provided. + + bash$ scm -rrandom + > (dump "rscm") + #<unspecified> + > (quit) + bash$ ./rscm -lpi.scm -e"(pi (random 200) 5)" + 00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 + 37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 + 70679 82148 08651 32823 06647 09384 46095 50582 23172 53594 + 08128 48111 74502 84102 70193 85211 05559 64462 29489 + bash$ + +This task can also be accomplished using the `-o' command line option +(*note SCM Options::). + + bash$ scm -rrandom -o rscm + > (quit) + bash$ ./rscm -lpi.scm -e"(pi (random 200) 5)" + 00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 + 37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 + 70679 82148 08651 32823 06647 09384 46095 50582 23172 53594 + 08128 48111 74502 84102 70193 85211 05559 64462 29489 + bash$ + + +File: scm.info, Node: Numeric, Next: Arrays, Prev: Dump, Up: Packages + +Numeric +======= + + - Constant: most-positive-fixnum + The immediate integer closest to positive infinity. *Note + Configuration: (slib)Configuration. + + - Constant: most-negative-fixnum + The immediate integer closest to negative infinity. + + - Constant: $pi + - Constant: pi + The ratio of the circumference to the diameter of a circle. + +These procedures augment the standard capabilities in *Note Numerical +operations: (r5rs)Numerical operations. + + - Function: pi* z + `(* pi Z)' + + - Function: pi/ z + `(/ pi Z)' + + - Function: sinh z + - Function: cosh z + - Function: tanh z + Return the hyperbolic sine, cosine, and tangent of Z + + - Function: asinh z + - Function: acosh z + - Function: atanh z + Return the inverse hyperbolic sine, cosine, and tangent of Z + + - Function: $sqrt x + - Function: $abs x + - Function: $exp x + - Function: $log x + - Function: $sin x + - Function: $cos x + - Function: $tan x + - Function: $asin x + - Function: $acos x + - Function: $atan x + - Function: $sinh x + - Function: $cosh x + - Function: $tanh x + - Function: $asinh x + - Function: $acosh x + - Function: $atanh x + Real-only versions of these popular functions. The argument X + must be a real number. It is an error if the value which should be + returned by a call to these procedures is _not_ real. + + - Function: $log10 x + Real-only base 10 logarithm. + + - Function: $atan2 y x + Computes `(angle (make-rectangular x y))' for real numbers Y and X. + + - Function: $expt x1 x2 + Returns real number X1 raised to the real power X2. It is an + error if the value which should be returned by a call to `$expt' + is not real. + + +File: scm.info, Node: Arrays, Next: Records, Prev: Numeric, Up: Packages + +Arrays +====== + +* Menu: + +* Conventional Arrays:: +* Array Mapping:: array-for-each +* Uniform Array:: +* Bit Vectors:: + + +File: scm.info, Node: Conventional Arrays, Next: Array Mapping, Prev: Arrays, Up: Arrays + +Conventional Arrays +------------------- + +"Arrays" read and write as a `#' followed by the "rank" (number of +dimensions) followed by the character #\a or #\A and what appear as +lists (of lists) of elements. The lists must be nested to the depth of +the rank. For each depth, all lists must be the same length. + (make-array 'ho 3 3) => + #2A((ho ho ho) (ho ho ho) (ho ho ho)) + +The rank may be elided, in which case it is read as one. + '#A(a b c) == '#(a b c) + +Unshared conventional (not uniform) 0-based arrays of rank 1 (dimension) +are equivalent to (and can't be distinguished from) vectors. + (make-array 'ho 3) => #(ho ho ho) + +When constructing an array, BOUND is either an inclusive range of +indices expressed as a two element list, or an upper bound expressed as +a single integer. So + (make-array 'foo 3 3) == (make-array 'foo '(0 2) '(0 2)) + + - Function: array? obj + Returns `#t' if the OBJ is an array, and `#f' if not. + + - Function: make-array initial-value bound1 bound2 ... + Creates and returns an array that has as many dimensions as there + are BOUNDs and fills it with INITIAL-VALUE. + + - Function: array-ref array index1 index2 ... + Returns the INDEX1, INDEX2, ...'th element of ARRAY. + + - Function: array-in-bounds? array index1 index2 ... + Returns `#t' if its arguments would be acceptable to ARRAY-REF. + + - Function: array-set! array new-value index1 index2 ... + Sets the INDEX1, INDEX2, ...'th element of ARRAY to NEW-VALUE. + The value returned by `array-set!' is unspecified. + + - Function: make-shared-array array mapper bound1 bound2 ... + `make-shared-array' can be used to create shared subarrays of other + arrays. The MAPPER is a function that translates coordinates in + the new array into coordinates in the old array. A MAPPER must be + linear, and its range must stay within the bounds of the old + array, but it can be otherwise arbitrary. A simple example: + (define fred (make-array #f 8 8)) + (define freds-diagonal + (make-shared-array fred (lambda (i) (list i i)) 8)) + (array-set! freds-diagonal 'foo 3) + (array-ref fred 3 3) => foo + (define freds-center + (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) + (array-ref freds-center 0 0) => foo + + - Function: transpose-array array dim0 dim1 ... + Returns an array sharing contents with ARRAY, but with dimensions + arranged in a different order. There must be one DIM argument for + each dimension of ARRAY. DIM0, DIM1, ... should be integers + between 0 and the rank of the array to be returned. Each integer + in that range must appear at least once in the argument list. + + The values of DIM0, DIM1, ... correspond to dimensions in the + array to be returned, their positions in the argument list to + dimensions of ARRAY. Several DIMs may have the same value, in + which case the returned array will have smaller rank than ARRAY. + + examples: + (transpose-array '#2A((a b) (c d)) 1 0) => #2A((a c) (b d)) + (transpose-array '#2A((a b) (c d)) 0 0) => #1A(a d) + (transpose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) => + #2A((a 4) (b 5) (c 6)) + + - Function: enclose-array array dim0 dim1 ... + DIM0, DIM1 ... should be nonnegative integers less than the rank + of ARRAY. ENCLOSE-ARRAY returns an array resembling an array of + shared arrays. The dimensions of each shared array are the same + as the DIMth dimensions of the original array, the dimensions of + the outer array are the same as those of the original array that + did not match a DIM. + + An enclosed array is not a general Scheme array. Its elements may + not be set using `array-set!'. Two references to the same element + of an enclosed array will be `equal?' but will not in general be + `eq?'. The value returned by ARRAY-PROTOTYPE when given an + enclosed array is unspecified. + + examples: + (enclose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) => + #<enclosed-array (#1A(a d) #1A(b e) #1A(c f)) (#1A(1 4) #1A(2 5) #1A(3 6))> + + (enclose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) => + #<enclosed-array #2A((a 1) (d 4)) #2A((b 2) (e 5)) #2A((c 3) (f 6))> + + - Function: array-shape array + Returns a list of inclusive bounds of integers. + (array-shape (make-array 'foo '(-1 3) 5)) => ((-1 3) (0 4)) + + - Function: array-dimensions array + `Array-dimensions' is similar to `array-shape' but replaces + elements with a `0' minimum with one greater than the maximum. So: + (array-dimensions (make-array 'foo '(-1 3) 5)) => ((-1 3) 5) + + - Function: array-rank obj + Returns the number of dimensions of OBJ. If OBJ is not an array, + `0' is returned. + + - Function: array->list array + Returns a list consisting of all the elements, in order, of ARRAY. + In the case of a rank-0 array, returns the single element. + + - Function: array-copy! source destination + Copies every element from vector or array SOURCE to the + corresponding element of DESTINATION. DESTINATION must have the + same rank as SOURCE, and be at least as large in each dimension. + The order of copying is unspecified. + + - Function: serial-array-copy! source destination + Same as `array-copy!' but guaranteed to copy in row-major order. + + - Function: array-fill! array fill + Stores FILL in every element of ARRAY. The value returned is + unspecified. + + - Function: array-equal? array0 array1 ... + Returns `#t' iff all arguments are arrays with the same shape, the + same type, and have corresponding elements which are either + `equal?' or `array-equal?'. This function differs from `equal?' + in that a one dimensional shared array may be ARRAY-EQUAL? but not + EQUAL? to a vector or uniform vector. + + - Function: array-contents array + - Function: array-contents array strict + If ARRAY may be "unrolled" into a one dimensional shared array + without changing their order (last subscript changing fastest), + then `array-contents' returns that shared array, otherwise it + returns `#f'. All arrays made by MAKE-ARRAY and CREATE-ARRAY may + be unrolled, some arrays made by MAKE-SHARED-ARRAY may not be. + + If the optional argument STRICT is provided, a shared array will + be returned only if its elements are stored internally contiguous + in memory. + + +File: scm.info, Node: Array Mapping, Next: Uniform Array, Prev: Conventional Arrays, Up: Arrays + +Array Mapping +------------- + +`(require 'array-for-each)' + + - Function: array-map! array0 proc array1 ... + If ARRAY1, ... are arrays, they must have the same number of + dimensions as ARRAY0 and have a range for each index which + includes the range for the corresponding index in ARRAY0. If they + are scalars, that is, not arrays, vectors, or strings, then they + will be converted internally to arrays of the appropriate shape. + PROC is applied to each tuple of elements of ARRAY1 ... and the + result is stored as the corresponding element in ARRAY0. The + value returned is unspecified. The order of application is + unspecified. + + + - Function: serial-array-map! array0 proc array1 ... + Same as ARRAY-MAP!, but guaranteed to apply PROC in row-major + order. + + - Function: array-for-each proc array0 ... + PROC is applied to each tuple of elements of ARRAY0 ... in + row-major order. The value returned is unspecified. + + - Function: array-index-map! array proc + applies PROC to the indices of each element of ARRAY in turn, + storing the result in the corresponding element. The value + returned and the order of application are unspecified. + + One can implement ARRAY-INDEXES as + (define (array-indexes array) + (let ((ra (apply make-array #f (array-shape array)))) + (array-index-map! ra (lambda x x)) + ra)) + Another example: + (define (apl:index-generator n) + (let ((v (make-vector n 1))) + (array-index-map! v (lambda (i) i)) + v)) + + - Function: scalar->array scalar array prototype + Returns a uniform array of the same shape as ARRAY, having only + one shared element, which is `eqv?' to SCALAR. If the optional + argument PROTOTYPE is supplied it will be used as the prototype + for the returned array. Otherwise the returned array will be of + the same type as `array' if that is possible, and a conventional + array if it is not. This function is used internally by + `array-map!' and friends to handle scalar arguments. + + +File: scm.info, Node: Uniform Array, Next: Bit Vectors, Prev: Array Mapping, Up: Arrays + +Uniform Array +------------- + +"Uniform Arrays" and vectors are arrays whose elements are all of the +same type. Uniform vectors occupy less storage than conventional +vectors. Uniform Array procedures also work on vectors, +uniform-vectors, bit-vectors, and strings. + +SLIB now supports uniform arrys. The primary array creation procedure +is `create-array', detailed in *Note Arrays: (slib)Arrays. + +Unshared uniform character 0-based arrays of rank 1 (dimension) are +equivalent to (and can't be distinguished from) strings. + (create-array "" 3) => "$q2" + +Unshared uniform boolean 0-based arrays of rank 1 (dimension) are +equivalent to (and can't be distinguished from) *Note bit-vectors: Bit +Vectors. + (create-array '#at() 3) => #*000 + == + #At(#f #f #f) => #*000 + == + #1At(#f #f #f) => #*000 + +PROTOTYPE arguments in the following procedures are interpreted +according to the table: + + prototype type display prefix + + () conventional vector #a + +64i complex (double precision) #ac64 + 64.0 double (double precision) #ar64 + 32.0 float (single precision) #ar32 + 32 unsigned integer (32-bit) #au32 + -32 signed integer (32-bit) #as32 + -16 signed integer (16-bit) #as16 + #\a char (string) #a\ + #t boolean (bit-vector) #at + +Other uniform vectors are written in a form similar to that of general +arrays, except that one or more modifying characters are put between the +#\A character and the contents list. For example, `'#As32(3 5 9)' +returns a uniform vector of signed integers. + + - Function: array? obj prototype + Returns `#t' if the OBJ is an array of type corresponding to + PROTOTYPE, and `#f' if not. + + - Function: array-prototype array + Returns an object that would produce an array of the same type as + ARRAY, if used as the PROTOTYPE for `list->uniform-array'. + + - Function: list->uniform-array rank prot lst + Returns a uniform array of the type indicated by prototype PROT + with elements the same as those of LST. Elements must be of the + appropriate type, no coercions are done. + + In, for example, the case of a rank-2 array, LST must be a list of + lists, all of the same length. The length of LST will be the + first dimension of the result array, and the length of each + element the second dimension. + + If RANK is zero, LST, which need not be a list, is the single + element of the returned array. + + - Function: uniform-vector-fill! uve fill + Stores FILL in every element of UVE. The value returned is + unspecified. + + - Function: dimensions->uniform-array dims prototype fill + - Function: dimensions->uniform-array dims prototype + Creates and returns a uniform array or vector of type + corresponding to PROTOTYPE with dimensions DIMS or length LENGTH. + If the FILL argument is supplied, the returned array is filled with + this value. + + - Function: uniform-array-read! ura + - Function: uniform-array-read! ura port + Attempts to read all elements of URA, in lexicographic order, as + binary objects from PORT. If an end of file is encountered during + uniform-array-read! the objects up to that point only are put into + URA (starting at the beginning) and the remainder of the array is + unchanged. + + `uniform-array-read!' returns the number of objects read. PORT + may be omitted, in which case it defaults to the value returned by + `(current-input-port)'. + + - Function: uniform-array-write ura + - Function: uniform-array-write ura port + Writes all elements of URA as binary objects to PORT. The number + of of objects actually written is returned. PORT may be omitted, + in which case it defaults to the value returned by + `(current-output-port)'. + + - Function: logaref array index1 index2 ... + If an INDEX is provided for each dimension of ARRAY returns the + INDEX1, INDEX2, ...'th element of ARRAY. If one more INDEX is + provided, then the last index specifies bit position of the + twos-complement representation of the array element indexed by the + other INDEXs returning `#t' if the bit is 1, and `#f' if 0. It is + an error if this element is not an exact integer. + + (logaref '#(#b1101 #b0010) 0) => #b1101 + (logaref '#(#b1101 #b0010) 0 1) => #f + (logaref '#2((#b1101 #b0010)) 0 0) => #b1101 + + - Function: logaset! array val index1 index2 ... + If an INDEX is provided for each dimension of ARRAY sets the + INDEX1, INDEX2, ...'th element of ARRAY to VAL. If one more INDEX + is provided, then the last index specifies bit position of the + twos-complement representation of an exact integer array element, + setting the bit to 1 if VAL is `#t' and to 0 if VAL is `#f'. In + this case it is an error if the array element is not an exact + integer or if VAL is not boolean. + + +File: scm.info, Node: Bit Vectors, Prev: Uniform Array, Up: Arrays + +Bit Vectors +----------- + +Bit vectors can be written and read as a sequence of `0's and `1's +prefixed by `#*'. + + #At(#f #f #f #t #f #t #f) => #*0001010 + +Some of these operations will eventually be generalized to other +uniform-arrays. + + - Function: bit-count bool bv + Returns the number occurrences of BOOL in BV. + + - Function: bit-position bool bv k + Returns the minimum index of an occurrence of BOOL in BV which is + at least K. If no BOOL occurs within the specified range `#f' is + returned. + + - Function: bit-invert! bv + Modifies BV by replacing each element with its negation. + + - Function: bit-set*! bv uve bool + If uve is a bit-vector BV and uve must be of the same length. If + BOOL is `#t', uve is OR'ed into BV; If BOOL is `#f', the inversion + of uve is AND'ed into BV. + + If uve is a unsigned integer vector all the elements of uve must be + between 0 and the `LENGTH' of BV. The bits of BV corresponding to + the indexes in uve are set to BOOL. + + The return value is unspecified. + + - Function: bit-count* bv uve bool + Returns + (bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). + BV is not modified. + + +File: scm.info, Node: Records, Next: I/O-Extensions, Prev: Arrays, Up: Packages + +Records +======= + +SCM provides user-definable datatypes with the same interface as SLIB, +see *Note Records: (slib)Records, with the following extension. + + - Function: record-printer-set! rtd printer + Causes records of type RTD to be printed in a user-specified + format. RTD must be a record type descriptor returned by + `make-record-type', PRINTER a procedure accepting three arguments: + the record to be printed, the port to print to, and a boolean + which is true if the record is being written on behalf of `write' + and false if for `display'. If PRINTER returns #f, the default + record printer will be called. + + A PRINTER value of #f means use the default printer. + + Only the default printer will be used when printing error messages. + + +File: scm.info, Node: I/O-Extensions, Next: Posix Extensions, Prev: Records, Up: Packages + +I/O-Extensions +============== + +If `'i/o-extensions' is provided (by linking in `ioext.o'), *Note Line +I/O: (slib)Line I/O, and the following functions are defined: + + - Function: stat <port-or-string> + Returns a vector of integers describing the argument. The argument + can be either a string or an open input port. If the argument is + an open port then the returned vector describes the file to which + the port is opened; If the argument is a string then the returned + vector describes the file named by that string. If there exists + no file with the name string, or if the file cannot be accessed + `#f' is returned. The elements of the returned vector are as + follows: + + 0 st_dev + ID of device containing a directory entry for this file + + 1 st_ino + Inode number + + 2 st_mode + File type, attributes, and access control summary + + 3 st_nlink + Number of links + + 4 st_uid + User ID of file owner + + 5 st_gid + Group ID of file group + + 6 st_rdev + Device ID; this entry defined only for char or blk spec files + + 7 st_size + File size (bytes) + + 8 st_atime + Time of last access + + 9 st_mtime + Last modification time + + 10 st_ctime + Last file status change time + + - Function: getpid + Returns the process ID of the current process. + + - Function: file-position port + Returns the current position of the character in PORT which will + next be read or written. If PORT is not open to a file the result + is unspecified. + + - Function: file-set-position port integer + Sets the current position in PORT which will next be read or + written. If PORT is not open to a file the action of + `file-set-position' is unspecified. The result of + `file-set-position' is unspecified. + + - Function: try-create-file name modes perms + If the file with name NAME already exists, return `#f', otherwise + try to create and open the file like `try-open-file', *Note Files + and Ports::. If the optional integer argument PERMS is provided, + it is used as the permissions of the new file (modified by the + current umask). + + - Function: reopen-file filename modes port + Closes port PORT and reopens it with FILENAME and MODES. + `reopen-file' returns `#t' if successful, `#f' if not. + + - Function: duplicate-port port modes + Creates and returns a "duplicate" port from PORT. Duplicate + _unbuffered_ ports share one file position. MODES are as for + *Note open-file: Files and Ports. + + - Function: redirect-port! from-port to-port + Closes TO-PORT and makes TO-PORT be a duplicate of FROM-PORT. + `redirect-port!' returns TO-PORT if successful, `#f' if not. If + unsuccessful, TO-PORT is not closed. + + - Function: opendir dirname + Returns a "directory" object corresponding to the file system + directory named DIRNAME. If unsuccessful, returns `#f'. + + - Function: readdir dir + Returns the string name of the next entry from the directory DIR. + If there are no more entries in the directory, `readdir' returns a + `#f'. + + - Function: rewinddir dir + Reinitializes DIR so that the next call to `readdir' with DIR will + return the first entry in the directory again. + + - Function: closedir dir + Closes DIR and returns `#t'. If DIR is already closed,, + `closedir' returns a `#f'. + + - Function: directory-for-each proc directory + The LISTs must be lists, and PROC must be a procedure taking one + argument. `Directory-For-Each' applies PROC to the (string) name + of each file in DIRECTORY. The dynamic order in which PROC is + applied to the elements of the LISTs is unspecified. The value + returned by `directory-for-each' is unspecified. + + - Function: directory-for-each proc directory pred + Applies PROC only to those filenames for which the procedure PRED + returns a non-false value. + + - Function: directory-for-each proc directory match + Applies PROC only to those filenames for which `(filename:match?? + MATCH)' would return a non-false value (*note Filenames: + (slib)Filenames.). + + (require 'directory-for-each) + (directory-for-each print "." "[A-Z]*.scm") + -| + "Init.scm" + "Iedline.scm" + "Link.scm" + "Macro.scm" + "Transcen.scm" + "Init5d6.scm" + + - Function: mkdir path mode + The `mkdir' function creates a new, empty directory whose name is + PATH. The integer argument MODE specifies the file permissions + for the new directory. *Note The Mode Bits for Access Permission: + (libc)The Mode Bits for Access Permission, for more information + about this. + + `mkdir' returns if successful, `#f' if not. + + - Function: rmdir path + The `rmdir' function deletes the directory PATH. The directory + must be empty before it can be removed. `rmdir' returns if + successful, `#f' if not. + + - Function: chdir filename + Changes the current directory to FILENAME. If FILENAME does not + exist or is not a directory, `#f' is returned. Otherwise, `#t' is + returned. + + - Function: getcwd + The function `getcwd' returns a string containing the absolute file + name representing the current working directory. If this string + cannot be obtained, `#f' is returned. + + - Function: rename-file oldfilename newfilename + Renames the file specified by OLDFILENAME to NEWFILENAME. If the + renaming is successful, `#t' is returned. Otherwise, `#f' is + returned. + + - Function: chmod file mode + The function `chmod' sets the access permission bits for the file + named by FILE to MODE. The FILE argument may be a string + containing the filename or a port open to the file. + + `chmod' returns if successful, `#f' if not. + + - Function: utime pathname acctime modtime + Sets the file times associated with the file named PATHNAME to + have access time ACCTIME and modification time MODTIME. `utime' + returns if successful, `#f' if not. + + - Function: umask mode + The function `umask' sets the file creation mask of the current + process to MASK, and returns the previous value of the file + creation mask. + + - Function: fileno port + Returns the integer file descriptor associated with the port PORT. + If an error is detected, `#f' is returned. + + - Function: access pathname how + Returns `#t' if the file named by PATHNAME can be accessed in the + way specified by the HOW argument. The HOW argument can be the + `logior' of the flags: + + 0. File-exists? + + 1. File-is-executable? + + 2. File-is-writable? + + 4. File-is-readable? + + Or the HOW argument can be a string of 0 to 3 of the following + characters in any order. The test performed is the `and' of the + associated tests and `file-exists?'. + + <x> + File-is-executable? + + <w> + File-is-writable? + + <r> + File-is-readable? + + - Function: execl command arg0 ... + - Function: execlp command arg0 ... + Transfers control to program COMMAND called with arguments ARG0 + .... For `execl', COMMAND must be an exact pathname of an + executable file. `execlp' searches for COMMAND in the list of + directories specified by the environment variable PATH. The + convention is that ARG0 is the same name as COMMAND. + + If successful, this procedure does not return. Otherwise an error + message is printed and the integer `errno' is returned. + + - Function: execv command arglist + - Function: execvp command arglist + Like `execl' and `execlp' except that the set of arguments to + COMMAND is ARGLIST. + + - Function: putenv string + adds or removes definitions from the "environment". If the STRING + is of the form `NAME=VALUE', the definition is added to the + environment. Otherwise, the STRING is interpreted as the name of + an environment variable, and any definition for this variable in + the environment is removed. + + Names of environment variables are case-sensitive and must not + contain the character `='. System-defined environment variables + are invariably uppercase. + + `Putenv' is used to set up the environment before calls to + `execl', `execlp', `execv', `execvp', `system', or `open-pipe' + (*note open-pipe: Posix Extensions.). + + To access environment variables, use `getenv' (*note getenv: + (slib)System Interface.). + + +File: scm.info, Node: Posix Extensions, Next: Unix Extensions, Prev: I/O-Extensions, Up: Packages + +Posix Extensions +================ + +If `'posix' is provided (by linking in `posix.o'), the following +functions are defined: + + - Function: open-pipe string modes + If the string MODES contains an <r>, returns an input port capable + of delivering characters from the standard output of the system + command STRING. Otherwise, returns an output port capable of + receiving characters which become the standard input of the system + command STRING. If a pipe cannot be created `#f' is returned. + + - Function: open-input-pipe string + Returns an input port capable of delivering characters from the + standard output of the system command STRING. If a pipe cannot be + created `#f' is returned. + + - Function: open-output-pipe string + Returns an output port capable of receiving characters which become + the standard input of the system command STRING. If a pipe cannot + be created `#f' is returned. + + - Function: broken-pipe port + If this function is defined at top level, it will be called when an + output pipe is closed from the other side (this is the condition + under which a SIGPIPE is sent). The already closed PORT will be + passed so that any necessary cleanup may be done. An error is not + signaled when output to a pipe fails in this way, but any further + output to the closed pipe will cause an error to be signaled. + + - Function: close-port pipe + Closes the PIPE, rendering it incapable of delivering or accepting + characters. This routine has no effect if the pipe has already + been closed. The value returned is unspecified. + + - Function: pipe + Returns `(cons RD WD)' where RD and WD are the read and write + (port) ends of a "pipe" respectively. + + - Function: fork + Creates a copy of the process calling `fork'. Both processes + return from `fork', but the calling ("parent") process's `fork' + returns the "child" process's ID whereas the child process's + `fork' returns 0. + +For a discussion of "ID"s *Note Process Persona: (GNU C Library)Process +Persona. + + - Function: getppid + Returns the process ID of the parent of the current process. For + a process's own ID *Note getpid: I/O-Extensions. + + - Function: getlogin + Returns the (login) name of the user logged in on the controlling + terminal of the process, or #f if this information cannot be + determined. + + - Function: getuid + Returns the real user ID of this process. + + - Function: getgid + Returns the real group ID of this process. + + - Function: getegid + Returns the effective group ID of this process. + + - Function: geteuid + Returns the effective user ID of this process. + + - Function: setuid id + Sets the real user ID of this process to ID. Returns `#t' if + successful, `#f' if not. + + - Function: setgid id + Sets the real group ID of this process to ID. Returns `#t' if + successful, `#f' if not. + + - Function: setegid id + Sets the effective group ID of this process to ID. Returns `#t' + if successful, `#f' if not. + + - Function: seteuid id + Sets the effective user ID of this process to ID. Returns `#t' if + successful, `#f' if not. + + - Function: kill pid sig + The `kill' function sends the signal SIGNUM to the process or + process group specified by PID. Besides the signals listed in + *Note Standard Signals: (libc)Standard Signals, SIGNUM can also + have a value of zero to check the validity of the PID. + + The PID specifies the process or process group to receive the + signal: + + > 0 + The process whose identifier is PID. + + 0 + All processes in the same process group as the sender. The + sender itself does not receive the signal. + + -1 + If the process is privileged, send the signal to all + processes except for some special system processes. + Otherwise, send the signal to all processes with the same + effective user ID. + + < -1 + The process group whose identifier is `(abs PID)'. + + A process can send a signal to itself with `(kill (getpid) + SIGNUM)'. If `kill' is used by a process to send a signal to + itself, and the signal is not blocked, then `kill' delivers at + least one signal (which might be some other pending unblocked + signal instead of the signal SIGNUM) to that process before it + returns. + + The return value from `kill' is zero if the signal can be sent + successfully. Otherwise, no signal is sent, and a value of `-1' is + returned. If PID specifies sending a signal to several processes, + `kill' succeeds if it can send the signal to at least one of them. + There's no way you can tell which of the processes got the signal + or whether all of them did. + + - Function: waitpid pid options + The `waitpid' function suspends execution of the current process + until a child as specified by the PID argument has exited, or + until a signal is delivered whose action is to terminate the + current process or to call a signal handling function. If a child + as requested by PID has already exited by the time of the call (a + so-called "zombie" process), the function returns immediately. + Any system resources used by the child are freed. + + The value of PID can be: + + < -1 + which means to wait for any child process whose process group + ID is equal to the absolute value of PID. + + -1 + which means to wait for any child process; this is the same + behaviour which wait exhibits. + + 0 + which means to wait for any child process whose process group + ID is equal to that of the calling process. + + > 0 + which means to wait for the child whose process ID is equal + to the value of PID. + + The value of OPTIONS is one of the following: + + 0. Nothing special. + + 1. (`WNOHANG') which means to return immediately if no child is + there to be waited for. + + 2. (`WUNTRACED') which means to also return for children which + are stopped, and whose status has not been reported. + + 3. Which means both of the above. + + The return value normally is the exit status of the child process, + including the exit value along with flags indicating whether a + coredump was generated or the child terminated as a result of a + signal. If the `WNOHANG' option was specified and no child + process is waiting to be noticed, the value is zero. A value of + `#f' is returned in case of error and `errno' is set. For + information about the `errno' codes *Note Process Completion: (GNU + C Library)Process Completion. + + - Function: uname + You can use the `uname' procedure to find out some information + about the type of computer your program is running on. + + Returns a vector of strings. These strings are: + + 0. The name of the operating system in use. + + 1. The network name of this particular computer. + + 2. The current release level of the operating system + implementation. + + 3. The current version level within the release of the operating + system. + + 4. Description of the type of hardware that is in use. + + Some examples are `"i386-ANYTHING"', `"m68k-hp"', + `"sparc-sun"', `"m68k-sun"', `"m68k-sony"' and `"mips-dec"'. + + - Function: getpw name + - Function: getpw uid + - Function: getpw + Returns a vector of information for the entry for `NAME', `UID', + or the next entry if no argument is given. The information is: + + 0. The user's login name. + + 1. The encrypted password string. + + 2. The user ID number. + + 3. The user's default group ID number. + + 4. A string typically containing the user's real name, and + possibly other information such as a phone number. + + 5. The user's home directory, initial working directory, or + `#f', in which case the interpretation is system-dependent. + + 6. The user's default shell, the initial program run when the + user logs in, or `#f', indicating that the system default + should be used. + + - Function: setpwent #t + Rewinds the pw entry table back to the begining. + + - Function: setpwent #f + - Function: setpwent + Closes the pw table. + + - Function: getgr name + - Function: getgr uid + - Function: getgr + Returns a vector of information for the entry for `NAME', `UID', + or the next entry if no argument is given. The information is: + + 0. The name of the group. + + 1. The encrypted password string. + + 2. The group ID number. + + 3. A list of (string) names of users in the group. + + - Function: setgrent #t + Rewinds the group entry table back to the begining. + + - Function: setgrent #f + - Function: setgrent + Closes the group table. + + - Function: getgroups + Returns a vector of all the supplementary group IDs of the process. + + - Function: link oldname newname + The `link' function makes a new link to the existing file named by + OLDNAME, under the new name NEWNAME. + + `link' returns a value of `#t' if it is successful and `#f' on + failure. + + - Function: chown filename owner group + The `chown' function changes the owner of the file FILENAME to + OWNER, and its group owner to GROUP. + + `chown' returns a value of `#t' if it is successful and `#f' on + failure. + + - Function: ttyname port + If port PORT is associated with a terminal device, returns a + string containing the file name of termainal device; otherwise + `#f'. + + +File: scm.info, Node: Unix Extensions, Next: Regular Expression Pattern Matching, Prev: Posix Extensions, Up: Packages + +Unix Extensions +=============== + +If `'unix' is provided (by linking in `unix.o'), the following +functions are defined: + +These "privileged" and symbolic link functions are not in Posix: + + - Function: symlink oldname newname + The `symlink' function makes a symbolic link to OLDNAME named + NEWNAME. + + `symlink' returns a value of `#t' if it is successful and `#f' on + failure. + + - Function: readlink filename + Returns the value of the symbolic link FILENAME or `#f' for + failure. + + - Function: lstat filename + The `lstat' function is like `stat', except that it does not + follow symbolic links. If FILENAME is the name of a symbolic + link, `lstat' returns information about the link itself; otherwise, + `lstat' works like `stat'. *Note I/O-Extensions::. + + - Function: nice increment + Increment the priority of the current process by INCREMENT. + `chown' returns a value of `#t' if it is successful and `#f' on + failure. + + - Function: acct filename + When called with the name of an exisitng file as argument, + accounting is turned on, records for each terminating process are + appended to FILENAME as it terminates. An argument of `#f' causes + accounting to be turned off. + + `acct' returns a value of `#t' if it is successful and `#f' on + failure. + + - Function: mknod filename mode dev + The `mknod' function makes a special file with name FILENAME and + modes MODE for device number DEV. + + `mknod' returns a value of `#t' if it is successful and `#f' on + failure. + + - Function: sync + `sync' first commits inodes to buffers, and then buffers to disk. + sync() only schedules the writes, so it may return before the + actual writing is done. The value returned is unspecified. + + +File: scm.info, Node: Regular Expression Pattern Matching, Next: Line Editing, Prev: Unix Extensions, Up: Packages + +Regular Expression Pattern Matching +=================================== + +These functions are defined in `rgx.c' using a POSIX or GNU "regex" +library. If your computer does not support regex, a package is +available via ftp from `ftp.gnu.org:/pub/gnu/regex-0.12.tar.gz'. For a +description of regular expressions, *Note syntax: (regex)syntax. + + - Function: regcomp PATTERN [FLAGS] + Compile a "regular expression". Return a compiled regular + expression, or an integer error code suitable as an argument to + `regerror'. + + FLAGS in `regcomp' is a string of option letters used to control + the compilation of the regular expression. The letters may + consist of: + + `n' + newlines won't be matched by `.' or hat lists; ( `[^...]' ) + + `i' + ignore case.only when compiled with _GNU_SOURCE: + + + `0' + allows dot to match a null character. + + `f' + enable GNU fastmaps. + + - Function: regerror ERRNO + Returns a string describing the integer ERRNO returned when + `regcomp' fails. + + - Function: regexec RE STRING + Returns `#f' or a vector of integers. These integers are in + doublets. The first of each doublet is the index of STRING of the + start of the matching expression or sub-expression (delimited by + parentheses in the pattern). The last of each doublet is index of + STRING of the end of that expression. `#f' is returned if the + string does not match. + + - Function: regmatch? RE STRING + Returns `#t' if the PATTERN such that REGEXP = (regcomp PATTERN) + matches STRING as a POSIX extended regular expressions. Returns + `#f' otherwise. + + - Function: regsearch RE STRING [START [LEN]] + - Function: regsearchv RE STRING [START [LEN]] + - Function: regmatch RE STRING [START [LEN]] + - Function: regmatchv RE STRING [START [LEN]] + `Regsearch' searches for the pattern within the string. + + `Regmatch' anchors the pattern and begins matching it against + string. + + `Regsearch' returns the character position where RE starts, or + `#f' if not found. + + `Regmatch' returns the number of characters matched, `#f' if not + matched. + + `Regsearchv' and `regmatchv' return the match vector is returned + if RE is found, `#f' otherwise. + + RE + may be either: + 1. a compiled regular expression returned by `regcomp'; + + 2. a string representing a regular expression; + + 3. a list of a string and a set of option letters. + + STRING + The string to be operated upon. + + START + The character position at which to begin the search or match. + If absent, the default is zero. + + _Compiled _GNU_SOURCE and using GNU libregex only:_ + + + When searching, if START is negative, the absolute value of + START will be used as the start location and reverse searching + will be performed. + + LEN + The search is allowed to examine only the first LEN + characters of STRING. If absent, the entire string may be + examined. + + - Function: string-split RE STRING + - Function: string-splitv RE STRING + `String-split' splits a string into substrings that are separated + by RE, returning a vector of substrings. + + `String-splitv' returns a vector of string positions that indicate + where the substrings are located. + + - Function: string-edit RE EDIT-SPEC STRING [COUNT] + Returns the edited string. + + EDIT-SPEC + Is a string used to replace occurances of RE. Backquoted + integers in the range of 1-9 may be used to insert + subexpressions in RE, as in `sed'. + + COUNT + The number of substitutions for `string-edit' to perform. If + `#t', all occurances of RE will be replaced. The default is + to perform one substitution. + + +File: scm.info, Node: Line Editing, Next: Curses, Prev: Regular Expression Pattern Matching, Up: Packages + +Line Editing +============ + +These procedures provide input line editing and recall. + +These functions are defined in `edline.c' and `Iedline.scm' using the +"editline" or GNU "readline" (*note Overview: (readline)Top.) libraries +available from: + + * `ftp.sys.toronto.edu:/pub/rc/editline.shar' + + * `ftp.gnu.org:/pub/gnu/readline-2.0.tar.gz' + +When `Iedline.scm' is loaded, if the current input port is the default +input port and the environment variable EMACS is not defined, +line-editing mode will be entered. + + - Function: default-input-port + Returns the initial `current-input-port' SCM was invoked with + (stdin). + + - Function: default-output-port + Returns the initial `current-output-port' SCM was invoked with + (stdout). + + - Function: make-edited-line-port + Returns an input/output port that allows command line editing and + retrieval of history. + + - Function: line-editing + Returns the current edited line port or `#f'. + + - Function: line-editing bool + If BOOL is false, exits line-editing mode and returns the previous + value of `(line-editing)'. If BOOL is true, sets the current + input and output ports to an edited line port and returns the + previous value of `(line-editing)'. + + +File: scm.info, Node: Curses, Next: Sockets, Prev: Line Editing, Up: Packages + +Curses +====== + +These functions are defined in `crs.c' using the "curses" library. +Unless otherwise noted these routines return `#t' for successful +completion and `#f' for failure. + + - Function: initscr + Returns a port for a full screen window. This routine must be + called to initialize curses. + + - Function: endwin + A program should call `endwin' before exiting or escaping from + curses mode temporarily, to do a system call, for example. This + routine will restore termio modes, move the cursor to the lower + left corner of the screen and reset the terminal into the proper + non-visual mode. To resume after a temporary escape, call *Note + refresh: Window Manipulation. + +* Menu: + +* Output Options Setting:: +* Terminal Mode Setting:: +* Window Manipulation:: +* Output:: +* Input:: +* Curses Miscellany:: + + +File: scm.info, Node: Output Options Setting, Next: Terminal Mode Setting, Prev: Curses, Up: Curses + +Output Options Setting +---------------------- + +These routines set options within curses that deal with output. All +options are initially `#f', unless otherwise stated. It is not +necessary to turn these options off before calling `endwin'. + + - Function: clearok win bf + If enabled (BF is `#t'), the next call to `force-output' or + `refresh' with WIN will clear the screen completely and redraw the + entire screen from scratch. This is useful when the contents of + the screen are uncertain, or in some cases for a more pleasing + visual effect. + + - Function: idlok win bf + If enabled (BF is `#t'), curses will consider using the hardware + "insert/delete-line" feature of terminals so equipped. If + disabled (BF is `#f'), curses will very seldom use this feature. + The "insert/delete-character" feature is always considered. This + option should be enabled only if your application needs + "insert/delete-line", for example, for a screen editor. It is + disabled by default because + + "insert/delete-line" tends to be visually annoying when used in + applications where it is not really needed. If + "insert/delete-line" cannot be used, curses will redraw the + changed portions of all lines. + + - Function: leaveok win bf + Normally, the hardware cursor is left at the location of the window + cursor being refreshed. This option allows the cursor to be left + wherever the update happens to leave it. It is useful for + applications where the cursor is not used, since it reduces the + need for cursor motions. If possible, the cursor is made + invisible when this option is enabled. + + - Function: scrollok win bf + This option controls what happens when the cursor of window WIN is + moved off the edge of the window or scrolling region, either from a + newline on the bottom line, or typing the last character of the + last line. If disabled (BF is `#f'), the cursor is left on the + bottom line at the location where the offending character was + entered. If enabled (BF is `#t'), `force-output' is called on the + window WIN, and then the physical terminal and window WIN are + scrolled up one line. + + _Note:_ in order to get the physical scrolling effect on the + terminal, it is also necessary to call `idlok'. + + - Function: nodelay win bf + This option causes wgetch to be a non-blocking call. If no input + is ready, wgetch will return an eof-object. If disabled, wgetch + will hang until a key is pressed. + + +File: scm.info, Node: Terminal Mode Setting, Next: Window Manipulation, Prev: Output Options Setting, Up: Curses + +Terminal Mode Setting +--------------------- + +These routines set options within curses that deal with input. The +options involve using ioctl(2) and therefore interact with curses +routines. It is not necessary to turn these options off before calling +`endwin'. The routines in this section all return an unspecified value. + + - Function: cbreak + - Function: nocbreak + These two routines put the terminal into and out of `CBREAK' mode, + respectively. In `CBREAK' mode, characters typed by the user are + immediately available to the program and erase/kill character + processing is not performed. When in `NOCBREAK' mode, the tty + driver will buffer characters typed until a <LFD> or <RET> is + typed. Interrupt and flowcontrol characters are unaffected by + this mode. Initially the terminal may or may not be in `CBREAK' + mode, as it is inherited, therefore, a program should call + `cbreak' or `nocbreak' explicitly. Most interactive programs + using curses will set `CBREAK' mode. + + _Note:_ `cbreak' overrides `raw'. For a discussion of how these + routines interact with `echo' and `noecho' *Note read-char: Input. + + - Function: raw + - Function: noraw + The terminal is placed into or out of `RAW' mode. `RAW' mode is + similar to `CBREAK' mode, in that characters typed are immediately + passed through to the user program. The differences are that in + `RAW' mode, the interrupt, quit, suspend, and flow control + characters are passed through uninterpreted, instead of generating + a signal. `RAW' mode also causes 8-bit input and output. The + behavior of the `BREAK' key depends on other bits in the terminal + driver that are not set by curses. + + - Function: echo + - Function: noecho + These routines control whether characters typed by the user are + echoed by `read-char' as they are typed. Echoing by the tty + driver is always disabled, but initially `read-char' is in `ECHO' + mode, so characters typed are echoed. Authors of most interactive + programs prefer to do their own echoing in a controlled area of + the screen, or not to echo at all, so they disable echoing by + calling `noecho'. For a discussion of how these routines interact + with `echo' and `noecho' *Note read-char: Input. + + - Function: nl + - Function: nonl + These routines control whether <LFD> is translated into <RET> and + `LFD' on output, and whether <RET> is translated into <LFD> on + input. Initially, the translations do occur. By disabling these + translations using `nonl', curses is able to make better use of + the linefeed capability, resulting in faster cursor motion. + + - Function: resetty + - Function: savetty + These routines save and restore the state of the terminal modes. + `savetty' saves the current state of the terminal in a buffer and + `resetty' restores the state to what it was at the last call to + `savetty'. + + +File: scm.info, Node: Window Manipulation, Next: Output, Prev: Terminal Mode Setting, Up: Curses + +Window Manipulation +------------------- + + - Function: newwin nlines ncols begy begx + Create and return a new window with the given number of lines (or + rows), NLINES, and columns, NCOLS. The upper left corner of the + window is at line BEGY, column BEGX. If either NLINES or NCOLS is + 0, they will be set to the value of `LINES'-BEGY and `COLS'-BEGX. + A new full-screen window is created by calling `newwin(0,0,0,0)'. + + - Function: subwin orig nlines ncols begy begx + Create and return a pointer to a new window with the given number + of lines (or rows), NLINES, and columns, NCOLS. The window is at + position (BEGY, BEGX) on the screen. This position is relative to + the screen, and not to the window ORIG. The window is made in the + middle of the window ORIG, so that changes made to one window will + affect both windows. When using this routine, often it will be + necessary to call `touchwin' or `touchline' on ORIG before calling + `force-output'. + + - Function: close-port win + Deletes the window WIN, freeing up all memory associated with it. + In the case of sub-windows, they should be deleted before the main + window WIN. + + - Function: refresh + - Function: force-output win + These routines are called to write output to the terminal, as most + other routines merely manipulate data structures. `force-output' + copies the window WIN to the physical terminal screen, taking into + account what is already there in order to minimize the amount of + information that's sent to the terminal (called optimization). + Unless `leaveok' has been enabled, the physical cursor of the + terminal is left at the location of window WIN's cursor. With + `refresh', the number of characters output to the terminal is + returned. + + - Function: mvwin win y x + Move the window WIN so that the upper left corner will be at + position (Y, X). If the move would cause the window WIN to be off + the screen, it is an error and the window WIN is not moved. + + - Function: overlay srcwin dstwin + - Function: overwrite srcwin dstwin + These routines overlay SRCWIN on top of DSTWIN; that is, all text + in SRCWIN is copied into DSTWIN. SRCWIN and DSTWIN need not be + the same size; only text where the two windows overlap is copied. + The difference is that `overlay' is non-destructive (blanks are + not copied), while `overwrite' is destructive. + + - Function: touchwin win + - Function: touchline win start count + Throw away all optimization information about which parts of the + window WIN have been touched, by pretending that the entire window + WIN has been drawn on. This is sometimes necessary when using + overlapping windows, since a change to one window will affect the + other window, but the records of which lines have been changed in + the other window will not reflect the change. `touchline' only + pretends that COUNT lines have been changed, beginning with line + START. + + - Function: wmove win y x + The cursor associated with the window WIN is moved to line (row) Y, + column X. This does not move the physical cursor of the terminal + until `refresh' (or `force-output') is called. The position + specified is relative to the upper left corner of the window WIN, + which is (0, 0). + + +File: scm.info, Node: Output, Next: Input, Prev: Window Manipulation, Up: Curses + +Output +------ + +These routines are used to "draw" text on windows + + - Function: display ch win + - Function: display str win + - Function: wadd win ch + - Function: wadd win str + The character CH or characters in STR are put into the window WIN + at the current cursor position of the window and the position of + WIN's cursor is advanced. At the right margin, an automatic + newline is performed. At the bottom of the scrolling region, if + scrollok is enabled, the scrolling region will be scrolled up one + line. + + If CH is a <TAB>, <LFD>, or backspace, the cursor will be moved + appropriately within the window WIN. A <LFD> also does a + `wclrtoeol' before moving. <TAB> characters are considered to be + at every eighth column. If CH is another control character, it + will be drawn in the `C-x' notation. (Calling `winch' after + adding a control character will not return the control character, + but instead will return the representation of the control + character.) + + Video attributes can be combined with a character by or-ing them + into the parameter. This will result in these attributes also + being set. The intent here is that text, including attributes, + can be copied from one place to another using inch and display. + See `standout', below. + + _Note:_ For `wadd' CH can be an integer and will insert the + character of the corresponding value. + + - Function: werase win + This routine copies blanks to every position in the window WIN. + + - Function: wclear win + This routine is like `werase', but it also calls *Note clearok: + Output Options Setting, arranging that the screen will be cleared + completely on the next call to `refresh' or `force-output' for + window WIN, and repainted from scratch. + + - Function: wclrtobot win + All lines below the cursor in window WIN are erased. Also, the + current line to the right of the cursor, inclusive, is erased. + + - Function: wclrtoeol win + The current line to the right of the cursor, inclusive, is erased. + + - Function: wdelch win + The character under the cursor in the window WIN is deleted. All + characters to the right on the same line are moved to the left one + position and the last character on the line is filled with a + blank. The cursor position does not change. This does not imply + use of the hardware "delete-character" feature. + + - Function: wdeleteln win + The line under the cursor in the window WIN is deleted. All lines + below the current line are moved up one line. The bottom line WIN + is cleared. The cursor position does not change. This does not + imply use of the hardware "deleteline" feature. + + - Function: winsch win ch + The character CH is inserted before the character under the + cursor. All characters to the right are moved one <SPC> to the + right, possibly losing the rightmost character of the line. The + cursor position does not change . This does not imply use of the + hardware "insertcharacter" feature. + + - Function: winsertln win + A blank line is inserted above the current line and the bottom + line is lost. This does not imply use of the hardware + "insert-line" feature. + + - Function: scroll win + The window WIN is scrolled up one line. This involves moving the + lines in WIN's data structure. As an optimization, if WIN is + stdscr and the scrolling region is the entire window, the physical + screen will be scrolled at the same time. + + +File: scm.info, Node: Input, Next: Curses Miscellany, Prev: Output, Up: Curses + +Input +----- + + - Function: read-char win + A character is read from the terminal associated with the window + WIN. Depending on the setting of `cbreak', this will be after one + character (`CBREAK' mode), or after the first newline (`NOCBREAK' + mode). Unless `noecho' has been set, the character will also be + echoed into WIN. + + When using `read-char', do not set both `NOCBREAK' mode + (`nocbreak') and `ECHO' mode (`echo') at the same time. Depending + on the state of the terminal driver when each character is typed, + the program may produce undesirable results. + + - Function: winch win + The character, of type chtype, at the current position in window + WIN is returned. If any attributes are set for that position, + their values will be OR'ed into the value returned. + + - Function: getyx win + A list of the y and x coordinates of the cursor position of the + window WIN is returned + + +File: scm.info, Node: Curses Miscellany, Prev: Input, Up: Curses + +Curses Miscellany +----------------- + + - Function: wstandout win + - Function: wstandend win + These functions set the current attributes of the window WIN. The + current attributes of WIN are applied to all characters that are + written into it. Attributes are a property of the character, and + move with the character through any scrolling and insert/delete + line/character operations. To the extent possible on the + particular terminal, they will be displayed as the graphic + rendition of characters put on the screen. + + `wstandout' sets the current attributes of the window WIN to be + visibly different from other text. `wstandend' turns off the + attributes. + + - Function: box win vertch horch + A box is drawn around the edge of the window WIN. VERTCH and + HORCH are the characters the box is to be drawn with. If VERTCH + and HORCH are 0, then appropriate default characters, `ACS_VLINE' + and `ACS_HLINE', will be used. + + _Note:_ VERTCH and HORCH can be an integers and will insert the + character (with attributes) of the corresponding values. + + - Function: unctrl c + This macro expands to a character string which is a printable + representation of the character C. Control characters are + displayed in the `C-x' notation. Printing characters are displayed + as is. + + +File: scm.info, Node: Sockets, Prev: Curses, Up: Packages + +Sockets +======= + +These procedures (defined in `socket.c') provide a Scheme interface to +most of the C "socket" library. For more information on sockets, *Note +Sockets: (libc)Sockets. + +* Menu: + +* Host Data:: +* Internet Addresses and Socket Names:: +* Socket:: + + +File: scm.info, Node: Host Data, Next: Internet Addresses and Socket Names, Prev: Sockets, Up: Sockets + +Host Data, Network, Protocol, and Service Inquiries +--------------------------------------------------- + + - Constant: af_inet + - Constant: af_unix + Integer family codes for Internet and Unix sockets, respectively. + + - Function: gethost host-spec + - Function: gethost + Returns a vector of information for the entry for `HOST-SPEC' or + the next entry if `HOST-SPEC' isn't given. The information is: + + 0. host name string + + 1. list of host aliases strings + + 2. integer address type (`AF_INET') + + 3. integer size of address entries (in bytes) + + 4. list of integer addresses + + - Function: sethostent stay-open + - Function: sethostent + Rewinds the host entry table back to the begining if given an + argument. If the argument STAY-OPEN is `#f' queries will be be + done using `UDP' datagrams. Otherwise, a connected `TCP' socket + will be used. When called without an argument, the host table is + closed. + + - Function: getnet name-or-number + - Function: getnet + Returns a vector of information for the entry for NAME-OR-NUMBER or + the next entry if an argument isn't given. The information is: + + 0. official network name string + + 1. list of network aliases strings + + 2. integer network address type (`AF_INET') + + 3. integer network number + + - Function: setnetent stay-open + - Function: setnetent + Rewinds the network entry table back to the begining if given an + argument. If the argument STAY-OPEN is `#f' the table will be + closed between calls to getnet. Otherwise, the table stays open. + When called without an argument, the network table is closed. + + - Function: getproto name-or-number + - Function: getproto + Returns a vector of information for the entry for NAME-OR-NUMBER or + the next entry if an argument isn't given. The information is: + + 1. official protocol name string + + 2. list of protocol aliases strings + + 3. integer protocol number + + - Function: setprotoent stay-open + - Function: setprotoent + Rewinds the protocol entry table back to the begining if given an + argument. If the argument STAY-OPEN is `#f' the table will be + closed between calls to getproto. Otherwise, the table stays + open. When called without an argument, the protocol table is + closed. + + - Function: getserv name-or-port-number protocol + - Function: getserv + Returns a vector of information for the entry for + NAME-OR-PORT-NUMBER and PROTOCOL or the next entry if arguments + aren't given. The information is: + + 0. official service name string + + 1. list of service aliases strings + + 2. integer port number + + 3. protocol + + - Function: setservent stay-open + - Function: setservent + Rewinds the service entry table back to the begining if given an + argument. If the argument STAY-OPEN is `#f' the table will be + closed between calls to getserv. Otherwise, the table stays open. + When called without an argument, the service table is closed. + + +File: scm.info, Node: Internet Addresses and Socket Names, Next: Socket, Prev: Host Data, Up: Sockets + +Internet Addresses and Socket Names +----------------------------------- + + - Function: inet:string->address string + Returns the host address number (integer) for host STRING or `#f' + if not found. + + - Function: inet:address->string address + Converts an internet (integer) address to a string in numbers and + dots notation. + + - Function: inet:network address + Returns the network number (integer) specified from ADDRESS or + `#f' if not found. + + - Function: inet:local-network-address address + Returns the integer for the address of ADDRESS within its local + network or `#f' if not found. + + - Function: inet:make-address network local-address + Returns the Internet address of LOCAL-ADDRESS in NETWORK. + +The type "socket-name" is used for inquiries about open sockets in the +following procedures: + + - Function: getsockname socket + Returns the socket-name of SOCKET. Returns `#f' if unsuccessful + or SOCKET is closed. + + - Function: getpeername socket + Returns the socket-name of the socket connected to SOCKET. + Returns `#f' if unsuccessful or SOCKET is closed. + + - Function: socket-name:family socket-name + Returns the integer code for the family of SOCKET-NAME. + + - Function: socket-name:port-number socket-name + Returns the integer port number of SOCKET-NAME. + + - Function: socket-name:address socket-name + Returns the integer Internet address for SOCKET-NAME. + + +File: scm.info, Node: Socket, Prev: Internet Addresses and Socket Names, Up: Sockets + +Socket +------ + +When a port is returned from one of these calls it is unbuffered. This +allows both reading and writing to the same port to work. If you want +buffered ports you can (assuming sock-port is a socket i/o port): + (require 'i/o-extensions) + (define i-port (duplicate-port sock-port "r")) + (define o-port (duplicate-port sock-port "w")) + + - Function: make-stream-socket family + - Function: make-stream-socket family protocol + Returns a `SOCK_STREAM' socket of type FAMILY using PROTOCOL. If + FAMILY has the value `AF_INET', `SO_REUSEADDR' will be set. The + integer argument PROTOCOL corresponds to the integer protocol + numbers returned (as vector elements) from `(getproto)'. If the + PROTOCOL argument is not supplied, the default (0) for the + specified FAMILY is used. SCM sockets look like ports opened for + neither reading nor writing. + + - Function: make-stream-socketpair family + - Function: make-stream-socketpair family protocol + Returns a pair (cons) of connected `SOCK_STREAM' (socket) ports of + type FAMILY using PROTOCOL. Many systems support only socketpairs + of the `af-unix' FAMILY. The integer argument PROTOCOL + corresponds to the integer protocol numbers returned (as vector + elements) from (getproto). If the PROTOCOL argument is not + supplied, the default (0) for the specified FAMILY is used. + + - Function: socket:shutdown socket how + Makes SOCKET no longer respond to some or all operations depending + on the integer argument HOW: + + 0. Further input is disallowed. + + 1. Further output is disallowed. + + 2. Further input or output is disallowed. + + `Socket:shutdown' returns SOCKET if successful, `#f' if not. + + - Function: socket:connect inet-socket host-number port-number + - Function: socket:connect unix-socket pathname + Returns SOCKET (changed to a read/write port) connected to the + Internet socket on host HOST-NUMBER, port PORT-NUMBER or the Unix + socket specified by PATHNAME. Returns `#f' if not successful. + + - Function: socket:bind inet-socket port-number + - Function: socket:bind unix-socket pathname + Returns INET-SOCKET bound to the integer PORT-NUMBER or the + UNIX-SOCKET bound to new socket in the file system at location + PATHNAME. Returns `#f' if not successful. Binding a UNIX-SOCKET + creates a socket in the file system that must be deleted by the + caller when it is no longer needed (using `delete-file'). + + - Function: socket:listen socket backlog + The bound (*note bind: Socket.) SOCKET is readied to accept + connections. The positive integer BACKLOG specifies how many + pending connections will be allowed before further connection + requests are refused. Returns SOCKET (changed to a read-only + port) if successful, `#f' if not. + + - Function: char-ready? listen-socket + The input port returned by a successful call to `socket:listen' can + be polled for connections by `char-ready?' (*note char-ready?: + Files and Ports.). This avoids blocking on connections by + `socket:accept'. + + - Function: socket:accept socket + Accepts a connection on a bound, listening SOCKET. Returns an + input/output port for the connection. + +The following example is not too complicated, yet shows the use of +sockets for multiple connections without input blocking. + + ;;;; Scheme chat server + + ;;; This program implements a simple `chat' server which accepts + ;;; connections from multiple clients, and sends to all clients any + ;;; characters received from any client. + + ;;; To connect to chat `telnet localhost 8001' + + (require 'socket) + (require 'i/o-extensions) + + (let ((listener-socket (socket:bind (make-stream-socket af_inet) 8001)) + (connections '())) + (socket:listen listener-socket 5) + (do () (#f) + (let ((actives (or (apply wait-for-input 5 listener-socket connections) + '()))) + (cond ((null? actives)) + ((memq listener-socket actives) + (set! actives (cdr (memq listener-socket actives))) + (let ((con (socket:accept listener-socket))) + (display "accepting connection from ") + (display (getpeername con)) + (newline) + (set! connections (cons con connections)) + (display "connected" con) + (newline con)))) + (set! connections + (let next ((con-list connections)) + (cond ((null? con-list) '()) + (else + (let ((con (car con-list))) + (cond ((memq con actives) + (let ((c (read-char con))) + (cond ((eof-object? c) + (display "closing connection from ") + (display (getpeername con)) + (newline) + (close-port con) + (next (cdr con-list))) + (else + (for-each (lambda (con) + (file-set-position con 0) + (write-char c con) + (file-set-position con 0)) + connections) + (cons con (next (cdr con-list))))))) + (else (cons con (next (cdr con-list))))))))))))) + +You can use `telnet localhost 8001' to connect to the chat server, or +you can use a client written in scheme: + + ;;;; Scheme chat client + + ;;; this program connects to socket 8001. It then sends all + ;;; characters from current-input-port to the socket and sends all + ;;; characters from the socket to current-output-port. + + (require 'socket) + (require 'i/o-extensions) + + (define con (make-stream-socket af_inet)) + (set! con (socket:connect con (inet:string->address "localhost") 8001)) + + (define (go) + (define actives (wait-for-input (* 30 60) con (current-input-port))) + (let ((cs (and actives (memq con actives) (read-char con))) + (ct (and actives (memq (current-input-port) actives) (read-char)))) + (cond ((or (eof-object? cs) (eof-object? ct)) (close-port con)) + (else (cond (cs (display cs))) + (cond (ct (file-set-position con 0) + (display ct con) + (file-set-position con 0))) + (go))))) + (cond (con (display "Connecting to ") + (display (getpeername con)) + (newline) + (go)) + (else (display "Server not listening on port 8001") + (newline))) + + +File: scm.info, Node: The Implementation, Next: Index, Prev: Packages, Up: Top + +The Implementation +****************** + +* Menu: + +* Data Types:: +* Operations:: +* Program Self-Knowledge:: What SCM needs to know about itself. +* Improvements To Make:: + + +File: scm.info, Node: Data Types, Next: Operations, Prev: The Implementation, Up: The Implementation + +Data Types +========== + +In the descriptions below it is assumed that `long int's are 32 bits in +length. Acutally, SCM is written to work with any `long int' size +larger than 31 bits. With some modification, SCM could work with word +sizes as small as 24 bits. + +All SCM objects are represented by type "SCM". Type `SCM' come in 2 +basic flavors, Immediates and Cells: + +* Menu: + +* Immediates:: +* Cells:: Non-Immediate types +* Header Cells:: Malloc objects +* Subr Cells:: Built-in and Compiled Procedures +* Ptob Cells:: I/O ports +* Smob Cells:: Miscellaneous datatypes +* Data Type Representations:: How they all fit together + + +File: scm.info, Node: Immediates, Next: Cells, Prev: Data Types, Up: Data Types + +Immediates +---------- + +An "immediate" is a data type contained in type `SCM' (`long int'). +The type codes distinguishing immediate types from each other vary in +length, but reside in the low order bits. + + - Macro: IMP x + - Macro: NIMP x + Return non-zero if the `SCM' object X is an immediate or + non-immediate type, respectively. + + - Immediate: inum + immediate 30 bit signed integer. An INUM is flagged by a `1' in + the second to low order bit position. The high order 30 bits are + used for the integer's value. + + - Macro: INUMP x + - Macro: NINUMP x + Return non-zero if the `SCM' X is an immediate integer or not + an immediate integer, respectively. + + - Macro: INUM x + Returns the C `long integer' corresponding to `SCM' X. + + - Macro: MAKINUM x + Returns the `SCM' inum corresponding to C `long integer' x. + + - Immediate Constant: INUM0 + is equivalent to `MAKINUM(0)'. + + Computations on INUMs are performed by converting the arguments to + C integers (by a shift), operating on the integers, and converting + the result to an inum. The result is checked for overflow by + converting back to integer and checking the reverse operation. + + The shifts used for conversion need to be signed shifts. If the C + implementation does not support signed right shift this fact is + detected in a #if statement in `scmfig.h' and a signed right shift, + `SRS', is constructed in terms of unsigned right shift. + + - Immediate: ichr + characters. + + - Macro: ICHRP x + Return non-zero if the `SCM' object X is a character. + + - Macro: ICHR x + Returns corresponding `unsigned char'. + + - Macro: MAKICHR x + Given `char' X, returns `SCM' character. + + + - Immediate: iflags + These are frequently used immediate constants. + + - Immediate Constant: SCM BOOL_T + `#t' + + - Immediate Constant: SCM BOOL_F + `#f' + + - Immediate Constant: SCM EOL + `()'. If `SICP' is `#define'd, `EOL' is `#define'd to be + identical with `BOOL_F'. In this case, both print as `#f'. + + - Immediate Constant: SCM EOF_VAL + end of file token, `#<eof>'. + + - Immediate Constant: SCM UNDEFINED + `#<undefined>' used for variables which have not been defined + and absent optional arguments. + + - Immediate Constant: SCM UNSPECIFIED + `#<unspecified>' is returned for those procedures whose return + values are not specified. + + + - Macro: IFLAGP n + Returns non-zero if N is an ispcsym, isym or iflag. + + - Macro: ISYMP n + Returns non-zero if N is an ispcsym or isym. + + - Macro: ISYMNUM n + Given ispcsym, isym, or iflag N, returns its index in the C array + `isymnames[]'. + + - Macro: ISYMCHARS n + Given ispcsym, isym, or iflag N, returns its `char *' + representation (from `isymnames[]'). + + - Macro: MAKSPCSYM n + Returns `SCM' ispcsym N. + + - Macro: MAKISYM n + Returns `SCM' iisym N. + + - Macro: MAKIFLAG n + Returns `SCM' iflag N. + + - Variable: isymnames + An array of strings containing the external representations of all + the ispcsym, isym, and iflag immediates. Defined in `repl.c'. + + - Constant: NUM_ISPCSYM + - Constant: NUM_ISYMS + The number of ispcsyms and ispcsyms+isyms, respectively. Defined + in `scm.h'. + + - Immediate: isym + `and', `begin', `case', `cond', `define', `do', `if', `lambda', + `let', `let*', `letrec', `or', `quote', `set!', `#f', `#t', + `#<undefined>', `#<eof>', `()', and `#<unspecified>'. + + - CAR Immediate: ispcsym + special symbols: syntax-checked versions of first 14 isyms + + - CAR Immediate: iloc + indexes to a variable's location in environment + + - CAR Immediate: gloc + pointer to a symbol's value cell + + - Immediate: CELLPTR + pointer to a cell (not really an immediate type, but here for + completeness). Since cells are always 8 byte aligned, a pointer + to a cell has the low order 3 bits `0'. + + There is one exception to this rule, _CAR Immediate_s, described + next. + +A "CAR Immediate" is an Immediate point which can only occur in the +`CAR's of evaluated code (as a result of `ceval''s memoization process). + + +File: scm.info, Node: Cells, Next: Header Cells, Prev: Immediates, Up: Data Types + +Cells +----- + +"Cell"s represent all SCM objects other than immediates. A cell has a +`CAR' and a `CDR'. Low-order bits in `CAR' identify the type of +object. The rest of `CAR' and `CDR' hold object data. The number +after `tc' specifies how many bits are in the type code. For instance, +`tc7' indicates that the type code is 7 bits. + + - Macro: NEWCELL x + Allocates a new cell and stores a pointer to it in `SCM' local + variable X. + + Care needs to be taken that stores into the new cell pointed to by + X do not create an inconsistent object. *Note Signals::. + +All of the C macros decribed in this section assume that their argument +is of type `SCM' and points to a cell (`CELLPTR'). + + - Macro: CAR x + - Macro: CDR x + Returns the `car' and `cdr' of cell X, respectively. + + - Macro: TYP3 x + - Macro: TYP7 x + - Macro: TYP16 x + Returns the 3, 7, and 16 bit type code of a cell. + + - Cell: tc3_cons + scheme cons-cell returned by (cons arg1 arg2). + + - Macro: CONSP x + - Macro: NCONSP x + Returns non-zero if X is a `tc3_cons' or isn't, respectively. + + - Cell: tc3_closure + applicable object returned by (lambda (args) ...). `tc3_closure's + have a pointer to the body of the procedure in the `CAR' and a + pointer to the environment in the `CDR'. Bits 1 and 2 + (zero-based) in the `CDR' indicate a lower bound on the number of + required arguments to the closure, which is used to avoid + allocating rest argument lists in the environment cache. This + encoding precludes an immediate value for the `CDR': In the case + of an empty environment all bits above 2 in the `CDR' are zero. + + - Macro: CLOSUREP x + Returns non-zero if X is a `tc3_closure'. + + - Macro: CODE x + - Macro: ENV x + Returns the code body or environment of closure X, + respectively. + + - Macro: ARGC x + Returns the a lower bound on the number of required arguments + to closure X, it cannot exceed 3. + + + +File: scm.info, Node: Header Cells, Next: Subr Cells, Prev: Cells, Up: Data Types + +Header Cells +------------ + +"Header"s are Cells whose `CDR's point elsewhere in memory, such as to +memory allocated by `malloc'. + + - Header: spare + spare `tc7' type code + + - Header: tc7_vector + scheme vector. + + - Macro: VECTORP x + - Macro: NVECTORP x + Returns non-zero if X is a `tc7_vector' or if not, + respectively. + + - Macro: VELTS x + - Macro: LENGTH x + Returns the C array of `SCM's holding the elements of vector + X or its length, respectively. + + - Header: tc7_ssymbol + static scheme symbol (part of initial system) + + - Header: tc7_msymbol + `malloc'ed scheme symbol (can be GCed) + + - Macro: SYMBOLP x + Returns non-zero if X is a `tc7_ssymbol' or `tc7_msymbol'. + + - Macro: CHARS x + - Macro: UCHARS x + - Macro: LENGTH x + Returns the C array of `char's or as `unsigned char's holding + the elements of symbol X or its length, respectively. + + - Header: tc7_string + scheme string + + - Macro: STRINGP x + - Macro: NSTRINGP x + Returns non-zero if X is a `tc7_string' or isn't, + respectively. + + - Macro: CHARS x + - Macro: UCHARS x + - Macro: LENGTH x + Returns the C array of `char's or as `unsigned char's holding + the elements of string X or its length, respectively. + + - Header: tc7_bvect + uniform vector of booleans (bit-vector) + + - Header: tc7_ivect + uniform vector of integers + + - Header: tc7_uvect + uniform vector of non-negative integers + + - Header: tc7_svect + uniform vector of short integers + + - Header: tc7_fvect + uniform vector of short inexact real numbers + + - Header: tc7_dvect + uniform vector of double precision inexact real numbers + + - Header: tc7_cvect + uniform vector of double precision inexact complex numbers + + - Header: tc7_contin + applicable object produced by call-with-current-continuation + + - Header: tc7_specfun + subr that is treated specially within the evaluator + + `apply' and `call-with-current-continuation' are denoted by these + objects. Their behavior as functions is built into the evaluator; + they are not directly associated with C functions. This is + necessary in order to make them properly tail recursive. + + tc16_cclo is a subtype of tc7_specfun, a cclo is similar to a + vector (and is GCed like one), but can be applied as a function: + + 1. the cclo itself is consed onto the head of the argument list + + 2. the first element of the cclo is applied to that list. Cclo + invocation is currently not tail recursive when given 2 or + more arguments. + + - Function: makcclo proc len + makes a closure from the _subr_ PROC with LEN-1 extra + locations for `SCM' data. Elements of a CCLO are referenced + using `VELTS(cclo)[n]' just as for vectors. + + - Macro: CCLO_LENGTH cclo + Expands to the length of CCLO. + + +File: scm.info, Node: Subr Cells, Next: Ptob Cells, Prev: Header Cells, Up: Data Types + +Subr Cells +---------- + +A "Subr" is a header whose `CDR' points to a C code procedure. Scheme +primitive procedures are subrs. Except for the arithmetic `tc7_cxr's, +the C code procedures will be passed arguments (and return results) of +type `SCM'. + + - Subr: tc7_asubr + associative C function of 2 arguments. Examples are `+', `-', + `*', `/', `max', and `min'. + + - Subr: tc7_subr_0 + C function of no arguments. + + - Subr: tc7_subr_1 + C function of one argument. + + - Subr: tc7_cxr + These subrs are handled specially. If inexact numbers are + enabled, the `CDR' should be a function which takes and returns + type `double'. Conversions are handled in the interpreter. + + `floor', `ceiling', `truncate', `round', `$sqrt', `$abs', `$exp', + `$log', `$sin', `$cos', `$tan', `$asin', `$acos', `$atan', + `$sinh', `$cosh', `$tanh', `$asinh', `$acosh', `$atanh', and + `exact->inexact' are defined this way. + + If the `CDR' is `0' (`NULL'), the name string of the procedure is + used to control traversal of its list structure argument. + + `car', `cdr', `caar', `cadr', `cdar', `cddr', `caaar', `caadr', + `cadar', `caddr', `cdaar', `cdadr', `cddar', `cdddr', `caaaar', + `caaadr', `caadar', `caaddr', `cadaar', `cadadr', `caddar', + `cadddr', `cdaaar', `cdaadr', `cdadar', `cdaddr', `cddaar', + `cddadr', `cdddar', and `cddddr' are defined this way. + + - Subr: tc7_subr_3 + C function of 3 arguments. + + - Subr: tc7_subr_2 + C function of 2 arguments. + + - Subr: tc7_rpsubr + transitive relational predicate C function of 2 arguments. The C + function should return either `BOOL_T' or `BOOL_F'. + + - Subr: tc7_subr_1o + C function of one optional argument. If the optional argument is + not present, `UNDEFINED' is passed in its place. + + - Subr: tc7_subr_2o + C function of 1 required and 1 optional argument. If the optional + argument is not present, `UNDEFINED' is passed in its place. + + - Subr: tc7_lsubr_2 + C function of 2 arguments and a list of (rest of) `SCM' arguments. + + - Subr: tc7_lsubr + C function of list of `SCM' arguments. + + +File: scm.info, Node: Ptob Cells, Next: Smob Cells, Prev: Subr Cells, Up: Data Types + +Ptob Cells +---------- + +A "ptob" is a port object, capable of delivering or accepting +characters. *Note Ports: (r5rs)Ports. Unlike the types described so +far, new varieties of ptobs can be defined dynamically (*note Defining +Ptobs::). These are the initial ptobs: + + - ptob: tc16_inport + input port. + + - ptob: tc16_outport + output port. + + - ptob: tc16_ioport + input-output port. + + - ptob: tc16_inpipe + input pipe created by `popen()'. + + - ptob: tc16_outpipe + output pipe created by `popen()'. + + - ptob: tc16_strport + String port created by `cwos()' or `cwis()'. + + - ptob: tc16_sfport + Software (virtual) port created by `mksfpt()' (*note Soft Ports::). + + - Macro: PORTP x + - Macro: OPPORTP x + - Macro: OPINPORTP x + - Macro: OPOUTPORTP x + - Macro: INPORTP x + - Macro: OUTPORTP x + Returns non-zero if X is a port, open port, open input-port, open + output-port, input-port, or output-port, respectively. + + - Macro: OPENP x + - Macro: CLOSEDP x + Returns non-zero if port X is open or closed, respectively. + + - Macro: STREAM x + Returns the `FILE *' stream for port X. + +Ports which are particularly well behaved are called "fport"s. +Advanced operations like `file-position' and `reopen-file' only work +for fports. + + - Macro: FPORTP x + - Macro: OPFPORTP x + - Macro: OPINFPORTP x + - Macro: OPOUTFPORTP x + Returns non-zero if X is a port, open port, open input-port, or + open output-port, respectively. + + +File: scm.info, Node: Smob Cells, Next: Data Type Representations, Prev: Ptob Cells, Up: Data Types + +Smob Cells +---------- + +A "smob" is a miscellaneous datatype. The type code and GCMARK bit +occupy the lower order 16 bits of the `CAR' half of the cell. The rest +of the `CAR' can be used for sub-type or other information. The `CDR' +contains data of size long and is often a pointer to allocated memory. + +Like ptobs, new varieties of smobs can be defined dynamically (*note +Defining Smobs::). These are the initial smobs: + + - smob: tc_free_cell + unused cell on the freelist. + + - smob: tc16_flo + single-precision float. + + Inexact number data types are subtypes of type `tc16_flo'. If the + sub-type is: + + 0. a single precision float is contained in the `CDR'. + + 1. `CDR' is a pointer to a `malloc'ed double. + + 3. `CDR' is a pointer to a `malloc'ed pair of doubles. + + - smob: tc_dblr + double-precision float. + + - smob: tc_dblc + double-precision complex. + + - smob: tc16_bigpos + - smob: tc16_bigneg + positive and negative bignums, respectively. + + Scm has large precision integers called bignums. They are stored + in sign-magnitude form with the sign occuring in the type code of + the SMOBs bigpos and bigneg. The magnitude is stored as a + `malloc'ed array of type `BIGDIG' which must be an unsigned + integral type with size smaller than `long'. `BIGRAD' is the + radix associated with `BIGDIG'. + + `NUMDIGS_MAX' (defined in `scmfig.h') limits the number of digits + of a bignum to 1000. These digits are base `BIGRAD', which is + typically 65536, giving 4816 decimal digits. + + Why only 4800 digits? The simple multiplication algorithm SCM + uses is O(n^2); this means the number of processor instructions + required to perform a multiplication is _some multiple_ of the + product of the number of digits of the two multiplicands. + + digits * digits ==> operations + 5 x + 50 100 * x + 500 10000 * x + 5000 1000000 * x + + To calculate numbers larger than this, FFT multiplication + [O(n*log(n))] and other specialized algorithms are required. You + should obtain a package which specializes in number-theoretical + calculations: + + <ftp://megrez.math.u-bordeaux.fr/pub/pari/> + + + - smob: tc16_promise + made by DELAY. *Note Control features: (r5rs)Control features. + + - smob: tc16_arbiter + synchronization object. *Note Process Synchronization::. + + - smob: tc16_macro + macro expanding function. *Note Low Level Syntactic Hooks::. + + - smob: tc16_array + multi-dimensional array. *Note Arrays::. + + This type implements both conventional arrays (those with + arbitrary data as elements *note Conventional Arrays::) and + uniform arrays (those with elements of a uniform type *note + Uniform Array::). + + Conventional Arrays have a pointer to a vector for their `CDR'. + Uniform Arrays have a pointer to a Uniform Vector type (string, + bvect, ivect, uvect, fvect, dvect, or cvect) in their `CDR'. + + +File: scm.info, Node: Data Type Representations, Prev: Smob Cells, Up: Data Types + +Data Type Representations +------------------------- + +IMMEDIATE: B,D,E,F=data bit, C=flag code, P=pointer address bit + ................................ +inum BBBBBBBBBBBBBBBBBBBBBBBBBBBBBB10 +ichr BBBBBBBBBBBBBBBBBBBBBBBB11110100 +iflag CCCCCCC101110100 +isym CCCCCCC001110100 + IMCAR: only in car of evaluated code, cdr has cell's GC bit +ispcsym 000CCCC00CCCC100 +iloc 0DDDDDDDDDDDEFFFFFFFFFFF11111100 +pointer PPPPPPPPPPPPPPPPPPPPPPPPPPPPP000 +gloc PPPPPPPPPPPPPPPPPPPPPPPPPPPPP001 + + HEAP CELL: G=gc_mark; 1 during mark, 0 other times. + 1s and 0s here indicate type. G missing means sys (not GC'd) + SIMPLE: +cons ..........SCM car..............0 ...........SCM cdr.............G +closure ..........SCM code...........011 ...........SCM env...........CCG + HEADERs: +ssymbol .........long length....G0000101 ..........char *chars........... +msymbol .........long length....G0000111 ..........char *chars........... +string .........long length....G0001101 ..........char *chars........... +vector .........long length....G0001111 ...........SCM **elts........... +bvect .........long length....G0010101 ..........long *words........... + spare G0010111 +ivect .........long length....G0011101 ..........long *words........... +uvect .........long length....G0011111 ......unsigned long *words...... + spare G0100101 +svect .........long length....G0100111 ........ short *words........... +fvect .........long length....G0101101 .........float *words........... +dvect .........long length....G0101111 ........double *words........... +cvect .........long length....G0110101 ........double *words........... + +contin .........long length....G0111101 .............*regs.............. +specfun ................xxxxxxxxG1111111 ...........SCM name............. +cclo ..short length..xxxxxx10G1111111 ...........SCM **elts........... + PTOBs: + port 0bwroxxxxxxxxG0110111 ..........FILE *stream.......... + socket ttttttt 00001xxxxxxxxG0110111 ..........FILE *stream.......... + inport uuuuuuuuuuU00011xxxxxxxxG0110111 ..........FILE *stream.......... +outport 0000000000000101xxxxxxxxG0110111 ..........FILE *stream.......... + ioport uuuuuuuuuuU00111xxxxxxxxG0110111 ..........FILE *stream.......... +fport 00 00000000G0110111 ..........FILE *stream.......... +pipe 00 00000001G0110111 ..........FILE *stream.......... +strport 00 00000010G0110111 ..........FILE *stream.......... +sfport 00 00000011G0110111 ..........FILE *stream.......... + SUBRs: + spare 010001x1 + spare 010011x1 +subr_0 ..........int hpoff.....01010101 ...........SCM (*f)()........... +subr_1 ..........int hpoff.....01010111 ...........SCM (*f)()........... +cxr ..........int hpoff.....01011101 .........double (*f)().......... +subr_3 ..........int hpoff.....01011111 ...........SCM (*f)()........... +subr_2 ..........int hpoff.....01100101 ...........SCM (*f)()........... +asubr ..........int hpoff.....01100111 ...........SCM (*f)()........... +subr_1o ..........int hpoff.....01101101 ...........SCM (*f)()........... +subr_2o ..........int hpoff.....01101111 ...........SCM (*f)()........... +lsubr_2 ..........int hpoff.....01110101 ...........SCM (*f)()........... +lsubr ..........int hpoff.....01110111 ...........SCM (*f)()........... +rpsubr ..........int hpoff.....01111101 ...........SCM (*f)()........... + SMOBs: +free_cell + 000000000000000000000000G1111111 ...........*free_cell........000 +flo 000000000000000000000001G1111111 ...........float num............ +dblr 000000000000000100000001G1111111 ..........double *real.......... +dblc 000000000000001100000001G1111111 .........complex *cmpx.......... +bignum ...int length...0000001 G1111111 .........short *digits.......... +bigpos ...int length...00000010G1111111 .........short *digits.......... +bigneg ...int length...00000011G1111111 .........short *digits.......... + xxxxxxxx = code assigned by newsmob(); +promise 000000000000000fxxxxxxxxG1111111 ...........SCM val.............. +arbiter 000000000000000lxxxxxxxxG1111111 ...........SCM name............. +macro 000000000000000mxxxxxxxxG1111111 ...........SCM name............. +array ...short rank..cxxxxxxxxG1111111 ............*array.............. + + +File: scm.info, Node: Operations, Next: Program Self-Knowledge, Prev: Data Types, Up: The Implementation + +Operations +========== + +* Menu: + +* Garbage Collection:: Automatically reclaims unused storage +* Memory Management for Environments:: +* Signals:: +* C Macros:: +* Changing Scm:: +* Defining Subrs:: +* Defining Smobs:: +* Defining Ptobs:: +* Allocating memory:: +* Embedding SCM:: In other programs +* Callbacks:: +* Type Conversions:: For use with C code. +* Continuations:: For C and SCM +* Evaluation:: Why SCM is fast + + +File: scm.info, Node: Garbage Collection, Next: Memory Management for Environments, Prev: Operations, Up: Operations + +Garbage Collection +------------------ + +The garbage collector is in the latter half of `sys.c'. The primary +goal of "garbage collection" (or "GC") is to recycle those cells no +longer in use. Immediates always appear as parts of other objects, so +they are not subject to explicit garbage collection. + +All cells reside in the "heap" (composed of "heap segments"). Note +that this is different from what Computer Science usually defines as a +heap. + +* Menu: + +* Marking Cells:: +* Sweeping the Heap:: + + +File: scm.info, Node: Marking Cells, Next: Sweeping the Heap, Prev: Garbage Collection, Up: Garbage Collection + +Marking Cells +............. + +The first step in garbage collection is to "mark" all heap objects in +use. Each heap cell has a bit reserved for this purpose. For pairs +(cons cells) the lowest order bit (0) of the CDR is used. For other +types, bit 8 of the CAR is used. The GC bits are never set except +during garbage collection. Special C macros are defined in `scm.h' to +allow easy manipulation when GC bits are possibly set. `CAR', `TYP3', +and `TYP7' can be used on GC marked cells as they are. + + - Macro: GCCDR x + Returns the CDR of a cons cell, even if that cell has been GC + marked. + + - Macro: GCTYP16 x + Returns the 16 bit type code of a cell. + +We need to (recursively) mark only a few objects in order to assure that +all accessible objects are marked. Those objects are `sys_protects[]' +(for example, `dynwinds'), the current C-stack and the hash table for +symbols, "symhash". + + - Function: void gc_mark (SCM OBJ) + The function `gc_mark()' is used for marking SCM cells. If OBJ is + marked, `gc_mark()' returns. If OBJ is unmarked, gc_mark sets the + mark bit in OBJ, then calls `gc_mark()' on any SCM components of + OBJ. The last call to `gc_mark()' is tail-called (looped). + + - Function: void mark_locations (STACKITEM X[], sizet LEN)) + The function `mark_locations' is used for marking segments of + C-stack or saved segments of C-stack (marked continuations). The + argument LEN is the size of the stack in units of size + `(STACKITEM)'. + + Each longword in the stack is tried to see if it is a valid cell + pointer into the heap. If it is, the object itself and any + objects it points to are marked using `gc_mark'. If the stack is + word rather than longword aligned `(#define WORD_ALIGN)', both + alignments are tried. This arrangement will occasionally mark an + object which is no longer used. This has not been a problem in + practice and the advantage of using the c-stack far outweighs it. + + +File: scm.info, Node: Sweeping the Heap, Prev: Marking Cells, Up: Garbage Collection + +Sweeping the Heap +................. + +After all found objects have been marked, the heap is swept. + +The storage for strings, vectors, continuations, doubles, complexes, and +bignums is managed by malloc. There is only one pointer to each malloc +object from its type-header cell in the heap. This allows malloc +objects to be freed when the associated heap object is garbage +collected. + + - Function: static void gc_sweep () + The function `gc_sweep' scans through all heap segments. The mark + bit is cleared from marked cells. Unmarked cells are spliced into + FREELIST, where they can again be returned by invocations of + `NEWCELL'. + + If a type-header cell pointing to malloc space is unmarked, the + malloc object is freed. If the type header of smob is collected, + the smob's `free' procedure is called to free its storage. + + +File: scm.info, Node: Memory Management for Environments, Next: Signals, Prev: Garbage Collection, Up: Operations + +Memory Management for Environments +---------------------------------- + + * "Ecache" was designed and implemented by Radey Shouman. + + * This documentation of ecache was written by Tom Lord. + +The memory management component of SCM contains special features which +optimize the allocation and garbage collection of environments. + +The optimizations are based on certain facts and assumptions: + +The SCM evaluator creates many environments with short lifetimes and +these account of a _large portion_ of the total number of objects +allocated. + +The general purpose allocator allocates objects from a freelist, and +collects using a mark/sweep algorithm. Research into garbage +collection suggests that such an allocator is sub-optimal for object +populations containing a large portion of short-lived members and that +allocation strategies involving a copying collector are more +appropriate. + +It is a property of SCM, reflected throughout the source code, that a +simple copying collector can not be used as the general purpose memory +manager: much code assumes that the run-time stack can be treated as a +garbage collection root set using "conservative garbage collection" +techniques, which are incompatible with objects that change location. + +Nevertheless, it is possible to use a mostly-separate +copying-collector, just for environments. Roughly speaking, cons pairs +making up environments are initially allocated from a small heap that +is collected by a precise copying collector. These objects must be +handled specially for the collector to work. The (presumably) small +number of these objects that survive one collection of the copying heap +are copied to the general purpose heap, where they will later be +collected by the mark/sweep collector. The remaining pairs are more +rapidly collected than they would otherwise be and all of this +collection is accomplished without having to mark or sweep any other +segment of the heap. + +Allocating cons pairs for environments from this special heap is a +heuristic that approximates the (unachievable) goal: + + allocate all short-lived objects from the copying-heap, at no + extra cost in allocation time. + +Implementation Details +...................... + +A separate heap (`ecache_v') is maintained for the copying collector. +Pairs are allocated from this heap in a stack-like fashion. Objects in +this heap may be protected from garbage collection by: + + 1. Pushing a reference to the object on a stack specially maintained + for that purpose. This stack (`scm_estk') is used in place of the + C run-time stack by the SCM evaluator to hold local variables + which refer to the copying heap. + + 2. Saving a reference to every object in the mark/sweep heap which + directly references the copying heap in a root set that is + specially maintained for that purpose (`scm_egc_roots'). If no + object in the mark/sweep heap directly references an object from + the copying heap, that object can be preserved by storing a direct + reference to it in the copying-collector root set. + + 3. Keeping no other references to these objects, except references + between the objects themselves, during copying collection. + +When the copying heap or root-set becomes full, the copying collector is +invoked. All protected objects are copied to the mark-sweep heap. All +references to those objects are updated. The copying collector root-set +and heap are emptied. + +References to pairs allocated specificly for environments are +inaccessible to the Scheme procedures evaluated by SCM. These pairs +are manipulated by only a small number of code fragments in the +interpreter. To support copying collection, those code fragments +(mostly in `eval.c') have been modified to protect environments from +garbage collection using the three rules listed above. + +During a mark-sweep collection, the copying collector heap is marked +and swept almost like any ordinary segment of the general purpose heap. +The only difference is that pairs from the copying heap that become +free during a sweep phase are not added to the freelist. + +The environment cache is disabled by adding `#define NO_ENV_CACHE' to +`eval.c'; all environment cells are then allocated from the regular +heap. + +Relation to Other Work +...................... + +This work seems to build upon a considerable amount of previous work +into garbage collection techniques about which a considerable amount of +literature is available. + + +File: scm.info, Node: Signals, Next: C Macros, Prev: Memory Management for Environments, Up: Operations + +Signals +------- + + - Function: init_signals + (in `scm.c') initializes handlers for `SIGINT' and `SIGALRM' if + they are supported by the C implementation. All of the signal + handlers immediately reestablish themselves by a call to + `signal()'. + + - Function: int_signal sig + - Function: alrm_signal sig + The low level handlers for `SIGINT' and `SIGALRM'. + +If an interrupt handler is defined when the interrupt is received, the +code is interpreted. If the code returns, execution resumes from where +the interrupt happened. `Call-with-current-continuation' allows the +stack to be saved and restored. + +SCM does not use any signal masking system calls. These are not a +portable feature. However, code can run uninterrupted by use of the C +macros `DEFER_INTS' and `ALLOW_INTS'. + + - Macro: DEFER_INTS + sets the global variable `ints_disabled' to 1. If an interrupt + occurs during a time when `ints_disabled' is 1, then + `deferred_proc' is set to non-zero, one of the global variables + `SIGINT_deferred' or `SIGALRM_deferred' is set to 1, and the + handler returns. + + - Macro: ALLOW_INTS + Checks the deferred variables and if set the appropriate handler is + called. + + Calls to `DEFER_INTS' can not be nested. An `ALLOW_INTS' must + happen before another `DEFER_INTS' can be done. In order to check + that this constraint is satisfied `#define CAREFUL_INTS' in + `scmfig.h'. + + +File: scm.info, Node: C Macros, Next: Changing Scm, Prev: Signals, Up: Operations + +C Macros +-------- + + - Macro: ASSERT cond arg pos subr + signals an error if the expression (COND) is 0. ARG is the + offending object, SUBR is the string naming the subr, and POS + indicates the position or type of error. POS can be one of + + * `ARGn' (> 5 or unknown ARG number) + + * `ARG1' + + * `ARG2' + + * `ARG3' + + * `ARG4' + + * `ARG5' + + * `WNA' (wrong number of args) + + * `OVFLOW' + + * `OUTOFRANGE' + + * `NALLOC' + + * `EXIT' + + * `HUP_SIGNAL' + + * `INT_SIGNAL' + + * `FPE_SIGNAL' + + * `BUS_SIGNAL' + + * `SEGV_SIGNAL' + + * `ALRM_SIGNAL' + + * a C string `(char *)' + + Error checking is not done by `ASSERT' if the flag `RECKLESS' is + defined. An error condition can still be signaled in this case + with a call to `wta(arg, pos, subr)'. + + - Macro: ASRTGO cond label + `goto' LABEL if the expression (COND) is 0. Like `ASSERT', + `ASRTGO' does is not active if the flag `RECKLESS' is defined. + + +File: scm.info, Node: Changing Scm, Next: Defining Subrs, Prev: C Macros, Up: Operations + +Changing Scm +------------ + +When writing C-code for SCM, a precaution is recommended. If your +routine allocates a non-cons cell which will _not_ be incorporated into +a `SCM' object which is returned, you need to make sure that a `SCM' +variable in your routine points to that cell as long as part of it +might be referenced by your code. + +In order to make sure this `SCM' variable does not get optimized out +you can put this assignment after its last possible use: + + SCM_dummy1 = foo; + +or put this assignment somewhere in your routine: + + SCM_dummy1 = (SCM) &foo; + +`SCM_dummy' variables are not currently defined. Passing the address +of the local `SCM' variable to _any_ procedure also protects it. The +procedure `scm_protect_temp' is provided for this purpose. + +Also, if you maintain a static pointer to some (non-immediate) `SCM' +object, you must either make your pointer be the value cell of a symbol +(see `errobj' for an example) or make your pointer be one of the +`sys_protects' (see `dynwinds' for an example). The former method is +prefered since it does not require any changes to the SCM distribution. + +To add a C routine to scm: + + 1. choose the appropriate subr type from the type list. + + 2. write the code and put into `scm.c'. + + 3. add a `make_subr' or `make_gsubr' call to `init_scm'. Or put an + entry into the appropriate `iproc' structure. + +To add a package of new procedures to scm (see `crs.c' for example): + + 1. create a new C file (`foo.c'). + + 2. at the front of `foo.c' put declarations for strings for your + procedure names. + + static char s_twiddle_bits[]="twiddle-bits!"; + static char s_bitsp[]="bits?"; + + 3. choose the appropriate subr types from the type list in `code.doc'. + + 4. write the code for the procedures and put into `foo.c' + + 5. create one `iproc' structure for each subr type used in `foo.c' + + static iproc subr3s[]= { + {s_twiddle-bits,twiddle-bits}, + {s_bitsp,bitsp}, + {0,0} }; + + 6. create an `init_<name of file>' routine at the end of the file + which calls `init_iprocs' with the correct type for each of the + `iproc's created in step 5. + + void init_foo() + { + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr3s, tc7_subr_3); + } + + If your package needs to have a "finalization" routine called to + free up storage, close files, etc, then also have a line in + `init_foo' like: + + add_final(final_foo); + + `final_foo' should be a (void) procedure of no arguments. The + finals will be called in opposite order from their definition. + + The line: + + add_feature("foo"); + + will append a symbol `'foo' to the (list) value of `*features*'. + + 7. put any scheme code which needs to be run as part of your package + into `Ifoo.scm'. + + 8. put an `if' into `Init5d6.scm' which loads `Ifoo.scm' if your + package is included: + + (if (defined? twiddle-bits!) + (load (in-vicinity (implementation-vicinity) + "Ifoo" + (scheme-file-suffix)))) + + or use `(provided? 'foo)' instead of `(defined? twiddle-bits!)' + if you have added the feature. + + 9. put documentation of the new procedures into `foo.doc' + + 10. add lines to your `Makefile' to compile and link SCM with your + object file. Add a `init_foo\(\)\;' to the `INITS=...' line at + the beginning of the makefile. + +These steps should allow your package to be linked into SCM with a +minimum of difficulty. Your package should also work with dynamic +linking if your SCM has this capability. + +Special forms (new syntax) can be added to scm. + + 1. define a new `MAKISYM' in `scm.h' and increment `NUM_ISYMS'. + + 2. add a string with the new name in the corresponding place in + `isymnames' in `repl.c'. + + 3. add `case:' clause to `ceval()' near `i_quasiquote' (in `eval.c'). + +New syntax can now be added without recompiling SCM by the use of the +`procedure->syntax', `procedure->macro', `procedure->memoizing-macro', +and `defmacro'. For details, *Note Syntax Extensions::. + + +File: scm.info, Node: Defining Subrs, Next: Defining Smobs, Prev: Changing Scm, Up: Operations + +Defining Subrs +-------------- + +If "CCLO" is `#define'd when compiling, the compiled closure feature +will be enabled. It is automatically enabled if dynamic linking is +enabled. + +The SCM interpreter directly recognizes subrs taking small numbers of +arguments. In order to create subrs taking larger numbers of arguments +use: + + - Function: make_gsubr name req opt rest fcn + returns a cclo (compiled closure) object of name `char *' NAME + which takes `int' REQ required arguments, `int' OPT optional + arguments, and a list of rest arguments if `int' REST is 1 (0 for + not). + + `SCM (*fcn)()' is a pointer to a C function to do the work. + + The C function will always be called with REQ + OPT + REST + arguments, optional arguments not supplied will be passed + `UNDEFINED'. An error will be signaled if the subr is called with + too many or too few arguments. Currently a total of 10 arguments + may be specified, but increasing this limit should not be + difficult. + + /* A silly example, taking 2 required args, + 1 optional, and a list of rest args */ + + #include <scm.h> + + SCM gsubr_21l(req1,req2,opt,rst) + SCM req1,req2,opt,rst; + { + lputs("gsubr-2-1-l:\n req1: ", cur_outp); + display(req1,cur_outp); + lputs("\n req2: ", cur_outp); + display(req2,cur_outp); + lputs("\n opt: ", cur_outp); + display(opt,cur_outp); + lputs("\n rest: ", cur_outp); + display(rst,cur_outp); + newline(cur_outp); + return UNSPECIFIED; + } + + void init_gsubr211() + { + make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); + } + + +File: scm.info, Node: Defining Smobs, Next: Defining Ptobs, Prev: Defining Subrs, Up: Operations + +Defining Smobs +-------------- + +Here is an example of how to add a new type named `foo' to SCM. The +following lines need to be added to your code: + +`long tc16_foo;' + The type code which will be used to identify the new type. + +`static smobfuns foosmob = {markfoo,freefoo,printfoo,equalpfoo};' + smobfuns is a structure composed of 4 functions: + + typedef struct { + SCM (*mark)P((SCM)); + sizet (*free)P((CELLPTR)); + int (*print)P((SCM exp, SCM port, int writing)); + SCM (*equalp)P((SCM, SCM)); + } smobfuns; + + `smob.mark' + is a function of one argument of type `SCM' (the cell to + mark) and returns type `SCM' which will then be marked. If + no further objects need to be marked then return an immediate + object such as `BOOL_F'. The smob cell itself will already + have been marked. _Note:_ This is different from SCM + versions prior to 5c5. Only additional data specific to a + smob type need be marked by `smob.mark'. + + 2 functions are provided: + + `markcdr(ptr)' + returns `CDR(ptr)'. + + `mark0(ptr)' + is a no-op used for smobs containing no additional `SCM' + data. 0 may also be used in this case. + + `smob.free' + is a function of one argument of type `CELLPTR' (the cell to + collected) and returns type `sizet' which is the number of + `malloc'ed bytes which were freed. `Smob.free' should free + any `malloc'ed storage associated with this object. The + function free0(ptr) is provided which does not free any + storage and returns 0. + + `smob.print' + is 0 or a function of 3 arguments. The first, of type `SCM', + is the smob object. The second, of type `SCM', is the stream + on which to write the result. The third, of type int, is 1 + if the object should be `write'n, 0 if it should be + `display'ed, and 2 if it should be `write'n for an error + report. This function should return non-zero if it printed, + and zero otherwise (in which case a hexadecimal number will + be printed). + + `smob.equalp' + is 0 or a function of 2 `SCM' arguments. Both of these + arguments will be of type `tc16foo'. This function should + return `BOOL_T' if the smobs are equal, `BOOL_F' if they are + not. If `smob.equalp' is 0, `equal?' will return `BOOL_F' if + they are not `eq?'. + +`tc16_foo = newsmob(&foosmob);' + Allocates the new type with the functions from `foosmob'. This + line goes in an `init_' routine. + +Promises and macros in `eval.c' and arbiters in `repl.c' provide +examples of SMOBs. There are a maximum of 256 SMOBs. Smobs that must +allocate blocks of memory should use, for example, `must_malloc' rather +than `malloc' *Note Allocating memory::. + + +File: scm.info, Node: Defining Ptobs, Next: Allocating memory, Prev: Defining Smobs, Up: Operations + +Defining Ptobs +-------------- + +"ptob"s are similar to smobs but define new types of port to which SCM +procedures can read or write. The following functions are defined in +the `ptobfuns': + + typedef struct { + SCM (*mark)P((SCM ptr)); + int (*free)P((FILE *p)); + int (*print)P((SCM exp, SCM port, int writing)); + SCM (*equalp)P((SCM, SCM)); + int (*fputc)P((int c, FILE *p)); + int (*fputs)P((char *s, FILE *p)); + sizet (*fwrite)P((char *s, sizet siz, sizet num, FILE *p)); + int (*fflush)P((FILE *stream)); + int (*fgetc)P((FILE *p)); + int (*fclose)P((FILE *p)); + } ptobfuns; + +The `.free' component to the structure takes a `FILE *' or other C +construct as its argument, unlike `.free' in a smob, which takes the +whole smob cell. Often, `.free' and `.fclose' can be the same +function. See `fptob' and `pipob' in `sys.c' for examples of how to +define ptobs. Ptobs that must allocate blocks of memory should use, +for example, `must_malloc' rather than `malloc' *Note Allocating +memory::. + + +File: scm.info, Node: Allocating memory, Next: Embedding SCM, Prev: Defining Ptobs, Up: Operations + +Allocating memory +----------------- + +SCM maintains a count of bytes allocated using malloc, and calls the +garbage collector when that number exceeds a dynamically managed limit. +In order for this to work properly, `malloc' and `free' should not be +called directly to manage memory freeable by garbage collection. The +following functions are provided for that purpose: + + - Function: SCM must_malloc_cell (long LEN, SCM C, char *WHAT) + - Function: char * must_malloc (long LEN, char *WHAT) + LEN is the number of bytes that should be allocated, WHAT is a + string to be used in error or gc messages. `must_malloc' returns + a pointer to newly allocated memory. `must_malloc_cell' returns a + newly allocated cell whose `car' is C and whose `cdr' is a pointer + to newly allocated memory. + + - Function: void must_realloc_cell (SCM Z, long OLEN, long LEN, char + *WHAT) + - Function: char * must_realloc (char *WHERE, long OLEN, long LEN, + char *WHAT) + `must_realloc_cell' takes as argument Z a cell whose `cdr' should + be a pointer to a block of memory of length OLEN allocated with + `must_malloc_cell' and modifies the `cdr' to point to a block of + memory of length LEN. `must_realloc' takes as argument WHERE the + address of a block of memory of length OLEN allocated by + `must_malloc' and returns the address of a block of length LEN. + + The contents of the reallocated block will be unchanged up to the + minimum of the old and new sizes. + + WHAT is a pointer to a string used for error and gc messages. + +`must_malloc', `must_malloc_cell', `must_realloc', and +`must_realloc_cell' must be called with interrupts deferred *Note +Signals::. `must_realloc' and `must_realloc_cell' must not be called +during initialization (non-zero errjmp_bad) - the initial allocations +must be large enough. + + - Function: void must_free (char *PTR, sizet LEN) + `must_free' is used to free a block of memory allocated by the + above functions and pointed to by PTR. LEN is the length of the + block in bytes, but this value is used only for debugging purposes. + If it is difficult or expensive to calculate then zero may be used + instead. + + +File: scm.info, Node: Embedding SCM, Next: Callbacks, Prev: Allocating memory, Up: Operations + +Embedding SCM +------------- + +The file `scmmain.c' contains the definition of main(). When SCM is +compiled as a library `scmmain.c' is not included in the library; a +copy of `scmmain.c' can be modified to use SCM as an embedded library +module. + + - Function: int main (int ARGC, char **ARGV) + This is the top level C routine. The value of the ARGC argument + is the number of command line arguments. The ARGV argument is a + vector of C strings; its elements are the individual command line + argument strings. A null pointer always follows the last element: + `ARGV[ARGC]' is this null pointer. + + - Variable: char *execpath + This string is the pathname of the executable file being run. This + variable can be examined and set from Scheme (*note Internal + State::). EXECPATH must be set to executable's path in order to + use DUMP (*note Dump::) or DLD. + +Rename main() and arrange your code to call it with an ARGV which sets +up SCM as you want it. + +If you need more control than is possible through ARGV, here are +descriptions of the functions which main() calls. + + - Function: void init_sbrk (void) + Call this before SCM calls malloc(). Value returned from sbrk() + is used to gauge how much storage SCM uses. + + - Function: char * scm_find_execpath (int ARGC, char **ARGV, char + *SCRIPT_ARG) + ARGC and ARGV are as described in main(). SCRIPT_ARG is the + pathname of the SCSH-style script (*note Scripting::) being + invoked; 0 otherwise. `scm_find_execpath' returns the pathname of + the executable being run; if `scm_find_execpath' cannot determine + the pathname, then it returns 0. + +`scm_find_implpath' is defined in `scmmain.c'. Preceeding this are +definitions ofGENERIC_NAME and INIT_GETENV. These, along with IMPLINIT +and DIRSEP control scm_find_implpath()'s operation. + +If your application has an easier way to locate initialization code for +SCM, then you can replace `scm_find_implpath'. + + - Function: char * scm_find_implpath (char *EXECPATH) + Returns the full pathname of the Scheme initialization file or 0 + if it cannot find it. + + The string value of the preprocessor variable INIT_GETENV names an + environment variable (default `"SCM_INIT_PATH"'). If this + environment variable is defined, its value will be returned from + `scm_find_implpath'. Otherwise find_impl_file() is called with the + arguments EXECPATH, GENERIC_NAME (default "scm"), INIT_FILE_NAME + (default "Init5d6_scm"), and the directory separator string + DIRSEP. If find_impl_file() returns 0 and IMPLINIT is defined, + then a copy of the string IMPLINIT is returned. + + - Function: int init_buf0 (FILE *INPORT) + Tries to determine whether INPORT (usually stdin) is an + interactive input port which should be used in an unbuffered mode. + If so, INPORT is set to unbuffered and non-zero is returned. + Otherwise, 0 is returned. + + `init_buf0' should be called before any input is read from INPORT. + Its value can be used as the last argument to + scm_init_from_argv(). + + - Function: void scm_init_from_argv (int ARGC, char **ARGV, char + *SCRIPT_ARG, int IVERBOSE, int BUF0STDIN) + Initializes SCM storage and creates a list of the argument strings + PROGRAM-ARGUMENTS from ARGV. ARGC and ARGV must already be + processed to accomodate Scheme Scripts (if desired). The scheme + variable *SCRIPT* is set to the string SCRIPT_ARG, or #f if + SCRIPT_ARG is 0. IVERBOSE is the initial prolixity level. If + BUF0STDIN is non-zero, stdin is treated as an unbuffered port. + +Call `init_signals' and `restore_signals' only if you want SCM to +handle interrupts and signals. + + - Function: void init_signals (void) + Initializes handlers for `SIGINT' and `SIGALRM' if they are + supported by the C implementation. All of the signal handlers + immediately reestablish themselves by a call to `signal()'. + + - Function: void restore_signals (void) + Restores the handlers in effect when `init_signals' was called. + + - Function: SCM scm_top_level (char *INITPATH, SCM (*toplvl_fun)()) + This is SCM's top-level. Errors longjmp here. TOPLVL_FUN is a + callback function of zero arguments that is called by + `scm_top_level' to do useful work - if zero, then `repl', which + implements a read-eval-print loop, is called. + + If TOPLVL_FUN returns, then `scm_top_level' will return as well. + If the return value of TOPLVL_FUN is an immediate integer then it + will be used as the return value of `scm_top_level'. In the main + function supplied with SCM, this return value is the exit status + of the process. + + If the first character of string INITPATH is `;', `(' or + whitespace, then scm_ldstr() is called with INITPATH to initialize + SCM; otherwise INITPATH names a file of Scheme code to be loaded + to initialize SCM. + + When a Scheme error is signaled; control will pass into + `scm_top_level' by `longjmp', error messages will be printed to + `current-error-port', and then TOPLVL_FUN will be called again. + TOPLVL_FUN must maintain enough state to prevent errors from being + resignalled. If `toplvl_fun' can not recover from an error + situation it may simply return. + + - Function: void final_scm (int FREEALL) + Calls all finalization routines registered with add_final(). If + FREEALL is non-zero, then all memory which SCM allocated with + malloc() will be freed. + +You can call indivdual Scheme procedures from C code in the TOPLVL_FUN +argument passed to scm_top_level(), or from module subrs (registered by +an `init_' function, *note Changing Scm::). + +Use `apply' to call Scheme procedures from your C code. For example: + + /* If this apply fails, SCM will catch the error */ + apply(CDR(intern("srv:startup",sizeof("srv:startup")-1)), + mksproc(srvproc), + listofnull); + + func = CDR(intern(rpcname,strlen(rpcname))); + retval = apply(func, cons(mksproc(srvproc), args), EOL); + +Functions for loading Scheme files and evaluating Scheme code given as +C strings are described in the next section, (*note Callbacks::). + +Here is a minimal embedding program `libtest.c': + + /* gcc -o libtest libtest.c libscm.a -ldl -lm -lc */ + #include "scm.h" + /* include patchlvl.h for SCM's INIT_FILE_NAME. */ + #include "patchlvl.h" + + void init_user_scm() + { + fputs("This is init_user_scm\n", stderr); fflush(stderr); + sysintern("*the-string*", makfrom0str("hello world\n")); + } + + SCM user_main() + { + static int done = 0; + if (done++) return MAKINUM(EXIT_FAILURE); + scm_ldstr("(display *the-string*)"); + return MAKINUM(EXIT_SUCCESS); + } + + int main(argc, argv) + int argc; + char **argv; + { + SCM retval; + char *implpath, *execpath; + + execpath = dld_find_executable(argv[0]); + fprintf(stderr, "dld_find_executable(%s): %s\n", argv[0], execpath); + implpath = find_impl_file(execpath, "scm", INIT_FILE_NAME, dirsep); + fprintf(stderr, "implpath: %s\n", implpath); + scm_init_from_argv(argc, argv, 0L, 0, 0); + + retval = scm_top_level(implpath, user_main); + + final_scm(!0); + return (int)INUM(retval); + } + + -| + dld_find_executable(./libtest): /home/jaffer/scm/libtest + implpath: /home/jaffer/scm/Init5d6.scm + This is init_user_scm + hello world + + +File: scm.info, Node: Callbacks, Next: Type Conversions, Prev: Embedding SCM, Up: Operations + +Callbacks +--------- + +SCM now has routines to make calling back to Scheme procedures easier. +The source code for these routines are found in `rope.c'. + + - Function: int scm_ldfile (char *FILE) + Loads the Scheme source file FILE. Returns 0 if successful, non-0 + if not. This function is used to load SCM's initialization file + `Init5d6.scm'. + + - Function: int scm_ldprog (char *FILE) + Loads the Scheme source file `(in-vicinity (program-vicinity) + FILE)'. Returns 0 if successful, non-0 if not. + + This function is useful for compiled code init_ functions to load + non-compiled Scheme (source) files. `program-vicinity' is the + directory from which the calling code was loaded (*note Vicinity: + (slib)Vicinity.). + + - Function: SCM scm_evstr (char *STR) + Returns the result of reading an expression from STR and + evaluating it. + + - Function: void scm_ldstr (char *STR) + Reads and evaluates all the expressions from STR. + +If you wish to catch errors during execution of Scheme code, then you +can use a wrapper like this for your Scheme procedures: + + (define (srv:protect proc) + (lambda args + (define result #f) ; put default value here + (call-with-current-continuation + (lambda (cont) + (dynamic-wind (lambda () #t) + (lambda () + (set! result (apply proc args)) + (set! cont #f)) + (lambda () + (if cont (cont #f)))))) + result)) + +Calls to procedures so wrapped will return even if an error occurs. + + +File: scm.info, Node: Type Conversions, Next: Continuations, Prev: Callbacks, Up: Operations + +Type Conversions +---------------- + +These type conversion functions are very useful for connecting SCM and C +code. Most are defined in `rope.c'. + + - Function: SCM long2num (long N) + - Function: SCM ulong2num (unsigned long N) + Return an object of type `SCM' corresponding to the `long' or + `unsigned long' argument N. If N cannot be converted, `BOOL_F' is + returned. Which numbers can be converted depends on whether SCM + was compiled with the `BIGDIG' or `FLOATS' flags. + + To convert integer numbers of smaller types (`short' or `char'), + use the macro `MAKINUM(n)'. + + - Function: long num2long (SCM NUM, char *POS, char *S_CALLER) + - Function: unsigned long num2ulong (SCM NUM, char *POS, char + *S_CALLER) + - Function: unsigned short num2ushort (SCM NUM, char *POS, char + *S_CALLER) + - Function: unsigned char num2uchar (SCM NUM, char *POS, char + *S_CALLER) + These functions are used to check and convert `SCM' arguments to + the named C type. The first argument NUM is checked to see it it + is within the range of the destination type. If so, the converted + number is returned. If not, the `ASSERT' macro calls `wta' with + NUM and strings POS and S_CALLER. For a listing of useful + predefined POS macros, *Note C Macros::. + + _Note:_ Inexact numbers are accepted only by `num2long' and + `num2ulong' (for when `SCM' is compiled without bignums). To + convert inexact numbers to exact numbers, *Note inexact->exact: + (r5rs)Numerical operations. + + - Function: unsigned long scm_addr (SCM ARGS, char *S_NAME) + Returns a pointer (cast to an `unsigned long') to the storage + corresponding to the location accessed by + `aref(CAR(args),CDR(args))'. The string S_NAME is used in any + messages from error calls by `scm_addr'. + + `scm_addr' is useful for performing C operations on strings or + other uniform arrays (*note Uniform Array::). + + _Note:_ While you use a pointer returned from `scm_addr' you must + keep a pointer to the associated `SCM' object in a stack allocated + variable or GC-protected location in order to assure that SCM does + not reuse that storage before you are done with it. + + - Function: SCM makfrom0str (char *SRC) + - Function: SCM makfromstr (char *SRC, sizet LEN) + Return a newly allocated string `SCM' object copy of the + null-terminated string SRC or the string SRC of length LEN, + respectively. + + - Function: SCM makfromstrs (int ARGC, char **ARGV) + Returns a newly allocated `SCM' list of strings corresponding to + the ARGC length array of null-terminated strings ARGV. If ARGV is + less than `0', ARGV is assumed to be `NULL' terminated. + `makfromstrs' is used by `scm_init_from_argv' to convert the + arguments SCM was called with to a `SCM' list which is the value + of SCM procedure calls to `program-arguments' (*note + program-arguments: SCM Session.). + + - Function: char ** makargvfrmstrs (SCM ARGS, char *S_NAME) + Returns a `NULL' terminated list of null-terminated strings copied + from the `SCM' list of strings ARGS. The string S_NAME is used in + messages from error calls by `makargvfrmstrs'. + + `makargvfrmstrs' is useful for constructing argument lists suitable + for passing to `main' functions. + + - Function: void must_free_argv (char **ARGV) + Frees the storage allocated to create ARGV by a call to + `makargvfrmstrs'. + + +File: scm.info, Node: Continuations, Next: Evaluation, Prev: Type Conversions, Up: Operations + +Continuations +------------- + +The source files `continue.h' and `continue.c' are designed to function +as an independent resource for programs wishing to use continuations, +but without all the rest of the SCM machinery. The concept of +continuations is explained in *Note call-with-current-continuation: +(r5rs)Control features. + +The C constructs `jmp_buf', `setjmp', and `longjmp' implement escape +continuations. On VAX and Cray platforms, the setjmp provided does not +save all the registers. The source files `setjump.mar', `setjump.s', +and `ugsetjump.s' provide implementations which do meet this criteria. + +SCM uses the names `jump_buf', `setjump', and `longjump' in lieu of +`jmp_buf', `setjmp', and `longjmp' to prevent name and declaration +conflicts. + + - Data type: CONTINUATION jmpbuf length stkbse other parent + is a `typedef'ed structure holding all the information needed to + represent a continuation. The OTHER slot can be used to hold any + data the user wishes to put there by defining the macro + `CONTINUATION_OTHER'. + + - Macro: SHORT_ALIGN + If `SHORT_ALIGN' is `#define'd (in `scmfig.h'), then the it is + assumed that pointers in the stack can be aligned on `short int' + boundaries. + + - Data type: STACKITEM + is a pointer to objects of the size specified by `SHORT_ALIGN' + being `#define'd or not. + + - Macro: CHEAP_CONTINUATIONS + If `CHEAP_CONTINUATIONS' is `#define'd (in `scmfig.h') each + `CONTINUATION' has size `sizeof CONTINUATION'. Otherwise, all but + "root" `CONTINUATION's have additional storage (immediately + following) to contain a copy of part of the stack. + + _Note:_ On systems with nonlinear stack disciplines (multiple + stacks or non-contiguous stack frames) copying the stack will not + work properly. These systems need to #define + `CHEAP_CONTINUATIONS' in `scmfig.h'. + + - Macro: STACK_GROWS_UP + Expresses which way the stack grows by its being `#define'd or not. + + - Variable: long thrown_value + Gets set to the VALUE passed to `throw_to_continuation'. + + - Function: long stack_size (STACKITEM *START) + Returns the number of units of size `STACKITEM' which fit between + START and the current top of stack. No check is done in this + routine to ensure that START is actually in the current stack + segment. + + - Function: CONTINUATION * make_root_continuation (STACKITEM + *STACK_BASE) + Allocates (`malloc') storage for a `CONTINUATION' of the current + extent of stack. This newly allocated `CONTINUATION' is returned + if successful, `0' if not. After `make_root_continuation' + returns, the calling routine still needs to + `setjump(NEW_CONTINUATION->jmpbuf)' in order to complete the + capture of this continuation. + + - Function: CONTINUATION * make_continuation (CONTINUATION + *PARENT_CONT) + Allocates storage for the current `CONTINUATION', copying (or + encapsulating) the stack state from `PARENT_CONT->stkbse' to the + current top of stack. The newly allocated `CONTINUATION' is + returned if successful, `0'q if not. After `make_continuation' + returns, the calling routine still needs to + `setjump(NEW_CONTINUATION->jmpbuf)' in order to complete the + capture of this continuation. + + - Function: void free_continuation (CONTINUATION *CONT) + Frees the storage pointed to by CONT. Remember to free storage + pointed to by `CONT->other'. + + - Function: void throw_to_continuation (CONTINUATION *CONT, long + VALUE, CONTINUATION *ROOT_CONT) + Sets `thrown_value' to VALUE and returns from the continuation + CONT. + + If `CHEAP_CONTINUATIONS' is `#define'd, then + `throw_to_continuation' does `longjump(CONT->jmpbuf, val)'. + + If `CHEAP_CONTINUATIONS' is not `#define'd, the CONTINUATION CONT + contains a copy of a portion of the C stack (whose bound must be + `CONT(ROOT_CONT)->stkbse'). Then: + + * the stack is grown larger than the saved stack, if neccessary. + + * the saved stack is copied back into it's original position. + + * `longjump(CONT->jmpbuf, val)'; + + +File: scm.info, Node: Evaluation, Prev: Continuations, Up: Operations + +Evaluation +---------- + +SCM uses its type representations to speed evaluation. All of the +`subr' types (*note Subr Cells::) are `tc7' types. Since the `tc7' +field is in the low order bit position of the `CAR' it can be retrieved +and dispatched on quickly by dereferencing the SCM pointer pointing to +it and masking the result. + +All the SCM "Special Forms" get translated to immediate symbols +(`isym') the first time they are encountered by the interpreter +(`ceval'). The representation of these immediate symbols is engineered +to occupy the same bits as `tc7'. All the `isym's occur only in the +`CAR' of lists. + +If the `CAR' of a expression to evaluate is not immediate, then it may +be a symbol. If so, the first time it is encountered it will be +converted to an immediate type `ILOC' or `GLOC' (*note Immediates::). +The codes for `ILOC' and `GLOC' lower 7 bits distinguish them from all +the other types we have discussed. + +Once it has determined that the expression to evaluate is not immediate, +`ceval' need only retrieve and dispatch on the low order 7 bits of the +`CAR' of that cell, regardless of whether that cell is a closure, +header, or subr, or a cons containing `ILOC' or `GLOC'. + +In order to be able to convert a SCM symbol pointer to an immediate +`ILOC' or `GLOC', the evaluator must be holding the pointer to the list +in which that symbol pointer occurs. Turning this requirement to an +advantage, `ceval' does not recursively call itself to evaluate symbols +in lists; It instead calls the macro "EVALCAR". `EVALCAR' does symbol +lookup and memoization for symbols, retrieval of values for `ILOC's and +`GLOC's, returns other immediates, and otherwise recursively calls +itself with the `CAR' of the list. + +`ceval' inlines evaluation (using `EVALCAR') of almost all procedure +call arguments. When `ceval' needs to evaluate a list of more than +length 3, the procedure `eval_args' is called. So `ceval' can be said +to have one level lookahead. The avoidance of recursive invocations of +`ceval' for the most common cases (special forms and procedure calls) +results in faster execution. The speed of the interpreter is currently +limited on most machines by interpreter size, probably having to do +with its cache footprint. In order to keep the size down, certain +`EVALCAR' calls which don't need to be fast (because they rarely occur +or because they are part of expensive operations) are instead calls to +the C function `evalcar'. + + - Variable: symhash + Top level symbol values are stored in the `symhash' table. + `symhash' is an array of lists of `ISYM's and pairs of symbols and + values. + + - Immediate: ILOC + Whenever a symbol's value is found in the local environment the + pointer to the symbol in the code is replaced with an immediate + object (`ILOC') which specifies how many environment frames down + and how far in to go for the value. When this immediate object is + subsequently encountered, the value can be retrieved quickly. + +`ILOC's work up to a maximum depth of 4096 frames or 4096 identifiers +in a frame. Radey Shouman added "FARLOC" to handle cases exceeding +these limits. A `FARLOC' consists of a pair whose CAR is the immediate +type `IM_FARLOC_CAR' or `IM_FARLOC_CDR', and whose CDR is a pair of +INUMs specifying the frame and distance with a larger range than +`ILOC's span. + +Adding `#define TEST_FARLOC' to `eval.c' causes `FARLOC's to be +generated for all local identifiers; this is useful only for testing +memoization. + + - Immediate: GLOC + Pointers to symbols not defined in local environments are changed + to one plus the value cell address in symhash. This incremented + pointer is called a `GLOC'. The low order bit is normally + reserved for GCmark; But, since references to variables in the + code always occur in the `CAR' position and the GCmark is in the + `CDR', there is no conflict. + +If the compile FLAG `CAUTIOUS' is #defined then the number of arguments +is always checked for application of closures. If the compile FLAG +`RECKLESS' is #defined then they are not checked. Otherwise, number of +argument checks for closures are made only when the function position +(whose value is the closure) of a combination is not an `ILOC' or +`GLOC'. When the function position of a combination is a symbol it +will be checked only the first time it is evaluated because it will +then be replaced with an `ILOC' or `GLOC'. + + - Macro: EVAL expression env + - Macro: SIDEVAL expression env + `EVAL' Returns the result of evaluating EXPRESSION in ENV. + `SIDEVAL' evaluates EXPRESSION in ENV when the value of the + expression is not used. + + Both of these macros alter the list structure of EXPRESSION as it + is memoized and hence should be used only when it is known that + EXPRESSION will not be referenced again. The C function `eval' is + safe from this problem. + + - Function: SCM eval (SCM EXPRESSION) + Returns the result of evaluating EXPRESSION in the top-level + environment. `eval' copies `expression' so that memoization does + not modify `expression'. + + +File: scm.info, Node: Program Self-Knowledge, Next: Improvements To Make, Prev: Operations, Up: The Implementation + +Program Self-Knowledge +====================== + +* Menu: + +* File-System Habitat:: +* Executable Pathname:: +* Script Support:: + + +File: scm.info, Node: File-System Habitat, Next: Executable Pathname, Prev: Program Self-Knowledge, Up: Program Self-Knowledge + +File-System Habitat +------------------- + +Where should software reside? Although individually a minor annoyance, +cumulatively this question represents many thousands of frustrated user +hours spent trying to find support files or guessing where packages need +to be installed. Even simple programs require proper habitat; games +need to find their score files. + +Aren't there standards for this? Some Operating Systems have devised +regimes of software habitats - only to have them violated by large +software packages and imports from other OS varieties. + +In some programs, the expected locations of support files are fixed at +time of compilation. This means that the program may not run on +configurations unanticipated by the authors. Compiling locations into a +program also can make it immovable - necessitating recompilation to +install it. + + Programs of the world unite! You have nothing to lose but loss + itself. + +The function `find_impl_file' in `scm.c' is an attempt to create a +utility (for inclusion in programs) which will hide the details of +platform-dependent file habitat conventions. It takes as input the +pathname of the executable file which is running. If there are systems +for which this information is either not available or unrelated to the +locations of support files, then a higher level interface will be +needed. + + - Function: char * find_impl_file (char *EXEC_PATH, char + *GENERIC_NAME, char *INITNAME, char *SEP) + Given the pathname of this executable (EXEC_PATH), test for the + existence of INITNAME in the implementation-vicinity of this + program. Return a newly allocated string of the path if + successful, 0 if not. The SEP argument is a _null-terminated + string_ of the character used to separate directory components. + + * One convention is to install the support files for an executable + program in the same directory as the program. This possibility is + tried first, which satisfies not only programs using this + convention, but also uninstalled builds when testing new releases, + etc. + + * Another convention is to install the executables in a directory + named `bin', `BIN', `exe', or `EXE' and support files in a + directroy named `lib', which is a peer the executable directory. + This arrangement allows multiple executables can be stored in a + single directory. For example, the executable might be in + `/usr/local/bin/' and initialization file in `/usr/local/lib/'. + + If the executable directory name matches, the peer directroy `lib' + is tested for INITNAME. + + * Sometimes `lib' directories become too crowded. So we look in any + subdirectories of `lib' or `src' having the name (sans type suffix + such as `.EXE') of the program we are running. For example, the + executable might be `/usr/local/bin/foo' and initialization file + in `/usr/local/lib/foo/'. + + * But the executable name may not be the usual program name; So also + look in any GENERIC_NAME subdirectories of `lib' or `src' peers. + + * Finally, if the name of the executable file being run has a (system + dependent) suffix which is not needed to invoke the program, then + look in a subdirectory (of the one containing the executable file) + named for the executable (without the suffix); And look in a + GENERIC_NAME subdirectory. For example, the executable might be + `C:\foo\bar.exe' and the initialization file in `C:\foo\bar\'. + + +File: scm.info, Node: Executable Pathname, Next: Script Support, Prev: File-System Habitat, Up: Program Self-Knowledge + +Executable Pathname +------------------- + +For purposes of finding `Init5d6.scm', dumping an executable, and +dynamic linking, a SCM session needs the pathname of its executable +image. + +When a program is executed by MS-DOS, the full pathname of that +executable is available in `argv[0]'. This value can be passed +directly to `find_impl_file' (*note File-System Habitat::). + +In order to find the habitat for a unix program, we first need to know +the full pathname for the associated executable file. + + - Function: char * dld_find_executable (const char *COMMAND) + `dld_find_executable' returns the absolute path name of the file + that would be executed if COMMAND were given as a command. It + looks up the environment variable PATH, searches in each of the + directory listed for COMMAND, and returns the absolute path name + for the first occurrence. Thus, it is advisable to invoke + `dld_init' as: + + main (int argc, char **argv) + { + ... + if (dld_init (dld_find_executable (argv[0]))) { + ... + } + ... + } + + *Note:* If the current process is executed using the `execve' + call without passing the correct path name as argument 0, + `dld_find_executable (argv[0]) ' will also fail to locate the + executable file. + + `dld_find_executable' returns zero if `command' is not found in + any of the directories listed in `PATH'. + + +File: scm.info, Node: Script Support, Prev: Executable Pathname, Up: Program Self-Knowledge + +Script Support +-------------- + +Source code for these C functions is in the file `script.c'. *Note +Scripting:: for a description of script argument processing. + +`script_find_executable' is only defined on unix systems. + + - Function: char * script_find_executable (const char *NAME) + `script_find_executable' returns the path name of the executable + which is invoked by the script file NAME; NAME if it is a binary + executable (not a script); or 0 if NAME does not exist or is not + executable. + + - Function: char ** script_process_argv (int ARGC; char **ARGV) + Given an "main" style argument vector ARGV and the number of + arguments, ARGC, `script_process_argv' returns a newly allocated + argument vector in which the second line of the script being + invoked is substituted for the corresponding meta-argument. + + If the script does not have a meta-argument, or if the file named + by the argument following a meta-argument cannot be opened for + reading, then 0 is returned. + + `script_process_argv' correctly processes argument vectors of + nested script invocations. + + - Function: int script_count_argv (char **ARGV) + Returns the number of argument strings in ARGV. + + +File: scm.info, Node: Improvements To Make, Prev: Program Self-Knowledge, Up: The Implementation + +Improvements To Make +==================== + + * Allow users to set limits for `malloc()' storage. + + * Prefix and make more uniform all C function, variable, and constant + names. Provide a file full of #define's to provide backward + compatability. + + * `lgcd()' _needs_ to generate at most one bignum, but currently + generates more. + + * `divide()' could use shifts instead of multiply and divide when + scaling. + + * Currently, `dump'ing an executable does not preserve ports. When + loading a `dump'ed executable, disk files could be reopened to the + same file and position as they had when the executable was dumped. + + * Copying all of the stack is wasteful of storage. Any time a + call-with-current-continuation is called the stack could be + re-rooted with a frame which calls the contin just created. This + in combination with checking stack depth could also be used to + allow stacks deeper than 64K on the IBM PC. + + * In the quest for speed, there has been some discussion about a + "Forth" style Scheme interpreter. + + Provided there is still type code space available in SCM, if + we devote some of the IMCAR codes to "inlined" operations, we + should get a significant performance boost. What is + eliminated is the having to look up a `GLOC' or `ILOC' and + then dispatch on the subr type. The IMCAR operation would be + dispatched to directly. Another way to view this is that we + make available special form versions of `CAR', `CDR', etc. + Since the actual operation code is localized in the + interpreter, it is much easier than uncompilation and then + recompilation to handle `(trace car)'; For instance a switch + gets set which tells the interpreter to instead always look + up the values of the associated symbols. + + +* Menu: + +* Finishing Dynamic Linking:: + + +File: scm.info, Node: Finishing Dynamic Linking, Prev: Improvements To Make, Up: Improvements To Make + +Finishing Dynamic Linking +------------------------- + +Scott Schwartz <schwartz@galapagos.cse.psu.edu> suggests: One way to +tidy up the dynamic loading stuff would be to grab the code from perl5. + +VMS +... + +George Carrette (gjc@mitech.com) outlines how to dynamically link on +VMS. There is already some code in `dynl.c' to do this, but someone +with a VMS system needs to finish and debug it. + + 1. Say you have this `main.c' program: + + main() + {init_lisp(); + lisp_repl();} + + 2. and you have your lisp in files `repl.c', `gc.c', `eval.c' and + there are some toplevel non-static variables in use called + `the_heap', `the_environment', and some read-only toplevel + structures, such as `the_subr_table'. + + $ LINK/SHARE=LISPRTL.EXE/DEBUG REPL.OBJ,GC.OBJ,EVAL.OBJ,LISPRTL.OPT/OPT + + 3. where `LISPRTL.OPT' must contain at least this: + + SYS$LIBRARY:VAXCRTL/SHARE + UNIVERSAL=init_lisp + UNIVERSAL=lisp_repl + PSECT_ATTR=the_subr_table,SHR,NOWRT,LCL + PSECT_ATTR=the_heap,NOSHR,LCL + PSECT_ATTR=the_environment,NOSHR,LCL + + _Notice:_ The "psect" (Program Section) attributes. + `LCL' + means to keep the name local to the shared library. You + almost always want to do that for a good clean library. + + `SHR,NOWRT' + means shared-read-only. Which is the default for code, and + is also good for efficiency of some data structures. + + `NOSHR,LCL' + is what you want for everything else. + + Note: If you do not have a handy list of all these toplevel + variables, do not dispair. Just do your link with the + /MAP=LISPRTL.MAP/FULL and then search the map file, + + $SEARCH/OUT=LISPRTL.LOSERS LISPRTL.MAP ", SHR,NOEXE, RD, WRT" + + And use an emacs keyboard macro to muck the result into the proper + form. Of course only the programmer can tell if things can be + made read-only. I have a DCL command procedure to do this if you + want it. + + 4. Now MAIN.EXE would be linked thusly: + + $ DEFINE LISPRTL USER$DISK:[JAFFER]LISPRTL.EXE + + $LINK MAIN.OBJ,SYS$INPUT:/OPT + SYS$LIBRARY:VAXCRTL/SHARE + LISPRTL/SHARE + + Note the definition of the `LISPRTL' logical name. Without such a + definition you will need to copy `LISPRTL.EXE' over to + `SYS$SHARE:' (aka `SYS$LIBRARY:') in order to invoke the main + program once it is linked. + + 5. Now say you have a file of optional subrs, `MYSUBRS.C'. And there + is a routine `INIT_MYSUBRS' that must be called before using it. + + $ CC MYSUBRS.C + $ LINK/SHARE=MYSUBRS.EXE MYSUBRS.OBJ,SYS$INPUT:/OPT + SYS$LIBRARY:VAXCRTL/SHARE + LISPRTL/SHARE + UNIVERSAL=INIT_MYSUBRS + + Ok. Another hint is that you can avoid having to add the `PSECT' + declaration of `NOSHR,LCL' by declaring variables `status' in the + C language source. That works great for most things. + + 6. Then the dynamic loader would have to do this: + + {void (*init_fcn)(); + long retval; + retval = lib$find_image_symbol("MYSUBRS","INIT_MYSUBRS",&init_fcn, + "SYS$DISK:[].EXE"); + if (retval != SS$_NORMAL) error(...); + (*init_fcn)();} + + But of course all string arguments must be `(struct dsc$descriptor + *)' and the last argument is optional if `MYSUBRS' is defined as a + logical name or if `MYSUBRS.EXE' has been copied over to + `SYS$SHARE'. The other consideration is that you will want to turn + off <C-c> or other interrupt handling while you are inside most + `lib$' calls. + + As far as the generation of all the `UNIVERSAL=...' declarations. + Well, you could do well to have that automatically generated from + the public `LISPRTL.H' file, of course. + + VMS has a good manual called the `Guide to Writing Modular + Procedures' or something like that, which covers this whole area + rather well, and also talks about advanced techniques, such as a + way to declare a program section with a pointer to a procedure + that will be automatically invoked whenever any shared image is + dynamically activated. Also, how to set up a handler for normal + or abnormal program exit so that you can clean up side effects + (such as opening a database). But for use with `LISPRTL' you + probably don't need that hair. + + One fancier option that is useful under VMS for `LISPLIB.EXE' is to + define all your exported procedures through an "call vector" + instead of having them just be pointers into random places in the + image, which is what you get by using `UNIVERSAL'. + + If you set up the call vector thing correctly it will allow you to + modify and relink `LISPLIB.EXE' without having to relink programs + that have been linked against it. + +Windows NT +.......... + +George Carrette (gjc@mitech.com) outlines how to dynamically link on +Windows NT: + + * The Software Developers Kit has a sample called SIMPLDLL. Here is + the gist of it, following along the lines of the VMS description + above (contents of a makefile for the SDK NMAKE) + + LISPLIB.exp: + LISPLIB.lib: LISPLIB.def + $(implib) -machine:$(CPU) -def:LISPLIB.def -out:LISPLIB.lib + + LISPLIB.DLL : $(LISPLIB_OBJS) LISPLIB.EXP + $(link) $(linkdebug) \ + -dll \ + -out:LISPLIB.DLL \ + LISPLIB.EXP $(LISPLIB_OBJS) $(conlibsdll) + + * The `LISPDEF.DEF' file has this: + + LIBRARY lisplib + EXPORT + init_lisp + init_repl + + * And `MAIN.EXE' using: + + CLINK = $(link) $(ldebug) $(conflags) -out:$*.exe $** $(conlibsdll) + + MAIN.EXE : MAIN.OBJ LISPLIB.LIB + $(CLINK) + + * And `MYSUBRS.DLL' is produced using: + + mysubrs.exp: + mysubrs.lib: mysubrs.def + $(implib) -machine:$(CPU) -def:MYSUBRS.def -out:MYSUBRS.lib + + mysubrs.dll : mysubrs.obj mysubrs.exp mysubrs.lib + $(link) $(linkdebug) \ + -dll \ + -out:mysubrs.dll \ + MYSUBRS.OBJ MYSUBRS.EXP LISPLIB.LIB $(conlibsdll) + + * Where `MYSUBRS.DEF' has + + LIBRARY mysubrs + EXPORT + INIT_MYSUBRS + + * And the dynamic loader looks something like this, calling the two + procedures `LoadLibrary' and `GetProcAddress'. + + LISP share_image_load(LISP fname) + {long iflag; + LISP retval,(*fcn)(void); + HANDLE hLib; + DWORD err; + char *libname,fcnname[64]; + iflag = nointerrupt(1); + libname = c_string(fname); + _snprintf(fcnname,sizeof(fcnname),"INIT_%s",libname); + if (!(hLib = LoadLibrary(libname))) + {err = GetLastError(); + retval = list2(fname,LSPNUM(err)); + serror1("library failed to load",retval);} + if (!(fcn = (LISP (*)(void)) GetProcAddress(hLib,fcnname))) + {err = GetLastError(); + retval = list2(fname,LSPNUM(err)); + serror1("could not find library init procedure",retval);} + retval = (*fcn)(); + nointerrupt(iflag); + return(retval);} + + * _Note:_ in VMS the linker and dynamic loader is case sensitive, but + all the language compilers, including C, will by default upper-case + external symbols for use by the linker, although the debugger gets + its own symbols and case sensitivity is language mode dependant. + In Windows NT things are case sensitive generally except for file + and device names, which are case canonicalizing like in the + Symbolics filesystem. + + * _Also:_ All this WINDOWS NT stuff will work in MS-DOS MS-Windows + 3.1 too, by a method of compiling and linking under Windows NT, + and then copying various files over to MS-DOS/WINDOWS. + + +File: scm.info, Node: Index, Prev: The Implementation, Up: Top + +Procedure and Macro Index +************************* + +This is an alphabetical list of all the procedures and macros in SCM. + +* Menu: + +* #!: Unix Scheme Scripts. +* #': Syntax Extensions. +* #+: Syntax Extensions. +* #-: Syntax Extensions. +* #.: Syntax Extensions. +* #;text-till-end-of-line: Syntax Extensions. +* #\token: Syntax Extensions. +* #|: Syntax Extensions. +* $abs: Numeric. +* $acos: Numeric. +* $acosh: Numeric. +* $asin: Numeric. +* $asinh: Numeric. +* $atan: Numeric. +* $atan2: Numeric. +* $atanh: Numeric. +* $cos: Numeric. +* $cosh: Numeric. +* $exp: Numeric. +* $expt: Numeric. +* $log: Numeric. +* $log10: Numeric. +* $sin: Numeric. +* $sinh: Numeric. +* $sqrt: Numeric. +* $tan: Numeric. +* $tanh: Numeric. +* -: SCM Options. +* ---: SCM Options. +* ---c-source-files=: Build Options. +* ---compiler-options=: Build Options. +* ---defines=: Build Options. +* ---features=: Build Options. +* ---help: SCM Options. +* ---initialization=: Build Options. +* ---libraries=: Build Options. +* ---linker-options=: Build Options. +* ---no-init-file: SCM Options. +* ---object-files=: Build Options. +* ---outname=: Build Options. +* ---platform=: Build Options. +* ---scheme-initial=: Build Options. +* ---type=: Build Options. +* ---version: SCM Options. +* --batch-dialect=: Build Options. +* --script-name=: Build Options. +* -a: SCM Options. +* -b: SCM Options. +* -c <1>: SCM Options. +* -c: Build Options. +* -d: SCM Options. +* -D: Build Options. +* -e: SCM Options. +* -f: SCM Options. +* -F: Build Options. +* -h <1>: SCM Options. +* -h: Build Options. +* -i <1>: SCM Options. +* -i: Build Options. +* -j: Build Options. +* -l <1>: SCM Options. +* -l: Build Options. +* -m: SCM Options. +* -no-init-file: SCM Options. +* -o <1>: SCM Options. +* -o: Build Options. +* -p <1>: SCM Options. +* -p: Build Options. +* -q: SCM Options. +* -r: SCM Options. +* -s <1>: SCM Options. +* -s: Build Options. +* -t: Build Options. +* -u: SCM Options. +* -v: SCM Options. +* -w: Build Options. +* @apply: Low Level Syntactic Hooks. +* @copy-tree: Miscellaneous Procedures. +* @macroexpand1: Syntactic Hooks for Hygienic Macros. +* _exclusive: Files and Ports. +* _ionbf: Files and Ports. +* _tracked: Files and Ports. +* abort: Internal State. +* access: I/O-Extensions. +* acct: Unix Extensions. +* acons: Miscellaneous Procedures. +* acosh: Numeric. +* add-alias: Configure Module Catalog. +* add-finalizer: Interrupts. +* add-link: Configure Module Catalog. +* add-source: Configure Module Catalog. +* alarm: Interrupts. +* alarm-interrupt: Interrupts. +* ALLOW_INTS: Signals. +* alrm_signal: Signals. +* ARGC: Cells. +* arithmetic-error: Interrupts. +* array->list: Conventional Arrays. +* array-contents: Conventional Arrays. +* array-copy!: Conventional Arrays. +* array-dimensions: Conventional Arrays. +* array-equal?: Conventional Arrays. +* array-fill!: Conventional Arrays. +* array-for-each: Array Mapping. +* array-in-bounds?: Conventional Arrays. +* array-index-map!: Array Mapping. +* array-map!: Array Mapping. +* array-prototype: Uniform Array. +* array-rank: Conventional Arrays. +* array-ref: Conventional Arrays. +* array-set!: Conventional Arrays. +* array-shape: Conventional Arrays. +* array? <1>: Uniform Array. +* array?: Conventional Arrays. +* asinh: Numeric. +* ASRTGO: C Macros. +* ASSERT: C Macros. +* atanh: Numeric. +* bit-count: Bit Vectors. +* bit-count*: Bit Vectors. +* bit-invert!: Bit Vectors. +* bit-position: Bit Vectors. +* bit-set*!: Bit Vectors. +* boot-tail <1>: Dump. +* boot-tail: SCM Session. +* box: Curses Miscellany. +* broken-pipe: Posix Extensions. +* call-with-outputs: Files and Ports. +* CAR: Cells. +* cbreak: Terminal Mode Setting. +* CCLO_LENGTH: Header Cells. +* CDR: Cells. +* char: Type Conversions. +* char-ready: Files and Ports. +* char-ready? <1>: Socket. +* char-ready?: Files and Ports. +* CHARS: Header Cells. +* chdir: I/O-Extensions. +* CHEAP_CONTINUATIONS: Continuations. +* chmod: I/O-Extensions. +* chown: Posix Extensions. +* clearok: Output Options Setting. +* close-port <1>: Window Manipulation. +* close-port <2>: Posix Extensions. +* close-port: Files and Ports. +* closedir: I/O-Extensions. +* CLOSEDP: Ptob Cells. +* CLOSUREP: Cells. +* CODE: Cells. +* comment: Syntax Extensions. +* CONSP: Cells. +* copy-tree: Miscellaneous Procedures. +* cosh: Numeric. +* could-not-open: Interrupts. +* current-error-port: Files and Ports. +* current-input-port: Files and Ports. +* current-time: Time. +* default-input-port: Line Editing. +* default-output-port: Line Editing. +* defconst: Syntax Extensions. +* DEFER_INTS: Signals. +* defined?: Syntax Extensions. +* defmacro: Syntax Extensions. +* defsyntax: Low Level Syntactic Hooks. +* defvar: Syntax Extensions. +* dimensions->uniform-array: Uniform Array. +* directory-for-each: I/O-Extensions. +* display: Output. +* dld_find_executable: Executable Pathname. +* dump: Dump. +* duplicate-port: I/O-Extensions. +* dyn:call: Dynamic Linking. +* dyn:link: Dynamic Linking. +* dyn:main-call: Dynamic Linking. +* dyn:unlink: Dynamic Linking. +* echo: Terminal Mode Setting. +* ed: Editing Scheme Code. +* enclose-array: Conventional Arrays. +* end-of-program: Interrupts. +* endwin: Curses. +* ENV: Cells. +* errno: Errors. +* error: Errors. +* eval: Evaluation. +* EVAL: Evaluation. +* eval: Miscellaneous Procedures. +* eval-string: Miscellaneous Procedures. +* exec-self: Internal State. +* execl: I/O-Extensions. +* execlp: I/O-Extensions. +* execpath: Internal State. +* execv: I/O-Extensions. +* execvp: I/O-Extensions. +* exit: SCM Session. +* extended-environment: Syntactic Hooks for Hygienic Macros. +* file-position: I/O-Extensions. +* file-set-position: I/O-Extensions. +* fileno: I/O-Extensions. +* final_scm: Embedding SCM. +* find_impl_file: File-System Habitat. +* force-output: Window Manipulation. +* fork: Posix Extensions. +* FPORTP: Ptob Cells. +* free_continuation: Continuations. +* freshline: Files and Ports. +* gc: Internal State. +* gc-hook: Interrupts. +* gc_mark: Marking Cells. +* GCCDR: Marking Cells. +* GCTYP16: Marking Cells. +* gentemp: Syntax Extensions. +* get-internal-real-time: Time. +* get-internal-run-time: Time. +* getcwd: I/O-Extensions. +* getegid: Posix Extensions. +* geteuid: Posix Extensions. +* getgid: Posix Extensions. +* getgr: Posix Extensions. +* getgroups: Posix Extensions. +* gethost: Host Data. +* getlogin: Posix Extensions. +* getnet: Host Data. +* getpeername: Internet Addresses and Socket Names. +* getpid: I/O-Extensions. +* getppid: Posix Extensions. +* getproto: Host Data. +* getpw: Posix Extensions. +* getserv: Host Data. +* getsockname: Internet Addresses and Socket Names. +* getuid: Posix Extensions. +* getyx: Input. +* hang-up: Interrupts. +* ICHR: Immediates. +* ICHRP: Immediates. +* identifier->symbol: Syntactic Hooks for Hygienic Macros. +* identifier-equal?: Syntactic Hooks for Hygienic Macros. +* identifier?: Syntactic Hooks for Hygienic Macros. +* idlok: Output Options Setting. +* IFLAGP: Immediates. +* IMP: Immediates. +* inet:address->string: Internet Addresses and Socket Names. +* inet:local-network-address: Internet Addresses and Socket Names. +* inet:make-address: Internet Addresses and Socket Names. +* inet:network: Internet Addresses and Socket Names. +* inet:string->address: Internet Addresses and Socket Names. +* init_buf0: Embedding SCM. +* init_sbrk: Embedding SCM. +* init_signals <1>: Embedding SCM. +* init_signals: Signals. +* initscr: Curses. +* INPORTP: Ptob Cells. +* int_signal: Signals. +* integer->line-number: Line Numbers. +* INUM: Immediates. +* INUMP: Immediates. +* isatty?: Files and Ports. +* ISYMCHARS: Immediates. +* ISYMNUM: Immediates. +* ISYMP: Immediates. +* kill: Posix Extensions. +* leaveok: Output Options Setting. +* LENGTH: Header Cells. +* line-editing: Line Editing. +* line-number: Miscellaneous Procedures. +* line-number->integer: Line Numbers. +* line-number?: Line Numbers. +* link: Posix Extensions. +* list->uniform-array: Uniform Array. +* list-file: Miscellaneous Procedures. +* load: Dynamic Linking. +* load-string: Miscellaneous Procedures. +* logaref: Uniform Array. +* logaset!: Uniform Array. +* long: Type Conversions. +* long2num: Type Conversions. +* lstat: Unix Extensions. +* macroexpand: Syntax Extensions. +* macroexpand-1: Syntax Extensions. +* main: Embedding SCM. +* makargvfrmstrs: Type Conversions. +* makcclo: Header Cells. +* make-arbiter: Process Synchronization. +* make-array: Conventional Arrays. +* make-edited-line-port: Line Editing. +* make-exchanger: Process Synchronization. +* make-shared-array: Conventional Arrays. +* make-soft-port: Soft Ports. +* make-stream-socket: Socket. +* make-stream-socketpair: Socket. +* make_continuation: Continuations. +* make_gsubr: Defining Subrs. +* make_root_continuation: Continuations. +* makfrom0str: Type Conversions. +* makfromstr: Type Conversions. +* makfromstrs: Type Conversions. +* MAKICHR: Immediates. +* MAKIFLAG: Immediates. +* MAKINUM: Immediates. +* MAKISYM: Immediates. +* MAKSPCSYM: Immediates. +* mark_locations: Marking Cells. +* milli-alarm: Interrupts. +* mkdir: I/O-Extensions. +* mknod: Unix Extensions. +* must_free: Allocating memory. +* must_free_argv: Type Conversions. +* must_malloc: Allocating memory. +* must_malloc_cell: Allocating memory. +* must_realloc: Allocating memory. +* must_realloc_cell: Allocating memory. +* mvwin: Window Manipulation. +* NCONSP: Cells. +* NEWCELL: Cells. +* newwin: Window Manipulation. +* nice: Unix Extensions. +* NIMP: Immediates. +* NINUMP: Immediates. +* nl: Terminal Mode Setting. +* nocbreak: Terminal Mode Setting. +* nodelay: Output Options Setting. +* noecho: Terminal Mode Setting. +* nonl: Terminal Mode Setting. +* noraw: Terminal Mode Setting. +* NSTRINGP: Header Cells. +* num2long: Type Conversions. +* NVECTORP: Header Cells. +* open-file: Files and Ports. +* open-input-pipe: Posix Extensions. +* open-output-pipe: Posix Extensions. +* open-pipe: Posix Extensions. +* open-ports: Files and Ports. +* opendir: I/O-Extensions. +* OPENP: Ptob Cells. +* OPFPORTP: Ptob Cells. +* OPINFPORTP: Ptob Cells. +* OPINPORTP: Ptob Cells. +* OPOUTFPORTP: Ptob Cells. +* OPOUTPORTP: Ptob Cells. +* OPPORTP: Ptob Cells. +* out-of-storage: Interrupts. +* OUTPORTP: Ptob Cells. +* overlay: Window Manipulation. +* overwrite: Window Manipulation. +* perror: Errors. +* pi*: Numeric. +* pi/: Numeric. +* pipe: Posix Extensions. +* port-closed?: Files and Ports. +* port-column: Miscellaneous Procedures. +* port-filename: Miscellaneous Procedures. +* port-line: Miscellaneous Procedures. +* port-type: Files and Ports. +* PORTP: Ptob Cells. +* print <1>: Miscellaneous Procedures. +* print: Debugging Scheme Code. +* print-args: Debugging Scheme Code. +* procedure->identifier-macro: Low Level Syntactic Hooks. +* procedure->macro: Low Level Syntactic Hooks. +* procedure->memoizing-macro: Low Level Syntactic Hooks. +* procedure->syntax: Low Level Syntactic Hooks. +* procedure-documentation: Syntax Extensions. +* profile-alarm: Interrupts. +* profile-alarm-interrupt: Interrupts. +* program-arguments: SCM Session. +* putenv: I/O-Extensions. +* qase: Syntax Extensions. +* quit: SCM Session. +* raw: Terminal Mode Setting. +* read-char <1>: Input. +* read-char: Files and Ports. +* read-numbered: Line Numbers. +* read:sharp: Low Level Syntactic Hooks. +* read:sharp-char: Low Level Syntactic Hooks. +* readdir: I/O-Extensions. +* readlink: Unix Extensions. +* record-printer-set!: Records. +* redirect-port!: I/O-Extensions. +* refresh: Window Manipulation. +* regcomp: Regular Expression Pattern Matching. +* regerror: Regular Expression Pattern Matching. +* regexec: Regular Expression Pattern Matching. +* regmatch: Regular Expression Pattern Matching. +* regmatch?: Regular Expression Pattern Matching. +* regmatchv: Regular Expression Pattern Matching. +* regsearch: Regular Expression Pattern Matching. +* regsearchv: Regular Expression Pattern Matching. +* release-arbiter: Process Synchronization. +* rename-file: I/O-Extensions. +* renamed-identifier: Syntactic Hooks for Hygienic Macros. +* renaming-transformer: Syntactic Hooks for Hygienic Macros. +* reopen-file: I/O-Extensions. +* require: Dynamic Linking. +* resetty: Terminal Mode Setting. +* restart: Internal State. +* restore_signals: Embedding SCM. +* rewinddir: I/O-Extensions. +* rmdir: I/O-Extensions. +* room: Internal State. +* savetty: Terminal Mode Setting. +* scalar->array: Array Mapping. +* scm_evstr: Callbacks. +* scm_find_execpath: Embedding SCM. +* scm_find_implpath: Embedding SCM. +* scm_init_from_argv: Embedding SCM. +* scm_ldfile: Callbacks. +* scm_ldprog: Callbacks. +* scm_ldstr: Callbacks. +* scm_top_level: Embedding SCM. +* script_count_argv: Script Support. +* script_find_executable: Script Support. +* script_process_argv: Script Support. +* scroll: Output. +* scrollok: Output Options Setting. +* serial-array-copy!: Conventional Arrays. +* serial-array-map!: Array Mapping. +* set!: Syntax Extensions. +* setegid: Posix Extensions. +* seteuid: Posix Extensions. +* setgid: Posix Extensions. +* setgrent: Posix Extensions. +* sethostent: Host Data. +* setnetent: Host Data. +* setprotoent: Host Data. +* setpwent: Posix Extensions. +* setservent: Host Data. +* setuid: Posix Extensions. +* short: Type Conversions. +* SHORT_ALIGN: Continuations. +* SIDEVAL: Evaluation. +* sinh: Numeric. +* socket-name:address: Internet Addresses and Socket Names. +* socket-name:family: Internet Addresses and Socket Names. +* socket-name:port-number: Internet Addresses and Socket Names. +* socket:accept: Socket. +* socket:bind: Socket. +* socket:connect: Socket. +* socket:listen: Socket. +* socket:shutdown: Socket. +* stack-trace: Errors. +* STACK_GROWS_UP: Continuations. +* stack_size: Continuations. +* stat: I/O-Extensions. +* STREAM: Ptob Cells. +* string-edit: Regular Expression Pattern Matching. +* string-split: Regular Expression Pattern Matching. +* string-splitv: Regular Expression Pattern Matching. +* STRINGP: Header Cells. +* subwin: Window Manipulation. +* SYMBOLP: Header Cells. +* symlink: Unix Extensions. +* sync: Unix Extensions. +* syntax-quote: Syntactic Hooks for Hygienic Macros. +* syntax-rules: Syntax Extensions. +* tanh: Numeric. +* terms: Miscellaneous Procedures. +* the-macro: Syntactic Hooks for Hygienic Macros. +* throw_to_continuation: Continuations. +* ticks: Interrupts. +* ticks-interrupt: Interrupts. +* touchline: Window Manipulation. +* touchwin: Window Manipulation. +* trace: Debugging Scheme Code. +* transpose-array: Conventional Arrays. +* try-arbiter: Process Synchronization. +* try-create-file: I/O-Extensions. +* try-load <1>: Line Numbers. +* try-load: Miscellaneous Procedures. +* try-open-file: Files and Ports. +* ttyname: Posix Extensions. +* TYP16: Cells. +* TYP3: Cells. +* TYP7: Cells. +* UCHARS: Header Cells. +* ulong2num: Type Conversions. +* umask: I/O-Extensions. +* uname: Posix Extensions. +* unctrl: Curses Miscellany. +* uniform-array-read!: Uniform Array. +* uniform-array-write: Uniform Array. +* uniform-vector-fill!: Uniform Array. +* untrace: Debugging Scheme Code. +* user-interrupt: Interrupts. +* usr:lib: Dynamic Linking. +* utime: I/O-Extensions. +* vector-set-length!: Miscellaneous Procedures. +* VECTORP: Header Cells. +* VELTS: Header Cells. +* verbose: Internal State. +* virtual-alarm: Interrupts. +* virtual-alarm-interrupt: Interrupts. +* vms-debug: SCM Session. +* void: Sweeping the Heap. +* wadd: Output. +* wait-for-input: Files and Ports. +* waitpid: Posix Extensions. +* warn: Errors. +* wclear: Output. +* wclrtobot: Output. +* wclrtoeol: Output. +* wdelch: Output. +* wdeleteln: Output. +* werase: Output. +* winch: Input. +* winsch: Output. +* winsertln: Output. +* with-error-to-file: Files and Ports. +* with-error-to-port: Files and Ports. +* with-input-from-port: Files and Ports. +* with-output-to-port: Files and Ports. +* wmove: Window Manipulation. +* wstandend: Curses Miscellany. +* wstandout: Curses Miscellany. +* x:lib: Dynamic Linking. + +Variable Index +************** + +This is an alphabetical list of all the global variables in SCM. + +* Menu: + +* $pi: Numeric. +* *argv*: SCM Variables. +* *execpath: Embedding SCM. +* *interactive* <1>: Internal State. +* *interactive*: SCM Variables. +* *load-pathname*: Miscellaneous Procedures. +* *load-reader*: Line Numbers. +* *scm-version*: Internal State. +* *slib-load-reader*: Line Numbers. +* *syntax-rules*: SCM Variables. +* af_inet: Host Data. +* af_unix: Host Data. +* BOOL_F: Immediates. +* BOOL_T: Immediates. +* EDITOR: SCM Variables. +* EOF_VAL: Immediates. +* EOL: Immediates. +* errobj: Errors. +* HOME: SCM Variables. +* internal-time-units-per-second: Time. +* INUM0: Immediates. +* isymnames: Immediates. +* most-negative-fixnum: Numeric. +* most-positive-fixnum: Numeric. +* NUM_ISPCSYM: Immediates. +* NUM_ISYMS: Immediates. +* open_both: Files and Ports. +* open_read: Files and Ports. +* open_write: Files and Ports. +* pi: Numeric. +* SCHEME_LIBRARY_PATH: SCM Variables. +* SCM_INIT_PATH: SCM Variables. +* symhash: Evaluation. +* thrown_value: Continuations. +* UNDEFINED: Immediates. +* UNSPECIFIED: Immediates. + +Type Index +********** + +This is an alphabetical list of data types and feature names in SCM. + +* Menu: + +* #! <1>: MS-DOS Compatible Scripts. +* #!: Unix Scheme Scripts. +* array-for-each: Array Mapping. +* CELLPTR: Immediates. +* CONTINUATION: Continuations. +* curses: Dynamic Linking. +* dump: Dump. +* FARLOC: Evaluation. +* GLOC: Evaluation. +* gloc: Immediates. +* i/o-extensions: Socket. +* ichr: Immediates. +* iflags: Immediates. +* ILOC: Evaluation. +* iloc: Immediates. +* inum: Immediates. +* ispcsym: Immediates. +* isym: Immediates. +* meta-argument <1>: Script Support. +* meta-argument: Unix Scheme Scripts. +* ptob: Ptob Cells. +* regex: Dynamic Linking. +* rev2-procedures: Dynamic Linking. +* rev3-procedures: Dynamic Linking. +* Scheme Script <1>: MS-DOS Compatible Scripts. +* Scheme Script: Unix Scheme Scripts. +* Scheme-Script <1>: MS-DOS Compatible Scripts. +* Scheme-Script: Unix Scheme Scripts. +* smob: Smob Cells. +* socket: Socket. +* spare: Header Cells. +* STACKITEM: Continuations. +* tc16_arbiter: Smob Cells. +* tc16_array: Smob Cells. +* tc16_bigneg: Smob Cells. +* tc16_bigpos: Smob Cells. +* tc16_flo: Smob Cells. +* tc16_inpipe: Ptob Cells. +* tc16_inport: Ptob Cells. +* tc16_ioport: Ptob Cells. +* tc16_macro: Smob Cells. +* tc16_outpipe: Ptob Cells. +* tc16_outport: Ptob Cells. +* tc16_promise: Smob Cells. +* tc16_sfport: Ptob Cells. +* tc16_strport: Ptob Cells. +* tc3_closure: Cells. +* tc3_cons: Cells. +* tc7_asubr: Subr Cells. +* tc7_bvect: Header Cells. +* tc7_contin: Header Cells. +* tc7_cvect: Header Cells. +* tc7_cxr: Subr Cells. +* tc7_dvect: Header Cells. +* tc7_fvect: Header Cells. +* tc7_ivect: Header Cells. +* tc7_lsubr: Subr Cells. +* tc7_lsubr_2: Subr Cells. +* tc7_msymbol: Header Cells. +* tc7_rpsubr: Subr Cells. +* tc7_specfun: Header Cells. +* tc7_ssymbol: Header Cells. +* tc7_string: Header Cells. +* tc7_subr_0: Subr Cells. +* tc7_subr_1: Subr Cells. +* tc7_subr_1o: Subr Cells. +* tc7_subr_2: Subr Cells. +* tc7_subr_2o: Subr Cells. +* tc7_subr_3: Subr Cells. +* tc7_svect: Header Cells. +* tc7_uvect: Header Cells. +* tc7_vector: Header Cells. +* tc_dblc: Smob Cells. +* tc_dblr: Smob Cells. +* tc_free_cell: Smob Cells. +* turtle-graphics: Dynamic Linking. +* unexec: Dump. + +This is an alphabetical list of concepts introduced in this manual. + +Concept Index +************* + +* Menu: + +* !#: MS-DOS Compatible Scripts. +* !#.exe: MS-DOS Compatible Scripts. +* #!: MS-DOS Compatible Scripts. +* #!.bat: MS-DOS Compatible Scripts. +* array <1>: Conventional Arrays. +* array: Build Options. +* array-for-each: Build Options. +* arrays: Build Options. +* bignums: Build Options. +* callbacks: Callbacks. +* careful-interrupt-masking: Build Options. +* cautious: Build Options. +* cheap-continuations: Build Options. +* compiled-closure: Build Options. +* continuations: Continuations. +* curses: Build Options. +* debug: Build Options. +* documentation string: Syntax Extensions. +* dump: Build Options. +* dynamic-linking: Build Options. +* ecache: Memory Management for Environments. +* edit-line: Build Options. +* Embedding SCM: Embedding SCM. +* engineering-notation: Build Options. +* environments: Memory Management for Environments. +* exchanger: Process Synchronization. +* Exrename: Bibliography. +* Extending Scm: Compiling and Linking Custom Files. +* foo.c: Compiling and Linking Custom Files. +* generalized-c-arguments: Build Options. +* graphics: Packages. +* hobbit: Packages. +* i/o-extensions: Build Options. +* IEEE: Bibliography. +* inexact: Build Options. +* JACAL: Bibliography. +* lit: Build Options. +* macro: Build Options. +* memory management: Memory Management for Environments. +* mysql: Build Options. +* no-heap-shrink: Build Options. +* NO_ENV_CACHE: Memory Management for Environments. +* none: Build Options. +* posix: Build Options. +* R4RS: Bibliography. +* R5RS: Bibliography. +* reckless: Build Options. +* record: Build Options. +* regex: Build Options. +* rev2-procedures: Build Options. +* SchemePrimer: Bibliography. +* SICP: Build Options. +* sicp: Build Options. +* SICP: Bibliography. +* signals: Signals. +* Simply: Bibliography. +* single-precision-only: Build Options. +* SLIB: Bibliography. +* socket: Build Options. +* stack-limit: Build Options. +* tick-interrupts: Build Options. +* turtlegr: Build Options. +* unix: Build Options. +* windows: Build Options. +* X: Packages. +* x <1>: Packages. +* x: Build Options. +* xlib: Packages. +* Xlib: Packages. +* xlib: Build Options. +* xlibscm: Packages. +* Xlibscm: Packages. + + + +Tag Table: +Node: Top203 +Node: Overview1426 +Node: SCM Features1737 +Node: SCM Authors3749 +Node: Copying4645 +Node: Bibliography7730 +Node: Installing SCM9598 +Node: Making SCM10113 +Node: SLIB11030 +Node: Building SCM12945 +Node: Invoking Build13519 +Node: Build Options15793 +Node: Compiling and Linking Custom Files27939 +Node: Installing Dynamic Linking29902 +Node: Configure Module Catalog31686 +Node: Saving Images33683 +Node: Automatic C Preprocessor Definitions34358 +Node: Problems Compiling37629 +Node: Problems Linking39282 +Node: Problems Running39547 +Node: Testing41622 +Node: Reporting Problems44659 +Node: Operational Features45504 +Node: Invoking SCM45868 +Node: SCM Options47473 +Node: Invocation Examples51745 +Node: SCM Variables52697 +Node: SCM Session54127 +Node: Editing Scheme Code55465 +Node: Debugging Scheme Code57608 +Node: Errors61231 +Node: Memoized Expressions65459 +Node: Internal State67815 +Node: Scripting70895 +Node: Unix Scheme Scripts71189 +Node: MS-DOS Compatible Scripts74401 +Node: Unix Shell Scripts76213 +Node: The Language78403 +Node: Standards Compliance78995 +Node: Miscellaneous Procedures81409 +Node: Time84509 +Node: Interrupts85503 +Node: Process Synchronization90581 +Node: Files and Ports92118 +Node: Line Numbers97992 +Node: Soft Ports100234 +Node: Syntax Extensions102032 +Node: Low Level Syntactic Hooks111007 +Node: Syntactic Hooks for Hygienic Macros116212 +Node: Packages123186 +Node: Dynamic Linking123988 +Node: Dump128597 +Node: Numeric132606 +Node: Arrays134333 +Node: Conventional Arrays134543 +Node: Array Mapping141171 +Node: Uniform Array143397 +Node: Bit Vectors148645 +Node: Records149910 +Node: I/O-Extensions150773 +Node: Posix Extensions159362 +Node: Unix Extensions169048 +Node: Regular Expression Pattern Matching170950 +Node: Line Editing174904 +Node: Curses176250 +Node: Output Options Setting177173 +Node: Terminal Mode Setting179822 +Node: Window Manipulation182900 +Node: Output186360 +Node: Input189986 +Node: Curses Miscellany191013 +Node: Sockets192437 +Node: Host Data192761 +Node: Internet Addresses and Socket Names195909 +Node: Socket197443 +Node: The Implementation204680 +Node: Data Types204939 +Node: Immediates205760 +Node: Cells210096 +Node: Header Cells212188 +Node: Subr Cells215229 +Node: Ptob Cells217447 +Node: Smob Cells218986 +Node: Data Type Representations222182 +Node: Operations226835 +Node: Garbage Collection227421 +Node: Marking Cells228042 +Node: Sweeping the Heap230144 +Node: Memory Management for Environments231089 +Node: Signals235646 +Node: C Macros237190 +Node: Changing Scm238313 +Node: Defining Subrs242572 +Node: Defining Smobs244449 +Node: Defining Ptobs247495 +Node: Allocating memory248672 +Node: Embedding SCM250985 +Node: Callbacks258587 +Node: Type Conversions260330 +Node: Continuations263886 +Node: Evaluation268100 +Node: Program Self-Knowledge273263 +Node: File-System Habitat273509 +Node: Executable Pathname277109 +Node: Script Support278713 +Node: Improvements To Make280031 +Node: Finishing Dynamic Linking282063 +Node: Index289809 + +End Tag Table @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -47,7 +47,9 @@ # define strchr index # define strrchr rindex #else -# include <string.h> +# ifndef PLAN9 +# include <string.h> +# endif #endif #include "scmflags.h" /* user specified, system independent flags */ @@ -106,7 +108,7 @@ rgx.c init_rgx(); regcomp and regexec. */ # define CDR_DOUBLES # endif -# ifdef _UNICOS /* doubles are no better than singles on Cray. */ +# ifdef _UNICOS /* doubles are no better than singles on Cray. */ # define SINGLESONLY # endif @@ -211,7 +213,7 @@ rgx.c init_rgx(); regcomp and regexec. */ #endif /* added by Denys Duchier */ #ifndef SVR4 -# ifdef __svr4__ +# ifdef __SVR4 # define SVR4 # endif #endif @@ -262,6 +264,7 @@ rgx.c init_rgx(); regcomp and regexec. */ #endif #ifdef _WIN32 # define MSDOS +# define LACK_SBRK # define LACK_TIMES #endif #ifdef _MSDOS @@ -297,13 +300,17 @@ rgx.c init_rgx(); regcomp and regexec. */ # define STDC_HEADERS # define USE_ANSI_PROTOTYPES # define HAVE_SYS_TIME_H -# define __svr4__ +# define __SVR4 #endif -#ifdef __svr4__ +#ifdef __SVR4 # define HAVE_SELECT #endif +#ifdef PLAN9 +# define STDC_HEADERS +#endif + #ifdef hpux # define LACK_E_IDs #endif @@ -312,6 +319,7 @@ rgx.c init_rgx(); regcomp and regexec. */ #ifdef __IBMC__ # define STDC_HEADERS # define LACK_TIMES +# define LACK_SBRK #endif #ifdef __CYGWIN32__ @@ -321,7 +329,7 @@ rgx.c init_rgx(); regcomp and regexec. */ # undef MSDOS #endif -#ifdef __amigados__ +#ifdef __amigaos__ # define HAVE_SELECT # define HAVE_SYS_TIME_H # define LACK_SBRK @@ -409,26 +417,26 @@ rgx.c init_rgx(); regcomp and regexec. */ # define ALLOW_INTS_EGC /**/ #else # ifdef CAREFUL_INTS -typedef struct {char *fname; long linum;} ints_infot; +typedef struct {char *fname; int linum;} ints_infot; extern ints_infot *ints_info; # define VERIFY_INTS(s1, s2) {if (!ints_disabled)\ - ints_warn(s1, s2, __FILE__,__LINE__); } + ints_warn(s1, s2, __FILE__, __LINE__); } # define DEFER_INTS \ {static ints_infot info = {__FILE__, __LINE__};\ FENCE;if (1==ints_disabled) ints_viol(&info, 1);\ - else {ints_info = &info; ints_disabled = 1;FENCE;}} + else {ints_info = &info; ints_disabled = 1;FENCE;}} # define ALLOW_INTS \ {static ints_infot info = {__FILE__, __LINE__};\ FENCE;if (1!=ints_disabled) ints_viol(&info, 0);\ - else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}} + else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}} # define DEFER_INTS_EGC \ {static ints_infot info = {__FILE__, __LINE__};\ FENCE;if (1==ints_disabled) ints_viol(&info, 1);\ - else {ints_info = &info; ints_disabled = 2;FENCE;}} + else {ints_info = &info; ints_disabled = 2;FENCE;}} # define ALLOW_INTS_EGC \ {static ints_infot info = {__FILE__, __LINE__};\ FENCE;if (1==ints_disabled) ints_viol(&info, 0);\ - else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}} + else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}} # else # define VERIFY_INTS(s1, s2) /**/ # define DEFER_INTS {FENCE;ints_disabled = 1;FENCE;} @@ -462,8 +470,14 @@ extern ints_infot *ints_info; # define PTR2SCM(x) (((SCM)(x)) << 3) # define POINTERS_MUNGED #else -# define SCM2PTR(x) (x) -# define PTR2SCM(x) ((SCM)(x)) +# ifdef TEST_SCM2PTR +# define SCM2PTR(x) ((x) ^ 0xf0L) +# define PTR2SCM(x) (((SCM)(x)) ^ 0xf0L) +# define POINTERS_MUNGED +# else +# define SCM2PTR(x) (x) +# define PTR2SCM(x) ((SCM)(x)) +# endif #endif /* FIXABLE is non-null if its long argument can be encoded in an INUM. */ @@ -576,7 +590,9 @@ extern ints_infot *ints_info; #ifdef FLOATS # ifdef STDC_HEADERS # ifndef macintosh -# include <float.h> +# ifndef PLAN9 +# include <float.h> +# endif # endif # endif # ifdef DBL_MAX_10_EXP @@ -597,12 +613,19 @@ extern ints_infot *ints_info; # endif #endif -/* Only some machines have pipes */ +#ifdef unix +# define HAVE_UNIX +#endif +#ifdef __unix__ +# define HAVE_UNIX +#endif #ifdef _IBMR2 -# define unix +# define HAVE_UNIX # define STDC_HEADERS #endif -#ifdef unix + +/* Only some machines have pipes */ +#ifdef HAVE_UNIX /* DJGPP (gcc for i386) defines unix! */ # define HAVE_PIPE #endif @@ -644,12 +667,20 @@ typedef SCM *SCMPTR; # endif #endif +#define PTR_GT(x, y) PTR_LT(y, x) +#define PTR_LE(x, y) (!PTR_GT(x, y)) +#define PTR_GE(x, y) (!PTR_LT(x, y)) + #ifdef STDC_HEADERS -# include <stdlib.h> -# ifdef AMIGA -# include <stddef.h> +# ifdef PLAN9 +# define sizet long +# else +# include <stdlib.h> +# ifdef AMIGA +# include <stddef.h> +# endif +# define sizet size_t # endif -# define sizet size_t #else # ifdef _SIZE_T # define sizet size_t @@ -665,7 +696,9 @@ typedef SCM *SCMPTR; /* On VMS, GNU C's errno.h contains a special hack to get link attributes for errno correct for linking with libc. */ -#include <errno.h> +#ifndef PLAN9 +# include <errno.h> +#endif /* SYSCALL retries system calls that have been interrupted (EINTR) */ #ifdef vms @@ -691,15 +724,19 @@ typedef SCM *SCMPTR; #define SYSCALL(line) do{errno = 0;line}while(SCM_INTERRUPTED(errno)) #ifdef EMFILE -# define SCM_NEED_FDS(errno) (EMFILE==errno || ENFILE==errno) +# ifdef ENFILE +# define SCM_NEED_FDS(errno) (EMFILE==errno || ENFILE==errno) +# else +# define SCM_NEED_FDS(errno) (EMFILE==errno) +# endif #else # define SCM_NEED_FDS(errno) (0) #endif #define SCM_OPENCALL(line) {int gcs = 0;\ - while (!0) {errno = 0; if (line) break;\ - if (0==gcs++ && SCM_NEED_FDS(errno)) \ - gc_for_open_files();\ + while (!0) {errno = 0; if (line) break;\ + if (0==gcs++ && SCM_NEED_FDS(errno)) \ + gc_for_open_files();\ else if (!SCM_INTERRUPTED(errno)) break;}} #ifndef MSDOS @@ -751,4 +788,12 @@ typedef SCM *SCMPTR; # define VOLATILE /**/ #endif +#ifdef _MSC_VER + // Disable annoying warnings for: +# pragma warning (disable: 4102) // unreferenced label +# pragma warning (disable: 4018) // signed/unsigned mismatch +# pragma warning (disable: 4101) // unreferenced variables +# pragma warning (disable: 4244) // conversion from unsigned long to unsigned short +#endif + /* end of automatic C pre-processor definitions */ diff --git a/scmhob.h b/scmhob.h new file mode 100644 index 0000000..b1480c1 --- /dev/null +++ b/scmhob.h @@ -0,0 +1,105 @@ +/* scmhob.h is a header file for scheme source compiled with hobbit5x + Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997 Tanel Tammet + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 1, or (at your option) +any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +*/ + +#include "scm.h" + +#define STBL_VECTOR_SET(v,k,o) (v[((long)INUM(k))] = o) +#define STBL_VECTOR_REF(v,k) (v[((long)INUM(k))]) +#define CHAR_LESSP(x,y) ((ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F) +#define CHAR_LEQP(x,y) ((ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F) +#define CHCI_EQ(x,y) ((upcase[ICHR(x)]==upcase[ICHR(y)]) ? BOOL_T : BOOL_F) +#define CHCI_LESSP(x,y) ((upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F) +#define CHCI_LEQP(x,y) ((upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F) +#define CHAR_ALPHAP(chr) ((isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F) +#define CHAR_NUMP(chr) ((isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F) +#define CHAR_WHITEP(chr) ((isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F) +#define CHAR_UPPERP(chr) ((isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F) +#define CHAR_LOWERP(chr) ((isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F) +#define CHAR2INT(chr) MAKINUM(ICHR(chr)) +#define INT2CHAR(n) MAKICHR(INUM(n)) +#define CHAR_UPCASE(chr) MAKICHR(upcase[ICHR(chr)]) +#define CHAR_DOWNCASE(chr) MAKICHR(downcase[ICHR(chr)]) +#define ST_LENGTH(str) MAKINUM(LENGTH(str)) +#define ST_REF(str,k) MAKICHR(CHARS(str)[INUM(k)]) +#define VECTOR_LENGTH(v) MAKINUM(LENGTH(v)) + +#ifdef FLOATS +#include <math.h> +#endif +#ifdef BIGDIG +#define PRE_TRANSC_FUN(x) (INUMP(x) ? (double) INUM(x) : (REALP(x) ? (double) REALPART(x) : (double) big2dbl(x))) +#else +#define PRE_TRANSC_FUN(x) (INUMP(x) ? (double) INUM(x) : (double) REALPART(x)) +#endif + +#define SIN_FUN(x) (makdbl( sin( PRE_TRANSC_FUN(x)), 0.0)) +#define COS_FUN(x) (makdbl( cos( PRE_TRANSC_FUN(x)), 0.0)) +#define TAN_FUN(x) (makdbl( tan( PRE_TRANSC_FUN(x)), 0.0)) +#define ASIN_FUN(x) (makdbl( asin( PRE_TRANSC_FUN(x)), 0.0)) +#define ACOS_FUN(x) (makdbl( acos( PRE_TRANSC_FUN(x)), 0.0)) +#define ATAN_FUN(x) (makdbl( atan( PRE_TRANSC_FUN(x)), 0.0)) +#define SINH_FUN(x) (makdbl( sinh( PRE_TRANSC_FUN(x)), 0.0)) +#define COSH_FUN(x) (makdbl( cosh( PRE_TRANSC_FUN(x)), 0.0)) +#define TANH_FUN(x) (makdbl( tanh( PRE_TRANSC_FUN(x)), 0.0)) +#define ASINH_FUN(x) (makdbl( asinh( PRE_TRANSC_FUN(x)), 0.0)) +#define ACOSH_FUN(x) (makdbl( acosh( PRE_TRANSC_FUN(x)), 0.0)) +#define ATANH_FUN(x) (makdbl( atanh( PRE_TRANSC_FUN(x)), 0.0)) +#define SQRT_FUN(x) (makdbl( sqrt( PRE_TRANSC_FUN(x)), 0.0)) +#define EXPT_FUN(x,y) (makdbl( pow(( PRE_TRANSC_FUN(x)), ( PRE_TRANSC_FUN(y))), 0.0)) +#define EXP_FUN(x) (makdbl( exp( PRE_TRANSC_FUN(x)), 0.0)) +#define LOG_FUN(x) (makdbl( log( PRE_TRANSC_FUN(x)), 0.0)) +#define ABS_FUN(x) (makdbl( fabs( PRE_TRANSC_FUN(x)), 0.0)) +#define EX2IN_FUN(x) (makdbl( PRE_TRANSC_FUN(x), 0.0)) +#define FLOOR_FUN(x) (makdbl( floor( PRE_TRANSC_FUN(x)), 0.0)) +#define CEILING_FUN(x) (makdbl( ceil( PRE_TRANSC_FUN(x)), 0.0)) +#define TRUNCATE_FUN(x) (makdbl( ltrunc( PRE_TRANSC_FUN(x)), 0.0)) +#define ROUND_FUN(x) (makdbl(round( PRE_TRANSC_FUN(x)), 0.0)) + +/* the following defs come from the #ifdef HOBBIT part of scm.h */ + +#define SBOOL(x) ((x) ? BOOL_T : BOOL_F) + +#define BOOLEAN_P(x) ((x)==BOOL_T || (x)==BOOL_F) +#define CHAR_P ICHRP +#define SYMBOL_P(x) (ISYMP(x) || (!(IMP(x)) && SYMBOLP(x))) +#define VECTOR_P(x) (!(IMP(x)) && VECTORP(x)) +#define PAIR_P(x) (!(IMP(x)) && CONSP(x)) +#define NUMBER_P INUMP +#define INTEGER_P INUMP +#define STRING_P(x) (!(IMP(x)) && STRINGP(x)) +#define NULL_P NULLP +#define ZERO_P(x) ((x)==INUM0) +#define POSITIVE_P(x) ((x) > INUM0) +#define NEGATIVE_P(x) ((x) < INUM0) + +#define NOT(x) ((x)==BOOL_F ? BOOL_T : BOOL_F) +#define SET_CAR(x,y) (CAR(x) = (SCM)(y)) +#define SET_CDR(x,y) (CDR(x) = (SCM)(y)) +#define VECTOR_SET(v,k,o) (VELTS(v)[((long)INUM(k))] = o) +#define VECTOR_REF(v,k) (VELTS(v)[((long)INUM(k))]) +#define GLOBAL(x) (*(x)) + +#define append2(lst1,lst2) (append(cons2(lst1,lst2,EOL))) +#define procedure_pred_(x) (BOOL_T==procedurep(x)) + +/* new for hobbit5 - scm5 */ + +/* +SCM intp(SCM); +SCM eqv(SCM,SCM); +*/ diff --git a/scmhob.scm b/scmhob.scm new file mode 100644 index 0000000..bdef580 --- /dev/null +++ b/scmhob.scm @@ -0,0 +1,51 @@ +;==================================================================== +; +; scmhob.scm defines several procedures recognized +; by the hobbit compiler as primitives, but not defined in scm or slib. +; +; Use scmhob when running code (meant for compilation by +; hobbit) under interpreter. Never compile scmhob.scm! +; +; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997 Tanel Tammet +; tammet@cs.chalmers.se +; +; version 5x +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. +; +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. +; +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +; +;==================================================================== + +; bitwise operations: logical shift left and logical shift right + +(define (logsleft x y) (ash x y)) +(define (logsright x y) (ash x (- 0 y))) + +; immediate-integer (30-bit signed int) versions of arithmetic primitives: + +(define %eqv? eqv?) +(define %zero? zero?) +(define %negative? negative?) +(define %positive? positive?) +(define %number? number?) +(define %= =) +(define %< <) +(define %> >) +(define %<= <=) +(define %>= >=) +(define %+ +) +(define %- -) +(define %* *) +(define %/ /) + @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -42,9 +42,20 @@ /* "scmmain.c" main() for SCM. Author: Aubrey Jaffer */ +/* added by Dai Inukai 2001-03-21*/ +#ifdef __FreeBSD__ +# include <floatingpoint.h> +#endif + #include "scm.h" #include "patchlvl.h" +#ifdef __IBMC__ +# include <io.h> +#endif +#ifdef __OpenBSD__ +# include <unistd.h> +#endif #ifndef GENERIC_NAME # define GENERIC_NAME "scm" #endif @@ -86,17 +97,23 @@ int main(argc, argv) char *script_arg = 0; /* location of SCSH style script file or 0. */ char *implpath = 0, **nargv; int nargc, iverbose = 0, buf0stdin; - int freeall = 1; /* Free storage when we're done. */ SCM retval; - +/* added by Dai Inukai 2001-03-21 */ +#ifdef __FreeBSD__ + fp_prec_t fpspec; +#endif /* {char ** argvv = argv; */ -/* for (;*argvv;argvv++) {fputs(*argvv,stderr); fputs(" ",stderr);} */ -/* fputs("\n",stderr);} */ +/* for (;*argvv;argvv++) {fputs(*argvv, stderr); fputs(" ", stderr);} */ +/* fputs("\n", stderr);} */ if (0==argc) {argc = 1; argv = generic_name;} /* for macintosh */ #ifndef LACK_SBRK init_sbrk(); /* Do this before malloc()s. */ #endif +/* added by Dai Inukai 2001-03-21 */ +#ifdef __FreeBSD__ + fpspec = fpsetprec(FP_PE); /* IEEE 64 bit FP mantissa*/ +#endif execpath = 0; /* even when dumped */ if ((nargv = script_process_argv(argc, argv))) { /* SCSH style scripts */ script_arg = argv[2]; /* Save for scm_find_execpath() call */ @@ -126,7 +143,7 @@ int main(argc, argv) #ifdef CAREFUL_INTS 1 #else - freeall || (2 <= verbose) + 1 /* freeall || (2 <= verbose) */ /* Free storage when we're done. */ #endif ); if (2 <= iverbose) fputs(";EXIT\n", stderr); @@ -134,6 +151,12 @@ int main(argc, argv) if (implpath) free(implpath); if (execpath) free(execpath); execpath = 0; +/* added by Dai Inukai 2001-03-27 */ +#ifdef __FreeBSD__ + fpspec = fpsetprec(fpspec); /* Set back to FP_PD which is 53 bit FP. */ + /* This may not be needed because the */ + /* kernel is set to FP_PD by default. */ +#endif return (int)INUM(retval); } @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -52,13 +52,13 @@ #ifdef linux # include <unistd.h> /* for X_OK define */ #endif /* def linux */ -#ifdef __svr4__ +#ifdef __SVR4 # include <unistd.h> /* for X_OK define */ #else # ifdef __sgi__ # include <unistd.h> /* for X_OK define */ # endif /* def __sgi__ */ -#endif /* def __svr4__ */ +#endif /* def __SVR4 */ /* Concatentate str2 onto str1 at position n and return concatenated string if file exists; 0 otherwise. */ @@ -124,7 +124,7 @@ char *scm_sep_init_try(path, sep, initname) # define X_OK 1 #endif /* ndef X_OK */ -#ifdef unix +#ifdef HAVE_UNIX # include <stdio.h> char *script_find_executable(name) @@ -156,7 +156,6 @@ char *script_find_executable(name) #endif /* unix */ #ifdef MSDOS - # define DEFAULT_PATH "C:\\DOS" # define PATH_DELIMITER ';' # define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '\\') \ @@ -170,6 +169,20 @@ char *dld_find_executable(file) } #endif /* def MSDOS */ +#ifdef __IBMC__ +# define PATH_DELIMITER ';' +# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '/') \ + || (fname[0] == '\\') \ + || (fname[0] && (fname[1] == ':'))) + +char *dld_find_executable(file) + const char *file; +{ + /* fprintf(stderr, "dld_find_executable %s -> %s\n", file, scm_cat_path(0L, file, 0L)); fflush(stderr); */ + return scm_cat_path(0L, file, 0L); +} +#endif /* def __IBMC__ */ + /* Given dld_find_executable()'s best guess for the pathname of this executable, find (and verify the existence of) initname in the implementation-vicinity of this program. Returns a newly allocated @@ -227,7 +240,7 @@ char *find_impl_file(exec_path, generic_name, initname, sep) path = scm_sep_init_try(path, sep, initname); if (path) return path; } - if (!strcmp(peer,"src")) break; + if (!strcmp(peer, "src")) break; } if (generic_name) { @@ -242,7 +255,7 @@ char *find_impl_file(exec_path, generic_name, initname, sep) path = scm_sep_init_try(path, sep, initname); if (path) return path; } - if (!strcmp(peer,"src")) break; + if (!strcmp(peer, "src")) break; }} /* Look for initname in executable-name peer directory. */ @@ -377,7 +390,7 @@ char **script_process_argv(argc, argv) int nargc = argc, argi = 1, nargi = 1; char *narg, **nargv; if (!(argc > 2 && script_meta_arg_P(argv[1]))) return 0L; - if (!(nargv = (char **)malloc((1 + nargc) * sizeof(char*)))) return 0L; + if (!(nargv = (char **)malloc((1 + nargc) * sizeof(char *)))) return 0L; nargv[0] = argv[0]; while (((argi+1) < argc) && (script_meta_arg_P(argv[argi]))) { FILE *f = fopen(argv[++argi], "r"); @@ -389,7 +402,7 @@ char **script_process_argv(argc, argv) case '\n': goto found_args; } found_args: while ((narg = script_read_arg(f))) - if (!(nargv = (char **)realloc(nargv, (1 + ++nargc) * sizeof(char*)))) + if (!(nargv = (char **)realloc(nargv, (1 + ++nargc) * sizeof(char *)))) return 0L; else nargv[nargi++] = narg; fclose(f); @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -125,7 +125,11 @@ /* other.dynenv and other.parent get GCed just by being there. */ struct scm_other {SCM dynenv; SCM parent; - SCM stkframe[2]; +#ifdef RECKLESS + SCM stkframe[2]; +#else + SCM stkframe[4]; +#endif SCM estk; SCM *estk_ptr; }; @@ -143,3 +147,7 @@ typedef struct safeport { } safeport; #define SAFEP_JMPBUF(sfp) (((safeport *)STREAM(sfp))->jmpbuf) + +#ifdef __hppa__ +#define STACK_GROWS_UP +#endif @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -69,6 +69,9 @@ # ifdef SVR4 # include <unistd.h> # endif +# ifdef __OpenBSD__ +# include <unistd.h> +# endif #endif /* STDC_HEADERS */ static char s_inetaddr[] = "inet:string->address"; @@ -313,9 +316,8 @@ SCM l_socket(fam, proto) close(sd); wta(MAKINUM(sd), (char *)NALLOC, s_port_type); } - CAR(port) = scm_port_entry(tc_socket, BUF0); + port = scm_port_entry(f, tc_socket, BUF0); SCM_PORTDATA(port) = fam; - SETSTREAM(port, f); i_setbuf0(port); ALLOW_INTS; if (AF_INET==tp) { @@ -354,9 +356,8 @@ SCM l_socketpair(fam, proto) close(sv[1]); wta(MAKINUM(sv[1]), (char *)NALLOC, s_port_type); } - CAR(port[0]) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0)); - CAR(port[1]) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0)); - SETSTREAM(port[0], f[0]); SETSTREAM(port[1], f[1]); + port[0] = scm_port_entry(f[0], tc16_fport, mode_bits("r+0", (char *)0)); + CAR(port[1]) = scm_port_entry(f[1], tc16_fport, mode_bits("r+0", (char *)0)); i_setbuf0(port[0]); i_setbuf0(port[1]); ALLOW_INTS; return cons(port[0], port[1]); @@ -387,6 +388,7 @@ static char s_connect[] = "socket:connect"; SCM l_connect (sockpt, address, arg) SCM sockpt, address, arg; { + long flags; int sts; ASSERT(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_connect); switch SOCKTYP(sockpt) { @@ -419,7 +421,9 @@ SCM l_connect (sockpt, address, arg) break; } if (sts) return BOOL_F; - CAR(sockpt) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0)); + flags = tc16_fport | mode_bits("r+0", (char *)0); + SCM_PORTFLAGS(sockpt) = flags; + SCM_SETFLAGS(sockpt, flags); SCM_PORTDATA(sockpt) = cons(address, arg); return sockpt; } @@ -464,13 +468,16 @@ static char s_listen[] = "socket:listen"; SCM l_listen(port, backlog) SCM port, backlog; { + long flags; int sts; ASSERT(NIMP(port) && SOCKP(port), port, ARG1, s_listen); ASSERT(INUMP(backlog), backlog, ARG2, s_listen); SYSCALL(sts = listen(fileno(STREAM(port)), INUM(backlog));); if (sts) return BOOL_F; DEFER_INTS; - CAR(port) = scm_port_entry(tc16_fport, mode_bits("r0", (char *)0)); + flags = tc16_fport | mode_bits("r0", (char *)0); + SCM_PORTFLAGS(port) = flags; + SCM_SETFLAGS(port, flags); ALLOW_INTS; return port; } @@ -500,8 +507,7 @@ SCM l_accept(sockpt) close(newsd); wta(MAKINUM(newsd), (char *)NALLOC, s_port_type); } - CAR(newpt) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0)); - SETSTREAM(newpt, newfd); + newpt = scm_port_entry(newfd, tc16_fport, mode_bits("r+0", (char *)0)); i_setbuf0(newpt); ALLOW_INTS; return newpt; @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -476,14 +476,14 @@ SCM modulo(x, y) BIGSIGN(y), (BIGSIGN(x) ^ BIGSIGN(y)) ? 1 : 0); } if (!(z = INUM(y))) goto ov; - return divbigint(x, z, y < 0, (BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0); + return divbigint(x, z, z < 0, (BIGSIGN(x) ? (z > 0) : (z < 0)) ? 1 : 0); } if NINUMP(y) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) bady: wta(y, (char *)ARG2, s_modulo); # endif - return (BIGSIGN(y) ? (x>0) : (x<0)) ? sum(x, y) : x; + return (BIGSIGN(y) ? (INUM(x)>0) : (INUM(x)<0)) ? sum(x, y) : x; } #else ASSERT(INUMP(x), x, ARG1, s_modulo); @@ -546,7 +546,8 @@ b3: if (!(1 & (int)t)) goto b3; if (t>0) u = t; else v = -t; - if ((t = u-v)) goto b3; + t = u-v; + if (t) goto b3; u = u*k; getout: if (!POSFIXABLE(u)) @@ -612,6 +613,7 @@ SCM scm_big_ior P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); SCM scm_big_and P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int zsgn)); SCM scm_big_xor P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); SCM scm_big_test P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); +SCM scm_big_ash P((SCM x, long cnt)); SCM scm_copy_big_dec(b, sign) SCM b; @@ -751,7 +753,7 @@ SCM scm_big_and(x, nx, xsgn, bigy, zsgn) } else if (xsgn) do { num += x[i]; - if (num < 0) {zds[i] &= num + BIGRAD; num = -1;} + if (num < 0) {zds[i] &= ~(num + BIGRAD); num = -1;} else {zds[i] &= ~BIGLO(num); num = 0;} } while (++i < nx); else do zds[i] = zds[i] & x[i]; while (++i < nx); @@ -800,6 +802,151 @@ SCM scm_big_test(x, nx, xsgn, bigy) return BOOL_F; } +static SCM scm_copy_big_2scomp P((SCM x, sizet blen, int sign)); +static void scm_2scomp1 P((SCM b)); +static SCM scm_copy_big_2scomp(x, blen, sign) + SCM x; + sizet blen; + int sign; +{ + sizet nres = (blen + BITSPERDIG - 1)/BITSPERDIG; + SCM res; + BIGDIG *rds; + long num = 0; + sizet i; + if INUMP(x) { + long lx = INUM(x); + if (nres < (LONG_BIT + BITSPERDIG - 1)/BITSPERDIG) + nres = (LONG_BIT + BITSPERDIG - 1)/BITSPERDIG; + res = mkbig(nres, sign); + rds = BDIGITS(res); + if (lx < 0) { + lx = -lx; + for (i = 0; i < nres; i++) { + num -= BIGLO(lx); + lx = BIGDN(lx); + if (num < 0) { + rds[i] = num + BIGRAD; + num = -1; + } + else { + rds[i] = num; + num = 0; + } + } + } + else { + for (i = 0; i < nres; i++) { + rds[i] = BIGLO(lx); + lx = BIGDN(lx); + } + } + } + else { + BIGDIG *xds = BDIGITS(x); + sizet nx = NUMDIGS(x); + if (nres < nx) + nres = nx; + res = mkbig(nres, sign); + rds = BDIGITS(res); + if BIGSIGN(x) { + for (i = 0; i < nx; i++) { + num -= xds[i]; + if (num < 0) { + rds[i] = num + BIGRAD; + num = -1; + } + else { + rds[i] = num; + num = 0; + } + } + for (; i < nres; i++) + rds[i] = BIGRAD - 1; + } + else { + for (i = 0; i < nx; i++) + rds[i] = xds[i]; + for (; i < nres; i++) + rds[i] = 0; + } + } + return res; +} +static void scm_2scomp1(b) + SCM b; +{ + long num = 0; + sizet i, n = NUMDIGS(b); + BIGDIG *bds = BDIGITS(b); + for (i = 0; i < n; i++) { + num -= bds[i]; + if (num < 0) { + bds[i] = num + BIGRAD; + num = -1; + } + else { + bds[i] = num; + num = 0; + } + } +} + +SCM scm_big_ash(x, cnt) + SCM x; + long cnt; +{ + SCM res; + BIGDIG *resds; + unsigned long d; + int sign, ishf; + long i, fshf, blen, n; + if INUMP(x) { + blen = LONG_BIT; + sign = INUM(x) < 0 ? 0x0100 : 0; + } + else { + blen = NUMDIGS(x)*BITSPERDIG; + sign = BIGSIGN(x); + } + if (cnt < 0) { + if (blen <= -cnt) return sign ? MAKINUM(-1) : INUM0; + ishf = (-cnt) / BITSPERDIG; + fshf = (-cnt) % BITSPERDIG; + res = scm_copy_big_2scomp(x, blen, sign); + resds = BDIGITS(res); + n = NUMDIGS(res) - ishf - 1; + for (i = 0; i < n; i++) { + d = (resds[i + ishf]>>fshf) | + ((resds[i + ishf + 1])<<(BITSPERDIG - fshf) & (BIGRAD - 1)); + resds[i] = d; + } + d = (resds[i + ishf]>>fshf); + if (sign) d |= ((BIGRAD - 1)<<(BITSPERDIG - fshf) & (BIGRAD - 1)); + resds[i] = d; + n = NUMDIGS(res); + d = sign ? BIGRAD - 1 : 0; + for (i++; i < n; i++) + resds[i] = d; + } + else { + ishf = cnt / BITSPERDIG; + fshf = cnt % BITSPERDIG; + res = scm_copy_big_2scomp(x, blen + cnt, sign); + resds = BDIGITS(res); + for (i = NUMDIGS(res) - 1; i > ishf; i--) { + d = (((resds[i - ishf])<<fshf) & (BIGRAD - 1)) | + ((resds[i - ishf - 1])>>(BITSPERDIG - fshf)); + resds[i] = d; + } + d = (((resds[i - ishf])<<fshf) & (BIGRAD - 1)); + resds[i] = d; + for (i--; i >= 0; i--) + resds[i] = 0; + } + if (sign) scm_2scomp1(res); + return normbig(res); +} #endif static char s_logand[] = "logand", s_lognot[] = "lognot", @@ -996,7 +1143,7 @@ SCM scm_logbitp(index, j1) ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp); #ifdef BIGDIG if NINUMP(j1) { - ASSERT(NIMP(j1) && BIGP(j1), j1, (char *)ARG2, s_logbitp); + ASSERT(NIMP(j1) && BIGP(j1), j1, ARG2, s_logbitp); if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F; else if BIGSIGN(j1) { long num = -1; @@ -1015,7 +1162,7 @@ SCM scm_logbitp(index, j1) (1L << (INUM(index)%BITSPERDIG))) ? BOOL_T : BOOL_F; } #else - ASSERT(INUMP(j1), j1, (char *)ARG2, s_logbitp); + ASSERT(INUMP(j1), j1, ARG2, s_logbitp); #endif return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F; } @@ -1025,13 +1172,29 @@ SCM scm_copybit(index, j1, bit) { ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_copybit); #ifdef BIGDIG - if (NINUMP(j1) || (INUM(index) >= LONG_BIT - 3)) - /* This function makes more bignums than it needs to. */ - if NFALSEP(bit) - return scm_logior(j1, scm_ash(MAKINUM(1), index)); - else - return scm_logand(j1, difference(MAKINUM(-1L), - scm_ash(MAKINUM(1), index))); + { + SCM res; + BIGDIG *rds; + sizet i = INUM(index); + int sign; + if (!INUMP(j1)) { + ASSERT(NIMP(j1) && BIGP(j1), j1, ARG2, s_copybit); + sign = BIGSIGN(j1); + ovflow: + res = scm_copy_big_2scomp(j1, i + 1, sign); + rds = BDIGITS(res); + if (NFALSEP(bit)) + rds[i / BITSPERDIG] |= 1 << (i % BITSPERDIG); + else + rds[i / BITSPERDIG] &= ~(1 << (i % BITSPERDIG)); + if (sign) scm_2scomp1(res); + return normbig(res); + } + if (i >= LONG_BIT - 3) { + sign = INUM(j1) < 0 ? 0x0100 : 0; + goto ovflow; + } + } #else ASSERT(INUMP(j1), j1, ARG2, s_copybit); ASSERT(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit); @@ -1053,37 +1216,61 @@ SCM scm_ash(n, cnt) { SCM res = INUM(n); ASSERT(INUMP(cnt), cnt, ARG2, s_ash); -#ifdef BIGDIG - if(cnt < 0) { - res = scm_intexpt(MAKINUM(2), MAKINUM(-INUM(cnt))); - if NFALSEP(negativep(n)) - return sum(MAKINUM(-1L), lquotient(sum(MAKINUM(1L), n), res)); - else return lquotient(n, res); + cnt = INUM(cnt); + if (INUMP(n)) { + if (cnt < 0) return MAKINUM(SRS(res, -cnt)); + if (cnt >= LONG_BIT) goto ovflow; + res = MAKINUM(res<<cnt); + if (INUM(res)>>cnt != INUM(n)) + goto ovflow; + else + return res; } - else return product(n, scm_intexpt(MAKINUM(2), cnt)); +#ifdef BIGDIG + ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_ash); + ovflow: + if (0==cnt) return n; + return scm_big_ash(n, cnt); #else - ASSERT(INUMP(n), n, ARG1, s_ash); - cnt = INUM(cnt); - if (cnt < 0) return MAKINUM(SRS(res, -cnt)); - res = MAKINUM(res<<cnt); - if (INUM(res)>>cnt != INUM(n)) wta(n, (char *)OVFLOW, s_ash); - return res; + ovflow: + wta(n, INUMP(n) ? (char *)OVFLOW : (char *)ARG1, s_ash); + return UNSPECIFIED; /* kill warning */ #endif } SCM scm_bitfield(n, start, end) SCM n, start, end; { + int sign; ASSERT(INUMP(start), start, ARG2, s_bitfield); ASSERT(INUMP(end), end, ARG3, s_bitfield); start = INUM(start); end = INUM(end); ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitfield); #ifdef BIGDIG - if (NINUMP(n) || end >= LONG_BIT - 2) - return - scm_logand(difference(scm_intexpt(MAKINUM(2), MAKINUM(end - start)), - MAKINUM(1L)), - scm_ash(n, MAKINUM(-start))); + if (NINUMP(n)) { + BIGDIG *ds; + sizet i, nd; + ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_bitfield); + sign = BIGSIGN(n); + big: + if (sign) n = scm_copy_big_2scomp(n, (sizet)end, 0); + n = scm_big_ash(n, -start); + if (INUMP(n)) { + if (end - start >= LONG_BIT - 2) return n; + return MAKINUM(INUM(n) & ((1L<<(end - start)) - 1)); + } + nd = NUMDIGS(n); + ds = BDIGITS(n); + i = (end - start) / BITSPERDIG; + if (i >= nd) return n; + ds[i] &= ((1 << ((end - start) % BITSPERDIG)) - 1); + for (++i; i < nd; i++) ds[i] = 0; + return normbig(n); + } + if (end >= LONG_BIT - 2) { + sign = INUM(n) < 0; + goto big; + } #else ASSERT(INUMP(n), n, ARG1, s_bitfield); ASSERT(end < LONG_BIT - 2, MAKINUM(end), OUTOFRANGE, s_bitfield); @@ -1126,7 +1313,7 @@ SCM scm_copybitfield(to, start, rest) ASSERT(len >= 0, MAKINUM(len), OUTOFRANGE, s_copybitfield); #ifdef BIGDIG if (NINUMP(from) || NINUMP(to) || (INUM(end) >= LONG_BIT - 2)) { - SCM mask = difference(scm_intexpt(MAKINUM(2), MAKINUM(len)), MAKINUM(1L)); + SCM mask = difference(scm_ash(MAKINUM(1L), MAKINUM(len)), MAKINUM(1L)); mask = scm_ash(mask, start); return scm_logior(scm_logand(mask, scm_ash(from, start)), scm_logand(scm_lognot(mask), to)); @@ -1568,7 +1755,7 @@ SCM make_vector(k, fill) if UNBNDP(fill) fill = UNSPECIFIED; i = INUM(k); DEFER_INTS; - v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L, + v = must_malloc_cell(i ? i*sizeof(SCM) : 1L, MAKE_LENGTH(i, tc7_vector), s_vector); velts = VELTS(v); while(--i >= 0) (velts)[i] = fill; @@ -1585,7 +1772,7 @@ SCM mkbig(nlen, sign) if (NUMDIGS_MAX <= nlen) wta(MAKINUM(nlen), (char *)NALLOC, s_bignum); DEFER_INTS; v = must_malloc_cell((0L+nlen)*sizeof(BIGDIG), - MAKE_NUMDIGS(nlen, sign?tc16_bigneg:tc16_bigpos), + MAKE_NUMDIGS(nlen, sign ? tc16_bigneg : tc16_bigpos), s_bignum); ALLOW_INTS; return v; @@ -1600,7 +1787,7 @@ SCM big2inum(b, l) if (TYP16(b)==tc16_bigpos) { if POSFIXABLE(num) return MAKINUM(num); } - else if UNEGFIXABLE(num) return MAKINUM(-num); + else if UNEGFIXABLE(num) return MAKINUM(-(long)num); return b; } char s_adjbig[] = "adjbig"; @@ -1809,7 +1996,7 @@ SCM divbigint(x, z, sgn, mode) sizet nd = NUMDIGS(x); while(nd--) t2 = (BIGUP(t2) + ds[nd]) % z; if (mode && t2) t2 = z - t2; - return MAKINUM(sgn ? -t2 : t2); + return MAKINUM(sgn ? -(long)t2 : t2); } { # ifndef DIGSTOOBIG diff --git a/syntest1.scm b/syntest1.scm new file mode 100644 index 0000000..f10be86 --- /dev/null +++ b/syntest1.scm @@ -0,0 +1,166 @@ +;Most of the tests themselves are taken from William Clinger's reference +;implementation of syntax-rules, `macros.will' in the Scheme repository +;at ftp.cs.indiana.edu + +;Copyright 1992 William Clinger + +;Permission to copy this software, in whole or in part, to use this +;software for any lawful purpose, and to redistribute this software +;is granted subject to the restriction that all copies made of this +;software must include this copyright notice in full. + +;I also request that you send me a copy of any improvements that you +;make to this software so that they may be incorporated within it to +;the benefit of the Scheme community. + + +(require 'macro) + +(define synerrs '()) + +(define-syntax test + (syntax-rules () + ((test ?exp ?ans) + (begin + (display '?exp) + (display " ==> ") + (let* ((exp (copy-tree '?exp)) + (x ?exp) + #+f(x (eval (macro:expand '?exp))) + ) + (display x) + (newline) + (or (equal? x ?ans) + (begin + (set! synerrs + (cons (list x ?ans '?exp) synerrs)) + (display "ERROR: expected ") + (display ?ans) + (newline)))))) + ((test ?exp0 ?exp1 ?exp2 ...) + (begin (display '?exp0) + (newline) + ?exp0 (test ?exp1 ?exp2 ...))))) + +(test (let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m)))) + 'outer) + +(test (let-syntax ((when (syntax-rules + () + ((when ?test ?stmt1 ?stmt2 ...) + (if ?test (begin ?stmt1 ?stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if)) + 'now) + +(test (letrec-syntax + ((or (syntax-rules + () + ((or) #f) + ((or ?e) ?e) + ((or ?e1 ?e2 ...) + (let ((temp ?e1)) + (if temp temp (or ?e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (or x + (let temp) + (if y) + y))) + 7) + +(test (let ((=> #f)) + (cond (#t => 'ok))) + 'ok) + +; This syntax of set*! matches that of an example in the R4RS. +; That example was put forth as an example of a hygienic macro +; that supposedly couldn't be written using syntax-rules. Hah! + +(test (define-syntax set*! + (syntax-rules + () + ((set*! (?var ?val) ...) + (set*!-help (?val ...) () (?var ?val) ...)))) + (define-syntax set*!-help + (syntax-rules + () + ((set*!-help () (?temp ...) (?var ?val) ...) + (let ((?temp ?val) ...) + (set! ?var ?temp) ...)) + ((set*!-help (?var1 ?var2 ...) ?temps ?assignments ...) + (set*!-help (?var2 ...) (temp . ?temps) ?assignments ...)))) + (let ((x 3) + (y 4) + (z 5)) + (set*! (x (+ x y z)) + (y (- x y z)) + (z (* x y z))) + (list x y z)) + + '(12 -6 60)) + +(test (let ((else #f)) + (cond (#f 3) + (else 4) + (#t 5))) + 5) + +(test (define-syntax push + (syntax-rules () + ((push item place) + (set! place (cons item place))))) + (let* ((cons (lambda (name) + (case name + ((phil) '("three-card monte")) + ((dick) '("secret plan to end the war" + "agnew" + "not a crook")) + ((jimmy) '("why not the best")) + ((ron) '("abolish the draft" + "balance the budget")) + (else '())))) + (scams (cons 'phil))) + (push (car (cons 'jimmy)) scams) + (push (cadr (cons 'ron)) scams) + scams) + '("balance the budget" "why not the best" "three-card monte")) + +(test (define-syntax replic + (syntax-rules () + ((_ (?x ...) (?y ...)) + (let ((?x (list ?y ...)) ...) + (list ?x ...))))) + (replic (x y z) (1 2)) + '((1 2) (1 2) (1 2))) + +;; The behavior of this one is one is not specified by R5RS, below +;; is what SCM does. +;(test (define-syntax spread +; (syntax-rules () +; ((_ ?x (?y ...)) +; '(((?x ?y) ...))))) +; (spread x (1 2 3)) +; '(((x 1) (x 2) (x 3)))) + +(cond + ((null? synerrs) + (newline) + (display "Passed all tests\n") + (display "Load \"syntest2\" to rewrite derived expressions and test\n")) + (else + (newline) + (display "FAILED, errors were:") + (newline) + (display "(got expected call)") + (newline) + (for-each (lambda (l) (write l) (newline)) synerrs) + (newline))) + diff --git a/syntest2.scm b/syntest2.scm new file mode 100644 index 0000000..68633cf --- /dev/null +++ b/syntest2.scm @@ -0,0 +1,186 @@ +;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +(require 'macro) + +;; Redefine some derived special forms. + +(define-syntax let + (syntax-rules () + ((let ((?name ?val) ...) . ?body) + ((lambda (?name ...) . ?body) ?val ...)) + ((let ?proc ((?name ?val) ...) . ?body) + (let ((?proc #f) + (?name ?val) ...) + (set! ?proc (lambda (?name ...) . ?body)) + (?proc ?name ...))))) + +(define-syntax let* + (syntax-rules () + ((let* () . ?body) + ((lambda () . ?body))) + ((let* ((?name ?val)) . ?body) + ((lambda (?name) . ?body) ?val)) + ((let* ((?name ?val) ?binding ...) . ?body) + (let* ((?name ?val)) + (let* (?binding ...) . ?body))))) + +(define-syntax letrec + (syntax-rules () + ((letrec ((?name ?val) ...) . ?body) + (let ((?name #f) ...) + (set! ?name ?val) ... + (let () . ?body))))) + +(define-syntax and + (syntax-rules () + ((and) #t) + ((and ?exp) + (let ((x ?exp)) + (if x x #f))) + ((and ?exp . ?rest) + (let ((x ?exp)) + (if x (and . ?rest) #f))))) + +(define-syntax or + (syntax-rules () + ((or) #f) + ((or ?exp) + (let ((x ?exp)) + (if x x #f))) + ((or ?exp . ?rest) + (let ((x ?exp)) + (if x x (or . ?rest)))))) + +(define (force promise) + (promise)) + +(define (make-promise proc) + (let ((result #f)) + (lambda () + (if result (car result) + (let ((x (proc))) + (if result (car result) + (begin (set! result (list x)) + x))))))) + +(define-syntax delay + (syntax-rules () + ((delay ?expr) + (make-promise (lambda () ?expr))))) + +(define-syntax do + (syntax-rules () + ((do ((?name ?init . ?step) ...) + (?test . ?result) + ?body ...) + (let-syntax ((do-step (syntax-rules () + ((do-step ?n) ?n) + ((do-step ?n ?s) ?s))) + (do-result (syntax-rules () + ((do-result) (if #f #f)) + ((do-result . ?r) (begin . ?r))))) + (let loop ((?name ?init) ...) + (if ?test + (do-result . ?result) + (begin ?body ... + (loop (do-step ?name . ?step) ...)))))))) + +(define-syntax case + (syntax-rules (else) + ((case ?x (else . ?conseq)) + (begin . ?conseq)) + ((case ?x (?lst . ?conseq)) + (if (memv ?x '?lst) (begin . ?conseq))) + ((case ?x (?lst . ?conseq) . ?rest) + (if (memv ?x '?lst) + (begin . ?conseq) + (case ?x . ?rest))))) + +(define-syntax cond + (syntax-rules (else =>) + ((cond ?clause0 . ?clauses) + (letrec-syntax + ((cond-aux + (syntax-rules (else =>) + ((cond-aux) (if #f #f)) + ((cond-aux (else . ?conseq)) + (begin . ?conseq)) + ((cond-aux (?test => ?proc) . ?rest) + (let ((val ?test)) + (if val (?proc val) (cond-aux . ?rest)))) + ((cond-aux (?test) . ?rest) + (or ?test (cond-aux . ?rest))) + ((cond-aux (?test . ?conseq) . ?rest) + (if ?test (begin . ?conseq) (cond-aux . ?rest)))))) + (cond-aux ?clause0 . ?clauses))))) + +;; This may fail if you redefine CONS, LIST, APPEND, or LIST->VECTOR +;; It uses the (... ...) escape. +;; All forms are evaluated inside a LETREC-SYNTAX body (is this a problem?). + +(define-syntax quasiquote + (syntax-rules () + ((_ ?template) + (letrec-syntax + ((qq + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ (unquote ?form) ()) + ?form) + ((_ (unquote ?form) (?depth)) + (list 'unquote (qq ?form ?depth))) + ((_ (quasiquote ?form) ?depth) + (list 'quasiquote (qq ?form (?depth)))) + ((_ ((unquote-splicing ?form) . ?rest) ()) + (append ?form (qq ?rest ()))) + ((_ ((unquote-splicing ?form) . ?rest) (?depth)) + (append (list 'unquote-splicing (qq ?form ?depth)) + (qq ?rest (?depth)))) + ((_ (?car . ?cdr) ?depth) + (cons (qq ?car ?depth) (qq ?cdr ?depth))) + ((_ #(?elt (... ...)) ?depth) + (list->vector (qq (?elt (... ...)) ?depth))) + ((_ ?atom ?depth) + '?atom)))) + (qq ?template ()))))) + +;;(load "r4rstest.scm") + + @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -48,6 +48,7 @@ void igc P((char *what, STACKITEM *stackbase)); void lfflush P((SCM port)); /* internal SCM call */ SCM *loc_open_file; /* for open-file callback */ +SCM *loc_try_create_file; /* ttyname() etc. should be defined in <unistd.h>. But unistd.h is missing on many systems. */ @@ -57,7 +58,7 @@ SCM *loc_open_file; /* for open-file callback */ char *tmpnam P((char *s)); sizet fwrite (); # ifdef sun -# ifndef __svr4__ +# ifndef __SVR4 int fputs P((char *s, FILE* stream)); int fputc P((char c, FILE* stream)); int fflush P((FILE* stream)); @@ -72,15 +73,20 @@ SCM *loc_open_file; /* for open-file callback */ # ifdef linux # include <unistd.h> # endif +# ifdef __OpenBSD__ +# include <unistd.h> +# endif #endif static void gc_sweep P((int contin_bad)); char s_nogrow[] = "could not grow", s_heap[] = "heap", - s_hplims[] = "hplims"; + s_hplims[] = "hplims", s_try_create_file[] = "try-create-file"; + static char s_segs[] = "segments", s_numheaps[] = "number of heaps"; static char s_input_portp[] = "input-port?", s_output_portp[] = "output-port?"; +static char s_port_closedp[] = "port-closed?"; static char s_try_open_file[] = "try-open-file"; #define s_open_file (&s_try_open_file[4]) char s_close_port[] = "close-port"; @@ -102,7 +108,9 @@ char s_close_port[] = "close-port"; # else # ifndef macintosh # ifndef ARM_ULIB -# include <sys/ioctl.h> +# ifndef PLAN9 +# include <sys/ioctl.h> +# endif # endif # endif # endif @@ -129,7 +137,10 @@ SCM i_setbuf0(port) /* should be called with DEFER_INTS active */ /* The CRDY bit is overloaded to indicate that additional processing is needed when reading or writing, such as updating line and column - numbers. */ + numbers. Returns 0 if cmodes is non-null and modes string is not + valid. */ +/* If nonnull, the CMODES argument receives a copy of all chars in MODES + which are allowed by ANSI C. */ long mode_bits(modes, cmodes) char *modes, *cmodes; { @@ -143,10 +154,15 @@ long mode_bits(modes, cmodes) case 'b': bits |= BINARY; goto outc; case '0': bits |= BUF0; break; case '?': bits |= (TRACKED | CRDY); break; + case 'x': bits |= EXCLUSIVE; break; outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break; } - if (cmodes) cmodes[iout] = 0; - return bits; + if (!cmodes) return bits; + cmodes[iout] = 0; + switch (cmodes[0]) { + default: return 0; + case 'r': case 'w': case 'a': return bits; + } } SCM try_open_file(filename, modes) @@ -155,18 +171,22 @@ SCM try_open_file(filename, modes) register SCM port; FILE *f; char cmodes[4]; - long flags = mode_bits(CHARS(modes), cmodes); + long flags; ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file); - ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file); - NEWCELL(port); + ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file); + flags = mode_bits(CHARS(modes), cmodes); + ASSERT(flags, modes, ARG2, s_open_file); + if ((EXCLUSIVE & flags) && NIMP(*loc_try_create_file)) { + port = apply(*loc_try_create_file, filename, cons(modes, listofnull)); + if (UNSPECIFIED != port) return port; + } DEFER_INTS; - SCM_OPENCALL(f = fopen(CHARS(filename), cmodes)); + SCM_OPENCALL((f = fopen(CHARS(filename), cmodes))); if (!f) { ALLOW_INTS; return BOOL_F; } - SETSTREAM(port, f); - CAR(port) = scm_port_entry(tc16_fport, flags); + port = scm_port_entry(f, tc16_fport, flags); if (BUF0 & flags) i_setbuf0(port); ALLOW_INTS; SCM_PORTDATA(port) = filename; @@ -182,6 +202,7 @@ SCM open_file(filename, modes) cons(modes, listofnull)); } +long tc16_clport; SCM close_port(port) SCM port; { @@ -194,6 +215,10 @@ SCM close_port(port) SYSCALL((ptobs[i].fclose)(STREAM(port));); } CAR(port) &= ~OPN; + SCM_PORTFLAGS(port) &= ~OPN; + /* Bash the old ptobnum with the closed port ptobnum. + This allows catching some errors cheaply. */ + SCM_SET_PTOBNUM(port, tc16_clport); ALLOW_INTS; return UNSPECIFIED; } @@ -209,6 +234,24 @@ SCM output_portp(x) if IMP(x) return BOOL_F; return OUTPORTP(x) ? BOOL_T : BOOL_F; } +SCM port_closedp(port) + SCM port; +{ + ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp); + if CLOSEDP(port) return BOOL_T; + return BOOL_F; +} +SCM scm_port_type(port) + SCM port; +{ + int i; + if (NIMP(port) && PORTP(port)) { + i = PTOBNUM(port); + if (ptobs[i].name) return CAR(sysintern(ptobs[i].name, UNDEFINED)); + return BOOL_T; + } + return BOOL_F; +} #if (__TURBOC__==1) # undef L_tmpnam /* Not supported in TURBOC V1.0 */ @@ -307,16 +350,25 @@ void prinport(exp, port, type) # ifndef _DCC # ifndef AMIGA # ifndef macintosh +# ifndef PLAN9 if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp)))) lputs(ttyname(fileno(STREAM(exp))), port); else +# endif # endif # endif # endif # endif #endif - if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port); - else intprint(CDR(exp), -16, port); + { + SCM s = PORTP(exp) ? SCM_PORTDATA(exp) : UNDEFINED; + if (NIMP(s) && STRINGP(s)) + iprin1(s, port, 1); + else if (OPFPORTP(exp)) + intprint((long)fileno(STREAM(exp)), 10, port); + else + intprint(CDR(exp), -16, port); + } lputc('>', port); } @@ -357,6 +409,24 @@ static int stgetc(p) CAR(p) = MAKINUM(ind + 1); return UCHARS(CDR(p))[ind]; } +static int stclose(p) + SCM p; +{ + SETCDR(p, nullstr); + return 0; +} +static int stungetc(c, p) + int c; + SCM p; +{ + sizet ind; + p = CDR(p); + ind = INUM(CAR(p)); + if (ind == 0) return EOF; + CAR(p) = MAKINUM(--ind); + ASSERT(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", ""); + return c; +} int noop0(stream) FILE *stream; { @@ -375,7 +445,8 @@ SCM mkstrport(pos, str, modes, caller) NEWCELL(z); DEFER_INTS; SETCHARS(z, str); - CAR(z) = scm_port_entry(tc16_strport, modes); + CAR(z) = (modes | tc16_strport); /* port table entry 0 is scratch. */ + /* z = scm_port_entry((FILE *)str, tc16_strport, modes); */ ALLOW_INTS; return z; } @@ -432,7 +503,7 @@ static ptobfuns fptob = { ptobfuns pipob = { 0, mark0, - 0, /* replaced by pclose in init_ioext() */ + 0, /* replaced by pclose in init_posix() */ 0, 0, fputc, @@ -456,8 +527,8 @@ static ptobfuns stptob = { stwrite, noop0, stgetc, - 0}; /* stungetc */ - + stclose, + stungetc}; /* Soft ports */ @@ -523,6 +594,7 @@ SCM mksfpt(pv, modes) SCM pv, modes; { SCM z; + long flags; static long arities[] = {1, 1, 0, 0, 0}; #ifndef RECKLESS int i; @@ -534,11 +606,11 @@ SCM mksfpt(pv, modes) badarg); } #endif - ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt); - NEWCELL(z); + ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt); + flags = mode_bits(CHARS(modes), (char *)0); + ASSERT(flags, modes, ARG2, s_mksfpt); DEFER_INTS; - CAR(z) = scm_port_entry(tc16_sfport, mode_bits(CHARS(modes), (char *)0)); - SETSTREAM(z, pv); + z = scm_port_entry((FILE *)pv, tc16_sfport, flags); ALLOW_INTS; return z; } @@ -556,6 +628,42 @@ static ptobfuns sfptob = { sfgetc, sfclose}; + /* Closed ports, just return an error code and let + the caller complain. */ +static int clputc(c, p) + int c; FILE *p; +{ + return EOF; +} +static sizet clwrite(str, siz, num, p) + sizet siz, num; + char *str; FILE *p; +{ + return 0; +} +static int clputs(s, p) + char *s; FILE *p; +{ + return EOF; +} +static int clgetc(p) + FILE *p; +{ + return EOF; +} +static ptobfuns clptob = { + s_port_type, + mark0, + noop0, + 0, + 0, + clputc, + clputs, + clwrite, + clgetc, + clgetc, + 0}; + /* The following ptob is for printing system messages in an interrupt-safe way. Writing to sys_errp while interrupts are disabled will never enable interrupts, do any actual i/o, or any allocation. Messages will be @@ -583,7 +691,7 @@ static sizet syswrite(str, siz, num, p) if NIMP(cur_outp) lflush(cur_outp); if (errbuf_end > 0) { if (errbuf_end > SYS_ERRP_SIZE) { - scm_warn("output buffer", " overflowed"); + scm_warn("output buffer", " overflowed", UNDEFINED); intprint((long)errbuf_end, 10, cur_errp); lputs(" chars needed\n", cur_errp); errbuf_end = errbuf_end % SYS_ERRP_SIZE; @@ -644,16 +752,12 @@ SCM mksafeport(maxlen, port) { SCM z; if UNBNDP(port) port = cur_errp; - else { - ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp); - } - DEFER_INTS; + ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp); z = must_malloc_cell(sizeof(safeport)+0L, tc16_safeport | OPN | WRTNG, s_msp); ((safeport *)STREAM(z))->ccnt = maxlen; ((safeport *)STREAM(z))->port = port; - ALLOW_INTS; return z; } int reset_safeport(sfp, maxlen, port) @@ -685,7 +789,7 @@ static sizet safewrite(str, siz, num, p) lputs(" ...", p->port); longjmp(p->jmpbuf, !0); /* The usual C longjmp, not SCM's longjump */ } - return siz; + return num; } static int safeputs(s, p) char *s; safeport *p; @@ -787,33 +891,35 @@ extern sizet num_protects; /* sys_protects now in scl.c */ void init_types() { sizet j = num_protects; - /* Because not all protects may get initialized */ - while(j) sys_protects[--j] = BOOL_F; + while(j) sys_protects[--j] = UNDEFINED; /* We need to set up tmp_errp before any errors may be - thrown, the port_table index will be zero, usable + thrown, the port_table index will be zero, usable by all ports that don't care about their table entries. */ tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0])); - CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG); + CAR(tmp_errp) = tc16_fport | OPN | WRTNG; + /* CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG); */ SETSTREAM(tmp_errp, stderr); cur_errp = def_errp = sys_safep = tmp_errp; - scm_init_gra(&subr_table_gra, sizeof(subr_info), 200, 0, "subr table"); - scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 4, 255, "ptobs"); + /* subrs_gra is trimmed to actual used by scm_init_extensions() */ + scm_init_gra(&subrs_gra, sizeof(subr_info), 420 , 0, "subrs"); + scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 8, 255, "ptobs"); /* These newptob calls must be done in this order */ /* tc16_fport = */ newptob(&fptob); /* tc16_pipe = */ newptob(&pipob); /* tc16_strport = */ newptob(&stptob); /* tc16_sfport = */ newptob(&sfptob); + tc16_clport = newptob(&clptob); tc16_sysport = newptob(&sysptob); tc16_safeport = newptob(&safeptob); - scm_init_gra(&smobs_gra, sizeof(smobfuns), 7, 255, "smobs"); + scm_init_gra(&smobs_gra, sizeof(smobfuns), 16, 255, "smobs"); /* These newsmob calls must be done in this order */ newsmob(&freecell); newsmob(&flob); newsmob(&bigob); newsmob(&bigob); - scm_init_gra(&finals_gra, sizeof(void (*)()), 2, 0, s_final); + scm_init_gra(&finals_gra, sizeof(void (*)()), 4, 0, s_final); } #ifdef TEST_FINAL @@ -828,6 +934,24 @@ void add_final(final) scm_grow_gra(&finals_gra, (char *)&final); } +static SCM gc_finalizers = EOL, gc_finalizers_pending = EOL; +static char s_add_finalizer[] = "add-finalizer"; +SCM scm_add_finalizer(value, finalizer) + SCM value, finalizer; +{ + SCM z; + ASSERT(NIMP(value), value, ARG1, s_add_finalizer); +#ifndef RECKLESS + scm_arity_check(finalizer, 0L, s_add_finalizer); +#endif + z = acons(value, finalizer, EOL); + DEFER_INTS; + CDR(z) = gc_finalizers; + gc_finalizers = z; + ALLOW_INTS; + return UNSPECIFIED; +} + static char s_estk[] = "environment stack"; static cell ecache_v[ECACHE_SIZE]; SCM scm_egc_roots[ECACHE_SIZE/20]; @@ -877,7 +1001,7 @@ void scm_estk_reset(size) if (!size) size = SCM_ESTK_BASE + 20*SCM_ESTK_FRLEN + 1; scm_estk = make_stk_seg(size, UNDEFINED); scm_estk_ptr = &(VELTS(scm_estk)[SCM_ESTK_BASE]); - scm_estk_size = size; + scm_estk_size = size + 0L; } void scm_estk_grow() { @@ -891,7 +1015,7 @@ void scm_estk_grow() sizet i, j; newv = VELTS(estk); oldv = VELTS(scm_estk); - j = scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN - overlap; + j = scm_estk_ptr - oldv + SCM_ESTK_FRLEN - overlap; SCM_ESTK_PARENT(estk) = scm_estk; SCM_ESTK_PARENT_WRITABLEP(estk) = BOOL_T; SCM_ESTK_PARENT_INDEX(estk) = MAKINUM(j - SCM_ESTK_FRLEN); @@ -901,19 +1025,18 @@ void scm_estk_grow() } scm_estk = estk; scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]); - scm_estk_size += size; + scm_estk_size += size + 0L; /* growth_mon(s_estk, scm_estk_size, "locations", !0); */ } void scm_estk_shrink() { - SCM parent, *v; + SCM parent; sizet i; parent = SCM_ESTK_PARENT(scm_estk); i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk)); - v = VELTS(scm_estk); if IMP(parent) wta(UNDEFINED, "underflow", s_estk); if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk)) - parent = make_stk_seg(LENGTH(parent), parent); + parent = make_stk_seg((sizet)LENGTH(parent), parent); SCM_ESTK_PARENT(scm_estk) = estk_pool; estk_pool = scm_estk; scm_estk_size -= LENGTH(scm_estk); @@ -961,27 +1084,32 @@ void scm_env_cons2(w, x, y) scm_ecache_index = i; } -/* scm_env_tmp = cons(x, scm_env_tmp) */ -void scm_env_cons_tmp(x) - SCM x; +void scm_env_cons3(v, w, x, y) + SCM v, w, x, y; { - register SCM z; + SCM z1, z2; register int i; DEFER_INTS_EGC; i = scm_ecache_index; - if (1>i) { + if (3>i) { scm_egc(); i = scm_ecache_index; } - z = PTR2SCM(&(scm_ecache[--i])); - CAR(z) = x; - CDR(z) = scm_env_tmp; - scm_env_tmp = z; + z1 = PTR2SCM(&(scm_ecache[--i])); + CAR(z1) = x; + CDR(z1) = y; + z2 = PTR2SCM(&(scm_ecache[--i])); + CAR(z2) = w; + CDR(z2) = z1; + z1 = PTR2SCM(&(scm_ecache[--i])); + CAR(z1) = v; + CDR(z1) = z2; + scm_env_tmp = z1; scm_ecache_index = i; } void scm_env_v2lst(argc, argv) - int argc; + long argc; SCM *argv; { SCM z1, z2; @@ -1004,7 +1132,23 @@ void scm_env_v2lst(argc, argv) } /* scm_env = acons(names, scm_env_tmp, scm_env) */ -void scm_extend_env(names) +void scm_extend_env() +{ + SCM z; + register int i; + DEFER_INTS_EGC; + i = scm_ecache_index; + if (1>i) { + scm_egc(); + i = scm_ecache_index; + } + z = PTR2SCM(&(scm_ecache[--i])); + CAR(z) = scm_env_tmp; + CDR(z) = scm_env; + scm_env = z; + scm_ecache_index = i; +} +void old_scm_extend_env(names) SCM names; { SCM z1, z2; @@ -1028,15 +1172,17 @@ char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc"; char s_recursive[] = "recursive"; #define s_gc (s_cache_gc+6) static iproc subr0s[] = { - /* {s_gc, gc}, */ {"tmpnam", ltmpnam}, + {"open-ports", scm_open_ports}, {0, 0}}; static iproc subr1s[] = { {s_input_portp, input_portp}, {s_output_portp, output_portp}, + {s_port_closedp, port_closedp}, {s_close_port, close_port}, {"eof-object?", eof_objectp}, + {"port-type", scm_port_type}, {s_cwos, cwos}, {"object-hash", obhash}, {s_obunhash, obunhash}, @@ -1047,6 +1193,7 @@ static iproc subr2s[] = { {s_try_open_file, try_open_file}, {s_cwis, cwis}, {s_mksfpt, mksfpt}, + {s_add_finalizer, scm_add_finalizer}, {0, 0}}; SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3)); @@ -1060,6 +1207,7 @@ void init_io() loc_open_file = &CDR(sysintern(s_open_file, CDR(sysintern(s_try_open_file, UNDEFINED)))); + loc_try_create_file = &CDR(sysintern(s_try_create_file, UNDEFINED)); #ifndef CHEAP_CONTINUATIONS add_feature("full-continuation"); #endif @@ -1079,6 +1227,7 @@ long heap_cells = 0; CELLPTR *hplims, heap_org; VOLATILE SCM freelist = EOL; long mltrigger, mtrigger = INIT_MALLOC_LIMIT; +int gc_hook_pending = 0, gc_hook_active = 0; /* Ints should be deferred when calling igc_for_alloc. */ static char *igc_for_alloc(where, olen, size, what) @@ -1090,17 +1239,16 @@ static char *igc_for_alloc(where, olen, size, what) char *ptr; long nm; /* Check to see that heap is initialized */ - ASSERT(heap_cells>0, MAKINUM(size), NALLOC, what); + ASSERT(heap_cells > 0, MAKINUM(size), NALLOC, what); +/* printf("igc_for_alloc(%lx, %lu, %u, %s)\n", where, olen, size, what); fflush(stdout); */ igc(what, CONT(rootcont)->stkbse); nm = mallocated + size - olen; if (nm > mltrigger) { if (nm > mtrigger) grew_lim(nm + nm/2); else grew_lim(mtrigger + mtrigger/2); } - if (where) - SYSCALL(ptr = (char *)realloc(where, size);); - else - SYSCALL(ptr = (char *)malloc(size);); + if (where) SYSCALL(ptr = (char *)realloc(where, size);); + else SYSCALL(ptr = (char *)malloc(size);); ASSERT(ptr, MAKINUM(size), NALLOC, what); if (nm > mltrigger) { if (nm > mtrigger) mtrigger = nm + nm/2; @@ -1121,14 +1269,11 @@ char *must_malloc(len, what) #ifdef SHORT_SIZET ASSERT(len==size, MAKINUM(len), NALLOC, what); #endif - if (nm <= mtrigger) - SYSCALL(ptr = (char *)malloc(size);); - else - ptr = 0; - if (!ptr) - ptr = igc_for_alloc(0L, 0L, size, what); - else - mallocated = nm; + if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size);); + else ptr = 0; + if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what); + else mallocated = nm; +/* printf("must_malloc(%lu, %s) => %lx\n", len, what, ptr); fflush(stdout); */ return ptr; } SCM must_malloc_cell(len, c, what) @@ -1145,14 +1290,11 @@ SCM must_malloc_cell(len, c, what) ASSERT(len==size, MAKINUM(len), NALLOC, what); #endif NEWCELL(z); - if (nm <= mtrigger) - SYSCALL(ptr = (char *)malloc(size);); - else - ptr = 0; - if (!ptr) - ptr = igc_for_alloc(0L, 0L, size, what); - else - mallocated = nm; + if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size);); + else ptr = 0; + if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what); + else mallocated = nm; +/* printf("must_malloc_cell(%lu, %lx, %s) => %lx\n", len, c, what, ptr); fflush(stdout); */ SETCHARS(z, ptr); CAR(z) = c; return z; @@ -1169,14 +1311,13 @@ char *must_realloc(where, olen, len, what) #ifdef SHORT_SIZET ASSERT(len==size, MAKINUM(len), NALLOC, what); #endif - if (nm <= mtrigger) - SYSCALL(ptr = (char *)realloc(where, size);); - else - ptr = 0; - if (!ptr) - ptr = igc_for_alloc(where, olen, size, what); - else - mallocated = nm; + ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what); +/* printf("must_realloc(%lx, %lu, %lu, %s)\n", where, olen, len, what); fflush(stdout); + printf("nm = %ld <= mtrigger = %ld: %d; size = %u\n", nm, mtrigger, (nm <= mtrigger), size); fflush(stdout); */ + if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size);); + else ptr = 0; + if (!ptr) ptr = igc_for_alloc(where, olen, size, what); + else mallocated = nm; return ptr; } void must_realloc_cell(z, olen, len, what) @@ -1191,14 +1332,12 @@ void must_realloc_cell(z, olen, len, what) #ifdef SHORT_SIZET ASSERT(len==size, MAKINUM(len), NALLOC, what); #endif - if (nm <= mtrigger) - SYSCALL(ptr = (char *)realloc(where, size);); - else - ptr = 0; - if (!ptr) - ptr = igc_for_alloc(where, olen, size, what); - else - mallocated = nm; + ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what); +/* printf("must_realloc_cell(%lx, %lu, %lu, %s)\n", z, olen, len, what); fflush(stdout); */ + if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size);); + else ptr = 0; + if (!ptr) ptr = igc_for_alloc(where, olen, size, what); + else mallocated = nm; SETCHARS(z, ptr); } void must_free(obj, len) @@ -1209,6 +1348,7 @@ void must_free(obj, len) #ifdef CAREFUL_INTS while (len--) obj[len] = '#'; #endif +/* printf("free(%lx)\n", obj); fflush(stdout); */ free(obj); mallocated = mallocated - len; } @@ -1243,7 +1383,7 @@ SCM intern(name, len) register sizet i = len; register unsigned char *tmp = (unsigned char *)name; sizet hash = strhash(tmp, i, (unsigned long)symhash_dim); - /* printf("intern %s len=%d\n",name,len);fflush(stdout); */ + /* printf("intern %s len=%d\n",name,len); fflush(stdout); */ DEFER_INTS; for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { z = CAR(lsym); @@ -1256,8 +1396,7 @@ SCM intern(name, len) trynext: ; } /* lsym = makfromstr(name, len); */ - lsym = must_malloc_cell(len+1L, - MAKE_LENGTH((long)len, tc7_msymbol), s_string); + lsym = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_msymbol), s_string); i = len; CHARS(lsym)[len] = 0; while (i--) CHARS(lsym)[i] = name[i]; @@ -1284,16 +1423,15 @@ SCM sysintern(name, val) if (LENGTH(z) != len) goto trynext; for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; lsym = CAR(lsym); - if (!UNBNDP(val)) - CDR(lsym) = val; + if (!UNBNDP(val)) CDR(lsym) = val; + else if (UNBNDP(CDR(lsym)) && tc7_msymbol==TYP7(CAR(lsym))) + scm_gc_protect(lsym); return lsym; trynext: ; } NEWCELL(lsym); - DEFER_INTS; - SETLENGTH(lsym, (long)len, tc7_ssymbol); + SETLENGTH(lsym, len, tc7_ssymbol); SETCHARS(lsym, name); - ALLOW_INTS; lsym = cons(lsym, val); z = cons(lsym, UNDEFINED); CDR(z) = VELTS(symhash)[hash]; @@ -1350,7 +1488,7 @@ SCM makstr(len) return s; } -scm_gra subr_table_gra; +scm_gra subrs_gra; SCM scm_maksubr(name, type, fcn) const char *name; int type; @@ -1360,7 +1498,7 @@ SCM scm_maksubr(name, type, fcn) int isubr; register SCM z; info.name = name; - isubr = scm_grow_gra(&subr_table_gra, (char *)&info); + isubr = scm_grow_gra(&subrs_gra, (char *)&info); NEWCELL(z); if (!fcn && tc7_cxr==type) { const char *p = name; @@ -1484,7 +1622,7 @@ SCM scm_make_cont() #else from[1] = BOOL_F; /* Can't write to parent stack */ estk = must_malloc_cell((long)n*sizeof(SCM), - MAKE_LENGTH((long)n, tc7_vector), s_cont); + MAKE_LENGTH(n, tc7_vector), s_cont); { SCM *to = VELTS(estk); while(n--) to[n] = from[n]; @@ -1500,6 +1638,10 @@ SCM scm_make_cont() ncont->other.stkframe[1] = scm_env_tmp; ncont->other.estk = estk; ncont->other.estk_ptr = scm_estk_ptr; +#ifndef RECKLESS + ncont->other.stkframe[2] = scm_trace_env; + ncont->other.stkframe[3] = scm_trace; +#endif return cont; } static char s_sstale[] = "strangely stale"; @@ -1521,14 +1663,17 @@ void scm_dynthrow(tocont, val) SCM *from = VELTS(cont->other.estk); SCM *to = VELTS(scm_estk); sizet n = LENGTH(cont->other.estk); - if (LENGTH(scm_estk) < n) - scm_estk_reset((sizet)LENGTH(scm_estk)); + if (LENGTH(scm_estk) < n) scm_estk_reset((sizet)LENGTH(scm_estk)); scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN; while(n--) to[n] = from[n]; } #endif scm_env = cont->other.stkframe[0]; scm_env_tmp = cont->other.stkframe[1]; +#ifndef RECKLESS + scm_trace_env = cont->other.stkframe[2]; + scm_trace = cont->other.stkframe[3]; +#endif ALLOW_INTS; } throw_to_continuation(cont, val, CONT(rootcont)); @@ -1621,6 +1766,24 @@ static void fixconfig(s1, s2, s) quit(MAKINUM(1L)); } +void heap_report() +{ + sizet i = 0; + if (hplim_ind) lputs("; heap segments:", sys_errp); + while(i < hplim_ind) { + { + long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]); + lputs("\n; 0x", sys_errp); + intprint((long)hplims[i++], -16, sys_errp); + lputs(" - 0x", sys_errp); + intprint((long)hplims[i++], -16, sys_errp); + lputs("; ", sys_errp); + intprint(seg_cells, 10, sys_errp); + lputs(" cells; ", sys_errp); + intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp); + lputs(".kiB", sys_errp); + }} +} sizet init_heap_seg(seg_org, size) CELLPTR seg_org; sizet size; @@ -1641,6 +1804,8 @@ sizet init_heap_seg(seg_org, size) hplims[ni++] = seg_end; ptr = CELL_UP(ptr); ni = seg_end - ptr; +/* printf("ni = %u; hplim_ind = %u\n", ni, hplim_ind); */ +/* printf("ptr = %lx\n", ptr); */ for (i = ni;i--;ptr++) { #ifdef POINTERS_MUNGED scmptr = PTR2SCM(ptr); @@ -1696,12 +1861,12 @@ void scm_init_gra(gra, eltsize, len, maxlen, what) char *what; { char *nelts; - DEFER_INTS; + /* DEFER_INTS; */ /* Can't call must_malloc, because heap may not be initialized yet. */ /* SYSCALL(nelts = malloc(len*eltsize);); if (!nelts) wta(MAKINUM(len*eltsize), (char *)NALLOC, what); mallocated += len*eltsize; - */ + */ nelts = must_malloc((long)len*eltsize, what); gra->eltsize = eltsize; gra->len = 0; @@ -1709,7 +1874,7 @@ void scm_init_gra(gra, eltsize, len, maxlen, what) gra->alloclen = len; gra->maxlen = maxlen; gra->what = what; - ALLOW_INTS; + /* ALLOW_INTS; */ } /* Returns the index into the elt array */ int scm_grow_gra(gra, elt) @@ -1718,12 +1883,11 @@ int scm_grow_gra(gra, elt) { int i; char *tmp; - DEFER_INTS; if (gra->alloclen <= gra->len) { sizet inc = gra->len / 5 + 1; sizet nlen = gra->len + inc; if (gra->maxlen && nlen > gra->maxlen) - growerr: wta(MAKINUM(nlen), (char *)NALLOC, gra->what); + /* growerr: */ wta(MAKINUM(nlen), (char *)NALLOC, gra->what); /* SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize);); if (!tmp) goto growerr; @@ -1738,9 +1902,22 @@ int scm_grow_gra(gra, elt) gra->len += 1; for (i = 0; i < gra->eltsize; i++) tmp[i] = elt[i]; - ALLOW_INTS; return gra->len - 1; } +void scm_trim_gra(gra) + scm_gra *gra; +{ + char *tmp; + long curlen = gra->len; + if (0L==curlen) curlen = 1L; + if (curlen==(long)gra->alloclen) return; + tmp = must_realloc(gra->elts, + (long)gra->alloclen * gra->eltsize, + curlen * gra->eltsize, + gra->what); + gra->elts = tmp; + gra->alloclen = curlen; +} void scm_free_gra(gra) scm_gra *gra; { @@ -1748,6 +1925,26 @@ void scm_free_gra(gra) gra->elts = 0; mallocated -= gra->maxlen*gra->eltsize; } +void gra_report1(gra) + scm_gra *gra; +{ + intprint((long)gra->len, -10, cur_errp); + lputs(" (of ", cur_errp); + intprint((long)gra->alloclen, -10, cur_errp); + lputs(") ", cur_errp); + lputs(gra->what, cur_errp); + lputs("; ", cur_errp); +} +void gra_report() +{ + lputs(";; gra: ", cur_errp); + gra_report1(&ptobs_gra); + gra_report1(&smobs_gra); + gra_report1(&finals_gra); + gra_report1(&subrs_gra); + lputs("\n", cur_errp); +} + scm_gra smobs_gra; long newsmob(smob) smobfuns *smob; @@ -1760,38 +1957,35 @@ long newptob(ptob) { return tc7_port + 256*scm_grow_gra(&ptobs_gra, (char *)ptob); } -#define PORT_TABLE_MAXLEN (1 + ((int)((unsigned long)~0L>>20))) port_info *scm_port_table = 0; -static int scm_port_table_len = 0; +static sizet scm_port_table_len = 0; static char s_port_table[] = "port table"; -SCM scm_port_entry(ptype, flags) +SCM scm_port_entry(stream, ptype, flags) + FILE *stream; long ptype, flags; { - int nlen; + SCM z; + sizet nlen; int i, j; VERIFY_INTS("scm_port_entry", 0L); flags = flags | (ptype & ~0xffffL); ASSERT(flags, INUM0, ARG1, "scm_port_entry"); - for (i = 0; i < scm_port_table_len; i++) + for (i = 1; i < scm_port_table_len; i++) if (0L==scm_port_table[i].flags) goto ret; - if (0==scm_port_table_len) { /* Initialize */ - scm_port_table_len = 16; - scm_port_table = (port_info *) - must_malloc((long)scm_port_table_len*sizeof(port_info), s_port_table); - } - else if (scm_port_table_len < PORT_TABLE_MAXLEN) { + if (scm_port_table_len <= SCM_PORTNUM_MAX) { nlen = scm_port_table_len + (scm_port_table_len / 2); - if (nlen > PORT_TABLE_MAXLEN) nlen = PORT_TABLE_MAXLEN; + if (nlen >= SCM_PORTNUM_MAX) nlen = (sizet)SCM_PORTNUM_MAX + 1; scm_port_table = (port_info *) must_realloc((char *)scm_port_table, - (long)scm_port_table_len*sizeof(port_info), - nlen*sizeof(port_info)+0L, + (long)scm_port_table_len * sizeof(port_info), + (long)nlen * sizeof(port_info), s_port_table); scm_port_table_len = nlen; - growth_mon(s_port_table, nlen+0L, "entries", !0); + growth_mon(s_port_table, nlen + 0L, "entries", !0); for (j = i; j < scm_port_table_len; j++) { scm_port_table[j].flags = 0L; - scm_port_table[j].data = EOL; + scm_port_table[j].data = UNDEFINED; + scm_port_table[j].port = UNDEFINED; } } else { @@ -1801,12 +1995,27 @@ SCM scm_port_entry(ptype, flags) wta(UNDEFINED, s_nogrow, s_port_table); } ret: + NEWCELL(z); + SETSTREAM(z, stream); + CAR(z) = (((long)i)<<20) | (flags & 0x0f0000) | ptype; scm_port_table[i].unread = EOF; scm_port_table[i].flags = flags; scm_port_table[i].line = 1L; /* should both be one-based? */ scm_port_table[i].col = 1; scm_port_table[i].data = UNSPECIFIED; - return (((long)i)<<20) | (flags & 0x0f0000) | ptype; + scm_port_table[i].port = z; + return z; +} +SCM scm_open_ports() +{ + SCM p, res = EOL; + int k; + for(k = scm_port_table_len - 1; k > 0; k--) { + p = scm_port_table[k].port; + if (NIMP(p) && OPPORTP(p)) + res = cons(p, res); + } + return res; } SCM markcdr(ptr) @@ -1888,8 +2097,10 @@ void init_storage(stack_start_ptr, init_heap_size) hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims); if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE; j = init_heap_size; +/* printf("j = %u; init_heap_size = %lu\n", j, init_heap_size); */ if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) { j = HEAP_SEG_SIZE; +/* printf("j = %u; HEAP_SEG_SIZE = %lu\n", j, HEAP_SEG_SIZE); */ if (!init_heap_seg((CELLPTR) malloc(j), j)) wta(MAKINUM(j), (char *)NALLOC, s_heap); } @@ -1897,12 +2108,37 @@ void init_storage(stack_start_ptr, init_heap_size) heap_org = CELL_UP(hplims[0]); /* hplims[0] can change. do not remove heap_org */ - NEWCELL(def_inp); - CAR(def_inp) = scm_port_entry(tc16_fport, OPN|RDNG); - SETSTREAM(def_inp, stdin); - NEWCELL(def_outp); - CAR(def_outp) = scm_port_entry(tc16_fport, OPN|WRTNG|TRACKED); - SETSTREAM(def_outp, stdout); + scm_port_table_len = 16; + scm_port_table = (port_info *) + must_malloc((long)scm_port_table_len * sizeof(port_info), s_port_table); + for (j = 0; j < scm_port_table_len; j++) { + scm_port_table[j].flags = 0L; + scm_port_table[j].data = UNDEFINED; + scm_port_table[j].port = UNDEFINED; + } + + nullstr = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_string), s_string); + CHARS(nullstr)[0] = 0; + nullvect = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_vector), s_vector); + { + long i = symhash_dim; + SCM *velts; + symhash = must_malloc_cell(i * sizeof(SCM), + MAKE_LENGTH(i, tc7_vector), + s_vector); + velts = VELTS(symhash); + while(--i >= 0) (velts)[i] = EOL; + } + /* Now that symhash is setup, we can sysintern() */ + sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM)); + sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM)); +#ifdef BIGDIG + sysintern("bignum-radix", MAKINUM(BIGRAD)); +#endif + def_inp = scm_port_entry(stdin, tc16_fport, OPN|RDNG); + SCM_PORTDATA(def_inp) = CAR(sysintern("stdin", UNDEFINED)); + def_outp = scm_port_entry(stdout, tc16_fport, OPN|WRTNG|TRACKED); + SCM_PORTDATA(def_outp) = CAR(sysintern("stdout", UNDEFINED)); NEWCELL(def_errp); CAR(def_errp) = (tc16_fport|OPN|WRTNG); SETSTREAM(def_errp, stderr); @@ -1922,17 +2158,6 @@ void init_storage(stack_start_ptr, init_heap_size) listofnull = cons(EOL, EOL); undefineds = cons(UNDEFINED, EOL); CDR(undefineds) = undefineds; - nullstr = makstr(0L); - nullvect = make_vector(INUM0, UNDEFINED); - /* NEWCELL(nullvect); - CAR(nullvect) = tc7_vector; - SETCHARS(nullvect, NULL); */ - symhash = make_vector((SCM)MAKINUM(symhash_dim), EOL); - sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM)); - sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM)); -#ifdef BIGDIG - sysintern("bignum-radix", MAKINUM(BIGRAD)); -#endif /* flo0 is now setup in scl.c */ /* Set up environment cache */ scm_ecache_len = sizeof(ecache_v)/sizeof(cell); @@ -2014,8 +2239,9 @@ jump_buf save_regs_gc_mark; void mark_locations P((STACKITEM x[], sizet n)); static void mark_syms P((SCM v)); static void mark_sym_values P((SCM v)); -static void mark_subr_table P((void)); +static void mark_subrs P((void)); static void sweep_symhash P((SCM v)); +static void mark_finalizers P((SCM *live, SCM *dead)); static void mark_port_table P((SCM port)); static void sweep_port_table P((void)); static void egc_mark P((void)); @@ -2032,6 +2258,49 @@ SCM gc(arg) ALLOW_INTS; return UNSPECIFIED; } + +void scm_run_finalizers(exiting) + int exiting; +{ + SCM f; + if (exiting) { /* run all finalizers, we're going home. */ + DEFER_INTS; + while NIMP(gc_finalizers) { + f = CAR(gc_finalizers); + CAR(f) = CDR(f); + CDR(f) = gc_finalizers_pending; + gc_finalizers_pending = f; + gc_finalizers = CDR(gc_finalizers); + } + ALLOW_INTS; + } + while (!0) { + DEFER_INTS; + if NIMP(gc_finalizers_pending) { + f = CAR(gc_finalizers_pending); + gc_finalizers_pending = CDR(gc_finalizers_pending); + } + else f = BOOL_F; + ALLOW_INTS; + if IMP(f) break; + apply(f, EOL, EOL); + } +} + +static SCM *loc_gc_hook = 0; +void scm_gc_hook () +{ + if (gc_hook_active) { + scm_warn("gc-hook thrashing?\n", "", UNDEFINED); + return; + } + gc_hook_active = !0; + if (! loc_gc_hook) loc_gc_hook = &CDR(sysintern("gc-hook", UNDEFINED)); + if (NIMP(*loc_gc_hook)) apply(*loc_gc_hook, EOL, EOL); + scm_run_finalizers(0); + gc_hook_active = 0; +} + void igc(what, stackbase) char *what; STACKITEM *stackbase; @@ -2043,8 +2312,7 @@ void igc(what, stackbase) if (err) wta(MAKINUM(err), "malloc corrupted", what); #endif gc_start(what); - if (errjmp_bad) - wta(UNDEFINED, s_recursive, s_gc); + if (errjmp_bad) wta(UNDEFINED, s_recursive, s_gc); errjmp_bad = s_gc; #ifdef NO_SYM_GC gc_mark(symhash); @@ -2057,7 +2325,7 @@ void igc(what, stackbase) /* mark_sym_values() can be called anytime after mark_syms. */ mark_sym_values(symhash); #endif - mark_subr_table(); + mark_subrs(); egc_mark(); if (stackbase) { FLUSH_REGISTER_WINDOWS; @@ -2088,6 +2356,7 @@ void igc(what, stackbase) } while(j--) gc_mark(sys_protects[j]); + mark_finalizers(&gc_finalizers, &gc_finalizers_pending); #ifndef NO_SYM_GC sweep_symhash(symhash); #endif @@ -2102,12 +2371,15 @@ void igc(what, stackbase) growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp); growth_mon(s_heap, heap_cells, s_cells, grewp); } + gc_hook_pending = !0; + deferred_proc = process_signals; } static char s_not_free[] = "not freed"; void free_storage() { DEFER_INTS; + loc_gc_hook = (SCM *)0; gc_start("free"); errjmp_bad = "free_storage"; cur_inp = BOOL_F; cur_outp = BOOL_F; @@ -2137,7 +2409,7 @@ void free_storage() hplims = 0; scm_free_gra(&finals_gra); scm_free_gra(&smobs_gra); - scm_free_gra(&subr_table_gra); + scm_free_gra(&subrs_gra); gc_end(); ALLOW_INTS; /* A really bad idea, but printing does it anyway. */ exit_report(); @@ -2302,7 +2574,7 @@ void mark_locations(x, n) register int i, j; register CELLPTR ptr; while(0 <= --m) if CELLP(*(SCM **)&x[m]) { - ptr = (CELLPTR)SCM2PTR((*(SCM **)&x[m])); + ptr = (CELLPTR)SCM2PTR((SCM)(*(SCM **)&x[m])); i = 0; j = hplim_ind; do { @@ -2332,10 +2604,10 @@ static void gc_sweep(contin_bad) long pre_m = mallocated; sizet i = 0; sizet seg_cells; - while (i<hplim_ind) { + while (i < hplim_ind) { ptr = CELL_UP(hplims[i++]); seg_cells = CELL_DN(hplims[i++]) - ptr; - for(j = seg_cells;j--;++ptr) { + for(j = seg_cells; j--; ++ptr) { #ifdef POINTERS_MUNGED scmptr = PTR2SCM(ptr); #endif @@ -2397,12 +2669,8 @@ static void gc_sweep(contin_bad) goto freechars; case tc7_contin: if GC8MARKP(scmptr) { - if (contin_bad && CONT(scmptr)->length) { - scm_warn("uncollected ", (char *)0); - iprin1(scmptr, cur_errp, 1); - lputc('\n', cur_errp); - lfflush(cur_errp); - } + if (contin_bad && CONT(scmptr)->length) + scm_warn("uncollected ", "", scmptr); goto c8mrkcontinue; } minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION); @@ -2456,8 +2724,8 @@ static void gc_sweep(contin_bad) default: goto sweeperr; } -#endif /* def FLOATS */ break; +#endif /* def FLOATS */ default: if GC8MARKP(scmptr) goto c8mrkcontinue; { @@ -2580,10 +2848,59 @@ static void sweep_symhash(v) } #endif -static void mark_subr_table() +/* This function should be called after all other marking is done. */ +static void mark_finalizers(finalizers, pending) + SCM *finalizers, *pending; +{ + SCM lst, elt, v; + SCM live = EOL, undead = *finalizers; + int more_to_do = !0; + gc_mark(*pending); + while NIMP(*pending) pending = &CDR(*pending); + while (more_to_do) { + more_to_do = 0; + lst = undead; + undead = EOL; + while (NIMP(lst)) { + elt = CAR(lst); + v = CAR(elt); + switch (TYP3(v)) { + default: + if (GCMARKP(v)) goto marked; + goto unmarked; + case tc3_tc7_types: + if (GC8MARKP(v)) { + marked: + gc_mark(CDR(elt)); + more_to_do = !0; + v = lst; + lst = CDR(lst); + CDR(v) = live; + live = v; + } + else { + unmarked: + v = lst; + lst = CDR(lst); + CDR(v) = undead; + undead = v; + } + break; + } + } + } + gc_mark(live); + for (lst = undead; NIMP(lst); lst = CDR(lst)) + CAR(lst) = CDR(CAR(lst)); + gc_mark(undead); + *finalizers = live; + *pending = undead; +} + +static void mark_subrs() { - subr_info *table = subr_table; - int k = subr_table_gra.len; + /* subr_info *table = subrs; */ + /* int k = subrs_gra.len; */ /* while (k--) { } */ } static void mark_port_table(port) @@ -2606,7 +2923,8 @@ static void sweep_port_table() scm_port_table[k].flags &= (~1L); else { scm_port_table[k].flags = 0L; - scm_port_table[k].data = EOL; + scm_port_table[k].data = UNDEFINED; + scm_port_table[k].port = UNDEFINED; } } } @@ -2732,9 +3050,9 @@ static void egc_copy_roots() non-cache cell was made to point into the cache. */ if ECACHEP(x) break; - e = CDR(x); + e = CAR(x); if (NIMP(e) && ECACHEP(e)) - egc_copy(&(CDR(x))); + egc_copy(&(CAR(x))); break; default: if (tc7_contin==TYP7(x)) { @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -103,12 +103,26 @@ # include <sys/timeb.h> # define USE_GETTIMEOFDAY #endif +#ifdef __MACH__ +# define unix +# include <sys/types.h> +# include <sys/time.h> +# include <sys/timeb.h> +# include <sys/times.h> +# define USE_GETTIMEOFDAY +#endif #ifdef __FreeBSD__ # include <sys/types.h> # include <sys/time.h> # include <sys/timeb.h> # define USE_GETTIMEOFDAY #endif +#ifdef __OpenBSD__ +# include <sys/types.h> +# include <sys/time.h> +# include <sys/timeb.h> +# define USE_GETTIMEOFDAY +#endif #ifdef __TURBOC__ # define LACK_TIMES #endif @@ -130,9 +144,13 @@ #ifdef SVR4 # define LACK_FTIME #endif -#ifdef __svr4__ +#ifdef __SVR4 # define LACK_FTIME #endif +#ifdef PLAN9 +#define LACK_FTIME +#define LACK_TIMES +#endif #ifdef nosve # define LACK_FTIME #endif @@ -160,7 +178,7 @@ #ifdef _UNICOS # define LACK_FTIME #endif -#ifdef __amigados__ +#ifdef __amigaos__ # include <sys/time.h> # include <sys/timeb.h> # include <sys/times.h> @@ -168,7 +186,7 @@ #endif #ifndef LACK_FTIME -# ifdef unix +# ifdef HAVE_UNIX # ifndef GO32 # include <sys/timeb.h> # endif @@ -199,7 +217,7 @@ #ifdef CLK_TCK # define CLKTCK CLK_TCK # ifdef CLOCKS_PER_SEC -# ifdef unix +# ifdef HAVE_UNIX # ifndef ARM_ULIB # include <sys/times.h> # endif @@ -335,7 +353,8 @@ SCM your_time() else if ((1 + time_buffer1.time)==time_buffer2.time) ; else if (cnt < TIMETRIES) goto tryagain; else { - scm_warn("could not read two ftime()s within one second in 10 tries",0L); + scm_warn("could not read two ftime()s within one second in 10 tries", + "", UNDEFINED); return MAKINUM(-1); } tmp = CLKTCK*(time_buffer2.millitm - your_base.millitm); @@ -1,2 +0,0 @@ -;(0.25 -3.25) -(define foo (quote (0.25 -3.25)))
\ No newline at end of file @@ -0,0 +1,20 @@ +#define turtle_width 40 +#define turtle_height 40 +static char turtle_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, + 0xff, 0x00, 0x00, 0x00, 0xe0, 0x84, 0x07, 0x00, 0x00, 0x10, 0x0c, 0x78, + 0x00, 0x00, 0x0c, 0x08, 0xc0, 0x00, 0x00, 0x02, 0x18, 0x40, 0x03, 0x00, + 0x01, 0x28, 0x40, 0x02, 0x80, 0x0f, 0xcc, 0x7f, 0x02, 0xc0, 0xf8, 0x07, + 0x10, 0x06, 0x40, 0x00, 0x04, 0x30, 0x0c, 0x60, 0x00, 0x04, 0x7c, 0x08, + 0xf8, 0x00, 0x04, 0xc2, 0x0f, 0x8c, 0x01, 0x0f, 0x01, 0x0b, 0x26, 0x01, + 0xf1, 0x01, 0x11, 0x03, 0x81, 0x01, 0x81, 0x20, 0x07, 0x83, 0x80, 0x80, + 0x40, 0x9a, 0x83, 0x00, 0x8f, 0xf8, 0x42, 0xc6, 0xff, 0xe3, 0x0f, 0x7e, + 0x63, 0x18, 0x22, 0x00, 0xc0, 0x31, 0xf0, 0x13, 0x00, 0x00, 0x11, 0x00, + 0x11, 0x00, 0x00, 0x0f, 0x00, 0x1b, 0x00, 0x00, 0x06, 0x00, 0x0e, 0x0e, + 0x00, 0x00, 0x00, 0x80, 0x09, 0x00, 0x00, 0x00, 0xc0, 0x88, 0x00, 0x00, + 0x00, 0x00, 0xff, 0x00, 0x00, 0x02, 0x00, 0x08, 0x00, 0x00, 0x05, 0x38, + 0x08, 0x00, 0x80, 0x08, 0x44, 0x08, 0x00, 0x40, 0x04, 0x44, 0x08, 0x00, + 0x20, 0x02, 0x48, 0x04, 0x00, 0x10, 0x01, 0x70, 0x06, 0x00, 0x88, 0x00, + 0xc0, 0x01, 0x00, 0x44, 0x00, 0x40, 0x00, 0x00, 0x22, 0x0e, 0x40, 0x00, + 0x00, 0x11, 0x0a, 0x40, 0x00, 0x00, 0x09, 0x0c, 0x40, 0x00, 0x80, 0x06, + 0x3e, 0x20, 0x00, 0x80, 0xf1, 0xc1, 0x1f, 0x00}; diff --git a/turtlegr.c b/turtlegr.c new file mode 100644 index 0000000..c74663b --- /dev/null +++ b/turtlegr.c @@ -0,0 +1,1298 @@ + +/* file turtlegr.c * + * Copyright (C) 1992 sjm@ee.tut.fi * + * jtl@cc.tut.fi * + * * + * Turtlegraphics primitives for the * + * SCM interpreter by Aubrey Jaffer * + * * + * Last modification: 13.10.1992 * + * * + * Versions: * + * 12.3.1992 The first version. * + * 13.3.1992 Added the possibility to pass * + * floating point args. * + * 15.3.1992 Graphics cards other than EGA * + * are now supported. * + * 9.4.1992 The internal representation * + * of X & Y is now float. * + * 13.10.1992 Added X11 support. * + * A major rewrite of certain * + * parts. * + * Put -DX11 -DFLOATS to CFLAGS * + * in Makefile to get it. * + * * + * REMEMBER to define INITS=init_turtlegr() * + * in the Makefile. * + * */ + +/* * + * This code tries to compromise between two very different * + * systems: MSDOS and UNIX with the X11 windowing system. * + * The MSDOS version was build first and it really shows. :) * + * The X port is a partial rewrite of the old MSDOS stuff * + * and plays around with #ifdef's a lot. The result is, * + * eventually, a C source which is expected to compile * + * under both MSDOS and UNIX (X11). * + * The X code handles colors emulating CGA palette. It tries * + * to act sensibly even on a monochrome screen and when the * + * color palette is full. * + * X event handling is implemented with polling whenever * + * appropriate. This is not The Right Way to do it in X, but * + * it was easiest to adopt in this case. * + * Another solution would have been to make the X graphics * + * a separate process, but I didn't want to because I wanted * + * to keep it simple. I can't tell how good an example of porting * + * MSDOS software to X this is, but it works. * + * * + * This has been tested with SunOs 4.1.2 with X11R5, Linux 0.98.1 * + * with Xfree86 1.1 (X11R5 port) and in MSDOS with BC 3.1. * + * Because the code uses only the basic Xlib calls, it should * + * compile without problems under _any_ UNIX with X11R4 or newer. * + * * + * Please send bugreports to sjm@ee.tut.fi. * + * I'm especially interested in hearing about ports to other * + * platforms than those tested by me. * + * * + * - sjm * + * */ + + +/****************************************************/ +/***** GENERIC includes & defines *****/ +/****************************************************/ +#include "scm.h" /* includes scmfig.h as well */ +#include "patchlvl.h" /* Guess... */ +#include <math.h> /* sin(), cos(), fmod() */ +#include <stdlib.h> /* atexit() */ + +/****************************************************/ +/***** X11 specific includes & defines *****/ +/****************************************************/ +#ifdef X11 + +/* Xlib include files */ +#include <X11/Xlib.h> +#include <X11/Xutil.h> +#include <X11/Xatom.h> +#include <stdio.h> + +#include "turtle" +#define BITMAPDEPTH 1 + +#define PROGNAME "scm" +#define CLASSNAME "Scm" +#define WINDOWNAME "TurtleSCM graphics window" +#define ICONNAME "TurtleSCM" + +#define GR_MAX_XSIZE 1024 +#define GR_MAX_YSIZE 1024 +#define GR_DEF_XSIZE 640 +#define GR_DEF_YSIZE 480 +#define GR_MIN_XSIZE 64 +#define GR_MIN_YSIZE 64 + +/* Fake CGA colormap with X - yuk! */ +#define GR_COLORS 16 /* CGA/EGA counterpart */ +#define GR_COLOR00 "black" /* black */ +#define GR_COLOR01 "blue2" /* blue */ +#define GR_COLOR02 "green2" /* green */ +#define GR_COLOR03 "cyan2" /* cyan */ +#define GR_COLOR04 "red3" /* red */ +#define GR_COLOR05 "magenta2" /* magenta */ +#define GR_COLOR06 "yellow2" /* brown */ +#define GR_COLOR07 "light gray" /* white */ +#define GR_COLOR08 "gray" /* gray */ +#define GR_COLOR09 "blue1" /* light blue */ +#define GR_COLOR10 "green1" /* light green */ +#define GR_COLOR11 "cyan1" /* light cyan */ +#define GR_COLOR12 "red1" /* light red */ +#define GR_COLOR13 "magenta1" /* light magenta */ +#define GR_COLOR14 "yellow1" /* yellow */ +#define GR_COLOR15 "white" /* bright white */ + +#ifdef __STDC__ +static void gr_events( int ); +#else +static void gr_events(); +#endif + +#else +/****************************************************/ +/***** PC specific includes & defines *****/ +/****************************************************/ +#include <graphics.h> +#include <stdlib.h> /* for getenv() */ +#include <stdio.h> /* for fputs() */ +#define BGIDIR_ENVSTRING "BGIDIR" +#endif + +/********************************************/ +/***** GENERIC code, declarations *****/ +/********************************************/ +#define SIN( x ) \ + sin( ((x)/180.0) * M_PI ) +#define COS( x ) \ + cos( ((x)/180.0) * M_PI ) + +static int gr_graphicsavail = 0; +static int gr_grmode_on = 0; +static float gr_dir = 0.0; +static int gr_max_x=0, gr_max_y=0, gr_max_color=0; +static float gr_x=0.0, gr_y=0.0; +static int gr_color = 0; + +static char s_gr_draw[] = "draw"; +static char s_gr_move[] = "move"; +static char s_gr_setcolor[] = "set-color!"; +static char s_gr_turnright[] = "turn-right"; +static char s_gr_turnleft[] = "turn-left"; +static char s_gr_turnto[] = "turn-to!"; + +static char s_gr_getdot[] = "get-dot"; +static char s_gr_drawTo[] = "draw-to!"; +static char s_gr_drawto[] = "draw-to"; +static char s_gr_moveTo[] = "move-to!"; + +static char s_gr_setdot[] = "set-dot!"; +static char s_gr_validXYC[] = "valid-xyc?"; + +#ifdef __GNUC__ +inline +#else +static +#endif +int valid_XYC( x, y, color ) +int x, y, color; +{ +#ifdef X11 + /* Check for changed window size */ + gr_events(0); +#endif + if( (x <= gr_max_x) && (y <= gr_max_y) && (color <= gr_max_color) + && (x >= 0) && (y >= 0) && (color >= 0) ) + return( 1 ); + else + return( 0 ); +} /* valid_XYC() */ + + +/********************************************************************/ +/***** X11 specific variable and function declarations *****/ +/********************************************************************/ +#ifdef X11 +static Display *gr_display; /* The X display */ +static int gr_screen; /* The X screen number */ +static Window gr_win; /* The drawable Window */ +static GC gr_gc; /* Graphics Context */ +static unsigned long gr_colortbl[GR_COLORS]; /* Color table */ +static XEvent gr_event; /* Event structure */ + +/* These are needed for XSetWMProperties */ +static char *gr_windowname = WINDOWNAME; +static char *gr_iconname = ICONNAME; +static char gr_progname[] = PROGNAME; +static char gr_classname[] = CLASSNAME; +static int gr_argc = 1; +static char *gr_argv[] = { gr_progname, NULL }; + +static void gr_eventhandler( event ) +XEvent event; +{ + switch( event.type ) { + + case ConfigureNotify: +#ifdef TESTING + fputs( "Received ConfigureNotify event\n", stderr ); +#endif + gr_max_x = event.xconfigure.width - 1; + gr_max_y = event.xconfigure.height - 1; + break; + + case MapNotify: +#ifdef TESTING + fputs( "Received MapNotify event\n", stderr ); +#endif + break; + + case DestroyNotify: +#ifdef TESTING + fputs( "Received DestroyNotify event\n", stderr ); +#endif + break; + + case UnmapNotify: +#ifdef TESTING + fputs( "Received UnmapNotify event\n", stderr ); +#endif + break; + + case Expose: +#ifdef TESTING + fputs( "Received Expose event\n", stderr ); +#endif + if( event.xexpose.count != 0 ) + break; + break; + + case ClientMessage: +#ifdef TESTING + fputs( "Received ClientMessage event\n", stderr ); +#endif + break; + + default: + /* Throw away any unknown events */ + break; + + } /* switch */ +} + +static void gr_events( expected ) +int expected; +{ +int i; + + /* Get at least 'expected' events */ + for( i = 0; i < expected; ++i ) { + XNextEvent( gr_display, &gr_event ); + gr_eventhandler( gr_event ); + } + /* Handle all remaining events if there are any */ + /* XPending will call XFlush() if it doesn't find events at once */ + while( XPending(gr_display) ) { + XNextEvent( gr_display, &gr_event ); + gr_eventhandler( gr_event ); + } /* while */ +} /* gr_events() */ + +static void gr_typedevent( type ) +int type; +{ + do { + XNextEvent( gr_display, &gr_event ); + gr_eventhandler( gr_event ); + } while( gr_event.type != type ); + /* Handle all remaining events if there are any */ + /* XPending will call XFlush() if it doesn't find events at once */ + while( XPending(gr_display) ) { + XNextEvent( gr_display, &gr_event ); + gr_eventhandler( gr_event ); + } /* while */ +} + + +/********************************************************************/ +/***** PC specific variable and function declarations *****/ +/********************************************************************/ +#else + +static int gr_max_display_mode; +static int gr_drivernum; + +#endif + + +/********************************************************************/ +/********************************************************************/ +/*** User callable SCM routines begin here *** + *** *** + *** ***/ + + +SCM gr_helpgr() +{ + fputs( "\ +Ret Name nargs args returns\n\ +---------------------------------------------------------\n\ +B graphics-avail? 0 - #t if graphics available\n\ +B graphics-mode! 0 - #f if no graphics\n\ +B text-mode! 0 - #t on success\n\ +B clear-graphics! 0 - #f if not in graphics mode\n\ +i max-x 0 - maximum value of x\n\ +i max-y 0 - maximum value of y\n\ +i max-color 0 - maximum value of color\n\ +B valid-xyc? 3 x y color #t if valid\n\ +B set-dot! 3 x y color #t on success\n\ +i get-dot 2 x y color of the dot in (x,y)\n\ + or #f if (x,y) not legal\n\ +\n\ +NOTE: Origin (0,0) is in the upper left corner.\n\n\ +", stdout ); + return BOOL_T; +} /* gr_helpgr() */ + + +SCM gr_helpturtlegr() +{ + fputs( "\ +Ret Name nargs args returns\n\ +---------------------------------------------------------\n\ +B goto-home! 0 - #f if not in graphics mode\n\ +B goto-center! 0 - #f if not in graphics mode\n\ +B goto-nw! 0 - #f if not in graphics mode\n\ +B goto-ne! 0 - #f if not in graphics mode\n\ +B goto-sw! 0 - #f if not in graphics mode\n\ +B goto-se! 0 - #f if not in graphics mode\n\ +B draw 1 length #t if target within drawing area\n\ +B draw-to 2 x y #t if (x,y) within drawing area\n\ +B draw-to! 2 x y #t if (x,y) within drawing area\n\ +B move 1 length #t if target within drawing area\n\ +B move-to! 2 x y #t if (x,y) within drawing area\n\ +i where-x 0 - current x-coordinate\n\ +i where-y 0 - current y-coordinate\n\ +i turn-right 1 angle drawing direction in degrees\n\ +i turn-left 1 angle drawing direction in degrees\n\ +i turn-to! 1 angle drawing direction in degrees\n\ +i what-direction 0 - drawing direction in degrees\n\ +B set-color! 1 color #t if color valid\n\ +i what-color 0 - current drawing color\n\n\ +", stdout ); + return BOOL_T; +} /* gr_helpturtlegr() */ + + +SCM gr_available() +{ + if( gr_graphicsavail ) + return BOOL_T; + else + return BOOL_F; +} /* gr_available() */ + + +SCM gr_maxx() +{ + if( !gr_grmode_on ) + return BOOL_F; +#ifdef X11 + /* Check for changed window size */ + gr_events(0); +#endif + return MAKINUM( (long)gr_max_x ); +} /* gr_maxx() */ + + +SCM gr_maxy() +{ + if( !gr_grmode_on ) + return BOOL_F; +#ifdef X11 + /* Check for changed window size */ + gr_events(0); +#endif + return MAKINUM( (long)gr_max_y ); +} /* gr_maxy() */ + +SCM gr_maxc() +{ + if( !gr_grmode_on ) + return BOOL_F; + return MAKINUM( (long)gr_max_color ); +} /* gr_maxc() */ + + +SCM gr_validXYC( x, y, c ) +SCM x, y, c; +{ +int xi, yi, ci; + + ASSERT( NUMBERP(x),x,ARG1,s_gr_validXYC ); + ASSERT( NUMBERP(y),y,ARG2,s_gr_validXYC ); + ASSERT( NUMBERP(c),c,ARG3,s_gr_validXYC ); + if( !gr_grmode_on ) + return BOOL_F; + + if( INUMP(x) ) + xi = (int)(INUM(x)); + else + xi = (int)(REALPART(x)); + + if( INUMP(y) ) + yi = (int)(INUM(y)); + else + yi = (int)(REALPART(y)); + + if( INUMP(c) ) + ci = (int)(INUM(c)); + else + ci = (int)(REALPART(c)); + +/* valid_XYC() calls gr_events() */ + + if( valid_XYC( xi, yi, ci ) ) + return BOOL_T; + else + return BOOL_F; +} /* gr_validXYC() */ + + +SCM gr_grmode() +{ + if( !gr_graphicsavail ) + return BOOL_F; +#ifdef X11 + /* bwuah... but it works :) */ + if( !gr_grmode_on ) { + XMapWindow( gr_display, gr_win ); + gr_typedevent( MapNotify ); + } +#else /* PC version */ + setgraphmode( gr_max_display_mode ); +#endif + gr_grmode_on = 1; + return BOOL_T; +} /* gr_grmode() */ + +SCM gr_txtmode() +{ + if( !gr_graphicsavail ) + return BOOL_F; +#ifdef X11 + /* bwuah... but it works :) */ + if( gr_grmode_on ) { + XUnmapWindow( gr_display, gr_win ); + gr_typedevent( UnmapNotify ); + } +#else /* PC version */ + restorecrtmode(); +#endif + gr_grmode_on = 0; + return BOOL_T; +} /* gr_txtmode() */ + + +SCM gr_cleargraph() +{ + if( !gr_grmode_on ) + return BOOL_F; +#ifdef X11 + XClearWindow( gr_display, gr_win ); + gr_events(0); +#else /* PC version */ + cleardevice(); +#endif + return BOOL_T; +} /* gr_cleargraph() */ + + +SCM gr_setdot( x, y, c ) +SCM x, y, c; +{ +int xi, yi, ci; + + ASSERT( NUMBERP(x),x,ARG1,s_gr_setdot ); + ASSERT( NUMBERP(y),y,ARG2,s_gr_setdot ); + ASSERT( NUMBERP(c),c,ARG3,s_gr_setdot ); + if( !gr_grmode_on ) + return BOOL_F; + + if( INUMP(x) ) + xi = (int)(INUM(x)); + else + xi = (int)(REALPART(x)); + + if( INUMP(y) ) + yi = (int)(INUM(y)); + else + yi = (int)(REALPART(y)); + + if( INUMP(c) ) + ci = (int)(INUM(c)); + else + ci = (int)(REALPART(c)); +#ifdef TESTING + fprintf( stderr, "set-dot! called (%d,%d,%d)\n", xi, yi, ci ); +#endif + if( !valid_XYC( xi, yi, ci ) ) + return BOOL_F; +#ifdef X11 + /* Set the drawing color */ + XSetForeground( gr_display, gr_gc, gr_colortbl[ ci ] ); + XDrawPoint( gr_display, gr_win, gr_gc, xi, yi ); + /* Restore the drawing color */ + XSetForeground( gr_display, gr_gc, gr_colortbl[ gr_color ] ); + gr_events(0); +#else /* PC version */ + putpixel( xi, yi, ci ); +#endif + return BOOL_T; +} /* gr_setdot() */ + + +SCM gr_getdot( x, y ) +SCM x, y; +{ +int xi, yi; +#ifdef X11 +XImage *xim; +XWindowAttributes wattr; +unsigned long dot; +int i; +#endif + ASSERT( NUMBERP(x),x,ARG1,s_gr_getdot ); + ASSERT( NUMBERP(y),y,ARG2,s_gr_getdot ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(x) ) + xi = (int)(INUM(x)); + else + xi = (int)(REALPART(x)); + + if( INUMP(y) ) + yi = (int)(INUM(y)); + else + yi = (int)(REALPART(y)); +#ifdef TESTING + fprintf( stderr, "get-dot called (%d,%d)\n", xi, yi ); +#endif + if( !valid_XYC( xi, yi, 0 ) ) + return BOOL_F; +#ifdef X11 + /* Now, this IS ugly. But it's there if you need it. */ + + /* Have to make sure that the window is mapped. Tough... */ + XGetWindowAttributes( gr_display, gr_win, &wattr ); + if( wattr.map_state == IsUnmapped ) { + XMapWindow( gr_display, gr_win ); + gr_typedevent( MapNotify ); + } + /* I KNOW this sucks. */ + xim = XGetImage( gr_display,gr_win, xi,yi, 1,1, AllPlanes, XYPixmap ); + dot = XGetPixel( xim, 0,0 ); + for( i = 0; i < GR_COLORS; ++i ) { + if( gr_colortbl[i] == dot ) + return MAKINUM( (long)i ); + } + /* This should never happen. There's garbage in the window! */ + fprintf( stderr, "%s: %s: Got an illegal pixel value %lu. \ +Is there garbage?\n", gr_progname, s_gr_getdot, dot ); + return BOOL_F; +#else /* PC version */ + return MAKINUM( (long)getpixel( xi, yi ) ); +#endif +} /* gr_getdot() */ + +SCM gr_draw( S ) +SCM S; +{ +float xf, yf; +float sf; +int ok; + + ASSERT( NUMBERP(S),S,ARG1,s_gr_draw ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(S) ) + sf = (float)(INUM(S)); + else + sf = REALPART(S); +#ifdef TESTING + fprintf( stderr, "draw called (%f)\n", sf ); +#endif + ok = 1; + xf = gr_x + ( COS( gr_dir ) * sf ); + yf = gr_y + ( SIN( gr_dir ) * sf ); + if( (int)xf > gr_max_x ) { + xf = (float)gr_max_x; + ok = 0; + } + else if( xf < 0.0 ) { + xf = 0.0; + ok = 0; + } + if( (int)yf > gr_max_y ) { + yf = (float)gr_max_y; + ok = 0; + } + else if( yf < 0.0 ) { + yf = 0.0; + ok = 0; + } +#ifdef X11 + XDrawLine( gr_display, gr_win, gr_gc, + (int)gr_x,(int)gr_y, + (int)xf,(int)yf ); + gr_events(0); +#else /* PC version */ + line( (int)gr_x,(int)gr_y, (int)xf,(int)yf ); +#endif + gr_x = xf; + gr_y = yf; + if( ok ) + return BOOL_T; + else + return BOOL_F; +} /* gr_draw() */ + + +SCM gr_move( S ) +SCM S; +{ +float xf, yf; +float sf; +int ok; + + ASSERT( NUMBERP(S),S,ARG1,s_gr_move ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(S) ) + sf = (float)(INUM(S)); + else + sf = REALPART(S); +#ifdef TESTING + fprintf( stderr, "move called (%f)\n", sf ); +#endif + ok = 1; + xf = gr_x + ( COS( gr_dir ) * sf ); + yf = gr_y + ( SIN( gr_dir ) * sf ); + + if( (int)xf > gr_max_x ) { + xf = (float)gr_max_x; + ok = 0; + } + else if( xf < 0.0 ) { + xf = 0.0; + ok = 0; + } + if( (int)yf > gr_max_y ) { + yf = (float)gr_max_y; + ok = 0; + } + else if( yf < 0.0 ) { + yf = 0.0; + ok = 0; + } + gr_x = xf; + gr_y = yf; + if( ok ) + return BOOL_T; + else + return BOOL_F; +} /* gr_move() */ + + +SCM gr_drawto( x, y ) +SCM x, y; +{ +int xi, yi; + + ASSERT( NUMBERP(x),x,ARG1,s_gr_drawto ); + ASSERT( NUMBERP(y),y,ARG2,s_gr_drawto ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(x) ) + xi = (int)(INUM(x)); + else + xi = (int)(REALPART(x)); + + if( INUMP(y) ) + yi = (int)(INUM(y)); + else + yi = (int)(REALPART(y)); +#ifdef TESTING + fprintf( stderr, "draw-to called (%d,%d)\n", xi, yi ); +#endif + if( !valid_XYC( xi,yi, 0 ) ) + return BOOL_F; +#ifdef X11 + XDrawLine( gr_display, gr_win, gr_gc, + (int)gr_x,(int)gr_y, xi,yi ); + gr_events(0); +#else /* PC version */ + line( (int)gr_x,(int)gr_y, xi,yi ); +#endif + return BOOL_T; +} /* gr_drawto() */ + + +SCM gr_drawTo( x, y ) +SCM x, y; +{ +float xf, yf; + + ASSERT( NUMBERP(x),x,ARG1,s_gr_drawTo ); + ASSERT( NUMBERP(y),y,ARG2,s_gr_drawTo ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(x) ) + xf = (float)(INUM(x)); + else + xf = (REALPART(x)); + + if( INUMP(y) ) + yf = (float)(INUM(y)); + else + yf = (REALPART(y)); +#ifdef TESTING + fprintf( stderr, "draw-to! called (%d,%d)\n", (int)xf, (int)yf ); +#endif + if( !valid_XYC( (int)xf,(int)yf, 0 ) ) + return BOOL_F; +#ifdef X11 + XDrawLine( gr_display, gr_win, gr_gc, + (int)gr_x,(int)gr_y, + (int)xf,(int)yf ); + gr_events(0); +#else /* PC version */ + line( (int)gr_x,(int)gr_y, (int)xf,(int)yf ); +#endif + gr_x = xf; + gr_y = yf; + return BOOL_T; +} /* gr_drawTo() */ + + +SCM gr_moveTo( x, y ) +SCM x, y; +{ +float xf, yf; + + ASSERT( NUMBERP(x),x,ARG1,s_gr_moveTo ); + ASSERT( NUMBERP(y),y,ARG2,s_gr_moveTo ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(x) ) + xf = (float)(INUM(x)); + else + xf = (REALPART(x)); + + if( INUMP(y) ) + yf = (float)(INUM(y)); + else + yf = (REALPART(y)); +#ifdef TESTING + fprintf( stderr, "move-to! called (%d,%d)\n", (int)xf, (int)yf ); +#endif + if( !valid_XYC( (int)xf,(int)yf, 0 ) ) + return BOOL_F; + gr_x = xf; + gr_y = yf; + return BOOL_T; +} /* gr_moveTo() */ + + +SCM gr_setcolor( c ) +SCM c; +{ +int color; + + ASSERT( NUMBERP(c),c,ARG1,s_gr_setcolor ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(c) ) + color = (int)(INUM(c)); + else + color = (int)(REALPART(c)); +#ifdef TESTING + fprintf( stderr, "set-color! called (%d)\n", color ); +#endif + if( !valid_XYC( 0,0, color ) ) + return BOOL_F; + gr_color = color; +#ifdef X11 + /* Set the drawing color */ + XSetForeground( gr_display, gr_gc, gr_colortbl[ gr_color ] ); + gr_events(0); +#else /* PC version */ + setcolor( gr_color ); +#endif + return BOOL_T; +} /* gr_setcolor() */ + + +SCM gr_turnright( d ) +SCM d; +{ +float df; + + ASSERT( NUMBERP(d),d,ARG1,s_gr_turnright ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(d) ) + df = (float)(INUM(d)); + else + df = REALPART(d); + df = fmod( df, 360.0 ); + gr_dir -= df; + gr_dir = fmod( gr_dir, 360.0 ); + return MAKINUM( (long)(gr_dir+.5) ); +} /* gr_turnright() */ + + +SCM gr_turnleft( d ) +SCM d; +{ +float df; + + ASSERT( NUMBERP(d),d,ARG1,s_gr_turnleft ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(d) ) + df = (float)(INUM(d)); + else + df = REALPART(d); + df = fmod( df, 360.0 ); + gr_dir += df; + gr_dir = fmod( gr_dir, 360.0 ); + return MAKINUM( (long)(gr_dir+.5) ); +} /* gr_turnleft() */ + + +SCM gr_turnto( d ) +SCM d; +{ +float df; + + ASSERT( NUMBERP(d),d,ARG1,s_gr_turnto ); + if( !gr_grmode_on ) + return BOOL_F; + if( INUMP(d) ) + df = (float)(INUM(d)); + else + df = REALPART(d); + df = fmod( df, 360.0 ); + gr_dir = df; + return MAKINUM( (long)(gr_dir+.5) ); +} /* gr_turnto() */ + + +SCM gr_gotohome() +{ + if( !gr_grmode_on ) + return BOOL_F; + gr_x = gr_y = 0.0; + return BOOL_T; +} /* gr_gotohome() */ + + +SCM gr_gotocenter() +{ + if( !gr_grmode_on ) + return BOOL_F; +#ifdef X11 + /* Check for changed window size */ + gr_events(0); +#endif + gr_x = ((float)gr_max_x+1.0) / 2.0; + gr_y = ((float)gr_max_y+1.0) / 2.0; + return BOOL_T; +} /* gr_gotocenter() */ + + +SCM gr_gotonw() +{ + if( !gr_grmode_on ) + return BOOL_F; +#ifdef X11 + /* Check for changed window size */ + gr_events(0); +#endif + gr_x = 0.0; + gr_y = 0.0; + return BOOL_T; +} /* gr_gotonw() */ + + +SCM gr_gotosw() +{ + if( !gr_grmode_on ) + return BOOL_F; +#ifdef X11 + /* Check for changed window size */ + gr_events(0); +#endif + gr_x = 0.0; + gr_y = (float)gr_max_y; + return BOOL_T; +} /* gr_gotosw() */ + + +SCM gr_gotone() +{ + if( !gr_grmode_on ) + return BOOL_F; +#ifdef X11 + /* Check for changed window size */ + gr_events(0); +#endif + gr_x = (float)gr_max_x; + gr_y = 0.0; + return BOOL_T; +} /* gr_gotone() */ + + +SCM gr_gotose() +{ + if( !gr_grmode_on ) + return BOOL_F; +#ifdef X11 + /* Check for changed window size */ + gr_events(0); +#endif + gr_x = (float)gr_max_x; + gr_y = (float)gr_max_y; + return BOOL_T; +} /* gr_gotose() */ + + +SCM gr_whatcolor() +{ + if( !gr_grmode_on ) + return BOOL_F; + return MAKINUM( (long)gr_color ); +} /* gr_whatcolor() */ + + +SCM gr_whatdirection() +{ + if( !gr_grmode_on ) + return BOOL_F; + return MAKINUM( (long)(gr_dir+.5) ); +} /* gr_whatdirection() */ + + +SCM gr_wherex() +{ + if( !gr_grmode_on ) + return BOOL_F; + return MAKINUM( (long)gr_x ); +} /* gr_wherex() */ + + +SCM gr_wherey() +{ + if( !gr_grmode_on ) + return BOOL_F; + return MAKINUM( (long)gr_y ); +} /* gr_wherey() */ + + +static iproc graph0[] = { + { "help-gr", gr_helpgr }, + { "help-turtlegr", gr_helpturtlegr }, + { "graphics-mode!", gr_grmode }, + { "text-mode!", gr_txtmode }, + { "clear-graphics!", gr_cleargraph }, + { "graphics-avail?", gr_available }, + { "max-x", gr_maxx }, + { "max-y", gr_maxy }, + { "max-color", gr_maxc }, + { "what-color", gr_whatcolor }, + { "what-direction", gr_whatdirection }, + { "where-x", gr_wherex }, + { "where-y", gr_wherey }, + { "goto-home!", gr_gotohome }, + { "goto-center!", gr_gotocenter }, + { "goto-nw!", gr_gotonw }, + { "goto-sw!", gr_gotosw }, + { "goto-ne!", gr_gotone }, + { "goto-se!", gr_gotose }, + {0,0} + }; + +static iproc graph1[] = { + { s_gr_draw, gr_draw }, + { s_gr_move, gr_move }, + { s_gr_setcolor, gr_setcolor }, + { s_gr_turnright, gr_turnright }, + { s_gr_turnleft, gr_turnleft }, + { s_gr_turnto, gr_turnto }, + {0,0} + }; + +static iproc graph2[] = { + { s_gr_getdot, gr_getdot }, + { s_gr_drawTo, gr_drawTo }, + { s_gr_drawto, gr_drawto }, + { s_gr_moveTo, gr_moveTo }, + {0,0} + }; + +static iproc graph3[] = { + { s_gr_setdot, gr_setdot }, + { s_gr_validXYC, gr_validXYC }, + {0,0} + }; + +#if defined __STDC__ || defined __TURBOC__ +void close_turtlegr() +{ +#ifdef X11 + gr_events(0); + XFreeColors( gr_display, DefaultColormap(gr_display,gr_screen), + gr_colortbl, GR_COLORS, AllPlanes ); + XFreeGC( gr_display, gr_gc ); + XUnmapWindow( gr_display, gr_win ); + XDestroyWindow( gr_display, gr_win ); +#else /* PC version */ + closegraph(); +#endif +} /* close_turtlegr() */ +#endif + +void init_banner(); /* from scm.c */ + +void init_turtlegr() /* detects if graphics is available; must be + called among program initializations */ +{ +#ifdef X11 + char *display_name = NULL; /* Server to connect to */ + Pixmap icon_pixmap; /* Icon */ + XSizeHints size_hints; /* Preferred sizes */ + XSetWindowAttributes win_attribs; /* Window attributes */ + XWMHints wm_hints; /* Window manager hints */ + XClassHint class_hints; /* Class hints */ + XTextProperty window_name, icon_name; /* Names for Icon & Window */ + XGCValues gc_values; /* Graphics Context values */ + static char *colorname[GR_COLORS] = { + GR_COLOR00, GR_COLOR01, GR_COLOR02, GR_COLOR03, + GR_COLOR04, GR_COLOR05, GR_COLOR06, GR_COLOR07, + GR_COLOR08, GR_COLOR09, GR_COLOR10, GR_COLOR11, + GR_COLOR12, GR_COLOR13, GR_COLOR14, GR_COLOR15 + }; + XColor x_color; /* X11 Color structure */ + unsigned long mask; /* Mask for selections */ + int i; /* loop counter variable */ + +#else /* PC version */ +int errcode; +#endif + +/***************************/ +/* generic initializations */ +/***************************/ + gr_x = gr_y = gr_dir = 0.0; + gr_max_x = gr_max_y = gr_max_color = 0; + + gr_graphicsavail = 0; /* DEFAULT is no graphics - you can do without */ + +/********************************************/ +/***** Initialize X11 turtlegraphics *****/ +/********************************************/ +#ifdef X11 + /* connect to X server */ + if( (gr_display = XOpenDisplay(display_name)) != NULL ) + { + + /*****************************/ + /* connection to X server OK */ + /*****************************/ + + gr_screen = DefaultScreen( gr_display ); /* X screen number */ + + /* Create a window with Black background and border */ + gr_win + = XCreateSimpleWindow( gr_display, + RootWindow( gr_display, gr_screen), + 0, 0, /* initial placement */ + GR_DEF_XSIZE, GR_DEF_YSIZE, + 3, /* border width */ + /* border pixel value */ + BlackPixel(gr_display,gr_screen), + /* background pixel value */ + BlackPixel(gr_display,gr_screen) ); + + /* Select input (events) for the window */ + XSelectInput( gr_display, gr_win, + StructureNotifyMask|ExposureMask ); + + /* Check for backing store capability */ + if( !DoesBackingStore(DefaultScreenOfDisplay(gr_display)) ) + { + fprintf( stderr, "%s: Warning: \ +X server does not offer backing store capability.\n\ +Window cannot be redrawn if obscured. Sorry...\n", gr_progname ); + } + else + { + /* Enable the backing store feature of X server + and set bit gravity */ + win_attribs.bit_gravity = NorthWestGravity; + win_attribs.backing_store = Always; + mask = CWBitGravity | CWBackingStore; + XChangeWindowAttributes( gr_display, gr_win, mask, &win_attribs ); + } + + /* Make names of Window and Icon for window manager */ + if( XStringListToTextProperty(&gr_windowname,1,&window_name) == 0 ) { + (void)fprintf( stderr, "%s: Structure allocation for windowName\ + failed.\n", gr_progname ); + exit( 42 ); + } + if( XStringListToTextProperty(&gr_iconname,1,&icon_name) == 0 ) { + (void)fprintf( stderr, "%s: Structure allocation for iconName\ + failed.\n", gr_progname ); + exit( 42 ); + } + + /* Create the icon */ + icon_pixmap = XCreateBitmapFromData( gr_display, gr_win, turtle_bits, + turtle_width, turtle_height ); + + /* Window size, state, icon etc. hints for the window manager */ + size_hints.flags = PPosition | PMaxSize | PMinSize | USSize; + /* position and desired size are given to XCreateSimpleWindow call */ + size_hints.min_width = GR_MIN_XSIZE; + size_hints.min_height = GR_MIN_YSIZE; + size_hints.max_width = GR_MAX_XSIZE; + size_hints.max_height = GR_MAX_YSIZE; + wm_hints.flags = StateHint | IconPixmapHint | InputHint; + wm_hints.initial_state = NormalState; + wm_hints.input = False; + wm_hints.icon_pixmap = icon_pixmap; + class_hints.res_name = gr_progname; + class_hints.res_class = gr_classname; + XSetWMProperties( gr_display, gr_win, &window_name, &icon_name, + gr_argv, gr_argc, + &size_hints, &wm_hints, &class_hints ); + + + /* Handle colors; this is quite complicated in X11 */ + + if( DefaultDepth( gr_display, gr_screen ) == 1 ) + { + /* Only 1 bitplane, BW screen */ + /* Emulate colors with 0 as Black and 1-15 White */ + gr_colortbl[0] = BlackPixel( gr_display, gr_screen ); + for( i = 1; i < GR_COLORS; ++i ) + gr_colortbl[i] = WhitePixel( gr_display, gr_screen ); +#ifdef TESTING + fprintf( stderr, "%s: 1-plane system, substituting White for \ +colors 1-15.\n", gr_progname ); + fprintf( stderr, "%s: Pixel value is %lu for Black, \ +%lu for White\n", gr_progname, gr_colortbl[0], gr_colortbl[1] ); +#endif + } + else + { + /* more than 1 bitplane */ + for( i = 0; i < GR_COLORS; ++i ) + { + /* Initialize the colortable using named colors */ + if( XParseColor( gr_display, + DefaultColormap(gr_display,gr_screen), + colorname[ i ], &x_color ) ) + { + if( !XAllocColor( gr_display, + DefaultColormap(gr_display,gr_screen), + &x_color ) ) + { + fprintf( stderr, "%s: Can't allocate color \ +\"%s\" (%d). Substituting White.\n", + gr_progname, + colorname[ i ], i ); + gr_colortbl[i] = WhitePixel( gr_display, gr_screen ); + } + else + { + /* succeeded in allocating color */ + gr_colortbl[ i ] = x_color.pixel; +#ifdef TESTING + fprintf( stderr, "%s: Pixel value is %lu for %s.\n", + gr_progname, gr_colortbl[i], colorname[i] ); +#endif + } + } + else + { + /* could not parse color */ + fprintf( stderr, + "%s: Color name \"%s\" (%d) not in database. \ +Substituting White.\n", + gr_progname, colorname[i], i ); + gr_colortbl[i] = WhitePixel( gr_display, gr_screen ); + } + } /* for */ + } /* else */ + gr_max_color = GR_COLORS - 1; + + /* Create and initialize a default GC */ + gr_gc = XCreateGC( gr_display, gr_win, 0L, &gc_values ); + + /* Initialize the drawing color, default's black */ + XSetForeground( gr_display, gr_gc, gr_colortbl[ 0 ] ); + XSetBackground( gr_display, gr_gc, gr_colortbl[ 0 ] ); + gr_color = 0; + + /* OK, we _do_ have graphics available */ + gr_graphicsavail = 1; + +#ifdef __STDC__ + /* Let's do the Right Thing if possible :) */ + atexit( close_turtlegr ); +#endif + } /* if */ + else { + gr_graphicsavail = 0; + } +/********************************************/ +/***** Initialize PC turtlegraphics *****/ +/********************************************/ +#else /* PC version */ + gr_drivernum = DETECT; + + detectgraph( &gr_drivernum, &gr_max_display_mode ); + if( gr_drivernum != grNotDetected ) { + if( !getenv( BGIDIR_ENVSTRING ) ) + fprintf( stderr, + "You really should set the %s environment variable.\n", + BGIDIR_ENVSTRING ); + initgraph( &gr_drivernum, &gr_max_display_mode, + getenv( BGIDIR_ENVSTRING ) ); + errcode = graphresult(); + if( errcode != grOk ) { + fputs( "Graphics error: ", stderr ); + fputs( grapherrormsg( errcode ), stderr ); + exit( EXIT_FAILURE ); + } + moveto( 0,0 ); + gr_x = gr_y = 0.0; + setcolor( 0 ); + gr_color = 0; + gr_max_x = getmaxx(); + gr_max_y = getmaxy(); + gr_max_color = getmaxcolor(); + gr_max_display_mode = getmaxmode(); + restorecrtmode(); + gr_graphicsavail = 1; + atexit( close_turtlegr ); + } + else { + gr_graphicsavail = 0; + } +#endif + +/* generic */ + init_iprocs( graph0, tc7_subr_0 ); + init_iprocs( graph1, tc7_subr_1 ); + init_iprocs( graph2, tc7_subr_2 ); + init_iprocs( graph3, tc7_subr_3 ); + gr_grmode_on = 0; + +#ifndef X11 + /* PC version clears screen so this must be repeated */ + init_banner(); +#endif + + fputs("\nSCM Turtlegraphics Copyright (C) 1992 sjm@cc.tut.fi, jtl@cc.tut.fi\n\ +Type `(help-gr)' or `(help-turtlegr)' for a quick reference of\n\ +the new primitives.\n", stderr); + + if( !gr_graphicsavail ) { +#ifdef X11 + fprintf( stderr, "%s: No X server found. \ +Turtlegraphics not available.\n", gr_progname ); +#else + fputs( "No graphics adapter detected. \ +Turtlegraphics not available.\n", stderr ); +#endif + } + else { +#ifdef X11 + gr_events(0); +#else + ; +#endif + } +} /* init_turtlegr() */ diff --git a/unexalpha.c b/unexalpha.c index 2adfd1f..69db5fd 100644 --- a/unexalpha.c +++ b/unexalpha.c @@ -20,7 +20,15 @@ the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -#include <config.h> +#ifndef emacs +# ifndef __ELF__ + /* Describe layout of the address space in an executing process. */ +# define TEXT_START 0x120000000 +# define DATA_START 0x140000000 +# endif +#else +# include <config.h> +#endif #include <sys/types.h> #include <sys/file.h> #include <sys/stat.h> @@ -93,7 +101,7 @@ struct headers { /* Define name of label for entry point for the dumped executable. */ #ifndef DEFAULT_ENTRY_ADDRESS -#define DEFAULT_ENTRY_ADDRESS __start +# define DEFAULT_ENTRY_ADDRESS __start #endif unexec (new_name, a_name, data_start, bss_start, entry_address) @@ -194,10 +202,10 @@ unexec (new_name, a_name, data_start, bss_start, entry_address) #endif #ifdef _PDATA CHECK_SCNHDR (pdata_section, _PDATA, STYP_PDATA); -#endif _PDATA +#endif /* _PDATA */ #ifdef _GOT CHECK_SCNHDR (got_section, _GOT, STYP_GOT); -#endif _GOT +#endif /* _GOT */ CHECK_SCNHDR (data_section, _DATA, STYP_DATA); #ifdef _XDATA CHECK_SCNHDR (xdata_section, _XDATA, STYP_XDATA); @@ -315,7 +323,7 @@ unexec (new_name, a_name, data_start, bss_start, entry_address) "writing data section to %s", new_name); #ifdef _GOT -#define old_got_section ((struct scnhdr *)buffer) +# define old_got_section ((struct scnhdr *)buffer) if (got_section != NULL) { @@ -327,7 +335,7 @@ unexec (new_name, a_name, data_start, bss_start, entry_address) "seeking to end of data section of %s", new_name); } -#undef old_got_section +# undef old_got_section #endif /* @@ -408,10 +416,10 @@ update_dynamic_symbols (old, new_name, new, aout) x = ds_base[rd_base[i].index]; -#if 0 +# if 0 fprintf (stderr, "Object inspected: %s, addr = %lx, shndx = %x", old + dynstr_section->s_scnptr + x.st_name, rd_base[i].addr, x.st_shndx); -#endif +# endif if ((ELF32_ST_BIND (x.st_info) == STB_GLOBAL) @@ -433,13 +441,13 @@ update_dynamic_symbols (old, new_name, new, aout) unsigned long newref = aout.tsize + reladdr; int len; -#if 0 +# if 0 fprintf (stderr, "...relocated\n"); -#endif +# endif - if (rd_base[i].type == R_REFLONG) + if (rd_base[i].type == R_REFLONG) len = 4; - else if (rd_base[i].type == R_REFQUAD) + else if (rd_base[i].type == R_REFQUAD) len = 8; else fatal_unexec ("unrecognized relocation type in .dyn.rel section (symbol #%d)", i); @@ -448,10 +456,10 @@ update_dynamic_symbols (old, new_name, new, aout) WRITE (new, oldref, len, "writing old dynrel info in %s", new_name); } -#if 0 +# if 0 else fprintf (stderr, "...not relocated\n"); -#endif +# endif } @@ -522,7 +522,7 @@ unexec (new_name, old_name, data_start, bss_start, entry_address) Elf32_Off new_data2_offset; Elf32_Addr new_data2_addr; - int n, nn, old_bss_index, old_data_index, new_data2_index; + int n, nn, old_bss_index, old_data_index; struct stat stat_buf; /* Open the old file & map it into the address space. */ @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -61,7 +61,6 @@ complex double cvect #endif long tc16_array = 0; -static SCM i_short; char s_resizuve[] = "vector-set-length!"; SCM resizuve(vect, len) @@ -112,7 +111,7 @@ SCM resizuve(vect, len) siz = l * sz; if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve); DEFER_INTS; - must_realloc_cell(vect, (long)ol*sz, (long)siz, s_resizuve); + must_realloc_cell(vect, ol*sz, (long)siz, s_resizuve); if VECTORP(vect) while(l > ol) VELTS(vect)[--l] = UNSPECIFIED; @@ -149,34 +148,22 @@ long scm_prot2type(prot) { if (BOOL_T==prot) return tc7_bvect; if ICHRP(prot) return tc7_string; - if INUMP(prot) - return INUM(prot)>0 ? tc7_uvect : tc7_ivect; - if (i_short==prot) return tc7_svect; + if (MAKINUM(32L)==prot) return tc7_uvect; + if (MAKINUM(-32L)==prot) return tc7_ivect; + if (MAKINUM(-16L)==prot) return tc7_svect; + if INUMP(prot) return INUM(prot) > 0 ? tc7_uvect : tc7_ivect; if IMP(prot) return tc7_vector; # ifdef FLOATS if INEXP(prot) { double x; - float fx; if CPLXP(prot) return tc7_cvect; x = REALPART(prot); - fx = x; - return (x == fx) ? tc7_fvect : tc7_dvect; - } -# endif -# ifdef BIGDIG - if (TYP16(prot)==tc16_bigpos) { - if (DIGSPERLONG < NUMDIGS(prot)) return tc7_vector; - return tc7_uvect; - } - if (TYP16(prot)==tc16_bigneg) { - long res = 0; - sizet l = NUMDIGS(prot); - if (DIGSPERLONG < l) return tc7_vector; - for(;l--;) res = BIGUP(res) + BDIGITS(prot)[l]; - if (0>=res) return tc7_vector; - return tc7_ivect; + if (32.0==x) return tc7_fvect; + if (64.0==x) return tc7_dvect; + return tc7_dvect; } # endif + return tc7_vector; } SCM make_uve(k, prot) @@ -216,34 +203,21 @@ SCM make_uve(k, prot) } DEFER_INTS; v = must_malloc_cell((i ? i : 1L), - MAKE_LENGTH((k<LENGTH_MAX ? k : LENGTH_MAX), type), + MAKE_LENGTH((k < LENGTH_MAX ? k : LENGTH_MAX), type), s_vector); if (tc7_string==type) CHARS(v)[k] = 0; ALLOW_INTS; return v; } -static char s_uve_len[] = "uniform-vector-length"; -SCM uve_len(v) - SCM v; -{ - ASRTGO(NIMP(v), badarg1); - switch TYP7(v) { - default: badarg1: wta(v, (char *)ARG1, s_uve_len); - case tc7_vector: - case tcs_uves: - return MAKINUM(LENGTH(v)); - } -} - SCM arrayp(v, prot) SCM v, prot; { int enclosed = 0; long typ; if IMP(v) return BOOL_F; - typ = TYP7(v); loop: + typ = TYP7(v); switch (typ) { case tc7_smob: if (!ARRAYP(v)) return BOOL_F; if (UNBNDP(prot)) return BOOL_T; @@ -866,7 +840,7 @@ SCM aref(v, args) int k = ARRAY_NDIM(v); SCM res = make_ra(k); if (!ARRAYP(v)) { - ASRTGO(NULLP(args),badarg); + ASRTGO(NULLP(args), badarg); return v; } ARRAY_V(res) = ARRAY_V(v); @@ -1125,7 +1099,7 @@ SCM uve_read(v, port) long sz, len, ans; long start=0; if UNBNDP(port) port = cur_inp; - else ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd); + ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd); ASRTGO(NIMP(v), badarg1); len = LENGTH(v); loop: @@ -1190,7 +1164,7 @@ SCM uve_write(v, port) long sz, len, ans; long start=0; if UNBNDP(port) port = cur_outp; - else ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr); + ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr); ASRTGO(NIMP(v), badarg1); len = LENGTH(v); loop: @@ -1233,7 +1207,7 @@ SCM uve_write(v, port) break; # endif } - SYSCALL(ans = fwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port));); + ans = lfwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, port); if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; return MAKINUM(ans); } @@ -1299,7 +1273,7 @@ SCM lcount(item, seq) } } static char s_uve_pos[] = "bit-position"; -SCM position(item, v, k) +SCM bit_position(item, v, k) SCM item, v, k; { long i, len, lenw, xbits, pos = INUM(k), offset = 0; @@ -1669,10 +1643,9 @@ SCM list2ura(ndim, prot, lst) SCM shp=EOL; SCM row=lst; SCM ra; - sizet k; long n; + sizet k = INUM(ndim); ASSERT(INUMP(ndim), ndim, ARG1, s_list2ura); - k = INUM(ndim); for (; k--; NIMP(row) && (row = CAR(row))) { n = ilength(row); ASSERT(n>=0, lst, ARG2, s_list2ura); @@ -1879,18 +1852,18 @@ int raprin1(exp, port, writing) case tc7_string: lputs("A\\", port); break; case tc7_uvect: - lputs("Au", port); break; + lputs("Au32", port); break; case tc7_ivect: - lputs("Ae", port); break; + lputs("As32", port); break; case tc7_svect: - lputs("Aes", port); break; + lputs("As16", port); break; # ifdef FLOATS case tc7_fvect: - lputs("Aif", port); break; + lputs("Ar32", port); break; case tc7_dvect: - lputs("Ai", port); break; + lputs("Ar64", port); break; case tc7_cvect: - lputs("Aic", port); break; + lputs("Ac64", port); break; # endif /*FLOATS*/ } if ((v != exp) && 0==ARRAY_NDIM(exp)) { @@ -1921,13 +1894,13 @@ SCM array_prot(ra) case tc7_vector: return EOL; case tc7_bvect: return BOOL_T; case tc7_string: return MAKICHR('a'); - case tc7_svect: return i_short; - case tc7_uvect: return MAKINUM(1L); - case tc7_ivect: return MAKINUM(-1L); + case tc7_uvect: return MAKINUM(32L); + case tc7_ivect: return MAKINUM(-32L); + case tc7_svect: return MAKINUM(-16L); # ifdef FLOATS - case tc7_fvect: return makflo(1.0); - case tc7_dvect: return makdbl(1.0/3.0, 0.0); - case tc7_cvect: return makdbl(0.0, 1.0); + case tc7_fvect: return makflo(32.0); + case tc7_dvect: return makdbl(64.0, 0.0); + case tc7_cvect: return makdbl(0.0, 64.0); # endif } } @@ -2007,23 +1980,21 @@ SCM scm_logaset(ra, obj, args) else if (BOOL_F==obj) obj = INUMP(oval) ? MAKINUM(INUM(oval) & (~(1<<INUM(ibit)))) : scm_logand(oval, MAKINUM(~(1<<INUM(ibit)))); -#ifndef RECKLESS +# ifndef RECKLESS else wta(obj, (char *)ARG2, s_logaset); -#endif +# endif } return aset(ra, obj, inds); } static iproc subr3s[] = { - {"uniform-vector-set1!", aset}, - {s_uve_pos, position}, + {s_uve_pos, bit_position}, {s_bit_set, bit_set}, {s_bit_count, bit_count}, {s_list2ura, list2ura}, {0, 0}}; static iproc subr2s[] = { - {"uniform-vector-ref", aref}, {s_resizuve, resizuve}, {s_count, lcount}, {s_uve_fill, uve_fill}, @@ -2033,7 +2004,6 @@ static iproc subr1s[] = { {"array-rank", array_rank}, {s_array_dims, array_dims}, {s_array2list, array2list}, - {s_uve_len, uve_len}, {s_bit_inv, bit_inv}, {s_strdown, strdown}, {s_strcap, strcap}, @@ -2059,8 +2029,6 @@ static iproc lsubr2s[] = { static iproc subr2os[] = { {"array?", arrayp}, {s_array_contents, array_contents}, - {s_uve_rd, uve_read}, - {s_uve_wr, uve_write}, {0, 0}}; static SCM markra(ptr) @@ -2071,7 +2039,8 @@ static SCM markra(ptr) static sizet freera(ptr) CELLPTR ptr; { - must_free(CHARS(ptr), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim)); + must_free(CHARS((SCM)ptr), + sizeof(array) + ARRAY_NDIM((SCM)ptr)*sizeof(array_dim)); return 0; } static smobfuns rasmob = {markra, freera, raprin1, 0}; @@ -2087,9 +2056,7 @@ void init_unif() init_iprocs(lsubr2s, tc7_lsubr_2); init_iprocs(subr2os, tc7_subr_2o); tc16_array = newsmob(&rasmob); - i_short = CAR(sysintern("exact-short", UNDEFINED)); add_feature(s_array); - add_feature("string-case"); } #else /* ARRAYS */ @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -49,8 +49,15 @@ /* #include <sys/wait.h> */ #include <sys/stat.h> +extern SCM stat2scm P((struct stat *stat_temp)); -SCM stat2scm P((struct stat *stat_temp)); +SCM scm_mknod P((SCM path, SCM mode, SCM dev)); +SCM scm_acct P((SCM path)); +SCM scm_nice P((SCM incr)); +SCM scm_sync P((void)); +SCM scm_symlink P((SCM oldpath, SCM newpath)); +SCM scm_readlink P((SCM path)); +SCM scm_lstat P((SCM str)); #ifndef STDC_HEADERS void sync P((void)); @@ -62,13 +69,16 @@ SCM stat2scm P((struct stat *stat_temp)); # ifdef SVR4 # include <unistd.h> # endif +# ifdef __OpenBSD__ +# include <unistd.h> +# endif #endif /* STDC_HEADERS */ /* Only the superuser can successfully execute mknod and acct */ /* int mknod P((const char *path, mode_t mode, dev_t dev)); should be in stat.h */ static char s_mknod[] = "mknod"; -SCM l_mknod(path, mode, dev) +SCM scm_mknod(path, mode, dev) SCM path, mode, dev; { int val; @@ -79,7 +89,7 @@ SCM l_mknod(path, mode, dev) return val ? BOOL_F : BOOL_T; } static char s_acct[] = "acct"; -SCM l_acct(path) +SCM scm_acct(path) SCM path; { int val; @@ -93,21 +103,21 @@ SCM l_acct(path) } static char s_nice[] = "nice"; -SCM l_nice(incr) +SCM scm_nice(incr) SCM incr; { ASSERT(INUMP(incr), incr, ARG1, s_nice); return nice(INUM(incr)) ? BOOL_F : BOOL_T; } -SCM l_sync() +SCM scm_sync() { sync(); return UNSPECIFIED; } static char s_symlink[] = "symlink"; -SCM l_symlink(oldpath, newpath) +SCM scm_symlink(oldpath, newpath) SCM oldpath, newpath; { int val; @@ -117,7 +127,7 @@ SCM l_symlink(oldpath, newpath) return val ? BOOL_F : BOOL_T; } static char s_readlink[] = "readlink"; -SCM l_readlink(path) +SCM scm_readlink(path) SCM path; { int i; @@ -128,7 +138,7 @@ SCM l_readlink(path) return makfromstr(buf, (sizet)i); } static char s_lstat[] = "lstat"; -SCM l_lstat(str) +SCM scm_lstat(str) SCM str; { int i; @@ -140,17 +150,17 @@ SCM l_lstat(str) } static iproc subr1s[] = { - {s_nice, l_nice}, - {s_acct, l_acct}, - {s_lstat, l_lstat}, - {s_readlink, l_readlink}, + {s_nice, scm_nice}, + {s_acct, scm_acct}, + {s_lstat, scm_lstat}, + {s_readlink, scm_readlink}, {0, 0}}; void init_unix() { - make_subr("sync", tc7_subr_0, l_sync); + make_subr("sync", tc7_subr_0, scm_sync); init_iprocs(subr1s, tc7_subr_1); - make_subr(s_symlink, tc7_subr_2, l_symlink); - make_subr(s_mknod, tc7_subr_3, l_mknod); + make_subr(s_symlink, tc7_subr_2, scm_symlink); + make_subr(s_mknod, tc7_subr_3, scm_mknod); add_feature("unix"); } diff --git a/version.txi b/version.txi index b5a0148..4bfee47 100644 --- a/version.txi +++ b/version.txi @@ -1,2 +1,2 @@ -@set SCMVERSION 5d0 -@set SCMDATE January 1999 +@set SCMVERSION 5d6 +@set SCMDATE May 2002 @@ -15,26 +15,26 @@ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -57,7 +57,10 @@ #include <stdio.h> #include <X11/X.h> #include <X11/Xlib.h> +#include <X11/Xcms.h> +/*#include <X11/Xcmsint.h>*/ /* For IntensityTbl */ #include <X11/Xutil.h> +#include <X11/Xatom.h> #include "scm.h" @@ -150,9 +153,12 @@ struct display_screen{ #define XCOLORMAP(x) (COLORMAP(x)->cm) #define XGCONDISPLAY(x) (GCONTEXT(x)->dpy) -/* Notice that types Visual and XEvent don't have struct wrappers. */ +/* Notice that types XVisualInfo, XcmsCCC, and XEvent don't have + struct wrappers. */ -#define XVISUAL(x) ((Visual *) CDR(x)) +#define XVISUALINFO(x) ((XVisualInfo *) CDR(x)) +#define XVISUAL(x) (XVISUALINFO(x)->visual) +#define XCCC(x) ((XcmsCCC) CDR(x)) #define XEVENT(x) ((XEvent *) CDR(x)) /* Type predicates */ @@ -163,6 +169,7 @@ struct display_screen{ #define OPWINDOWP(x) (((0xffff | OPN) & (int)CAR(x))==(tc16_xwindow | OPN)) #define COLORMAPP(x) (TYP16(x)==tc16_xcolormap) #define GCONTEXTP(x) (TYP16(x)==tc16_xgcontext) +#define CCCP(x) (TYP16(x)==tc16_xccc) #define CURSORP(x) (TYP16(x)==tc16_xcursor) #define FONTP(x) (TYP16(x)==tc16_xfont) #define VISUALP(x) (TYP16(x)==tc16_xvisual) @@ -178,13 +185,16 @@ static char s_x_root_window[] = "x:root-window"; static char s_x_default_gcontext[] = "x:default-gc"; static char s_x_default_visual[] = "x:default-visual"; static char s_x_default_colormap[] = "x:default-colormap"; +static char s_x_default_ccc[] = "x:default-ccc"; +/* static char s_x_ccc_screen_info[] = "x:ccc-screen-info"; */ static char s_x_create_window[] = "x:create-window"; static char s_x_window_set[] = "x:window-set!"; -/* static char s_x_window_ref[] = "x:window-ref"; */ +static char s_x_window_ref[] = "x:window-ref"; static char s_x_create_pixmap[] = "x:create-pixmap"; +static char s_x_get_window_property[] = "x:get-window-property"; +static char s_x_list_properties[] = "x:list-properties"; static char s_x_map_window[] = "x:map-window"; -static char s_x_map_raised[] = "x:map-raised"; static char s_x_map_subwindows[] = "x:map-subwindows"; static char s_x_unmap_window[] = "x:unmap-window"; static char s_x_unmap_subwindows[] = "x:unmap-subwindows"; @@ -215,7 +225,10 @@ static char s_x_screen_dimm[] = "x:screen-dimensions"; static char s_x_screen_white[] = "x:screen-white"; static char s_x_screen_black[] = "x:screen-black"; static char s_x_make_visual[] = "x:make-visual"; +static char s_x_visual_class[] = "x:visual-class"; +static char s_x_visual_geometry[] = "x:visual-geometry"; static char s_x_window_geometry[] = "x:window-geometry"; +static char s_x_window_geometry_set[] = "x:window-geometry-set!"; static char s_x_create_colormap[] = "x:create-colormap"; static char s_x_recreate_colormap[] = "x:copy-colormap-and-free"; @@ -225,6 +238,8 @@ static char s_x_find_color[] = "x:colormap-find-color"; static char s_x_color_set[] = "x:colormap-set!"; static char s_x_color_ref[] = "x:colormap-ref"; static char s_x_install_colormap[] = "x:install-colormap"; +/* static char s_x_colormap_basis[] = "x:colormap-basis"; */ +/* static char s_x_colormap_limits[] = "x:colormap-limits"; */ static char s_x_clear_area[] = "x:clear-area"; static char s_x_fill_rectangle[] = "x:fill-rectangle"; @@ -238,6 +253,7 @@ static char s_x_image_string[] = "x:image-string"; static char s_x_flush[] = "x:flush"; static char s_x_event_ref[] = "x:event-ref"; +static char s_x_event_keysym[] = "x:event->keysym"; /* Type-name strings */ @@ -247,6 +263,7 @@ static char s_gc[] = "graphics-context"; #define s_cursor (&s_x_create_cursor[9]) #define s_font (&s_x_load_font[7]) #define s_colormap (&s_x_create_colormap[9]) +#define s_visual (&s_x_make_visual[7]) /* Scheme (SMOB) types defined in this module */ @@ -258,6 +275,8 @@ long tc16_xcursor; long tc16_xfont; long tc16_xvisual; long tc16_xevent; +long tc16_xccc; +XContext xtc_ccc, xtc_cmp; /* We use OPN (which is already defined and used for PTOB ports) to keep track of whether objects of types Display and Window are open. @@ -327,6 +346,9 @@ SCM make_xcolormap(sdpy, cmp) { SCM z; struct xs_Colormap *xcm; + XPointer scmptr; + if (!XFindContext(XDISPLAY(sdpy), (XID)cmp, xtc_cmp, &scmptr)) + return (SCM)scmptr; DEFER_INTS; z = must_malloc_cell((long)sizeof(struct xs_Colormap), (SCM)tc16_xcolormap, @@ -335,14 +357,18 @@ SCM make_xcolormap(sdpy, cmp) xcm->display = sdpy; xcm->dpy = DISPLAY(xcm->display)->dpy; xcm->cm = cmp; + XSaveContext(XDISPLAY(sdpy), (XID)cmp, xtc_cmp, z); ALLOW_INTS; return z; } static SCM mark_xcolormap(ptr) SCM ptr; { + struct xs_Colormap *xcm; if CLOSEDP(ptr) return BOOL_F; - return COLORMAP(ptr)->display; + xcm = COLORMAP(ptr); + gc_mark(CCC2SCM_P(XcmsCCCOfColormap(xcm->dpy, xcm->cm))); + return xcm->display; } static sizet free_xcolormap(ptr) CELLPTR ptr; @@ -385,10 +411,10 @@ SCM make_xdisplay(d) make_xwindow(z, idx, RootWindow(d, idx), (char) 0, (char) 1); scrns[idx].default_gcontext = make_xgcontext(z, idx, XDefaultGC(d, idx), !0); + scrns[idx].default_visual = + make_xvisual(visual2visualinfo(d, DefaultVisual(d, idx))); scrns[idx].default_colormap = make_xcolormap(z, DefaultColormap(d, idx)); - scrns[idx].default_visual = - make_xvisual(DefaultVisual(d, idx)); } return z; } @@ -401,10 +427,12 @@ static SCM mark_xdisplay(ptr) struct xs_screen *scrns = (struct xs_screen *)(xsd + 1); int idx = xsd->screen_count; while (--idx) { + SCM scmp = scrns[idx].default_colormap; gc_mark(scrns[idx].root_window); gc_mark(scrns[idx].default_gcontext); gc_mark(scrns[idx].default_visual); - gc_mark(scrns[idx].default_colormap); + gc_mark(scmp); + gc_mark (CCC2SCM_P(XcmsCCCOfColormap(xsd->dpy, XCOLORMAP(scmp)))); } gc_mark(scrns[idx].root_window); gc_mark(scrns[idx].default_gcontext); @@ -549,7 +577,7 @@ static sizet free_xfont(ptr) } SCM make_xvisual(vsl) - Visual *vsl; + XVisualInfo *vsl; { SCM s_vsl; NEWCELL(s_vsl); @@ -560,6 +588,37 @@ SCM make_xvisual(vsl) return s_vsl; } +SCM CCC2SCM_P(ccc) + XcmsCCC ccc; +{ + XPointer scmptr; + if (XFindContext(ccc->dpy, (XID)ccc, xtc_ccc, &scmptr)) + return BOOL_F; + return (SCM)scmptr; +} +SCM CCC2SCM(ccc) + XcmsCCC ccc; +{ + SCM s_ccc = CCC2SCM_P(ccc); + if FALSEP(s_ccc) { + NEWCELL(s_ccc); + DEFER_INTS; + CAR(s_ccc) = tc16_xccc; + SETCDR(s_ccc, ccc); + XSaveContext(ccc->dpy, (XID)ccc, xtc_ccc, s_ccc); + ALLOW_INTS; + } + return s_ccc; +} +static sizet free_xccc(ptr) + CELLPTR ptr; +{ + XcmsCCC ccc = XCCC((SCM)ptr); + XDeleteContext(ccc->dpy, (XID)ccc, xtc_ccc); + XcmsFreeCCC(ccc); + return 0; +} + SCM make_xevent(e) XEvent *e; { @@ -571,7 +630,7 @@ XEvent *e; NEWCELL(w); DEFER_INTS; CAR(w) = tc16_xevent; - SETCDR(w,ec); + SETCDR(w, ec); ALLOW_INTS; return w; } @@ -683,7 +742,7 @@ int scm2xpointslen(sara, s_caller) && (1==adm[1].inc) && ARRAY_CONTP(sara) && (tc7_svect==TYP7(ARRAY_V(sara))))) return -1; - len = adm[0].ubnd - adm[0].lbnd; + len = 1 + adm[0].ubnd - adm[0].lbnd; if (len < 0) return 0; return len; } @@ -719,7 +778,7 @@ SCM thevalue(obj) SCM obj; { if (NIMP(obj) && SYMBOLP(obj)) - return ceval(obj, (SCM)EOL); + return ceval(obj, (SCM)EOL, (SCM)EOL); else return obj; } @@ -780,15 +839,16 @@ int theuint(obj, s_caller) return INUM(val); } -static int args2xgcvalmask(oargs) +static int args2valmask(oargs, s_caller) SCM oargs; + char *s_caller; { SCM args = oargs; int attr, len, attr_mask = 0; if (!(len = ilength(args))) return 0; while (len) { - ASSERT(NIMP(args), oargs, WNA, s_gc); - attr = theint(CAR(args), s_gc); args = CDR(args); + ASSERT(NIMP(args), oargs, WNA, s_caller); + attr = theint(CAR(args), s_caller); args = CDR(args); attr_mask |= attr; len -= 1; } @@ -904,6 +964,36 @@ static int args2winattribs(vlu, oargs) } return attr_mask; } +static int args2wincfgs(vlu, oargs) + XWindowChanges *vlu; + SCM oargs; +{ + SCM sval, args = oargs; + int cfgs, len, cfgs_mask = 0; + /* (void)memset((char *)vlu, 0, sizeof(XWindowChanges)); */ + if (!(len = ilength(args))) return 0; + ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_window); + while (len) { + ASSERT(NIMP(args), oargs, WNA, s_window); + cfgs = theint(CAR(args), s_window); args = CDR(args); + ASSERT(NIMP(args), oargs, WNA, s_window); + sval = CAR(args); args = CDR(args); + cfgs_mask |= cfgs; + switch (cfgs) { + + case CWX: vlu->x = theuint(sval, s_window); break; + case CWY: vlu->y = theuint(sval, s_window); break; + case CWWidth: vlu->width = theuint(sval, s_window); break; + case CWHeight: vlu->height = theuint(sval, s_window); break; + case CWBorderWidth: vlu->border_width = theuint(sval, s_window); break; + case CWSibling: vlu->sibling =thepxmap(sval, s_window); break; + case CWStackMode: vlu->stack_mode = theint(sval, s_window); break; + default: ASSERT(0, MAKINUM(cfgs), ARGn, s_window); + } + len -= 2; + } + return cfgs_mask; +} /* Scheme-visible procedures */ @@ -1012,6 +1102,47 @@ SCM x_create_pixmap(obj, s_size, s_depth) p = XCreatePixmap(dpy, drawable, size.x, size.y, depth); return make_xwindow(display, scn, p, (char) 1, (char) 0); } +SCM x_window_ref(oargs) + SCM oargs; +{ + SCM swn, args = oargs, sval = BOOL_F; + SCM vals = cons(BOOL_T, EOL), valend = vals; + struct xs_Window *xwn; + XWindowAttributes vlu; + int attr, len = ilength(args); + /* (void)memset((char *)&vlu, 0, sizeof(XWindowAttributes)); */ + ASSERT(len > 0, oargs, WNA, s_x_window_ref); + if (1==len--) return EOL; + swn = CAR(args); args = CDR(args); + ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_ref); + xwn = WINDOW(swn); + if (!XGetWindowAttributes(xwn->dpy, xwn->p.win, &vlu)) return BOOL_F; + while (len) { + attr = theint(CAR(args), s_x_window_ref); args = CDR(args); + switch (attr) { + + case CWBackPixel: sval = MAKINUM(vlu.backing_pixel); break; + case CWBitGravity: sval = MAKINUM(vlu.bit_gravity); break; + case CWWinGravity: sval = MAKINUM(vlu.win_gravity); break; + case CWBackingStore: sval = MAKINUM(vlu.backing_store); break; + case CWBackingPlanes:sval = MAKINUM(vlu.backing_planes); break; + case CWBackingPixel: sval = MAKINUM(vlu.backing_pixel); break; + case CWOverrideRedirect:sval = x_make_bool(vlu.override_redirect); break; + case CWSaveUnder: sval = x_make_bool(vlu.save_under); break; + case CWEventMask: sval = MAKINUM(vlu.your_event_mask); break; + case CWDontPropagate:sval = MAKINUM(vlu.do_not_propagate_mask); break; + case CWColormap: sval = make_xcolormap(xwn->display, vlu.colormap); break; + + default: ASSERT(0, MAKINUM(attr), ARGn, s_x_window_ref); + } + CAR(valend) = sval; + CDR(valend) = cons(BOOL_T, EOL); + len -= 1; + if (len) valend = CDR(valend); + else CDR(valend) = EOL; + } + return vals; +} SCM x_window_set(args) SCM args; { @@ -1047,6 +1178,22 @@ SCM x_window_geometry(swin) cons2(MAKINUM(w), MAKINUM(h), EOL), cons2(MAKINUM(border_width), MAKINUM(depth), EOL)); } +SCM x_window_geometry_set(args) + SCM args; +{ + SCM swn; + struct xs_Window *xwn; + XWindowChanges vlu; + unsigned long mask; + + ASSERT(NIMP(args), args, WNA, s_x_window_geometry_set); + swn = CAR(args); args = CDR(args); + ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_geometry_set); + xwn = WINDOW(swn); + mask = args2wincfgs(&vlu, args); + XConfigureWindow(xwn->dpy, xwn->p.win, mask, &vlu); + return UNSPECIFIED; +} SCM x_close(obj) SCM obj; @@ -1121,6 +1268,25 @@ SCM x_install_colormap(s_cm, s_flg) XInstallColormap(XDISPLAY(xcm->display), xcm->cm); return UNSPECIFIED; } +/* SCM x_colormap_basis(svsl) */ +/* SCM svsl; */ +/* { */ +/* XColormapInfo *vsl; */ +/* ASSERT(NIMP(svsl) && COLORMAPP(svsl), svsl, ARG1, s_x_colormap_basis); */ +/* vsl = XCOLORMAPINFO(svsl); */ +/* return cons2(vsl->red_mult, vsl->green_mult, */ +/* cons2(vsl->blue_mult, vsl->base_pixel, EOL)); */ +/* } */ +/* SCM x_colormap_limits(svsl) */ +/* SCM svsl; */ +/* { */ +/* XColormapInfo *vsl; */ +/* ASSERT(NIMP(svsl) && COLORMAPP(svsl), svsl, ARG1, s_x_colormap_limits); */ +/* vsl = XCOLORMAPINFO(svsl); */ +/* return cons2(vsl->red_mult, vsl->green_mult, */ +/* cons2(vsl->blue_mult, vsl->base_pixel, EOL)); */ +/* } */ + /* Colors in Colormap */ SCM x_alloc_color_cells(scmap, spxls, sargs) @@ -1246,15 +1412,6 @@ SCM x_map_window(swin) XMapWindow(w->dpy, w->p.win); return UNSPECIFIED; } -SCM x_map_raised(swin) - SCM swin; -{ - struct xs_Window *w; - ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_raised); - w = WINDOW(swin); - XMapRaised(w->dpy, w->p.win); - return UNSPECIFIED; -} SCM x_map_subwindows(swin) SCM swin; { @@ -1332,7 +1489,7 @@ SCM x_copy_gc(dst, src, args) ASSERT(NIMP(src) && GCONTEXTP(src), src, ARG2, s_x_copy_gc); dgc = GCONTEXT(dst); sgc = GCONTEXT(src); - mask = args2xgcvalmask(args); + mask = args2valmask(args, s_gc); XCopyGC(dgc->dpy, sgc->gc, mask, dgc->gc); return UNSPECIFIED; } @@ -1349,8 +1506,9 @@ SCM x_gc_ref(oargs) ASSERT(len > 0, oargs, WNA, s_x_gc_ref); if (1==len--) return EOL; sgc = CAR(args); args = CDR(args); + ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG1, s_x_gc_ref); xgc = GCONTEXT(sgc); - valuemask = args2xgcvalmask(args); + valuemask = args2valmask(args, s_gc); /* printf("valuemask = %lx\n", valuemask); */ valuemask &= (GCFunction | GCPlaneMask | GCForeground | GCBackground | GCLineWidth | GCLineStyle | GCCapStyle | GCJoinStyle | @@ -1399,8 +1557,9 @@ SCM x_gc_ref(oargs) } CAR(valend) = sval; CDR(valend) = cons(BOOL_T, EOL); - valend = CDR(valend); len -= 1; + if (len) valend = CDR(valend); + else CDR(valend) = EOL; } return vals; } @@ -1575,6 +1734,8 @@ SCM x_screen_depth(sd, si) SCM sd, si; { struct display_screen dspscn; + if (UNBNDP(si) && NIMP(sd) && VISUALP(sd)) + return MAKINUM(XVISUALINFO(sd)->depth); scm2display_screen(sd, si, &dspscn, s_x_screen_depth); return MAKINUM(DisplayPlanes(dspscn.dpy, dspscn.screen_number)); } @@ -1630,20 +1791,65 @@ SCM x_screen_white(sd, si) return ulong2num(WhitePixelOfScreen(scn)); } +XVisualInfo *visual2visualinfo(dsp, vis) + Display *dsp; + Visual *vis; +{ + int nitems_return; + XVisualInfo vinfo_template; + XVisualInfo *vislst; + vinfo_template.visualid = XVisualIDFromVisual(vis); + vislst = XGetVisualInfo(dsp, VisualIDMask, &vinfo_template, &nitems_return); + if (1 != nitems_return) { + if (vislst) XFree(vislst); + wta(MAKINUM(nitems_return), (char *)WNA, s_visual); + } + return vislst; +} SCM x_make_visual(sd, sdepth, sclass) SCM sd, sdepth, sclass; { + int nitems_return; struct display_screen dspscn; - XVisualInfo vis; - Status sts; + XVisualInfo vinfo_template; + XVisualInfo *vislst; scm2display_screen(sd, UNDEFINED, &dspscn, s_x_make_visual); - sts = XMatchVisualInfo(dspscn.dpy, dspscn.screen_number, - theuint(sdepth, s_x_make_visual), - theuint(sclass, s_x_make_visual), - &vis); - if (!sts) return BOOL_F; - return make_xvisual(vis.visual); + vinfo_template.screen = dspscn.screen_number; + vinfo_template.depth = theuint(sdepth, s_x_make_visual); + vinfo_template.class = theuint(sclass, s_x_make_visual); + vislst = + XGetVisualInfo(dspscn.dpy, + VisualScreenMask | VisualDepthMask | VisualClassMask, + &vinfo_template, + &nitems_return); + if (0==nitems_return) return BOOL_F; + return make_xvisual(vislst); +} +static sizet free_visual(ptr) + CELLPTR ptr; +{ + XFree(XVISUALINFO(ptr)); + return 0; +} +SCM x_visual_geometry(svsl) + SCM svsl; +{ + XVisualInfo *vsl; + ASSERT(NIMP(svsl) && VISUALP(svsl), svsl, ARG1, s_x_visual_geometry); + vsl = XVISUALINFO(svsl); + return cons2(MAKINUM(vsl->red_mask), MAKINUM(vsl->green_mask), + cons2(MAKINUM(vsl->blue_mask), MAKINUM(vsl->colormap_size), + EOL)); +} +SCM x_visual_class(svsl) + SCM svsl; +{ + XVisualInfo *vsl; + ASSERT(NIMP(svsl) && VISUALP(svsl), svsl, ARG1, s_x_visual_class); + vsl = XVISUALINFO(svsl); + return MAKINUM(vsl->class); } + SCM x_root_window(sdpy, sscr) SCM sdpy, sscr; { @@ -1688,6 +1894,151 @@ SCM x_default_visual(sdpy, sscr) scrns = (struct xs_screen *)(xsd + 1); return scrns[dspscn.screen_number].default_visual; } +SCM x_default_ccc(sdpy, sscr) + SCM sdpy, sscr; +{ + struct display_screen dspscn; + XcmsCCC ccc; + if (NIMP(sdpy) && COLORMAPP(sdpy) && UNBNDP(sscr)) { + struct xs_Colormap *cmp = COLORMAP(sdpy); + ccc = XcmsCCCOfColormap(cmp->dpy, cmp->cm); + } + else { + scm2display_screen(sdpy, sscr, &dspscn, s_x_default_ccc); + ccc = XcmsDefaultCCC(dspscn.dpy, dspscn.screen_number); + } + return CCC2SCM(ccc); +} +/* +SCM x_ccc_screen_info(sccc, sfmt) + SCM sccc; + SCM sfmt; +{ + XcmsCCC xccc; + XcmsPerScrnInfo *pPerScrnInfo; + ASSERT(NIMP(sccc) && CCCP(sccc), sccc, ARG1, s_x_ccc_screen_info); + ASSERT(NIMP(sfmt) && STRINGP(sfmt), sfmt, ARG2, s_x_ccc_screen_info); + xccc = XCCC(sccc); + pPerScrnInfo = (XcmsFunctionSet *)xccc->pPerScrnInfo; + return ; +} +*/ + /* Window Information */ + +SCM x_propdata2scm(type, format, nitems, data) + Atom type; + int format; + unsigned long nitems; + unsigned char* data; +{ + SCM datum = EOL; + SCM lst = EOL; + int cnt; + for (cnt = nitems; cnt--;) { + switch (type) { + case XA_ATOM: + case XA_VISUALID: + case XA_CARDINAL: + switch (format) { + case 8: datum = MAKINUM(((unsigned char *)data)[cnt]); break; + case 16: datum = MAKINUM(((unsigned short *)data)[cnt]); break; + case 32: datum = ulong2num(((unsigned long *)data)[cnt]); break; + default: return MAKINUM(format); + } break; + case XA_INTEGER: + switch (format) { + case 8: datum = MAKINUM(((char *)data)[cnt]); break; + case 16: datum = MAKINUM(((short *)data)[cnt]); break; + case 32: datum = long2num(((long *)data)[cnt]); break; + default: return MAKINUM(format); + } break; + case XA_STRING: + switch (format) { + case 8: return makfrom0str(data); + default: return MAKINUM(format); + } break; + case XA_ARC: + case XA_BITMAP: + case XA_COLORMAP: + case XA_CURSOR: + case XA_DRAWABLE: + case XA_FONT: + case XA_PIXMAP: + case XA_POINT: + case XA_RECTANGLE: + case XA_RGB_COLOR_MAP: + case XA_WINDOW: + case XA_WM_HINTS: + case XA_WM_SIZE_HINTS: + default: + /* datum = BOOL_F; */ + return MAKINUM(-type); + } + lst = cons(datum, lst); + } + return lst; +} +SCM x_get_window_property(swin, sprop, sargs) + SCM swin, sprop, sargs; +{ + struct xs_Window *xwn; + Atom property; + Atom actual_type_return; + int actual_format_return; + unsigned long nitems_return; + unsigned long bytes_after_return; + unsigned char *prop_return; + int sarglen = ilength(sargs); + ASSERT(IMP(sprop) ? INUMP(sprop) : STRINGP(sprop), + sprop, ARG2, s_x_get_window_property); + ASSERT(sarglen >= 0 && sarglen < 2, sargs, WNA, s_x_get_window_property); + if (1 == sarglen) { + ASSERT(NFALSEP(booleanp(CAR(sargs))), sargs, ARG3, s_x_get_window_property); + } + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window); + xwn = WINDOW(swin); + if (INUMP(sprop)) + property = INUM(sprop); + else + property = XInternAtom(xwn->dpy, CHARS(sprop), !0); + + if (None == property) return BOOL_F; + if (XGetWindowProperty(xwn->dpy, xwn->p.win, property, 0L, 65536L, + (1 == sarglen) && NFALSEP(CAR(sargs)), AnyPropertyType, + &actual_type_return, &actual_format_return, + &nitems_return, &bytes_after_return, + &prop_return) + != Success) + return BOOL_F; + { + SCM ans = x_propdata2scm(actual_type_return, actual_format_return, + nitems_return, prop_return); + XFree(prop_return); + return ans; + } +} +SCM x_list_properties(swin) + SCM swin; +{ + struct xs_Window *xwn; + Atom *atoms; + int num_prop_return; + SCM lst; + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window); + xwn = WINDOW(swin); + atoms = XListProperties(xwn->dpy, xwn->p.win, &num_prop_return); + { + int i = num_prop_return; + lst = EOL; + while (i--) { + char *name = XGetAtomName(xwn->dpy, atoms[i]); + lst = cons(makfrom0str(name), lst); + XFree(name); + } + } + XFree(atoms); + return lst; +} /* Rendering */ @@ -1856,6 +2207,24 @@ SCM x_fill_poly(sdbl, sgc, sargs) return xldraw_lines(sdbl, sgc, sargs, 2, s_x_fill_poly); } +static char s_x_read_bitmap_file[] = "x:read-bitmap-file"; +SCM x_read_bitmap_file(sdbl, sfname) + SCM sdbl, sfname; +{ + unsigned int w, h; + int x, y; + Pixmap pxmp; + ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_x_read_bitmap_file); + if (XReadBitmapFile(XWINDISPLAY(sdbl), + WINDOW(sdbl)->p.pm, + CHARS(sfname), + &w, &h, &pxmp, &x, &y) == BitmapSuccess) + return make_xwindow(WINDOW(sdbl)->display, + WINDOW(sdbl)->screen_number, + pxmp, (char) 1, (char) 0); + else return BOOL_F; +} + /* XEvents */ /* x_make_bool() is used in xevent.h */ @@ -1895,6 +2264,26 @@ static char *x__event_name(type) if (type==event_names[i].type) return event_names[i].name; return "unknown"; } + +SCM x_event_keysym(sevent) + SCM sevent; +{ + XKeyEvent *ev; + KeySym ans; + ASRTGO(NIMP(sevent) && XEVENTP(sevent), badarg); + ev = (XKeyEvent *)CHARS(sevent); + switch (((XEvent*)ev)->type) { + badarg: + default: wta(sevent, (char *)ARG1, s_x_event_keysym); + case KeyPress: + case KeyRelease: + ; + } + ans = XLookupKeysym(ev, ev->state); + if (ans) return MAKINUM(ans); + else return BOOL_F; +} + /* SMOB print routines */ static int print_xevent(exp, f, writing) @@ -1972,13 +2361,56 @@ static int print_xgcontext(exp, f, writing) lputc('>', f); return 1; } + +char *xvisualclass2name(class) + int class; +{ + switch (class) { + case StaticGray: return "StaticGray"; + case GrayScale: return "GrayScale"; + case StaticColor: return "StaticColor"; + case PseudoColor: return "PseudoColor"; + case TrueColor: return "TrueColor"; + case DirectColor: return "DirectColor"; + default: return "??"; + } +} + static int print_xvisual(exp, f, writing) SCM exp; SCM f; int writing; { + XVisualInfo *xvi = XVISUALINFO(exp); lputs("#<X visual #x", f); - intprint((long) XVisualIDFromVisual(XVISUAL(exp)), 16, f); + intprint((long) xvi->visualid, 16, f); + lputs(" ", f); + lputs(xvisualclass2name(xvi->class), f); + lputc(' ', f); + intprint((long) xvi->depth, 10, f); + lputc('x', f); + intprint((long) xvi->colormap_size, 10, f); + lputc('>', f); + return 1; +} +static int print_xccc(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + XcmsColorSpace **papColorSpaces; + XcmsCCC xccc = XCCC(exp); + lputs("#<X CCC", f); + papColorSpaces = + ((XcmsFunctionSet *)xccc->pPerScrnInfo->functionSet)->DDColorSpaces; + if (papColorSpaces != NULL) { + while (*papColorSpaces != NULL) { + lputs(" ", f); + lputs((*papColorSpaces)->prefix, f); + papColorSpaces++; + } + } + lputc('>', f); return 1; } @@ -1989,7 +2421,8 @@ static smobfuns smob_xcursor = {mark_xcursor, free_xcursor, print_xcursor, 0}; static smobfuns smob_xfont = {mark_xfont, free_xfont, print_xfont, 0}; static smobfuns smob_xgcontext = {mark_xgcontext, free_xgcontext, print_xgcontext, 0}; static smobfuns smob_xcolormap = {mark_xcolormap, free_xcolormap, print_xcolormap, 0}; -static smobfuns smob_xvisual = {mark0, free0, print_xvisual, 0}; +static smobfuns smob_xvisual = {mark0, free_visual, print_xvisual, 0}; +static smobfuns smob_xccc = {mark0, free_xccc, print_xccc, 0}; static smobfuns smob_xevent = {mark0, x_free_xevent, print_xevent, 0}; static iproc x_subr3s[] = { @@ -2005,6 +2438,7 @@ static iproc x_lsubr2s[] = { {s_x_create_cursor, x_create_cursor}, {s_x_alloc_color_cells, x_alloc_color_cells}, {s_x_free_color_cells, x_free_color_cells}, + {s_x_get_window_property, x_get_window_property}, {s_x_clear_area, x_clear_area}, {s_x_fill_rectangle, x_fill_rectangle}, {s_x_draw_string, x_draw_string}, @@ -2022,7 +2456,8 @@ static iproc x_lsubrs[] = { {s_x_gc_ref, x_gc_ref}, {s_x_copy_gc, x_copy_gc}, {s_x_window_set, x_window_set}, -/* {s_x_window_ref, x_window_ref}, */ + {s_x_window_geometry_set, x_window_geometry_set}, + {s_x_window_ref, x_window_ref}, {0, 0} }; @@ -2031,6 +2466,7 @@ static iproc x_subr2s[] = { {s_x_find_color, x_find_color}, {s_x_color_ref, x_color_ref}, {s_x_load_font, x_load_font}, + {s_x_read_bitmap_file, x_read_bitmap_file}, {0, 0} }; @@ -2057,6 +2493,7 @@ static iproc x_subr2os[] = { {s_x_default_visual, x_default_visual}, {s_x_default_colormap, x_default_colormap}, {s_x_install_colormap, x_install_colormap}, + {s_x_default_ccc, x_default_ccc}, {s_x_flush, x_flush}, {0, 0} }; @@ -2066,12 +2503,17 @@ static iproc x_subr1s[] = { {s_x_close, x_close}, {s_x_default_screen, x_default_screen}, {s_x_window_geometry, x_window_geometry}, + {s_x_list_properties, x_list_properties}, {s_x_map_window, x_map_window}, - {s_x_map_raised, x_map_raised}, {s_x_map_subwindows, x_map_subwindows}, {s_x_unmap_window, x_unmap_window}, {s_x_unmap_subwindows, x_unmap_subwindows}, {s_x_recreate_colormap, x_recreate_colormap}, + {s_x_visual_geometry, x_visual_geometry}, + {s_x_visual_class, x_visual_class}, + {s_x_event_keysym, x_event_keysym}, +/* {s_x_colormap_basis, x_colormap_basis}, */ +/* {s_x_colormap_limits, x_colormap_limits}, */ {0, 0} }; @@ -2099,10 +2541,16 @@ void init_x() tc16_xgcontext = newsmob(&smob_xgcontext); tc16_xvisual = newsmob(&smob_xvisual); tc16_xevent = newsmob(&smob_xevent); + tc16_xccc = newsmob(&smob_xccc); + xtc_ccc = XUniqueContext(); + xtc_cmp = XUniqueContext(); scm_ldprog("x11.scm"); scm_ldprog("xevent.scm"); - scm_ldstr("\ + /* Redefines STRING */ +/* scm_ldprog("xatoms.scm"); */ + scm_ldstr("\ +(define x:ccc x:default-ccc)\n\ (define x:GC-Clip-Origin (logior x:GC-Clip-X-Origin x:GC-Clip-Y-Origin))\n\ (define x:GC-Tile-Stip-Origin \n\ (logior x:GC-Tile-Stip-X-Origin x:GC-Tile-Stip-Y-Origin))\n\ @@ -5,7 +5,9 @@ SCM make_xdisplay(Display *d); SCM make_xgcontext(SCM d, int screen_number, GC gc, int rootp); SCM make_xcursor(SCM display, Cursor cursor); SCM make_xfont(SCM display, Font font, SCM name); -SCM make_xvisual(Visual *vsl); +SCM make_xvisual(XVisualInfo *vsl); +SCM CCC2SCM_P(XcmsCCC ccc); +SCM CCC2SCM(XcmsCCC ccc); SCM make_xevent(XEvent *e); size_t x_free_xevent(CELLPTR ptr); void scm2XPoint(int signp, SCM dat, XPoint *ipr, char *pos, char *s_caller); @@ -25,8 +27,10 @@ SCM x_display_debug(SCM sd, SCM si); SCM x_default_screen(SCM sdpy); SCM x_create_window(SCM swin, SCM spos, SCM sargs); SCM x_create_pixmap(SCM obj, SCM s_size, SCM s_depth); +SCM x_window_ref(SCM oargs); SCM x_window_set(SCM args); SCM x_window_geometry(SCM swin); +SCM x_window_geometry_set(SCM args); SCM x_close(SCM obj); SCM x_flush(SCM sd, SCM si); SCM x_create_colormap(SCM swin, SCM s_vis, SCM s_alloc); @@ -38,7 +42,6 @@ SCM x_find_color(SCM scmap, SCM dat); SCM x_color_set(SCM scmap, SCM s_pix, SCM dat); SCM x_color_ref(SCM scmap, SCM sidx); SCM x_map_window(SCM swin); -SCM x_map_raised(SCM swin); SCM x_map_subwindows(SCM swin); SCM x_unmap_window(SCM swin); SCM x_unmap_subwindows(SCM swin); @@ -65,14 +68,21 @@ SCM x_screen_size(SCM sd, SCM si); SCM x_screen_dimm(SCM sd, SCM si); SCM x_screen_black(SCM sd, SCM si); SCM x_screen_white(SCM sd, SCM si); +XVisualInfo *visual2visualinfo(Display *dsp, Visual *vis); SCM x_make_visual(SCM sd, SCM sdepth, SCM sclass); +SCM x_visual_geometry(SCM svsl); +SCM x_visual_class(SCM svsl); SCM x_root_window(SCM sdpy, SCM sscr); SCM x_default_colormap(SCM sdpy, SCM sscr); SCM x_default_gcontext(SCM sdpy, SCM sscr); SCM x_default_visual(SCM sdpy, SCM sscr); +SCM x_default_ccc(SCM sdpy, SCM sscr); +SCM x_propdata2scm(Atom type, int format, unsigned long nitems, unsigned char *data); +SCM x_get_window_property(SCM swin, SCM sprop, SCM sargs); +SCM x_list_properties(SCM swin); SCM x_clear_area(SCM swin, SCM spos, SCM sargs); SCM x_fill_rectangle(SCM swin, SCM sgc, SCM sargs); -void xldraw_string(SCM sdbl, SCM sgc, SCM sargs, int (*proc)(), char *s_caller); +void xldraw_string(SCM sdbl, SCM sgc, SCM sargs, int (*proc)(void), char *s_caller); SCM x_draw_string(SCM sdbl, SCM sgc, SCM sargs); SCM x_image_string(SCM sdbl, SCM sgc, SCM sargs); SCM x_draw_points(SCM sdbl, SCM sgc, SCM sargs); @@ -80,7 +90,10 @@ SCM xldraw_lines(SCM sdbl, SCM sgc, SCM sargs, int funcod, char *s_caller); SCM x_draw_segments(SCM sdbl, SCM sgc, SCM sargs); SCM x_draw_lines(SCM sdbl, SCM sgc, SCM sargs); SCM x_fill_poly(SCM sdbl, SCM sgc, SCM sargs); +SCM x_read_bitmap_file(SCM sdbl, SCM sfname); SCM x_make_bool(int f); SCM x_event_ref(SCM sevent, SCM sfield); +SCM x_event_keysym(SCM sevent); +char *xvisualclass2name(int class); void x_scm_final(void); void init_x(void); @@ -431,16 +431,16 @@ (define x:Queued-After-Reading 1) (define x:Queued-After-Flush 2) (define x:All-Planes -1) -(define x:XN-Required-Char-Set 134530035) -(define x:XN-Query-Orientation 134530074) -(define x:XN-Base-Font-Name 134530114) -(define x:XNOM-Automatic 134530147) -(define x:XN-Missing-Char-Set 134530176) -(define x:XN-Default-String 134530213) -(define x:XN-Orientation 134530247) -(define x:XN-Directional-Dependent-Drawing 134530276) -(define x:XN-Contextual-Drawing 134530339) -(define x:XN-Font-Info 134530381) +(define x:XN-Required-Char-Set 134529975) +(define x:XN-Query-Orientation 134530014) +(define x:XN-Base-Font-Name 134530054) +(define x:XNOM-Automatic 134530087) +(define x:XN-Missing-Char-Set 134530116) +(define x:XN-Default-String 134530153) +(define x:XN-Orientation 134530187) +(define x:XN-Directional-Dependent-Drawing 134530216) +(define x:XN-Contextual-Drawing 134530307) +(define x:XN-Font-Info 134530349) (define x:XIM-Preedit-Area 1) (define x:XIM-Preedit-Callbacks 2) (define x:XIM-Preedit-Position 4) @@ -450,48 +450,48 @@ (define x:XIM-Status-Callbacks 512) (define x:XIM-Status-Nothing 1024) (define x:XIM-Status-None 2048) -(define x:XN-Va-Nested-List 134530592) -(define x:XN-Query-Input-Style 134530627) -(define x:XN-Client-Window 134530666) -(define x:XN-Input-Style 134530698) -(define x:XN-Focus-Window 134530726) -(define x:XN-Resource-Name 134530756) -(define x:XN-Resource-Class 134530788) -(define x:XN-Geometry-Callback 134530822) -(define x:XN-Destroy-Callback 134530862) -(define x:XN-Filter-Events 134530900) -(define x:XN-Preedit-Start-Callback 134530932) -(define x:XN-Preedit-Done-Callback 134530981) -(define x:XN-Preedit-Draw-Callback 134531028) -(define x:XN-Preedit-Caret-Callback 134531075) -(define x:XN-Preedit-State-Notify-Callback 134531124) -(define x:XN-Preedit-Attributes 134531186) -(define x:XN-Status-Start-Callback 134531228) -(define x:XN-Status-Done-Callback 134531275) -(define x:XN-Status-Draw-Callback 134531320) -(define x:XN-Status-Attributes 134531365) -(define x:XN-Area 134531405) -(define x:XN-Area-Needed 134531420) -(define x:XN-Spot-Location 134531448) -(define x:XN-Colormap 134531480) -(define x:XN-Std-Colormap 134531503) -(define x:XN-Foreground 134531533) -(define x:XN-Background 134531560) -(define x:XN-Background-Pixmap 134531587) -(define x:XN-Font-Set 134531627) -(define x:XN-Line-Space 134531649) -(define x:XN-Cursor 134531675) -(define x:XN-Query-IM-Values-List 134531694) -(define x:XN-Query-IC-Values-List 134531738) -(define x:XN-Visible-Position 134531782) -(define x:XNR6-Preedit-Callback 134531820) -(define x:XN-String-Conversion-Callback 134531862) -(define x:XN-String-Conversion 134531919) -(define x:XN-Reset-State 134531959) -(define x:XN-Hot-Key 134531987) -(define x:XN-Hot-Key-State 134532007) -(define x:XN-Preedit-State 134532038) -(define x:XN-Separatorof-Nested-List 134532070) +(define x:XN-Va-Nested-List 134530560) +(define x:XN-Query-Input-Style 134530595) +(define x:XN-Client-Window 134530634) +(define x:XN-Input-Style 134530666) +(define x:XN-Focus-Window 134530694) +(define x:XN-Resource-Name 134530724) +(define x:XN-Resource-Class 134530756) +(define x:XN-Geometry-Callback 134530790) +(define x:XN-Destroy-Callback 134530830) +(define x:XN-Filter-Events 134530868) +(define x:XN-Preedit-Start-Callback 134530900) +(define x:XN-Preedit-Done-Callback 134530949) +(define x:XN-Preedit-Draw-Callback 134530996) +(define x:XN-Preedit-Caret-Callback 134531043) +(define x:XN-Preedit-State-Notify-Callback 134531092) +(define x:XN-Preedit-Attributes 134531171) +(define x:XN-Status-Start-Callback 134531213) +(define x:XN-Status-Done-Callback 134531260) +(define x:XN-Status-Draw-Callback 134531305) +(define x:XN-Status-Attributes 134531350) +(define x:XN-Area 134531390) +(define x:XN-Area-Needed 134531405) +(define x:XN-Spot-Location 134531433) +(define x:XN-Colormap 134531465) +(define x:XN-Std-Colormap 134531488) +(define x:XN-Foreground 134531518) +(define x:XN-Background 134531545) +(define x:XN-Background-Pixmap 134531572) +(define x:XN-Font-Set 134531612) +(define x:XN-Line-Space 134531634) +(define x:XN-Cursor 134531660) +(define x:XN-Query-IM-Values-List 134531679) +(define x:XN-Query-IC-Values-List 134531723) +(define x:XN-Visible-Position 134531767) +(define x:XNR6-Preedit-Callback 134531805) +(define x:XN-String-Conversion-Callback 134531847) +(define x:XN-String-Conversion 134531904) +(define x:XN-Reset-State 134531944) +(define x:XN-Hot-Key 134531972) +(define x:XN-Hot-Key-State 134531992) +(define x:XN-Preedit-State 134532023) +(define x:XN-Separatorof-Nested-List 134532055) (define x:X-Buffer-Overflow -1) (define x:X-Lookup-None 1) (define x:X-Lookup-Chars 2) @@ -522,7 +522,7 @@ (define x:XIM-String-Conversion-Word 3) (define x:XIM-String-Conversion-Char 4) (define x:XIM-String-Conversion-Substitution 1) -(define x:XIM-String-Conversion-Retrival 2) +(define x:XIM-String-Conversion-Retrieval 2) (define x:XIM-Hot-Key-State-ON 1) (define x:XIM-Hot-Key-State-OFF 2) ;;inc2scm extracted #define values from /usr/include/X11/Xutil.h diff --git a/xatoms.scm b/xatoms.scm new file mode 100644 index 0000000..d6661c3 --- /dev/null +++ b/xatoms.scm @@ -0,0 +1,80 @@ +;; xgen.scm extracted definitions from /usr/include/X11/Xatom.h +(define PRIMARY 1) +(define SECONDARY 2) +(define ARC 3) +(define ATOM 4) +(define BITMAP 5) +(define CARDINAL 6) +(define COLORMAP 7) +(define CURSOR 8) +(define CUT-BUFFER0 9) +(define CUT-BUFFER1 10) +(define CUT-BUFFER2 11) +(define CUT-BUFFER3 12) +(define CUT-BUFFER4 13) +(define CUT-BUFFER5 14) +(define CUT-BUFFER6 15) +(define CUT-BUFFER7 16) +(define DRAWABLE 17) +(define FONT 18) +(define INTEGER 19) +(define PIXMAP 20) +(define POINT 21) +(define RECTANGLE 22) +(define RESOURCE-MANAGER 23) +(define RGB-COLOR-MAP 24) +(define RGB-BEST-MAP 25) +(define RGB-BLUE-MAP 26) +(define RGB-DEFAULT-MAP 27) +(define RGB-GRAY-MAP 28) +(define RGB-GREEN-MAP 29) +(define RGB-RED-MAP 30) +(define STRING 31) +(define VISUALID 32) +(define WINDOW 33) +(define WM-COMMAND 34) +(define WM-HINTS 35) +(define WM-CLIENT-MACHINE 36) +(define WM-ICON-NAME 37) +(define WM-ICON-SIZE 38) +(define WM-NAME 39) +(define WM-NORMAL-HINTS 40) +(define WM-SIZE-HINTS 41) +(define WM-ZOOM-HINTS 42) +(define MIN-SPACE 43) +(define NORM-SPACE 44) +(define MAX-SPACE 45) +(define END-SPACE 46) +(define SUPERSCRIPT-X 47) +(define SUPERSCRIPT-Y 48) +(define SUBSCRIPT-X 49) +(define SUBSCRIPT-Y 50) +(define UNDERLINE-POSITION 51) +(define UNDERLINE-THICKNESS 52) +(define STRIKEOUT-ASCENT 53) +(define STRIKEOUT-DESCENT 54) +(define ITALIC-ANGLE 55) +(define X-HEIGHT 56) +(define QUAD-WIDTH 57) +(define WEIGHT 58) +(define POINT-SIZE 59) +(define RESOLUTION 60) +(define COPYRIGHT 61) +(define NOTICE 62) +(define FONT-NAME 63) +(define FAMILY-NAME 64) +(define FULL-NAME 65) +(define CAP-HEIGHT 66) +(define WM-CLASS 67) +(define WM-TRANSIENT-FOR 68) +(define LAST-PREDEFINED 68) +;; xgen.scm extracted definitions from /usr/include/X11/Xcms.h +(define X:Undefined #x00000000) +(define X:CIEXYZ #x00000001) +(define X:CIEuvY #x00000002) +(define X:CIExyY #x00000003) +(define X:CIELab #x00000004) +(define X:CIELuv #x00000005) +(define X:TekHVC #x00000006) +(define X:RGB #x80000000) +(define X:RGBi #x80000001) @@ -1,4 +1,4 @@ -/* ./xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h */ +/* xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h */ #ifdef SCM_EVENT_FIELDS case (KeyPress<<8)+0x10: case (KeyRelease<<8)+0x10: return MAKINUM(((XKeyEvent *) x)->type); case (KeyPress<<8)+0x11: case (KeyRelease<<8)+0x11: return MAKINUM(((XKeyEvent *) x)->serial); @@ -1,4 +1,4 @@ -;; ./xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h +;; xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h (define X-event:type #x10) (define X-event:serial #x11) (define X-event:send-event #x12) @@ -1,6 +1,6 @@ #! /usr/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 - !# -;; Copyright (C) 1991-1999 Free Software Foundation, Inc. +;; Copyright (C) 1991-2000 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -17,26 +17,26 @@ ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. +;; for additional uses of the text contained in its release of SCM. ;; -;; The exception is that, if you link the GUILE library with other files +;; The exception is that, if you link the SCM library with other files ;; to produce an executable, this does not by itself cause the ;; resulting executable to be covered by the GNU General Public License. ;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. +;; linking the SCM library code into it. ;; ;; This exception does not however invalidate any other reasons why ;; the executable file might be covered by the GNU General Public License. ;; ;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy +;; Free Software Foundation under the name SCM. If you copy ;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does +;; SCM, as the General Public License permits, the exception does ;; not apply to the code that you add in this way. To avoid misleading ;; anyone as to the status of such modified files, you must delete ;; this exception notice from them. ;; -;; If you write modifications of your own for GUILE, it is your choice +;; If you write modifications of your own for SCM, it is your choice ;; whether to permit this exception to apply to your modifications. ;; If you do not wish that, delete this exception notice. @@ -44,8 +44,9 @@ ;;; Author: Aubrey Jaffer. (define (go-script) - (cond ((not *script*)) + (cond ;;((not *script*)) ((>= 1 (- (length *argv*) *optind*)) + (xatoms) (apply xgen.scm (list-tail *argv* *optind*))) (else (display "\ @@ -60,28 +61,14 @@ Usage: xgen.scm /usr/include/X11/Xlib.h (require 'common-list-functions) (require 'string-search) +(require 'string-case) (require 'line-i/o) (require 'printf) (require 'scanf) -(define (StudlyCaps->dashed-name nstr) - (do ((idx (+ -1 (string-length nstr)) (+ -1 idx))) - ((> 2 idx)) - (cond ((and (char-upper-case? (string-ref nstr (+ -1 idx))) - (char-lower-case? (string-ref nstr idx))) - (set! nstr - (string-append (substring nstr 0 (+ -1 idx)) - "-" - (substring nstr (+ -1 idx) - (string-length nstr))))) - ((and (char-lower-case? (string-ref nstr (+ -1 idx))) - (char-upper-case? (string-ref nstr idx))) - (set! nstr - (string-append (substring nstr 0 idx) - "-" - (substring nstr idx - (string-length nstr))))))) - nstr) +(define progname (if (defined? *optind*) + (list-ref *argv* (+ -1 *optind*)) + (car (program-arguments)))) ;; SCHEMEIFY-NAME: ;; * Changes _ to - @@ -93,8 +80,8 @@ Usage: xgen.scm /usr/include/X11/Xlib.h (let ((sid (string-index nstr #\-))) (cond ((and pre sid (< sid 3)) (string-set! nstr sid #\:) nstr) - (pre (string-append pre (StudlyCaps->dashed-name nstr))) - (else (StudlyCaps->dashed-name nstr))))) + (pre (string-append pre (StudlyCapsExpand nstr))) + (else (StudlyCapsExpand nstr))))) (define (extract-structs port) (define typedef-struct (string-append (string #\newline) "typedef struct {")) @@ -241,54 +228,91 @@ Usage: xgen.scm /usr/include/X11/Xlib.h (let ((structs (remove-if-not (lambda (struct) (substring? "Event" (car struct))) (call-with-input-file filename extract-structs)))) - (call-with-output-file "xevent.h" - (lambda (xevent.h) - (fprintf xevent.h "/* %s extracted typedef structs from %s */\n" - (car *argv*) filename) - (fprintf xevent.h - "#ifdef SCM_EVENT_FIELDS\n") - (call-with-output-file "xevent.scm" - (lambda (xevent.scm) - (define evs #f) - (fprintf xevent.scm ";; %s extracted typedef structs from %s\n" - (car *argv*) filename) - (for-each - (lambda (struct) - (define name (car struct)) - (set! evs (assoc name event-map)) - (and - evs - (for-each - (lambda (decl) - (define typ (string->symbol (car decl))) - (casev typ - ((,Bool ,Time int char) - (fprintf xevent.h " ") - (for-each (lambda (event-name) - (fprintf xevent.h "case (%s<<8)+0x%02x: " - event-name - (do-field xevent.scm (cadr decl)))) - (cdr evs)) - (fprintf xevent.h "return %s(((%s *) x)->%s);\n" - (casev typ - ((,Bool) "x_make_bool") - ((,Time) "ulong2num") - ((int char) "MAKINUM")) - name - (cadr decl))) - ;;(else (print 'typ typ)) - )) - (cdr struct)))) - structs))) - (fprintf xevent.h "#else\n") - (for-each (lambda (apr) - (for-each (lambda (evnt) - (fprintf xevent.h - " {%-20s \"%s\"},\n" - (string-append evnt ",") evnt)) - (cdr apr))) - event-map) - (fprintf xevent.h "#endif\n"))))) + (call-with-open-ports + (open-file "xevent.h" "w") + (open-file "xevent.scm" "w") + (lambda (xevent.h xevent.scm) + (define evs #f) + (fprintf xevent.h "/* %s extracted typedef structs from %s */\n" + progname filename) + (fprintf xevent.h + "#ifdef SCM_EVENT_FIELDS\n") + (fprintf xevent.scm ";; %s extracted typedef structs from %s\n" + progname filename) + (for-each + (lambda (struct) + (define name (car struct)) + (set! evs (assoc name event-map)) + (and + evs + (for-each + (lambda (decl) + (define typ (string->symbol (car decl))) + (qase typ + ((,Bool ,Time int char) + (fprintf xevent.h " ") + (for-each (lambda (event-name) + (fprintf xevent.h "case (%s<<8)+0x%02x: " + event-name + (do-field xevent.scm (cadr decl)))) + (cdr evs)) + (fprintf xevent.h "return %s(((%s *) x)->%s);\n" + (qase typ + ((,Bool) "x_make_bool") + ((,Time) "ulong2num") + ((int char) "MAKINUM")) + name + (cadr decl))) + ;;(else (print 'typ typ)) + )) + (cdr struct)))) + structs) + (fprintf xevent.h "#else\n") + (for-each (lambda (apr) + (for-each (lambda (evnt) + (fprintf xevent.h + " {%-20s \"%s\"},\n" + (string-append evnt ",") evnt)) + (cdr apr))) + event-map) + (fprintf xevent.h "#endif\n"))))) + +(define (xatoms) + (define /usr/include/X11/Xatom.h "/usr/include/X11/Xatom.h") + (define /usr/include/X11/Xcms.h "/usr/include/X11/Xcms.h") + (call-with-open-ports + (open-file /usr/include/X11/Xatom.h "r") + (open-file "/usr/include/X11/Xcms.h" "r") + (open-file "xatoms.scm" "w") + (lambda (xatom.h xcms.h xatoms.scm) + (fprintf xatoms.scm ";; %s extracted definitions from %s\n" + progname /usr/include/X11/Xatom.h) + (do ((line (read-line xatom.h) (read-line xatom.h))) + ((eof-object? line)) + (let ((lst (scanf-read-list "#define XA_%s ((Atom) %d)" line))) + (and (list? lst) + (case (length lst) + ((2) (fprintf xatoms.scm "(define %s %d)\n" + (string-subst (car lst) "_" "-") + (cadr lst))) + ((0) #f) ;(write-line line) + (else (slib:error 'xatom.h 'line line)))))) + (fprintf xatoms.scm ";; %s extracted definitions from %s\n" + progname /usr/include/X11/Xcms.h) + (do ((line (read-line xcms.h) (read-line xcms.h))) + ((eof-object? line)) + (let ((lst (scanf-read-list "#define Xcms%s (XcmsColorFormat)0x%4x%4x" + line))) + (and (list? lst) + (case (length lst) + ((3) (apply fprintf xatoms.scm "(define\tX:%s\t#x%04x%04x)\n" + (string-subst (car lst) "Format" "") + (cdr lst))) + ((2) (fprintf xatoms.scm "(define\tX:%s\t#x%08x)\n" + (string-subst (car lst) "Format" "") + (cadr lst))) + ((0 1) #f) + (else (slib:error 'xcms.h 'line line))))))))) (go-script) |