diff options
| -rw-r--r-- | .gdbinit | 2 | ||||
| -rw-r--r-- | ANNOUNCE | 357 | ||||
| -rw-r--r-- | COPYING | 2 | ||||
| -rw-r--r-- | ChangeLog | 1360 | ||||
| -rw-r--r-- | Iedline.scm | 14 | ||||
| -rw-r--r-- | Init5d2.scm (renamed from Init5c3.scm) | 418 | ||||
| -rw-r--r-- | Link.scm | 80 | ||||
| -rw-r--r-- | Macro.scm | 155 | ||||
| -rw-r--r-- | Macroexpand.scm | 370 | ||||
| -rw-r--r-- | Makefile | 333 | ||||
| -rw-r--r-- | README | 568 | ||||
| -rw-r--r-- | Transcen.scm | 13 | ||||
| -rw-r--r-- | Tscript.scm | 60 | ||||
| -rw-r--r-- | Xlibscm.info | 1905 | ||||
| -rw-r--r-- | Xlibscm.texi | 1955 | ||||
| -rw-r--r-- | bench.scm | 2 | ||||
| -rwxr-xr-x | build | 72 | ||||
| -rwxr-xr-x | build.bat | 5 | ||||
| -rw-r--r-- | build.scm | 2344 | ||||
| -rw-r--r-- | continue.c | 10 | ||||
| -rw-r--r-- | continue.h | 14 | ||||
| -rw-r--r-- | crs.c | 41 | ||||
| -rw-r--r-- | disarm.scm | 2 | ||||
| -rw-r--r-- | dynl.c | 44 | ||||
| -rw-r--r-- | edline.c | 2 | ||||
| -rw-r--r-- | eval.c | 1356 | ||||
| -rw-r--r-- | findexec.c | 5 | ||||
| -rw-r--r-- | gmalloc.c | 52 | ||||
| -rw-r--r-- | gsubr.c | 23 | ||||
| -rwxr-xr-x | inc2scm | 190 | ||||
| -rw-r--r-- | ioext.c | 92 | ||||
| -rw-r--r-- | mkimpcat.scm | 10 | ||||
| -rw-r--r-- | patchlvl.h | 15 | ||||
| -rw-r--r-- | pi.c | 2 | ||||
| -rw-r--r-- | pi.scm | 2 | ||||
| -rw-r--r-- | posix.c | 48 | ||||
| -rw-r--r-- | r4rstest.scm | 124 | ||||
| -rw-r--r-- | ramap.c | 383 | ||||
| -rw-r--r-- | record.c | 197 | ||||
| -rw-r--r-- | repl.c | 856 | ||||
| -rw-r--r-- | requires.scm | 22 | ||||
| -rw-r--r-- | rgx.c | 82 | ||||
| -rw-r--r-- | rope.c | 69 | ||||
| -rw-r--r-- | sc2.c | 10 | ||||
| -rw-r--r-- | scl.c | 341 | ||||
| -rw-r--r-- | scm.1 | 15 | ||||
| -rw-r--r-- | scm.c | 455 | ||||
| -rw-r--r-- | scm.doc | 24 | ||||
| -rw-r--r-- | scm.h | 267 | ||||
| -rw-r--r-- | scm.info | 8099 | ||||
| -rw-r--r-- | scm.texi | 1947 | ||||
| -rw-r--r-- | scmfig.h | 105 | ||||
| -rw-r--r-- | scmmain.c | 145 | ||||
| -rw-r--r-- | script.c | 49 | ||||
| -rw-r--r-- | setjump.h | 24 | ||||
| -rw-r--r-- | socket.c | 43 | ||||
| -rw-r--r-- | split.scm | 2 | ||||
| -rw-r--r-- | subr.c | 76 | ||||
| -rw-r--r-- | sys.c | 1201 | ||||
| -rw-r--r-- | time.c | 27 | ||||
| -rw-r--r-- | unexsgi.c | 888 | ||||
| -rw-r--r-- | unif.c | 345 | ||||
| -rw-r--r-- | unix.c | 10 | ||||
| -rw-r--r-- | x.c | 2114 | ||||
| -rw-r--r-- | x.h | 86 | ||||
| -rw-r--r-- | x11.scm | 587 | ||||
| -rw-r--r-- | xevent.h | 217 | ||||
| -rw-r--r-- | xevent.scm | 31 | ||||
| -rwxr-xr-x | xgen.scm | 297 |
69 files changed, 25792 insertions, 5269 deletions
@@ -12,7 +12,7 @@ # # 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, 675 Mass Ave, Cambridge, MA 02139, USA. +# 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. @@ -1,145 +1,144 @@ -This message announces the availability of Scheme release scm5c3. - -New in scm5c3: - - * patchlvl.h (SCMVERSION): Bumped from 5c2 to 5c3. - * gmalloc.c: Imported gmalloc.c from emacs 20.2.1. - (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 - stack. - * scl.c (big2str): Added call to scm_protect_temp. - * eval.c (map): (for_each): Added calls to scm_protect_temp. - * rgx.c (lregcomp): Added call to scm_protect_temp. - * scl.c (big2str): Take address of SCM temporary as gc protection. - * dynl.c (l_dyn_link): - conditionalized message on verbose. Cleaned up message. - * Link.scm (link:link): - prepend ./ to non-absolute sun-dl library paths. - * scm.texi, scm.doc, scm.1, r4rstest.scm, README, Init5c2.scm, ANNOUNCE: - ...-swiss => swissnet - * scm.h (verbose): read only macro for scm_verbose. - * repl.c (scm_verbose): renamed from verbose. - * 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. - * sys.c (sys_errp): Interrupt safe system output port added. - (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, - ENV_RESTORE, local to eval.c - (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. - (m_lambda): Computes and memoizes the number of required arguments. - * 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 - sys_errp. - (ints_warn): Added for interrupt warnings using VERIFY_INTS. - (scm_stack_trace): Now completely prints stacks up to 20 deep, - rather than 10. - (def_err_response): Prints errobj if error is fatal. - (lroom): Made subr_1o for easier calling from C. - * Init5c2.scm (array-shape): No longer signals an error when - passed a non-array -- now returns whatever ARRAY-DIMENSIONS - returned (currently #f). - * scm.c (scm_proftimer): Also conditional on SIGALRM. - * sys.c (init_storage): Fixed initialization of tmp_errp so that - it is always correctly aligned. - * scm.c (process_signals): Fixed braino in code to search for - deferred signals. - (scmable_signal): Added POSIX signal unblocking call, conditional - on SIG_UNBLOCK, so Scheme signal handlers may be interrupted - before they exit. - * scm.c (scmable_signal): (err_signal): (init_signals): - (ignore_signals): - (unignore_signals): (restore_signals): Abstracted signal handling. - (fpe_signal): (bus_signal): (segv_signal): (alrm_signal): - (prof_signal): Removed. - * repl.c (process_signals): Moved to scm.c - * sys.c (must_realloc_cell): Now returns void. - * scm.c (prof_signal): (scm_proftimer): (ignore_signals): - (unignore_signals): Added handler for SIGPROF, raised via call to - setitimer (Scheme function PROFILE-TIMER). - * repl.c (handle_it): No longer saves scm_env, scm_env_tmp to - estk, they are protected by doing ecache gc. - (process_signals): Handles SIGPROF. - * sys.c (scm_fill_freelist): No longer always does gc. - (gc_mark): No longer bashes cdr of `free' cells, handle_it now - bashes more selectively. - (scm_egc): DEFER/ALLOW_INTS moved to minimize debugging ints_viol - messages -- some will still occur. - (scm_egc): No longer saves scm_env and scm_env_ptr to estk, they - are protected separately. To improve interrupt safety. - * unif.c (resizuve): eliminated unused variable `ptr'. - * sys.c (freeprint): Now prints cdr of new cell. - * repl.c (input_waiting): Now checks return value of select and - restarts if interrupted. This was causing CHAR-READY? to return - #T when no input was actually readable. - * sys.c (scm_egc): (scm_egc_copy_roots): Eliminated extra root - argument, made safe because EGC_ROOT is always called with ints - deferred. - (gc_mark): Check for ecache broken heart during mark -- fatal error. - (gc_sweep): Now uses HUGE_LENGTH instead of LENGTH for string - termination check. - (must_malloc_cell): (must_realloc_cell): Added. - (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. - * subr.c (make_vector): (mkbig): (adjbig): Now use - must_malloc_cell, must_realloc_cell. - * socket.c (maksknm): Now uses must_malloc_cell. - * scm.h (ISYMNUM): Use only 8 bits for number, freeing some bits - for other uses. - * scl.c (makdbl): Now uses must_malloc_cell. - * rgx.c (lrgecomp): Now uses must_malloc_cell. - * repl.c (handle_it): Keep pointers to discarded new cells. - * 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 - ints sections. For dlopen versions, print more error messages. - * eval.c (macroexp1): now prints name of unbound variable. - (s_unbnd s_wtap): abstracted error message strings. - * eval.c (ceval_1): No longer make extra environment frame for - LETREC, since internal DEFINE is now rewritten. - * sys.c (scm_fill_freelist): added. Assures that at least - MIN_GC_YIELD cells are in freelis. This is used before returning - from interrupts. - * repl.c (handle_it): Discard 2 cells (because of CDR in NEWCELL). - Call scm_fill_freelist(); - * Init5c2.scm: removed DEFINED? conditionals for old SCMs. - * 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 - prevent problems with interrupt handlers that run Scheme code. - * sys.c (scm_estk_grow): Protected critical section with - DEFER/ALLOW_INTS - (must_malloc): (must_realloc): Protected igc call with - DEFER/ALLOW_INTS. - (scm_egc): Added DEFER/ALLOW_INTS around call to igc -- prevents - interrupts violation message in debug mode. - (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 - root. Simplifies handling of the case where scm_egc calls igc, - and possibly itself. - * repl.c (growth_mon): Now prints "shrank" instead of "grew" if - the relevant limit decreased. - (handle_it): Do env cache gc before applying interrupt - handler, to protect data on the estk, which might move. +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. -=-=- Scm conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Scm is written in C and runs under -Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Unix and -similar systems. ASCII and EBCDIC are supported. +Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Windows, +Unix, and similar systems. ASCII and EBCDIC are supported. Documentation is included explaining the many Scheme Language extensions in scm, the internal representations, and how to extend or @@ -147,89 +146,75 @@ include SCM in other programs. Documentation is online at: http://swissnet.ai.mit.edu/~jaffer/SCM.html -SCM can be obtained via FTP (detailed instructions follow) from: - swissnet.ai.mit.edu:pub/scm/scm5c3.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/scm5c3.tar.gz +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) SLIB is a portable Scheme library which SCM uses: - swissnet.ai.mit.edu:pub/scm/slib2c3.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/slib2c3.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip + ftp.gnu.org:pub/gnu/jacal/slib2c7.zip JACAL is a symbolic math system written in Scheme: - swissnet.ai.mit.edu:pub/scm/jacal1a7.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/jacal1a7.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b0.zip + ftp.gnu.org:pub/gnu/jacal/jacal1b0.zip HOBBIT is a compiler for SCM code: - swissnet.ai.mit.edu:pub/scm/hobbit4d.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/hobbit5x.tar.gz + ftp.gnu.org:pub/gnu/jacal/hobbit5x.tar.gz SLIB-PSD is a portable debugger for Scheme (requires emacs editor): - swissnet.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz + ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz SMG-SCM is an SMG interface package which works with SCM on VMS. - swissnet.ai.mit.edu:pub/scm/smg-scm2a1.zip - prep.ai.mit.edu:pub/gnu/jacal/smg-scm2a1.zip + http://swissnet.ai.mit.edu/ftpdir/scm/smg-scm2a1.zip + ftp.gnu.org:pub/gnu/jacal/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: - swissnet.ai.mit.edu:pub/scm/turtlegr.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/turtlegr.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/turtlegr.tar.gz + ftp.gnu.org:pub/gnu/jacal/turtlegr.tar.gz XSCM is a X windows interface package which works with SCM: - swissnet.ai.mit.edu:pub/scm/xscm-2.01.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/xscm-2.01.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/xscm-2.01.tar.gz + ftp.gnu.org:pub/gnu/jacal/xscm-2.01.tar.gz MacSCM is a Macintosh applications building package which works with SCM (similar to XSCM). - swissnet.ai.mit.edu:pub/scm/macscm.tar.Z + http://swissnet.ai.mit.edu/ftpdir/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. - swissnet.ai.mit.edu:pub/scm/wb1a2.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/wb1a2.tar.gz SIMSYNCH is a digital logic simulation system written in SCM. - swissnet.ai.mit.edu:pub/scm/synch1a2.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/synch1a3.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/synch1b0.zip + ftp.gnu.org:pub/gnu/jacal/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 (SunOS 4.0), Sequent Symmetry (Dynix), Atari ST, and a.out Linux systems. - prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz + 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. + http://swissnet.ai.mit.edu/ftpdir/scm/scm.exe #! implements "#!" (POSIX) shell-scripts for MS-DOS batch files. - swissnet.ai.mit.edu:pub/scm/#!.zip + http://swissnet.ai.mit.edu/ftpdir/scm/sharpbang.zip + http://swissnet.ai.mit.edu/ftpdir/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 swissnet.ai.mit.edu (anonymous) - bin - cd pub/scm - get scm5c3.tar.gz - get slib2c3.tar.gz -or - ftp prep.ai.mit.edu (anonymous) + ftp ftp.gnu.org (anonymous) bin cd pub/gnu/jacal - get scm5c3.tar.gz - get slib2c3.tar.gz - - `scm5c3.tar.gz' is a gzipped tar file of the C code distribution. - `slib2c3.tar.gz' is a gzipped tar file of a Scheme Library. - -Files in these directories with the ".gz" suffix are compressed with -patent-free gzip (no relation to zip). The program to uncompress them -is available from - prep.ai.mit.edu:pub/gnu/gzip-1.2.4.tar - prep.ai.mit.edu:pub/gnu/gzip-1.2.4.shar - prep.ai.mit.edu:pub/gnu/gzip-1.2.4.msdos.exe - -Remember to use binary mode when transferring the files. -Be sure to get and read the GNU General Public License (COPYING). -It is included in scm5c3.tar.gz. - -I sell IBM PC floppy disk sets with the source files, documentation, -and MS-DOS and i386 MS-DOS executables for $99.00. To order, send -e-mail to jaffer @ rice-chex.ai.mit.edu. + get slib2c7.zip + get scm5d2.zip @@ -2,7 +2,7 @@ Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. @@ -1,3 +1,1349 @@ +Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * patchlvl.h (SCMVERSION): Bumped from 5d1 to 5d2. + +1999-12-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * Makefile (install): Make sure $(libscmdir)require.scm exists. + (libscmdir): Use instead of IMPLPATH. + +1999-12-02 Radey Shouman <Radey_Shouman@splashtech.com> + + * scmfig.h: Don't #define SINGLES for MSC, per suggestion of David + Yeh <theyeh@uclink.berkeley.edu> + +1999-12-01 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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> + + * 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. + +1999-11-09 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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*. + +1999-11-04 Radey Shouman <Radey_Shouman@splashtech.com> + + * scl.c (dbl_prec): Use dbl_mant_dig in preference of potentially + undefined DBL_MANT_DIG. + +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> + + * gmalloc.c: include "getpagesize.h" conditionalized on __svr4__. + +1999-10-31 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * 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> + + * Makefile: Added platform.txi dependency where dependent on + scm.texi. + +1999-10-16 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * Makefile (scm.info require.scm): "cp -p" more portable than "cp -a"? + +1999-10-15 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c (mode_bits): Fix for null output string case. + +1999-10-14 Radey Shouman <Radey_Shouman@splashtech.com> + + * unif.c (make_sh_array): Reduced consing by using scm_cvapply + instead of apply. + +1999-10-13 Radey Shouman <Radey_Shouman@splashtech.com> + + *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. + +1999-10-13 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * r4rstest.scm (float-print-test): stop after first error. + +1999-10-13 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c (try_open_file): Insure that only 'r', 'w', 'b', or '+' + may be included in mode strings passed to fopen. + +1999-10-11 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c (scm_freshline): Added FRESHLINE. + * sys.c (init_storage): Make def_outp tracked, so freshline will + work with it. + +1999-10-10 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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. + +1999-10-09 Radey Shouman <Radey_Shouman@splashtech.com> + + * subr.c (make_vector): Fixed broken length argument test. + +1999-10-08 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c (scm_env_v2lst): Now takes list tail in scm_env_tmp, so + tail can be allocated on ecache. + +1999-10-06 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c (scm_top_level): Print out supplied program arguments for + failure exits to simplify debugging scripts. + + * eval.c (varcheck): Fixed for RECKLESS case. + +1999-10-04 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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. + +1999-09-21 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * sys.c (scm_port_entry): Make 16-bit safe. + +1999-09-19 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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. + +Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * patchlvl.h (SCMVERSION): Bumped from 5d0 to 5d1. + +1999-09-12 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * x.c (init_x): Load "xevent.scm". + + * xtest.scm: Test key-press event. + + * xevent.h: Generated by "xgen.scm" + + * xevent.scm: Generated by "xgen.scm" + + * requires.scm: Sample "require.scm". + +1999-09-11 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * Xlibscm.texi (Event): Documented x:event-ref. + +1999-08-26 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c (scm_egc): More robust test for sufficient cells in + freelist. + +1999-08-24 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (wrapenv): Will no longer wrap an already wrapped + environment. + + * repl.c (def_err_response): Now prints "expand-time environment" + message only when relevant. + +1999-08-21 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * xgen.scm (event-map): Added. + + * x.c: Absorbed event_names into "xevent.h". + +1999-08-20 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c (def_err_response): Error message for expand-time only + environment. + + * 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, + LETREC-SYNTAX. + + (ceval_1): Fixed bug in eval. + + * scm.h (ENVP): exported macro from eval.c. + +1999-08-18 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (apply): Removed some unreached statements, merged + duplicate code in tc7_specfun case. + +1999-08-17 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c: (ceval_1): Made EVAL tail recursive. + Cleaned up some stack tracing cases, renamed POP_TRACE + to TOP_TRACE, since POP_TRACE sounds as though it should be the + inverse of PUSH_TRACE. + + (ceval_1): Now modifies stack trace only after an estk + frame may be pushed, that is, when some invocation of eval may + modify the environment. The bottom of the stack trace (the form + being evaluated during a call to a subr) is kept in a global + `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 + tracing. + + * repl.c (scm_stack_trace): Now may print out the value of the + global `scm_trace' as the top of the stack trace. + +1999-08-13 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c: Include <sys/types.h> for Cygwin, needed for select + support macros. + * scmfig.h: Define HAVE_SELECT for the Cygwin environment. + +1999-07-23 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c (scm_stack_trace): Put semi colons after frame numbers in + stack trace, rather than colons so emacs will not try to balance + parens. + +1999-07-20 Radey Shouman <Radey_Shouman@splashtech.com> + + * build: Require build.scm in program-vicinity, since build.scm + may not be installed in implementation-vicinity. + +1999-07-19 <radey@cartman.colorage.net> + + * repl.c (def_err_response): Changed setjump to setjmp when + setting up safeport. + +1999-07-11 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * Makefile (incdir): Added to abstract include directory location. + + * xgen.scm: Rewritten. generates xevent.h and xevent.scm from + <Xlib.h>. + + * inc2scm (scm<-usr/includes): System include path can be passed + as argument. + +1999-07-07 Radey Shouman <Radey_Shouman@splashtech.com> + + * unif.c (arrayp): Fixed problem with immediate arguments. + + (scm_prot2type): Added, abstracts prototype -> + internal-array-type mapping. Accepts positive bignums as uvect + 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. + + SINGLES no longer need to be #DEFINEd in order to allow fvects. + + * ramap.c: Modifications for fvects if SINGLES not #DEFINEd. + +1999-07-06 Radey Shouman <Radey_Shouman@splashtech.com> + + * r4rstest.scm: Added named LET test for scope of init forms. + * eval.c (m_let): Changed scope of init forms in named LET, to + 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> + + * crs.c (lwinsch): Renamed from lwinsert. Why were idlok and + nodelay commented out? + +1999-07-02 "Dai INUKAI(GAF05" <GAF05426@nifty.ne.jp> + + * rgx.c: __FreeBSD__ include should be "gnuregex.h". + +1999-05-31 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Xlibscm.texi: Pulled out of "scm.texi". + +1999-05-29 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scl.c (llog2 lpow10): renamed from log2 and lpow10, which + conflicted with djgpp include file /d/djgpp/include/math.h. + +1999-05-15 Dai INUKAI <GAF05426@nifty.ne.jp> + + * Transcen.scm (expt): R5RS: 0^z is 1 if z = 0 and 0 otherwise. + * r4rstest.scm (test-inexact): Added tests for EXPT of zero. + +1999-05-12 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (lookupcar): Combined some error checking cases. + + (scm_macroexpand1): + (scm_extended_env): + (scm_env_ref): Low level support for hygienic macro expansion. + + * Macroexpand.scm (macro:expand): Added for hygienic macro expansion. + + * Macro.scm (renaming-transformer): Now passes a memoizing RENAME + procedure, so that renaming the same identifier results in renamed + identifiers that are EQV? per "Hygienic Macros Through Explicit + Renaming". + + * Init5d0.scm (defconst): Now allows redefinitions without effect + in the sense of EQUAL? rather than EQV? to allow reloading code + defining constant list structure. + +1999-05-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * r4rstest.scm (test-eq?-eqv?-agreement): Added tests for eqv? + vs. eq? agreement discussed in section "Equivalence predicates". + +1999-05-09 Arne Glenstrup <panic@diku.dk> + + * Makefile (udscm5): Added '-s $(IMPLPATH)' for executable builds. + +1999-04-26 Radey Shouman <Radey_Shouman@splashtech.com> + + * scl.c (inex_divbigbig): Was broken (did not return valid SCM) + for some cases. + +1999-04-22 Radey Shouman <Radey_Shouman@splashtech.com> + + * r4rstest.scm (test-inexact-printing): Added to check that + (EQV? X (STRING->NUMBER (NUMBER->STRING X))) holds for inexact X. + + * scl.c (iflo2str): Revamped so that (EQV? X (STRING->NUMBER + (NUMBER->STRING X))) holds for floating point X. Somewhat as in: + Burger & Dybvig + "Printing Floating-Point Numbers Quickly and Accurately" + <http://www.cs.indiana.edu/scheme-repository/doc.publications.html> + But floating point rather than bignum arithmetic is used -- due to + this state of sin one slop factor was introduced. It would be + good to check this on non-IEEE-754 architectures. + + (istr2flo): Now reads floating point numbers with exponents somewhat + below -MAXEXP, since this such numbers can be represented with + gradually underflowing denormals. + +1999-04-15 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * Makefile (require.scm): Added constructor. + +1999-04-01 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c (scm_maksubr): Added, returns a subr not (yet) bound to an + interned symbol, abstracts the addition of the subr_table entry. + (make_subr): Now uses scm_maksubr. + + * gsubr.c (make_gsubr): Now uses scm_maksubr (was buggily using + old subr name encoding.) + + * eval.c (make_synt): Now uses scm_maksubr. + + * scm.h: Added prototypes for make_gsubr, scm_maksubr. + +1999-03-26 Arne John Glenstrup <panic@diku.dk> + + * scm.h (ptobfuns): added const to puts() and fwrite() prototypes. + + * gmalloc.c: fixed compilation on hpux. + +1999-03-26 Radey Shouman <Radey_Shouman@splashtech.com> + + * Init5d0.scm (identity): Now a subr: CR. + * eval.c + * gsubr.c + * repl.c + * scm.h + * subr.c + * sys.c (SNAME): Pointers to subr names now kept in a mallocated + data structure, the top 16 bits of the CAR of a subr is an index + into this table. Eventually this should help support eg generic + arithmetic. + +1999-03-25 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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> + + * Init5d0.scm (exec-self): Undo *script* meta-argument processing. + +1999-03-18 Radey Shouman <Radey_Shouman@splashtech.com> + + * Init5d0.scm (read:sharp): Simplified somewhat; again accepts + '#2((a b c) (1 2 3)) as array read syntax, with warning. + +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. + + * Init5d0.scm (read:sharp): New read syntax for uniform vectors + and arrays. + +1999-03-16 Radey Shouman <Radey_Shouman@splashtech.com> + + * x.c (scm2int_pair): Generalized to accept uniform vectors and + arrays. + + * eval.c + * ramap.c + * repl.c + * rope.c + * scl.c + * scm.h + * sys.c + * unif.c + Added uniform vector type for signed short integers, tc7_svect. + The prototype is the symbol 'short, the print representation is + not currently readable. (Both items subject to change.) + +1999-03-11 Aubrey Jaffer <jaffer@ai.mit.edu> + + * x.c (x:close): Merged from x:close-display and x:destroy-window. + Flushes after closing window. + + * x.c: Use OPN and other bits in type-word. Fixed GC of closed + windows and displays. + +1999-03-10 Aubrey Jaffer <jaffer@ai.mit.edu> + + * x.c: Added copyright notice. + +1999-03-07 Aubrey Jaffer <jaffer@ai.mit.edu> + + * mkimpcat.scm (edit-line): editline -> readline. + + * Makefile (mydlls): build edit-line separately to link in + libraries correctly. + +1999-02-17 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * build.scm, mkimpcat.scm, x.c, x.h, x11.scm, xgen.scm, xscm.doc, + xtest.scm: Xlib interface from xscm-2.01 + +1999-02-12 Hakan L. Younes <d93-hyo@nada.kth.se> + + * build.scm, findexec.c, scm.c, scm.texi, scmfig.h, time.c: + amiga-gcc port. + +1999-02-11 Aubrey Jaffer <jaffer@ai.mit.edu> + + * repl.c (scm_warn): renamed from warn(). + +1999-02-04 Radey Shouman <Radey_Shouman@splashtech.com> + + * setjump.h + * repl.c (scm_stack_trace): + * sys.c (safewrite): + Made all safeport operations consistently use the standard C + setjmp, longjmp, and jmp_buf. + +1999-01-27 Aubrey Jaffer <jaffer@ai.mit.edu> + + * build.scm (build): -Dfreebsd no longer necessary for freebsd + builds. + + * findexec.c: freebsd -> __FreeBSD__. + * ioext.c: freebsd -> __FreeBSD__. + * time.c: freebsd -> __FreeBSD__. + +1999-01-27 Bakul Shah <bakul@torrentnet.com> + + * sys.c (add_final): Fixed call to scm_grow_gra. + + * subr.c (promisep): Added PROMISE? + +1999-01-23 Aubrey Jaffer <jaffer@ai.mit.edu> + + * build.scm (obj->): Added (was called but not defined). + +1999-01-17 Aubrey Jaffer <jaffer@ai.mit.edu> + + * 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> + + * patchlvl.h (SCMVERSION): Bumped from 5c4 to 5d0. + +1999-01-16 Aubrey Jaffer <jaffer@ai.mit.edu> + + * ramap.c (init_ramap): definition for ARRAY-INDEXES added. + + * scmmain.c (generic_name): Added (local char** init wasn't + portable). + +1999-01-12 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Makefile (version.txi): support added. + + * scm.texi (SCM_VERSION): abstracted to version.txi. + +1999-01-12 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * build (make-readme): moved (require 'posix) here. + +1999-01-11 Aubrey Jaffer <jaffer@ai.mit.edu> + + * build.scm (read-version): simplified. + + * build (make-readme): added. Makes README from scm5c4.info. + +1999-01-11 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * Makefile (README): added target. + + * build (print-manifest): added. + + * scm.texi: Added spacing workaround for Texinfo @deftypefun bugs. + (Problems *): @table --> @multitable. + (Standards Compliance): Updated for R5RS. + (SCM Options): fixed - and --; @minus{} breaks TeX! + +1999-01-10 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.texi (Scripting): renamed from Shell Scripts. Reorganized; + rewrote examples. + (SCM Options): fixed -- as well as texinfo can. + + * Init5c4.scm (boot-tail): load *script* if not done by options. + + * script.c (script_process_argv): Allow space between #! and + pathname. + + * scm.c (scm_init_from_argv): gets additional argument + `script_arg', which becomes the value of *script*. + + * ioext.c (director-for-each): fail gracefully if can't open + directory. + +1999-01-08 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * scm.texi (Smob Cells): Explained NUMDIGS_MAX limit. + + * sys.c (init_storage): Added check for NUMDIGS_MAX. + + * scmfig.h (NUMDIGS_MAX): moved from "scm.h". Reduced to 1000 + (4816 decimal digits). + +1999-01-04 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.texi (Embedding SCM): Added libtest.c example. + + * Makefile (libtest): Added target. + + * scm.c (dirsep): added variable. + + * 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> + + * scm.texi (Unix Shell Scripts): merged in "SCSH scripts". + Removed description of single non-\ argument on first script line. + +1999-01-03 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.texi (Embedding SCM): Rewrote. + + * repl.c (scm_top_level): Pass initpath string to boot-tail + (rather than #t) for dumped executables. + + * scmfig.h (RTL): removed. main() is now in scmmain.c. + + * build.scm (C-libraries): Added `lib', which excludes + "scmmain.c"; Removed RTL flag. + + * dynl.c (init_dynl): Don't try to compute execpath. + + * script.c (find_impl_file): Renamed from scm_find_impl_file. + Fixed reduntant "lib" check. Added tests for executable-name peer + and generic peer directories. + + * Init5c4.scm (set-vicinities!): Simplified. Now takes init-file + argument. + + * scmmain.c: created, stealing main() and scm_find_implpath() from + "scm.c". + + * scm.c (scm_find_impl RTL main): removed. + +1999-01-02 Aubrey Jaffer <jaffer@ai.mit.edu> + + * repl.c, scm.c: moved initpath==0 argument handling from main to + scm_top_level(). + + * Makefile: Redundant DFLAG = -DIMPLINIT=\"$(IMPLINIT)\" removed. + IMPLINIT still #defined by scmflags.h. + +1998-12-18 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Link.scm (compile-file): Converted from replace-suffix to + filename:substitute??. + + * build.scm (c->): Added. + (c->o): Added. + (c->obj): Added. + (obj->exe): Converted from replace-suffix to filename:substitute??. + +1998-12-15 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (ecache_eval_args): Added, allocates an environment frame + in the ecache and does argument number checking for closures with + >= 3 arguments (and no rest argument). + (asubr_apply): Added to apply multiargument rpsubrs and asubrs without + consing. + + * sys.c (scm_env_v2lst): Added for ecache_eval_args, builds a list + of ecache cells from an argument vector. + +1998-12-14 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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. + +1998-12-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * sys.c (VERIFY_INTS): Pass 0L rather than 0 for null pointer args. + + * scm.c: Pass 0L rather than 0 for null pointer args. + + * rgx.c (lregerror): Pass 0L rather than 0 for null pointer args. + +1998-12-09 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c (scm_top_level): Now takes a second argument, toplvl_fun, + which is a function of no arguments returning SCM. If this + variable is non-null, it will be called instead of repl(), if + toplvl_fun returns BOOL_T, it may be called again, otherwise + scm_top_level will return. + + Now checks that BOOT-TAIL is non-immediate before applying it, so + that it becomes optional. + + * scm.c (run_scm): Deleted, subsumed by main(). + + * patchlvl.h (INIT_FILE_NAME): #defined even for RTL case. The + init file is probably useful even if the default top level is not + used. + + * eval.c (varcheck): Now counts required arguments so m_lambda + doesn't have to. + +1998-12-08 Radey Shouman <Radey_Shouman@splashtech.com> + + * Macro.scm (Macro:compile-syntax-rules) Check that car of each + rule is a pair. + +1998-12-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.c (main): Changed argc==0 argv[0] from "scm" to + GENERIC_NAME. + +1998-12-06 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.texi (Embedding SCM): Changed from "Calling Scheme From C". + + * scm.c (scm_execpath scm_find_executable): moved from repl.c. + (init_banner): Changed to use pre-processor concatenation. + (main): modularized. + (run_scm): freeall argument added to control calling of + free_storage(). + + * repl.c (scm_top_level): initpath with leading '(', ';', or + whitespace taken as string to load (rather than filename). + (init_sbrk): extracted from main(). + + * dynl.c (init_dynl): ifdef RTL removed. + +1998-12-06 Radey Shouman <Radey_Shouman@splashtech.com> + + * subr.c + * scl.c (scm_intexpt): Special cases for arithmetic that can be + 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 + control memoization of local variables to ilocs. + +1998-12-05 Aubrey Jaffer <jaffer@ai.mit.edu> + + * repl.c (tryload): Removed TAIL_RECURSIVE_LOAD version. + (scm_top_level): If string argument starts with whitespace, `)', or + `;', then call scm_ldstr() with argument rather than scm_ldfile(). + + * build.scm (compile-dll-c-files linux): delete .o after making .so. + + * scm.c (init_scm): Rest of inits moved into. + (final_scm): Handles finals. + (scm_init_from_argv): Handles universal argv processing; + platform-dependent argv processing remains in main(). + +1998-12-04 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c (def_err_response): Fixed to print stack trace even if + err_exp is not defined. + + * repl.c + * sys.c + * scm.h errjmp_bad is now a pointer to a string, rather than an + int, so that the final error message can say in which critical + code section the error occured. + +1998-12-03 Aubrey Jaffer <jaffer@ai.mit.edu> + + * repl.c (scm_top_level): renamed from repl_driver. + +1998-12-03 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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 + converting them to doubles for calculating inexact results. + (big2scaldbl): (bigdblop): (inex_divbigbig): Auxiliary functions + added. + (idbl2str): Decrease minimum exponent to allow printing of + gradually underflowing IEEE doubles. + + * scm.c (setitimer): Made each option individually controlled by #ifdef, + now returns #f instead of error if given an unsupported option. + + * Init5c4.scm This is used to initialize the appropriate alarm + procedures. + +1998-12-02 Radey Shouman <Radey_Shouman@splashtech.com> + + * scm.h (NUMDIGS): Added cast so that NALLOC error reports would + print correctly. + +1998-12-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * setjump.h: windframe removed -- dowinds could only be processed + while (possibly oversize) stack was intact. + + * scm.h (ARGn .. PROF_SIGNAL): Special err_pos values renumbered + from 1; this allows 0 to indicate message has been printed. + (dynwinds): restored to sys_protects. + + * repl.c (repl_driver): dowinds() call moved from abrt(), quit(), + and restart(); dowinds() now done after longjump. + (repl_driver): cur_inp being closed now indicates that SCM should + exit -- after printing error messages. + (def_err_response): err_pos = 0 after printing message. If + err_pos==0, don't print message. + + * Init5c4.scm (fluid-let): Shrunk using multi_set returns. + + * eval.c (scm_multi_set): Now returns new list of old values. + + * scm.c (l_pause): DJGPP2.0 lacks ITIMER_VIRTUAL; can't quit SCM! + #undef SIGPROF if ITIMER_VIRTUAL not defined. + + * sys.c (reset_safeport): fixed 16-bit argument to + must_malloc_cell. + (dowinds): fixed limit case behavior. + +1998-12-01 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Init5c4.scm (fluid-let): defmacro added. + + * eval.c (scm_multi_set): Added. (set! (a b c) (list 10 20 30)) + sets 3 variables. + + * sys.c (dowinds): Eliminated second argument. + (dynwinds): No longer a sysprotect. + + * setjump.h (windframe): Dynamic wind information now kept in + linked struct windframe on C-stack. + +1998-12-01 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c safeport now includes jmp_buf, to which it will longjump + after writing its character limit. This makes it safe to print + out possibly circular structures in error handling routines. + (reset_safeport): Now returns non-zero only if its argument + really was a safeport. + + * setjump.h (SAFEP_JMPBUF): Macro accessor for the jmp_buf, + setjump *must* be called with this argument before using a + safeport. + + * repl.c (scm_stack_trace): (def_err_response): Use new + safeport features. + + * Macro.scm (substitute-in-template): Added check that all pattern + variables combined in an ellipsis template have the same length. + +1998-11-29 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.texi (Socket): examples updated to use wait-for-input; no + longer spin-wait. + + * repl.c (wait_for_input): `select'-like procedure added. + (char_readyp): now supported by DJGPP. + + * ioext.c (l_putenv lexec*): DJGPP now supports. + + * scm.c (l_raise SIGALRM): DJGPP now supports. + + * scmfig.h: include <float.h> now seems safe for DJGPP. + +1998-11-28 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scm.texi (Data Type Representations): PTOBs had wrong code and + lsubr was missing! + +1998-11-26 Aubrey Jaffer <jaffer@ai.mit.edu> + + * repl.c (def_err_response): Now truncates ALL long expressions + being printed. + + * sys.c (must_malloc must_malloc_cell): 0 -> 0L to fix 16-bit + scmlit. + +1998-11-26 Radey Shouman <rshouman@metro2000.com> + + * 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. + +1998-11-25 Radey Shouman <Radey_Shouman@splashtech.com> + + * repl.c (scm_stack_trace): Changed numbering of stack frames. + (def_err_response): Now prints erring expression before + stack trace. + (init_tables): Removed unnecessary assignment to + scm_verbose, which was already 1 under any circumstances. + (def_err_response): Now truncates long expressions being + printed. + (err_head): More robust test for output to stderr, to + decide whether to call perror or not. + + * 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 + sys_protects earlier, in case allocating ptobs or smobs causes + errors to be thrown. + +1998-11-24 Radey Shouman <Radey_Shouman@splashtech.com> + + * scm.h (NUM_IFLAGS): Added to make COOKIE, UNCOOK definitions a + little easier to read. + + * sys.c (reset_safeport): Added, resets count and optionally + parent port on a safe-port. + (sys_safep): New sys_protect, so stack-trace doesn't have to + 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): + Now checks and dies horribly but predictably if def_err_response + is recursively entered. + +1998-11-20 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (env2tree): Check for undefineds in environment to + prevent endless loop, substitute #<unspecified>. + * repl.c (stack_trace): Now uses safe ports, prints "STACK TRACE" + message (I don't remember when that disappeared) and prints at + most 12 traced frames. + + * 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): + (rec_constr1): Better error reporting, including the name of the + expected record type and the relevant field. + + (rec_prinset): Added PRINTER field to RTDs so they may be printed + by a user- specified procedure. Scheme signature: + (RECORD-PRINTER-SET! RTD PRINT-PROCEDURE) where PRINT-PROCEDURE + takes as arguments the record and a port. + + Added local accessor macros for record & rtd fields, removed + questionable union type declarations. + +1998-11-18 Radey Shouman <Radey_Shouman@splashtech.com> + + * Macro.scm (macro:compile-syntax-rules): Minor cleanup, made + internal rule representation a record type rather than list. + (renaming-transformer): Added to support `explicit + renaming' low-level macros. + + * 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. + +1998-11-16 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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 + respective alarms, so that restarting does not cause an error when + an alarm is pending. + + * sys.c (gc_mark): Now marks the header of smobs and ptobs, so the + mark function doesn't have to. + * unif.c: + * record.c: + * rgx.c: + * rope.c: + * scm.h: Ptob and smob mark functions modified to not mark headers. + +1998-11-15 Radey Shouman <rshouman@metro2000.com> + + * eval.c (bodycheck): Removed, was only used in m_do. + (m_do): No longer calls bodycheck. + (lookupcar): No longer memoizes if no checking is to be done, eg + if doing speculative expansion. + (macroexp1): Now saves car in local variable to avoid calling + unmemocar. + (uniqcheck): Added, checks for non-unique identifiers in a binding + list. + (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> + + * scmfig.h (SCM_NEED_FDS SCM_INTERRUPTED): added argument to make + clear that this is not a constant. + +1998-11-11 Radey Shouman <Radey_Shouman@splashtech.com> + + * scmfig.h (SCM_INTERRUPTED): Abstracted the interrupted test from + SYSCALL. + (SCM_OPENCALL): Similar to SYSCALL, but will gc to reclaim + file descriptors. + + * sys.c (try_open_file): Now uses SCM_OPENCALL. + (gc_for_open_files): Added. + + * ioext.c: + * posix.c: + * socket.c: File opening system calls now use SCM_OPENCALL. + 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> + + * Init5c4.scm (vicinity:suffix?): Abstracted from + pathname->vicinity and "Link.scm". + +1998-11-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * sys.c, scm.c, record.c, ramap.c: Changed some intern -> sysintern. + + * build.scm (compile-c-files linux): gcc -O2 produces unreliable + objects for Cyrix 6x86 processor; -O2 option removed. + +1998-11-05 Aubrey Jaffer <jaffer@ai.mit.edu> + + * 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): + (ESTK_PARENT_INDEX): SCM_ prepended, definition moved to scm.h, + now used in repl.c. + + * repl.c (handle_it): Fixed so stack traces extend before + interrupt handler calls. + (scm_stack_trace): Fixed for segmented environment stack. + +1998-11-03 Aubrey Jaffer <jaffer@ai.mit.edu> + + * repl.c (def_err_response): print out errobj if short string; if + long string, print out first 57 characters and "...". This makes + messages about not finding Init???.scm more informative. + +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> + + * ioext.c (directory-for-each): Added. + + * Makefile (build): Added to TAGS. + +1998-11-02 Radey Shouman <radey_shouman@splashtech.com> + + * sys.c (makcclo): Fixed argument to ASSERT. + +1998-11-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * 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. + + * scmfig.h sys.c (SHORT_SIZET): Added to detect whether sizet + width or LENGTH field more restrictive. + + * rope.c (must_free_argv): changed to use must_free. + + * scm.h (LENGTH_MAX): Changed from fixed constant to cpp computed. + (NUMDIGS_MAX): Added. + +1998-11-01 Aubrey Jaffer <jaffer@ai.mit.edu> + + * sys.c (gc_sweep): Continuation storage was not being counted + when freed. + + * time.c (your_time): fixed scaling so numbers returned use full + INUM range. + +1998-10-29 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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): + 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> + + * scm.c (scm_init_extensions): Added call to init_user_scm + for RTL case. + Moved #ifndef RTL to insure DIRSEP and GENERIC_NAME are #defined + for RTL case. + + * build.scm Now builds archive called libscm.a rather than scm.a + +1998-10-20 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Init5c3.scm (with-XXX-to-port): Oops. fixed earlier change. + +1998-10-19 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * 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, + prevents compiler warning under hpux. + + * sys.c (scm_free_gra): Now sets elts pointer to zero. + (free_storage): scm_free_gra now sets smobs and ptobs to zero. + (egc_sweep): Give dead cells immediate values, prevents obscure + gc bug seen in hpux. + + * sys.c (scm_estk_grow): (scm_estk_shrink): Deleted incorrect + DEFER/ALLOW_INTS. + + (init_storage): SHORT_INT fixconfig message now suggests changing + scmfig.h rather than setjump.h + +1998-10-16 Basile STARYNKEVITCH <Basile.Starynkevitch@wanadoo.fr> + + * repl.c (lreadr): linum now incremented for LINE_INCREMENTORS + within strings. + +1998-10-16 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scmfig.h (SHORT_INT): __alpha is. + +1998-10-14 Radey Shouman <Radey_Shouman@splashtech.com> + + * eval.c (apply): Deleted redundant DEFER_INTS_EGC, added + ALLOW_INTS_EGC to closure apply case. + +1998-10-13 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c (egc_copy_stack): Provide strict bound on live locations. + + * eval.c (apply): Added default case for tc7_specfun type, + replaces special handling for (apply apply ...) and (apply + call-with-current-continuation ...) + +1998-10-12 Radey Shouman <Radey_Shouman@splashtech.com> + + * scm.h (ISYMSETVAL): renamed to MAKISYMVAL. + + * 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 + 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_extend_env): Rewritten using local temporary for indexing + into ecache. + +1998-10-06 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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> + + * build.scm (read-version): Will use implementation-vicinity if + scm-srcdir does not contain "patchlvl.h". + +1998-10-03 Radey Shouman <Radey_Shouman@splashtech.com> + + * scm.c (run_scm): Fixed finals call loop + +1998-10-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * 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(). + + * scm.h, repl.c, dynl.c, continue.h: + CodeWarrior-Pro-3 port from Bob Schumaker <cobblers@netcom.com> + +1998-10-01 Bob Schumaker <cobblers@netcom.com> + + * dynl.c: must_free_argv() was called with extra argument! + + * continue.h (SHORT_ALIGN): Port for `CodeWarrior Pro 3'. + + * repl.c, scm.h: declarations added for `CodeWarrior Pro 3'. + +1998-09-29 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Link.scm (link-named-scm): simplified; prepping for hobbit5. + +1998-09-29 Radey Shouman <Radey_Shouman@splashtech.com> + + * scm.c Added SIGVTALRM callback. + + * Init5c3.scm (profile-alarm-timer): Renamed from profile-timer, + (virtual-alarm-timer): added. + + * 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. + +1998-09-29 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * build (build-from-argv): slib:warns if not successful. + (bi): Exits with error indication when build not successful. + + * build.scm (build): Sense was wrong; heap-can-shrink renamed + no-heap-shrink + (batch:rebuild-catalog): always return #t. + +1998-09-22 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c (scm_init_gra): (scm_grow_gra): (scm_free_gra): GRowable + Array 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 + SETITIMER. + + * sys.c (sysintern): No longer changes the CDR of an existing + symhash value cell if second argument is UNDEFINED. For use with + scm_setitimer, which uses symbols as keys, but not as identifiers. + + * scm.c (scm_proftimer): Removed. + (scm_setitimer): Added, interface to setitimer/getitimer allowing + use of ITIMER_REAL, ITIMER_VIRTUAL, ITIMER_PROF. + +1998-09-18 Aubrey Jaffer <jaffer@colorage.com> + + * posix.c (scm_getgroups): added scm_protect_temp(&grps); + +1998-09-17 Aubrey Jaffer <jaffer@ai.mit.edu> + + * 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! + + * repl.c (set_inp set_outp set_errp): Made variable swap atomic. + Also changed so port argument can be closed. + +1998-09-17 Radey Shouman <Radey_Shouman@splashtech.com> + + * sys.c (init_storage): Fixed estk initialization to work when + restarted. + +1998-09-16 Radey Shouman <Radey_Shouman@splashtech.com> + + * Init5c3.scm (read:sharp-char): Added, parses emacs style meta + and control char syntax. + + * repl.c (lreadpr): Added callout to READ:SHARP-CHAR for otherwise + undefined #\ read sequences, memoized references to READ:SHARP. + + * unif.c (resizuve): Fixed accounting of mallocated storage for + strings and bitvectors. + + * 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 + on #define DEBUG_GMALLOC. + + (gc_sweep): Fixed accounting of bignum storage for DIGSTOOBIG case. + + (intern): Avoid possible race condition by deferring ints during + search. + + * scm.c (process_signals): Process from low numbers to higher, ala + Unix signals. More fatal errors should come earlier in the list. + Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * patchlvl.h (SCMVERSION): Bumped from 5c2 to 5c3. @@ -5,7 +1351,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-09-11 Radey Shouman <Radey_Shouman@splashtech.com> * gmalloc.c: Imported gmalloc.c from emacs 20.2.1. - + (check_block): (check_frag_blocks): Debugging functions added. * sys.c (scm_protect_temp): Added, is currently, and probably will @@ -15,7 +1361,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. - + * rgx.c (lregcomp): Added call to scm_protect_temp. 1998-09-04 Radey Shouman <radey@colorage.com> @@ -41,7 +1387,7 @@ 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. * sys.c (sys_errp): Interrupt safe system output port added. @@ -59,7 +1405,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> (closure): Now takes the number of required closure arguments as a second argument. (m_lambda): Computes and memoizes the number of required arguments. - + * 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. @@ -76,7 +1422,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> * Init5c2.scm (array-shape): No longer signals an error when passed a non-array -- now returns whatever ARRAY-DIMENSIONS returned (currently #f). - + 1998-08-26 Aubrey Jaffer <jaffer@colorage.com> * scm.c (scm_proftimer): Also conditional on SIGALRM. @@ -435,7 +1781,7 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> 1998-06-22 Radey Shouman <radey@colorage.com> * eval.c (ENV_PUSH): Fixed problem introduced during last change: - estk was overstepping its bounds. + estk was overstepping its bounds. 1998-06-19 Radey Shouman <radey@colorage.com> @@ -638,7 +1984,7 @@ 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): + (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, diff --git a/Iedline.scm b/Iedline.scm index cbeb265..8c076a0 100644 --- a/Iedline.scm +++ b/Iedline.scm @@ -1,18 +1,18 @@ ;; Copyright (C) 1994, 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -36,14 +36,14 @@ ;; ;; 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. +;; If you do not wish that, delete this exception notice. ;; "Iedline.scm" Scheme interface to readline library ;; Author: Radey Shouman ;; Change both current-input-port and current-output-port to ;; allow line editing of input. -;; All output goes through a soft port in order to detect prompt +;; All output goes through a soft port in order to detect prompt ;; lines, i.e. lines unterminated by a newline. (define (make-edited-line-port) @@ -96,7 +96,7 @@ (set! edit-port #f))) past))) -(and +(and (if (provided? 'unix) (isatty? (current-input-port)) #t) (eq? (current-input-port) (default-input-port)) (not (getenv "EMACS")) diff --git a/Init5c3.scm b/Init5d2.scm index 903003e..946e6d7 100644 --- a/Init5c3.scm +++ b/Init5d2.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1991-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 @@ -12,7 +12,7 @@ ;; ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -42,24 +42,28 @@ ;;; Author: Aubrey Jaffer. (define (scheme-implementation-type) 'SCM) -(define (scheme-implementation-version) "5c3") +(define (scheme-implementation-version) "5d2") +(define (scheme-implementation-home-page) + "http://swissnet.ai.mit.edu/~jaffer/SCM.html") -(define pathname->vicinity - (let ((*vicinity-suffix* +(define vicinity:suffix? + (let ((suffi (case (software-type) - ((AMIGA) '(#\: #\/)) + ((AMIGA) '(#\: #\/)) + ((MACOS THINKC) '(#\:)) ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) - ((MACOS THINKC) '(#\:)) - ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT) '(#\/)) - ((VMS) '(#\: #\]))))) - (lambda (pathname) - ;;Go up one level if PATHNAME ends in a vicinity suffix. - (let loop ((i (- (string-length pathname) 2))) - (cond ((negative? i) "") - ((memv (string-ref pathname i) *vicinity-suffix*) - (substring pathname 0 (+ i 1))) - (else (loop (- i 1)))))))) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\]))))) + (lambda (chr) (memv chr suffi)))) + +(define (pathname->vicinity pathname) + ;;Go up one level if PATHNAME ends in a vicinity suffix. + (let loop ((i (- (string-length pathname) 2))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) ;;; This definition of PROGRAM-VICINITY is equivalent to the one defined ;;; SLIB/require.scm. It is used here to bootstrap @@ -84,18 +88,9 @@ (define library-vicinity #f) (define home-vicinity #f) -(define (set-vicinities!) +(define (set-vicinities! init-file) (set! implementation-vicinity - (let ((vic (if *load-pathname* ;Happens when not dumped. - (program-vicinity) - (let ((path - (or (getenv "SCM_INIT_PATH") - (find-init-file (execpath #t))))) - (if path - (pathname->vicinity path) - (or (and (procedure? implementation-vicinity) - (implementation-vicinity)) - (error "Can't find SCM_INIT_PATH"))))))) + (let ((vic (pathname->vicinity init-file))) (lambda () vic))) (set! library-vicinity (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) @@ -105,11 +100,11 @@ (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))) + (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)))))) @@ -117,13 +112,13 @@ (let ((home (getenv "HOME"))) (and home (case (software-type) - ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + ((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!) +(set-vicinities! *load-pathname*) ;;; Here for backward compatability (define scheme-file-suffix @@ -134,54 +129,71 @@ (set! *features* (append '(getenv tmpnam abort transcript with-file ieee-p1178 rev4-report rev4-optional-procedures - hash object-hash delay dynamic-wind + hash object-hash delay dynamic-wind fluid-let multiarg-apply multiarg/and- logical defmacro - string-port source current-time) + string-port source current-time sharp:semi) *features*)) (define (exec-self) (require 'i/o-extensions) - (execv (execpath) (program-arguments))) + (execv (execpath) (if *script* + (cons (car (program-arguments)) + (cons "\\" + (member *script* (program-arguments)))) + (program-arguments)))) -(define (terms) - (list-file (in-vicinity (implementation-vicinity) "COPYING"))) - -(define (list-file file) +(define (display-file file) (call-with-input-file file (lambda (inport) (do ((c (read-char inport) (read-char inport))) ((eof-object? c)) (write-char c))))) - -(define (read:array digit port) - (define chr0 (char->integer #\0)) - (let ((rank (let readnum ((val (- (char->integer digit) chr0))) - (if (char-numeric? (peek-char port)) - (readnum (+ (* 10 val) - (- (char->integer (read-char port)) chr0))) - val))) - (prot (if (eq? #\( (peek-char port)) - '() - (let ((c (read-char port))) - (case c ((#\b) #t) - ((#\a) #\a) - ((#\u) 1) - ((#\e) -1) - ((#\s) 1.0) - ((#\i) 1/3) - ((#\c) 0+i) - (else (error "read:array unknown option " c))))))) - (if (eq? (peek-char port) #\() - (list->uniform-array rank prot (read port)) - (error "read:array list not found")))) - -(define (read:uniform-vector proto port) - (if (eq? #\( (peek-char port)) - (list->uniform-array 1 proto (read port)) - (error "read:uniform-vector list not found"))) +(define (terms) + (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:array rank port) + (let ((prot + (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)))) (define (read:sharp c port) - (define (barf) (error "unknown # object" c)) + (define (barf c) + (error "unknown # object" c)) + (define chr0 (char->integer #\0)) (define (feature? exp) (cond ((symbol? exp) (or (memq exp *features*) (eq? exp (software-type)))) @@ -195,34 +207,102 @@ (and (feature? (cadr exp)) (feature? (cons 'and (cddr exp)))))) (else (error "read:sharp+ invalid expression " exp)))))) - (case c ((#\') (read port)) - ((#\.) (eval (read port))) - ((#\+) (if (feature? (read port)) - (read port) - (begin (read port) (if #f #f)))) - ((#\-) (if (not (feature? (read port))) - (read port) - (begin (read port) (if #f #f)))) - ((#\b) (read:uniform-vector #t port)) - ((#\a) (read:uniform-vector #\a port)) - ((#\u) (read:uniform-vector 1 port)) - ((#\e) (read:uniform-vector -1 port)) - ((#\s) (read:uniform-vector 1.0 port)) - ((#\i) (read:uniform-vector 1/3 port)) - ((#\c) (read:uniform-vector 0+i port)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (read:array c 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))) - (else (barf)))) + (case c + ((#\') (read port)) + ((#\.) (eval (read port))) + ((#\+) (if (feature? (read port)) + (read port) + (begin (read port) (if #f #f)))) + ((#\-) (if (not (feature? (read port))) + (read port) + (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))) + (else (barf c)))) + +;; 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))))))) + (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)))))))))) + +;;;; Function used to accumulate comments before a definition. +(define comment + (let ((*accumulated-comments* '())) + (lambda args + (cond ((null? args) + (let ((ans + (apply string-append + (map (lambda (comment) + (string-append (or comment "") "\n")) + (reverse *accumulated-comments*))))) + (set! *accumulated-comments* '()) + (if (equal? "" ans) + "no-comment" ;#f + (substring ans 0 (+ -1 (string-length ans)))))) + (else (set! *accumulated-comments* + (append (reverse args) *accumulated-comments*))))))) + +;; Make #; convert the rest of the line to a (comment ...) form. +;; "build.scm" uses this. +(define read:sharp + (let ((rdsharp read:sharp)) + (lambda (c port) + (if (eqv? c #\;) + (let skip-semi () + (cond ((eqv? #\; (peek-char port)) + (read-char port) + (skip-semi)) + (else `(comment ,(read-line port))))) + (rdsharp c port))))) + (define type 'type) ;for /bin/sh hack. (define : ':) @@ -243,7 +323,8 @@ (define >=? >=) (define t #t) (define nil #f) -(define (identity x) x) +(define identity + (if (defined? cr) cr (lambda (x) x))) (if (not (defined? the-macro)) (define the-macro identity)) @@ -268,6 +349,7 @@ ((MS-DOS WINDOWS ATARIST) "r+b") (else "r+"))) (define (_IONBF mode) (string-append mode "0")) +(define (_TRACKED mode) (string-append mode "?")) (define could-not-open #f) @@ -298,16 +380,19 @@ ans)) (define (with-input-from-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-input-port port))))) - (dynamic-wind swaports thunk swaports))) + (dynamic-wind (lambda () (set! port (set-current-input-port port))) + thunk + (lambda () (set! port (set-current-input-port port))))) (define (with-output-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-output-port port))))) - (dynamic-wind swaports thunk swaports))) + (dynamic-wind (lambda () (set! port (set-current-output-port port))) + thunk + (lambda () (set! port (set-current-output-port port))))) (define (with-error-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-error-port port))))) - (dynamic-wind swaports thunk swaports))) + (dynamic-wind (lambda () (set! port (set-current-error-port port))) + thunk + (lambda () (set! port (set-current-error-port port))))) (define (with-input-from-file file thunk) (let* ((nport (open-input-file file)) @@ -361,6 +446,9 @@ (for-each (lambda (x) (set! result x) (write x) (display #\ )) args) (newline) result) +(define (pp . args) + (for-each pretty-print args) + (if #f #f)) (define (file-exists? str) (let ((port (open-file str OPEN_READ))) @@ -396,12 +484,6 @@ (if (not (defined? last-pair)) (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))) -(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 slib:error error) (define slib:warn warn) (define slib:tab #\tab) @@ -431,6 +513,12 @@ (newline cep) (force-output cep)))) +(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 (scm:load file . libs) (define filesuf file) (define hss (has-suffix? file (scheme-file-suffix))) @@ -582,6 +670,14 @@ (define (pretty-print . args) (require 'pretty-print) (apply pretty-print args)) +;; (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)))) + (transcript-on arg)) +(define (transcript-off) + (error "No transcript active")) + ;;; Macros. ;;; Trace gets redefmacroed when tracef autoloads. @@ -597,28 +693,38 @@ (defmacro defconst (name value) (cond ((list? name) `(defconst ,(car name) (lambda ,(cdr name) ,value))) (else (cond ((not (slib:eval `(defined? ,name)))) - ((and (symbol? name) (eqv? (slib:eval value) - (slib:eval name)))) + ((and (symbol? name) (equal? (slib:eval value) + (slib:eval name)))) (else (slib:error 'trying-to-defconst name 'to-different-value value))) `(define ,name ,value)))) (defmacro casev (key . clauses) - (let ((clauses - (map (lambda (clause) - (if (list? (car clause)) - (cons (apply - append - (map (lambda (elt) - (case elt - ((unquote) '(unquote)) - ((unquote-splicing) '(unquote-splicing)) - (else - (eval (list 'quasiquote (list elt)))))) - (car clause))) - (cdr clause)) - clause)) - clauses))) - `(case ,key ,@clauses))) + `(case ,key + ,@(map (lambda (clause) + (if (list? (car clause)) + (cons (apply + append + (map (lambda (elt) + (case elt + ((unquote) '(unquote)) + ((unquote-splicing) '(unquote-splicing)) + (else + (eval (list 'quasiquote (list elt)))))) + (car clause))) + (cdr clause)) + clause)) + clauses))) + +(defmacro fluid-let (clauses . body) + (let ((ids (map car clauses)) + (temp (gentemp)) + (swap (gentemp))) + `(let* ((,temp (list ,@(map cadr clauses))) + (,swap (lambda () (set! ,temp (set! ,ids ,temp))))) + (dynamic-wind + ,swap + (lambda () ,@body) + ,swap)))) (define print-args (procedure->syntax @@ -706,6 +812,25 @@ dims) dims))))) +(define (alarm-interrupt) (alarm 0)) +(if (defined? setitimer) + (begin + (define profile-alarm #f) + (define (profile-alarm-interrupt) (profile-alarm 0)) + (define virtual-alarm #f) + (define (virtual-alarm-interrupt) (virtual-alarm 0)) + (define milli-alarm #f) + (let ((make-alarm + (lambda (sym) + (and (setitimer sym 0 0) ;DJGPP supports only REAL and PROFILE + (lambda (value . interval) + (cadr + (setitimer sym value + (if (pair? interval) (car interval) 0)))))))) + (set! profile-alarm (make-alarm 'profile)) + (set! virtual-alarm (make-alarm 'virtual)) + (set! milli-alarm (make-alarm 'real))))) + ;;;; Initialize statically linked add-ons (cond ((defined? scm_init_extensions) (scm_init_extensions) @@ -726,7 +851,7 @@ (cond ((not *argv*) (set! *argv* (program-arguments)) (cond (dumped? - (set-vicinities!) + (set-vicinities! dumped?) (verbose (if (and (isatty? (current-input-port)) (isatty? (current-output-port))) (if (<= (length *argv*) 1) 2 1) @@ -777,7 +902,8 @@ (lambda () (thunk) (set! complete #t)) - (lambda () (if (not complete) (quit #f))))))) + (lambda () + (if (not complete) (close-port (current-input-port)))))))) (define (do-string-arg) (require 'string-port) @@ -817,7 +943,7 @@ (display " [-- | -s | -] [file] [args...]" cep) (newline cep) (if success? (display success? cep) (quit #f))) - ;; -a int => ignore (handled by run_scm) + ;; -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) @@ -865,8 +991,7 @@ (require 'rev2-procedures)) ((#\3) (require 'rev3-procedures)) ((#\4) (require 'rev4-optional-procedures)) - ((#\5) (require 'dynamic-wind) - (require 'values) + ((#\5) (require 'values) (require 'macro) (require 'eval) (set! *R4RS-macro* #t)) @@ -912,21 +1037,21 @@ which is included in the " There is no warranty, to the extent permitted by law. " )) - (cond ((execpath) - (display " This executable was loaded from ") - (display (execpath)) - (newline))) + (cond ((execpath) => + (lambda (path) + (display " This executable was loaded from ") + (write path) + (newline)))) (quit #t)) ((string-ci=? "help" option) (usage "This is " up-name ", a Scheme interpreter." - (string-append - "Latest info: " - "http://swissnet.ai.mit.edu/~jaffer/" - up-name ".html -" - )) + (let ((sihp (scheme-implementation-home-page))) + (if sihp + (string-append "Latest info: " sihp " +") + ""))) (quit #t)) (else #f)) (usage "scm: unknown option `--" option "'" #f)))) @@ -936,8 +1061,9 @@ There is no warranty, to the extent permitted by law. ((< *optind* (length *argv*)) ;No more opts (set! *argv* (list-tail *argv* *optind*)) (set! *optind* 1) - (cond ((not didsomething) (do-load (car *argv*)) - (set! *optind* (+ 1 *optind*)))) + (cond ((and (not didsomething) *script*) + (do-load *script*) + (set! *optind* (+ 1 *optind*)))) (cond ((and (> (verbose) 2) (not (= (+ -1 *optind*) (length *argv*)))) (display "scm: extra command arguments unused:" @@ -1,18 +1,18 @@ -;; Copyright (C) 1993, 1994, 1995, 1997 Free Software Foundation, Inc. -;; +;; Copyright (C) 1993, 1994, 1995, 1997, 1998 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -36,29 +36,11 @@ ;; ;; 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. +;; If you do not wish that, delete this exception notice. ;;;; "Link.scm", Compiling and dynamic linking code for SCM. ;;; Author: Aubrey Jaffer. -(define cc:command - (let ((default "cc -c")) ;-O removed for HP-UX self-compile - (case (software-type) - ((unix) (if (memq 'sun-dl *features*) - "gcc -g -O -fpic -c" ; If you have problems change -fpic to - ; -fPIC (see GCC info pages). - default)) - (else default)))) - -(define link:command - (case (software-type) - (else "cc"))) - -(define scm:object-suffix - (case (software-type) - ((MSDOS VMS) ".OBJ") - (else ".o"))) - ;;; This is an unusual autoload because it should load either the ;;; source or compiled version if present. (if (not (defined? hobbit)) ;Autoload for hobbit @@ -74,30 +56,34 @@ (string-append "--compiler-options=-I" (implementation-vicinity)) "-c" (begin (require 'glob) - (replace-suffix file (scheme-file-suffix) ".c")) + ((filename:substitute?? (scheme-file-suffix) ".c") file)) "-hsystem" ))) -(define (link-named-scm name . modules) - (load (in-vicinity (implementation-vicinity) "build")) - (let* ((iv (implementation-vicinity)) - (oss (string-append scm:object-suffix " ")) - (command - (list "build" "--type=exe" "-cscm.c" "-hsystem" - (string-append "--linker-options=-L" (implementation-vicinity)) - (apply string-append - "-i" - (map (lambda (n) - (string-append "init_" n)) - modules)) +(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))) + "-o" name)))) + (cond ((>= (verbose) 3) + (write command) (newline))) + (build-from-whole-argv command))))) ;;;; Dynamic linking/loading @@ -114,17 +100,9 @@ (define oloadpath *load-pathname*) (let* ((sl (string-length file)) (lasl (string-length link:able-suffix)) - (*vicinity-suffix* - (case (software-type) - ((NOSVE) '(#\: #\.)) - ((AMIGA) '(#\: #\/)) - ((UNIX) '(#\/)) - ((VMS) '(#\: #\])) - ((MSDOS ATARIST OS/2) '(#\\)) - ((MACOS THINKC) '(#\:)))) (fname (let loop ((i (- sl 1))) (cond ((negative? i) file) - ((memv (string-ref file i) *vicinity-suffix*) + ((vicinity:suffix? (string-ref file i)) (substring file (+ i 1) sl)) (else (loop (- i 1)))))) (nsl (string-length fname)) @@ -166,7 +144,7 @@ (define fil "") (let loop ((i (- (string-length file) 1))) (cond ((negative? i) (set! dir file)) - ((memv (string-ref file i) '(#\: #\])) + ((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))))) @@ -1,4 +1,4 @@ -;; Copyright (C) 1997, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 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 @@ -12,7 +12,7 @@ ;; ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -41,20 +41,20 @@ ;;;; "Macro.scm", Support for syntax-rules macros. ;;; Author: Radey Shouman ;; -;; As in SYNTAX-CASE, the identifier ... may be quoted in a +;; As in SYNTAX-CASE, the identifier ... may be quoted in a ;; SYNTAX-RULES pattern or template as (... ...). ;; ;; THE-MACRO may be used to define macros, eg ;; (define-syntax foo (the-macro and)) -;; defines the syntactic keyword FOO to have the same transformer +;; defines the syntactic keyword FOO to have the same transformer ;; as the macro AND. (require 'rev2-procedures) ;append! (require 'record) (define macro:compile-syntax-rules - ;; We keep local copies of these standard special forms, otherwise, - ;; redefining them before they are memoized below can lead to + ;; 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 (the-macro let)) @@ -63,8 +63,9 @@ (and (the-macro and)) (or (the-macro or))) (let ((var-rtd (make-record-type '? '(name rank))) - (e-pat-rtd (make-record-type '... '(pattern vars)))) - + (e-pat-rtd (make-record-type '... '(pattern vars))) + (rule-rtd (make-record-type 'rule '(pattern inserted template)))) + (define pattern-variable (record-constructor var-rtd '(name rank))) (define pattern-variable? (record-predicate var-rtd)) (define pattern-variable->name @@ -82,10 +83,15 @@ (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 rule->pattern (record-accessor rule-rtd 'pattern)) + (define rule->inserted (record-accessor rule-rtd 'inserted)) + (define rule->template (record-accessor rule-rtd 'template)) + (define (append2 x y) (if (null? y) x (append x y))) - + (define ellipsis? (let (($... (renamed-identifier '... #f))) (lambda (x env) @@ -101,25 +107,26 @@ (car vars) (duplicates? (cdr vars))))) - (define (compile-pattern literals rule env-def) - (let recur ((pat (cdar rule)) + (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 + (error "syntax-rules: duplicate pattern variable:" - dup " in rule " rule))) - (cons compiled - (rewrite-template - (cadr rule) vars env-def))))) + dup " in rule " rule-exp))) + (apply rule + compiled + (rewrite-template + (cadr rule-exp) vars env-def))))) (cond ((null? pat) (k pat vars)) ((identifier? pat) (let ((lit (memq pat literals))) (if lit - (k pat vars) + (k (renamed-identifier pat env-def) vars) (let ((var (pattern-variable pat rank))) (k var (cons (cons pat var) vars)))))) ((pair? pat) @@ -146,7 +153,7 @@ (k (list->vector comp) vars)))) (else (k pat vars))))) - + (define (rewrite-template template vars env-def) (let recur ((tmpl template) (rank 0) @@ -173,7 +180,7 @@ (or (null? (cddr tmpl)) (error "bad ellipsis:" tmpl))) ;; (... ...) escape - (k (car tmpl) (list (car tmpl)) '()) + (k (car tmpl) (list (car tmpl)) '()) (recur (car tmpl) (+ rank 1) '() (lambda (comp1 ins1 op1) (if (null? op1) @@ -203,14 +210,14 @@ ;;; Match EXP to RULE, returning alist of variable bindings or #f. - (define (match literals rule exp env-def env-use) - (let recur ((r rule) + (define (match rule exp env-use) + (let recur ((r (rule->pattern rule)) (x (cdr exp))) (cond ((null? r) (and (null? x) '())) ((pair? r) (if (ellipsis-pattern? (car r)) - (and + (and (list? x) (let ((pat (ellipsis-pattern->pattern (car r)))) (let match1 ((x x) @@ -233,9 +240,7 @@ (let ((v2 (recur (cdr r) (cdr x)))) (and v2 (append2 v1 v2)))))))) ((identifier? r) ;literal - (and (identifier? x) - (identifier-equal? (cdr (assq r literals)) x env-use) - '())) + (and (identifier? x) (identifier-equal? r x env-use) '())) ((pattern-variable? r) (list (cons r x))) ((vector? r) @@ -244,30 +249,35 @@ (else (and (equal? r x) '()))))) - (define (substitute-in-template inserted template vars env-def) + (define (substitute-in-template rule vars env-def) (let ((ins (map (lambda (id) (cons id (renamed-identifier id env-def))) - inserted))) - (let recur ((tmpl template) + (rule->inserted rule)))) + (let recur ((tmpl (rule->template rule)) (vars vars)) (cond ((null? tmpl) tmpl) ((pair? tmpl) (if (ellipsis-pattern? (car tmpl)) - (let ((enames (ellipsis-pattern->vars (car tmpl))) - (etmpl (ellipsis-pattern->pattern (car tmpl)))) - (let ((evals (apply map list - (map (lambda (nam) - (cdr (assq nam vars))) - enames)))) - (append! - (map (lambda (eval) - (recur etmpl - (append! - (map cons enames eval) - vars))) - evals) - (recur (cdr tmpl) vars)))) + (let* ((enames (ellipsis-pattern->vars (car tmpl))) + (etmpl (ellipsis-pattern->pattern (car tmpl))) + (evals (map (lambda (nam) + (cdr (assq nam vars))) + enames)) + (n (length (car evals)))) + (let check ((es (cdr evals))) + (if (pair? es) + (if (= n (length (car es))) + (check (cdr es)) + (error "syntax-rules: pattern variable length mismatch:")))) + (append! + (map (lambda (eval) + (recur etmpl + (append! + (map cons enames eval) + vars))) + (apply map list evals)) + (recur (cdr tmpl) vars))) (cons (recur (car tmpl) vars) (recur (cdr tmpl) vars)))) ((identifier? tmpl) @@ -291,33 +301,22 @@ (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)))) - ;;Rules have the form: (<pattern> <inserted-identifiers> <template>). - (let ((rules - (map - (lambda (rule) - (or (and (list? rule) - (= 2 (length rule))) - (error "Bad rule:" rule)) - (compile-pattern literals rule env-def)) - (cddr x-def))) - (re-lits - (map (lambda (sym) - (cons sym (renamed-identifier sym env-def))) - literals))) - (lambda (x-use env-use) (let loop ((rules rules)) (cond ((null? rules) (error "macro use does not match definition:" x-use)) - ((match re-lits (caar rules) x-use env-def env-use) + ((match (car rules) x-use env-use) => (lambda (vars) - (let ((r (car rules))) - (substitute-in-template (cadr r) - (caddr r) - vars - env-def)))) + (substitute-in-template (car rules) vars env-def))) (else (loop (cdr rules)))))))))))) @@ -327,6 +326,38 @@ (procedure->memoizing-macro (macro:compile-syntax-rules expr env-def))))) +;; Explicit renaming macro facility, as in +;; W. Clinger, "Hygienic Macros Through Explicit Renaming" +(define (macro:renaming-transformer-procedure proc env-def) + (procedure->memoizing-macro + (lambda (expr env-use) + (proc (@copy-tree expr) + (let ((al '())) + (lambda (id) + (cond ((not (identifier? id)) + (error id "non-identifier passed to rename procedure" + expr)) + ((assq id al) => cdr) + (else + (let ((r-id (renamed-identifier id env-def))) + (set! al (cons id r-id)) + r-id))))) + (lambda (id1 id2) + (or (and (identifier? id1) + (identifier? id2) + (error (if (identifier? id1) id2 id1) + "non-identifier passed to compare procedure" + expr))) + (identifier-equal? id1 id2 env-use)))))) + +(define renaming-transformer + (let ((?transformer + (renamed-identifier 'macro:renaming-transformer-procedure #f)) + (?syntax-quote (renamed-identifier 'syntax-quote #f))) + (procedure->memoizing-macro + (lambda (exp env-def) + `(,?transformer ,(cadr exp) (,?syntax-quote ,env-def)))))) + (define define-syntax (syntax-rules () ((define-syntax ?name ?val) diff --git a/Macroexpand.scm b/Macroexpand.scm new file mode 100644 index 0000000..3b658f8 --- /dev/null +++ b/Macroexpand.scm @@ -0,0 +1,370 @@ +;; 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: @@ -1,18 +1,18 @@ -# Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc. -# +# Copyright (C) 1990-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, 675 Mass Ave, Cambridge, MA 02139, USA. +# 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. @@ -36,71 +36,56 @@ # # 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. +# If you do not wish that, delete this exception notice. -# "Makefile" for scm5c3 Scheme Interpreter +# "Makefile" for scm Scheme Interpreter # Author: Aubrey Jaffer SHELL = /bin/sh +CPROTO = cproto #CC = CFLAGS = -g #LIBS = LD = $(CC) -g -# directory where COPYING and Init5c3.scm reside. +# directory where COPYING and InitXXX.scm reside. #IMPLPATH = /usr/local/src/scm/ #this one is good for bootstrapping IMPLPATH = `pwd`/ -# Pathname where Init5c3.scm resides. -IMPLINIT = $(IMPLPATH)Init5c3.scm -DFLAG = -DIMPLINIT=\"$(IMPLINIT)\" +# Pathname where InitXXX.scm resides. +include patchlvl.h +IMPLINIT = $(IMPLPATH)Init$(VERSION).scm -# If pathname where Init5c3.scm resides is not known in advance then +# If pathname where InitXXX.scm resides is not known in advance then # SCM_INIT_PATH is the environment variable whose value is the -# pathname where Init5c3.scm resides. +# pathname where InitXXX.scm resides. intro: @echo - @echo "This is scm$(VERSION). Read \"scm.info\" (from \"scm.texi\")" - @echo "to learn how to build and install SCM." - @echo "Here is a quick guide:" - @echo - @echo " From: bos@scrg.cs.tcd.ie" - @echo " Build and install scripts using GNU autoconf are" - @echo " available as scmconfig.tar.gz in the SCM distribution" - @echo " directories. See README.unix in scmconfig.tar.gz for" - @echo " further instructions." - @echo - @echo " Alternatively:" - @echo " make scmlit" - @echo - @echo " If you are on a non-unix system, create an empty file" - @echo " \"scmflags.h\". Then compile time.c, repl.c, scl.c," - @echo " sys.c, eval.c, subr.c, unif.c, and rope.c. Then link" - @echo " them to create a \"scmlit\" executable." - @echo - @echo " Once you have built scmlit successfully, test it:" - @echo " make checklit" - @echo " If this reports no errors, use scmlit to build" - @echo " fancier versions of scm, with optional features." - -cfiles = 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 \ + @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 -ofiles = time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \ +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 # ramap.o -ifiles = Init5c3.scm Transcen.scm Link.scm Macro.scm - -all: - make mydlls - make myscm -scmlit: $(ofiles) scm.o - $(LD) -o scmlit $(ofiles) scm.o $(LIBS) - make checklit -scm.o: scm.c scm.h scmfig.h patchlvl.h scmflags.h - $(CC) $(CFLAGS) -c $(DFLAG) scm.c +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 + +all: require.scm + $(MAKE) mydlls + $(MAKE) myscm +require.scm: + cp -p requires.scm require.scm + +scmlit: $(ofiles) scmmain.o require.scm + $(LD) -o scmlit $(ofiles) scmmain.o $(LIBS) + $(MAKE) checklit scmflags.h: scmflags scmflags: echo "#ifndef IMPLINIT" > newflags.h @@ -111,6 +96,8 @@ scmflags: .c.o: $(CC) -c $(CFLAGS) $< -o $@ +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 unif.o: unif.c scm.h scmfig.h scmflags.h @@ -121,48 +108,66 @@ time.o: time.c scm.h scmfig.h scmflags.h 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 - $(CC) $(CFLAGS) -c continue.c srcdir=$(HOME)/scm/ udscm4: $(cfiles) $(hfiles) build.scm build - $(srcdir)build -hsystem -o udscm4 -Fcautious \ + $(srcdir)build -hsystem -o udscm4 -s $(IMPLPATH) -Fcautious \ bignums arrays inexact engineering-notation dump dynamic-linking + rm $(ofiles) scmmain.o udscm5: $(cfiles) $(hfiles) build.scm build - $(srcdir)build -hsystem -o udscm5 -Fcautious \ + $(srcdir)build -hsystem -o udscm5 -l debug -s $(IMPLPATH) -Fcautious \ bignums arrays inexact engineering-notation dump dynamic-linking \ macro #-DNO_SYM_GC + rm $(ofiles) scmmain.o -myscm4: udscm4 $(ifiles) +myscm4: udscm4 $(ifiles) require.scm -rm slibcat implcat -mv scm scm~ echo "(quit)" | ./udscm4 -no-init-file -o scm -myscm: udscm5 $(ifiles) +myscm: udscm5 $(ifiles) require.scm -rm slibcat implcat -mv scm scm~ echo "(quit)" | ./udscm5 -no-init-file -r5 -o scm - make check + $(MAKE) check -mylib: +mylib: libscm.a +libscm.a: $(srcdir)build -hsystem -Fcautious bignums arrays inexact \ - engineering-notation dump dynamic-linking -tlib + dynamic-linking -t lib +libtest: libscm.a libtest.c + gcc -o libtest libtest.c libscm.a -ldl -lm -lc + ./libtest pgscm: - $(srcdir)build -hsystem -Fcautious bignums arrays inexact \ - engineering-notation dump dynamic-linking -o udscm \ - --compiler-options=-pg --linker-options=-pg + $(srcdir)build -hsystem -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 -F cautious \ + $(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 echo "(quit)" | ./udgdbscm -no-init-file -r5 -o gdbscm -mydlls: - $(srcdir)build -h system -t dll -c sc2.c rgx.c crs.c edline.c \ - record.c gsubr.c ioext.c posix.c unix.c socket.c \ - ramap.c + +incdir=/usr/include/ +x11.scm: inc2scm Makefile + 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 +x.h: x.c xevent.h + $(CPROTO) x.c > x.h +x.so: x.c x.h xevent.h + $(srcdir)build -h system -Fx -t dll --compiler-options=-Wall +mydlls: x.so + 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 \ + ioext.c posix.c unix.c socket.c ramap.c myturtle: $(srcdir)build -h system -F turtlegr -t dll @@ -202,19 +207,41 @@ report: scm -e"(slib:report #t)" dvidir=../dvi/ -dvi: $(dvidir)scm.dvi -$(dvidir)scm.dvi: $(srcdir)scm.texi $(dvidir)scm.fn Makefile +dvi: $(dvidir)scm.dvi $(dvidir)Xlibscm.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 -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex scm.??) 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 +# 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 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)scm_toc.html: $(srcdir)scm.texi - cd $(htmldir);make scm_toc.html +html: $(htmldir)scm_toc.html $(htmldir)Xlibscm_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) ################ INSTALL DEFINITIONS ################ @@ -223,30 +250,64 @@ exec_prefix = $(prefix) # directory where `make install' will put executable. bindir = $(exec_prefix)bin/ libdir = $(exec_prefix)lib/ +libscmdir = $(libdir)scm/ # directory where `make install' will put manual page. -man1dir = $(prefix)man/man1/ +mandir = $(prefix)man/ +man1dir = $(mandir)man1/ infodir = $(prefix)info/ includedir = $(prefix)include/ -info: $(infodir)/scm.info -$(infodir)/scm.info: scm.texi - makeinfo scm.texi -o $(infodir)/scm.info - install-info $(infodir)/scm.info $(infodir)/dir - -rm $(infodir)/scm.info*.gz - -infoz: $(infodir)/scm.info.gz -$(infodir)/scm.info.gz: $(infodir)/scm.info - gzip -f $(infodir)/scm.info* +README: build build.scm scm.info + scm -l build -e"(make-readme)" + +info: installinfo +installinfo: $(infodir)scm.info $(infodir)Xlibscm.info + +platform.txi: build.scm + scmlit -r database-browse -l build.scm -e "(browse build 'platform)" \ + > platform.txi +features.txi: build build.scm + scmlit -l build -e"(make-features-txi)" +scm$(VERSION).info: version.txi scm.texi platform.txi features.txi + -mv scm.info scmtemp.info + 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 +$(infodir)scm.info: scm.info + cp -p scm.info $(infodir)scm.info + -install-info $(infodir)scm.info $(infodir)dir + -rm $(infodir)scm.info.gz + +Xlibscm.info: version.txi Xlibscm.texi + makeinfo Xlibscm.texi --no-split -o Xlibscm.info +$(infodir)Xlibscm.info: + cp Xlibscm.info $(infodir)Xlibscm.info + -install-info $(infodir)Xlibscm.info $(infodir)/dir + -rm $(infodir)Xlibscm.info*.gz + +infoz: installinfoz +installinfoz: $(infodir)scm.info.gz $(infodir)Xlibscm.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 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.1 $(man1dir) - test -d $(IMPLPATH) || mkdir $(IMPLPATH) - -cp Init5c3.scm Link.scm Transcen.scm Macro.scm COPYING $(IMPLPATH) - -cp mkimpcat.scm Iedline.scm *.sl *.so $(IMPLPATH) + test -d $(libdir) || mkdir $(libdir) + test -d $(libscmdir) || mkdir $(libscmdir) + -cp Init$(VERSION).scm Link.scm Transcen.scm Macro.scm Tscript.scm \ + COPYING $(libscmdir) + test -f $(libscmdir)require.scm || \ + cp requires.scm $(libscmdir)require.scm + -cp mkimpcat.scm Iedline.scm *.sl *.so $(libscmdir) installlib: test -d $(includedir) || mkdir $(includedir) @@ -261,26 +322,29 @@ uninstall: -rm $(includedir)scm.h -rm $(includedir)scmfig.h -rm $(libdir)libscm.a -# -rm $(IMPLPATH)Init5c3.scm -# -rm $(IMPLPATH)Link.scm -# -rm $(IMPLPATH)Transcen.scm -# -rm $(IMPLPATH)COPYING +# -rm $(libscmdir)Init$(VERSION).scm +# -rm $(libscmdir)Link.scm +# -rm $(libscmdir)Transcen.scm +# -rm $(libscmdir)COPYING scm.doc: scm.1 nroff -man $< | ul -tunknown >$@ #### Stuff for maintaining SCM below #### -include patchlvl.h ver = $(VERSION) +version.txi: patchlvl.h + echo @set SCMVERSION $(VERSION) > version.txi + echo @set SCMDATE `date +"%B %Y"` >> version.txi + RM_R = rm -rf ufiles = pre-crt0.c ecrt0.c gmalloc.c unexec.c unexelf.c unexhp9k800.c \ - unexsunos4.c unexalpha.c + unexsunos4.c unexalpha.c unexsgi.c # cxux-crt0.s ecrt0.c gmalloc.c pre-crt0.c unexaix.c unexalpha.c \ # unexapollo.c unexconvex.c unexec.c unexelf.c unexelf1.c \ # unexencap.c unexenix.c unexfx2800.c unexhp9k800.c unexmips.c \ -# unexnext.c unexnt.c unexsgi.c unexsni.c unexsunos4.c +# unexnext.c unexnt.c unexsgi.c unexsni.c unexsunos4.c confiles = scmconfig.h.in mkinstalldirs acconfig-1.5.h install-sh \ configure configure.in Makefile.in COPYING README.unix @@ -288,14 +352,16 @@ confiles = scmconfig.h.in mkinstalldirs acconfig-1.5.h install-sh \ hfiles = scm.h scmfig.h setjump.h patchlvl.h continue.h tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \ - scm.texi ChangeLog -mfiles = Makefile build.scm build build.bat .gdbinit mkimpcat.scm disarm.scm + scm.info scm.texi Xlibscm.info Xlibscm.texi ChangeLog +mfiles = Makefile build.scm build build.bat requires.scm \ + .gdbinit mkimpcat.scm disarm.scm vfiles = setjump.mar setjump.s afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \ - $(vfiles) $(ufiles) + $(vfiles) $(ufiles) $(xfiles) makedev = make -f $(HOME)/makefile.dev CHPAT=$(HOME)/bin/chpat +RSYNC=rsync -v --rsync-path bin/rsync dest = $(HOME)/dist/ temp/scm: $(afiles) -$(RM_R) temp @@ -304,15 +370,30 @@ temp/scm: $(afiles) ln $(afiles) temp/scm release: dist - rsync -v $(htmldir)SCM.html martigny.ai.mit.edu:public_html/ - rsync -v $(dest)README $(dest)scm$(VERSION).tar.gz martigny.ai.mit.edu:dist/ - upload $(dest)README $(dest)scm$(VERSION).tar.gz prep.ai.mit.edu:gnu/jacal/ + 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/ +# upload $(dest)README $(dest)scm$(VERSION).zip ftp.gnu.org:gnu/jacal/ +# $(MAKE) indiana +indiana: + upload $(dest)scm$(VERSION).zip ftp@ftp.cs.indiana.edu:/pub/scheme-repository/incoming + echo -e \ + 'I have uploaded scm$(VERSION).zip to ftp.cs.indiana.edu:/pub/scheme-repository/incoming\n' \ + 'for placement into ftp.cs.indiana.edu:/pub/scheme-repository/imp/' \ + | mail -s 'SCM upload' -b jaffer scheme-repository-request@cs.indiana.edu + +postnews: + echo -e "Newsgroups: comp.lang.scheme\n" | cat - ANNOUNCE | \ + inews -h -O -S \ + -f "announce@docupress.com (Aubrey Jaffer & Radey Shouman)" \ + -t "SCM$(VERSION) Released" -d world + upzip: $(HOME)/pub/scm.zip - rsync -v $(HOME)/pub/scm.zip martigny.ai.mit.edu:pub/ + $(RSYNC) $(HOME)/pub/scm.zip nestle.ai.mit.edu:pub/ -dist: $(dest)scm$(VERSION).tar.gz -$(dest)scm$(VERSION).tar.gz: temp/scm - $(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) tar.gz +dist: $(dest)scm$(VERSION).zip +$(dest)scm$(VERSION).zip: temp/scm + $(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) zip cvs tag -F scm$(VERSION) shar: scm.shar scm.shar: temp/scm @@ -324,12 +405,12 @@ scm.com: temp/scm zip: scm.zip scm.zip: temp/scm $(makedev) PROD=scm zip -distzip: scm$(VERSION).zip -scm$(VERSION).zip: temp/scm turtle turtlegr.c grtest.scm require.scm - $(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) zip - cd ..; zip -9ur $(dest)scm$(VERSION).zip \ - scm/turtle scm/turtlegr.c scm/grtest.scm scm/require.scm - mv $(dest)scm$(VERSION).zip /c/scm/dist/ +doszip: /c/scm/dist/scm$(VERSION).zip +/c/scm/dist/scm$(VERSION).zip: temp/scm turtle turtlegr.c grtest.scm + $(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 pubzip: $(HOME)/pub/scm.zip $(HOME)/pub/scm.zip: temp/scm $(makedev) DEST=$(HOME)/pub/ PROD=scm zip @@ -341,7 +422,7 @@ distdiffs: temp/scm $(makedev) DEST=$(dest) PROD=scm ver=$(ver) distdiffs -HOBBITVERSION = 4d +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 @@ -351,12 +432,12 @@ hobtemp/scm: $(hobfiles) mkdir hobtemp/scm ln $(hobfiles) hobtemp/scm -hobdist: $(dest)hobbit$(HOBBITVERSION).tar.gz -$(dest)hobbit$(HOBBITVERSION).tar.gz: hobtemp/scm +hobdist: $(dest)hobbit$(HOBBITVERSION).zip +$(dest)hobbit$(HOBBITVERSION).zip: hobtemp/scm $(makedev) DEST=$(dest) PROD=scm ver=-hob$(HOBBITVERSION) \ - tar.gz TEMP=hobtemp/ - mv $(dest)scm-hob$(HOBBITVERSION).tar.gz \ - $(dest)hobbit$(HOBBITVERSION).tar.gz + 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 @@ -374,19 +455,17 @@ new: $(htmldir)SCM.html $(htmldir)Hobbit.html \ $(htmldir)SIMSYNCH.html \ /c/scm/dist/install.bat /c/scm/dist/makefile \ - /c/scm/dist/mkdisk.bat README + /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) scm.texi patchlvl.h \ - Init$(ver).scm $(htmldir)SCM.html Makefile + $(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' \ Init$(VERSION).scm Init$(ver).scm cvs commit -m '(SCMVERSION): Bumped from $(VERSION) to $(ver).' cvs tag -F scm$(ver) - if [ -L Init.scm ]; then rm -f Init.scm; else \ - mv -f Init.scm Init.scm~; fi - ln -s Init$(ver).scm Init.scm configtemp/scm: $(confiles) -$(RM_R) configtemp/scm @@ -426,16 +505,18 @@ name8s: scmlit }else p=1;\ l=$$1\ }END{exit stat}' - -ctags: $(hfiles) $(cfiles) - etags $(hfiles) $(cfiles) +ctags: $(hfiles) $(cfiles) $(xfiles) + etags $(hfiles) $(cfiles) $(xfiles) TAGS: -tags: $(hfiles) $(cfiles) $(ifiles) $(vfiles) $(ufiles)\ - scm.texi README build.scm # $(mfiles) ChangeLog hobbit.scm - etags $(hfiles) $(cfiles) $(ifiles) $(vfiles) $(ufiles)\ - scm.texi README build.scm # $(mfiles) ChangeLog hobbit.scm +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 mostlyclean: clean: - -rm -f core a.out ramap.o ramap.obj $(ofiles) scm.o lints + -rm -f core a.out ramap.o ramap.obj $(ofiles) scmmain.o lints -$(RM_R) *temp distclean: clean -rm -f $(EXECFILES) *.o *.obj a.out TAGS implcat slibcat gdbscm @@ -1,93 +1,96 @@ -This directory contains the distribution of scm5c3. Scm conforms to +This directory contains the distribution of scm5d2. Scm conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 -specification. Scm runs under VMS, MS-DOS, OS2, MacOS, Amiga, -Atari-ST, NOS/VE, Unix and similar systems. - -This file consists mainly of excerpts from "scm.info", the result of -compiling (with makeinfo) "scm.texi" to `info' form. In case of -conflicts with "scm.info", consult "scm.info". - -The author can be reached at <jaffer@ai.mit.edu> - - MANIFEST - - `README' is this file. It contains a MANIFEST, INSTALLATION - INSTRUCTIONS, hints for EDITING SCHEME CODE, and a TROUBLE - SHOOTING GUIDE. - `COPYING' details the LACK OF WARRANTY for scm and the conditions - for distributing scm. - `scm.1' is the unix style man page in nroff format. - `scm.doc' is the text man page generated from scm.1. - `QUICKREF' is a Quick Reference card for IEEE and R4RS. - `scm.texi' details feature support and enhancements to Scheme and - contains a SCHEME BIBLIOGRAPHY. - `ChangeLog' documents changes to the scm. - - `r4rstest.scm' is Scheme code which tests conformance with Scheme - specifications. - `example.scm' is Scheme code from Revised^4 Report on the - Algorithmic Language Scheme which uses inexact numbers. - `pi.scm' is Scheme code for computing digits of pi [type (pi 100 5)] - which can be used to test the performance of scm against - compiled C code [cc -o pi pi.c;time pi 100 5]. - `pi.c' is C code for computing digits of pi. - `bench.scm' is Scheme code for computing and recording speed of - "pi.scm". - - `Makefile' is for building scmlit using the `make' program. - `build.scm' creates a database and program for compiling and linking - new SCM executables, libraries, and dlls. - `build.bat' invokes build.scm on MS-DOS platforms. - `mkimpcat.scm' build SCM-specific catalog for SLIB. - `disarm.scm' disables file opening and modifications. - `.gdbinit' provides commands for debugging SCM with GDB. - `setjump.mar' provides setjump and longjump which do not use $unwind - utility on VMS. - `ugsetjump.s' provides setjump and longjump which work on Ultrix VAX. - `setjump.s' provides setjump and longjump for the Cray YMP. - - `Init5c2.scm' is Scheme initialization code. - `Transcen.scm' has Scheme code for inexact builtin procedures. - `Link.scm' has Scheme code for compiling and dynamic linking. - `scmfig.h' is a C include file containing system dependent definitions. - `patchlvl.h is the patchlevel of this release. - `continue.c' code for continuations. - `continue.h' data types and external functions for continuations. - `setjump.h' is an include file dealing with continuations, stacks, - and memory allocation. - `scm.h' has the data type and external definitions of scm. - - `scm.c' has the top level and interrupt code. - `findexec.c' has code to find the executable file. - `time.c' has functions dealing with time. - `repl.c' has error, read-eval-print loop, read, write and load code. - `scl.c' has the code for utility functions which are not part of the - IEEE Scheme spec or which are required for non-integer - arithmetic. - `eval.c' has the evaluator, apply, map, and foreach. - `sys.c' has the code for opening and closing files, storage - allocation and garbage collection. - `rope.c' has C interface functions. - `subr.c' has all the rest of functions. - `sc2.c' has code for procedures from R2RS and R3RS not in R4RS. - `dynl.c' has c code for dynamically loading object files. - `unif.c' has code for uniform vectors. - `rgx.c' has code for string regular expression match. - `crs.c' has code for interactive terminal control. - `split.scm' sets up CURSCM (SCM with crs.c) so that input, output, - and diagnostic output are each directed to separate windows. - `edline.c' Gnu readline input editing - (get ftp.sys.toronto.edu:/pub/rc/editline.shar). - `Iedline.scm' Gnu readline input editing. - `record.c' has code for proposed "Record" user definable datatypes. - `gsubr.c' has make_gsubr for arbitrary (< 11) arguments to C functions. - - `ioext.c' has code for system calls in common between PC compilers and unix. - `posix.c' has code for posix library interface. - `unix.c' has code for non-posix system calls on unix systems. - `socket.c' has code for socket interface. - - SLIB +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' + +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. + + +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 @@ -95,18 +98,19 @@ 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/slib2c3.tar.gz - * prep.ai.mit.edu:pub/gnu/jacal/slib2c3.tar.gz - * ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c3.tar.gz - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c3.tar.gz + * swissnet.ai.mit.edu:/pub/scm/slib2c7.tar.gz -Unpack SLIB (`tar xzf slib2c3.tar.gz' or `unzip -ao slib2c3.zip') in an + * ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz + + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz + +Unpack SLIB (`tar xzf slib2c7.tar.gz' or `unzip -ao slib2c7.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 `Init.scm' is installed). -`require.scm' should have the contents: +(this is the same directory as where the file `Init5d2.scm' is +installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") (load (in-vicinity (library-vicinity) "require")) @@ -128,16 +132,21 @@ Alternatively, you can set the (shell) environment variable SCHEME_LIBRARY_PATH: SCM Variables.). If set, the environment variable overrides `require.scm'. Again, absolute pathnames are recommended. - MAKING SCM + + +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.scm'. `build.scm' 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 +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: * Use SCM on a different platform to run `build.scm' to create a @@ -148,8 +157,8 @@ proceed: * Create your own script or `Makefile'. - * Buy a SCM executable from jaffer@ai.mit.edu. See the end of - `ANNOUNCE' in the distribution for details. + * 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): @@ -161,51 +170,31 @@ proceed: I am moving it to the OLD subdirectory until someone submits an update. - Making SCM with Think C 4.0 or 4.1 - -Note: These instructions need to be uptdated for scm5c3. If Think C -can be called using system(), then SCM can be built using build.scm. - - Edit Scmfig.H to set desired options and IMPLINIT. - from Yasuaki Honda // honda@csl.SONY.co.jp: - Make a project and add source files repl.c, time.c, scm.c, subr.c, - sys.c, eval.c, scl.c, sc2.c, and unif.c to it. - Add libraries MacTraps, unix, ANSI to the project. - The project should be segmented in the following way: - ---------- - repl.c - scm.c - subr.c - sys.c - sc2.c - unif.c - time.c - ---------- - MacTraps - unix - ---------- - ANSI - ---------- - eval.c - ---------- - scl.c - ---------- - Choose 'Set Project Type' from 'Project' menu. - Choose Application from radio buttons. - Set Partition size to 600K. (The default 384K is not enough). - - EDITING SCHEME CODE + + +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 + `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 @@ -224,7 +213,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: @@ -233,152 +222,159 @@ other systems: Typing `(e)' will invoke the editor with the file of interest. After editing, the modified file will be loaded. - TROUBLE SHOOTING - -Reported problems and solutions are grouped under "Compiling", -"Linking", "Running", and "Testing". If you don't find your problem -listed here, you can send a bug report to <jaffer@ai.mit.edu>. The -bug report should include: - - * The version of SCM (printed when SCM is invoked with no arguments). - - * The type of computer you are using. - - * The name and version of your computer's operating system. - - * The values of the environment variables SCM_INIT_PATH and - SCHEME_LIBRARY_PATH. - - * The name and version of your C compiler. - - * 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. - - - Compiling: - -FILE ERROR or WARNING HOW TO FIX - -*.c include file not found Correct status of - STDC_HEADERS - - fix #include statement - or add #define for - system type to scmfig.h - -scm.c assignment between incompatible types change SIGRETTYPE in scm.c - -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. - -sys.c statement not reached ignore - constant in conditional expression ignore - -sys.c: `???' undeclared, outside of functions #undef STDC_HEADERS - in scmfig.h - -scl.c syntax error define system type in - scmfig.h and scl.c (softtype) - - Linking: - -ERROR or WARNING HOW TO FIX - -_sin etc. missing. uncomment LIBS in makefile - - Running: - -PROBLEM HOW TO FIX - -Opening message and then machine Change memory model option -crashes. to C compiler (or makefile). - - Make sure sizet definition is - correct in scmfig.h - - Reduce size of HEAP_SEG_SIZE - in setjump.h - -Input hangs #define NOSETBUF - -ERROR: heap: need larger initial Need to increase the initial - heap allocation using - -a<kbytes> or INIT_HEAP_SIZE. - -ERROR: Could not allocate ... Check sizet definition. - - Get more memory. - - Don't try to run as subproccess - -... in scmfig.h and recompile scm Do it and recompile files. - -ERROR: Init.scm not found Assign correct IMPLINIT in - makefile or scmfig.h or - define environment variable - SCM_INIT_PATH to be the full - pathname of Init.scm (see - INSTALLATION instructions). - -WARNING: require.scm not found define environment variable - SCHEME_LIBRARY_PATH to be the - full pathname of the scheme - library SLIB or change - library-vicinity in Init.scm - to point to library or remove. - See section SLIB above. - - Make sure library-vicinity has - a trailing file separator - (like / or \). - - Testing: (load "r4rstest.scm") or (load "pi.scm") (pi 100 5) - -Runs some and then machine crashes. See above under machine - crashes. - -Runs some and then ERROR: ... Remove optimization option -(after a GC has happened) to C 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_... -output files. in Init.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 -VAX: botched longjmp in scmfig.h -Sparc(SUN-4) heap is growing out of control: +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: 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 \). + + + +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 mSec (0 in gc) 767 cells work, 233 bytes 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 + #<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. `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. + +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. - 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. diff --git a/Transcen.scm b/Transcen.scm index 362420a..7898251 100644 --- a/Transcen.scm +++ b/Transcen.scm @@ -1,18 +1,18 @@ ;; Copyright (C) 1992, 1993, 1995, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -36,7 +36,7 @@ ;; ;; 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. +;; If you do not wish that, delete this exception notice. ;;;; "Transcen.scm", Complex trancendental functions for SCM. ;;; Author: Jerry D. Hedden. @@ -61,7 +61,8 @@ (define expt (let ((integer-expt integer-expt)) (lambda (z1 z2) - (cond ((exact? z2) + (cond ((zero? z1) (if (zero? z2) 1 0)) + ((exact? z2) (integer-expt z1 z2)) ((and (real? z2) (real? z1) (>= z1 0)) ($expt z1 z2)) diff --git a/Tscript.scm b/Tscript.scm new file mode 100644 index 0000000..22b80ea --- /dev/null +++ b/Tscript.scm @@ -0,0 +1,60 @@ +(define transcript-on #f) +(define transcript-off #f) + +(let ((*transcript-stack* '())) + (define (trans-on filename) + (let ((trans (open-output-file filename)) + (inp (current-input-port)) + (outp (current-output-port)) + (errp (current-error-port))) + (define (clone-port port) + (make-soft-port + (vector (and (output-port? port) + (lambda (c) + (write-char c port) + (write-char c trans))) + (and (output-port? port) + (lambda (s) + (display s port) + (display s trans))) + (and (output-port? port) + (lambda () + (force-output port) + (force-output trans))) + (and (input-port? port) + (lambda () + (let ((c (read-char port))) + (write-char c trans) + c))) + (lambda () + (close-port port))) + (if (input-port? port) + (if (output-port? port) "r+" "r") + "w"))) + + (set! *transcript-stack* + (cons (list trans + (current-input-port) + (current-output-port) + (current-error-port)) + *transcript-stack*)) + (set-current-input-port (clone-port inp)) + (set-current-output-port (clone-port outp)) + (set-current-error-port (clone-port errp)))) + + (define (trans-off) + (cond ((pair? *transcript-stack*) + (apply (lambda (trans inp outp errp) + (close-port trans) + (set-current-input-port inp) + (set-current-output-port outp) + (set-current-error-port errp)) + (car *transcript-stack*)) + (set! *transcript-stack* (cdr *transcript-stack*))) + (else + (error "No transcript active")))) + + (set! transcript-on trans-on) + (set! transcript-off trans-off)) + +(provide 'transcript)
\ No newline at end of file diff --git a/Xlibscm.info b/Xlibscm.info new file mode 100644 index 0000000..4c57ced --- /dev/null +++ b/Xlibscm.info @@ -0,0 +1,1905 @@ +This is Info file Xlibscm.info, produced by Makeinfo version 1.68 from +the input file Xlibscm.texi. + +INFO-DIR-SECTION The Algorithmic Language Scheme +START-INFO-DIR-ENTRY +* Xlibscm: (Xlibscm). SCM Language X Interface. +END-INFO-DIR-ENTRY + + +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' + +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: + +* Xlibscm:: +* Display:: +* Screen:: +* Window:: +* Window Visibility:: +* Graphics Context:: +* Cursor:: +* Colormap:: +* Rendering:: +* Event:: +* Index:: + + +File: Xlibscm.info, Node: Xlibscm, Next: Display, Prev: Top, Up: Top + +Xlibscm +******* + +"Xlibscm" is a SCM interface to "X". The X Window System is a +network-transparent window system that was designed at MIT. SCM is a +portable Scheme implementation written in C. The interface can be +compiled into SCM or, on those platforms supporting dynamic linking, +compiled separately and loaded with `(require 'Xlib)'. + +Much of this X documentation is dervied from: + + Xlib - C Language X Interface + + X Consortium Standard + + X Version 11, Release 6.3 + +The X Window System is a trademark of X Consortium, Inc. + +TekHVC is a trademark of Tektronix, Inc. + +Copyright (C) 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1994, 1996 X +Consortium + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +Except as contained in this notice, the name of the X Consortium shall +not be used in advertising or otherwise to promote the sale, use or +other dealings in this Software without prior written authorization from +the X Consortium. + +Copyright (C) 1985, 1986, 1987, 1988, 1989, 1990, 1991 by Digital +Equipment Corporation + +Portions Copyright (C) 1990, 1991 by Tektronix, Inc. + +Permission to use, copy, modify and distribute this documentation for +any purpose and without fee is hereby granted, provided that the above +copyright notice appears in all copies and that both that copyright +notice and this permission notice appear in all copies, and that the +names of Digital and Tektronix not be used in in advertising or +publicity pertaining to this documentation without specific, written +prior permission. Digital and Tektronix makes no representations about +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 + +Display +******* + + - 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 + the value of the DISPLAY environment variable. + + The encoding and interpretation of DISPLAY-NAME is + implementation-dependent. On POSIX-conformant systems, the + DISPLAY-NAME or DISPLAY environment variable can be a string in + the format: + + - Special Form: hostname:number.screen-number + HOSTNAME specifies the name of the host machine on which the + display is physically attached. Follow the HOSTNAME with + either a single colon (:) or a double colon (::). + + NUMBER specifies the number of the display server on that host + machine. You may optionally follow this display number with + a period (.). A single CPU can have more than one display. + Multiple displays are usually numbered starting with zero. + + SCREEN-NUMBER specifies the screen to be used on that server. + Multiple screens can be controlled by a single X server. The + SCREEN-NUMBER sets an internal variable that can be accessed + by using the x:default-screen procedure. + + - Function: x:close DISPLAY + DISPLAY specifies the connection to the X server. + + The `x:close' function closes the connection to the X server for + the DISPLAY specified and destroys all windows, resource IDs + (Window, Font, Pixmap, Colormap, Cursor, and GContext), or other + resources that the client has created on this display, unless the + close-down mode of the resource has been changed (see + `x:set-close-down-mode'). Therefore, these windows, resource IDs, + and other resources should not be used again or an error will be + 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 + 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 + 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 + 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". + + - Function: x:screen-count DISPLAY + Returns the number of available screens. + + - 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 + SCREEN-NUMBER, if givien, specifies the appropriate screen number + on the host server. Otherwise the default-screen for DISPLAY is + used. + + Returns the root window for the specified SCREEN-NUMBER. Use + `x:root-window' for functions that need a drawable of a particular + screen or for creating top-level windows. + + - 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 + 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 + 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. + +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 + Returns the default Visual type for the specified screen. + + + - 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: + * x:Static-Gray + + * x:Static-Color + + * x:True-Color + + * x:Gray-Scale + + * x:Pseudo-Color + + * x:Direct-Color + + `X:make-visual' returns a visual type for the screen specified by + DISPLAY or WINDOW if successful; #f if not. + + + - 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 + Returns the depth of the root window of the specified screen. + + 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 + 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 + 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 + 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 + Returns the black pixel value of the specified screen. + + +File: Xlibscm.info, Node: Window, Next: Window Visibility, Prev: Screen, Up: Top + +Window +****** + +A "Drawable" is either a window or pixmap. + + - 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 + stacking order with respect to siblings. Any part of the window + that extends outside its parent WINDOW is clipped. The + BORDER-WIDTH for an x:Input-Only window must be zero. + + The coordinate system has the X axis horizontal and the Y axis + vertical with the origin [0, 0] at the upper-left corner. + Coordinates are integral, in terms of pixels, and coincide with + pixel centers. Each window and pixmap has its own coordinate + system. For a window, the origin is inside the border at the + inside, upper-left corner. + + CLASS can be x:Input-Output, x:Input-Only, or x:Copy-From-Parent. + For class x:Input-Output, the VISUAL type and DEPTH must be a + combination supported for the screen. The DEPTH need not be the + same as the parent, but the parent must not be a window of class + x:Input-Only. For an x:Input-Only window, the DEPTH must be zero, + and the VISUAL must be one supported by the screen. + + The returned window will have the attributes specified by + FIELD-NAMEs and VALUE. + + - 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 + SIZE is a list, vector, or pair of nonzero integers specifying the + width and height desired in the new pixmap. + + X:CREATE-PIXMAP returns a new pixmap of the width, height, and + DEPTH specified. It is valid to pass an x:Input-Only window to the + drawable argument. The DEPTH argument must be one of the depths + supported by the screen of the specified DRAWABLE. + + - 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 + specified by the WINDOW argument is mapped, it is unmapped + automatically. The ordering of the DestroyNotify events is such + that for any given window being destroyed, DestroyNotify is + generated on any inferiors of the window before being generated on + the window itself. The ordering among siblings and across + subhierarchies is not otherwise constrained. If the WINDOW you + specified is a root window, an error is signaled. Destroying a + mapped WINDOW will generate x:Expose events on other windows that + were obscured by the window being destroyed. + + - 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 + Returns a list of: + + coordinates + `cons' 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 + a window, these dimensions specify the inside size, not + including the border. + + border-width + The border width in pixels. If the DRAWABLE is a pixmap, + this is zero. + + depth + The depth of the DRAWABLE (bits per pixel for the object). + + - 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 +below; and the second is the value to associate with that property. + + - Attribute: x:CW-Back-Pixmap + Sets the background pixmap of the WINDOW to the specified pixmap. + The background pixmap can immediately be freed if no further + explicit references to it are to be made. If x:Parent-Relative is + specified, the background pixmap of the window's parent is used, + or on the root window, the default background is restored. It is + an error to perform this operation on an x:Input-Only window. If + the background is set to #f or None, the window has no defined + background. + + - Attribute: x:CW-Back-Pixel + Sets the background of the WINDOW to the specified pixel value. + Changing the background does not cause the WINDOW contents to be + changed. It is an error to perform this operation on an + x:Input-Only window. + + - Attribute: x:CW-Border-Pixmap + Sets the border pixmap of the WINDOW to the pixmap you specify. + The border pixmap can be freed if no further explicit references + to it are to be made. If you specify x:Copy-From-Parent, a copy + of the parent window's border pixmap is used. It is an error to + perform this operation on an x:Input-Only WINDOW. + + - Attribute: x:CW-Border-Pixel + Sets the border of the WINDOW to the pixel VALUE. It is an error + to perform this operation on an x:Input-Only window. + + - Attribute: x:CW-Bit-Gravity + - Attribute: x:CW-Win-Gravity + The bit gravity of a window defines which region of the window + should be retained when an x:Input-Output window is resized. The + default value for the bit-gravity attribute is x:Forget-Gravity. + The window gravity of a window allows you to define how the + x:Input-Output or x:Input-Only window should be repositioned if + its parent is resized. The default value for the win-gravity + attribute is x:North-West-Gravity. + + If the inside width or height of a window is not changed and if the + window is moved or its border is changed, then the contents of the + window are not lost but move with the window. Changing the inside + width or height of the window causes its contents to be moved or + lost (depending on the bit-gravity of the window) and causes + 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) + + When a window with one of these bit-gravity values is resized, the + corresponding pair defines the change in position of each pixel in + the window. When a window with one of these win-gravities has its + parent window resized, the corresponding pair defines the change + in position of the window within the parent. When a window is so + repositioned, a x:Gravity-Notify event is generated (see section + 10.10.5). + + A bit-gravity of x:Static-Gravity indicates that the contents or + origin should not move relative to the origin of the root window. + If the change in size of the window is coupled with a change in + position (x, y), then for bit-gravity the change in position of + each pixel is (-x, -y), and for win-gravity the change in position + of a child when its parent is so resized is (-x, -y). Note that + x:Static-Gravity still only takes effect when the width or height + of the window is changed, not when the window is moved. + + A bit-gravity of x:Forget-Gravity indicates that the window's + contents are always discarded after a size change, even if a + backing store or save under has been requested. The window is + tiled with its background and zero or more x:Expose events are + generated. If no background is defined, the existing screen + contents are not altered. Some X servers may also ignore the + specified bit-gravity and always generate x:Expose events. + + The contents and borders of inferiors are not affected by their + parent's bit-gravity. A server is permitted to ignore the + specified bit-gravity and use x:Forget-Gravity instead. + + A win-gravity of x:Unmap-Gravity is like x:North-West-Gravity (the + window is not moved), except the child is also unmapped when the + parent is resized, and an x:Unmap-Notify event is generated. + + - Attribute: x:CW-Backing-Store + Some implementations of the X server may choose to maintain the + contents of x:Input-Output windows. If the X server maintains the + contents of a window, the off-screen saved pixels are known as + backing store. The backing store advises the X server on what to + do with the contents of a window. The backing-store attribute can + be set to x:Not-Useful (default), x:When-Mapped, or x:Always. A + backing-store attribute of x:Not-Useful advises the X server that + maintaining contents is unnecessary, although some X + implementations may still choose to maintain contents and, + therefore, not generate x:Expose events. A backing-store + attribute of x:When-Mapped advises the X server that maintaining + contents of obscured regions when the window is mapped would be + beneficial. In this case, the server may generate an x:Expose + event when the window is created. A backing-store attribute of + x:Always advises the X server that maintaining contents even when + the window is unmapped would be beneficial. Even if the window is + larger than its parent, this is a request to the X server to + maintain complete contents, not just the region within the parent + window boundaries. While the X server maintains the window's + contents, x:Expose events normally are not generated, but the X + server may stop maintaining contents at any time. + + When the contents of obscured regions of a window are being + maintained, regions obscured by noninferior windows are included + in the destination of graphics requests (and source, when the + window is the source). However, regions obscured by inferior + windows are not included. + + - Attribute: x:CW-Backing-Planes + - Attribute: x:CW-Backing-Pixel + You can set backing planes to indicate (with bits set to 1) which + bit planes of an x:Input-Output window hold dynamic data that must + be preserved in backing store and during save unders. The default + value for the backing-planes attribute is all bits set to 1. You + can set backing pixel to specify what bits to use in planes not + covered by backing planes. The default value for the + backing-pixel attribute is all bits set to 0. The X server is + free to save only the specified bit planes in the backing store or + the save under and is free to regenerate the remaining planes with + the specified pixel value. Any extraneous bits in these values + (that is, those bits beyond the specified depth of the window) may + be simply ignored. If you request backing store or save unders, + you should use these members to minimize the amount of off-screen + memory required to store your window. + + - Attribute: x:CW-Override-Redirect + To control window placement or to add decoration, a window manager + often needs to intercept (redirect) any map or configure request. + Pop-up windows, however, often need to be mapped without a window + manager getting in the way. To control whether an x:Input-Output + or x:Input-Only window is to ignore these structure control + facilities, use the override-redirect flag. + + The override-redirect flag specifies whether map and configure + requests on this window should override a + x:Substructure-Redirect-Mask on the parent. You can set the + override-redirect flag to #t or #f (default). Window managers use + this information to avoid tampering with pop-up windows. + + - Attribute: x:CW-Save-Under + Some server implementations may preserve contents of + x:Input-Output windows under other x:Input-Output windows. This + is not the same as preserving the contents of a window for you. + You may get better visual appeal if transient windows (for + example, pop-up menus) request that the system preserve the screen + contents under them, so the temporarily obscured applications do + not have to repaint. + + You can set the save-under flag to True or False (default). If + save-under is True, the X server is advised that, when this window + is mapped, saving the contents of windows it obscures would be + beneficial. + + - Attribute: x:CW-Event-Mask + The event mask defines which events the client is interested in + for this x:Input-Output or x:Input-Only window (or, for some event + types, inferiors of this window). The event mask is the bitwise + inclusive OR of zero or more of the valid event mask bits. You + can specify that no maskable events are reported by setting + x:No-Event-Mask (default). + + The following table lists the event mask constants you can pass to + 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 + + - Attribute: x:CW-Dont-Propagate + The do-not-propagate-mask attribute defines which events should + not be propagated to ancestor windows when no client has the event + type selected in this x:Input-Output or x:Input-Only window. The + do-not-propagate-mask is the bitwise inclusive OR of zero or more + of the following masks: x:Key-Press, x:Key-Release, x:Button-Press, + x:Button-Release, x:Pointer-Motion, x:Button1Motion, + x:Button2Motion, x:Button3Motion, x:Button4Motion, + x:Button5Motion, and x:Button-Motion. You can specify that all + events are propagated by setting x:No-Event-Mask (default). + + - Attribute: x:CW-Colormap + The colormap attribute specifies which colormap best reflects the + true colors of the x:Input-Output window. The colormap must have + the same visual type as the window. X servers capable of + supporting multiple hardware colormaps can use this information, + and window managers can use it for calls to X:Install-Colormap. + You can set the colormap attribute to a colormap or to + x:Copy-From-Parent (default). + + If you set the colormap to x:Copy-From-Parent, the parent window's + colormap is copied and used by its child. However, the child + window must have the same visual type as the parent. The parent + window must not have a colormap of x:None. The colormap is copied + by sharing the colormap object between the child and parent, not + by making a complete copy of the colormap contents. Subsequent + changes to the parent window's colormap attribute do not affect + the child window. + + - Attribute: x:CW-Cursor + The cursor attribute specifies which cursor is to be used when the + pointer is in the x:Input-Output or x:Input-Only window. You can + set the cursor to a cursor or x:None (default). + + If you set the cursor to x:None, the parent's cursor is used when + the pointer is in the x:Input-Output or x:Input-Only window, and + any change in the parent's cursor will cause an immediate change + in the displayed cursor. On the root window, the default cursor + is restored. + + +File: Xlibscm.info, Node: Window Visibility, Next: Graphics Context, Prev: Window, Up: Top + +Window Visibility +***************** + +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 + 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 + ancestor becomes mapped. Such a window is called unviewable. + When all its ancestors are mapped, the window becomes viewable and + will be visible on the screen if it is not obscured by another + window. This function has no effect if the WINDOW is already + mapped. + + If the override-redirect of the window is False and if some other + client has selected x:Substructure-Redirect-Mask on the parent + window, then the X server generates a MapRequest event, and the + `x:map-window' function does not map the WINDOW. Otherwise, the + WINDOW is mapped, and the X server generates a MapNotify event. + + If the WINDOW becomes viewable and no earlier contents for it are + remembered, the X server tiles the WINDOW with its background. If + the window's background is undefined, the existing screen contents + are not altered, and the X server generates zero or more x:Expose + events. If backing-store was maintained while the WINDOW was + unmapped, no x:Expose events are generated. If backing-store will + now be maintained, a full-window exposure is always generated. + Otherwise, only visible regions may be reported. Similar tiling + and exposure take place for any newly viewable inferiors. + + If the window is an Input-Output window, `x:map-window' generates + x:Expose events on each Input-Output window that it causes to be + displayed. If the client maps and paints the window and if the + client begins processing events, the window is painted twice. To + avoid this, first ask for x:Expose events and then map the window, + so the client processes input events as usual. The event list + will include x:Expose for each window that has appeared on the + screen. The client's normal response to an x:Expose event should + 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 + 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 + mapping many windows one 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. + + - 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 + formerly obscured windows is performed. Any child window will no + longer be visible until another map call is made on the parent. + In other words, the subwindows are still mapped but are not + visible until the parent is mapped. Unmapping a WINDOW will + generate x:Expose events on windows that were formerly obscured by + it. + + - 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 + windows. Using this function is much more efficient than + unmapping multiple windows one 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. + + +File: Xlibscm.info, Node: Graphics Context, Next: Cursor, Prev: Window Visibility, Up: Top + +Graphics Context +**************** + +Most attributes of graphics operations are stored in "GC"s. These +include line width, line style, plane mask, foreground, background, +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 ... + 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 ... + 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 ... + 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 ... + Returns a list of the components specified by FIELD-NAMEs ... + from the specified GRAPHICS-CONTEXT. + +GC Attributes +============= + +Both `x:create-gc' and `x:change-gc' take one argument followed by +pairs of arguments, where the first is one of the property-name symbols +(or its top-level value) listed below; and the second is the value to +associate with that property. + + - Attribute: x:GC-Function + The function attributes of a GC are used when you update a section + of a drawable (the destination) with bits from somewhere else (the + source). The function in a GC defines how the new destination + bits are to be computed from the source bits and the old + destination bits. x:G-Xcopy is typically the most useful because + it will work on a color display, but special applications may use + other functions, particularly in concert with particular planes of + a color display. The 16 functions are: + + + x:G-Xclear 0 + x:G-Xand (AND src dst) + x:G-Xand-Reverse (AND src (NOT dst)) + x:G-Xcopy src + x:G-Xand-Inverted (AND (NOT src) dst) + x:G-Xnoop dst + x:G-Xxor (XOR src dst) + x:G-Xor (OR src dst) + x:G-Xnor (AND (NOT src) (NOT dst)) + x:G-Xequiv (XOR (NOT src) dst) + x:G-Xinvert (NOT dst) + x:G-Xor-Reverse (OR src (NOT dst)) + x:G-Xcopy-Inverted (NOT src) + x:G-Xor-Inverted (OR (NOT src) dst) + x:G-Xnand (OR (NOT src) (NOT dst)) + x:G-Xset 1 + + - Attribute: x:GC-Plane-Mask + Many graphics operations depend on either pixel values or planes + in a GC. The planes attribute is an integer which specifies which + planes of the destination are to be modified, one bit per plane. + A monochrome display has only one plane and will be the least + significant bit of the integer. As planes are added to the + display hardware, they will occupy more significant bits in the + plane mask. + + In graphics operations, given a source and destination pixel, the + result is computed bitwise on corresponding bits of the pixels. + That is, a Boolean operation is performed in each bit plane. The + plane-mask restricts the operation to a subset of planes. + `x:All-Planes' can be used to refer to all planes of the screen + simultaneously. The result is computed by the following: + + (OR (AND (FUNC src dst) plane-mask) (AND dst (NOT plane-mask))) + + Range checking is not performed on a plane-mask value. It is + simply truncated to the appropriate number of bits. + + - Attribute: x:GC-Foreground + - Attribute: x:GC-Background + Range checking is not performed on the values for foreground or + background. They are simply truncated to the appropriate number of + bits. + + Note that foreground and background are not initialized to any + values likely to be useful in a window. + + - Attribute: x:GC-Line-Width + The line-width is measured in pixels and either can be greater + than or equal to one (wide line) or can be the special value zero + (thin line). + + Thin lines (zero line-width) are one-pixel-wide lines drawn using + an unspecified, device-dependent algorithm. There are only two + constraints on this algorithm. + + * If a line is drawn unclipped from [x1,y1] to [x2,y2] and if + another line is drawn unclipped from [x1+dx,y1+dy] to + [x2+dx,y2+dy], a point [x,y] is touched by drawing the first + line if and only if the point [x+dx,y+dy] is touched by + drawing the second line. + + * The effective set of points comprising a line cannot be + affected by clipping. That is, a point is touched in a + clipped line if and only if the point lies inside the + clipping region and the point would be touched by the line + when drawn unclipped. + + A wide line drawn from [x1,y1] to [x2,y2] always draws the same + pixels as a wide line drawn from [x2,y2] to [x1,y1], not counting + cap-style and join-style. It is recommended that this property be + true for thin lines, but this is not required. A line-width of + zero may differ from a line-width of one in which pixels are + drawn. This permits the use of many manufacturers' line drawing + hardware, which may run many times faster than the more precisely + specified wide lines. + + In general, drawing a thin line will be faster than drawing a wide + line of width one. However, because of their different drawing + algorithms, thin lines may not mix well aesthetically with wide + lines. If it is desirable to obtain precise and uniform results + across all displays, a client should always use a line-width of + one rather than a linewidth of zero. + + - Attribute: x:GC-Line-Style + The line-style defines which sections of a line are drawn: + + x:Line-Solid + The full path of the line is drawn. + + x:Line-Double-Dash + The full path of the line is drawn, but the even dashes are + filled differently from the odd dashes (see fill-style) with + x:Cap-Butt style used where even and odd dashes meet. + + x:Line-On-Off-Dash + Only the even dashes are drawn, and cap-style applies to all + internal ends of the individual dashes, except x:Cap-Not-Last + is treated as x:Cap-Butt. + + - Attribute: x:GC-Cap-Style + The cap-style defines how the endpoints of a path are drawn: + + x:Cap-Not-Last + This is equivalent to x:Cap-Butt except that for a line-width + of zero the final endpoint is not drawn. + + x:Cap-Butt + The line is square at the endpoint (perpendicular to the + slope of the line) with no projection beyond. + + x:Cap-Round + The line has a circular arc with the diameter equal to the + line-width, centered on the endpoint. (This is equivalent to + x:Cap-Butt for line-width of zero). + + x:Cap-Projecting + The line is square at the end, but the path continues beyond + the endpoint for a distance equal to half the line-width. + (This is equivalent to x:Cap-Butt for line-width of zero). + + - Attribute: x:GC-Join-Style + The join-style defines how corners are drawn for wide lines: + + x:Join-Miter + The outer edges of two lines extend to meet at an angle. + However, if the angle is less than 11 degrees, then a + x:Join-Bevel join-style is used instead. + + x:Join-Round + The corner is a circular arc with the diameter equal to the + line-width, centered on the x:Join-point. + + x:Join-Bevel + The corner has x:Cap-Butt endpoint styles with the triangular + notch filled. + + - Attribute: x:GC-Fill-Style + The fill-style defines the contents of the source for line, text, + and fill requests. For all text and fill requests (for example, + X:Draw-Text, X:Fill-Rectangle, X:Fill-Polygon, and X:Fill-Arc); + for line requests with linestyle x:Line-Solid (for example, + X:Draw-Line, X:Draw-Segments, X:Draw-Rectangle, X:Draw-Arc); and + for the even dashes for line requests with line-style + x:Line-On-Off-Dash or x:Line-Double-Dash, the following apply: + + x:Fill-Solid + Foreground + + x:Fill-Tiled + Tile + + x:Fill-Opaque-Stippled + A tile with the same width and height as stipple, but with + background everywhere stipple has a zero and with foreground + everywhere stipple has a one + + x:Fill-Stippled + Foreground masked by stipple + + When drawing lines with line-style x:Line-Double-Dash, the odd + dashes are controlled by the fill-style in the following manner: + + x:Fill-Solid + Background + + x:Fill-Tiled + Same as for even dashes + + x:Fill-Opaque-Stippled + Same as for even dashes + + x:Fill-Stippled + Background masked by stipple + + - Attribute: x:GC-Fill-Rule + The fill-rule defines what pixels are inside (drawn) for paths + given in X:Fill-Polygon requests and can be set to x:Even-Odd-Rule + or x:Winding-Rule. + + x:Even-Odd-Rule + A point is inside if an infinite ray with the point as origin + crosses the path an odd number of times. + + x:Winding-Rule + A point is inside if an infinite ray with the point as origin + crosses an unequal number of clockwise and counterclockwise + directed path segments. + + A clockwise directed path segment is one that crosses the ray from + left to right as observed from the point. A counterclockwise + segment is one that crosses the ray from right to left as observed + from the point. The case where a directed line segment is + coincident with the ray is uninteresting because you can simply + choose a different ray that is not coincident with a segment. + + For both x:Even-Odd-Rule and x:Winding-Rule, a point is infinitely + small, and the path is an infinitely thin line. A pixel is inside + if the center point of the pixel is inside and the center point is + not on the boundary. If the center point is on the boundary, the + pixel is inside if and only if the polygon interior is immediately + to its right (x increasing direction). Pixels with centers on a + horizontal edge are a special case and are inside if and only if + the polygon interior is immediately below (y increasing direction). + + - Attribute: x:GC-Tile + - Attribute: x:GC-Stipple + The tile/stipple represents an infinite two-dimensional plane, + with the tile/stipple replicated in all dimensions. + + The tile pixmap must have the same root and depth as the GC, or an + error results. The stipple pixmap must have depth one and must + have the same root as the GC, or an error results. For stipple + operations where the fill-style is x:Fill-Stippled but not + x:Fill-Opaque-Stippled, the stipple pattern is tiled in a single + plane and acts as an additional clip mask to be ANDed with the + clip-mask. Although some sizes may be faster to use than others, + any size pixmap can be used for tiling or stippling. + + - Attribute: x:GC-Tile-Stip-X-Origin + - Attribute: x:GC-Tile-Stip-Y-Origin + When the tile/stipple plane is superimposed on a drawable for use + in a graphics operation, the upper-left corner of some instance of + the tile/stipple is at the coordinates within the drawable + specified by the tile/stipple origin. The tile/stipple origin is + interpreted relative to the origin of whatever destination + drawable is specified in a graphics request. + + - Attribute: x:GC-Font + The font to be used for drawing text. + + - Attribute: x:GC-Subwindow-Mode + You can set the subwindow-mode to x:Clip-By-Children or + x:Include-Inferiors. + x:Clip-By-Children + Both source and destination windows are additionally clipped + by all viewable Input-Output children. + + x:Include-Inferiors + Neither source nor destination window is clipped by + inferiors. This will result in including subwindow contents + in the source and drawing through subwindow boundaries of the + destination. The use of `x:Include-Inferiors' on a window of + one depth with mapped inferiors of differing depth is not + illegal, but the semantics are undefined by the core protocol. + + - Attribute: x:GC-Graphics-Exposures + The graphics-exposure flag controls x:Graphics-Expose event + generation for X:Copy-Area and X:Copy-Plane requests (and any + similar requests defined by extensions). + + - Attribute: x:GC-Clip-X-Origin + - Attribute: x:GC-Clip-Y-Origin + The clip-mask origin is interpreted relative to the origin of + whatever destination drawable is specified in a graphics request. + + - Attribute: x:GC-Clip-Mask + The clip-mask restricts writes to the destination drawable. If the + clip-mask is set to a pixmap, it must have depth one and have the + same root as the GC, or an error results. If clip-mask is set to + "x:None", the pixels are always drawn regardless of the clip + origin. The clip-mask also can be set by calling `X:Set-Region'. + Only pixels where the clip-mask has a bit set to 1 are drawn. + Pixels are not drawn outside the area covered by the clip-mask or + where the clip-mask has a bit set to 0. The clip-mask affects all + graphics requests. The clip-mask does not clip sources. The + clip-mask origin is interpreted relative to the origin of whatever + destination drawable is specified in a graphics request. + + - Attribute: x:GC-Dash-Offset + Defines the phase of the pattern, specifying how many pixels into + the dash-list the pattern should actually begin in any single + graphics request. Dashing is continuous through path elements + combined with a join-style but is reset to the dash-offset between + each sequence of joined lines. + + The unit of measure for dashes is the same for the ordinary + coordinate system. Ideally, a dash length is measured along the + slope of the line, but implementations are only required to match + this ideal for horizontal and vertical lines. Failing the ideal + semantics, it is suggested that the length be measured along the + major axis of the line. The major axis is defined as the x axis + for lines drawn at an angle of between -45 and +45 degrees or + between 135 and 225 degrees from the x axis. For all other lines, + the major axis is the y axis. + + - Attribute: x:GC-Dash-List + There must be at least one element in the specified DASH-LIST. + The initial and alternating elements (second, fourth, and so on) + of the DASH-LIST are the even dashes, and the others are the odd + dashes. Each element specifies a dash length in pixels. All of + the elements must be nonzero. Specifying an odd-length list is + equivalent to specifying the same list concatenated with itself to + produce an even-length list. + + - Attribute: x:GC-Arc-Mode + The arc-mode controls filling in the X:Fill-Arcs function and can + be set to x:Arc-Pie-Slice or x:Arc-Chord. + x:Arc-Pie-Slice + The arcs are pie-slice filled. + + x:Arc-Chord + The arcs are chord filled. + + +File: Xlibscm.info, Node: Cursor, Next: Colormap, Prev: Graphics Context, Up: Top + +Cursor +****** + + - 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 + display type. The SHAPE argument specifies which glyph of the + standard fonts to use. + + The hotspot comes from the information stored in the cursor font. + The initial colors of a cursor are a black foreground and a white + 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 + 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 + glyph in MASK-FONT. The origins of the SOURCE-CHAR and MASK-CHAR + glyphs are positioned coincidently and define the hotspot. The + SOURCE-CHAR and MASK-CHAR need not have the same bounding box + 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 + 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 + 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, + even if the X server only has a x:Static-Gray or x:Gray-Scale + screen. The hotspot must be a point within the SOURCE-PIXMAP. + + `X:Create-Cursor' creates and returns a cursor. The + FOREGROUND-COLOR is used for the pixels set to 1 in the source, + and the BACKGROUND-COLOR is used for the pixels set to 0. Both + source and mask must have depth one but can have any root. The + MASK-PIXMAP defines the shape of the cursor. The pixels set to 1 + 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 + If MASK-PIXMAP is #f, all pixels of the source are displayed. + + +File: Xlibscm.info, Node: Colormap, Next: Rendering, Prev: Cursor, Up: Top + +Colormap +******** + +A "colormap" maps pixel values to "RGB" color space values. + + - 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 + can pass `X:Alloc-None' or `X:Alloc-All'. + + The `X:Create-Colormap' function creates and returns a colormap of + the specified VISUAL type for the screen on which WINDOW resides. + 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 + ALLOC-POLICY must be `X:Alloc-None'. + + For the other visual classes, if ALLOC-POLICY is `X:Alloc-None', + the colormap initially has no allocated entries, and clients can + allocate them. + + If ALLOC-POLICY is `X:Alloc-All', the entire colormap is allocated + writable. The initial values of all allocated entries are + 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 + entries value in VISUAL. + + `X:Direct-Color' + The effect is as if an `XAllocColorPlanes' call returned a + pixel value of zero and red_mask, green_mask, and blue_mask + values containing the same bits as the corresponding masks in + the specified visual. + + +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 + 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 + new colormap with their color values intact and their read-only or + writable characteristics intact and frees those entries in the + specified colormap. Color values in other entries in the new + colormap are undefined. If the specified colormap was created by + the client with alloc set to `X:Alloc-All', the new colormap is + also created with `X:Alloc-All', all color values for all entries + are copied from the specified COLORMAP, and then all entries in + the specified COLORMAP are freed. If the specified COLORMAP was + not created by the client with `X:Alloc-All', the allocations to + be moved are all those pixels and planes that have been allocated + by the client and that have not been freed since they were + allocated. + + +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? + 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 + requested, then NCOLORS pixels and nplane plane masks are + returned. No mask will have any bits set to 1 in common with any + other mask or with any of the pixels. By ORing together each + pixel with zero or more masks, NCOLORS * 2^NPLANES distinct pixels + can be produced. All of these are allocated writable by the + 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 + contiguous set of bits set to 1 is formed. + + `x:Direct-Color' + Each mask has exactly three bits set to 1. If CONTIGUOUS? is + non-false and if all masks are ORed together, three + contiguous sets of bits set to 1 (one within each pixel + subfield) is formed. + + The RGB values of the allocated entries are undefined. + `X:Alloc-Color-Cells' returns a list of two uniform arrays if it + 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? + 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 + returned; and the masks have NREDS, NGREENS, and NBLUES bits set + to 1, respectively. If CONTIGUOUS? is non-false, each mask will + have a contiguous set of bits set to 1. No mask will have any + bits set to 1 in common with any other mask or with any of the + pixels. + + Each mask will lie within the corresponding pixel subfield. By + ORing together subsets of masks with each pixel value, NCOLORS * + 2(NREDS+NGREENS+NBLUES) distinct pixel values can be produced. + All of these are allocated by the request. However, in the + colormap, there are only NCOLORS * 2^NREDS independent red + entries, NCOLORS * 2^NGREENS independent green entries, and + NCOLORS * 2^NBLUES independent blue entries. + + `X:Alloc-Color-Cells' returns a list if it succeeded or #f if it + failed. The first element of the list has an array of the pixels + 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 + 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 + pixels. The set of all pixels is produced by ORing together + subsets of the PLANES argument with the pixels. The request frees + all of these pixels that were allocated by the client. Note that + freeing an individual pixel obtained from `X:Alloc-Colormap-Cells' + with a planes argument may not actually allow it to be reused + until all of its related pixels are also freed. Similarly, a + read-only entry is not actually freed until it has been freed by + all clients, and if a client allocates the same read-only entry + multiple times, it must free the entry that many times before the + entry is actually freed. + + All specified pixels that are allocated by the client in the + COLORMAP are freed, even if one or more pixels produce an error. + It is an error if a specified pixel is not allocated by the client + (that is, is unallocated or is only allocated by another client) + or if the colormap was created with all entries writable (by + 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 + 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 + The case-insensitive string COLOR_NAME specifies the name of a + color (for example, `red') + + `X:Colormap-Find-Color' allocates a read-only colormap entry + corresponding to the closest RGB value supported by the hardware. + `X:Colormap-Find-Color' returns the pixel value of the color + closest to the specified RGB or COLOR_NAME elements supported by + the hardware, if successful; otherwise `X:Colormap-Find-Color' + returns #f. + + Multiple clients that request the same effective RGB value can be + assigned the same read-only entry, thus allowing entries to be + shared. When the last client deallocates a shared cell, it is + deallocated. + + + - 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 + 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 + The case-insensitive string COLOR_NAME specifies the name of a + color (for example, `red') + + The integer PIXEL must be a valid index into COLORMAP. + + `X:Color-Set!' changes the COLORMAP entry of the read/write cell + indexed by PIXEL. If the COLORMAP is an installed map for its + screen, the changes are visible immediately. + + + - 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 + created or its attributes changed. + + If the specified colormap is not already an installed colormap, + the X server generates a ColormapNotify event on each window that + has that colormap. + + + +File: Xlibscm.info, Node: Rendering, Next: Event, Prev: Colormap, Up: Top + +Rendering +********* + + - 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 + Forces sending of GC component changes. + + Xlib usually defers sending changes to the components of a GC to + the server until a graphics function is actually called with that + GC. This permits batching of component changes into a single + server request. In some circumstances, however, it may be + necessary for the client to explicitly force sending the changes + to the server. An example might be when a protocol extension uses + 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? + 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 + is zero, it is replaced with the current width of the WINDOW minus + x. If height is zero, it is replaced with the current height of + the WINDOW minus y. If the WINDOW has a defined background tile, + the rectangle clipped by any children is filled with this tile. + If the WINDOW has background x:None, the contents of the WINDOW + are not changed. In either case, if EXPOSE? is True, one or more + x:Expose events are generated for regions of the rectangle that + 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 + +Draw Strings +============ + + - 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 + 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, + starting at POSITION. + +Draw Shapes +=========== + + - Function: x:draw-points DRAWABLE GC POSITION ... + POSITION ... specifies coordinates of the point to be drawn. + + - 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 + POINT-ARRAY is a uniform short array of rank 2, whose rightmost + index spans a range of 2. + + The `X:Draw-Points' procedure uses the foreground pixel and + function components of the GC to draw points into DRAWABLE at the + positions (relative to the origin of DRAWABLE) specified. + + `X:Draw-Points' uses these GC components: function, planemask, + foreground, subwindow-mode, clip-x-origin, clip-y-origin, and + clip-mask. + + - 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 ... + (X1, Y1), (X2, Y2) ... specify coordinates to be connected by + segments. + + - 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. + + The `X:Draw-Segments' procedure uses the components of the + specified GC to draw multiple unconnected lines between disjoint + adjacent pair of points passed as arguments. It draws the + segments in order and does not perform joining at coincident + endpoints. For any given line, `X:Draw-Segments' does not draw a + pixel more than once. If thin (zero line-width) segments + intersect, the intersecting pixels are drawn multiple times. If + wide segments intersect, the intersecting pixels are drawn only + once, as though the entire PolyLine protocol request were a + single, filled shape. `X:Draw-Segments' treats all coordinates as + relative to the origin of DRAWABLE. + + `X:Draw-Segments' uses these GC components: function, plane-mask, + line-width, line-style, cap-style, fill-style, subwindow-mode, + clip-x-origin, clip-y-origin, and clip-mask, join-style. It also + use these GC mode-dependent components: foreground, background, + tile, stipple, tilestipple-x-origin, tile-stipple-y-origin, + dash-offset, and dash-list. + + - 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 ... + (X1, Y1), (X2, Y2) ... specify coordinates to be connected by + lines. + + - 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. + + The `X:Draw-Lines' procedure uses the components of the specified + GC to draw lines between each adjacent pair of points passed as + arguments. It draws the lines in order. The lines join correctly + at all intermediate points, and if the first and last points + coincide, the first and last lines also join correctly. For any + given line, `X:Draw-Lines' does not draw a pixel more than once. + If thin (zero line-width) lines intersect, the intersecting pixels + are drawn multiple times. If wide lines intersect, the + intersecting pixels are drawn only once, as though the entire + PolyLine protocol request were a single, filled shape. + `X:Draw-Lines' treats all coordinates as relative to the origin of + DRAWABLE. + + `X:Draw-Lines' uses these GC components: function, plane-mask, + line-width, line-style, cap-style, fill-style, subwindow-mode, + clip-x-origin, clip-y-origin, and clip-mask, join-style. It also + use these GC mode-dependent components: foreground, background, + tile, stipple, tilestipple-x-origin, tile-stipple-y-origin, + dash-offset, and dash-list. + + - 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 ... + (X1, Y1), (X2, Y2) ... specify coordinates of the border path. + + - 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. + + The path is closed automatically if the last point in the list or + POINT-ARRAY does not coincide with the first point. + + The `X:Fill-Polygon' procedure uses the components of the specified + GC to fill the region closed by the specified path. + `X:Fill-Polygon' does not draw a pixel of the region more than + once. `X:Fill-Polygon' treats all coordinates as relative to the + origin of DRAWABLE. + + `X:Fill-Polygon' uses these GC components: function, planemask, + fill-style, fill-rule, subwindow-mode, clip-x-origin, + clip-y-origin, and clip-mask. It also use these GC mode-dependent + components: foreground, background, tile, stipple, + tile-stipple-x-origin, and tile-stipple-y-origin. + + +File: Xlibscm.info, Node: Event, Next: Index, Prev: Rendering, Up: Top + +Event +***** + +These three status routines always return immediately if there are +events already in the queue. + + - 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 + 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 + 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 + without flushing the output buffer and returns the number read. + +Both of these routines return an object of type "event". + + - 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 + 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 + is received. + +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. + + +File: Xlibscm.info, Node: Index, Prev: Event, Up: Top + +Procedure and Macro Index +************************* + +This is an alphabetical list of all the procedures and macros in +Xlibscm. + +* Menu: + +* hostname:number.screen-number: Display. +* x:alloc-colormap-cells: Colormap. +* x:clear-area: Rendering. +* x:close <1>: Window. +* x:close: Display. +* x:color-ref: Colormap. +* X:Color-Set!: Colormap. +* x:colormap-find-color: Colormap. +* x:copy-colormap-and-free: Colormap. +* x:copy-gc-fields!: Graphics Context. +* 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:draw-lines: Rendering. +* x:draw-points: Rendering. +* x:draw-segments: Rendering. +* x:draw-string: Rendering. +* x:event-ref: Event. +* x:events-queued: Event. +* x:fill-polygon: Rendering. +* x:fill-rectangle: Rendering. +* x:flush: Rendering. +* x:free-colormap-cells: Colormap. +* x:gc-ref: Graphics Context. +* x:gc-set!: Graphics Context. +* 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:next-event: Event. +* x:open-display: Display. +* x:peek-event: Event. +* x:pending: Event. +* x:protocol-version: Display. +* 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. + +Variable Index +************** + +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:GC-Arc-Mode: Graphics Context. +* x:GC-Background: Graphics Context. +* x:GC-Cap-Style: Graphics Context. +* x:GC-Clip-Mask: Graphics Context. +* x:GC-Clip-X-Origin: Graphics Context. +* x:GC-Clip-Y-Origin: Graphics Context. +* x:GC-Dash-List: Graphics Context. +* x:GC-Dash-Offset: Graphics Context. +* x:GC-Fill-Rule: Graphics Context. +* x:GC-Fill-Style: Graphics Context. +* x:GC-Font: Graphics Context. +* x:GC-Foreground: Graphics Context. +* x:GC-Function: Graphics Context. +* x:GC-Graphics-Exposures: Graphics Context. +* x:GC-Join-Style: Graphics Context. +* x:GC-Line-Style: Graphics Context. +* x:GC-Line-Width: Graphics Context. +* x:GC-Plane-Mask: Graphics Context. +* x:GC-Stipple: Graphics Context. +* x:GC-Subwindow-Mode: Graphics Context. +* x:GC-Tile: Graphics Context. +* x:GC-Tile-Stip-X-Origin: Graphics Context. +* x:GC-Tile-Stip-Y-Origin: Graphics Context. + +This is an alphabetical list of concepts introduced in this manual. + +Concept Index +************* + +* Menu: + +* colormap: Colormap. +* cursor: Cursor. +* depth: Screen. +* drawable: Window. +* Drawable: Window. +* map: Window Visibility. +* mapped: Window Visibility. +* none: Graphics Context. +* RGB: Colormap. +* unmap: Window Visibility. +* unmapped: Window Visibility. +* Visual: Screen. +* visual: Screen. +* X: Xlibscm. +* x:None: Graphics Context. +* Xlib: Xlibscm. + + + +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 + +End Tag Table diff --git a/Xlibscm.texi b/Xlibscm.texi new file mode 100644 index 0000000..59e6c3c --- /dev/null +++ b/Xlibscm.texi @@ -0,0 +1,1955 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename Xlibscm.info +@settitle Xlibscm +@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 +* Xlibscm: (Xlibscm). SCM Language X Interface. +@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 Xlibscm +@subtitle SCM Language X Interface +@subtitle Version @value{SCMVERSION} +@author by Aubrey Jaffer + +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 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. +@end titlepage + +@node Top, Xlibscm, (dir), (dir) + + +@ifinfo +This manual documents the X - SCM Language X Interface. 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} + + +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. + +@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 + +@menu +* Xlibscm:: +* Display:: +* Screen:: +* Window:: +* Window Visibility:: +* Graphics Context:: +* Cursor:: +* Colormap:: +* Rendering:: +* Event:: +* Index:: +@end menu + +@node Xlibscm, Display, Top, Top +@chapter Xlibscm + +@dfn{Xlibscm} is a SCM interface to @dfn{X}. +@cindex X +The +@ifset html +<A HREF="http://www.x.org/"> +@end ifset +X Window System +@ifset html +</A> +@end ifset +is a network-transparent window system that was +designed at MIT. +@ifset html +<A HREF="scm_toc.html"> +@end ifset +SCM +@ifset html +</A> +@end ifset +is a portable Scheme implementation written in C. +The interface can be compiled into SCM or, on those platforms supporting +dynamic linking, compiled separately and loaded with @code{(require +'Xlib)}. +@ftindex Xlib + +@iftex +@noindent +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} +@end iftex + +Much of this X documentation is dervied from: + +@center Xlib - C Language X Interface +@center X Consortium Standard +@center X Version 11, Release 6.3 + +The X Window System is a trademark of X Consortium, Inc. + +TekHVC is a trademark of Tektronix, Inc. + + + +Copyright (C) 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1994, 1996 X +Consortium + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +Except as contained in this notice, the name of the X Consortium shall +not be used in advertising or otherwise to promote the sale, use or +other dealings in this Software without prior written authorization from +the X Consortium. + + + + +Copyright (C) 1985, 1986, 1987, 1988, 1989, 1990, 1991 by +Digital Equipment Corporation + +Portions Copyright (C) 1990, 1991 by Tektronix, Inc. + +Permission to use, copy, modify and distribute this documentation for +any purpose and without fee is hereby granted, provided that the above +copyright notice appears in all copies and that both that copyright +notice and this permission notice appear in all copies, and that the +names of Digital and Tektronix not be used in in advertising or +publicity pertaining to this documentation without specific, written +prior permission. Digital and Tektronix makes no representations about +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 + +@defun x:open-display display-name +@var{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 the value of the +@var{DISPLAY} environment variable. + +The encoding and interpretation of @var{display-name} is +implementation-dependent. On POSIX-conformant systems, the +@var{display-name} or @var{DISPLAY} environment variable can be a string +in the format: + +@defspec hostname:number.screen-number + +@var{hostname} specifies the name of the host machine on which the +display is physically attached. Follow the @var{hostname} with either a +single colon (:) or a double colon (::). + +@var{number} specifies the number of the display server on that host +machine. You may optionally follow this display number with a period +(.). A single CPU can have more than one display. Multiple displays +are usually numbered starting with zero. + +@var{screen-number} specifies the screen to be used on that server. +Multiple screens can be controlled by a single X server. The +@var{screen-number} sets an internal variable that can be accessed by +using the x:default-screen procedure. +@end defspec +@end defun + +@defun x:close display +@var{display} specifies the connection to the X server. + +The @code{x:close} function closes the connection to the X server for +the @var{display} specified and destroys all windows, resource IDs +(Window, Font, Pixmap, Colormap, Cursor, and GContext), or other +resources that the client has created on this display, unless the +close-down mode of the resource has been changed (see +@code{x:set-close-down-mode}). Therefore, these windows, resource IDs, +and other resources should not be used again or an error will be +generated. Before exiting, you should call @var{x:close-display} or +@var{x:flush} explicitly so that any pending errors are reported. +@end defun + +@defun x:protocol-version display +Returns cons of the major version number (11) of the X protocol +associated with the connected @var{display} and the minor protocol +revision number of the X server. +@end defun + +@defun 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. +@end defun + +@defun x:vendor-release display +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}. + +@defun x:screen-count display +Returns the number of available screens. +@end defun + +@defun x:default-screen display +Returns the default screen number specified by the @code{x:open-display} +function. Use this screen number in applications which will use only a +single screen. +@end defun + +@defun x:root-window display screen-number +@defunx x:root-window display +@var{screen-number}, if givien, specifies the appropriate screen number +on the host server. Otherwise the default-screen for @var{display} is +used. + +Returns the root window for the specified @var{screen-number}. Use +@code{x:root-window} for functions that need a drawable of a particular +screen or for creating top-level windows. + +@defunx x:root-window window +Returns the root window for the specified @var{window}'s screen. +@end defun + +@defun x:default-colormap display screen-number +@defunx x:default-colormap display +@defunx x:default-colormap window +Returns the default colormap 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. +@end defun + +The @dfn{Visual} type describes possible colormap depths and +arrangements. + +@defun x:default-visual display screen-number +@defunx x:default-visual display +@defunx x:default-visual window +Returns the default Visual type for the specified screen. + +@cindex visual +@cindex Visual +@end defun + +@defun x:make-visual display depth class +@defunx x:make-visual window depth class + +The integer @var{depth} specifies the number of bits per pixel. +The @var{class} argument specifies one of the possible +visual classes for a screen: +@itemize @bullet +@item x:Static-Gray +@item x:Static-Color +@item x:True-Color +@item x:Gray-Scale +@item x:Pseudo-Color +@item x:Direct-Color +@end itemize + +@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:screen-cells display screen-number +@defunx x:screen-cells display +@defunx x:screen-cells window +Returns the number of entries in the default colormap. +@end defun + +@defun x:screen-depth display screen-number +@defunx x:screen-depth display +@defunx x:screen-depth window +Returns the depth of the root window of the specified screen. + +@cindex depth +The @dfn{depth} of a window or pixmap is the number of bits per pixel it has. +The @dfn{depth} of a graphics context is the depth of the drawables it can be +used in conjunction with graphics output. +@end defun + +@defun x:screen-size display screen-number +@defunx x:screen-size display +@defunx x:screen-size window +Returns a list of integer height and width of the screen in pixels. +@end defun + +@defun x:screen-dimensions display screen-number +@defunx x:screen-dimensions display +@defunx x:screen-dimensions window +Returns a list of integer height and width of the screen in millimeters. +@end defun + +@defun x:screen-white display screen-number +@defunx x:screen-white display +@defunx x:screen-white window +Returns the white pixel value of the specified screen. +@end defun + +@defun x:screen-black display screen-number +@defunx x:screen-black display +@defunx x:screen-black window +Returns the black pixel value of the specified screen. +@end defun + + +@node Window, Window Visibility, Screen, Top +@chapter Window + +@cindex Drawable +@cindex drawable +A @dfn{Drawable} is either a window or pixmap. + +@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 +event. The created window is placed on top in the stacking order with +respect to siblings. Any part of the window that extends outside its +parent @var{window} is clipped. The @var{border-width} for an +x:Input-Only window must be zero. + +The coordinate system has the X axis horizontal and the Y axis vertical +with the origin [0, 0] at the upper-left corner. Coordinates are +integral, in terms of pixels, and coincide with pixel centers. Each +window and pixmap has its own coordinate system. For a window, the +origin is inside the border at the inside, upper-left corner. + +@var{Class} can be x:Input-Output, x:Input-Only, or x:Copy-From-Parent. +For class x:Input-Output, the @var{visual} type and @var{depth} must be +a combination supported for the screen. The @var{depth} need not be the +same as the parent, but the parent must not be a window of class +x:Input-Only. For an x:Input-Only window, the @var{depth} must be zero, +and the @var{visual} must be one supported by the screen. + +The returned window will have the attributes specified by +@var{field-name}s and @var{value}. + +@defunx 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 @var{background} and +@var{border}, have their default values. +@end defun + +@defun x:create-pixmap drawable size depth +@defunx x:create-pixmap display size depth + +@var{size} is a list, vector, or pair of nonzero integers specifying the width +and height desired in the new pixmap. + +@var{x:create-pixmap} returns a new pixmap of the width, height, and +@var{depth} specified. It is valid to pass an x:Input-Only window to the +drawable argument. The @var{depth} argument must be one of the depths +supported by the screen of the specified @var{drawable}. +@end defun + +@defun x:close window +Destroys the specified @var{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 specified by the +@var{window} argument is mapped, it is unmapped automatically. The +ordering of the DestroyNotify events is such that for any given window +being destroyed, DestroyNotify is generated on any inferiors of the +window before being generated on the window itself. The ordering among +siblings and across subhierarchies is not otherwise constrained. If the +@var{window} you specified is a root window, an error is signaled. +Destroying a mapped @var{window} will generate x:Expose events on other +windows that were obscured by the window being destroyed. +@end defun + +@defun x:close pixmap +Deletes the association between the @var{pixmap} and its storage. The X +server frees the pixmap storage when there are no references to it. +@end defun + +@defun x:window-geometry drawable +Returns a list of: + +@table @asis +@item coordinates +@code{cons} 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 +a window, these dimensions specify the inside size, not including the +border. +@item border-width +The border width in pixels. If the @var{drawable} is a pixmap, this is +zero. +@item depth +The depth of the @var{drawable} (bits per pixel for the object). +@end table +@end defun + +@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 +@code{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. +@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 +the first is one of the property-name symbols (or its top-level value) +listed below; and the second is the value to associate with that +property. + +@defvr Attribute x:CW-Back-Pixmap +Sets the background pixmap of the @var{window} to the specified pixmap. +The background pixmap can immediately be freed if no further explicit +references to it are to be made. If x:Parent-Relative is specified, the +background pixmap of the window's parent is used, or on the root window, +the default background is restored. It is an error to perform this +operation on an x:Input-Only window. If the background is set to #f or +None, the window has no defined background. +@end defvr + +@defvr Attribute x:CW-Back-Pixel +Sets the background of the @var{window} to the specified pixel value. +Changing the background does not cause the @var{window} contents to be +changed. It is an error to perform this operation on an x:Input-Only +window. +@end defvr + +@defvr Attribute x:CW-Border-Pixmap +Sets the border pixmap of the @var{window} to the pixmap you specify. +The border pixmap can be freed if no further explicit references to it +are to be made. If you specify x:Copy-From-Parent, a copy of the parent +window's border pixmap is used. It is an error to perform this +operation on an x:Input-Only @var{window}. +@end defvr + +@defvr Attribute x:CW-Border-Pixel +Sets the border of the @var{window} to the pixel @var{value}. It is an +error to perform this operation on an x:Input-Only window. +@end defvr + +@defvr Attribute x:CW-Bit-Gravity +@defvrx Attribute x:CW-Win-Gravity +The bit gravity of a window defines which region of the window should be +retained when an x:Input-Output window is resized. The default value +for the bit-gravity attribute is x:Forget-Gravity. The window gravity +of a window allows you to define how the x:Input-Output or x:Input-Only +window should be repositioned if its parent is resized. The default +value for the win-gravity attribute is x:North-West-Gravity. + +If the inside width or height of a window is not changed and if the +window is moved or its border is changed, then the contents of the +window are not lost but move with the window. Changing the inside width +or height of the window causes its contents to be moved or lost +(depending on the bit-gravity of the window) and causes children to be +reconfigured (depending on their win-gravity). For a change of width +and height, the (x, y) pairs are defined: + +@multitable @columnfractions .5 .5 +@item Gravity Direction +@tab Coordinates +@item x:North-West-Gravity +@tab (0, 0) +@item x:North-Gravity +@tab (Width/2, 0) +@item x:North-East-Gravity +@tab (Width, 0) +@item x:West-Gravity +@tab (0, Height/2) +@item x:Center-Gravity +@tab (Width/2, Height/2) +@item x:East-Gravity +@tab (Width, Height/2) +@item x:South-West-Gravity +@tab (0, Height) +@item x:South-Gravity +@tab (Width/2, Height) +@item x:South-East-Gravity +@tab (Width, Height) +@end multitable + +When a window with one of these bit-gravity values is resized, the +corresponding pair defines the change in position of each pixel in the +window. When a window with one of these win-gravities has its parent +window resized, the corresponding pair defines the change in position of +the window within the parent. When a window is so repositioned, a +x:Gravity-Notify event is generated (see section 10.10.5). + +A bit-gravity of x:Static-Gravity indicates that the contents or origin +should not move relative to the origin of the root window. If the +change in size of the window is coupled with a change in position (x, +y), then for bit-gravity the change in position of each pixel is (-x, +-y), and for win-gravity the change in position of a child when its +parent is so resized is (-x, -y). Note that x:Static-Gravity still only +takes effect when the width or height of the window is changed, not when +the window is moved. + +A bit-gravity of x:Forget-Gravity indicates that the window's contents +are always discarded after a size change, even if a backing store or +save under has been requested. The window is tiled with its background +and zero or more x:Expose events are generated. If no background is +defined, the existing screen contents are not altered. Some X servers +may also ignore the specified bit-gravity and always generate x:Expose +events. + +The contents and borders of inferiors are not affected by their parent's +bit-gravity. A server is permitted to ignore the specified bit-gravity +and use x:Forget-Gravity instead. + +A win-gravity of x:Unmap-Gravity is like x:North-West-Gravity (the +window is not moved), except the child is also unmapped when the parent +is resized, and an x:Unmap-Notify event is generated. +@end defvr + +@defvr Attribute x:CW-Backing-Store +Some implementations of the X server may choose to maintain the contents +of x:Input-Output windows. If the X server maintains the contents of a +window, the off-screen saved pixels are known as backing store. The +backing store advises the X server on what to do with the contents of a +window. The backing-store attribute can be set to x:Not-Useful +(default), x:When-Mapped, or x:Always. A backing-store attribute of +x:Not-Useful advises the X server that maintaining contents is +unnecessary, although some X implementations may still choose to +maintain contents and, therefore, not generate x:Expose events. A +backing-store attribute of x:When-Mapped advises the X server that +maintaining contents of obscured regions when the window is mapped would +be beneficial. In this case, the server may generate an x:Expose event +when the window is created. A backing-store attribute of x:Always +advises the X server that maintaining contents even when the window is +unmapped would be beneficial. Even if the window is larger than its +parent, this is a request to the X server to maintain complete contents, +not just the region within the parent window boundaries. While the X +server maintains the window's contents, x:Expose events normally are not +generated, but the X server may stop maintaining contents at any time. + +When the contents of obscured regions of a window are being maintained, +regions obscured by noninferior windows are included in the destination +of graphics requests (and source, when the window is the source). +However, regions obscured by inferior windows are not included. +@end defvr + +@defvr Attribute x:CW-Backing-Planes +@defvrx Attribute x:CW-Backing-Pixel +You can set backing planes to indicate (with bits set to 1) which bit +planes of an x:Input-Output window hold dynamic data that must be +preserved in backing store and during save unders. The default value +for the backing-planes attribute is all bits set to 1. You can set +backing pixel to specify what bits to use in planes not covered by +backing planes. The default value for the backing-pixel attribute is +all bits set to 0. The X server is free to save only the specified bit +planes in the backing store or the save under and is free to regenerate +the remaining planes with the specified pixel value. Any extraneous +bits in these values (that is, those bits beyond the specified depth of +the window) may be simply ignored. If you request backing store or save +unders, you should use these members to minimize the amount of +off-screen memory required to store your window. +@end defvr + +@defvr Attribute x:CW-Override-Redirect +To control window placement or to add decoration, a window manager often +needs to intercept (redirect) any map or configure request. Pop-up +windows, however, often need to be mapped without a window manager +getting in the way. To control whether an x:Input-Output or +x:Input-Only window is to ignore these structure control facilities, use +the override-redirect flag. + +The override-redirect flag specifies whether map and configure requests +on this window should override a x:Substructure-Redirect-Mask on the +parent. You can set the override-redirect flag to #t or #f (default). +Window managers use this information to avoid tampering with pop-up +windows. +@end defvr + +@defvr Attribute x:CW-Save-Under +Some server implementations may preserve contents of x:Input-Output windows +under other x:Input-Output windows. This is not the same as preserving the +contents of a window for you. You may get better visual appeal if +transient windows (for example, pop-up menus) request that the system +preserve the screen contents under them, so the temporarily obscured +applications do not have to repaint. + +You can set the save-under flag to True or False (default). If +save-under is True, the X server is advised that, when this window is +mapped, saving the contents of windows it obscures would be beneficial. +@end defvr + +@defvr Attribute x:CW-Event-Mask +The event mask defines which events the client is interested in for this +x:Input-Output or x:Input-Only window (or, for some event types, +inferiors of this window). The event mask is the bitwise inclusive OR +of zero or more of the valid event mask bits. You can specify that no +maskable events are reported by setting x:No-Event-Mask (default). + +The following table lists the event mask constants you can pass to the +event-mask argument and the circumstances in which you would want to +specify the event mask: + +@multitable @columnfractions .45 .55 +@item Event Mask +@tab Circumstances +@item x:No-Event-Mask +@tab No events wanted +@item x:Key-Press-Mask +@tab Keyboard down events wanted +@item x:Key-Release-Mask +@tab Keyboard up events wanted +@item x:Button-Press-Mask +@tab Pointer button down events wanted +@item x:Button-Release-Mask +@tab Pointer button up events wanted +@item x:Enter-Window-Mask +@tab Pointer window entry events wanted +@item x:Leave-Window-Mask +@tab Pointer window leave events wanted +@item x:Pointer-Motion-Mask +@tab Pointer motion events wanted +@item x:Pointer-Motion-Hint-Mask +@tab +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. +@item x:Button1-Motion-Mask +@tab Pointer motion while button 1 down +@item x:Button2-Motion-Mask +@tab Pointer motion while button 2 down +@item x:Button3-Motion-Mask +@tab Pointer motion while button 3 down +@item x:Button4-Motion-Mask +@tab Pointer motion while button 4 down +@item x:Button5-Motion-Mask +@tab Pointer motion while button 5 down +@item x:Button-Motion-Mask +@tab Pointer motion while any button down +@item x:Keymap-State-Mask +@tab Keyboard state wanted at window entry and focus in +@item x:Exposure-Mask +@tab Any exposure wanted +@item x:Visibility-Change-Mask +@tab Any change in visibility wanted +@item x:Structure-Notify-Mask +@tab Any change in window structure wanted +@item x:Resize-Redirect-Mask +@tab Redirect resize of this window +@item x:Substructure-Notify-Mask +@tab Substructure notification wanted +@item x:Substructure-Redirect-Mask +@tab Redirect structure requests on children +@item x:Focus-Change-Mask +@tab Any change in input focus wanted +@item x:Property-Change-Mask +@tab Any change in property wanted +@item x:Colormap-Change--Mask +@tab Any change in colormap wanted +@item x:Owner-Grab-Button--Mask +@tab Automatic grabs should activate with owner_events set to True +@end multitable + +@end defvr + +@defvr Attribute x:CW-Dont-Propagate +The do-not-propagate-mask attribute defines which events should not be +propagated to ancestor windows when no client has the event type +selected in this x:Input-Output or x:Input-Only window. The +do-not-propagate-mask is the bitwise inclusive OR of zero or more of the +following masks: x:Key-Press, x:Key-Release, x:Button-Press, +x:Button-Release, x:Pointer-Motion, x:Button1Motion, x:Button2Motion, +x:Button3Motion, x:Button4Motion, x:Button5Motion, and x:Button-Motion. +You can specify that all events are propagated by setting +x:No-Event-Mask (default). +@end defvr + +@defvr Attribute x:CW-Colormap +The colormap attribute specifies which colormap best reflects the true +colors of the x:Input-Output window. The colormap must have the same +visual type as the window. X servers capable of supporting multiple +hardware colormaps can use this information, and window managers can use +it for calls to X:Install-Colormap. You can set the colormap attribute +to a colormap or to x:Copy-From-Parent (default). + +If you set the colormap to x:Copy-From-Parent, the parent window's +colormap is copied and used by its child. However, the child window +must have the same visual type as the parent. The parent window must +not have a colormap of x:None. The colormap is copied by sharing the +colormap object between the child and parent, not by making a complete +copy of the colormap contents. Subsequent changes to the parent +window's colormap attribute do not affect the child window. +@end defvr + +@defvr Attribute x:CW-Cursor +The cursor attribute specifies which cursor is to be used when the +pointer is in the x:Input-Output or x:Input-Only window. You can set +the cursor to a cursor or x:None (default). + +If you set the cursor to x:None, the parent's cursor is used when the +pointer is in the x:Input-Output or x:Input-Only window, and any change +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 + + +@node Window Visibility, Graphics Context, Window, Top +@chapter Window Visibility + +@noindent +In X parlance, a window which is hidden even when not obscured by other +windows is @dfn{unmapped}; one which +@cindex map +@cindex unmap +@cindex mapped +@cindex unmapped +shows is @dfn{mapped}. It is an unfortunate name-collision with Scheme, +and is ingrained in the attribute names. + +@defun x:map-window window +Maps the @var{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 +ancestor becomes mapped. Such a window is called unviewable. When all +its ancestors are mapped, the window becomes viewable and will be +visible on the screen if it is not obscured by another window. This +function has no effect if the @var{window} is already mapped. + +If the override-redirect of the window is False and if some other client +has selected x:Substructure-Redirect-Mask on the parent window, then the X +server generates a MapRequest event, and the @code{x:map-window} +function does not map the @var{window}. Otherwise, the @var{window} is +mapped, and the X server generates a MapNotify event. + +If the @var{window} becomes viewable and no earlier contents for it are +remembered, the X server tiles the @var{window} with its background. If +the window's background is undefined, the existing screen contents are +not altered, and the X server generates zero or more x:Expose events. If +backing-store was maintained while the @var{window} was unmapped, no +x:Expose events are generated. If backing-store will now be maintained, a +full-window exposure is always generated. Otherwise, only visible +regions may be reported. Similar tiling and exposure take place for any +newly viewable inferiors. + +If the window is an Input-Output window, @code{x:map-window} generates +x:Expose events on each Input-Output window that it causes to be displayed. +If the client maps and paints the window and if the client begins +processing events, the window is painted twice. To avoid this, first +ask for x:Expose events and then map the window, so the client processes +input events as usual. The event list will include x:Expose for each +window that has appeared on the screen. The client's normal response to +an x:Expose event should be to repaint the window. This method usually +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 +displayed window. This may be much more efficient than mapping many +windows one 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 + +@defun x:unmap-window window +Unmaps the specified @var{window} and causes the X server to generate an +UnmapNotify event. If the specified @var{window} is already unmapped, +@code{x:unmap-window} has no effect. Normal exposure processing on +formerly obscured windows is performed. Any child window will no longer +be visible until another map call is made on the parent. In other +words, the subwindows are still mapped but are not visible until the +parent is mapped. Unmapping a @var{window} will generate x:Expose events +on windows that were formerly obscured by it. +@end defun + +@defun x:unmap-subwindows window +Unmaps all subwindows for the specified @var{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 windows. Using +this function is much more efficient than unmapping multiple windows one +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 +@chapter Graphics Context + +@noindent +Most attributes of graphics operations are stored in @dfn{GC}s. These +include line width, line style, plane mask, foreground, background, +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. + +@defun x:create-gc drawable field-name value @dots{} +Creates and returns graphics context. The graphics context can be used +with any destination drawable having the same root and depth as the +specified @var{drawable}. +@end defun + +@defun x:gc-set! graphics-context field-name value @dots{} +Changes the components specified by @var{field-name}s for the specified +@var{graphics-context}. The restrictions are the same as for +@code{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. +@end defun + +@defun x:copy-gc-fields! gcontext-src gcontext-dst field-name @dots{} +Copies the components specified by @var{field-name}s from +@var{gcontext-src} to @var{gcontext-dst}. @var{Gcontext-src} and +@var{gcontext-dst} must have the same root and depth. +@end defun + +@defun x:gc-ref graphics-context field-name @dots{} +Returns a list of the components specified by @var{field-name}s @dots{} +from the specified @var{graphics-context}. +@end defun + +@heading GC Attributes + +@noindent +Both @code{x:create-gc} and @code{x:change-gc} take one argument +followed by pairs of arguments, where the first is one of the +property-name symbols (or its top-level value) listed below; and the +second is the value to associate with that property. + +@defvr Attribute x:GC-Function +The function attributes of a GC are used when you update a section of a +drawable (the destination) with bits from somewhere else (the source). +The function in a GC defines how the new destination bits are to be +computed from the source bits and the old destination bits. x:G-Xcopy is +typically the most useful because it will work on a color display, but +special applications may use other functions, particularly in concert +with particular planes of a color display. The 16 functions are: + +@format +@t{ +x:G-Xclear 0 +x:G-Xand (AND src dst) +x:G-Xand-Reverse (AND src (NOT dst)) +x:G-Xcopy src +x:G-Xand-Inverted (AND (NOT src) dst) +x:G-Xnoop dst +x:G-Xxor (XOR src dst) +x:G-Xor (OR src dst) +x:G-Xnor (AND (NOT src) (NOT dst)) +x:G-Xequiv (XOR (NOT src) dst) +x:G-Xinvert (NOT dst) +x:G-Xor-Reverse (OR src (NOT dst)) +x:G-Xcopy-Inverted (NOT src) +x:G-Xor-Inverted (OR (NOT src) dst) +x:G-Xnand (OR (NOT src) (NOT dst)) +x:G-Xset 1} +@end format +@end defvr + +@defvr Attribute x:GC-Plane-Mask + +Many graphics operations depend on either pixel values or planes in a +GC. The planes attribute is an integer which specifies which planes of +the destination are to be modified, one bit per plane. A monochrome +display has only one plane and will be the least significant bit of the +integer. As planes are added to the display hardware, they will occupy +more significant bits in the plane mask. + +In graphics operations, given a source and destination pixel, the result +is computed bitwise on corresponding bits of the pixels. That is, a +Boolean operation is performed in each bit plane. The plane-mask +restricts the operation to a subset of planes. @code{x:All-Planes} can be +used to refer to all planes of the screen simultaneously. The result is +computed by the following: + +@format +(OR (AND (FUNC src dst) plane-mask) (AND dst (NOT plane-mask))) +@end format + +Range checking is not performed on a plane-mask value. It is simply +truncated to the appropriate number of bits. +@end defvr + +@defvr Attribute x:GC-Foreground +@defvrx Attribute x:GC-Background +Range checking is not performed on the values for foreground or +background. They are simply truncated to the appropriate number of +bits. + +Note that foreground and background are not initialized to any values +likely to be useful in a window. +@end defvr + +@defvr Attribute x:GC-Line-Width +The line-width is measured in pixels and either can be greater than or +equal to one (wide line) or can be the special value zero (thin line). + +Thin lines (zero line-width) are one-pixel-wide lines drawn using an +unspecified, device-dependent algorithm. There are only two constraints +on this algorithm. + +@itemize @bullet +@item +If a line is drawn unclipped from [x1,y1] to [x2,y2] and if another line +is drawn unclipped from [x1+dx,y1+dy] to [x2+dx,y2+dy], a point [x,y] is +touched by drawing the first line if and only if the point [x+dx,y+dy] +is touched by drawing the second line. + +@item +The effective set of points comprising a line cannot be affected by +clipping. That is, a point is touched in a clipped line if and only if +the point lies inside the clipping region and the point would be touched +by the line when drawn unclipped. +@end itemize + +A wide line drawn from [x1,y1] to [x2,y2] always draws the same pixels +as a wide line drawn from [x2,y2] to [x1,y1], not counting cap-style and +join-style. It is recommended that this property be true for thin +lines, but this is not required. A line-width of zero may differ from a +line-width of one in which pixels are drawn. This permits the use of +many manufacturers' line drawing hardware, which may run many times +faster than the more precisely specified wide lines. + +In general, drawing a thin line will be faster than drawing a wide line +of width one. However, because of their different drawing algorithms, +thin lines may not mix well aesthetically with wide lines. If it is +desirable to obtain precise and uniform results across all displays, a +client should always use a line-width of one rather than a linewidth of +zero. +@end defvr + +@defvr Attribute x:GC-Line-Style +The line-style defines which sections of a line are drawn: + +@table @t +@item x:Line-Solid +The full path of the line is drawn. +@item x:Line-Double-Dash +The full path of the line is drawn, but the even dashes are filled +differently from the odd dashes (see fill-style) with x:Cap-Butt style used +where even and odd dashes meet. +@item x:Line-On-Off-Dash +Only the even dashes are drawn, and cap-style applies to all internal +ends of the individual dashes, except x:Cap-Not-Last is treated as x:Cap-Butt. +@end table +@end defvr + +@defvr Attribute x:GC-Cap-Style + +The cap-style defines how the endpoints of a path are drawn: + +@table @t +@item x:Cap-Not-Last +This is equivalent to x:Cap-Butt except that for a line-width of zero the +final endpoint is not drawn. +@item x:Cap-Butt +The line is square at the endpoint (perpendicular to the slope of the +line) with no projection beyond. +@item x:Cap-Round +The line has a circular arc with the diameter equal to the line-width, +centered on the endpoint. (This is equivalent to x:Cap-Butt for line-width +of zero). +@item x:Cap-Projecting +The line is square at the end, but the path continues beyond the +endpoint for a distance equal to half the line-width. (This is +equivalent to x:Cap-Butt for line-width of zero). +@end table +@end defvr + +@defvr Attribute x:GC-Join-Style + +The join-style defines how corners are drawn for wide lines: + +@table @t +@item x:Join-Miter +The outer edges of two lines extend to meet at an angle. However, if +the angle is less than 11 degrees, then a x:Join-Bevel join-style is used +instead. +@item x:Join-Round +The corner is a circular arc with the diameter equal to the +line-width, centered on the x:Join-point. +@item x:Join-Bevel +The corner has x:Cap-Butt endpoint styles with the triangular notch filled. +@end table +@end defvr + +@defvr Attribute x:GC-Fill-Style + +The fill-style defines the contents of the source for line, text, and +fill requests. For all text and fill requests (for example, +X:Draw-Text, X:Fill-Rectangle, X:Fill-Polygon, and X:Fill-Arc); for line +requests with linestyle x:Line-Solid (for example, X:Draw-Line, +X:Draw-Segments, X:Draw-Rectangle, X:Draw-Arc); and for the even dashes +for line requests with line-style x:Line-On-Off-Dash or +x:Line-Double-Dash, the following apply: + +@table @t +@item x:Fill-Solid +Foreground +@item x:Fill-Tiled +Tile +@item x:Fill-Opaque-Stippled +A tile with the same width and height as stipple, but with background +everywhere stipple has a zero and with foreground everywhere stipple has +a one +@item x:Fill-Stippled +Foreground masked by stipple +@end table + +When drawing lines with line-style x:Line-Double-Dash, the odd dashes +are controlled by the fill-style in the following manner: + +@table @t +@item x:Fill-Solid +Background +@item x:Fill-Tiled +Same as for even dashes +@item x:Fill-Opaque-Stippled +Same as for even dashes +@item x:Fill-Stippled +Background masked by stipple +@end table +@end defvr + +@defvr Attribute x:GC-Fill-Rule +The fill-rule defines what pixels are inside (drawn) for paths given in +X:Fill-Polygon requests and can be set to x:Even-Odd-Rule or +x:Winding-Rule. + +@table @t +@item x:Even-Odd-Rule +A point is inside if an infinite ray with the point as +origin crosses the path an odd number of times. +@item x:Winding-Rule +A point is inside if an infinite ray with the point as origin crosses an +unequal number of clockwise and counterclockwise directed path segments. +@end table + +A clockwise directed path segment is one that crosses the ray from left +to right as observed from the point. A counterclockwise segment is one +that crosses the ray from right to left as observed from the point. The +case where a directed line segment is coincident with the ray is +uninteresting because you can simply choose a different ray that is not +coincident with a segment. + +For both x:Even-Odd-Rule and x:Winding-Rule, a point is infinitely +small, and the path is an infinitely thin line. A pixel is inside if +the center point of the pixel is inside and the center point is not on +the boundary. If the center point is on the boundary, the pixel is +inside if and only if the polygon interior is immediately to its right +(x increasing direction). Pixels with centers on a horizontal edge are +a special case and are inside if and only if the polygon interior is +immediately below (y increasing direction). +@end defvr + +@defvr Attribute x:GC-Tile +@defvrx Attribute x:GC-Stipple +The tile/stipple represents an infinite two-dimensional plane, with the +tile/stipple replicated in all dimensions. + +The tile pixmap must have the same root and depth as the GC, or an error +results. The stipple pixmap must have depth one and must have the same +root as the GC, or an error results. For stipple operations where the +fill-style is x:Fill-Stippled but not x:Fill-Opaque-Stippled, the +stipple pattern is tiled in a single plane and acts as an additional +clip mask to be ANDed with the clip-mask. Although some sizes may be +faster to use than others, any size pixmap can be used for tiling or +stippling. +@end defvr + +@defvr Attribute x:GC-Tile-Stip-X-Origin +@defvrx Attribute x:GC-Tile-Stip-Y-Origin +When the tile/stipple plane is superimposed on a drawable for use in a +graphics operation, the upper-left corner of some instance of the +tile/stipple is at the coordinates within the drawable specified by the +tile/stipple origin. The tile/stipple origin is interpreted relative to +the origin of whatever destination drawable is specified in a graphics +request. +@end defvr + +@defvr Attribute x:GC-Font +The font to be used for drawing text. +@end defvr + +@defvr Attribute x:GC-Subwindow-Mode +You can set the subwindow-mode to x:Clip-By-Children or +x:Include-Inferiors. +@table @t +@item x:Clip-By-Children +Both source and destination windows are additionally clipped by all +viewable Input-Output children. +@item x:Include-Inferiors +Neither source nor destination window is clipped by inferiors. This +will result in including subwindow contents in the source and drawing +through subwindow boundaries of the destination. The use of +@code{x:Include-Inferiors} on a window of one depth with mapped +inferiors of differing depth is not illegal, but the semantics are +undefined by the core protocol. +@end table +@end defvr + +@defvr Attribute x:GC-Graphics-Exposures +The graphics-exposure flag controls x:Graphics-Expose event generation +for X:Copy-Area and X:Copy-Plane requests (and any similar requests +defined by extensions). +@end defvr + +@defvr Attribute x:GC-Clip-X-Origin +@defvrx Attribute x:GC-Clip-Y-Origin +The clip-mask origin is interpreted relative to the origin of whatever +destination drawable is specified in a graphics request. +@end defvr + +@defvr Attribute x:GC-Clip-Mask +The clip-mask restricts writes to the destination drawable. If the +clip-mask is set to a pixmap, it must have depth one and have the same +root as the GC, or an error results. If clip-mask is set to +@cindex x:None +@cindex none +@dfn{x:None}, the pixels are always drawn regardless of the clip origin. +The clip-mask also can be set by calling @code{X:Set-Region}. Only +pixels where the clip-mask has a bit set to 1 are drawn. Pixels are not +drawn outside the area covered by the clip-mask or where the clip-mask +has a bit set to 0. The clip-mask affects all graphics requests. The +clip-mask does not clip sources. The clip-mask origin is interpreted +relative to the origin of whatever destination drawable is specified in +a graphics request. +@end defvr + +@defvr Attribute x:GC-Dash-Offset +Defines the phase of the pattern, specifying how many pixels into the +dash-list the pattern should actually begin in any single graphics +request. Dashing is continuous through path elements combined with a +join-style but is reset to the dash-offset between each sequence of +joined lines. + +The unit of measure for dashes is the same for the ordinary +coordinate system. Ideally, a dash length is measured along +the slope of the line, but implementations are only required +to match this ideal for horizontal and vertical lines. +Failing the ideal semantics, it is suggested that the length +be measured along the major axis of the line. The major +axis is defined as the x axis for lines drawn at an angle of +between -45 and +45 degrees or between 135 and 225 degrees +from the x axis. For all other lines, the major axis is the +y axis. +@end defvr + +@defvr Attribute x:GC-Dash-List +There must be at least one element in the specified @var{dash-list}. +The initial and alternating elements (second, fourth, and so on) of the +@var{dash-list} are the even dashes, and the others are the odd dashes. +Each element specifies a dash length in pixels. All of the elements +must be nonzero. Specifying an odd-length list is equivalent to +specifying the same list concatenated with itself to produce an +even-length list. +@end defvr + +@defvr Attribute x:GC-Arc-Mode +The arc-mode controls filling in the X:Fill-Arcs function and can be set +to x:Arc-Pie-Slice or x:Arc-Chord. +@table @t +@item x:Arc-Pie-Slice +The arcs are pie-slice filled. +@item x:Arc-Chord +The arcs are chord filled. +@end table +@end defvr + + +@node Cursor, Colormap, Graphics Context, Top +@chapter Cursor + +@defun x:create-cursor display shape +X provides a set of standard cursor shapes in a special font named +@cindex cursor +@dfn{cursor}. Applications are encouraged to use this interface for +their cursors because the font can be customized for the individual +display type. The @var{shape} argument specifies which glyph of the standard +fonts to use. + +The hotspot comes from the information stored in the cursor font. The +initial colors of a cursor are a black foreground and a white background +(see X:Recolor-Cursor). The names of all cursor shapes are defined with +the prefix XC: in @file{x11.scm}. + +@defunx 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 @var{source-char} must be a defined +glyph in @var{source-font}. The integer @var{mask-char} must be a +defined glyph in @var{mask-font}. The origins of the @var{source-char} +and @var{mask-char} glyphs are positioned coincidently and define the +hotspot. The @var{source-char} and @var{mask-char} need not have the +same bounding box metrics, and there is no restriction on the placement +of the hotspot relative to the bounding boxes. + +@defunx x:create-cursor source-font source-char #f #f fgc bgc +If @var{mask-font} and @var{mask-char} are #f, all pixels of the source +are displayed. + +@defunx x:create-cursor source-pixmap mask-pixmap fgc bgc origin +@var{mask-pixmap} must be the same size as the pixmap defined by the +@var{source-pixmap} argument. The foreground and background RGB values +must be specified using @var{foreground-color} and +@var{background-color}, even if the X server only has a x:Static-Gray or +x:Gray-Scale screen. The hotspot must be a point within the +@var{source-pixmap}. + +@code{X:Create-Cursor} creates and returns a cursor. The +@var{foreground-color} is used for the pixels set to 1 in the source, +and the @var{background-color} is used for the pixels set to 0. Both +source and mask must have depth one but can have any root. The +@var{mask-pixmap} defines the shape of the cursor. The pixels set to 1 +in @var{mask-pixmap} define which source pixels are displayed, and the +pixels set to 0 define which pixels are ignored. + +@defunx x:create-cursor source-pixmap #f fgc bgc origin +If @var{mask-pixmap} is #f, all pixels of the source are displayed. +@end defun + +@node Colormap, Rendering, Cursor, Top +@chapter Colormap + +@cindex colormap +@cindex RGB +A @dfn{colormap} maps pixel values to @dfn{RGB} color space values. + +@defun x:create-colormap window visual alloc-policy +@var{window} specifies the window on whose screen you want to create a +colormap. @var{visual} specifies a visual type supported on the screen. +@var{alloc-policy} Specifies the colormap entries to be allocated. You +can pass @code{X:Alloc-None} or @code{X:Alloc-All}. + +The @code{X:Create-Colormap} function creates and returns a colormap of +the specified @var{visual} type for the screen on which @var{window} +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 +The initial values of the colormap entries are undefined. + +@item X:Static-Gray +@itemx X:Static-Color +@itemx 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}. + +@end table + +For the other visual classes, if @var{alloc-policy} is +@samp{X:Alloc-None}, the colormap initially has no allocated entries, +and clients can allocate them. + +If @var{alloc-policy} is @samp{X:Alloc-All}, the entire colormap is +allocated writable. The initial values of all allocated entries are +undefined. + +@table @samp +@item X:Gray-Scale +@itemx 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}. + +@item X:Direct-Color +The effect is as if an @code{XAllocColorPlanes} call returned a pixel +value of zero and red_mask, green_mask, and blue_mask values containing +the same bits as the corresponding masks in the specified visual. +@end table + +@end defun + + +To create a new colormap when the allocation out of a previously +shared colormap has failed because of resource exhaustion, use: + +@defun x:copy-colormap-and-free colormap + +Creates and returns a colormap of the same visual type and for the same +screen as the specified @var{colormap}. It also moves all of the +client's existing allocation from the specified @var{colormap} to the +new colormap with their color values intact and their read-only or +writable characteristics intact and frees those entries in the specified +colormap. Color values in other entries in the new colormap are +undefined. If the specified colormap was created by the client with +alloc set to @samp{X:Alloc-All}, the new colormap is also created with +@samp{X:Alloc-All}, all color values for all entries are copied from the +specified @var{colormap}, and then all entries in the specified +@var{colormap} are freed. If the specified @var{colormap} was not +created by the client with @samp{X:Alloc-All}, the allocations to be moved +are all those pixels and planes that have been allocated by the client +and that have not been freed since they were allocated. + +@end defun + +A @dfn{colormap} maps pixel values to elements of the @dfn{RGB} +datatype. An @var{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. + +@defun x:alloc-colormap-cells colormap ncolors nplanes +@defunx x:alloc-colormap-cells colormap ncolors nplanes contiguous? + +The @code{X:Alloc-Color-Cells} function allocates read/write color +cells. The number of colors, @var{ncolors} must be positive and the +number of planes, @var{nplanes} nonnegative. If @var{ncolors} and +nplanes are requested, then @var{ncolors} pixels and nplane plane masks +are returned. No mask will have any bits set to 1 in common with any +other mask or with any of the pixels. By ORing together each pixel with +zero or more masks, @var{ncolors} * 2^@var{nplanes} distinct pixels can +be produced. All of these are allocated writable by the request. + +@table @samp +@item x:Gray-Scale +@itemx 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. +@item x:Direct-Color +Each mask has exactly three bits set to 1. If @var{contiguous?} is +non-false and if all masks are ORed together, three contiguous sets of +bits set to 1 (one within each pixel subfield) is formed. +@end table + +The RGB values of the allocated entries are undefined. +@code{X:Alloc-Color-Cells} returns a list of two uniform arrays if it +succeeded or #f if it failed. The first array has the pixels allocated +and the second has the plane-masks. + + +@defunx x:alloc-colormap-cells colormap ncolors rgb +@defunx x:alloc-colormap-cells colormap ncolors rgb contiguous? + +The specified @var{ncolors} must be positive; and @var{rgb} a list or +vector of 3 nonnegative integers. If @var{ncolors} colors, @var{nreds} +reds, @var{ngreens} greens, and @var{nblues} blues are requested, +@var{ncolors} pixels are returned; and the masks have @var{nreds}, +@var{ngreens}, and @var{nblues} bits set to 1, respectively. If +@var{contiguous?} is non-false, each mask will have a contiguous set of +bits set to 1. No mask will have any bits set to 1 in common with any +other mask or with any of the pixels. + +Each mask will lie within the corresponding pixel subfield. By ORing +together subsets of masks with each pixel value, @var{ncolors} * +2(@var{nreds}+@var{ngreens}+@var{nblues}) distinct pixel values can be +produced. All of these are allocated by the request. However, in the +colormap, there are only @var{ncolors} * 2^@var{nreds} independent red +entries, @var{ncolors} * 2^@var{ngreens} independent green entries, and +@var{ncolors} * 2^@var{nblues} independent blue entries. + +@code{X:Alloc-Color-Cells} returns a list if it succeeded or #f if it +failed. The first element of the list has an array of the pixels +allocated. The second, third, and fourth elements are the red, green, +and blue plane-masks. +@end defun + +@defun x:free-colormap-cells colormap pixels planes +@defunx x:free-colormap-cells colormap pixels + +Frees the cells represented by pixels whose values are in the +@var{pixels} unsigned-integer uniform-vector. The @var{planes} argument +should not have any bits set to 1 in common with any of the pixels. The +set of all pixels is produced by ORing together subsets of the +@var{planes} argument with the pixels. The request frees all of these +pixels that were allocated by the client. Note that freeing an +individual pixel obtained from @code{X:Alloc-Colormap-Cells} with a +planes argument may not actually allow it to be reused until all of its +related pixels are also freed. Similarly, a read-only entry is not +actually freed until it has been freed by all clients, and if a client +allocates the same read-only entry multiple times, it must free the +entry that many times before the entry is actually freed. + +All specified pixels that are allocated by the client in the +@var{colormap} are freed, even if one or more pixels produce an error. +It is an error if a specified pixel is not allocated by the client (that +is, is unallocated or is only allocated by another client) or if the +colormap was created with all entries writable (by passing +@samp{x:Alloc-All} to @code{X:Create-Colormap}). If more than one pixel +is in error, the one that gets reported is arbitrary. +@end defun + +@defun x:colormap-find-color colormap rgb + +@var{rgb} is a list or vector of 3 integers, describing the red, green, +and blue intensities respectively; or an integer @samp{#x@i{rrggbb}}, +packing red, green and blue intensities in the range 0 - 255. + +@defunx x:colormap-find-color colormap color-name + +The case-insensitive string @var{color_name} specifies the name of a +color (for example, @file{red}) + +@code{X:Colormap-Find-Color} allocates a read-only colormap entry +corresponding to the closest RGB value supported by the hardware. +@code{X:Colormap-Find-Color} returns the pixel value of the color +closest to the specified @var{RGB} or @var{color_name} elements +supported by the hardware, if successful; otherwise +@code{X:Colormap-Find-Color} returns #f. + +Multiple clients that request the same effective RGB value can +be assigned the same read-only entry, thus allowing entries to be +shared. When the last client deallocates a shared cell, it is +deallocated. + +@end defun + +@defun x:color-ref colormap pixel + +Returns a list of 3 integers, describing the red, green, +and blue intensities respectively of the @var{colormap} entry of the +cell indexed by @var{pixel}. + +The integer @var{pixel} must be a valid index into @var{colormap}. +@end defun + +@defun X:Color-Set! colormap pixel rgb + +@var{rgb} is a list or vector of 3 integers, describing the red, green, +and blue intensities respectively; or an integer @samp{#x@i{rrggbb}}, +packing red, green and blue intensities in the range 0 - 255. + +@defunx X:Color-Set! colormap pixel color-name + +The case-insensitive string @var{color_name} specifies the name of a +color (for example, @file{red}) + +The integer @var{pixel} must be a valid index into @var{colormap}. + +@code{X:Color-Set!} changes the @var{colormap} entry of the read/write +cell indexed by @var{pixel}. If the @var{colormap} is an installed map +for its screen, the changes are visible immediately. + +@end defun + +@defun x:install-colormap colormap + +Installs the specified @var{colormap} for its associated screen. All +windows associated with @var{colormap} immediately display with true +colors. A colormap is associated with a window when the window is +created or its attributes changed. + +If the specified colormap is not already an installed colormap, the X +server generates a ColormapNotify event on each window that has that +colormap. + +@end defun + + +@node Rendering, Event, Colormap, Top +@chapter Rendering + +@defun x:flush display +@defunx 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. + +@defunx x:flush gc +Forces sending of GC component changes. + +Xlib usually defers sending changes to the components of a GC to the +server until a graphics function is actually called with that GC. This +permits batching of component changes into a single server request. In +some circumstances, however, it may be necessary for the client to +explicitly force sending the changes to the server. An example might be +when a protocol extension uses the GC indirectly, in such a way that the +extension interface cannot know what GC will be used. +@end defun + +@defun x:clear-area window (x-pos y-pos) (width height) expose? +Paints a rectangular area in the specified @var{window} according to the +specified dimensions with the @var{window}'s background pixel or pixmap. +The subwindow-mode effectively is @samp{x:Clip-By-Children}. If width +is zero, it is replaced with the current width of the @var{window} minus +x. If height is zero, it is replaced with the current height of the +@var{window} minus y. If the @var{window} has a defined background +tile, the rectangle clipped by any children is filled with this tile. +If the @var{window} has background x:None, the contents of the +@var{window} are not changed. In either case, if @var{expose?} is True, +one or more x:Expose events are generated for regions of the rectangle +that are either visible or are being retained in a backing store. If +you specify a @var{window} whose class is x:Input-Only, an error +results. +@end defun + +@defun x:fill-rectangle window gcontext position size + +@end defun + +@heading Draw Strings + +@defun x:draw-string drawable gc position string +@var{Position} specifies coordinates relative to the origin of +@var{drawable} of the origin of the first character to be drawn. + +@code{x:draw-string} draws the characters of @var{string}, starting at +@var{position}. +@end defun + +@defun x:image-string drawable gc position string +@var{Position} specifies coordinates relative to the origin of +@var{drawable} of the origin of the first character to be drawn. + +@code{x:image-string} draws the characters @emph{and background} of +@var{string}, starting at @var{position}. +@end defun + +@heading Draw Shapes + +@defun x:draw-points drawable gc position @dots{} +@var{Position} @dots{} specifies coordinates of the point to be drawn. + +@defunx x:draw-points drawable gc x y @dots{} +(@var{x}, @var{y}) @dots{} specifies coordinates of the point to be +drawn. + +@defunx x:draw-points drawable gc point-array +@var{point-array} is a uniform short array of rank 2, whose rightmost +index spans a range of 2. + +The @code{X:Draw-Points} procedure uses the foreground pixel and +function components of the @var{gc} to draw points into @var{drawable} +at the positions (relative to the origin of @var{drawable}) specified. + +@code{X:Draw-Points} uses these @var{gc} components: function, +planemask, foreground, subwindow-mode, clip-x-origin, clip-y-origin, and +clip-mask. +@end defun + + +@defun x:draw-segments drawable gc pos1 pos2 @dots{} +@var{Pos1}, @var{pos2}, @dots{} specify coordinates to be connected by +segments. + +@defunx x:draw-segments drawable gc x1 y1 x2 y2 @dots{} +(@var{x1}, @var{y1}), (@var{x2}, @var{y2}) @dots{} specify coordinates +to be connected by segments. + +@defunx x:draw-segments drawable gc point-array +@var{point-array} is a uniform short array of rank 2, whose rightmost +index spans a range of 2. + +The @code{X:Draw-Segments} procedure uses the components of the +specified @var{gc} to draw multiple unconnected lines between disjoint +adjacent pair of points passed as arguments. It draws the segments in +order and does not perform joining at coincident endpoints. For any +given line, @code{X:Draw-Segments} does not draw a pixel more than once. +If thin (zero line-width) segments intersect, the intersecting pixels +are drawn multiple times. If wide segments intersect, the intersecting +pixels are drawn only once, as though the entire PolyLine protocol +request were a single, filled shape. @code{X:Draw-Segments} treats all +coordinates as relative to the origin of @var{drawable}. + +@code{X:Draw-Segments} uses these @var{gc} components: function, +plane-mask, line-width, line-style, cap-style, fill-style, +subwindow-mode, clip-x-origin, clip-y-origin, and clip-mask, join-style. +It also use these @var{gc} mode-dependent components: foreground, +background, tile, stipple, tilestipple-x-origin, tile-stipple-y-origin, +dash-offset, and dash-list. +@end defun + +@defun x:draw-lines drawable gc pos1 pos2 @dots{} +@var{Pos1}, @var{pos2}, @dots{} specify coordinates to be connected by +lines. + +@defunx x:draw-lines drawable gc x1 y1 x2 y2 @dots{} +(@var{x1}, @var{y1}), (@var{x2}, @var{y2}) @dots{} specify coordinates +to be connected by lines. + +@defunx x:draw-lines drawable gc point-array +@var{point-array} is a uniform short array of rank 2, whose rightmost +index spans a range of 2. + +The @code{X:Draw-Lines} procedure uses the components of the specified +@var{gc} to draw lines between each adjacent pair of points passed as +arguments. It draws the lines in order. The lines join correctly at +all intermediate points, and if the first and last points coincide, the +first and last lines also join correctly. For any given line, +@code{X:Draw-Lines} does not draw a pixel more than once. If thin (zero +line-width) lines intersect, the intersecting pixels are drawn multiple +times. If wide lines intersect, the intersecting pixels are drawn only +once, as though the entire PolyLine protocol request were a single, +filled shape. @code{X:Draw-Lines} treats all coordinates as relative to +the origin of @var{drawable}. + +@code{X:Draw-Lines} uses these @var{gc} components: function, +plane-mask, line-width, line-style, cap-style, fill-style, +subwindow-mode, clip-x-origin, clip-y-origin, and clip-mask, join-style. +It also use these @var{gc} mode-dependent components: foreground, +background, tile, stipple, tilestipple-x-origin, tile-stipple-y-origin, +dash-offset, and dash-list. +@end defun + +@defun x:fill-polygon drawable gc pos1 pos2 @dots{} +@var{Pos1}, @var{pos2}, @dots{} specify coordinates of the border path. + +@defunx x:fill-polygon drawable gc x1 y1 x2 y2 @dots{} +(@var{x1}, @var{y1}), (@var{x2}, @var{y2}) @dots{} specify coordinates +of the border path. + +@defunx x:fill-polygon drawable gc point-array +@var{point-array} is a uniform short array of rank 2, whose rightmost +index spans a range of 2. + +The path is closed automatically if the last point in the list or +@var{point-array} does not coincide with the first point. + +The @code{X:Fill-Polygon} procedure uses the components of the specified +@var{gc} to fill the region closed by the specified path. +@code{X:Fill-Polygon} does not draw a pixel of the region more than +once. @code{X:Fill-Polygon} treats all coordinates as relative to the +origin of @var{drawable}. + +@code{X:Fill-Polygon} uses these @var{gc} components: function, +planemask, fill-style, fill-rule, subwindow-mode, clip-x-origin, +clip-y-origin, and clip-mask. It also use these @var{gc} mode-dependent +components: foreground, background, tile, stipple, +tile-stipple-x-origin, and tile-stipple-y-origin. +@end defun + +@node Event, Index, Rendering, Top +@chapter Event + +@noindent +These three status routines always return immediately if there are +events already in the queue. + +@defun x:q-length display +Returns the length of the event queue for the connected @var{display}. +Note that there may be more events that have not been read into the +queue yet (see X:Events-Queued). +@end defun + +@defun 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. +@end defun + +@defun 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, @code{X:Events-Queued} +attempts to read more events out of the application's connection without +flushing the output buffer and returns the number read. +@end defun + +@noindent +Both of these routines return an object of type @dfn{event}. + +@defun x:next-event display +Removes and returns the first event from the event queue. If the event +queue is empty, @code{X:Next-Event} flushes the output buffer and blocks +until an event is received. +@end defun + +@defun 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, @code{X:Peek-Event} +flushes the output buffer and blocks until an event is received. +@end defun + +@noindent +Each event object has fields dependent on its sub-type. + +@defun x:event-ref event field-name +@multitable @columnfractions .40 .60 +@item window +@tab +The window on which @var{event} was generated and is referred to as the +event window. +@item root +@tab +is the event window's root window. +@item subwindow +@tab +If the source window is an inferior of the event window, the +@var{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, @samp{None}. +@item X-event:type +@tab +An integer: @var{x:Key-Press}, @var{x:Key-Release}, +@var{x:Button-Press}, @var{x:Button-Release}, @var{x:Motion-Notify}, +@var{x:Enter-Notify}, @var{x:Leave-Notify}, @var{x:Focus-In}, +@var{x:Focus-Out}, @var{x:Keymap-Notify}, @var{x:Expose}, +@var{x:Graphics-Expose}, @var{x:No-Expose}, @var{x:Visibility-Notify}, +@var{x:Create-Notify}, @var{x:Destroy-Notify}, @var{x:Unmap-Notify}, +@var{x:Map-Notify}, @var{x:Map-Request}, @var{x:Reparent-Notify}, +@var{x:Configure-Notify}, @var{x:Configure-Request}, +@var{x:Gravity-Notify}, @var{x:Resize-Request}, +@var{x:Circulate-Notify}, @var{x:Circulate-Request}, +@var{x:Property-Notify}, @var{x:Selection-Clear}, +@var{x:Selection-Request}, @var{x:Selection-Notify}, +@var{x:Colormap-Notify}, @var{x:Client-Message}, or +@var{x:Mapping-Notify}. +@item X-event:serial +@tab +The serial number of the protocol request that generated the @var{event}. +@item X-event:send-event +@tab +Boolean that indicates whether the event was sent by a different client. +@item X-event:time +@tab +The time when the @var{event} was generated expressed in milliseconds. +@item X-event:x +@item X-event:y +@tab +For window entry/exit events the @var{x} and @var{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, +@var{x} and @var{y} are the pointer coordinates relative to the event +window's origin. Otherwise, @var{x} and @var{y} are set to zero. + +For expose events The @var{x} and @var{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 @var{x} and +@var{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. +@item X-event:x-root +@itemx X-event:y-root +@tab +The pointer's coordinates relative to the root window's origin at the +time of the @var{event}. +@item X-event:state +@tab +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 @var{event}, which is the bitwise inclusive OR of +one or more of the button or modifier key masks: @var{x:Button1-Mask}, +@var{x:Button2-Mask}, @var{x:Button3-Mask}, @var{x:Button4-Mask}, +@var{x:Button5-Mask}, @var{x:Shift-Mask}, @var{x:Lock-Mask}, +@var{x:Control-Mask}, @var{x:Mod1-Mask}, @var{x:Mod2-Mask}, +@var{x:Mod3-Mask}, @var{x:Mod4-Mask}, and @var{x:Mod5-Mask}. + +For visibility events, the state of the window's visibility: +@var{x:Visibility-Unobscured}, @var{x:Visibility-Partially-Obscured}, or +@var{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. +@item X-event:keycode +@tab +An integer that represents a physical key on the keyboard. +@item X-event:same-screen +@tab +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. +@item X-event:button +@tab +The pointer button that changed state; can be the @var{x:Button1}, +@var{x:Button2}, @var{x:Button3}, @var{x:Button4}, or @var{x:Button5} +value. +@item X-event:is-hint +@tab +Detail of motion-notify events: @var{x:Notify-Normal} or +@var{x:Notify-Hint}. +@item X-event:mode +@tab +Indicates whether the @var{event} is a normal event, pseudo-motion event +when a grab activates, or a pseudo-motion event when a grab deactivates: +@var{x:Notify-Normal}, @var{x:Notify-Grab}, or @var{x:Notify-Ungrab}. +@item X-event:detail +@tab +Indicates the notification detail: @var{x:Notify-Ancestor}, +@var{x:Notify-Virtual}, @var{x:Notify-Inferior}, +@var{x:Notify-Nonlinear}, or @var{x:Notify-Nonlinear-Virtual}. +@item X-event:focus +@tab +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 +@tab +The size (extent) of the rectangle. +@item X-event:count +@tab +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. +@item X-event:major-code +@tab +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. +@item X-event:minor-code +@tab +Not currently used. +@item X-event:border-width +@tab +For configure events, the width of the window's border, in pixels. +@item X-event:override-redirect +@tab +The override-redirect attribute of the window. Window manager clients +normally should ignore this window if it is #t. +@item X-event:from-configure +@tab +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. +@item X-event:value-mask +@tab +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. +@item X-event:place +@tab +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. +@item X-event:new +@tab +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. +@item X-event:format +@tab +Is 8, 16, or 32 and specifies whether the data should be viewed as a +list of bytes, shorts, or longs +@item X-event:request +@tab +Indicates the kind of mapping change that occurred and can be +@var{x:Mapping-Modifier}, @var{x:Mapping-Keyboard}, or +@var{x:Mapping-Pointer}. If it is @var{x:Mapping-Modifier}, the +modifier mapping was changed. If it is @var{x:Mapping-Keyboard}, the +keyboard mapping was changed. If it is @var{x:Mapping-Pointer}, the +pointer button mapping was changed. +@item X-event:first-keycode +@tab +The X-event:first-keycode is set only if the X-event:request was set to +@var{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. +@end multitable +@end defun + +@node Index, , Event, Top +@c @node Procedure and Macro Index, Variable Index, The Implementation, Top +@unnumbered Procedure and Macro Index + +This is an alphabetical list of all the procedures and macros in Xlibscm. + +@printindex fn + +@c @node Variable Index, Type Index, Procedure and Macro Index, Top +@unnumbered Variable Index + +This is an alphabetical list of all the global variables in Xlibscm. + +@printindex vr + +This is an alphabetical list of concepts introduced in this manual. + +@unnumbered Concept Index +@printindex cp + +@contents +@bye @@ -12,7 +12,7 @@ ;; ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -1,10 +1,70 @@ #!/bin/sh :;exec scmlit -f $0 -e"(bi)" build $* -(require '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) @@ -22,8 +82,12 @@ (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) + (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)))))))))) @@ -48,7 +112,7 @@ (display "build> ") (force-output))) -(define (bi) (build-from-argv *argv*)) +(define (bi) (if (build-from-argv *argv*) #t (exit #f))) (cond (*interactive* (display "type (b \"build <command-line>\") to build") (newline) @@ -1 +1,4 @@ -scmlit -f build -e(bi) build %1 %2 %3 %4 %5 %6 %7 %8 %9 +scmlit -fbuild -e(bi) build %1 %2 %3 %4 %5 %6 %7 %8 %9 +@IF NOT ERRORLEVEL 1 GOTO ok +@ECHO **** build.bat FAILED! **** +:ok @@ -1,9 +1,10 @@ ;;; "build.scm" Build database and program -*-scheme-*- -;;; Copyright (C) 1994, 1995, 1996, 1997 Aubrey Jaffer. +;;; Copyright (C) 1994-1999 Aubrey Jaffer. ;;; See the file `COPYING' for terms applying to this program. (require 'parameters) (require 'database-utilities) +(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)) @@ -11,9 +12,10 @@ (require 'glob) (require 'batch) (batch:initialize! build) -((((build 'open-table) 'batch-dialect #t) 'row:insert) '(default-for-platform)) +((((build 'open-table) 'batch-dialect #t) 'row:insert) + '(default-for-platform 0)) -(set! OPEN_WRITE "w") ; Because MS-DOS scripts need ^M +;;;; This first part is about SCM files and features. (define-tables build @@ -44,22 +46,6 @@ (test "test SCM") (none "no files"))) - '(build-whats - ((name symbol)) - ((class file-categories) - (c-proc symbol) - (o-proc symbol) - (spec expression) - (documentation string)) - ((exe required compile-c-files link-c-program #f - "executable program") - (lib required compile-c-files make-archive ((define "RTL")) - "library module") - (dlls linkable compile-dll-c-files make-dll-archive ((define "DLL")) - "archived dynamically linked library object files") - (dll none compile-dll-c-files update-catalog ((define "DLL")) - "dynamically linked library object file"))) - '(manifest ((file string) (format file-formats) @@ -95,7 +81,8 @@ ("continue.h" c-header required "continuations.") ("continue.c" c-source required "continuations.") ("scm.h" c-header required "data type and external definitions of SCM.") - ("scm.c" c-source required "top level, interrupts, and non-IEEE utility functions.") + ("scm.c" c-source required "initialization, interrupts, and non-IEEE utility functions.") + ("scmmain.c" c-source required "initialization, interrupts, and non-IEEE utility functions.") ("findexec.c" c-source required "find the executable file function.") ("script.c" c-source required "utilities for running as `#!' script.") ("time.c" c-source required "functions dealing with time.") @@ -127,14 +114,283 @@ ("unexhp9k800.c" c-source platform-specific "Convert a running HP-UX program into an executable file.") ("unexelf.c" c-source platform-specific "Convert a running ELF program into an executable file.") ("unexalpha.c" c-source platform-specific "Convert a running program into an Alpha executable file.") + ("unexsgi.c" c-source platform-specific "Convert a running program into an IRIX executable file.") ("unexsunos4.c" c-source platform-specific "Convert a running program into an executable file.") - ))) + )) + + '(build-whats + ((name symbol)) + ((class file-categories) + (c-proc symbol) + (o-proc symbol) + (spec expression) + (documentation string)) + ((exe required compile-c-files link-c-program #f + "executable program") + (lib required compile-c-files make-archive ((c-lib lib)) + "library module") + (dlls linkable compile-dll-c-files make-dll-archive ((define "DLL")) + "archived dynamically linked library object files") + (dll none compile-dll-c-files update-catalog ((define "DLL")) + "dynamically linked library object file"))) + + '(features + ((name symbol)) + ((spec expression) + (documentation string)) + ((none () "No features")))) (for-each (build 'add-domain) '((optstring #f (lambda (x) (or (not x) (string? x))) string #f) (filename #f #f string #f) + (features features #f symbol #f) (build-whats build-whats #f symbol #f))) +(define define-build-feature + (let ((defeature (((build 'open-table) 'features #t) 'row:insert))) + (lambda args + (defeature (append args (list (comment))))))) + +#;Lightweight -- no features +(define-build-feature + 'lit + '()) + +#;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}. +(define-build-feature + 'cautious + '((define "CAUTIOUS"))) + +#;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. +(define-build-feature + 'careful-interrupt-masking + '((define "CAREFUL_INTS"))) + +#;Turns on the features @samp{cautious}, +#;@samp{careful-interrupt-masking}, and @samp{stack-limit}; uses +#;@code{-g} flags for debugging SCM source code. +(define-build-feature + 'debug + '((c-lib debug) (features cautious careful-interrupt-masking stack-limit))) + +#;If your scheme code runs without any errors you can disable almost +#;all error checking by compiling all files with @samp{reckless}. +(define-build-feature + 'reckless + '((define "RECKLESS"))) + +#;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. +(define-build-feature + 'stack-limit + '((define ("STACK_LIMIT" "(HEAP_SEG_SIZE/2)")))) + +#;C level support for hygienic and referentially transparent macros +#;(syntax-rules macros). +(define-build-feature + 'macro + '((define "MACRO") (features rev2-procedures record))) + +#;Large precision integers. +(define-build-feature + 'bignums + '((define "BIGNUMS"))) + +#;Use if you want arrays, uniform-arrays and uniform-vectors. +(define-build-feature + 'arrays + '((define "ARRAYS"))) + +#;Alias for ARRAYS +(define-build-feature + 'array + '((define "ARRAYS"))) + +#;array-map! and array-for-each (arrays must also be featured). +(define-build-feature + 'array-for-each + '((c-file "ramap.c") (init "init_ramap"))) + +#;Use if you want floating point numbers. +(define-build-feature + 'inexact + '((define "FLOATS") (c-lib m))) + +#;Use if you want floats to display in engineering notation (exponents +#;always multiples of 3) instead of scientific notation. +(define-build-feature + 'engineering-notation + '((define "ENGNOT"))) + +#;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. +(define-build-feature + 'single-precision-only + '((define "SINGLESONLY"))) + +#;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 +(define-build-feature + 'sicp + '((define "SICP"))) + +#;These procedures were specified in the @cite{Revised^2 Report on Scheme} +#;but not in @cite{R4RS}. +(define-build-feature + 'rev2-procedures + '((c-file "sc2.c") (init "init_sc2"))) + +#;The Record package provides a facility for user to define their own +#;record data types. See SLIB for documentation. +(define-build-feature + 'record + '((define "CCLO") (c-file "record.c") (init "init_record"))) + +#;Use if you want to use compiled closures. +(define-build-feature + 'compiled-closure + '((define "CCLO"))) + +#;@code{make_gsubr} for arbitrary (< 11) arguments to C functions. +(define-build-feature + 'generalized-c-arguments + '((c-file "gsubr.c") (init "init_gsubr"))) + +#;Use if you want the ticks and ticks-interrupt functions. +(define-build-feature + 'tick-interrupts + '((define "TICKS"))) + +#;Commonly available I/O extensions: @dfn{exec}, line I/O, file +#;positioning, file delete and rename, and directory functions. +(define-build-feature + 'i/o-extensions + '((c-file "ioext.c") (init "init_ioext"))) + +#;@dfn{Turtle} graphics calls for both Borland-C and X11 from +#;sjm@@ee.tut.fi. +(define-build-feature + 'turtlegr + '((c-file "turtlegr.c") (c-lib graphics) (features inexact) + (init "init_turtlegr"))) + +#;Interface to Xlib graphics routines. +(define-build-feature + 'Xlib + '((c-file "x.c") (c-lib graphics) (compiled-init "init_x") (features arrays))) + +#;Alias for Xlib feature. +(define-build-feature + 'X + '((features Xlib))) + +#;For the @dfn{curses} screen management package. +(define-build-feature + 'curses + '((c-file "crs.c") (c-lib curses) (init "init_crs"))) + +#;interface to the editline or GNU readline library. +(define-build-feature + 'edit-line + '((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"))) + +#;String regular expression matching. +(define-build-feature + 'regex + '((c-file "rgx.c") (c-lib regex) (init "init_rgx"))) + +#;BSD @dfn{socket} interface. +(define-build-feature + 'socket + '((c-lib socket) (c-file "socket.c") (init "init_socket"))) + +#;Posix functions available on all @dfn{Unix-like} systems. fork and +#;process functions, user and group IDs, file permissions, and +#;@dfn{link}. +(define-build-feature + 'posix + '((c-file "posix.c") (init "init_posix"))) + +#;Those unix features which have not made it into the Posix specs: +#;nice, acct, lstat, readlink, symlink, mknod and sync. +(define-build-feature + 'unix + '((c-file "unix.c") (init "init_unix"))) + +#;Microsoft Windows executable. +(define-build-feature + 'windows + '((c-lib windows))) ; (define "NON_PREEMPTIVE") + +#;Be able to load compiled files while running. +(define-build-feature + 'dynamic-linking + '((c-file "dynl.c") (c-lib dlll))) + +#;Convert a running scheme program into an executable file. +(define-build-feature + 'dump + '((define "CAN_DUMP") (c-lib dump) (c-lib nostart))) + +;;; Descriptions of these parameters is in "setjump.h". +;; (initial-heap-size ((define "INIT_HEAP_SIZE" (* 25000 sizeof-cell)))) +;; (heap-segment-size ((define "HEAP_SEG_SIZE" (* 8100 sizeof-cell)))) +;; (short-aligned-stack ((define "SHORT_ALIGN"))) +;; (initial-malloc-limit ((define "INIT_MALLOC_LIMIT" 100000))) +;; (number-of-hash-buckets ((define "NUM_HASH_BUCKETS" 137))) +;; (minimum-gc-yield ((define "MIN_GC_YIELD" "(heap_cells/4)"))) + +#;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. +(define-build-feature + 'no-heap-shrink + '((define "DONT_GC_FREE_SEGMENTS"))) + +#;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. +(define-build-feature + 'cheap-continuations + '((define "CHEAP_CONTINUATIONS"))) + + +;;;; The rest is about building on specific platforms. + (define-tables build '(processor-family @@ -166,43 +422,46 @@ ((name symbol)) ((processor processor-family) (operating-system operating-system) - (compiler symbol)) - ((*unknown* *unknown* unix *unknown*) - (acorn-unixlib acorn *unknown* *unknown*) - (aix powerpc aix *unknown*) - (alpha alpha osf1 cc) - (alpha-elf alpha unix *unknown*) - (alpha-linux alpha linux gcc) - (amiga-aztec m68000 amiga aztec) - (amiga-dice-c m68000 amiga dice-c) - (amiga-gcc m68000 amiga gcc) - (amiga-sas/c-5.10 m68000 amiga sas/c) - (atari-st-gcc m68000 atari.st gcc) - (atari-st-turbo-c m68000 atari.st turbo-c) - (borland-c-3.1 8086 ms-dos borland-c) - (cygwin32 i386 unix gcc) - (djgpp i386 ms-dos gcc) - (freebsd i386 unix cc) - (gcc *unknown* unix gcc) - (highc.31 i386 ms-dos highc) - (hp-ux hp-risc hp-ux *unknown*) - (linux i386 linux gcc) - (linux-aout i386 linux gcc) - (microsoft-c 8086 ms-dos microsoft-c) - (microsoft-c-nt i386 ms-dos microsoft-c) - (microsoft-quick-c 8086 ms-dos microsoft-quick-c) - (ms-dos 8086 ms-dos *unknown*) - (os/2-cset i386 os/2 C-Set++) - (os/2-emx i386 os/2 gcc) - (sun-svr4-gcc-sunld sparc sunos gcc) - (sunos sparc sunos *unknown*) - (svr4 *unknown* unix *unknown*) - (turbo-c-2 8086 ms-dos turbo-c) - (unicos cray unicos *unknown*) - (unix *unknown* unix *unknown*) - (vms vax vms *unknown*) - (vms-gcc vax vms gcc) - (watcom-9.0 i386 ms-dos watcom) + (compiler symbol) + ;;(linker symbol) + ) + ((*unknown* *unknown* unix cc ) ;ld + (acorn-unixlib acorn *unknown* cc ) ;link + (aix powerpc aix cc ) ;cc + (alpha alpha osf1 cc ) ;cc + (alpha-elf alpha unix cc ) ;cc + (alpha-linux alpha linux gcc ) ;gcc + (amiga-aztec m68000 amiga cc ) ;cc + (amiga-dice-c m68000 amiga dcc ) ;dcc + (amiga-gcc m68000 amiga gcc ) ;gcc + (amiga-sas m68000 amiga lc ) ;link + (atari-st-gcc m68000 atari.st gcc ) ;gcc + (atari-st-turbo-c m68000 atari.st tcc ) ;tlink + (borland-c 8086 ms-dos bcc ) ;bcc + (cygwin32 i386 unix gcc ) ;gcc + (djgpp i386 ms-dos gcc ) ;gcc + (freebsd i386 unix cc ) ;cc + (gcc *unknown* unix gcc ) ;gcc + (highc i386 ms-dos hc386 ) ;bind386 + (hp-ux hp-risc hp-ux cc ) ;cc + (irix mips irix gcc ) ;gcc + (linux i386 linux gcc ) ;gcc + (linux-aout i386 linux gcc ) ;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 + (os/2-cset i386 os/2 icc ) ;link386 + (os/2-emx i386 os/2 gcc ) ;gcc + (svr4-gcc-sun-ld sparc sunos gcc ) ;ld + (sunos sparc sunos cc ) ;ld + (svr4 *unknown* unix cc ) ;ld + (turbo-c 8086 ms-dos tcc ) ;tcc + (unicos cray unicos cc ) ;cc + (unix *unknown* unix cc ) ;cc + (vms vax vms cc ) ;link + (vms-gcc vax vms gcc ) ;link + (watcom-9.0 i386 ms-dos wcc386p ) ;wlinkp )) '(C-libraries @@ -224,6 +483,9 @@ (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" () ()) (c cygwin32 "" "" "" () ()) (m linux-aout "" "-lm" "/usr/lib/libm.sa" () ()) @@ -244,14 +506,16 @@ (nostart linux "" "" #f () ()) (dump linux "" "" #f ("unexelf.c" "gmalloc.c") ()) + (dump irix "" "-G 0" #f () ()) + (m acorn-unixlib "" "" #f () ()) (nostart alpha "" "-non_shared" #f ("pre-crt0.c") ()) (dump alpha "" "" #f ("unexalpha.c") ()) (m amiga-dice-c "" "-lm" #f () ()) - (m amiga-SAS/C-5.10 "" "lcmieee.lib" #f () ()) - (c amiga-SAS/C-5.10 "" "lc.lib" #f () ()) + (m amiga-sas "" "lcmieee.lib" #f () ()) + (c amiga-sas "" "lc.lib" #f () ()) (m vms-gcc "" "" #f () ()) (m vms "" "" #f () ()) @@ -264,12 +528,12 @@ (nostart sunos "" "-e __start -nostartfiles -static" #f ("ecrt0.c") ()) (dump sunos "" "" #f ("unexelf.c" "gmalloc.c") ()) - (m sun-svr4-gcc-sunld "" "-lm" #f () ()) - (dlll sun-svr4-gcc-sunld "-DSUN_DL" "-Wl,-ldl" #f () ()) - (nostart sun-svr4-gcc-sunld "" "-e __start -nostartfiles" #f ("ecrt0.c") ()) - (dump sun-svr4-gcc-sunld "" "" #f ("unexelf.c" "gmalloc.c") ()) - (socket sun-svr4-gcc-sunld "" "-lsocket -lnsl" #f () ()) - (regex sun-svr4-gcc-sunld "" "" #f () ()) + (m svr4-gcc-sun-ld "" "-lm" #f () ()) + (dlll svr4-gcc-sun-ld "-DSUN_DL" "-Wl,-ldl" #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 () ()) + (regex svr4-gcc-sun-ld "" "" #f () ()) (nostart gcc "" "-e __start -nostartfiles" #f ("ecrt0.c") ()) (dump gcc "" "" #f ("unexelf.c" "gmalloc.c") ()) @@ -298,18 +562,18 @@ (c Microsoft-Quick-C "" "" #f () ("findexec.c")) (m Microsoft-Quick-C "" "" #f () ()) - (c Turbo-C-2 "" "" #f () ("findexec.c")) - (m Turbo-C-2 "" "" #f () ()) - (graphics Turbo-C-2 "" "graphics.lib" #f () ()) + (c turbo-c "" "" #f () ("findexec.c")) + (m turbo-c "" "" #f () ()) + (graphics turbo-c "" "graphics.lib" #f () ()) - (c Borland-C-3.1 "" "" #f () ("findexec.c")) - (m Borland-C-3.1 "" "" #f () ()) - (graphics Borland-C-3.1 "" "graphics.lib" #f () ()) - (windows Borland-C-3.1 "-N -W" "-W" #f () ()) + (c borland-c "" "" #f () ("findexec.c")) + (m borland-c "" "" #f () ()) + (graphics borland-c "" "graphics.lib" #f () ()) + (windows borland-c "-N -W" "-W" #f () ()) - (c highc.31 "" "" #f () ("findexec.c")) - (m highc.31 "" "" #f () ()) - (windows highc.31 "-Hwin" "-Hwin" #f () ()) + (c highc "" "" #f () ("findexec.c")) + (m highc "" "" #f () ()) + (windows highc "-Hwin" "-Hwin" #f () ()) (m freebsd "" "-lm" #f () ()) (regex freebsd "" "-lgnuregex" "" () ()) @@ -323,1035 +587,818 @@ ((name symbol) (platform platform)) ((procedure expression)) - - ((compile-c-files Borland-C-3.1 - (lambda (files parms) - (define rsp-name "temp.rsp") - (apply batch:lines->file parms rsp-name files) - (and (batch:try-system - parms - "bcc" "-d" "-O" "-Z" "-G" "-w-pro" "-ml" "-c" - (if (member '(define "FLOATS" #t) - (c-defines parms)) - "" "-f-") - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - (string-append "@" rsp-name)) - (truncate-up-to - (replace-suffix files ".c" ".obj") - #\\)))) - (link-c-program Borland-C-3.1 - (lambda (oname objects libs parms) - (define lnk-name (string-append oname ".lnk")) - (apply batch:lines->file parms - lnk-name - (append libs objects)) - (and (batch:try-system - parms "bcc" (string-append "-e" oname) - "-ml" (string-append "@" lnk-name)) - (string-append oname ".exe")))) - - (compile-c-files Turbo-C-2 - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "tcc" "-c" "-d" "-O" "-Z" "-G" "-ml" "-c" - "-Ic:\\turboc\\include" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".obj") - #\\)))) - (link-c-program Turbo-C-2 - (lambda (oname objects libs parms) - (let ((exe (truncate-up-to - (replace-suffix (car objects) ".obj" ".exe") - #\\)) - (oexe (string-append oname ".exe"))) - (and (or (string-ci=? exe oexe) - (batch:delete-file parms oexe)) - (batch:try-system - parms "tcc" "-Lc:\\turboc\\lib" libs objects) - (or (string-ci=? exe oexe) - (batch:rename-file parms exe oexe)) - oexe)))) - - (compile-c-files Microsoft-C - (lambda (files parms) - (and (batch:chop-to-fit-system - parms "cl" "-c" "Oxp" "-AH" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".obj") - #\\)))) - (link-c-program Microsoft-C - (lambda (oname objects libs parms) - (let ((exe (truncate-up-to - (replace-suffix (car objects) ".obj" ".exe") - #\\)) - (oexe (string-append oname ".exe"))) - (and (or (string-ci=? exe oexe) - (batch:delete-file parms oexe)) - (batch:try-system - parms "link" "/noe" "/ST:40000" - (apply string-join "+" - (map (lambda (o) - (replace-suffix o ".obj" "")) - objects)) - libs) - (or (string-ci=? exe oexe) - (batch:rename-file parms exe oexe)) - oexe)))) - (compile-c-files Microsoft-C-nt - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "cl" "-c" "-nologo" "-O2" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".obj") - #\\)))) - (link-c-program Microsoft-C-nt + ((update-catalog *unknown* (lambda (oname objects libs parms) - (let ((exe (truncate-up-to - (replace-suffix (car objects) ".obj" ".exe") - #\\)) - (oexe (string-append oname ".exe"))) - (and (batch:try-system - parms "link" "/nologo" - (string-append "/out:" oexe) - (apply string-join " " - (map (lambda (o) - (replace-suffix o ".obj" "")) - objects)) - libs) - oexe)))) - - (compile-c-files Microsoft-Quick-C - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "qcl" "/AH" "/W1" "/Ze" "/O" "/Ot" "/DNDEBUG" - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".obj") - #\\)))) - (link-c-program Microsoft-Quick-C - (lambda (oname objects libs parms) - (define crf-name (string-append oname ".crf")) - (apply batch:lines->file parms - crf-name - `(,@(map (lambda (f) (string-append f " +")) - objects) - "" - ,(string-append oname ".exe") - ,(apply string-join " " libs) - ";")) - (and (batch:try-system - parms "qlink" - "/CP:0xffff" "/NOI" "/SE:0x80" "/ST:0x9c40" - crf-name) - (string-append oname ".exe")))) - - (compile-c-files Watcom-9.0 - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "wcc386p" "/mf" "/d2" "/ze" "/oxt" "/3s" - "/zq" "/w3" - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".obj") - #\\)))) - (link-c-program Watcom-9.0 - (lambda (oname objects libs parms) - (let ((exe (truncate-up-to - (replace-suffix (car objects) - ".obj" ".exe") - #\\)) - (oexe (string-append oname ".exe"))) - (and (or (string-ci=? exe oexe) - (batch:delete-file parms oexe)) - (batch:try-system - parms - "wlinkp" "option" "quiet" "option" - "stack=40000" "FILE" - (apply string-join "," - (map (lambda (o) - (replace-suffix o ".obj" "")) - objects)) - libs) - (if (not (string-ci=? exe oexe)) - (batch:rename-file parms exe oexe)) - oexe)))) - (compile-c-files highc.31 - (lambda (files parms) - (define hcc-name "temp.hcc") - (apply batch:lines->file parms hcc-name files) - (and (batch:try-system - parms - "d:\\hi_c\\hc386.31\\bin\\hc386" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - "-c" (string-append "@" hcc-name)) - (truncate-up-to - (replace-suffix files ".c" ".obj") - #\\)))) - (link-c-program highc.31 - (lambda (oname objects libs parms) - (let ((oexe (string-append oname ".exe"))) - (define lnk-name (string-append oname ".lnk")) - (apply batch:lines->file parms - lnk-name (append libs objects)) - (and (batch:try-system - parms - "d:\\hi_c\\hc386.31\\bin\\hc386" "-o" oname - "-stack 65000" - (string-append "@" lnk-name)) - (batch:try-system - parms - "bind386" "d:/hi_c/pharlap.51/run386b.exe" oname - "-exe" oexe) - oexe)))) - - (compile-c-files djgpp - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "gcc" "-Wall" "-O2" "-c" - (include-spec "-I" parms) - (c-includes parms) (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - "\\/")))) - (link-c-program djgpp - (lambda (oname objects libs parms) - (let ((exe (string-append oname ".exe"))) - (and (or (batch:try-system parms - "gcc" "-o" oname - (must-be-first - '("-nostartfiles" - "pre-crt0.o" "ecrt0.o" - "c:/djgpp/lib/crt0.o") - (append objects libs))) - (let ((arname (string-append oname ".a"))) - (batch:delete-file parms arname) - (and (batch:chop-to-fit-system - parms - "ar" "r" arname objects) - (batch:try-system - parms "gcc" "-o" oname - (must-be-first - '("-nostartfiles" - "pre-crt0.o" "ecrt0.o" - "c:/djgpp/lib/crt0.o") - (cons arname libs))) - (batch:delete-file parms arname))) - ;;(build:error 'build "couldn't build archive") - ) - (batch:try-system parms "strip" exe) - (batch:delete-file parms oname) - ;;(batch:delete-file parms exe) - ;;(batch:try-system parms "coff2exe" "-s" "c:\\djgpp\\bin\\go32.exe" oname) - exe)))) - - (compile-c-files os/2-emx - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "gcc" "-O" "-m386" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - #\\)))) - (link-c-program os/2-emx - (lambda (oname objects libs parms) - (and (batch:try-system - parms "gcc" "-o" (string-append oname ".exe") - objects libs) - (string-append oname ".exe")))) - - (compile-c-files os/2-cset - (lambda (files parms) - (and (batch:chop-to-fit-system - parms "icc.exe" "/Gd-" "/Ge+" "/Gm+" "/Q" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".obj") - #\\)))) - (link-c-program os/2-cset - (lambda (oname objects libs parms) - (and (batch:try-system - parms "link386.exe" objects libs - (string-append "," oname ".exe,,,;")) - (string-append oname ".exe")))) - - (compile-c-files HP-UX - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "cc" "+O1" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (compile-dll-c-files HP-UX - (lambda (files parms) - (and (batch:chop-to-fit-system - parms "cc" "+O1" "-Wl,-E" "+z" "-c" - (c-includes parms) - (c-flags parms) - files) - (let ((results - (map - (lambda (fname) - (batch:rename-file - parms - (string-append fname ".sl") - (string-append fname ".sl~")) - (and (batch:try-system - parms "ld" "-b" "-o" - (string-append fname ".sl") - (string-append fname ".o")) - (string-append fname ".sl"))) - (truncate-up-to - (replace-suffix files ".c" "") - #\/)))) - (and (apply and? results) results))))) + (batch:rebuild-catalog parms) + (if (= 1 (length objects)) (car objects) + objects)))))) + +(define define-compile-commands + (let ((defcomms (((build 'open-table) 'compile-commands #t) 'row:insert))) + (lambda args + (defcomms args)))) ;(append args (list (comment))) +(defmacro defcommand (name platform procedure) + `(define-compile-commands ',name ',platform ',procedure)) + +(defcommand compile-c-files borland-c + (lambda (files parms) + (define rsp-name "temp.rsp") + (apply batch:lines->file parms rsp-name files) + (and (batch:try-command + parms + "bcc" "-d" "-O" "-Z" "-G" "-w-pro" "-ml" "-c" + (if (member '(define "FLOATS" #t) + (c-defines parms)) + "" "-f-") + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + (string-append "@" rsp-name)) + (truncate-up-to (map c->obj files) #\\)))) +(defcommand link-c-program borland-c + (lambda (oname objects libs parms) + (define lnk-name (string-append oname ".lnk")) + (apply batch:lines->file parms + lnk-name + (append libs objects)) + (and (batch:try-command + parms "bcc" (string-append "-e" oname) + "-ml" (string-append "@" lnk-name)) + (string-append oname ".exe")))) + +(defcommand compile-c-files turbo-c + (lambda (files parms) + (and (batch:try-chopped-command + parms + "tcc" "-c" "-d" "-O" "-Z" "-G" "-ml" "-c" + "-Ic:\\turboc\\include" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->obj files) #\\)))) +(defcommand link-c-program turbo-c + (lambda (oname objects libs parms) + (let ((exe (truncate-up-to (obj->exe (car objects)) #\\)) + (oexe (string-append oname ".exe"))) + (and (or (string-ci=? exe oexe) + (batch:delete-file parms oexe)) + (batch:try-command + parms "tcc" "-Lc:\\turboc\\lib" libs objects) + (or (string-ci=? exe oexe) + (batch:rename-file parms exe oexe)) + oexe)))) + +(defcommand compile-c-files Microsoft-C + (lambda (files parms) + (and (batch:try-chopped-command + parms "cl" "-c" "Oxp" "-AH" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->obj files) #\\)))) +(defcommand link-c-program Microsoft-C + (lambda (oname objects libs parms) + (let ((exe (truncate-up-to (obj->exe (car objects)) #\\)) + (oexe (string-append oname ".exe"))) + (and (or (string-ci=? exe oexe) + (batch:delete-file parms oexe)) + (batch:try-command + parms "link" "/noe" "/ST:40000" + (apply string-join "+" (map obj-> objects)) + libs) + (or (string-ci=? exe oexe) + (batch:rename-file parms exe oexe)) + 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) + (truncate-up-to (map c->obj files) #\\)))) +(defcommand link-c-program Microsoft-C-nt + (lambda (oname objects libs parms) + (let ((exe (truncate-up-to (obj->exe (car objects)) #\\)) + (oexe (string-append oname ".exe"))) + (and (batch:try-command + parms "link" "/nologo" + (string-append "/out:" oexe) + (apply string-join " " (map obj-> objects)) + libs) + oexe)))) + +(defcommand compile-c-files Microsoft-Quick-C + (lambda (files parms) + (and (batch:try-chopped-command + parms + "qcl" "/AH" "/W1" "/Ze" "/O" "/Ot" "/DNDEBUG" + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->obj files) #\\)))) +(defcommand link-c-program Microsoft-Quick-C + (lambda (oname objects libs parms) + (define crf-name (string-append oname ".crf")) + (apply batch:lines->file parms + crf-name + `(,@(map (lambda (f) (string-append f " +")) + objects) + "" + ,(string-append oname ".exe") + ,(apply string-join " " libs) + ";")) + (and (batch:try-command + parms "qlink" + "/CP:0xffff" "/NOI" "/SE:0x80" "/ST:0x9c40" + crf-name) + (string-append oname ".exe")))) + +(defcommand compile-c-files Watcom-9.0 + (lambda (files parms) + (and (batch:try-chopped-command + parms + "wcc386p" "/mf" "/d2" "/ze" "/oxt" "/3s" + "/zq" "/w3" + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->obj files) #\\)))) +(defcommand link-c-program Watcom-9.0 + (lambda (oname objects libs parms) + (let ((exe (truncate-up-to (obj->exe (car objects)) #\\)) + (oexe (string-append oname ".exe"))) + (and (or (string-ci=? exe oexe) + (batch:delete-file parms oexe)) + (batch:try-command + parms + "wlinkp" "option" "quiet" "option" + "stack=40000" "FILE" + (apply string-join "," (map obj-> objects)) + libs) + (if (not (string-ci=? exe oexe)) + (batch:rename-file parms exe oexe)) + oexe)))) +(defcommand compile-c-files highc + (lambda (files parms) + (define hcc-name "temp.hcc") + (apply batch:lines->file parms hcc-name files) + (and (batch:try-command + parms + "d:\\hi_c\\hc386.31\\bin\\hc386" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + "-c" (string-append "@" hcc-name)) + (truncate-up-to (map c->obj files) #\\)))) +(defcommand link-c-program highc + (lambda (oname objects libs parms) + (let ((oexe (string-append oname ".exe"))) + (define lnk-name (string-append oname ".lnk")) + (apply batch:lines->file parms + lnk-name (append libs objects)) + (and (batch:try-command + parms + "d:\\hi_c\\hc386.31\\bin\\hc386" "-o" oname + "-stack 65000" + (string-append "@" lnk-name)) + (batch:try-command + parms + "bind386" "d:/hi_c/pharlap.51/run386b.exe" oname + "-exe" oexe) + oexe)))) + +(defcommand compile-c-files djgpp + (lambda (files parms) + (and (batch:try-chopped-command + parms + "gcc" "-Wall" "-O2" "-c" + (include-spec "-I" parms) + (c-includes parms) (c-flags parms) + files) + (truncate-up-to (map c->o files) "\\/")))) +(defcommand link-c-program djgpp + (lambda (oname objects libs parms) + (let ((exe (string-append oname ".exe"))) + (and (or (batch:try-command parms + "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "c:/djgpp/lib/crt0.o") + (append objects libs))) + (let ((arname (string-append oname ".a"))) + (batch:delete-file parms arname) + (and (batch:try-chopped-command + parms + "ar" "r" arname objects) + (batch:try-command + parms "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "c:/djgpp/lib/crt0.o") + (cons arname libs))) + (batch:delete-file parms arname))) + ;;(build:error 'build "couldn't build archive") + ) + (batch:try-command parms "strip" exe) + (batch:delete-file parms oname) + ;;(batch:delete-file parms exe) + ;;(batch:try-command parms "coff2exe" "-s" "c:\\djgpp\\bin\\go32.exe" oname) + exe)))) + +(defcommand compile-c-files os/2-emx + (lambda (files parms) + (and (batch:try-chopped-command parms + "gcc" "-O" "-m386" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\\)))) +(defcommand link-c-program os/2-emx + (lambda (oname objects libs parms) + (and (batch:try-command + parms "gcc" "-o" (string-append oname ".exe") + objects libs) + (string-append oname ".exe")))) + +(defcommand compile-c-files os/2-cset + (lambda (files parms) + (and (batch:try-chopped-command + parms "icc" "/Gd-" "/Ge+" "/Gm+" "/Q" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->obj files) #\\)))) +(defcommand link-c-program os/2-cset + (lambda (oname objects libs parms) + (and (batch:try-command + parms "link386" objects libs + (string-append "," oname ".exe,,,;")) + (string-append oname ".exe")))) + +(defcommand compile-c-files HP-UX + (lambda (files parms) + (and (batch:try-chopped-command parms + "cc" "+O1" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand compile-dll-c-files HP-UX + (lambda (files parms) + (and (batch:try-chopped-command + parms "cc" "+O1" "-Wl,-E" "+z" "-c" + (c-includes parms) + (c-flags parms) + files) + (let ((results + (map + (lambda (fname) + (batch:rename-file + parms + (string-append fname ".sl") + (string-append fname ".sl~")) + (and (batch:try-command + parms "ld" "-b" "-o" + (string-append fname ".sl") + (string-append fname ".o")) + (string-append fname ".sl"))) + (truncate-up-to (map c-> files) #\/)))) + (and (apply and? results) results))))) ; (make-dll-archive HP-UX ; (lambda (oname objects libs parms) -; (and (batch:try-system +; (and (batch:try-command ; parms "ld" "-b" "-o" (string-append oname ".sl") ; objects) ; (batch:rebuild-catalog parms) ; (string-append oname ".sl")))) - (make-dll-archive sunos - (lambda (oname objects libs parms) - (and (batch:try-system - 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")))) - - (compile-c-files linux-aout - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "gcc" "-Wall" "-O2" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (compile-dll-c-files linux-aout - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "gcc" "-Wall" "-O2" "-c" - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - #\/)))) +(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) + (and (batch:try-chopped-command parms + "gcc" "-Wall" "-O2" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand compile-dll-c-files linux-aout + (lambda (files parms) + (and (batch:try-chopped-command + parms + "gcc" "-Wall" "-O2" "-c" + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) ;;; (make-dll-archive linux-aout ;;; (lambda (oname objects libs parms) #t ;;; (batch:rebuild-catalog parms) ;;; oname)) - (compile-c-files linux - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "gcc" - (if (member "-g" (c-includes parms)) "" "-O2") - "-c" (c-includes parms) - (include-spec "-I" parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (compile-dll-c-files linux - (lambda (files parms) - (and - (batch:chop-to-fit-system - 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-system - parms - "gcc" "-shared" "-o" - (string-append fname ".so") - (string-append fname ".o") - ld-opts) - (string-append fname ".so"))) - (truncate-up-to - (replace-suffix files ".c" "") - #\/)))) - (and (apply and? results) results))))) - (make-dll-archive linux - (lambda (oname objects libs parms) - (let ((platform (car (parameter-list-ref - parms 'platform)))) - (and (batch:try-system - parms - "gcc" "-shared" "-o" - (string-append - (car (parameter-list-ref parms 'implvic)) - oname ".so") - objects - (map (lambda (l) - (build:lib-ld-flag l platform)) - (parameter-list-ref parms 'c-lib))) - (batch:rebuild-catalog parms) - (string-append - (car (parameter-list-ref parms 'implvic)) - oname ".so"))))) - (link-c-program linux - (lambda (oname objects libs parms) - (and (batch:try-system - parms "gcc" "-rdynamic" "-o" oname - (must-be-first - '("pre-crt0.o" "ecrt0.o" "/usr/lib/crt0.o") - (append objects libs))) - oname))) - - (compile-c-files Unicos - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "cc" "-hvector2" "-hscalar2" "-c" - (include-spec "-i" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program unicos - (lambda (oname objects libs parms) - (and (batch:try-system - parms "cc" "setjump.o" "-o" oname objects libs) - oname))) - - (compile-c-files gcc - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "gcc" "-Wall" "-O2" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program gcc - (lambda (oname objects libs parms) - (batch:rename-file parms - oname (string-append oname "~")) - (and (batch:try-system parms - "gcc" "-o" oname - (must-be-first - '("-nostartfiles" - "pre-crt0.o" "ecrt0.o" - "/usr/lib/crt0.o") - (append objects libs))) - oname))) - - (compile-c-files cygwin32 - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "gcc" "-Wall" "-O2" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program cygwin32 - (lambda (oname objects libs parms) - (batch:rename-file parms - (string-append oname ".exe") - (string-append oname "~")) - (and (batch:try-system parms - "gcc" "-o" oname - (must-be-first - '("-nostartfiles" - "pre-crt0.o" "ecrt0.o" - "/usr/lib/crt0.o") - (append objects libs))) - oname))) - - (compile-c-files sun-svr4-gcc-sunld - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "gcc" "-Wall" "-O2" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program sun-svr4-gcc-sunld - (lambda (oname objects libs parms) - (batch:rename-file parms - oname (string-append oname "~")) - (and (batch:try-system parms - "gcc" "-o" oname - (must-be-first - '("-nostartfiles" - "pre-crt0.o" "ecrt0.o" - "/usr/lib/crt0.o") - (append objects libs))) - oname))) - - (compile-c-files svr4 - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "cc" "-O" "-DSVR4" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - - (compile-c-files aix - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "cc" "-O" "-Dunix" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program aix - (lambda (oname objects libs parms) - (and (batch:try-system - parms "cc" "-lansi" "-o" oname objects libs) - oname))) - - (compile-c-files amiga-aztec - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "cc" "-dAMIGA" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program amiga-aztec - (lambda (oname objects libs parms) - (and (batch:try-system - parms "cc" "-o" oname objects libs "-lma") - oname))) - - (compile-c-files amiga-SAS/C-5.10 - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "lc" "-d3" "-M" "-fi" "-O" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (batch:try-system - parms "blink with link.amiga NODEBUG") - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program amiga-SAS/C-5.10 - (lambda (oname objects libs parms) - (define lnk-name "link.amiga") - (apply batch:lines->file parms - lnk-name - (apply string-join "+" ">FROM LIB:c.o" - (map object->string objects)) - (string-append - "TO " (object->string (string-append "/" oname))) - (append - (cond - ((pair? libs) - (cons (string-append "LIB LIB:" (car libs)) - (map (lambda (s) - (string-append " LIB:" s)) - (cdr libs)))) - (else '())) - '("VERBOSE" "SC" "SD"))) - oname)) - - (compile-c-files amiga-dice-c - (lambda (files parms) - (and (batch:try-system - parms - "dcc" "-r" "-gs" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files "-o" (truncate-up-to - (replace-suffix files ".c" ".o") - #\/)) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program amiga-dice-c - (lambda (oname objects libs parms) - (and (batch:try-system - parms "dcc" "-r" "-gs" "-o" oname objects libs) - oname))) - - (compile-c-files atari-st-gcc - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "gcc" "-v" "-O" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program atari-st-gcc - (lambda (oname objects libs parms) - (and (batch:try-system - parms "gcc" "-v" "-o" (string-append oname ".ttp") - objects libs) - (string-append oname ".ttp")))) - - (compile-c-files atari-st-turbo-c - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "tcc" "-P" "-W-" "-Datarist" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program atari-st-turbo-c - (lambda (oname objects libs parms) - (and (batch:try-system - parms "tlink" "-o" (string-append oname ".ttp") - objects libs "mintlib.lib" "osbind.lib" - "pcstdlib.lib" "pcfltlib.lib") - (string-append oname ".ttp")))) - - (compile-c-files acorn-unixlib - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "cc" "-c" "-depend" "!Depend" "-IUnixLib:" - "-pcc" "-Dunix" "-DSVR3" "-DARM_ULIB" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - #\/)))) - (link-c-program acorn-unixlib - (lambda (oname objects libs parms) - (and (batch:try-system - parms "link" "-o" oname objects libs - ":5.$.dev.gcc.unixlib36d.clib.o.unixlib") - (batch:try-system parms "squeeze" oname) - oname))) - - (compile-c-files vms - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "cc" - (c-includes parms) - (c-flags parms) - (replace-suffix files ".c" "")) - (truncate-up-to - (replace-suffix files ".c" ".obj") - "/]")))) - (link-c-program vms - (lambda (oname objects libs parms) - (let ((exe (truncate-up-to - (replace-suffix (car objects) - ".obj" ".exe") - "/]")) - (oexe (string-append oname ".exe"))) - (and (batch:try-system parms "macro" "setjump") - (batch:try-system - parms - "link" - (apply string-join "," - (append (map (lambda (f) - (replace-suffix f ".obj" "")) - objects) - '("setjump" "sys$input/opt\n "))) - (apply string-join - "," (append (remove "" libs) - '("sys$share:vaxcrtl/share")))) - (or (string-ci=? exe oexe) - (batch:rename-file parms exe oexe)) - oexe)))) - - (compile-c-files vms-gcc - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "gcc" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - (replace-suffix files ".c" "")) - (truncate-up-to - (replace-suffix files ".c" ".obj") - "/]")))) - (link-c-program vms-gcc - (lambda (oname objects libs parms) - (let ((exe (truncate-up-to - (replace-suffix (car objects) ".obj" ".exe") - "/]")) - (oexe (string-append oname ".exe"))) - (and (batch:try-system parms "macro" "setjump") - (batch:try-system - parms - "link" - (apply string-join "," - (append objects - '("setjump.obj" - "sys$input/opt\n "))) - (apply string-join - "," (append (remove "" libs) - '("gnu_cc:[000000]gcclib/lib" - "sys$share:vaxcrtl/share")))) - (or (string-ci=? exe oexe) - (batch:rename-file parms exe oexe)) - oexe)))) - - (compile-c-files *unknown* - (lambda (files parms) - (batch:chop-to-fit-system - parms - "cc" "-O" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - "\\/]"))) - (link-c-program *unknown* - (lambda (oname objects libs parms) - (batch:rename-file parms - oname (string-append oname "~")) - (and (batch:try-system parms - "cc" "-o" oname - (must-be-first - '("-nostartfiles" - "pre-crt0.o" "ecrt0.o" - "/usr/lib/crt0.o") - (append objects libs))) - oname))) - (make-archive *unknown* - (lambda (oname objects libs parms) - (let ((aname (string-append oname ".a"))) - (and (batch:try-system parms "ar rc" aname objects) - (batch:try-system parms "ranlib" aname) - aname)))) - (compile-dll-c-files *unknown* - (lambda (files parms) - (and (batch:chop-to-fit-system parms - "cc" "-O" "-c" - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to - (replace-suffix files ".c" ".o") - "\\/]")))) - (make-dll-archive *unknown* - (lambda (oname objects libs parms) - (let ((aname - (string-append - (car (parameter-list-ref parms 'implvic)) - oname ".a"))) - (and (batch:try-system parms "ar rc" aname objects) - (batch:try-system parms "ranlib" aname) - (batch:rebuild-catalog parms) - aname)))) - (update-catalog *unknown* - (lambda (oname objects libs parms) - (batch:rebuild-catalog parms) - (if (= 1 (length objects)) (car objects) - objects))) - - (compile-c-files freebsd - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "cc" "-O" "-Dfreebsd" "-c" - (c-includes parms) - (c-flags parms) - files) - (replace-suffix files ".c" ".o")))) - (link-c-program freebsd - (lambda (oname objects libs parms) - (batch:rename-file parms - oname (string-append oname "~")) - (and (batch:try-system parms - "cc" "-o" oname - (must-be-first - '("-nostartfiles" - "pre-crt0.o" "crt0.o" - "/usr/lib/crt0.o") - (append objects libs))) - oname))) - (compile-dll-c-files freebsd - (lambda (files parms) - (and (batch:chop-to-fit-system - parms - "cc" "-O" "-fpic" "-c" - "-Dfreebsd" - (string-append - "-I" (parameter-list-ref parms 'scm-srcdir)) - (c-includes parms) - (c-flags parms) - files) - (let ((objs (replace-suffix files ".c" ".o"))) - (every - (lambda (f) - (and (batch:try-system - parms "ld" "-Bshareable" f) - (batch:try-system - parms "mv" "a.out" f))) - objs) - objs)))) - - (make-dll-archive freebsd - (lambda (oname objects libs parms) - (and (batch:try-system - parms - "ld" "-Bshareable" "-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")))) - - )) - - '(features - ((name symbol)) - ((spec expression) - (documentation string)) - ((lit () "Light - no features") - (none () "No features") - - (cautious ((define "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 CAUTIOUS.") - - (careful-interrupt-masking ((define "CAREFUL_INTS")) - "\ -Define CAREFUL_INTS for extra checking of interrupt masking. This is -for debugging C code in sys.c and repl.c.") - - (debug ((c-lib debug) - (features cautious careful-interrupt-masking stack-limit)) - "Debugging") - - (reckless ((define "RECKLESS")) - "\ -If your scheme code runs without any errors you can disable almost all -error checking by compiling all files with RECKLESS.") - - (stack-limit ((define ("STACK_LIMIT" "(HEAP_SEG_SIZE/2)"))) - "\ -Define STACK_LIMIT to enable checking for stack overflow. Define -value of 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.") - - (macro ((define "MACRO") (features rev2-procedures record)) - "\ -R4RS-macros") - - (bignums ((define "BIGNUMS")) - "\ -Large precision integers.") - - (arrays ((define "ARRAYS")) - "\ -Define ARRAYS if you want arrays, uniform-arrays and uniform-vectors.") - - (array-for-each ((c-file "ramap.c") (init "init_ramap")) - "\ -array-map! and array-for-each (ARRAYS must also be defined).") - - (inexact ((define "FLOATS") (c-lib m)) - "\ -Define FLOATS if you want floating point numbers.") - - (engineering-notation ((define "ENGNOT")) - "\ -Define ENGNOT if you want floats to display in engineering notation - (exponents always multiples of 3) instead of scientific notation.") - - (single-precision-only ((define "SINGLESONLY")) - "\ -Define SINGLESONLY 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.") - - (sicp ((define "SICP")) - "\ -Define SICP if you want to run code from: - - H. Abelson, G. J. Sussman, and J. Sussman, - Structure and Interpretation of Computer Programs, - The MIT Press, Cambridge, Massachusetts, USA - - (eq? '() '#f) is the major difference.") - - (rev2-procedures ((c-file "sc2.c") (init "init_sc2")) - "\ -These procedures were specified in the `Revised^2 Report on Scheme' -but not in `R4RS'.") - - (record ((define "CCLO") (c-file "record.c") (init "init_record")) - "\ -The Record package provides a facility for user to define their own -record data types. See SLIB for documentation.") - - (compiled-closure ((define "CCLO")) - "\ -Define CCLO if you want to use compiled closures.") - - (generalized-c-arguments ((c-file "gsubr.c") (init "init_gsubr")) - "\ -make_gsubr for arbitrary (< 11) arguments to C functions.") - - (tick-interrupts ((define "TICKS")) - "\ -Define TICKS if you want the ticks and ticks-interrupt functions.") - - (i/o-extensions ((c-file "ioext.c") (init "init_ioext")) - "\ -Commonly available I/O extensions: `Exec', line I/O, file positioning, -file delete and rename, and directory functions.") - - (turtlegr - ((c-file "turtlegr.c") (c-lib graphics) (features inexact) - (init "init_turtlegr")) - "\ -`Turtle' graphics calls for both Borland-C and X11.") - - (curses ((c-file "crs.c") (c-lib curses) (init "init_crs")) - "\ -`Curses' screen management package.") - - (edit-line - ((c-file "edline.c") (c-lib termcap editline) (compiled-init "init_edline")) - "\ -interface to the editline or GNU readline library") - - (regex ((c-file "rgx.c") (c-lib regex) (init "init_rgx")) - "\ -String regular expression matching.") - - (socket ((c-lib socket) (c-file "socket.c") (init "init_socket")) - "\ -BSD socket interface.") - - (posix ((c-file "posix.c") (init "init_posix")) - "\ -Posix functions available on all `Unix-like' systems. fork and -process functions, user and group IDs, file permissions, and `link'.") - - (unix ((c-file "unix.c") (init "init_unix")) - "\ -Those unix features which have not made it into the Posix specs: nice, -acct, lstat, readlink, symlink, mknod and sync.") - - (windows ((c-lib windows)) ; (define "NON_PREEMPTIVE") - "\ -Microsoft Windows executable.") - - (dynamic-linking ((c-file "dynl.c") (c-lib dlll)) - "\ -Load compiled files while running.") - - (dump ((define "CAN_DUMP") (c-lib dump) (c-lib nostart)) - "\ -Convert a running scheme program into an executable file.") - -;;;; Descriptions of these parameters is in "setjump.h". -;;; (initial-heap-size ((define "INIT_HEAP_SIZE" (* 25000 sizeof-cell)))) -;;; (heap-segment-size ((define "HEAP_SEG_SIZE" (* 8100 sizeof-cell)))) -;;; (short-aligned-stack ((define "SHORT_ALIGN"))) -;;; (initial-malloc-limit ((define "INIT_MALLOC_LIMIT" 100000))) -;;; (number-of-hash-buckets ((define "NUM_HASH_BUCKETS" 137))) -;;; (minimum-gc-yield ((define "MIN_GC_YIELD" "(heap_cells/4)"))) - - (heap-can-shrink ((define "DONT_GC_FREE_SEGMENTS")) - "\ -Define DONT_GC_FREE_SEGMENTS if you want segments of unused heap to -not be freed up after garbage collection. This may reduce time in GC -for *very* large working sets.") - - (cheap-continuations ((define "CHEAP_CONTINUATIONS")) - "\ -If you only need straight stack continuations CHEAP_CONTINUATIONS 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 define -CHEAP_CONTINUATIONS.") - ))) +(defcommand compile-c-files linux + (lambda (files parms) + (and (batch:try-chopped-command + parms + "gcc" "-O2" + ;;(if (member "-g" (c-includes parms)) "" "-O2") + "-c" (c-includes parms) + (include-spec "-I" parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand compile-dll-c-files linux + (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 + "gcc" "-shared" "-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 make-dll-archive linux + (lambda (oname objects libs parms) + (let ((platform (car (parameter-list-ref + parms 'platform)))) + (and (batch:try-command + parms + "gcc" "-shared" "-o" + (string-append + (car (parameter-list-ref parms 'implvic)) + oname ".so") + objects + (map (lambda (l) + (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib))) + (batch:rebuild-catalog parms) + (string-append + (car (parameter-list-ref parms 'implvic)) + oname ".so"))))) +(defcommand link-c-program linux + (lambda (oname objects libs parms) + (and (batch:try-command + parms "gcc" "-rdynamic" "-o" oname + (must-be-first + '("pre-crt0.o" "ecrt0.o" "/usr/lib/crt0.o") + (append objects libs))) + oname))) + +(defcommand compile-c-files Unicos + (lambda (files parms) + (and (batch:try-chopped-command + parms + "cc" "-hvector2" "-hscalar2" "-c" + (include-spec "-i" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program unicos + (lambda (oname objects libs parms) + (and (batch:try-command + parms "cc" "setjump.o" "-o" oname objects libs) + oname))) + +(defcommand compile-c-files gcc + (lambda (files parms) + (and (batch:try-chopped-command parms + "gcc" "-O2" "-c" ; "-Wall" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program gcc + (lambda (oname objects libs parms) + (batch:rename-file parms + oname (string-append oname "~")) + (and (batch:try-command parms + "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "/usr/lib/crt0.o") + (append objects libs))) + oname))) +(defcommand compile-dll-c-files gcc + (lambda (files parms) + (and (batch:try-chopped-command parms + "gcc" "-O" "-c" + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) "\\/]")))) + +(defcommand compile-c-files cygwin32 + (lambda (files parms) + (and (batch:try-chopped-command parms + "gcc" "-Wall" "-O2" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program cygwin32 + (lambda (oname objects libs parms) + (batch:rename-file parms + (string-append oname ".exe") + (string-append oname "~")) + (and (batch:try-command parms + "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "/usr/lib/crt0.o") + (append objects libs))) + oname))) + +(defcommand compile-c-files svr4-gcc-sun-ld + (lambda (files parms) + (and (batch:try-chopped-command parms + "gcc" "-O2" "-c" ; "-Wall" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program svr4-gcc-sun-ld + (lambda (oname objects libs parms) + (batch:rename-file parms + oname (string-append oname "~")) + (and (batch:try-command parms + "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "/usr/lib/crt0.o") + (append objects libs))) + oname))) + +(defcommand compile-c-files svr4 + (lambda (files parms) + (and (batch:try-chopped-command parms + "cc" "-O" "-DSVR4" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) + +(defcommand compile-c-files aix + (lambda (files parms) + (and (batch:try-chopped-command parms + "cc" "-O" "-Dunix" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program aix + (lambda (oname objects libs parms) + (and (batch:try-command + parms "cc" "-lansi" "-o" oname objects libs) + oname))) + +(defcommand compile-c-files amiga-aztec + (lambda (files parms) + (and (batch:try-chopped-command parms + "cc" "-dAMIGA" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program amiga-aztec + (lambda (oname objects libs parms) + (and (batch:try-command + parms "cc" "-o" oname objects libs "-lma") + oname))) + +(defcommand compile-c-files amiga-sas + (lambda (files parms) + (and (batch:try-chopped-command + parms + "lc" "-d3" "-M" "-fi" "-O" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (batch:try-command + parms "blink with link.amiga NODEBUG") + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program amiga-sas + (lambda (oname objects libs parms) + (define lnk-name "link.amiga") + (apply batch:lines->file parms + lnk-name + (apply string-join "+" ">FROM LIB:c.o" + (map object->string objects)) + (string-append + "TO " (object->string (string-append "/" oname))) + (append + (cond + ((pair? libs) + (cons (string-append "LIB LIB:" (car libs)) + (map (lambda (s) + (string-append " LIB:" s)) + (cdr libs)))) + (else '())) + '("VERBOSE" "SC" "SD"))) + oname)) + +(defcommand compile-c-files amiga-dice-c + (lambda (files parms) + (and (batch:try-command + parms + "dcc" "-r" "-gs" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files "-o" (truncate-up-to (map c->o files) #\/)) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program amiga-dice-c + (lambda (oname objects libs parms) + (and (batch:try-command + parms "dcc" "-r" "-gs" "-o" oname objects libs) + oname))) + +(defcommand compile-c-files amiga-gcc + (lambda (files parms) + (and (batch:try-chopped-command parms + "gcc" "-Wall" "-O2" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program amiga-gcc + (lambda (oname objects libs parms) + (batch:rename-file parms + oname (string-append oname "~")) + (and (batch:try-command parms + "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "/usr/lib/crt0.o") + (append objects libs))) + oname))) + +(defcommand compile-c-files atari-st-gcc + (lambda (files parms) + (and (batch:try-chopped-command parms + "gcc" "-v" "-O" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program atari-st-gcc + (lambda (oname objects libs parms) + (and (batch:try-command + parms "gcc" "-v" "-o" (string-append oname ".ttp") + objects libs) + (string-append oname ".ttp")))) + +(defcommand compile-c-files atari-st-turbo-c + (lambda (files parms) + (and (batch:try-chopped-command + parms + "tcc" "-P" "-W-" "-Datarist" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program atari-st-turbo-c + (lambda (oname objects libs parms) + (and (batch:try-command + parms "tlink" "-o" (string-append oname ".ttp") + objects libs "mintlib.lib" "osbind.lib" + "pcstdlib.lib" "pcfltlib.lib") + (string-append oname ".ttp")))) + +(defcommand compile-c-files acorn-unixlib + (lambda (files parms) + (and (batch:try-chopped-command + parms + "cc" "-c" "-depend" "!Depend" "-IUnixLib:" + "-pcc" "-Dunix" "-DSVR3" "-DARM_ULIB" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) #\/)))) +(defcommand link-c-program acorn-unixlib + (lambda (oname objects libs parms) + (and (batch:try-command + parms "link" "-o" oname objects libs + ":5.$.dev.gcc.unixlib36d.clib.o.unixlib") + (batch:try-command parms "squeeze" oname) + oname))) + +(defcommand compile-c-files vms + (lambda (files parms) + (and (batch:try-chopped-command + parms + "cc" + (c-includes parms) + (c-flags parms) + (map c-> files)) + (truncate-up-to (map c->obj files) "/]")))) +(defcommand link-c-program vms + (lambda (oname objects libs parms) + (let ((exe (truncate-up-to (obj->exe (car objects)) "/]")) + (oexe (string-append oname ".exe"))) + (and (batch:try-command parms "macro" "setjump") + (batch:try-command + parms + "link" + (apply string-join "," + (append (map obj-> objects) + '("setjump" "sys$input/opt\n "))) + (apply string-join + "," (append (remove "" libs) + '("sys$share:vaxcrtl/share")))) + (or (string-ci=? exe oexe) + (batch:rename-file parms exe oexe)) + oexe)))) + +(defcommand compile-c-files vms-gcc + (lambda (files parms) + (and (batch:try-chopped-command + parms + "gcc" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + (map c-> files)) + (truncate-up-to (map c->obj files) "/]")))) +(defcommand link-c-program vms-gcc + (lambda (oname objects libs parms) + (let ((exe (truncate-up-to (obj->exe (car objects)) "/]")) + (oexe (string-append oname ".exe"))) + (and (batch:try-command parms "macro" "setjump") + (batch:try-command + parms + "link" + (apply string-join "," + (append objects + '("setjump.obj" + "sys$input/opt\n "))) + (apply string-join + "," (append (remove "" libs) + '("gnu_cc:[000000]gcclib/lib" + "sys$share:vaxcrtl/share")))) + (or (string-ci=? exe oexe) + (batch:rename-file parms exe oexe)) + oexe)))) + +(defcommand compile-c-files *unknown* + (lambda (files parms) + (batch:try-chopped-command + parms + "cc" "-O" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) "\\/]"))) +(defcommand link-c-program *unknown* + (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" "ecrt0.o" + "/usr/lib/crt0.o") + (append objects libs))) + oname))) +(defcommand make-archive *unknown* + (lambda (oname objects libs parms) + (let ((aname (string-append "lib" oname ".a"))) + (and (batch:try-command parms "ar rc" aname objects) + (batch:try-command parms "ranlib" aname) + aname)))) +(defcommand compile-dll-c-files *unknown* + (lambda (files parms) + (and (batch:try-chopped-command parms + "cc" "-O" "-c" + (c-includes parms) + (c-flags parms) + files) + (truncate-up-to (map c->o files) "\\/]")))) +(defcommand make-dll-archive *unknown* + (lambda (oname objects libs parms) + (let ((aname + (string-append + (car (parameter-list-ref parms 'implvic)) + oname ".a"))) + (and (batch:try-command parms "ar rc" aname objects) + (batch:try-command parms "ranlib" aname) + (batch:rebuild-catalog parms) + aname)))) + +(defcommand compile-c-files freebsd + (lambda (files parms) + (and (batch:try-chopped-command + parms + "cc" "-O" "-c" + (c-includes parms) + (c-flags parms) + files) + (map c->o files)))) +(defcommand link-c-program freebsd + (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 objects libs))) + oname))) +(defcommand compile-dll-c-files freebsd + (lambda (files parms) + (and (batch:try-chopped-command + parms + "cc" "-O" "-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 "ld" "-Bshareable" f) + (batch:try-command + parms "mv" "a.out" f))) + objs) + objs)))) + +(defcommand make-dll-archive freebsd + (lambda (oname objects libs parms) + (and (batch:try-command + parms + "ld" "-Bshareable" "-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) - '((features features #f symbol #f) - (C-libraries C-libraries #f symbol #f))) + '((C-libraries C-libraries #f symbol #f))) (define-tables build @@ -1501,14 +1548,18 @@ CHEAP_CONTINUATIONS.") (string-append c "();")) (parameter-list-ref parms 'compiled-init)))) (implvic (let ((impl (car (parameter-list-ref parms 'implvic)))) - (if (equal? "" impl) - (car (parameter-list-ref parms 'scm-srcdir)) - impl))) + (if (equal? "" impl) + (car (parameter-list-ref parms 'scm-srcdir)) + impl))) (c-defines `((define "IMPLINIT" ,(object->string (string-append - implvic "Init" (read-version parms) ".scm"))) + implvic "Init" + (read-version + (in-vicinity (car (parameter-list-ref parms 'scm-srcdir)) + "patchlvl.h")) + ".scm"))) ;;,@`(if (equal? "" implvic) '() (...)) ,@(if (string=? "" init=) '() `((define "INITS" ,init=))) @@ -1547,45 +1598,55 @@ CHEAP_CONTINUATIONS.") parms name (lambda (batch-port) - (define o-files '()) + (define o-files #f) (adjoin-parameters! parms (list 'batch-port batch-port)) - ;; ================ Write file with C defines - (apply batch:lines->file parms - "scmflags.h" - (defines->c-defines c-defines)) - - ;; ================ Compile C source files - (set! o-files - (let ((suppressors - (apply append - (map (lambda (l) (build:c-suppress l platform)) - (parameter-list-ref parms 'c-lib)))) - (ssdir (car (parameter-list-ref parms 'scm-srcdir)))) - (c-proc - (map (lambda (file) (in-vicinity ssdir file)) - (apply - append - (remove-if (lambda (file) (member file suppressors)) - (parameter-list-ref parms 'c-file)) - (map - (lambda (l) (build:c-lib-support l platform)) - (parameter-list-ref parms 'c-lib)))) - parms))) - - ;; ================ Link C object files - ((plan-command - ((((rdb 'open-table) 'build-whats #f) 'get 'o-proc) what) - platform) - (car (parameter-list-ref parms 'target-name)) - (append o-files (parameter-list-ref parms 'o-file)) - (append - (parameter-list-ref parms 'linker-options) - (map (lambda (l) (build:lib-ld-flag l platform)) - (parameter-list-ref parms 'c-lib))) - parms))))))) + (batch:comment parms "================ Write file with C defines") + (cond + ((not (apply batch:lines->file parms + "scmflags.h" + (defines->c-defines c-defines))) + (batch:comment parms "================ Write failed!") #f) + (else + (batch:comment parms "================ Compile C source files") + (set! o-files + (let ((suppressors + (apply append + (map (lambda (l) (build:c-suppress l platform)) + (parameter-list-ref parms 'c-lib)))) + (ssdir (car (parameter-list-ref parms 'scm-srcdir)))) + (c-proc + (map (lambda (file) (in-vicinity ssdir file)) + (apply + append + (remove-if (lambda (file) (member file suppressors)) + (parameter-list-ref parms 'c-file)) + (map + (lambda (l) (build:c-lib-support l platform)) + (parameter-list-ref parms 'c-lib)))) + parms))) + (cond + ((not o-files) + (batch:comment parms "================ Compilation failed!") #f) + (else + + (batch:comment parms "================ Link C object files") + (let ((ans + ((plan-command + ((((rdb 'open-table) 'build-whats #f) 'get 'o-proc) what) + platform) + (car (parameter-list-ref parms 'target-name)) + (append o-files (parameter-list-ref parms 'o-file)) + (append + (parameter-list-ref parms 'linker-options) + (map (lambda (l) (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib))) + parms))) + (cond ((not ans) + (batch:comment parms "================ Link failed!") #f) + (else ans))))))))))))) (define (include-spec str parms) (let ((path (car (parameter-list-ref parms 'scm-srcdir)))) @@ -1615,23 +1676,30 @@ CHEAP_CONTINUATIONS.") (else (string-append "-D" (cadr d) "=" (object->string (caddr d)))))) defines)) -(define (batch:chop-to-fit-system . args) - (apply batch:apply-chop-to-fit - batch:try-system - args)) +(define c-> (filename:substitute?? "*.c" "*")) +(define c->o (filename:substitute?? "*.c" "*.o")) +(define c->obj (filename:substitute?? "*.c" "*.obj")) +(define obj-> (filename:substitute?? "*.obj" "*")) +(define obj->exe (filename:substitute?? "*.obj" "*.exe")) -(define (read-version parms) +(define (read-version revfile) (call-with-input-file - (string-append (car (parameter-list-ref parms 'scm-srcdir)) "patchlvl.h") + (if (file-exists? revfile) + revfile + (in-vicinity (implementation-vicinity) "patchlvl.h")) (lambda (port) (do ((c (read-char port) (read-char port))) ((or (eof-object? c) (eqv? #\= c)) - (symbol->string (read port))))))) + (do ((c (read-char port) (read-char port)) + (lst '() (cons c lst))) + ((or (eof-object? c) (char-whitespace? c)) + (list->string (reverse lst))))))))) (define (batch:rebuild-catalog parms) (batch:delete-file parms (in-vicinity (car (parameter-list-ref parms 'implvic)) - "slibcat"))) + "slibcat")) + #t) (define build:initializer (lambda (rdb) @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "continue.c" Scheme Continuations for C. @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "continue.h" Scheme Continuations for C. @@ -91,7 +91,9 @@ # define SHORT_ALIGN #endif #ifdef __MWERKS__ -# define SHORT_ALIGN +# ifdef __MC68K__ +# define SHORT_ALIGN +# endif #endif #ifdef MSDOS # define SHORT_ALIGN @@ -1,18 +1,18 @@ /* Copyright (C) 1992, 1993, 1994, 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "crs.c" interface to `curses' interactive terminal control library. @@ -64,12 +64,6 @@ int freewindow(win) delwin(win); return 0; } -int prinwindow(exp, port, writing) - SCM exp; SCM port; int writing; -{ - prinport(exp, port, "window"); - return !0; -} int bwaddch(c, win) int c; WINDOW *win; {waddch(win, c);return c;} int bwaddstr(str, win) char *str; WINDOW *win; {waddstr(win, str);return 0;} sizet bwwrite(str, siz, num, win) @@ -82,9 +76,10 @@ sizet bwwrite(str, siz, num, win) } int tc16_window; static ptobfuns winptob = { + "window", mark0, freewindow, - prinwindow, + 0, equal0, bwaddch, bwaddstr, @@ -101,7 +96,7 @@ SCM mkwindow(win) NEWCELL(z); DEFER_INTS; SETCHARS(z, win); - CAR(z) = tc16_window | OPN | RDNG | WRTNG; + CAR(z) = scm_port_entry(tc16_window, OPN | RDNG | WRTNG); ALLOW_INTS; return z; } @@ -187,7 +182,7 @@ SCM loverwrite(srcwin, dstwin) return ERR==overwrite(WIN(srcwin), WIN(dstwin)) ? BOOL_F : BOOL_T; } -static char s_wmove[] = "wmove", s_wadd[] = "wadd", s_winsert[] = "winsert", +static char s_wmove[] = "wmove", s_wadd[] = "wadd", s_winsch[] = "winsch", s_box[] = "box"; SCM lwmove(win, y, x) SCM win, y, x; @@ -210,13 +205,13 @@ SCM lwadd(win, obj) return ERR==waddstr(WIN(win), CHARS(obj)) ? BOOL_F : BOOL_T; } -SCM lwinsert(win, obj) +SCM lwinsch(win, obj) SCM win, obj; { - ASSERT(NIMP(win) && WINP(win), win, ARG1, s_winsert); + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_winsch); if INUMP(obj) return ERR==winsch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T; - ASSERT(ICHRP(obj), obj, ARG2, s_winsert); + ASSERT(ICHRP(obj), obj, ARG2, s_winsch); return ERR==winsch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T; } @@ -361,12 +356,12 @@ static iproc subr1s[] = { {ASSERT(NIMP(w) && WINP(w), w, ARG1, sn);\ return ERR==n(WIN(w), BOOL_F != b)?BOOL_F:BOOL_T;} -/* SUBROPT(lclearok, clearok, s_clearok, "clearok") */ -/* SUBROPT(lidlok, idlok, s_idlok, "idlok") */ +SUBROPT(lidlok, idlok, s_idlok, "idlok") SUBROPT(lleaveok, leaveok, s_leaveok, "leaveok") SUBROPT(lscrollok, scrollok, s_scrollok, "scrollok") -/* SUBROPT(lnodelay, nodelay, s_nodelay, "nodelay") */ +SUBROPT(lnodelay, nodelay, s_nodelay, "nodelay") +/* SUBROPT(lclearok, clearok, s_clearok, "clearok") */ static char s_clearok[] = "clearok"; SCM lclearok(w, b) SCM w, b; { @@ -379,12 +374,12 @@ static iproc subr2s[] = { {s_overlay, loverlay}, {s_overwrite, loverwrite}, {s_wadd, lwadd}, - {s_winsert, lwinsert}, + {s_winsch, lwinsch}, {s_clearok, lclearok}, - /* {s_idlok, lidlok}, */ + {s_idlok, lidlok}, {s_leaveok, lleaveok}, {s_scrollok, lscrollok}, -/* {s_nodelay, lnodelay}, */ + {s_nodelay, lnodelay}, {0, 0}}; void init_crs() @@ -12,7 +12,7 @@ ;; ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -1,18 +1,18 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc. - * +/* Copyright (C) 1990-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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "dynl.c" dynamically link&load object files. @@ -121,7 +121,7 @@ SCM l_dyn_main_call(symb, shl, args) else dld_perror("DLDP"); if (!i) listundefs(); if (!func) { - must_free_argv(argv, 0); + must_free_argv(argv); ALLOW_INTS; dld_perror("DLD"); return BOOL_F; @@ -131,7 +131,7 @@ SCM l_dyn_main_call(symb, shl, args) i = (*func) ((int)ilength(args), argv); /* *loc_loadpath = oloadpath; */ DEFER_INTS; - must_free_argv(argv, 0); + must_free_argv(argv); ALLOW_INTS; return MAKINUM(0L+i); } @@ -155,14 +155,11 @@ static iproc subr1s[] = { {0, 0}}; void init_dynl() { -# ifndef RTL - if (!execpath) execpath = scm_find_executable(); + /* if (!execpath) execpath = scm_find_execpath(); */ if ((!execpath) || dld_init(execpath)) { dld_perror("DLD:"); -/* wta(CAR(progargs), "couldn't init", "dld"); */ return; } -# endif if (!dumped) { init_iprocs(subr1s, tc7_subr_1); make_subr(s_call, tc7_subr_2, l_dyn_call); @@ -178,7 +175,8 @@ void init_dynl() # ifdef hpux # include "dl.h" -# define SHL(obj) ((shl_t*)CDR(obj)) +# define P_SHL(obj) ((shl_t*)(&CDR(obj))) +# define SHL(obj) (*P_SHL(obj)) int prinshl(exp, port, writing) SCM exp; SCM port; int writing; { @@ -219,7 +217,7 @@ SCM l_dyn_call(symb, shl) ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call); ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call); DEFER_INTS; - if ((i = shl_findsym(&SHL(shl), + if ((i = shl_findsym(P_SHL(shl), CHARS(symb), TYPE_PROCEDURE, &func)) != 0) { puts(" undef:"); puts(CHARS(symb)); @@ -237,13 +235,13 @@ SCM l_dyn_main_call(symb, shl, args) SCM symb, shl, args; { int i; - int (*func)P((int argc, char **argv)) = 0; + int (*func)P((int argc, char **argv)) = 0; char **argv; /* SCM oloadpath = *loc_loadpath; */ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call); DEFER_INTS; - if ((i = shl_findsym(&SHL(shl), + if ((i = shl_findsym(P_SHL(shl), CHARS(symb), TYPE_PROCEDURE, &func)) != 0) { puts(" undef:"); puts(CHARS(symb)); @@ -255,7 +253,7 @@ SCM l_dyn_main_call(symb, shl, args) i = (*func) ((int)ilength(args), argv); /* *loc_loadpath = oloadpath; */ DEFER_INTS; - must_free_argv(argv, 0); + must_free_argv(argv); ALLOW_INTS; return MAKINUM(0L+i); } @@ -444,7 +442,7 @@ SCM l_dyn_main_call(symb, shl, args) SCM symb, shl, args; { int i; - int (*func)P((int argc, char **argv)) = 0; + int (*func)P((int argc, char **argv)) = 0; char **argv; /* SCM oloadpath = *loc_loadpath; */ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); @@ -572,12 +570,12 @@ SCM l_dyn_call(symb, shl) OSErr err; CFragSymbolClass symClass; Str255 symName; - + /* SCM oloadpath = *loc_loadpath; */ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call); ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call); DEFER_INTS; - + strcpy((char *)symName, CHARS(symb)); c2pstr((char *)symName); err = FindSymbol((CFragConnectionID)SHL(shl), symName, @@ -599,12 +597,12 @@ SCM l_dyn_main_call(symb, shl, args) SCM symb, shl, args; { int i; - int (*func)P((int argc, char **argv)) = 0; + int (*func)P((int argc, char **argv)) = 0; char **argv; OSErr err; CFragSymbolClass symClass; Str255 symName; - + /* SCM oloadpath = *loc_loadpath; */ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call); @@ -625,7 +623,7 @@ SCM l_dyn_main_call(symb, shl, args) i = (*func) ((int)ilength(args), argv); /* *loc_loadpath = oloadpath; */ DEFER_INTS; - must_free_argv(argv, 0); + must_free_argv(argv); ALLOW_INTS; return MAKINUM(0L+i); } @@ -12,7 +12,7 @@ * * 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -1,18 +1,18 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc. - * +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "eval.c" eval and apply. @@ -69,7 +69,7 @@ arguments to C functions, or to return them from C functions, since such objects may be moved by the ecache gc. Ecache gc may happen anywhere interrupts are not deferred, because some interrupt - handlers may evaluate Scheme code and then return. + handlers may evaluate Scheme code and then return. Interrupts may be deferred with DEFER_INTS_EGC: This will prevent interrupts until an ALLOW_INTS or ALLOW_INTS_EGC, which may happen @@ -100,24 +100,30 @@ 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)); +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 eqv P((SCM x, SCM y)); -void scm_dynthrow P((CONTINUATION *cont, SCM val)); +SCM scm_multi_set P((SCM syms, SCM vals)); +SCM eval_args P((SCM x)); +void scm_dynthrow P((SCM cont, SCM val)); void scm_egc P((void)); -void scm_estk_grow P((sizet inc)); +void scm_estk_grow P((void)); void scm_estk_shrink P((void)); int badargsp P((SCM proc, SCM args)); +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 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, int check)); +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)); @@ -125,24 +131,31 @@ 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)); -static void bodycheck P((SCM xorig, SCM *bodyloc, char *what)); 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)); #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)); #endif /* Flush global variable state to estk. */ -#define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;} +#ifdef CAREFUL_INTS +# define ENV_SAVE debug_env_save(__FILE__, __LINE__) +#else +# define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;} +#endif /* 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 (INUM0==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow(20);\ + if (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\ else scm_estk_ptr += SCM_ESTK_FRLEN;} #define ENV_POP {DEFER_INTS_EGC;\ - if (INUM0==scm_estk_ptr[-SCM_ESTK_FRLEN]) scm_estk_shrink();\ + if (UNDEFINED==scm_estk_ptr[-1]) scm_estk_shrink();\ else scm_estk_ptr -= SCM_ESTK_FRLEN; ENV_RESTORE;} #ifdef NO_ENV_CACHE @@ -159,13 +172,20 @@ static void debug_env_warn P((char *fnam, long line, char *what)); # endif #endif +#ifdef CAUTIOUS +SCM scm_trace = UNDEFINED; +#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) #ifdef CAUTIOUS -# define TRACE(x) scm_estk_ptr[2]=(x) +# define TRACE(x) {scm_estk_ptr[2]=(x);} +# define TOP_TRACE(x) {scm_trace=(x);} +# define PUSH_TRACE TRACE(scm_trace) #else # define TRACE(x) /**/ +# define TOP_TRACE(x) /**/ +# define PUSH_TRACE /**/ #endif #define EVALIMP(x) (ILOCP(x)?*ilookup(x):x) @@ -181,7 +201,6 @@ 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_LEXP (1L<<16) # 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 @@ -239,7 +258,7 @@ SCM scm_profile(resetp) /* Inhibit warnings for ARGC, is not changed by egc. */ # undef ARGC # define ARGC(x) ((6L & (((cell *)(SCM2PTR(x)))->cdr))>>1) -#include <signal.h> +# include <signal.h> SCM test_ints(x) SCM x; { @@ -302,6 +321,18 @@ SCM *debug_env_cdr(x, fnam, line) debug_env_warn(fnam, line, "CAR"); return ret; } +static void debug_env_save(fnam, line) + char *fnam; + long line; +{ + if (NIMP(scm_env) && (!scm_cell_p(scm_env))) + debug_env_warn(fnam, line, "ENV_SAVE (env)"); + if (NIMP(scm_env_tmp) && (!scm_cell_p(scm_env_tmp))) + debug_env_warn(fnam, line, "ENV_SAVE (tmp)"); + scm_estk_ptr[0]=scm_env; + scm_estk_ptr[1]=scm_env_tmp; +} + #endif /* CAREFUL_INTS */ SCM *ilookup(iloc) @@ -338,14 +369,17 @@ SCM *farlookup(farloc) 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_UNDEFP and LOOKUP_MACROP */ -#define LOOKUP_UNDEFP 1 -#define LOOKUP_MACROP 2 +/* 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; { SCM env; + long icdr = 0L; register SCM *al, fl, var = CAR(vloc); register unsigned int idist, iframe = 0; #ifdef MACRO @@ -353,52 +387,65 @@ SCM *lookupcar(vloc, check) #endif DEFER_INTS_EGC; env = scm_env; + if (NIMP(env) && ENVP(env)) + env = CDR(env); for(; NIMP(env); env = CDR(env)) { idist = 0; al = &CAR(env); - for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) { + fl = CAR(*al); #ifdef MACRO - if (fl==mark) { - var = IDENT_PARENT(var); - mark = IDENT_MARK(var); - } + if (fl==mark) { + var = IDENT_PARENT(var); + mark = IDENT_MARK(var); + } #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; #ifndef RECKLESS - if ((check & LOOKUP_UNDEFP) - && UNBNDP(CDR(*al))) { env = EOL; goto errout; } -# ifdef MACRO - if ((check & LOOKUP_MACROP) - && (NIMP(CDR(*al)) && MACROP(CDR(*al)))) goto badkey; -# endif + fl = CDR(*al); #endif -#ifndef TEST_FARLOC - if (iframe < 4096 && idist < (1L<<(LONG_BIT-20))) - CAR(vloc) = MAKILOC(iframe, idist) + ICDR; - else -#endif - CAR(vloc) = cons2(IM_FARLOC_CDR, MAKINUM(iframe), MAKINUM(idist)); - return &CDR(*al); + 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(CAR(*al))) {env = EOL; goto errout;} + && UNBNDP(fl)) {env = EOL; goto errout;} # ifdef MACRO if ((check & LOOKUP_MACROP) - && NIMP(CAR(*al)) && MACROP(CAR(*al))) goto badkey; + && 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 */ + local_out: +#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 -#ifndef TEST_FARLOC - if (iframe < 4096 && idist < (1L<<(LONG_BIT-20))) - CAR(vloc) = MAKILOC(iframe, idist); - else -#endif - CAR(vloc) = cons2(IM_FARLOC_CAR, MAKINUM(iframe), MAKINUM(idist)); - return &CAR(*al); + return icdr ? &CDR(*al) : &CAR(*al); } idist++; } @@ -411,11 +458,12 @@ SCM *lookupcar(vloc, check) } #endif var = sym2vcell(var); + gloc_out: #ifndef RECKLESS if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) { var = CAR(var); errout: - everr(vloc, wrapenv() /*scm_env*/, var, + everr(vloc, wrapenv(), var, # ifdef MACRO M_IDENTP(var) ? s_escaped : # endif @@ -424,11 +472,11 @@ SCM *lookupcar(vloc, check) # ifdef MACRO if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) { var = CAR(var); - badkey: everr(vloc, wrapenv()/*scm_env*/, var, s_badkey, ""); + badkey: everr(vloc, wrapenv(), var, s_badkey, ""); } # endif #endif - CAR(vloc) = var + 1; + if (check) CAR(vloc) = var + 1; return &CDR(var); } @@ -439,6 +487,7 @@ static SCM unmemocar(form) 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)); @@ -458,13 +507,13 @@ static SCM evalatomcar(x) SCM r; switch TYP7(CAR(x)) { default: - everr(x, wrapenv() /*scm_env*/, CAR(x), "Cannot evaluate: ", ""); + everr(x, wrapenv(), CAR(x), "Cannot evaluate: ", ""); case tcs_symbols: lookup: return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP); case tc7_vector: #ifndef RECKLESS - if (2 <= verbose) warn("unquoted ", s_vector); + if (2 <= verbose) scm_warn("unquoted ", s_vector); #endif r = cons2(IM_QUOTE, CAR(x), EOL); CAR(x) = r; @@ -474,13 +523,39 @@ static SCM evalatomcar(x) if M_IDENTP(CAR(x)) goto lookup; #endif /* fall through */ - case tc7_string: - case tc7_bvect: case tc7_ivect: case tc7_uvect: - case tc7_fvect: case tc7_dvect: case tc7_cvect: + case tcs_uves: return CAR(x); } } +SCM scm_multi_set(syms, vals) + SCM syms, vals; +{ + SCM res = EOL, *pres = &res; + SCM *loc; + do { + ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set); + switch (7 & (int)(CAR(syms))) { + case 0: + loc = lookupcar(syms, LOOKUP_UNDEFP|LOOKUP_MACROP); + break; + case 1: + loc = &(I_VAL(CAR(syms))); + break; + case 4: + loc = ilookup(CAR(syms)); + break; + } + *pres = cons(*loc, EOL); + pres = &CDR(*pres); + *loc = CAR(vals); + syms = CDR(syms); + vals = CDR(vals); + } while (NIMP(syms)); + ASSERT(NULLP(vals) && NULLP(syms), vals, WNA, s_set); + return res; +} + SCM eval_args(l) SCM l; { @@ -493,6 +568,75 @@ SCM eval_args(l) return res; } +static void ecache_evalx(x) + SCM x; +{ + SCM argv[10]; + int i = 0, imax = sizeof(argv)/sizeof(SCM); + scm_env_tmp = EOL; + while NIMP(x) { + if (imax==i) { + ecache_evalx(x); + break; + } + argv[i++] = EVALCAR(x); + x = CDR(x); + } + scm_env_v2lst(i, argv); +} + +/* result is 1 if right number of arguments, 0 otherwise, + environment frame is put in scm_env_tmp */ +static int ecache_eval_args(proc, arg1, arg2, arg3, x) + SCM proc, arg1, arg2, arg3, x; +{ + SCM argv[3]; + argv[0] = arg1; + argv[1] = arg2; + argv[2] = arg3; + if (NIMP(x)) + ecache_evalx(x); + else + scm_env_tmp = EOL; + scm_env_v2lst(3, argv); +#ifndef RECKLESS + proc = CAR(CODE(proc)); + proc = CDR(proc); + proc = CDR(proc); + proc = CDR(proc); + for (; NIMP(proc); proc=CDR(proc)) { + if IMP(x) return 0; + x = CDR(x); + } + if NIMP(x) return 0; +#endif + return 1; +} + +static SCM asubr_apply(proc, arg1, arg2, arg3, args) + SCM proc, arg1, arg2, arg3, args; +{ + switch TYP7(proc) { + case tc7_asubr: + arg1 = SUBRF(proc)(arg1, arg2); + arg1 = SUBRF(proc)(arg1, arg3); + while NIMP(args) { + arg1 = SUBRF(proc)(arg1, CAR(args)); + args = CDR(args); + } + return arg1; + case tc7_rpsubr: + if FALSEP(SUBRF(proc)(arg1, arg2)) return BOOL_F; + while (!0) { + if FALSEP(SUBRF(proc)(arg2, arg3)) return BOOL_F; + if IMP(args) return BOOL_T; + arg2 = arg3; + arg3 = CAR(args); + args = CDR(args); + } + } +} + /* the following rewrite expressions and * some memoized forms have different syntax */ @@ -531,6 +675,7 @@ static SCM *id_denote(var) 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)) { @@ -545,6 +690,12 @@ static SCM *id_denote(var) 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; } @@ -556,7 +707,7 @@ static void unpaint(p) if CONSP(x) { if NIMP(CAR(x)) unpaint(&CAR(x)); p = &CDR(*p); - } + } else if VECTORP(x) { sizet i = LENGTH(x); if (0==i) return; @@ -575,18 +726,11 @@ static void unpaint(p) # define TOPRENAME(v) (v) #endif -static void bodycheck(xorig, bodyloc, what) - SCM xorig, *bodyloc; - char *what; -{ - ASRTSYNTAX(ilength(*bodyloc) >= 1, s_expression); -} - static SCM m_body(op, xorig, what) SCM op, xorig; char *what; { - ASRTSYNTAX(ilength(xorig) >= 1, s_expression); + 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. */ @@ -631,8 +775,10 @@ SCM m_set(xorig, env) { SCM x = CDR(xorig); ASSYNT(2==ilength(x), xorig, s_expression, s_set); - ASSYNT(NIMP(CAR(x)) && IDENTP(CAR(x)), - xorig, s_variable, s_set); + varcheck(xorig, + (NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) : + (ilength(CAR(x)) > 0) ? CAR(x) : UNDEFINED, + s_set, s_variable); return cons(IM_SET, x); } @@ -641,8 +787,11 @@ SCM m_and(xorig, env) { int len = ilength(CDR(xorig)); ASSYNT(len >= 0, xorig, s_test, s_and); - if (len >= 1) return cons(IM_AND, CDR(xorig)); - else return BOOL_T; + switch (len) { + default: return cons(IM_AND, CDR(xorig)); + case 1: return CAR(CDR(xorig)); + case 0: return BOOL_T; + } } SCM m_or(xorig, env) @@ -650,8 +799,11 @@ SCM m_or(xorig, env) { int len = ilength(CDR(xorig)); ASSYNT(len >= 0, xorig, s_test, s_or); - if (len >= 1) return cons(IM_OR, CDR(xorig)); - else return BOOL_F; + switch (len) { + default: return cons(IM_OR, CDR(xorig)); + case 1: return CAR(CDR(xorig)); + case 0: return BOOL_F; + } } #ifdef INUMS_ONLY @@ -660,11 +812,11 @@ SCM m_or(xorig, env) SCM m_case(xorig, env) SCM xorig, env; { - SCM clause, cdrx = copy_list(CDR(xorig)), x = cdrx; + SCM clause, cdrx = copy_list(CDR(xorig), 2), x = cdrx; #ifndef RECKLESS SCM s, keys = EOL; #endif - ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case); + ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_case); while(NIMP(x = CDR(x))) { clause = CAR(x); ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case); @@ -673,19 +825,22 @@ SCM m_case(xorig, env) CAR(x) = cons(IM_ELSE, CDR(clause)); } else { - ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case); #ifdef MACRO - clause = cons(copy_list(CAR(clause)), CDR(clause)); + SCM c = copy_list(CAR(clause), 0); + ASSYNT(!UNBNDP(c), xorig, s_clauses, s_case); + clause = cons(c, CDR(clause)); DEFER_INTS; unpaint(&CAR(clause)); 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 +#endif } } return cons(IM_CASE, cdrx); @@ -694,9 +849,9 @@ SCM m_case(xorig, env) SCM m_cond(xorig, env) SCM xorig, env; { - SCM arg1, cdrx = copy_list(CDR(xorig)), x = cdrx; + SCM arg1, cdrx = copy_list(CDR(xorig), 1), x = cdrx; int len = ilength(x); - ASSYNT(len >= 1, xorig, s_clauses, s_cond); + ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_cond); while(NIMP(x)) { arg1 = CAR(x); len = ilength(arg1); @@ -717,30 +872,39 @@ SCM m_cond(xorig, env) return cons(IM_COND, cdrx); } -SCM m_lambda(xorig, env) - SCM xorig, env; +static int varcheck(xorig, vars, op, what) + SCM xorig, vars; + char *op, *what; { - SCM proc, x = CDR(xorig); - int argc = 0; /* Number of required args */ - if (ilength(x) < 2) goto badforms; - proc = CAR(x); - if NULLP(proc) goto memlambda; - if (IM_LET==proc) goto memlambda; /* named let */ - if IMP(proc) goto badforms; - if IDENTP(proc) goto memlambda; - if NCONSP(proc) goto badforms; - while NIMP(proc) { - if NCONSP(proc) - if (!IDENTP(proc)) goto badforms; - else goto memlambda; - if (!(NIMP(CAR(proc)) && IDENTP(CAR(proc)))) goto badforms; - proc = CDR(proc); + SCM v1, vs; + int argc = 0; + for (; NIMP(vars) && CONSP(vars); vars = CDR(vars)) { argc++; +#ifndef RECKLESS + v1 = CAR(vars); + if (IMP(v1) || !IDENTP(v1)) + badvar: wta(xorig, what, op); + for (vs = CDR(vars); NIMP(vs) && CONSP(vs); vs = CDR(vs)) { + if (v1==CAR(vs)) + nonuniq: wta(xorig, "non-unique bindings", op); + } + if (v1==vs) goto nonuniq; +#endif } - if (NNULLP(proc) && (IM_LET != proc)) /* IM_LET inserted by named let. */ - badforms: wta(xorig, s_formals, s_lambda); - memlambda: - return cons2(ISYMSETVAL(IM_LAMBDA, argc), CAR(x), + /* argc of 3 means no rest argument, 3+ required arguments */ + if (NULLP(vars) || ISYMP(vars)) return argc > 3 ? 3 : argc; + ASRTGO(NIMP(vars) && IDENTP(vars), badvar); + return argc > 2 ? 2 : argc; +} +SCM m_lambda(xorig, env) + SCM xorig, env; +{ + SCM x = CDR(xorig); + int argc; + ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda); + argc = varcheck(xorig, CAR(x), s_lambda, s_formals); + if (argc > 3) argc = 3; + return cons2(MAKISYMVAL(IM_LAMBDA, argc), CAR(x), m_body(IM_LAMBDA, CDR(x), s_lambda)); } SCM m_letstar(xorig, env) @@ -771,17 +935,16 @@ SCM m_letstar(xorig, env) <body>) ;; becomes (do_mem (varn ... var2 var1) - (<init1> <init2> ... <initn>) + (<initn> ... <init2> <init1>) (<test> <return>) (<body>) - <step1> <step2> ... <stepn>) ;; missing steps replaced by var + <stepn> ... <step2> <step1>) ;; missing steps replaced by var */ SCM m_do(xorig, env) SCM xorig, env; { SCM x = CDR(xorig), arg1, proc; SCM vars = IM_DO, inits = EOL, steps = EOL; - SCM *initloc = &inits, *steploc = &steps; int len = ilength(x); ASSYNT(len >= 2, xorig, s_test, s_do); proc = CAR(x); @@ -790,22 +953,20 @@ SCM m_do(xorig, env) arg1 = CAR(proc); len = ilength(arg1); ASSYNT(2==len || 3==len, xorig, s_bindings, s_do); - ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_do); /* vars reversed here, inits and steps reversed at evaluation */ vars = cons(CAR(arg1), vars); /* variable */ arg1 = CDR(arg1); - *initloc = cons(CAR(arg1), EOL); /* init */ - initloc = &CDR(*initloc); + inits = cons(CAR(arg1), inits); arg1 = CDR(arg1); - *steploc = cons(IMP(arg1)?CAR(vars):CAR(arg1), EOL); /* step */ - steploc = &CDR(*steploc); + steps = cons(IMP(arg1)?CAR(vars):CAR(arg1), steps); proc = CDR(proc); } x = CDR(x); ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do); + 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); - bodycheck(xorig, &CAR(CDR(CDR(x))), s_do); return cons(IM_DO, x); } @@ -832,7 +993,7 @@ static SCM iqq(form) } if NCONSP(form) return form; tmp = CAR(form); - if (IM_UNQUOTE==tmp) + if (IM_UNQUOTE==tmp) return evalcar(CDR(form)); if (NIMP(tmp) && IM_UQ_SPLICING==CAR(tmp)) return append(cons2(evalcar(CDR(tmp)), iqq(CDR(form)), EOL)); @@ -877,7 +1038,7 @@ static SCM m_iqq(form, depth, env) } if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) { --depth; - if (0==depth) CAR(form) = IM_UNQUOTE; + if (0==depth) CAR(form) = IM_UNQUOTE; label: tmp = CDR(form); ASSERT(NIMP(tmp) && ECONSP(tmp) && NULLP(CDR(tmp)), @@ -917,6 +1078,20 @@ SCM m_delay(xorig, env) return cons2(IM_DELAY, EOL, CDR(xorig)); } +static int built_inp(name, x) + SCM name, x; +{ + if NIMP(x) { + tail: + switch TYP7(x) { + case tcs_subrs: return CHARS(name)==SNAME(x); + case tc7_smob: if MACROP(x) {x = CDR(x); goto tail;} + /* else fall through */ + } + } + return 0; +} + SCM m_define(x, env) SCM x, env; { @@ -930,7 +1105,7 @@ SCM m_define(x, env) } ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define); ASSYNT(1==ilength(x), arg1, s_expression, s_define); - if (NIMP(env) && tc16_env==CAR(env)) { + if (NIMP(env) && ENVP(env)) { DEFER_INTS_EGC; env = CDR(env); } @@ -945,15 +1120,13 @@ SCM m_define(x, env) arg1 = sym2vcell(proc); #ifndef RECKLESS if (2 <= verbose && - NIMP(CDR(arg1)) && - (proc == - ((SCM) SNAME(MACROP(CDR(arg1)) ? CDR(CDR(arg1)) : CDR(arg1)))) + built_inp(proc, CDR(arg1)) && (CDR(arg1) != x)) - warn("redefining built-in ", CHARS(proc)); + scm_warn("redefining built-in ", CHARS(proc)); else #endif if (5 <= verbose && UNDEFINED != CDR(arg1)) - warn("redefining ", CHARS(proc)); + scm_warn("redefining ", CHARS(proc)); CDR(arg1) = x; #ifdef SICP return m_quote(cons2(i_quote, CAR(arg1), EOL), EOL); @@ -962,7 +1135,6 @@ SCM m_define(x, env) #endif } return cons2(IM_DEFINE, proc, x); - /* return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x); */ } /* end of acros */ @@ -972,24 +1144,17 @@ static SCM m_letrec1(op, imm, xorig, env) SCM cdrx = CDR(xorig); /* locally mutable version of form */ char *what = CHARS(CAR(xorig)); SCM x = cdrx, proc, arg1; /* structure traversers */ - SCM vars = imm, inits = EOL, *initloc = &inits; - + SCM vars = imm, inits = EOL; /* ASRTSYNTAX(ilength(x) >= 2, s_body); */ proc = CAR(x); -#if 0 - if NULLP(proc) /* null binding, let* faster */ - return m_letstar(cons2(CAR(xorig), EOL, m_body(imm, CDR(x), what)), env); -#endif ASRTSYNTAX(ilength(proc) >= 1, s_bindings); do { - /* vars list reversed here, inits reversed at evaluation */ arg1 = CAR(proc); ASRTSYNTAX(2==ilength(arg1), s_bindings); - ASRTSYNTAX(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), s_variable); vars = cons(CAR(arg1), vars); - *initloc = cons(CAR(CDR(arg1)), EOL); - initloc = &CDR(*initloc); + 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))); } @@ -1039,9 +1204,8 @@ SCM m_let(xorig, env) proc = CDR(proc); } proc = cons2(TOPRENAME(i_lambda), vars, m_body(IM_LET, CDR(x), s_let)); - proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL), - acons(name, inits, EOL)); - return m_letrec1(IM_LETREC, IM_LET, proc, env); + proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL), cons(name, EOL)); + return cons(m_letrec1(IM_LETREC, IM_LET, proc, env), inits); } #define s_atapply (ISYMCHARS(IM_APPLY)+1) @@ -1053,7 +1217,7 @@ SCM m_apply(xorig, env) return cons(IM_APPLY, CDR(xorig)); } -SCM m_expand_body(xorig) +static SCM m_expand_body(xorig) SCM xorig; { SCM form, x = CDR(xorig), defs = EOL; @@ -1063,7 +1227,7 @@ SCM m_expand_body(xorig) if (IMP(form) || NCONSP(form)) break; if IMP(CAR(form)) break; if (! IDENTP(CAR(form))) break; - form = macroexp1(cons(CAR(form), CDR(form)), 0); + form = macroexp1(form, defs); if (IM_DEFINE==CAR(form)) { defs = cons(CDR(form), defs); x = CDR(x); @@ -1091,109 +1255,59 @@ SCM m_expand_body(xorig) return xorig; } -static SCM macroexp1(x, check) - SCM x; - int check; +static SCM macroexp1(x, defs) + SCM x, defs; { - SCM res, proc; + SCM res = UNDEFINED, proc = CAR(x); int argc; - ASRTGO(IDENTP(CAR(x)), badfun); + ASRTGO(IDENTP(proc), badfun); macro_tail: - proc = *lookupcar(x, 0); + res = CAR(x); + proc = *lookupcar(x, IMP(defs) ? LOOKUP_UNDEFP : 0); if (NIMP(proc) && MACROP(proc)) { - unmemocar(x); - res = apply(CDR(proc), cons2(x, wrapenv(), EOL), EOL); + CAR(x) = res; + res = cons2(x, wrapenv(), EOL); switch ((int)(CAR(proc)>>16) & 0x7f) { - case 2: /* mmacro */ - if (ilength(res) <= 0) - res = cons2(IM_BEGIN, res, EOL); - DEFER_INTS; - CAR(x) = CAR(res); - CDR(x) = CDR(res); - ALLOW_INTS; - break; - case 1: /* macro */ + 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; + } + /* else fall through */ + case 1: case 5: /* macro */ + res = apply(CDR(proc), res, EOL); x = NIMP(res) ? res : cons2(IM_BEGIN, res, EOL); break; - case 0: /* acro */ + case 0: case 4: /* acro */ + res = IMP(defs) ? apply(CDR(proc), res, EOL) : UNSPECIFIED; return cons2(IM_QUOTE, res, EOL); } if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail; #ifndef RECKLESS - if (check && IM_DEFINE==CAR(x)) - everr(x, wrapenv() /*scm_env*/, i_define, "Bad placement", ""); + if (UNBNDP(defs) && IM_DEFINE==CAR(x)) + everr(x, wrapenv(), i_define, "Bad placement", ""); #endif return x; } - else if (!check) { - unmemocar(x); - return x; - } -#ifdef RECKLESS - return x; -#else - ASRTGO(NIMP(proc), badfun); - argc = ilength(CDR(x)); -# ifdef CCLO - cclo_tail: -# endif - switch TYP7(proc) { - default: - badfun: - unmemocar(x); - everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc, - UNBNDP(proc) ? s_unbnd : s_wtap, ""); - case tc7_lsubr: - case tc7_rpsubr: - case tc7_asubr: - return x; - case tc7_subr_0: - ASRTGO(0==argc, wrongnumargs); - return x; - case tc7_contin: - case tc7_subr_1: - case tc7_cxr: - ASRTGO(1==argc, wrongnumargs); - return x; - case tc7_subr_2: - ASRTGO(2==argc, wrongnumargs); - return x; - case tc7_subr_3: - ASRTGO(3==argc, wrongnumargs); - return x; - case tc7_subr_1o: - ASRTGO(0==argc || 1==argc, wrongnumargs); - return x; - case tc7_subr_2o: - ASRTGO(1==argc || 2==argc, wrongnumargs); - return x; - case tc7_lsubr_2: - ASRTGO(2<=argc, wrongnumargs); - return x; - case tc7_specfun: - switch TYP16(proc) { - case tc16_apply: - ASRTGO(2<=argc, wrongnumargs); - return x; - case tc16_call_cc: - ASRTGO(1==argc, wrongnumargs); - return x; -# ifdef CCLO - case tc16_cclo: - proc = CCLO_SUBR(proc); - argc++; - goto cclo_tail; -# endif +#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), + ""); } - case tcs_closures: - if (badargsp(proc, CDR(x))) { - wrongnumargs: - unmemocar(x); - everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, ""); - } - return x; } #endif /* ndef RECKLESS */ + return x; } #ifndef RECKLESS @@ -1209,6 +1323,62 @@ int badargsp(proc, args) } return NNULLP(args) ? 1 : 0; } +/* If what is 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; + cclo_tail: + switch TYP7(p) { + default: + badproc: + if (what) wta(proc, (char *)ARG1, 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: + case tc7_subr_1: ASRTGO(1==argc, wrongnumargs) return !0; + case tc7_subr_1o: ASRTGO(0==argc || 1==argc, wrongnumargs) return !0; + case tc7_subr_2: ASRTGO(2==argc, wrongnumargs) return !0; + case tc7_subr_2o: ASRTGO( 1==argc || 2==argc, wrongnumargs) return !0; + case tc7_subr_3: ASRTGO(3==argc, wrongnumargs) return !0; + case tc7_rpsubr: + case tc7_asubr: + case tc7_lsubr: return !0; + 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; + case tc16_call_cc: + case tc16_eval: ASRTGO(1==argc, wrongnumargs) return !0; +# ifdef CCLO + case tc16_cclo: + p = CCLO_SUBR(p); + argc++; + goto cclo_tail; +# endif + } + case tcs_closures: + { + SCM formals = CAR(CODE(p)); + while (argc--) { + if IMP(formals) goto wrongnumargs; + if (CONSP(formals)) + formals = CDR(formals); + else + return !0; + } + ASRTGO(IMP(formals) || NCONSP(formals), wrongnumargs); + } + } +} #endif char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval"; @@ -1219,19 +1389,23 @@ static SCM wrapenv() 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); + EGC_ROOT(z); return z; } SCM ceval(x, env) SCM x, env; { - DEFER_INTS_EGC; ENV_PUSH; - scm_env = env; +#ifdef CAUTIOUS + scm_trace = UNSPECIFIED; +#endif TRACE(x); + scm_env = env; x = ceval_1(x); ENV_POP; ALLOW_INTS_EGC; @@ -1245,9 +1419,14 @@ static SCM ceval_1(x) SCM proc, arg2, arg3; int envpp = 0; /* 1 means an environment has been pushed in this invocation of ceval_1, -1 means pushed and then popped. */ +#ifdef CAUTIOUS + SCM xorig; +#endif CHECK_STACK; loop: POLL; - TRACE(x); +#ifdef CAUTIOUS + xorig = x; +#endif #ifdef SCM_PROFILE eval_cases[TYP7(x)]++; #endif @@ -1283,18 +1462,17 @@ static SCM ceval_1(x) if NCELLP(CAR(x)) { x = CAR(x); x = IMP(x) ? EVALIMP(x) : I_VAL(x); - goto retx; } - - if ATOMP(CAR(x)) { + else if ATOMP(CAR(x)) x = evalatomcar(x); - retx: - ENV_MAY_POP(envpp, 0); - ALLOW_INTS_EGC; - return x; + else { + x = CAR(x); + goto loop; /* tail recurse */ } - x = CAR(x); - goto loop; /* tail recurse */ + retx: + ENV_MAY_POP(envpp, 0); + ALLOW_INTS_EGC; + return x; case (127 & IM_CASE): x = CDR(x); @@ -1321,10 +1499,8 @@ static SCM ceval_1(x) proc = CDR(proc); } } - retunspec: - ENV_MAY_POP(envpp, 0); - ALLOW_INTS_EGC; - return UNSPECIFIED; + x = UNSPECIFIED; + goto retx; case (127 & IM_COND): while(NIMP(x = CDR(x))) { proc = CAR(x); @@ -1342,16 +1518,13 @@ static SCM ceval_1(x) goto evap1; } } - goto retunspec; + x = UNSPECIFIED; + goto retx; case (127 & IM_DO): ENV_MAY_PUSH(envpp); + TRACE(x); x = CDR(x); - proc = CAR(CDR(x)); /* inits */ - scm_env_tmp = EOL; /* values */ - while NIMP(proc) { - scm_env_cons_tmp(EVALCAR(proc)); - proc = CDR(proc); - } + ecache_evalx(CAR(CDR(x))); /* inits */ EXTEND_ENV(CAR(x)); x = CDR(CDR(x)); while (proc = CAR(x), FALSEP(EVALCAR(proc))) { @@ -1359,51 +1532,42 @@ static SCM ceval_1(x) t.arg1 = CAR(proc); /* body */ SIDEVAL_1(t.arg1); } - scm_env_tmp = EOL; - for(proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc)) { - scm_env_cons_tmp(EVALCAR(proc)); /* steps */ - } - DEFER_INTS_EGC; + ecache_evalx(CDR(CDR(x))); /* steps */ t.arg1 = CAR(CAR(scm_env)); scm_env = CDR(scm_env); EXTEND_ENV(t.arg1); } x = CDR(proc); - if NULLP(x) goto retunspec; + if NULLP(x) {x = UNSPECIFIED; goto retx;} goto begin; case (127 & IM_IF): x = CDR(x); if NFALSEP(EVALCAR(x)) x = CDR(x); - else if IMP(x = CDR(CDR(x))) goto retunspec; + else if IMP(x = CDR(CDR(x))) {x = UNSPECIFIED; goto retx;} goto carloop; case (127 & IM_LET): ENV_MAY_PUSH(envpp); + TRACE(x); x = CDR(x); - proc = CAR(CDR(x)); - scm_env_tmp = EOL; - do { - scm_env_cons_tmp(EVALCAR(proc)); - } while NIMP(proc = CDR(proc)); + ecache_evalx(CAR(CDR(x))); EXTEND_ENV(CAR(x)); x = CDR(x); goto cdrxbegin; case (127 & IM_LETREC): ENV_MAY_PUSH(envpp); + TRACE(x); x = CDR(x); scm_env_tmp = undefineds; EXTEND_ENV(CAR(x)); x = CDR(x); - proc = CAR(x); - scm_env_tmp = EOL; - do { - scm_env_cons_tmp(EVALCAR(proc)); - } while NIMP(proc = CDR(proc)); + ecache_evalx(CAR(x)); EGC_ROOT(CAR(scm_env)); CDR(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) { @@ -1439,10 +1603,13 @@ static SCM ceval_1(x) proc = CAR(x); switch (7 & (int)proc) { case 0: - if CONSP(proc) - *farlookup(proc) = arg2; - else - *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2; + if ECONSP(proc) + if ISYMP(CAR(proc)) *farlookup(proc) = arg2; + else { + x = scm_multi_set(proc, arg2); + goto retx; + } + else *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2; break; case 1: I_VAL(proc) = arg2; @@ -1453,26 +1620,12 @@ static SCM ceval_1(x) } #ifdef SICP x = arg2; - goto retx; +#else + x = UNSPECIFIED; #endif - goto retunspec; + goto retx; case (127 & IM_DEFINE): /* only for internal defines */ goto badfun; -#if 0 - x = CDR(x); - proc = CAR(x); - x = CDR(x); - x = evalcar(x); - DEFER_INTS_EGC; - scm_env_tmp = CDR(CAR(scm_env)); - scm_env_cons_tmp(x); - EGC_ROOT(CAR(scm_env)); - /* DEFER_INTS; */ - CAR(CAR(scm_env)) = proc; - CDR(CAR(scm_env)) = scm_env_tmp; - /* ALLOW_INTS; */ - goto retunspec; -#endif /* new syntactic forms go here. */ case (127 & MAKISYM(0)): proc = CAR(x); @@ -1482,13 +1635,13 @@ static SCM ceval_1(x) #endif switch ISYMNUM(proc) { case (ISYMNUM(IM_APPLY)): - proc = CDR(x); - proc = EVALCAR(proc); + x = CDR(x); + proc = evalcar(x); ASRTGO(NIMP(proc), badfun); - t.arg1 = CDR(CDR(x)); - t.arg1 = EVALCAR(t.arg1); + t.arg1 = evalcar(CDR(x)); if (CLOSUREP(proc)) { ENV_MAY_PUSH(envpp); + TRACE(x); scm_env_tmp = t.arg1; #ifndef RECKLESS goto clo_checked; @@ -1497,7 +1650,7 @@ static SCM ceval_1(x) #endif } x = apply(proc, t.arg1, EOL); - goto retx; + goto retx; case (ISYMNUM(IM_DELAY)): x = makprom(closure(CDR(x), 0)); goto retx; @@ -1515,11 +1668,12 @@ static SCM ceval_1(x) default: proc = x; badfun: - everr(x, wrapenv() /*scm_env*/, proc, s_wtap, ""); +#ifdef CAUTIOUS + scm_trace = UNDEFINED; +#endif + everr(x, wrapenv(), proc, s_wtap, ""); case tc7_vector: - case tc7_bvect: case tc7_ivect: case tc7_uvect: - case tc7_fvect: case tc7_dvect: case tc7_cvect: - case tc7_string: + case tcs_uves: case tc7_smob: goto retx; case (127 & ILOC00): @@ -1530,18 +1684,28 @@ static SCM ceval_1(x) break; case tcs_cons_nimcar: if ATOMP(CAR(x)) { - x = macroexp1(x, !0); + TOP_TRACE(x); +#ifdef MEMOIZE_LOCALS + x = macroexp1(x, UNDEFINED); goto loop; +#else + proc = *lookupcar(x, 0); + if (NIMP(proc) && MACROP(proc)) { + x = macroexp1(x, UNDEFINED); + goto loop; + } +#endif } - proc = ceval_1(CAR(x)); + else proc = ceval_1(CAR(x)); /* 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 = scm_env; /* For error reporting at wrongnumargs. */ + scm_estk_ptr[0] = scm_env; /* For error reporting at wrongnumargs. */ if NULLP(CDR(x)) { evap0: ENV_MAY_POP(envpp, CLOSUREP(proc)); + TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { /* no arguments given */ case tc7_subr_0: @@ -1582,6 +1746,7 @@ static SCM ceval_1(x) x = CODE(proc); scm_env = ENV(proc); EXTEND_ENV(CAR(x)); + TRACE(CDR(x)); goto cdrxbegin; case tc7_specfun: #ifdef CCLO @@ -1603,9 +1768,10 @@ static SCM ceval_1(x) wrongnumargs: if (envpp < 0) { scm_estk_ptr += SCM_ESTK_FRLEN; - scm_env = *scm_estk_ptr; + scm_env = scm_estk_ptr[0]; } - everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, ""); + TOP_TRACE(UNDEFINED); + everr(x, wrapenv(), proc, (char *)WNA, ""); default: goto badfun; } @@ -1619,6 +1785,7 @@ static SCM ceval_1(x) if NULLP(x) { 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: @@ -1639,16 +1806,19 @@ evap1: return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0); # endif floerr: - wta(t.arg1, (char *)ARG1, CHARS(SNAME(proc))); + wta(t.arg1, (char *)ARG1, SNAME(proc)); } #endif - proc = (SCM)SNAME(proc); { - char *chrs = CHARS(proc)+LENGTH(proc)-1; - while('c' != *--chrs) { + int op = CXR_OP(proc); +#ifndef RECKLESS + x = t.arg1; +#endif + while (op) { ASSERT(NIMP(t.arg1) && CONSP(t.arg1), - t.arg1, ARG1, CHARS(proc)); - t.arg1 = ('a'==*chrs)?CAR(t.arg1):CDR(t.arg1); + x, ARG1, SNAME(proc)); + t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1)); + op >>= 2; } return t.arg1; } @@ -1672,7 +1842,7 @@ evap1: goto clo_checked; } case tc7_contin: - scm_dynthrow(CONT(proc), t.arg1); + scm_dynthrow(proc, t.arg1); case tc7_specfun: switch TYP16(proc) { case tc16_call_cc: @@ -1684,10 +1854,19 @@ evap1: #ifdef SHORT_INT x = (SCM)thrown_value; #endif +#ifdef CHEAP_CONTINUATIONS + envpp = 0; +#endif goto retx; } ASRTGO(NIMP(proc), badfun); goto evap1; + case tc16_eval: + ENV_MAY_PUSH(envpp); + TRACE(x); + scm_env = EOL; + x = cons(copytree(t.arg1), EOL); + goto begin; #ifdef CCLO case tc16_cclo: arg2 = t.arg1; @@ -1714,6 +1893,7 @@ evap1: if NULLP(x) { /* have two arguments */ evap2: ENV_MAY_POP(envpp, CLOSUREP(proc)); + TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { case tc7_subr_2: @@ -1745,9 +1925,12 @@ evap1: apply4: if NULLP(x) goto evap2; ASRTGO(NIMP(x) && CONSP(x), badlst); - arg3 = CAR(x); - ASRTGO(0 <= ilength(x), badlst); - x = copy_list(CDR(x)); + arg3 = x; + x = copy_list(CDR(x), 0); +#ifndef RECKLESS + if UNBNDP(x) {x = arg3; goto badlst;} +#endif + arg3 = CAR(arg3); goto evap3; #ifdef CCLO case tc16_cclo: cclon: @@ -1775,15 +1958,15 @@ evap1: eval_clo_cases[2][ARGC(proc)]++; #endif switch ARGC(proc) { - case 2: + case 2: scm_env_cons2(t.arg1, arg2, EOL); goto clo_unchecked; case 1: scm_env_cons(t.arg1, cons(arg2, EOL)); goto clo_checked; - case 0: + case 0: case 3: /* Error, will be caught at clo_checked: */ - scm_env_tmp = cons2(t.arg1, arg2, EOL); + scm_env_tmp = cons2(t.arg1, arg2, EOL); goto clo_checked; } } @@ -1791,23 +1974,27 @@ evap1: { /* have 3 or more arguments */ arg3 = EVALCAR(x); x = CDR(x); - if NIMP(x) x = eval_args(x); + if NIMP(x) { + if (CLOSUREP(proc) && 3==ARGC(proc)) { + ENV_MAY_PUSH(envpp); + if (ecache_eval_args(proc, t.arg1, arg2, arg3, x)) + goto clo_unchecked; + goto umwrongnumargs; + } + x = eval_args(x); + } evap3: - ENV_MAY_POP(envpp, CLOSUREP(proc)); + ENV_MAY_POP(envpp, CLOSUREP(proc)); + TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { case tc7_subr_3: ASRTGO(NULLP(x), wrongnumargs); return SUBRF(proc)(t.arg1, arg2, arg3); case tc7_asubr: - /* t.arg1 = SUBRF(proc)(t.arg1, arg2); - while NIMP(x) { - t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env)); - x = CDR(x); - } - return t.arg1; */ case tc7_rpsubr: - return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL); + return asubr_apply(proc, t.arg1, arg2, arg3, x); + /* return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL); */ case tc7_lsubr_2: return SUBRF(proc)(t.arg1, arg2, cons(arg3, x)); case tc7_lsubr: @@ -1928,22 +2115,35 @@ SCM nconc2copy(lst) } return lst; } -/* Shallow copy */ -SCM copy_list(lst) +/* Shallow copy. If LST is not a proper list of length at least + MINLEN, returns UNDEFINED */ +SCM copy_list(lst, minlen) SCM lst; + int minlen; { SCM res, *lloc = &res; res = EOL; - for(; NIMP(lst); lst = CDR(lst)) { + for(; NIMP(lst) && CONSP(lst); lst = CDR(lst)) { *lloc = cons(CAR(lst), EOL); lloc = &CDR(*lloc); + minlen--; } + if (NULLP(lst) && minlen <= 0) + return res; + return UNDEFINED; +} +SCM scm_v2lst(n, v) + long n; + SCM *v; +{ + SCM res = EOL; + 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; { - apply_tail: ASRTGO(NIMP(proc), badproc); if NULLP(args) if NULLP(arg1) arg1 = UNDEFINED; @@ -1951,13 +2151,16 @@ SCM apply(proc, arg1, args) args = CDR(arg1); arg1 = CAR(arg1); } - else { - /* ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */ + else args = nconc2copy(args); - } cc_tail: ALLOW_INTS_EGC; switch TYP7(proc) { + default: + badproc: + wta(proc, (char *)ARG1, s_apply); + wrongnumargs: + wta(proc, (char *)WNA, s_apply); case tc7_subr_2o: if NULLP(args) { args = UNDEFINED; @@ -1992,13 +2195,16 @@ SCM apply(proc, arg1, args) wta(arg1, (char *)ARG1, CHARS(SNAME(proc))); } #endif - proc = (SCM)SNAME(proc); { - char *chrs = CHARS(proc)+LENGTH(proc)-1; - while('c' != *--chrs) { + int op = CXR_OP(proc); +#ifndef RECKLESS + args = arg1; +#endif + while (op) { ASSERT(NIMP(arg1) && CONSP(arg1), - arg1, ARG1, CHARS(proc)); - arg1 = ('a'==*chrs)?CAR(arg1):CDR(arg1); + args, ARG1, SNAME(proc)); + arg1 = (1 & op ? CAR(arg1) : CDR(arg1)); + op >>= 2; } return arg1; } @@ -2033,134 +2239,275 @@ SCM apply(proc, arg1, args) #ifndef RECKLESS if (badargsp(proc, arg1)) goto wrongnumargs; #endif - DEFER_INTS_EGC; ENV_PUSH; - TRACE(proc); + PUSH_TRACE; scm_env_tmp = arg1; scm_env = ENV(proc); - EXTEND_ENV(CAR(CODE(proc))); proc = CODE(proc); - arg1 = ceval_1(cons(IM_BEGIN, CDR(proc))); - /* while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(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; return arg1; case tc7_contin: ASRTGO(NULLP(args), wrongnumargs); - scm_dynthrow(CONT(proc), arg1); + scm_dynthrow(proc, arg1); case tc7_specfun: - switch TYP16(proc) { - case tc16_apply: - ASRTGO(!UNBNDP(arg1), wrongnumargs); - proc = arg1; - arg1 = args; - args = EOL; - goto apply_tail; - case tc16_call_cc: - ASRTGO(NULLP(args), wrongnumargs); - proc = arg1; - ASRTGO(NIMP(proc), badproc); - DEFER_INTS_EGC; - arg1 = scm_make_cont(); - EGC_ROOT(arg1); - if ((args = setjump(CONT(arg1)->jmpbuf))) { -#ifdef SHORT_INT - args = (SCM)thrown_value; + args = UNBNDP(arg1) ? EOL : cons(arg1, args); + arg1 = proc; +#ifdef CCLO + proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure); +#else + proc = f_apply_closure; +#endif + goto cc_tail; + } +} + +/* This function does not check that proc is a procedure, nor the + number of arguments, call scm_arity_check to do that. */ +SCM scm_cvapply(proc, n, argv) + SCM proc, *argv; + long n; +{ + SCM res; + long i; + tail: + ALLOW_INTS_EGC; + switch TYP7(proc) { + default: return UNSPECIFIED; + case tc7_subr_2o: + if (1==n) return SUBRF(proc)(argv[0], UNDEFINED); + /* Fall through */ + 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); + /* Fall through */ + case tc7_subr_1: + return SUBRF(proc)(argv[0]); + case tc7_cxr: +#ifdef FLOATS + if SUBRF(proc) { + if INUMP(argv[0]) + return makdbl(DSUBRF(proc)((double) INUM(argv[0])), 0.0); + ASRTGO(NIMP(argv[0]), floerr); + if REALP(argv[0]) + return makdbl(DSUBRF(proc)(REALPART(argv[0])), 0.0); +# ifdef BIGDIG + if BIGP(argv[0]) + return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0); +# endif + floerr: + wta(argv[0], (char *)ARG1, CHARS(SNAME(proc))); + } #endif - return args; + { + int op = CXR_OP(proc); + res = argv[0]; + while (op) { + ASSERT(NIMP(res) && CONSP(res), + argv[0], ARG1, SNAME(proc)); + res = (1 & op ? CAR(res) : CDR(res)); + op >>= 2; } - args = EOL; - goto cc_tail; -#ifdef CCLO - case tc16_cclo: - args = (UNBNDP(arg1) ? EOL : cons(arg1, args)); - arg1 = proc; - proc = CCLO_SUBR(proc); - goto cc_tail; + return res; + } + 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)); + case tc7_lsubr_2: + return SUBRF(proc)(argv[0], argv[1], + 2==n ? EOL : scm_v2lst(n-2, &argv[2])); + case tc7_asubr: + if (1 >= n) return SUBRF(proc)(0==n ? argv[0] : UNDEFINED, UNDEFINED); + res = argv[0]; + for (i = 1; i < n; i++) + res = SUBRF(proc)(res, argv[i]); + return res; + case tc7_rpsubr: + if (1 >= n) return BOOL_T; + 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: + ENV_PUSH; + PUSH_TRACE; + i = ARGC(proc); + if (3==i) { + scm_env_tmp = EOL; + scm_env_v2lst((int)n, argv); + } + else { + scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i]) : 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_POP; + ALLOW_INTS_EGC; + return res; + case tc7_contin: + scm_dynthrow(proc, argv[0]); + case tc7_specfun: + if (tc16_apply==TYP16(proc)) { + proc = argv[0]; + argv++; + n--; +#ifndef RECKLESS + scm_arity_check(proc, n, s_apply); #endif + goto tail; } - goto badproc; - wrongnumargs: - wta(proc, (char *)WNA, s_apply); - default: - badproc: - wta(proc, (char *)ARG1, s_apply); - return arg1; + res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv)); +#ifdef CCLO + proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure); +#else + proc = f_apply_closure; +#endif + return apply(proc, res, EOL); } } SCM map(proc, arg1, args) SCM proc, arg1, args; { - long i; - SCM res = EOL, *pres = &res; - SCM *ve; - scm_protect_temp(&args); /* Keep args from being optimized away. */ - if NULLP(arg1) return res; - ASSERT(NIMP(arg1), arg1, ARG2, s_map); - if NULLP(args) { - while NIMP(arg1) { - ASSERT(CONSP(arg1), arg1, ARG2, s_map); - *pres = cons(apply(proc, CAR(arg1), listofnull), EOL); - pres = &CDR(*pres); - arg1 = CDR(arg1); - } - return res; - } - args = vector(cons(arg1, args)); - ve = VELTS(args); + SCM res = EOL, *pres = &res; + SCM heap_ve, auto_ve[5], auto_ave[5]; + SCM *ve = auto_ve, *ave = auto_ave; + 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 - for(i = LENGTH(args)-1; i >= 0; i--) - ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARG2, s_map); -#endif - while (1) { - arg1 = EOL; - for (i = LENGTH(args)-1;i >= 0;i--) { - if IMP(ve[i]) return res; - arg1 = cons(CAR(ve[i]), arg1); - ve[i] = CDR(ve[i]); - } - *pres = cons(apply(proc, arg1, EOL), EOL); - pres = &CDR(*pres); - } + scm_arity_check(proc, n, s_map); +#endif + ASSERT(NIMP(arg1), arg1, ARG2, s_map); +#ifdef CCLO + if (tc16_cclo==TYP16(proc)) { + args = cons(arg1, args); + arg1 = cons(proc, EOL); + SETCDR(arg1, arg1); /* circular list */ + proc = CCLO_SUBR(proc); + n++; + } +#endif + if (n > 5) { + heap_ve = make_vector(MAKINUM(2*n), BOOL_F); + ve = VELTS(heap_ve); + ave = &(ve[n]); + } + ve[0] = arg1; + ASSERT(NIMP(ve[0]) && CONSP(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); + args = CDR(args); + } + while (1) { + arg1 = EOL; + for (i = n-1;i >= 0;i--) { + if IMP(ve[i]) { +#ifdef CAUTIOUS + ENV_POP; +#endif + return res; + } + ave[i] = CAR(ve[i]); + ve[i] = CDR(ve[i]); + } + *pres = cons(scm_cvapply(proc, n, ave), EOL); + pres = &CDR(*pres); + } } SCM for_each(proc, arg1, args) SCM proc, arg1, args; { - SCM *ve; - long i; - scm_protect_temp(&args); /* Keep args from being optimized away. */ - if NULLP(arg1) return UNSPECIFIED; - ASSERT(NIMP(arg1), arg1, ARG2, s_for_each); - if NULLP(args) { - while NIMP(arg1) { - ASSERT(CONSP(arg1), arg1, ARG2, s_for_each); - apply(proc, CAR(arg1), listofnull); - arg1 = CDR(arg1); - } - return UNSPECIFIED; - } - args = vector(cons(arg1, args)); - ve = VELTS(args); - while (1) { - arg1 = EOL; - for (i = LENGTH(args)-1;i >= 0;i--) { - if IMP(ve[i]) return UNSPECIFIED; - arg1 = cons(CAR(ve[i]), arg1); - ve[i] = CDR(ve[i]); - } - apply(proc, arg1, EOL); - } + SCM heap_ve, auto_ve[5], auto_ave[5]; + SCM *ve = auto_ve, *ave = auto_ave; + 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 + ASSERT(NIMP(arg1), arg1, ARG2, s_for_each); +#ifdef CCLO + if (tc16_cclo==TYP16(proc)) { + args = cons(arg1, args); + arg1 = cons(proc, EOL); + SETCDR(arg1, arg1); /* circular list */ + proc = CCLO_SUBR(proc); + n++; + } +#endif + if (n > 5) { + heap_ve = make_vector(MAKINUM(2*n), BOOL_F); + ve = VELTS(heap_ve); + ave = &(ve[n]); + } + ve[0] = arg1; + ASSERT(NIMP(ve[0]) && CONSP(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); + 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; + } + ave[i] = CAR(ve[i]); + ve[i] = CDR(ve[i]); + } + scm_cvapply(proc, n, ave); + } } /* The number of required arguments up to 3 is encoded in the cdr of the - closure. This information is used to make sure that rest args are not + closure. A value 3 means no rest argument, 3 or more required arguments. + This information is used to make sure that rest args are not allocated in the environment cache. */ SCM closure(code, argc) SCM code; int argc; { register SCM z; - if (argc > 3) argc = 3; NEWCELL(z); SETCODE(z, code); DEFER_INTS_EGC; @@ -2194,40 +2541,135 @@ static int prinprom(exp, port, writing) return !0; } +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; } +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; } +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; } +#ifdef MACRO +/* Functions for (eventual) smart expansion */ +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); + } + 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); + } + } + 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; +} +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); +} +#endif /* MACRO */ + static int prinmacro(exp, port, writing) SCM exp; SCM port; int writing; { - if (CAR(exp) & (3L<<16)) lputs("#<macro", port); - else lputs("#<syntax", port); + 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); lputc(' ', port); iprin1(CDR(exp), port, writing); @@ -2267,7 +2709,7 @@ SCM force(x) { ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force); if (!((1L<<16) & CAR(x))) { - SCM ans = apply(CDR(x), EOL, EOL); + SCM ans = scm_cvapply(CDR(x), 0L, (SCM *)0); if (!((1L<<16) & CAR(x))) { DEFER_INTS; CDR(x) = ans; @@ -2330,7 +2772,6 @@ SCM ident_eqp(id1, id2, env) SCM id1, id2, env; { SCM s1 = id1, s2 = id2, ret; - # ifndef RECKLESS if IMP(id1) badarg1: wta(id1, (char *)ARG1, s_ident_eqp); @@ -2343,10 +2784,14 @@ SCM ident_eqp(id1, id2, env) ASRTGO(SYMBOLP(s1), badarg1); ASRTGO(SYMBOLP(s2), badarg2); if (s1 != s2) return BOOL_F; - DEFER_INTS_EGC; ENV_PUSH; - scm_env = (NIMP(env) && tc16_env==CAR(env)) ? CDR(env) : env; - ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F; + 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; } @@ -2367,7 +2812,7 @@ SCM renamed_ident(id, env) SCM z; ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident); if NIMP(env) { - ASSERT(tc16_env==CAR(env), env, ARG2, s_renamed_ident); + ASSERT(ENVP(env), env, ARG2, s_renamed_ident); DEFER_INTS_EGC; env = CDR(env); } @@ -2402,7 +2847,7 @@ SCM m_atlet_syntax(xorig, env) { SCM mark; DEFER_INTS_EGC; - if (tc16_env==CAR(env)) + if (NIMP(env) && ENVP(env)) env = CDR(env); if NULLP(env) return m_let(xorig, env); mark = CAR(CAR(env)); @@ -2435,16 +2880,21 @@ SCM env2tree(env) { SCM ans, a, *lloc; if NULLP(env) return env; - ASSERT(NIMP(env) && tc16_env==CAR(env), env, ARG1, s_env2tree); - DEFER_INTS_EGC; - if IMP(CDR(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; @@ -2459,12 +2909,14 @@ SCM env2tree(env) } 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}, +/* {s_eval, eval}, now a (tail recursive) specfun */ {s_force, force}, {s_proc_doc, l_proc_doc}, {"procedure->syntax", makacro}, @@ -2482,8 +2934,20 @@ static iproc lsubr2s[] = { /* {s_apply, apply}, now explicity initted */ {s_map, map}, {s_for_each, for_each}, +#ifdef MACRO + {s_macroexpand1, scm_macroexpand1}, + {s_env_ref, scm_env_ref}, + {s_eval_syntax, scm_eval_syntax}, +#endif {0, 0}}; +static iproc subr3s[] = { +#ifdef MACRO + {s_ident_eqp, ident_eqp}, + {s_extended_env, scm_extended_env}, +#endif + {0, 0}}; + static smobfuns promsmob = {markcdr, free0, prinprom}; static smobfuns macrosmob = {markcdr, free0, prinmacro}; static smobfuns envsmob = {markcdr, free0, prinenv}; @@ -2492,19 +2956,14 @@ static smobfuns idsmob = {markcdr, free0, prinid}; #endif SCM make_synt(name, macroizer, fcn) - char *name; + const char *name; SCM (*macroizer)(); SCM (*fcn)(); { SCM symcell = sysintern(name, UNDEFINED); - long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8); - register SCM z; - if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org)) - tmp = 0; - NEWCELL(z); - SUBRF(z) = fcn; - CAR(z) = tmp + tc7_subr_2; - CDR(symcell) = macroizer(z); + SCM z = macroizer(scm_maksubr(name, tc7_subr_2, fcn)); + CAR(z) |= (4L << 16); /* Flags result as primitive macro. */ + CDR(symcell) = z; return CAR(symcell); } SCM make_specfun(name, typ) @@ -2526,11 +2985,13 @@ void init_eval() tc16_env = newsmob(&envsmob); init_iprocs(subr1s, tc7_subr_1); 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); i_dot = CAR(sysintern(".", UNDEFINED)); i_arrow = CAR(sysintern("=>", UNDEFINED)); @@ -2561,10 +3022,13 @@ void init_eval() 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)))"))); + #ifdef MACRO tc16_ident = newsmob(&idsmob); make_subr(s_renamed_ident, tc7_subr_2, renamed_ident); - make_subr(s_ident_eqp, tc7_subr_3, ident_eqp); 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. */ @@ -62,11 +62,12 @@ Wed Feb 21 23:06:35 1996 Aubrey Jaffer <jaffer@jacal.bertronics> #ifdef __amigados__ # include <stdlib.h> # include <sys/stat.h> +# include <unistd.h> #endif #ifndef __STDC__ # define const /**/ #endif -#ifdef freebsd +#ifdef __FreeBSD__ /* This might be same for 44bsd derived system. */ # include <sys/types.h> # include <sys/stat.h> @@ -77,7 +78,7 @@ Wed Feb 21 23:06:35 1996 Aubrey Jaffer <jaffer@jacal.bertronics> # include <sys/types.h> # include <sys/stat.h> #endif -#ifdef __GO32__ +#ifdef GO32 # include <sys/stat.h> #endif @@ -19,9 +19,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. +License along with this library; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place, Suite +330, Boston, MA 02111, USA. The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ @@ -252,8 +252,8 @@ extern __ptr_t (*__memalign_hook) PP ((__malloc_size_t __size, __malloc_size_t __alignment)); /* Debugging functions, added by Radey Shouman */ -int check_block __P((__malloc_size_t block, int cont)); -int check_frag_blocks __P((void)); +/* int check_block __P((__malloc_size_t block, int cont)); */ +/* int check_frag_blocks __P((void)); */ /* Return values for `mprobe': these are the kinds of inconsistencies that `mcheck' enables detection of. */ @@ -331,9 +331,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. +License along with this library; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place, Suite +330, Boston, MA 02111, USA. The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ @@ -857,9 +857,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. +License along with this library; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place, Suite +330, Boston, MA 02111, USA. The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ @@ -1166,9 +1166,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. +License along with this library; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place, Suite +330, Boston, MA 02111, USA. The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ @@ -1407,9 +1407,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. +License along with this library; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place, Suite +330, Boston, MA 02111, USA. The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ @@ -1448,7 +1448,7 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with the GNU C Library; see the file COPYING. If not, write to -the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ +the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. */ #ifndef _MALLOC_INTERNAL #define _MALLOC_INTERNAL @@ -1496,9 +1496,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. */ +License along with this library; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place, Suite +330, Boston, MA 02111, USA. */ #ifndef _MALLOC_INTERNAL #define _MALLOC_INTERNAL @@ -1595,9 +1595,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. +License along with this library; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place, Suite +330, Boston, MA 02111, USA. The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ @@ -1622,7 +1622,11 @@ Cambridge, MA 02139, USA. extern size_t __getpagesize PP ((void)); #endif #else +#ifndef hpux /* declared in <unistd.h> */ +#ifndef __svr4__ /* declared in <unistd.h> */ #include "getpagesize.h" +#endif +#endif #define __getpagesize() getpagesize() #endif @@ -1,18 +1,18 @@ /* Copyright (C) 1994, 1995, 1996 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "gsubr.c" CCLOs taking general number of required, optional, and rest args. @@ -55,7 +55,7 @@ static SCM f_gsubr_apply; SCM make_gsubr(name, req, opt, rst, fcn) - char *name; + const char *name; int req, opt, rst; SCM (*fcn)(); { @@ -71,15 +71,10 @@ SCM make_gsubr(name, req, opt, rst, fcn) default: { SCM symcell = sysintern(name, UNDEFINED); - SCM z, cclo = makcclo(f_gsubr_apply, 3L); - long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8); + SCM z = scm_maksubr(name, tc7_subr_0, fcn); + SCM cclo = makcclo(f_gsubr_apply, 3L); ASSERT(GSUBR_MAX >= req + opt + rst, MAKINUM(req + opt + rst), OUTOFRANGE, "make_gsubr"); - if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org)) - tmp = 0; - NEWCELL(z); - SUBRF(z) = fcn; - CAR(z) = tmp + tc7_subr_0; GSUBR_PROC(cclo) = z; GSUBR_TYPE(cclo) = MAKINUM(GSUBR_MAKTYPE(req, opt, rst)); CDR(symcell) = cclo; @@ -102,7 +97,7 @@ SCM gsubr_apply(args) for (i = 0; i < GSUBR_REQ(typ); i++) { #ifndef RECKLESS if IMP(args) - wnargs: wta(UNDEFINED, (char *)WNA, CHARS(SNAME(GSUBR_PROC(self)))); + wnargs: wta(UNDEFINED, (char *)WNA, SNAME(GSUBR_PROC(self))); #endif v[i] = CAR(args); args = CDR(args); @@ -0,0 +1,190 @@ +#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 +- !# +;; Copyright (C) 1991-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. + +;;;; "inc2scm", Convert numeric C #defines to Scheme definitions. +;;; Author: Aubrey Jaffer. + +(define (go-script) + (cond ((not *script*)) + ((< 1 (- (length *argv*) *optind*)) + (apply inc2scm (list-tail *argv* *optind*))) + (else + (display "\ +\ +Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ... +\ + Appends to DEFINES.SCM the Scheme translations of the numeric + #define statements in /USR/INCLUDE/FILE1.H, /USR/INCLUDE/FILE2.H, ... + + PRE: is prepended to those scheme names lacking a prefix. + + /USR/INCLUDE/ defaults to /usr/include/. +" + (current-error-port)) + (exit #f)))) + +(require 'string-search) +(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) + +;; SCHEMEIFY-NAME: +;; * Changes _ to - +;; * Changes the first - to : if it is within the first 3 characters. +;; * inserts dashes between `StudlyCaps' + +(define (schemeify-name pre name) + (define nstr (string-subst name "_" "-")) + (let ((sid (string-index nstr #\-))) + (cond ((and sid (< sid 3)) (string-set! nstr sid #\:) + nstr) + (pre (string-append pre (StudlyCaps->dashed-name nstr))) + (else (StudlyCaps->dashed-name nstr))))) + +(define (extract-defineds port) + (define sharp (string #\newline #\#)) + (define defineds '()) + (do ((find? (find-string-from-port? sharp port) + (find-string-from-port? sharp port))) + ((not find?) (reverse defineds)) + (do ((chr (read-char port) (read-char port))) + ((or (eof-object? chr) (not (char-whitespace? chr))) + (and (eqv? chr #\d) + (let ((op #f) (va #f)) + (fscanf port "efine%*[ \t]%s%*[ \t]%s" op va) + (if (and op va + (not (string-index op #\()) + (not (eqv? #\_ (string-ref op 0))) + (not (equal? "int" va))) + (set! defineds (cons op defineds))))))))) + +(define (scm<-includes scmname pre non-local? . filenames) + (define tmpprog "tmpprog") + (call-with-output-file (string-append tmpprog ".c") + (lambda (cport) + (for-each (lambda (filename) + (fprintf cport + (if non-local? + "#include <%s>\\n" + "#include \"%s\"\\n") + filename)) + filenames) + (for-each + (lambda (args) (apply fprintf cport args)) + `(("#include <stdio.h>\\n") + ("void pSl(sname, value)\\n") + (" char sname[];\\n") + (" int value;\\n") + ("{\\n") + ("%s\\n" " printf(\"(define %s %d)\\n\", sname, value);") + ("}\\n") + ("\\n") + ("int main(argc, argv)\\n") + (" int argc;\\n") + (" char *argv[];\\n") + ("{\\n") + )) + (for-each + (lambda (filename) + (if non-local? + (set! filename (string-append non-local? filename))) + (fprintf cport "/* Extract #define values from %s */\\n" filename) + (fprintf cport "%s %s%s\\n" + " printf(\";;inc2scm extracted #define values from" + filename + "\\n\");") + (for-each + (lambda (name) (fprintf cport " pSl(\"%s\", %s);\\n" + (schemeify-name pre name) name)) + (call-with-input-file filename extract-defineds))) + filenames) + (fprintf cport "}\\n"))) + (cond + ((not (zero? (system (sprintf #f "cc -o %s %s.c" tmpprog tmpprog))))) + ((not (zero? (system (sprintf #f "./%s >> %s" tmpprog scmname))))))) + +(define (scm<-usr/includes scmname . filenames) + (define pre (let ((first (car filenames))) + (cond ((substring-ci? ".h" first) #f) + (else (set! filenames (cdr filenames)) first)))) + (define include-path "/usr/include/") + (let* ((first (car filenames))) + (cond ((memv (string-ref first (+ -1 (string-length first))) '(#\\ #\/)) + (set! include-path first) + (set! filenames (cdr filenames))))) + (apply scm<-includes scmname pre include-path filenames) + (delete-file "tmpprog.c") + (delete-file "tmpprog")) +(define inc2scm scm<-usr/includes) + +(define (scm<-h* scmname . filenames) + (define pre (let ((first (car filenames))) + (cond ((substring-ci? ".h" first) first) + (else (set! filenames (cdr filenames)) #f)))) + (apply scm<-includes scmname pre #f filenames) + (delete-file "tmpprog.c") + (delete-file "tmpprog")) +(define h2scm scm<-h*) + +(go-script) + +;;; Local Variables: +;;; mode:scheme +;;; End: @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "ioext.c" code for system calls in common between PC compilers and unix. @@ -53,7 +53,7 @@ # include <stat.h> # else # include <sys/stat.h> -#endif +# endif # ifdef __TURBOC__ # include <io.h> @@ -67,7 +67,7 @@ SCM stat2scm P((struct stat *stat_temp)); #ifdef __sgi__ # include <unistd.h> #endif -#ifdef freebsd +#ifdef __FreeBSD__ # include <unistd.h> #endif /* added by Denys Duchier */ @@ -78,6 +78,9 @@ SCM stat2scm P((struct stat *stat_temp)); #ifdef linux # include <unistd.h> #endif +#ifdef GO32 +# include <unistd.h> +#endif #ifndef STDC_HEADERS int chdir P((const char *path)); @@ -211,18 +214,27 @@ SCM reopen_file(filename, modes, port) SCM filename, modes, port; { FILE *f; + 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); + flags = mode_bits(CHARS(modes), cmodes); DEFER_INTS; ASSERT(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file); - SYSCALL(f = freopen(CHARS(filename), CHARS(modes), STREAM(port));); - if (!f) port = BOOL_F; + SCM_OPENCALL(f = freopen(CHARS(filename), cmodes, STREAM(port))); + if (!f) { + ALLOW_INTS; + return BOOL_F; + } else { SETSTREAM(port, f); - if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes)))) + SCM_PORTFLAGS(port) = flags; + CAR(port) = scm_port_entry(tc16_fport, flags); + if (BUF0 & flags) i_setbuf0(port); } ALLOW_INTS; + SCM_PORTDATA(port) = filename; return port; } @@ -232,22 +244,26 @@ static char s_dup[]="duplicate-port"; SCM l_dup(oldpt, modes) SCM oldpt, modes; { + long flags; + char cmodes[4]; int tfd; FILE *f; SCM newpt; - ASSERT(NIMP(oldpt) && OPPORTP(oldpt), oldpt, ARG1, s_dup); + ASSERT(NIMP(oldpt) && OPFPORTP(oldpt), oldpt, ARG1, s_dup); ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_dup); + flags = mode_bits(CHARS(modes), cmodes); NEWCELL(newpt); DEFER_INTS; - SYSCALL(tfd = dup(fileno(STREAM(oldpt)));); + SCM_OPENCALL(tfd = dup(fileno(STREAM(oldpt)))); if (-1==tfd) {ALLOW_INTS;return BOOL_F;}; - SYSCALL(f = fdopen(tfd, CHARS(modes));); + SYSCALL(f = fdopen(tfd, cmodes);); if (!f) { close(tfd); wta(MAKINUM(tfd), (char *)NALLOC, s_port_type); } SETSTREAM(newpt, f); - if (BUF0 & (CAR(newpt) = tc16_fport | mode_bits(CHARS(modes)))) + CAR(newpt) = scm_port_entry(tc16_fport, flags); + if (BUF0 & flags) i_setbuf0(newpt); ALLOW_INTS; return newpt; @@ -258,11 +274,11 @@ SCM l_dup2(into_pt, from_pt) { int ans, oldfd, newfd; DEFER_INTS; - ASSERT(NIMP(into_pt) && OPPORTP(into_pt), into_pt, ARG1, s_dup2); - ASSERT(NIMP(from_pt) && OPPORTP(from_pt), from_pt, ARG1, s_dup2); + ASSERT(NIMP(into_pt) && OPFPORTP(into_pt), into_pt, ARG1, s_dup2); + ASSERT(NIMP(from_pt) && OPFPORTP(from_pt), from_pt, ARG1, s_dup2); oldfd = fileno(STREAM(into_pt)); newfd = fileno(STREAM(from_pt)); - SYSCALL(ans = dup2(oldfd, newfd);); + SCM_OPENCALL(ans = dup2(oldfd, newfd)); if (-1==ans) {ALLOW_INTS;return BOOL_F;}; ALLOW_INTS; return into_pt; @@ -281,7 +297,7 @@ SCM l_opendir(dirname) ASSERT(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir); NEWCELL(dir); DEFER_INTS; - SYSCALL(ds = opendir(CHARS(dirname));); + SCM_OPENCALL(ds = opendir(CHARS(dirname))); if (!ds) {ALLOW_INTS; return BOOL_F;} CAR(dir) = tc16_dir | OPN; SETCDR(dir, ds); @@ -573,11 +589,10 @@ SCM l_getpid() #ifndef __IBMC__ # ifndef macintosh # ifndef __WATCOMC__ -# ifndef GO32 -# ifndef _Windows -# ifdef __TURBOC__ -# include <process.h> -# endif +# ifndef _Windows +# ifdef __TURBOC__ +# include <process.h> +# endif char s_execv[] = "execv"; char s_execvp[] = "execvp"; SCM i_execv(modes, path, args) @@ -588,7 +603,7 @@ SCM i_execv(modes, path, args) int i = ilength(args); ASSERT(i>0, args, WNA, s_execv); ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_execv); - /* dowinds(EOL, ilength(dynwinds)); */ + /* dowinds(EOL); */ args = cons(path, args); DEFER_INTS; execargv = makargvfrmstrs(args, s_execv); @@ -626,7 +641,6 @@ SCM l_putenv(str) ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_putenv); return putenv(CHARS(str)) ? BOOL_F : BOOL_T; } -# endif # endif # endif # endif @@ -706,18 +720,40 @@ void init_ioext() #ifndef __IBMC__ # ifndef macintosh # ifndef __WATCOMC__ -# ifndef GO32 -# ifndef _Windows +# ifndef _Windows make_subr(s_execv, tc7_subr_2, lexecv); make_subr(s_execvp, tc7_subr_2, lexecvp); make_subr("execl", tc7_lsubr_2, lexec); make_subr("execlp", tc7_lsubr_2, lexecp); make_subr(s_putenv, tc7_subr_1, l_putenv); -# endif # endif # endif # endif #endif add_feature("i/o-extensions"); add_feature("line-i/o"); + scm_ldstr("\n\ +(define (directory-for-each proc dirname . args)\n\ + (define dir (opendir (if (symbol? dirname)\n\ + (symbol->string dirname)\n\ + dirname)))\n\ + (if dir\n\ + (let ((selector\n\ + (cond ((null? args) identity)\n\ + ((> (length args) 1)\n\ + (slib:error 'directory-for-each\n\ + 'too-many-arguments\n\ + (cdr args)))\n\ + ((procedure? (car args)) (car args))\n\ + ((string? (car args))\n\ + (require 'glob)\n\ + (filename:match?? (car args)))\n\ + (else (slib:error 'directory-for-each\n\ + 'unknown-selector-type\n\ + (car args))))))\n\ + (do ((filename (readdir dir) (readdir dir)))\n\ + ((not filename) (closedir dir))\n\ + (and (selector filename) (proc filename))))))\n\ +"); + add_feature("directory-for-each"); } diff --git a/mkimpcat.scm b/mkimpcat.scm index 890d521..57c29b0 100644 --- a/mkimpcat.scm +++ b/mkimpcat.scm @@ -12,7 +12,7 @@ ;; ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -75,6 +75,7 @@ (in-vicinity (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 @@ -115,6 +116,11 @@ (x:lib "X11") (usr:lib "m") (usr:lib "c")) + (add-link 'Xlib + (in-vicinity (implementation-vicinity) "x" + link:able-suffix) + (x:lib "X11") + (usr:lib "c")) (add-link 'curses (in-vicinity (implementation-vicinity) "crs" link:able-suffix) @@ -125,7 +131,7 @@ (add-link 'edit-line (in-vicinity (implementation-vicinity) "edline" link:able-suffix) - (usr:lib "edit") + (usr:lib "readline") (usr:lib "termcap") (usr:lib "c")) (add-link 'regex @@ -4,17 +4,14 @@ # 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=5c3 +VERSION=5d2 #endif #ifndef SCMVERSION -# define SCMVERSION "5c3" +# define SCMVERSION "5d2" #endif -#ifndef RTL -# ifdef nosve -# define INIT_FILE_NAME "Init5c3_scm"; -# endif -# ifndef INIT_FILE_NAME -# define INIT_FILE_NAME "Init5c3.scm" -# endif +#ifdef nosve +# define INIT_FILE_NAME "Init"SCMVERSION"_scm"; +#else +# define INIT_FILE_NAME "Init"SCMVERSION".scm" #endif @@ -12,7 +12,7 @@ * * 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -12,7 +12,7 @@ ;; ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -1,18 +1,18 @@ /* Copyright (C) 1994, 1995, 1998 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "posix.c" functions only in Posix (unix). @@ -101,15 +101,15 @@ SCM l_pipe() close(fd[0]); goto errout; } - SYSCALL(f_wt = fdopen(fd[1], "w");); + SCM_OPENCALL(f_wt = fdopen(fd[1], "w")); if (!f_wt) { fclose(f_rd); errout: close(fd[1]); wta(UNDEFINED, (char *)NALLOC, s_port_type); } - CAR(p_rd) = tc16_fport | mode_bits("r"); - CAR(p_wt) = tc16_fport | mode_bits("w"); + 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); ALLOW_INTS; @@ -128,22 +128,21 @@ SCM open_pipe(pipestr, modes) /* DEFER_INTS, SYSCALL, and ALLOW_INTS are probably paranoid here*/ DEFER_INTS; ignore_signals(); - SYSCALL(f = popen(CHARS(pipestr), CHARS(modes));); + SCM_OPENCALL(f = popen(CHARS(pipestr), CHARS(modes))); unignore_signals(); - if (!f) z = BOOL_F; + if (!f) { + ALLOW_INTS; + return BOOL_F; + } else { - CAR(z) = tc16_pipe | OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG); + CAR(z) = scm_port_entry(tc16_pipe, + OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG)); SETSTREAM(z, f); } ALLOW_INTS; + SCM_PORTDATA(z) = pipestr; return z; } -static int prinpipe(exp, port, writing) - SCM exp; SCM port; int writing; -{ - prinport(exp, port, s_pipe); - return !0; -} static char scm_s_getgroups[] = "getgroups"; SCM scm_getgroups() @@ -151,13 +150,14 @@ SCM scm_getgroups() SCM grps, ans; int ngroups = getgroups(0, 0); if (!ngroups) return BOOL_F; - NEWCELL(grps); + scm_protect_temp(&grps); DEFER_INTS; /* grps is used as a gc protect, its type used to be tc7_string, but - strings are now checked for null termination during gc. */ - grps = must_malloc_cell(ngroups * sizeof(gid_t), scm_s_getgroups); - /* length need not be exactly right */ - SETLENGTH(grps, (0L + ngroups * sizeof(gid_t))/sizeof(long), tc7_uvect); + 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); ALLOW_INTS; { gid_t *groups = (gid_t *)CHARS(grps); @@ -167,7 +167,7 @@ SCM scm_getgroups() while (--ngroups >= 0) VELTS(ans)[ngroups] = MAKINUM(groups[ngroups]); return ans; } -} +} /* These 2 routines are not protected against `entry' being reused before access to that structure is completed */ @@ -396,9 +396,9 @@ void init_posix() init_iprocs(subr2s, tc7_subr_2); init_iprocs(subr3s, tc7_subr_3); add_feature("posix"); + ptobs[0x0ff & (tc16_pipe>>8)].name = s_pipe; ptobs[0x0ff & (tc16_pipe>>8)].fclose = pclose; ptobs[0x0ff & (tc16_pipe>>8)].free = pclose; - ptobs[0x0ff & (tc16_pipe>>8)].print = prinpipe; add_feature(s_pipe); scm_ldstr("\n\ (define (open-input-pipe cmd) (open-pipe cmd \"r\"))\n\ diff --git a/r4rstest.scm b/r4rstest.scm index 35da2f4..bc3f2f7 100644 --- a/r4rstest.scm +++ b/r4rstest.scm @@ -39,7 +39,7 @@ ;;; If you are testing a R3RS version which does not have `list?' do: ;;; (define list? #f) -;;; send corrections or additions to jaffer@ai.mit.edu +;;; send corrections or additions to jaffer @ai.mit.edu (define cur-section '())(define errs '()) (define SECTION (lambda args @@ -210,6 +210,9 @@ (loop (cdr numbers) (cons (car numbers) nonneg) neg))))) +;;From: Allegro Petrofsky <Allegro@Petrofsky.Berkeley.CA.US> +(test -1 'let (let ((f -)) (let f ((n (f 1))) n))) + (SECTION 4 2 6) (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) @@ -310,6 +313,31 @@ (let ((x '#())) (test #t eq? x x)) (let ((x (lambda (x) x))) (test #t eq? x x)) +(define test-eq?-eqv?-agreement + (lambda (obj1 obj2) + (cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2))) + (else + (record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2))) + (display "eqv? and eq? disagree about ") + (write obj1) + (display #\ ) + (write obj2) + (newline))))) + +(test-eq?-eqv?-agreement '#f '#f) +(test-eq?-eqv?-agreement '#t '#t) +(test-eq?-eqv?-agreement '#t '#f) +(test-eq?-eqv?-agreement '(a) '(a)) +(test-eq?-eqv?-agreement '(a) '(b)) +(test-eq?-eqv?-agreement car car) +(test-eq?-eqv?-agreement car cdr) +(test-eq?-eqv?-agreement (list 'a) (list 'a)) +(test-eq?-eqv?-agreement (list 'a) (list 'b)) +(test-eq?-eqv?-agreement '#(a) '#(a)) +(test-eq?-eqv?-agreement '#(a) '#(b)) +(test-eq?-eqv?-agreement "abc" "abc") +(test-eq?-eqv?-agreement "abc" "abz") + (test #t equal? 'a 'a) (test #t equal? '(a) '(a)) (test #t equal? '(a (b) c) '(a (b) c)) @@ -541,6 +569,8 @@ (test f1.0 round f0.8) (test f4.0 round f3.5) (test f4.0 round f4.5) + (test 1 expt 0 0) + (test 0 expt 0 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))) @@ -561,6 +591,87 @@ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) (report-errs)) +(define (test-inexact-printing) + (let ((f0.0 (string->number "0.0")) + (f0.5 (string->number "0.5")) + (f1.0 (string->number "1.0")) + (f2.0 (string->number "2.0"))) + (define log2 + (let ((l2 (log 2))) + (lambda (x) (/ (log x) l2)))) + + (define (slow-frexp x) + (if (zero? x) + (list f0.0 0) + (let* ((l2 (log2 x)) + (e (floor (log2 x))) + (e (if (= l2 e) + (inexact->exact e) + (+ (inexact->exact e) 1))) + (f (/ x (expt 2 e)))) + (list f e)))) + + (define float-precision + (let ((mantissa-bits + (do ((i 0 (+ i 1)) + (eps f1.0 (* f0.5 eps))) + ((= f1.0 (+ f1.0 eps)) + i))) + (minval + (do ((x f1.0 (* f0.5 x))) + ((zero? (* f0.5 x)) x)))) + (lambda (x) + (apply (lambda (f e) + (let ((eps + (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits)))) + ((zero? f) minval) + (else (expt f2.0 (- e mantissa-bits)))))) + (if (zero? eps) ;Happens if gradual underflow. + minval + eps))) + (slow-frexp x))))) + + (define (float-print-test x) + (define (testit number) + (eqv? number (string->number (number->string number)))) + (let ((eps (float-precision x)) + (all-ok? #t)) + (do ((j -100 (+ j 1))) + ((or (not all-ok?) (> j 100)) all-ok?) + (let* ((xx (+ x (* j eps))) + (ok? (testit xx))) + (cond ((not ok?) + (display "Number readback failure for ") + (display `(+ ,x (* ,j ,eps))) + (newline) + (display xx) + (newline) + (set! all-ok? #f)) + ;; (else (display xx) (newline)) + ))))) + + (define (mult-float-print-test x) + (let ((res #t)) + (for-each + (lambda (mult) + (or (float-print-test (* mult x)) (set! res #f))) + (map string->number + '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100" + "0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100"))) + res)) + + (SECTION 6 5 6) + (test #t 'float-print-test (float-print-test f0.0)) + (test #t 'mult-float-print-test (mult-float-print-test f1.0)) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "3.0"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "7.0"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "3.1415926535897931"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "2.7182818284590451"))))) + (define (test-bignum) (define tb (lambda (n1 n2) @@ -569,7 +680,7 @@ (newline) (display ";testing bignums; ") (newline) - (SECTION 6 5 5) + (SECTION 6 5 7) (test 0 modulo 33333333333333333333 3) (test 0 modulo 33333333333333333333 -3) (test 0 remainder 33333333333333333333 3) @@ -598,12 +709,12 @@ (test 0 modulo -2177452800 -86400) (test #t 'remainder (tb 281474976710655325431 65535)) (test #t 'remainder (tb 281474976710655325430 65535)) - (SECTION 6 5 6) + (SECTION 6 5 8) (test 281474976710655325431 string->number "281474976710655325431") (test "281474976710655325431" number->string 281474976710655325431) (report-errs)) -(SECTION 6 5 6) +(SECTION 6 5 9) (test "0" number->string 0) (test "100" number->string 100) (test "100" number->string 256 16) @@ -1034,8 +1145,9 @@ (report-errs)) (report-errs) -(if (and (string->number "0.0") (inexact? (string->number "0.0"))) - (test-inexact)) +(cond ((and (string->number "0.0") (inexact? (string->number "0.0"))) + (test-inexact) + (test-inexact-printing))) (let ((n (string->number "281474976710655325431"))) (if (and n (exact? n)) @@ -1,18 +1,18 @@ /* Copyright (C) 1994, 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "ramap.c" Array mapping functions for APL-Scheme. @@ -65,18 +65,16 @@ typedef struct { # define IVDEP(test, line) line # endif - /* inds must be a uvect or ivect, no check. */ static sizet cind(ra, inds) - SCM ra, inds; + SCM ra; + long *inds; { sizet i; int k; - long *ve = VELTS(inds); - if (!ARRAYP(ra)) - return *ve; + if (!ARRAYP(ra)) return *inds; i = ARRAY_BASE(ra); for (k = 0; k < ARRAY_NDIM(ra); k++) - i += (ve[k] - ARRAY_DIMS(ra)[k].lbnd)*ARRAY_DIMS(ra)[k].inc; + i += (inds[k] - ARRAY_DIMS(ra)[k].lbnd)*ARRAY_DIMS(ra)[k].inc; return i; } @@ -100,8 +98,8 @@ int ra_matchp(ra0, ras) if IMP(ra0) return 0; switch TYP7(ra0) { default: return 0; - case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect: - case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect: + case tc7_vector: + case tcs_uves: s0->lbnd = 0; s0->inc = 1; s0->ubnd = (long)LENGTH(ra0) - 1; @@ -118,8 +116,8 @@ int ra_matchp(ra0, ras) switch (IMP(ra1) ? 0 : TYP7(ra1)) { default: scalar: CAR(ras) = sc2array(ra1,ra0,EOL); break; - case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect: - case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect: + case tc7_vector: + case tcs_uves: if (1 != ndim) return 0; switch (exact) { case 4: if (0 != bas0) exact = 3; @@ -132,8 +130,8 @@ int ra_matchp(ra0, ras) break; case tc7_smob: if (!ARRAYP(ra1)) goto scalar; - if (ndim != ARRAY_NDIM(ra1)) - if (0==ARRAY_NDIM(ra1)) + if (ndim != ARRAY_NDIM(ra1)) + if (0==ARRAY_NDIM(ra1)) goto scalar; else return 0; @@ -165,10 +163,8 @@ int ramapc(cproc, data, ra0, lra, what) SCM data, ra0, lra; char *what; { - SCM inds, z; - SCM vra0, ra1, vra1; + SCM z, vra0, ra1, vra1; SCM lvra, *plvra; - long *vinds; int k, kmax = (ARRAYP(ra0) ? ARRAY_NDIM(ra0) - 1 : 0); switch (ra_matchp(ra0, lra)) { default: @@ -204,73 +200,81 @@ int ramapc(cproc, data, ra0, lra, what) } return (UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)); case 1: gencase: /* Have to loop over all dimensions. */ - vra0 = make_ra(1); - if ARRAYP(ra0) { - if (kmax < 0) { - ARRAY_DIMS(vra0)->lbnd = 0; - ARRAY_DIMS(vra0)->ubnd = 0; - ARRAY_DIMS(vra0)->inc = 1; - } - else { - ARRAY_DIMS(vra0)->lbnd = ARRAY_DIMS(ra0)[kmax].lbnd; - ARRAY_DIMS(vra0)->ubnd = ARRAY_DIMS(ra0)[kmax].ubnd; - ARRAY_DIMS(vra0)->inc = ARRAY_DIMS(ra0)[kmax].inc; + { + SCM hp_indv; + long auto_indv[5]; + long *indv = &auto_indv[0]; + if (ARRAY_NDIM(ra0) >= 5) { + scm_protect_temp(&hp_indv); + hp_indv = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-1L)); + indv = (long *)VELTS(hp_indv); } - ARRAY_BASE(vra0) = ARRAY_BASE(ra0); - ARRAY_V(vra0) = ARRAY_V(ra0); - } - else { - ARRAY_DIMS(vra0)->lbnd = 0; - ARRAY_DIMS(vra0)->ubnd = LENGTH(ra0) - 1; - ARRAY_DIMS(vra0)->inc = 1; - ARRAY_BASE(vra0) = 0; - ARRAY_V(vra0) = ra0; - ra0 = vra0; - } - lvra = EOL; - plvra = &lvra; - for (z = lra; NIMP(z); z = CDR(z)) { - ra1 = CAR(z); - vra1 = make_ra(1); - ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd; - ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd; - if ARRAYP(ra1) { - if (kmax >= 0) - ARRAY_DIMS(vra1)->inc = ARRAY_DIMS(ra1)[kmax].inc; - ARRAY_V(vra1) = ARRAY_V(ra1); + vra0 = make_ra(1); + if ARRAYP(ra0) { + if (kmax < 0) { + ARRAY_DIMS(vra0)->lbnd = 0; + ARRAY_DIMS(vra0)->ubnd = 0; + ARRAY_DIMS(vra0)->inc = 1; + } + else { + ARRAY_DIMS(vra0)->lbnd = ARRAY_DIMS(ra0)[kmax].lbnd; + ARRAY_DIMS(vra0)->ubnd = ARRAY_DIMS(ra0)[kmax].ubnd; + ARRAY_DIMS(vra0)->inc = ARRAY_DIMS(ra0)[kmax].inc; + } + ARRAY_BASE(vra0) = ARRAY_BASE(ra0); + ARRAY_V(vra0) = ARRAY_V(ra0); } else { - ARRAY_DIMS(vra1)->inc = 1; - ARRAY_V(vra1) = ra1; - } - *plvra = cons(vra1, EOL); - plvra = &CDR(*plvra); - } - inds = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-1L)); - vinds = (long *)VELTS(inds); - for (k = 0; k <= kmax; k++) - vinds[k] = ARRAY_DIMS(ra0)[k].lbnd; - k = kmax; - do { - if (k==kmax) { - SCM y = lra; - ARRAY_BASE(vra0) = cind(ra0, inds); - for (z = lvra; NIMP(z); z = CDR(z), y = CDR(y)) - ARRAY_BASE(CAR(z)) = cind(CAR(y), inds); - if (0==(UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra))) - return 0; - k--; - continue; + ARRAY_DIMS(vra0)->lbnd = 0; + ARRAY_DIMS(vra0)->ubnd = LENGTH(ra0) - 1; + ARRAY_DIMS(vra0)->inc = 1; + ARRAY_BASE(vra0) = 0; + ARRAY_V(vra0) = ra0; + ra0 = vra0; } - if (vinds[k] < ARRAY_DIMS(ra0)[k].ubnd) { - vinds[k]++; - k++; - continue; + lvra = EOL; + plvra = &lvra; + for (z = lra; NIMP(z); z = CDR(z)) { + ra1 = CAR(z); + vra1 = make_ra(1); + ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd; + ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd; + if ARRAYP(ra1) { + if (kmax >= 0) + ARRAY_DIMS(vra1)->inc = ARRAY_DIMS(ra1)[kmax].inc; + ARRAY_V(vra1) = ARRAY_V(ra1); + } + else { + ARRAY_DIMS(vra1)->inc = 1; + ARRAY_V(vra1) = ra1; + } + *plvra = cons(vra1, EOL); + plvra = &CDR(*plvra); } - vinds[k] = ARRAY_DIMS(ra0)[k].lbnd - 1; - k--; - } while (k >= 0); - return 1; + for (k = 0; k <= kmax; k++) + indv[k] = ARRAY_DIMS(ra0)[k].lbnd; + k = kmax; + do { + if (k==kmax) { + SCM y = lra; + ARRAY_BASE(vra0) = cind(ra0, indv); + for (z = lvra; NIMP(z); z = CDR(z), y = CDR(y)) + ARRAY_BASE(CAR(z)) = cind(CAR(y), indv); + if (0==(UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra))) + return 0; + k--; + continue; + } + if (indv[k] < ARRAY_DIMS(ra0)[k].ubnd) { + indv[k]++; + k++; + continue; + } + indv[k] = ARRAY_DIMS(ra0)[k].lbnd - 1; + k--; + } while (k >= 0); + return 1; + } } } @@ -349,7 +353,6 @@ static int racp(src, dst) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *d = (float *)VELTS(dst); float *s = (float *)VELTS(src); @@ -373,7 +376,6 @@ static int racp(src, dst) } break; } -# endif /* SINGLES */ case tc7_dvect: { double *d = (double *)VELTS(dst); double *s = (double *)VELTS(src); @@ -544,7 +546,7 @@ SCM sc2array(s, ra, prot) case tc7_string: if ICHRP(s) break; goto mismatch; - case tc7_uvect: + case tc7_uvect: if (INUMP(s) && INUM(s)>=0) break; #ifdef BIGDIG if (NIMP(s) && tc16_bigpos==TYP16(s) && NUMDIGS(s)<=DIGSPERLONG) break; @@ -557,9 +559,7 @@ SCM sc2array(s, ra, prot) #endif goto mismatch; #ifdef FLOATS -#ifdef SINGLES case tc7_fvect: -#endif case tc7_dvect: if (NUMBERP(s) && !(NIMP(s) && CPLXP(s))) break; goto mismatch; @@ -603,14 +603,12 @@ int ra_eqp(ra0, ras) if (VELTS(ra1)[i1] != VELTS(ra2)[i2]) BVE_CLR(ra0, i0); break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) if BVE_REF(ra0, i0) if (((float *)VELTS(ra1))[i1] != ((float *)VELTS(ra2))[i2]) BVE_CLR(ra0, i0); break; -# endif /*SINGLES*/ case tc7_dvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) if BVE_REF(ra0, i0) @@ -671,7 +669,6 @@ static int ra_compare(ra0, ra1, ra2, opt) } break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) if BVE_REF(ra0, i0) @@ -680,7 +677,6 @@ static int ra_compare(ra0, ra1, ra2, opt) ((float *)VELTS(ra1))[i1] >= ((float *)VELTS(ra2))[i2]) BVE_CLR(ra0, i0); break; -# endif /*SINGLES*/ case tc7_dvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) if BVE_REF(ra0, i0) @@ -758,7 +754,6 @@ int ra_sum(ra0, ras) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *v0 = (float *)VELTS(ra0); float *v1 = (float *)VELTS(ra1); @@ -767,7 +762,6 @@ int ra_sum(ra0, ras) v0[i0] += v1[i1]); break; } -# endif /* SINGLES */ case tc7_dvect: { double *v0 = (double *)VELTS(ra0); double *v1 = (double *)VELTS(ra1); @@ -814,14 +808,12 @@ int ra_difference(ra0, ras) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *v0 = (float *)VELTS(ra0); for (; n-- > 0; i0 += inc0) v0[i0] = -v0[i0]; break; } -# endif /* SINGLES */ case tc7_dvect: { double *v0 = (double *)VELTS(ra0); for (; n-- > 0; i0 += inc0) @@ -875,7 +867,6 @@ int ra_difference(ra0, ras) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *v0 = (float *)VELTS(ra0); float *v1 = (float *)VELTS(ra1); @@ -884,7 +875,6 @@ int ra_difference(ra0, ras) v0[i0] -= v1[i1]); break; } -# endif /* SINGLES */ case tc7_dvect: { double *v0 = (double *)VELTS(ra0); double *v1 = (double *)VELTS(ra1); @@ -953,7 +943,6 @@ int ra_product(ra0, ras) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *v0 = (float *)VELTS(ra0); float *v1 = (float *)VELTS(ra1); @@ -962,7 +951,6 @@ int ra_product(ra0, ras) v0[i0] *= v1[i1]); break; } -# endif /* SINGLES */ case tc7_dvect: { double *v0 = (double *)VELTS(ra0); double *v1 = (double *)VELTS(ra1); @@ -1004,14 +992,12 @@ int ra_divide(ra0, ras) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *v0 = (float *)VELTS(ra0); for (; n-- > 0; i0 += inc0) v0[i0] = 1.0/v0[i0]; break; } -# endif /* SINGLES */ case tc7_dvect: { double *v0 = (double *)VELTS(ra0); for (; n-- > 0; i0 += inc0) @@ -1044,7 +1030,6 @@ int ra_divide(ra0, ras) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *v0 = (float *)VELTS(ra0); float *v1 = (float *)VELTS(ra1); @@ -1053,7 +1038,6 @@ int ra_divide(ra0, ras) v0[i0] /= v1[i1]); break; } -# endif /* SINGLES */ case tc7_dvect: { double *v0 = (double *)VELTS(ra0); double *v1 = (double *)VELTS(ra1); @@ -1089,34 +1073,29 @@ static int ra_identity(dst, src) static int ramap(ra0, proc, ras) SCM ra0, proc, ras; { - long i = ARRAY_DIMS(ra0)->lbnd; - long inc = ARRAY_DIMS(ra0)->inc; - long n = ARRAY_DIMS(ra0)->ubnd; - long base = ARRAY_BASE(ra0) - i*inc; - ra0 = ARRAY_V(ra0); - if NULLP(ras) - for (; i <= n; i++) - aset(ra0, apply(proc, EOL, EOL), MAKINUM(i*inc + base)); - else { - SCM ra1 = CAR(ras); - SCM args, *ve = &ras; - sizet k, i1 = ARRAY_BASE(ra1); - long inc1 = ARRAY_DIMS(ra1)->inc; - ra1 = ARRAY_V(ra1); + SCM heap_ve, auto_rav[5], auto_argv[5]; + SCM *rav = &auto_rav[0], *argv = &auto_argv[0]; + long argc = ilength(ras); + long i, k, inc, n, base; + scm_protect_temp(&heap_ve); + if (argc >= 5) { + heap_ve = make_vector(MAKINUM(2*argc), BOOL_F); + rav = VELTS(heap_ve); + argv = &(rav[n]); + } + for (k = 0; k < argc; k++) { + rav[k] = CAR(ras); ras = CDR(ras); - if NULLP(ras) - ras = nullvect; - else { - ras = vector(ras); - ve = VELTS(ras); - } - for (; i <= n; i++, i1 += inc1) { - args = EOL; - for (k = LENGTH(ras); k--;) - args = cons(aref(ve[k], MAKINUM(i)), args); - args = cons(cvref(ra1, i1, UNDEFINED), args); - aset(ra0, apply(proc, args, EOL), MAKINUM(i*inc + base)); - } + } + i = ARRAY_DIMS(ra0)->lbnd; + inc = ARRAY_DIMS(ra0)->inc; + n = ARRAY_DIMS(ra0)->ubnd; + base = ARRAY_BASE(ra0) - i*inc; + ra0 = ARRAY_V(ra0); + for (; i <= n; i++) { + for (k = 0; k < argc; k++) + argv[k] = aref(rav[k], MAKINUM(i)); + aset(ra0, scm_cvapply(proc, argc, argv), MAKINUM(i*inc + base)); } return 1; } @@ -1132,11 +1111,12 @@ static int ramap_cxr(ra0, proc, ras) ra1 = ARRAY_V(ra1); switch TYP7(ra0) { default: gencase: - for (; n-- > 0; i0 += inc0, i1 += inc1) - aset(ra0, apply(proc, RVREF(ra1, i1, e1), listofnull), MAKINUM(i0)); + for (; n-- > 0; i0 += inc0, i1 += inc1) { + e1 = cvref(ra1, i1, e1); + aset(ra0, scm_cvapply(proc, 1L, &e1), MAKINUM(i0)); + } break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *dst = (float *)VELTS(ra0); switch TYP7(ra1) { @@ -1153,7 +1133,6 @@ static int ramap_cxr(ra0, proc, ras) } break; } -# endif /* SINGLES */ case tc7_dvect: { double *dst = (double *)VELTS(ra0); switch TYP7(ra1) { @@ -1296,12 +1275,13 @@ static char s_sarray_map[] = "serial-array-map!"; SCM array_map(ra0, proc, lra) SCM ra0, proc, lra; { - int narg = ilength(lra); + long narg = ilength(lra); ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_map); tail: 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); @@ -1393,34 +1373,27 @@ SCM array_map(ra0, proc, lra) static int rafe(ra0, proc, ras) SCM ra0, proc, ras; { - long i = ARRAY_DIMS(ra0)->lbnd; - sizet i0 = ARRAY_BASE(ra0); - long inc0 = ARRAY_DIMS(ra0)->inc; - long n = ARRAY_DIMS(ra0)->ubnd; - ra0 = ARRAY_V(ra0); - if NULLP(ras) - for (; i <= n; i++, i0 += inc0) - apply(proc, cvref(ra0, i0, UNDEFINED), listofnull); - else { - SCM ra1 = CAR(ras); - SCM args, *ve = &ras; - sizet k, i1 = ARRAY_BASE(ra1); - long inc1 = ARRAY_DIMS(ra1)->inc; - ra1 = ARRAY_V(ra1); + SCM heap_ve, auto_rav[5], auto_argv[5]; + SCM *rav = &auto_rav[0], *argv = &auto_argv[0]; + long argc = ilength(ras) + 1; + long i, k, inc, n, base; + scm_protect_temp(&heap_ve); + if (argc >= 5) { + heap_ve = make_vector(MAKINUM(2*argc), BOOL_F); + rav = VELTS(heap_ve); + argv = &(rav[n]); + } + rav[0] = ra0; + for (k = 1; k < argc; k++) { + rav[k] = CAR(ras); ras = CDR(ras); - if NULLP(ras) - ras = nullvect; - else { - ras = vector(ras); - ve = VELTS(ras); - } - for (; i <= n; i++, i0 += inc0, i1 += inc1) { - args = EOL; - for (k = LENGTH(ras); k--;) - args = cons(aref(ve[k], MAKINUM(i)), args); - args = cons2(cvref(ra0, i0, UNDEFINED), cvref(ra1, i1, UNDEFINED), args); - apply(proc, args, EOL); - } + } + i = ARRAY_DIMS(ra0)->lbnd; + n = ARRAY_DIMS(ra0)->ubnd; + for (; i <= n; i++) { + for (k = 0; k < argc; k++) + argv[k] = aref(rav[k], MAKINUM(i)); + scm_cvapply(proc, argc, argv); } return 1; } @@ -1428,8 +1401,12 @@ static char s_array_for_each[] = "array-for-each"; 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); +#endif switch TYP7(proc) { default: gencase: ramapc(rafe, proc, ra0, lra, s_array_for_each); @@ -1440,6 +1417,7 @@ SCM array_for_each(proc, ra0, lra) lra = cons(ra0, lra); ra0 = sc2array(proc, ra0, EOL); proc = CCLO_SUBR(proc); + narg++; goto tail; } goto gencase; @@ -1451,53 +1429,68 @@ static char s_array_imap[] = "array-index-map!"; SCM array_imap(ra, proc) SCM ra, proc; { + SCM hp_av, hp_indv, auto_av[5]; + SCM *av = &auto_av[0]; + long auto_indv[5]; + 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); +#endif + if (i >= 5) { + scm_protect_temp(&hp_av); + scm_protect_temp(&hp_indv); + hp_av = make_vector(MAKINUM(i), BOOL_F); + av = VELTS(hp_av); + hp_indv = make_uve(i+0L, MAKINUM(-1L)); + indv = (long *)VELTS(hp_indv); + } switch TYP7(ra) { default: badarg: wta(ra, (char *)ARG1, s_array_imap); - case tc7_vector: - { - SCM *ve = VELTS(ra); - for (i = 0; i < LENGTH(ra); i++) - ve[i] = apply(proc, MAKINUM(i), listofnull); - return UNSPECIFIED; + case tc7_vector: { + SCM *ve = VELTS(ra); + for (i = 0; i < LENGTH(ra); i++) { + av[0] = MAKINUM(i); + ve[i] = scm_cvapply(proc, 1L, av); + } + return UNSPECIFIED; + } + case tcs_uves: + for (i = 0; i < LENGTH(ra); i++) { + av[0] = MAKINUM(i); + aset(ra, scm_cvapply(proc, 1L, auto_av), MAKINUM(i)); } - case tc7_string: case tc7_bvect: case tc7_uvect: case tc7_ivect: - case tc7_fvect: case tc7_dvect: case tc7_cvect: - for (i = 0; i < LENGTH(ra); i++) - aset(ra, apply(proc, MAKINUM(i), listofnull), MAKINUM(i)); return UNSPECIFIED; case tc7_smob: ASRTGO(ARRAYP(ra), badarg); { - SCM args = EOL; - SCM inds = make_uve(ARRAY_NDIM(ra)+0L, MAKINUM(-1L)); - long *vinds = VELTS(inds); int j, k, kmax = ARRAY_NDIM(ra) - 1; if (kmax < 0) return aset(ra, apply(proc, EOL, EOL), EOL); for (k = 0; k <= kmax; k++) - vinds[k] = ARRAY_DIMS(ra)[k].lbnd; + indv[k] = ARRAY_DIMS(ra)[k].lbnd; k = kmax; do { if (k==kmax) { - vinds[k] = ARRAY_DIMS(ra)[k].lbnd; - i = cind(ra, inds); - for (; vinds[k] <= ARRAY_DIMS(ra)[k].ubnd; vinds[k]++) { - for (j = kmax+1, args = EOL; j--;) - args = cons(MAKINUM(vinds[j]), args); - aset(ARRAY_V(ra), apply(proc, args, EOL), MAKINUM(i)); + indv[k] = ARRAY_DIMS(ra)[k].lbnd; + i = cind(ra, indv); + for (; indv[k] <= ARRAY_DIMS(ra)[k].ubnd; indv[k]++) { + for (j = kmax+1; j--;) + av[j] = MAKINUM(indv[j]); + aset(ARRAY_V(ra), scm_cvapply(proc, kmax+1L, av), MAKINUM(i)); i += ARRAY_DIMS(ra)[k].inc; } k--; continue; } - if (vinds[k] < ARRAY_DIMS(ra)[k].ubnd) { - vinds[k]++; + if (indv[k] < ARRAY_DIMS(ra)[k].ubnd) { + indv[k]++; k++; continue; } - vinds[k] = ARRAY_DIMS(ra)[k].lbnd - 1; + indv[k] = ARRAY_DIMS(ra)[k].lbnd - 1; k--; } while (k >= 0); return UNSPECIFIED; @@ -1556,7 +1549,6 @@ static int raeql_1(ra0, as_equal, ra1) return 1; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *v0 = (float *)VELTS(ra0) + i0; float *v1 = (float *)VELTS(ra1) + i1; @@ -1564,7 +1556,6 @@ static int raeql_1(ra0, as_equal, ra1) if (*v0 != *v1) return 0; return 1; } -# endif /* SINGLES */ case tc7_dvect: { double *v0 = (double *)VELTS(ra0) + i0; double *v1 = (double *)VELTS(ra1) + i1; @@ -1634,16 +1625,14 @@ SCM array_equal(ra0, ra1) callequal: return equal(ra0, ra1); switch TYP7(ra0) { default: goto callequal; - case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: - case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: - break; + case tc7_vector: + case tcs_uves: break; case tc7_smob: if (!ARRAYP(ra0)) goto callequal; } switch TYP7(ra1) { default: goto callequal; - case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: - case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: - break; + case tc7_vector: + case tcs_uves: break; case tc7_smob: if (!ARRAYP(ra1)) goto callequal; } return (raeql(ra0, BOOL_F, ra1) ? BOOL_T : BOOL_F); @@ -1672,7 +1661,7 @@ static void init_raprocs(subra) ra_iproc *subra; { for(; subra->name; subra++) - subra->sproc = CDR(intern(subra->name, strlen(subra->name))); + subra->sproc = CDR(sysintern(subra->name, UNDEFINED)); } void init_ramap() @@ -1685,4 +1674,10 @@ void init_ramap() make_subr(s_array_equalp, tc7_rpsubr, array_equal); smobs[0x0ff & (tc16_array>>8)].equalp = raequal; add_feature(s_array_for_each); +scm_ldstr("\n\ +(define (array-indexes ra)\n\ + (let ((ra0 (apply make-array '() (array-shape ra))))\n\ + (array-index-map! ra0 list)\n\ + ra0))\n\ +"); } @@ -1,18 +1,18 @@ /* Copyright (C) 1994, 1995, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,50 +36,33 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "record.c" code for (R5RS) proposed "Record" user definable datatypes. Author: Radey Shouman */ #include "scm.h" - -typedef struct { - SCM rtd; - SCM name; - SCM fields; -} rtd_type; - -typedef union { - struct { - SCM proc; - SCM rtd; - } pred; - struct { - SCM proc; - SCM rtd; - SCM index; - } acc; - struct { - SCM proc; - SCM rtd; - SCM recsize; - SCM indices; - } constr; -} rec_cclo; - long tc16_record; /* Record-type-descriptor for record-type-descriptors */ static SCM the_rtd_rtd; -/* Record <= [rtd, ... elts ... ] */ +/* Record <= [rtd, elt ... ] + RTD <= [rtd, name, (field ...), printer] + Predicate <= [cclo-procedure, rtd] + Accessor, Modifier <= [cclo-procedure, rtd, index] + Constructor <= [cclo-procedure, rtd, record-size, #(index ...)] */ #define REC_RTD(x) (VELTS(x)[0]) #define RECP(x) (tc16_record==TYP16(x)) #define RTDP(x) (RECP(x) && the_rtd_rtd==REC_RTD(x)) -#define RTD_NAME(x) (((rtd_type *)CDR(x))->name) -#define RTD_FIELDS(x) (((rtd_type *)CDR(x))->fields) -#define RCLO_RTD(x) (((rec_cclo *)CDR(x))->pred.rtd) +#define RTD_NAME(x) (VELTS(x)[1]) +#define RTD_FIELDS(x) (VELTS(x)[2]) +#define RTD_PRINTER(x) (VELTS(x)[3]) +#define RCLO_RTD(x) (VELTS(x)[1]) +#define RCLO_INDEX(x) (VELTS(x)[2]) /* For accessors, modifiers */ +#define RCONSTR_SIZE(x) (VELTS(x)[2]) +#define RCONSTR_INDICES(x) (VELTS(x)[3]) /* If we are compiling this as a dll, then we cannot assume that arrays will be available when the dll is loaded */ @@ -103,7 +86,6 @@ SCM recordp(obj) { return (NIMP(obj) && RECP(obj) ? BOOL_T : BOOL_F); } -static char s_rec_pred1[] = " record-predicate-procedure"; SCM rec_pred1(cclo, obj) SCM cclo, obj; { @@ -136,58 +118,80 @@ SCM rec_constr(rtd, flds) SCM rtd, flds; { SCM flst, fld; - SCM cclo = makcclo(f_rec_constr1, (long)sizeof(rec_cclo)/sizeof(SCM)); - rec_cclo *ptr = (rec_cclo *)CDR(cclo); + SCM cclo = makcclo(f_rec_constr1, 4L); + SCM indices; sizet i, j; ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_constr); - ptr->constr.rtd = rtd; + RCLO_RTD(cclo) = rtd; i = ilength(RTD_FIELDS(rtd)); - ptr->constr.recsize = MAKINUM(i); + RCONSTR_SIZE(cclo) = MAKINUM(i); if UNBNDP(flds) { - ptr->constr.indices = MAKE_REC_INDS(i); - while (i--) - REC_IND_SET(ptr->constr.indices, i, i+1); + indices = MAKE_REC_INDS(i); + while (i--) REC_IND_SET(indices, i, i+1); } else { ASSERT(NIMP(flds) && CONSP(flds), flds, ARG2, s_rec_constr); - ptr->constr.indices = MAKE_REC_INDS(ilength(flds)); + indices = MAKE_REC_INDS(ilength(flds)); 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)) { if (fld==CAR(flst)) { - REC_IND_SET(ptr->constr.indices, i, j+1); + REC_IND_SET(indices, i, j+1); break; } ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr); } } } + RCONSTR_INDICES(cclo) = indices; return cclo; } -static char s_rec_constr1[] = " record-constructor-procedure"; +#ifndef RECKLESS +static void rec_error(arg, pos, what, rtd, i) + SCM arg, rtd; + int i; + char *pos, *what; +{ + SCM recname = RTD_NAME(rtd); + SCM fld = RTD_FIELDS(rtd); + SCM mesg = makfrom0str(what); + if (i > 0) { + while (--i) fld = CDR(fld); + fld = CAR(fld); + mesg = st_append(cons2(mesg, recname, + cons2(makfrom0str(" -> "), symbol2string(fld), EOL))); + } + else + mesg = st_append(cons2(mesg, recname, EOL)); + everr(UNDEFINED, EOL, arg, pos, CHARS(mesg)); +} +#endif +static char s_rec_constr1[] = "record constructor: "; SCM rec_constr1(args) SCM args; { SCM cclo = CAR(args); - SCM rec, inds = (((rec_cclo *)CDR(cclo))->constr.indices); - sizet i = INUM(((rec_cclo *)CDR(cclo))->constr.recsize); + SCM rec, inds = RCONSTR_INDICES(cclo); + sizet i = INUM(RCONSTR_SIZE(cclo)); args = CDR(args); DEFER_INTS; - rec = must_malloc_cell((i+1L)*sizeof(SCM), s_record); - SETNUMDIGS(rec, i+1L, tc16_record); - ALLOW_INTS; + rec = must_malloc_cell((i+1L)*sizeof(SCM), + MAKE_NUMDIGS(i+1L, tc16_record), s_record); while (i--) VELTS(rec)[i+1] = UNSPECIFIED; REC_RTD(rec) = RCLO_RTD(cclo); + ALLOW_INTS; for (i = 0; i < LENGTH(inds); i++, args = CDR(args)) { - ASSERT(NNULLP(args), UNDEFINED, WNA, s_rec_constr1); +#ifndef RECKLESS + if (NULLP(args)) + wna: rec_error(UNDEFINED, WNA, s_rec_constr1, RCLO_RTD(cclo), -1); +#endif VELTS(rec)[ REC_IND_REF(inds, i) ] = CAR(args); } - ASSERT(NULLP(args), UNDEFINED, WNA, s_rec_constr1); + ASRTGO(NULLP(args), wna); return rec; - } /* Makes an accessor or modifier. @@ -199,7 +203,7 @@ static SCM makrecclo(proc, rtd, field, what) SCM flst; SCM cclo = makcclo(proc, 3L); int i; - ASSERT(RTDP(rtd), rtd, ARG1, what); + ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, what); ASSERT(NIMP(field) && SYMBOLP(field), field, ARG2, what); RCLO_RTD(cclo) = rtd; flst = RTD_FIELDS(rtd); @@ -208,24 +212,30 @@ static SCM makrecclo(proc, rtd, field, what) if (CAR(flst)==field) break; flst = CDR(flst); } - (((rec_cclo *)CDR(cclo))->acc.index) = MAKINUM(i); + RCLO_INDEX(cclo) = MAKINUM(i); return cclo; } -static char s_rec_accessor1[] = " record-accessor-procedure"; +static char s_rec_accessor1[] = "record accessor: "; SCM rec_accessor1(cclo, rec) SCM cclo, rec; { - ASSERT(NIMP(rec) && RECP(rec), rec, ARG1, s_rec_accessor1); - ASSERT(RCLO_RTD(cclo)==REC_RTD(rec), rec, ARG1, s_rec_accessor1); - return VELTS(rec)[ INUM(((rec_cclo *)CDR(cclo))->acc.index) ]; + register int i = INUM(RCLO_INDEX(cclo)); +#ifndef RECKLESS + if (IMP(rec) || !RECP(rec) || RCLO_RTD(cclo)!=REC_RTD(rec)) + rec_error(rec, ARG1, s_rec_accessor1, RCLO_RTD(cclo), i); +#endif + return VELTS(rec)[i]; } -static char s_rec_modifier1[] = " record-modifier-procedure"; +static char s_rec_modifier1[] = "record modifier: "; SCM rec_modifier1(cclo, rec, val) SCM cclo, rec, val; { - ASSERT(NIMP(rec) && RECP(rec), rec, ARG1, s_rec_modifier1); - ASSERT(RCLO_RTD(cclo)==REC_RTD(rec), rec, ARG1, s_rec_modifier1); - VELTS(rec)[ INUM(((rec_cclo *)CDR(cclo))->acc.index) ] = val; + register int i = INUM(RCLO_INDEX(cclo)); +#ifndef RECKLESS + if (IMP(rec) || !RECP(rec) || RCLO_RTD(cclo)!=REC_RTD(rec)) + rec_error(rec, ARG1, s_rec_modifier1, RCLO_RTD(cclo), i); +#endif + VELTS(rec)[i] = val; return UNSPECIFIED; } static SCM f_rec_accessor1; @@ -242,28 +252,38 @@ SCM rec_modifier(rtd, field) { return makrecclo(f_rec_modifier1, rtd, field, s_rec_accessor); } - -static char s_makrectyp[] = "make-record-type"; SCM *loc_makrtd; +static char s_makrectyp[] = "make-record-type"; SCM makrectyp(name, fields) SCM name, fields; { - SCM n; + SCM n, argv[2]; #ifndef RECKLESS if(ilength(fields) < 0) errout: wta(fields, (char *)ARG2, s_makrectyp); for (n=fields; NIMP(n); n = CDR(n)) if (!SYMBOLP(CAR(n))) goto errout; #endif - return apply(*loc_makrtd, name, cons(fields, listofnull)); + argv[0] = name; + argv[1] = fields; + return scm_cvapply(*loc_makrtd, 2L, argv); +} + +static char s_rec_prinset[] = "record-printer-set!"; +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), + printer, ARG2, s_rec_prinset); + RTD_PRINTER(rtd) = printer; + return UNSPECIFIED; } static SCM markrec(ptr) SCM ptr; { sizet i; - if GC8MARKP(ptr) return BOOL_F; - SETGC8MARK(ptr); for (i = NUMDIGS(ptr); --i;) if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]); return REC_RTD(ptr); @@ -272,14 +292,21 @@ static sizet freerec(ptr) CELLPTR ptr; { must_free(CHARS(ptr), sizeof(SCM)*NUMDIGS(ptr)); - return sizeof(SCM)*NUMDIGS(ptr); + return 0; } static int recprin1(exp, port, writing) SCM exp, port; int writing; { - SCM names = RTD_FIELDS(REC_RTD(exp)); + SCM names, printer = RTD_PRINTER(REC_RTD(exp)); sizet i; + if NIMP(printer) { + SCM argv[2]; + argv[0] = exp; + argv[1] = port; + return scm_cvapply(printer, 2L, argv); + } + names = RTD_FIELDS(REC_RTD(exp)); lputs("#s(", port); iprin1(RTD_NAME(REC_RTD(exp)), port, 0); for (i = 1; i < NUMDIGS(exp); i++) { @@ -323,23 +350,26 @@ static iproc subr2s[] = { {s_rec_accessor, rec_accessor}, {s_rec_modifier, rec_modifier}, {s_makrectyp, makrectyp}, + {s_rec_prinset, rec_prinset}, {0, 0}}; -static char s_name[] = "name"; -static char s_fields[] = "fields"; void init_record() { - SCM i_name = CAR(intern(s_name, (sizeof s_name)-1)); - SCM i_fields = CAR(intern(s_fields, (sizeof s_fields)-1)); + SCM i_name = CAR(sysintern("name", UNDEFINED)); + SCM i_fields = CAR(sysintern("fields", UNDEFINED)); + SCM i_printer = CAR(sysintern("printer", UNDEFINED)); + SCM the_rtd, rtd_name = makfrom0str("record-type"); + SCM rtd_fields = cons2(i_name, i_fields, cons(i_printer, EOL)); tc16_record = newsmob(&recsmob); DEFER_INTS; - the_rtd_rtd = must_malloc_cell((long)sizeof(rtd_type), s_record); - SETNUMDIGS(the_rtd_rtd, (long)sizeof(rtd_type)/sizeof(SCM), tc16_record); + 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; ALLOW_INTS; - REC_RTD(the_rtd_rtd) = the_rtd_rtd; - RTD_NAME(the_rtd_rtd) = makfromstr(s_record, (sizeof s_record)-1); - RTD_FIELDS(the_rtd_rtd) = cons2(i_name, i_fields, EOL); - sysintern("record:rtd", the_rtd_rtd); - f_rec_pred1 = make_subr(s_rec_pred1, tc7_subr_2, rec_pred1); + the_rtd_rtd = the_rtd; /* Protected by make-record-type */ + f_rec_pred1 = make_subr(" record-predicate-procedure", tc7_subr_2, rec_pred1); f_rec_constr1 = make_subr(s_rec_constr1, tc7_lsubr, rec_constr1); f_rec_accessor1 = make_subr(s_rec_accessor1, tc7_subr_2, rec_accessor1); f_rec_modifier1 = make_subr(s_rec_modifier1, tc7_subr_3, rec_modifier1); @@ -349,6 +379,7 @@ void init_record() sysintern("record-type-descriptor?", rec_pred(the_rtd_rtd)); sysintern("record-type-name", rec_accessor(the_rtd_rtd, i_name)); sysintern("record-type-field-names", rec_accessor(the_rtd_rtd, i_fields)); - loc_makrtd = &CDR(sysintern("RTD:make", rec_constr(the_rtd_rtd, UNDEFINED))); + loc_makrtd = &CDR(sysintern("RTD:make", + rec_constr(the_rtd_rtd, cons2(i_name, i_fields, EOL)))); add_feature(s_record); } @@ -1,18 +1,18 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998 Free Software Foundation, Inc. - * +/* Copyright (C) 1990-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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "repl.c" error, read-eval-print loop, read, write and load code. @@ -47,6 +47,11 @@ void igc P((char *what, STACKITEM *stackbase)); void unexec P((char *new_name, char *a_name, unsigned data_start, unsigned bss_start, unsigned entry_address)); +void scm_fill_freelist P((void)); + +#ifdef __CYGWIN32__ +# include <sys/types.h> +#endif #ifdef ARM_ULIB # include <termio.h> @@ -74,8 +79,6 @@ void init_tables() upcase[lowers[i]] = uppers[i]; downcase[uppers[i]] = lowers[i]; } - scm_verbose = 1; /* Here so that monitor info won't be */ - /* printed while in init_storage. (BOOM) */ } #ifdef EBCDIC @@ -130,6 +133,7 @@ char *isymnames[] = { static char s_read_char[] = "read-char", s_peek_char[] = "peek-char"; char s_read[] = "read", s_write[] = "write", s_newline[] = "newline"; static char s_display[] = "display", s_write_char[] = "write-char"; +static char s_freshline[] = "freshline"; static char s_eofin[] = "end of file in "; static char s_unknown_sharp[] = "unknown # object"; @@ -282,16 +286,13 @@ taloop: lputc(')', port); break; case tc7_bvect: - case tc7_ivect: - case tc7_uvect: - case tc7_fvect: - case tc7_dvect: - case tc7_cvect: + case tc7_ivect: case tc7_uvect: case tc7_svect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: raprin1(exp, port, writing); break; case tcs_subrs: lputs("#<primitive-procedure ", port); - lputs(CHARS(SNAME(exp)), port); + lputs(SNAME(exp), port); lputc('>', port); break; case tc7_specfun: @@ -299,6 +300,8 @@ taloop: if (tc16_cclo==TYP16(exp)) { lputs("#<compiled-closure ", port); iprin1(CCLO_SUBR(exp), port, writing); + lputc(' ', port); + iprin1(VELTS(exp)[1], port, writing); lputc('>', port); break; } @@ -316,8 +319,13 @@ taloop: break; case tc7_port: i = PTOBNUM(exp); - if (i<numptob && ptobs[i].print && (ptobs[i].print)(exp, port, writing)) + if (i<numptob) { + if (ptobs[i].print && (ptobs[i].print)(exp, port, writing)) + ; + else + prinport(exp, port, ptobs[i].name ? ptobs[i].name : "unknown"); break; + } goto punk; case tc7_smob: i = SMOBNUM(exp); @@ -329,17 +337,14 @@ taloop: } } -#ifndef GO32 static char s_char_readyp[]="char-ready?"; -#endif #ifdef __IBMC__ # define MSDOS #endif #ifdef MSDOS -# ifndef GO32 -# include <io.h> -# include <conio.h> +# include <io.h> +# include <conio.h> static int input_waiting(f) FILE *f; { @@ -347,7 +352,6 @@ static int input_waiting(f) if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin)))) return kbhit(); return -1; } -# endif #else # ifdef _DCC # include <ioctl.h> @@ -367,10 +371,8 @@ static int input_waiting(f) # endif # endif -# ifdef HAVE_SELECT -# ifdef HAVE_SYS_TIME_H -# include <sys/time.h> -# endif +# ifdef HAVE_SYS_TIME_H +# include <sys/time.h> # endif static int input_waiting(f) @@ -402,16 +404,115 @@ static int input_waiting(f) } #endif /* perhaps should undefine MSDOS from __IBMC__ here */ -#ifndef GO32 SCM char_readyp(port) SCM port; { if UNBNDP(port) port = cur_inp; else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp); - if (CRDYP(port) || !(BUF0 & CAR(port))) return BOOL_T; + if (CRDYP(port) || !(BUF0 & SCM_PORTFLAGS(port))) return BOOL_T; return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F; } + +#ifdef GO32 +# include <pc.h> +#endif +#ifndef HAVE_SELECT +# include <time.h> +#endif +#ifdef __STDC__ +# define timet time_t +#else +# define timet long +#endif +static char s_wfi[] = "wait-for-input"; +SCM wait_for_input(args) + SCM args; +{ + SCM how_long, port1, port, ports, ans = EOL; + int timeout, pos = ARG2; + ASSERT(!NULLP(args), INUM0, WNA, s_wfi); + how_long = CAR(args); + args = CDR(args); + if NULLP(args) port1 = cur_inp; + else { + port1 = CAR(args); + args = CDR(args); + } + timeout = num2long(how_long, (char *)ARG1, s_wfi); + ASSERT(timeout >= 0, how_long, ARG1, s_wfi); + port = port1; + ports = args; + while (1) { + ASSERT(NIMP(port) && OPINPORTP(port) && (BUF0 & SCM_PORTFLAGS(port)), + port, pos, s_wfi); + if (CRDYP(port) || feof(STREAM(port))) timeout = 0; + if (NULLP(ports)) break; + if (ARG5 <= pos) pos = ARGn; + else if (ARG1 < pos) pos = 1 + pos; + port = CAR(ports); + ports = CDR(ports); + } + { +#ifdef HAVE_SELECT + fd_set ifds; + struct timeval tv; + int ret, fd_max = 0; + + tv.tv_sec = timeout; + tv.tv_usec = 0; + + FD_ZERO(&ifds); + port = port1; + ports = args; + while (1) { + int fd = fileno(STREAM(port)); + FD_SET(fd, &ifds); + if (fd_max < fd) fd_max = fd; + + if (NULLP(ports)) break; + port = CAR(ports); + ports = CDR(ports); + } + SYSCALL(ret = select(fd_max + 1, &ifds, (fd_set *)0L, (fd_set *)0L, &tv);); + ASSERT(ret>=0, MAKINUM(ret), "select error", s_wfi); + + port = port1; + ports = args; + while (1) { + if (FD_ISSET(fileno(STREAM(port)), &ifds) + || CRDYP(port) || feof(STREAM(port))) + ans = cons(port, ans); + if (NULLP(ports)) break; + port = CAR(ports); + ports = CDR(ports); + } +#else + timet start = 0; + time(&start); + start = start + timeout; + port = port1; + ports = args; + do { + FILE *f = STREAM(port); + if (feof(f)) ans = cons(port, ans); + else { +# ifdef FIONREAD + long remir; + ioctl(fileno(f), FIONREAD, &remir); + if (remir) ans = cons(port, ans); +# else + if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin))) && kbhit()) + ans = cons(port, ans); +# endif + if (NULLP(ports)) break; + port = CAR(ports); + ports = CDR(ports); + } + } while (time((timet*)0L) < start); #endif + return NULLP(ans) ? BOOL_F : ans; + } +} SCM eof_objectp(x) SCM x; @@ -493,22 +594,21 @@ SCM write_char(chr, port) #endif return UNSPECIFIED; } - -FILE *trans = 0; -SCM trans_on(fil) - SCM fil; -{ - transcript = try_open_file(fil, makfromstr("w", (sizet)sizeof(char))); - if FALSEP(transcript) trans = 0; - else trans = STREAM(transcript); - return UNSPECIFIED; -} -SCM trans_off() +SCM scm_freshline(port) + SCM port; { - if (!FALSEP(transcript)) close_port(transcript); - transcript = BOOL_F; - trans = 0; - return UNSPECIFIED; + if UNBNDP(port) port = cur_outp; + 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); + return UNSPECIFIED; } void lputc(c, port) @@ -517,8 +617,17 @@ void lputc(c, port) { sizet i = PTOBNUM(port); SYSCALL((ptobs[i].fputc)(c, STREAM(port));); - if (trans && (port==def_outp || port==cur_errp)) - SYSCALL(fputc(c, trans);); + if (CRDY & CAR(port)) { + i = SCM_PORTNUM(port); + switch (c) { + case LINE_INCREMENTORS: + scm_port_table[i].line++; + scm_port_table[i].col = 0; + break; + default: + scm_port_table[i].col++; + } + } } void lputs(s, port) char *s; @@ -527,21 +636,44 @@ void lputs(s, port) sizet i = PTOBNUM(port); ASSERT(s, INUM0, ARG1, "lputs"); SYSCALL((ptobs[i].fputs)(s, STREAM(port));); - if (trans && (port==def_outp || port==cur_errp)) - SYSCALL(fputs(s, trans);); + if (CRDY & CAR(port)) { + sizet j; + i = SCM_PORTNUM(port); + for (j = 0; s[j]; j++) { + switch (s[j]) { + case LINE_INCREMENTORS: + scm_port_table[i].line++; + scm_port_table[i].col = 0; + break; + default: + scm_port_table[i].col++; + } + } + } } -int lfwrite(ptr, size, nitems, port) +sizet lfwrite(ptr, size, nitems, port) char *ptr; sizet size; sizet nitems; SCM port; { - int ret; - sizet i = PTOBNUM(port); + sizet ret, i = PTOBNUM(port); SYSCALL(ret = (ptobs[i].fwrite) (ptr, size, nitems, STREAM(port));); - if (trans && (port==def_outp || port==cur_errp)) - SYSCALL(fwrite(ptr, size, nitems, trans);); + if (CRDY & CAR(port)) { + sizet j; + i = SCM_PORTNUM(port); + for (j = 0; j < ret*size; j++) { + switch (ptr[j]) { + case LINE_INCREMENTORS: + scm_port_table[i].line++; + scm_port_table[i].col = 0; + break; + default: + scm_port_table[i].col++; + } + } + } return ret; } @@ -550,22 +682,34 @@ int lgetc(port) { FILE *f; int c; - sizet i; - /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */ - if CRDYP(port) - { - c = CGETUN(port); - CLRDY(port); /* Clear ungetted char */ + sizet i, j; + if (CRDY & CAR(port)) { + j = SCM_PORTNUM(port); + c = scm_port_table[j].unread; + if (c != EOF) { + scm_port_table[j].unread = EOF; + CAR(port) &= (scm_port_table[j].flags | (~0xf0000)); /* CLRDY(port) */ return c; } - f=STREAM(port); + } + f = STREAM(port); i = PTOBNUM(port); #ifdef linux c = (ptobs[i].fgetc)(f); #else SYSCALL(c = (ptobs[i].fgetc)(f);); #endif - if (trans && (f==stdin)) SYSCALL(fputc(c, trans);); + if (CRDY & CAR(port)) { /* CRDY 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; + break; + default: + scm_port_table[j].col++; + } + } return c; } void lungetc(c, port) @@ -573,7 +717,8 @@ void lungetc(c, port) SCM port; { /* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/ - CUNGET(c, port); + scm_port_table[SCM_PORTNUM(port)].unread = c; + CAR(port) |= CRDY; } SCM scm_read_char(port) @@ -617,7 +762,7 @@ static int flush_ws(port) case EOF: return c; case LINE_INCREMENTORS: break; } - case LINE_INCREMENTORS: if (port==loadport) linum++; + case LINE_INCREMENTORS: case WHITE_SPACES: break; case EOF: default: @@ -639,6 +784,7 @@ SCM lread(port) } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port))); return tok_buf; } +static SCM *loc_readsharp = 0, *loc_readsharpc = 0; static SCM lreadpr(tok_buf, port) SCM tok_buf; SCM port; @@ -653,7 +799,8 @@ tryagain: #ifdef BRACKETS_AS_PARENS case '[': #endif - case '(': return lreadparen(tok_buf, port, s_list); + case '(': + return lreadparen(tok_buf, port, s_list); #ifdef BRACKETS_AS_PARENS case ']': #endif @@ -702,6 +849,11 @@ tryagain: if (charnames[c] && (0==strcmp(charnames[c], CHARS(tok_buf)))) return MAKICHR(charnums[c]); + if (loc_readsharpc && NIMP(*loc_readsharpc)) { + resizuve(tok_buf, MAKINUM(j)); + p = apply(*loc_readsharpc, tok_buf, listofnull); + if ICHRP(p) return p; + } wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf)); case '|': j = 1; /* here j is the comment nesting depth */ @@ -710,7 +862,6 @@ lpc: switch (c) { case EOF: wta(UNDEFINED, s_eofin, "balanced comment"); case LINE_INCREMENTORS: - if (port==loadport) linum++; default: goto lp; case '|': @@ -723,10 +874,8 @@ lpc: switch (c) { } goto tryagain; default: callshrp: - p = CDR(intern("read:sharp", (sizeof "read:sharp")-1)); - if NIMP(p) { - p = apply(p, cons2(MAKICHR(c), port, EOL), EOL); - /* p = apply(p, MAKICHR(c), acons(port, EOL, EOL)); */ + if (loc_readsharp && NIMP(*loc_readsharp)) { + p = apply(*loc_readsharp, cons2(MAKICHR(c), port, EOL), EOL); if (UNSPECIFIED==p) goto tryagain; return p; } @@ -735,20 +884,24 @@ lpc: switch (c) { case '\"': j = 0; while ('\"' != (c = lgetc(port))) { - ASSERT(EOF != c, UNDEFINED, s_eofin, s_string); - if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf); - if (c=='\\') switch (c = lgetc(port)) { - case '\n': continue; - case '0': c = '\0'; break; - case 'f': c = '\f'; break; - case 'n': c = '\n'; break; - case 'r': c = '\r'; break; - case 't': c = '\t'; break; - case 'a': c = '\007'; break; - case 'v': c = '\v'; break; - } - CHARS(tok_buf)[j] = c; - ++j; + ASSERT(EOF != c, UNDEFINED, s_eofin, s_string); + if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf); + switch (c) { + case LINE_INCREMENTORS: break; + case '\\': + switch (c = lgetc(port)) { + case LINE_INCREMENTORS: continue; + case '0': c = '\0'; break; + case 'f': c = '\f'; break; + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + case 't': c = '\t'; break; + case 'a': c = '\007'; break; + case 'v': c = '\v'; break; + } + } + CHARS(tok_buf)[j] = c; + ++j; } if (j==0) return nullstr; CHARS(tok_buf)[j] = 0; @@ -782,7 +935,7 @@ static SCM lreadr(tok_buf, port) SCM ans = lreadpr(tok_buf, port); switch (ans) { case UNDEFINED: - warn("unexpected \")\"", ""); + scm_warn("unexpected \")\"", ""); return lreadpr(tok_buf, port); } return ans; @@ -835,7 +988,7 @@ static SCM lreadparen(tok_buf, port, name) fst = lreadr(tok_buf, port); closeit: tmp = lreadpr(tok_buf, port); - if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", ""); + if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name); return fst; } fst = lst = cons(tmp, EOL); @@ -914,11 +1067,14 @@ struct errdesc errmsgs[] = { {"bus error", 0, 0}, {"segment violation", 0, 0}, {"alarm", "alarm-interrupt", 0}, - {"profile interrupt", "profile-interrupt", 0}, + {"virtual alarm", "virtual-alarm-interrupt", 0}, + {"profile interrupt", "profile-alarm-interrupt", 0}, }; void (* deferred_proc) P((void)) = 0; -int errjmp_bad = 1, ints_disabled = 1; +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; @@ -926,9 +1082,8 @@ 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; -SCM loadport = UNDEFINED; -long linum = 1; -int scm_verbose = 1; +int scm_verbose = 1; /* Low so that monitor info won't be */ + /* printed while in init_storage. (BOOM) */ long cells_allocated = 0, lcells_allocated = 0, mallocated = 0, lmallocated = 0, rt = 0, gc_rt, gc_time_taken; @@ -941,17 +1096,19 @@ static void def_err_response P((void)); int handle_it(i) int i; { - char *name = errmsgs[i-WNA].s_response; SCM proc; - if (errjmp_bad) + char *name = errmsgs[i-WNA].s_response; + if (errjmp_bad || errjmp_recursive) wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */ if (name) { SCM n[2]; int j; + DEFER_INTS; for (j=0; j<2; j++) { NEWCELL(n[j]); /* discard 2 possibly-used cells */ } CDR(n[1]) = EOL; + ALLOW_INTS; proc = CDR(intern(name, (sizet)strlen(name))); if NIMP(proc) { /* Save environment stack, in case it moves when applying proc. Do an ecache gc @@ -966,7 +1123,9 @@ int handle_it(i) env = scm_env; env_tmp = scm_env_tmp; scm_estk = BOOL_F; - scm_estk_reset(); + scm_estk_reset(0); + SCM_ESTK_PARENT(scm_estk) = estk; + SCM_ESTK_PARENT_INDEX(scm_estk) = MAKINUM(estk_ptr - VELTS(estk)); ALLOW_INTS; apply(proc, EOL, EOL); DEFER_INTS; @@ -1006,9 +1165,11 @@ SCM scm_load_string(str) SCM exitval = MAKINUM(EXIT_FAILURE); /* INUM return value */ extern char s_unexec[]; -SCM repl_driver(initpath) +SCM scm_top_level(initpath, toplvl_fun) char *initpath; + SCM (*toplvl_fun)(); { + SCM ret; #ifdef _UNICOS int i; #else @@ -1019,22 +1180,26 @@ SCM repl_driver(initpath) #ifndef SHORT_INT if (i) i = UNCOOK(i); #endif - /* printf("repl_driver got %d\n", i); */ + if (!toplvl_fun) toplvl_fun = repl; + /* printf("scm_top_level got %d\n", i); */ drloop: switch ((int)i) { - default: { - char *name = errmsgs[i-WNA].s_response; - if (name) { - SCM proc = CDR(intern(name, (sizet)strlen(name))); - if NIMP(proc) apply(proc, EOL, EOL); - } + default: + { + char *name = errmsgs[i-WNA].s_response; + if (name) { + SCM proc = CDR(intern(name, (sizet)strlen(name))); + if NIMP(proc) apply(proc, EOL, EOL); + }} if ((i = errmsgs[i-WNA].parent_err)) goto drloop; + case 1: /* from everr() */ def_err_response(); + dowinds(EOL); goto reset_toplvl; - } case 0: exitval = MAKINUM(EXIT_SUCCESS); - errjmp_bad = 0; + errjmp_bad = (char *)0; + errjmp_recursive = 0; lflush(sys_errp); errno = 0; SIG_deferred = 0; @@ -1046,58 +1211,73 @@ SCM repl_driver(initpath) rt = INUM(my_time()); gc_time_taken = 0; } - else if (scm_ldfile(initpath)) /* load Scheme init files */ + else if (initpath && + (isspace(initpath[0]) || ';'==initpath[0] || '('==initpath[0])) + scm_ldstr(initpath); + else if (scm_ldfile(initpath ? initpath : "")) /* load Scheme init files */ wta(*loc_errobj, "Could not open file", s_load); { SCM boot_tail = scm_evstr("boot-tail"); /* initialization tail-call */ - apply(boot_tail, (dumped ? BOOL_T : BOOL_F), listofnull); + if NIMP(boot_tail) + apply(boot_tail, (dumped ? makfrom0str(initpath) : BOOL_F), listofnull); } case -2: /* abrt */ reset_toplvl: + dowinds(EOL); ints_disabled = 1; - errjmp_bad = 0; + errjmp_bad = (char *)0; + errjmp_recursive = 0; lflush(sys_errp); SIG_deferred = 0; deferred_proc = 0; - scm_estk_reset(); + scm_estk_reset(0); /* Closing the loading file turned out to be a bad idea. */ /* But I will leave the code here in case someone wants it. */ #ifdef CLOSE_LOADING_PORTS_ON_ABORT - if (NIMP(loadport) && OPINPORTP(loadport)) { + if (NIMP(loadports) && OPINPORTP(CAR(loadports))) { if (scm_verbose > 1) { lputs("; Aborting load (closing): ", cur_errp); display(*loc_loadpath, cur_errp); newline(cur_errp); } - close_port(loadport); /* close loading file. */ + close_port(CAR(loadports)); /* close loading file. */ } #endif + *loc_loadpath = BOOL_F; - loadport = UNDEFINED; + loadports = EOL; ints_disabled = 0; - repl(); + 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) { + lputs("; program args: ", cur_errp); + lwrite(progargs, cur_errp); + newline(cur_errp); + } return exitval; case -3: /* restart. */ + dowinds(EOL); return 0; #ifdef CAN_DUMP case -4: /* dump */ DEFER_INTS; - scm_estk_reset(); + scm_estk_reset(0); scm_egc(); igc(s_unexec, (STACKITEM *)0); ALLOW_INTS; dumped = 1; -# ifdef linux - /* The last few words of the .data segment +# ifdef linux + sbrk(getpagesize()); /* The last few words of the .data segment were not being mapped in for dumped executables. */ - sbrk(getpagesize()); # endif unexec(CHARS(*loc_errobj), execpath, 0, 0, 0); goto reset_toplvl; @@ -1107,8 +1287,57 @@ SCM repl_driver(initpath) SCM line_num() { - return MAKINUM(linum); + if (IMP(loadports)) + return INUM0; + return scm_port_line(CAR(loadports)); +} +static char s_port_line[] = "port-line"; +SCM scm_port_line(port) + SCM port; +{ + sizet lnum; + ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_line); + if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F; + lnum = scm_port_table[SCM_PORTNUM(port)].line; + switch (CGETUN(port)) { + default: + break; + case LINE_INCREMENTORS: + lnum--; + break; + } + return MAKINUM(lnum); } +static char s_port_col[] = "port-column"; +SCM scm_port_col(port) + SCM port; +{ + short 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; + switch (CGETUN(port)) { + default: + col--; + break; + case LINE_INCREMENTORS: + col = scm_port_table[SCM_PORTNUM(port)].colprev; + break; + } + return MAKINUM(col); +} +static char s_port_filename[] = "port-filename"; +SCM scm_port_filename(port) + SCM port; +{ + SCM x; + ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_filename); + x = SCM_PORTDATA(port); + if (NIMP(x) && STRINGP(x)) + return SCM_PORTDATA(port); + return BOOL_F; +} + SCM prog_args() { return progargs; @@ -1210,13 +1439,20 @@ void repl_report() } } #ifndef LACK_SBRK -extern long scm_init_brk, scm_dumped_brk; +unsigned long scm_init_brk = 0, scm_dumped_brk = 0; +void init_sbrk() +{ + if (dumped) + scm_dumped_brk = (unsigned long)sbrk(0); + else + scm_init_brk = (unsigned long)sbrk(0); +} void scm_brk_report() { - long scm_curbrk = sbrk(0), + unsigned long scm_curbrk = sbrk(0), dif1 = ((dumped ? scm_dumped_brk : scm_curbrk) - scm_init_brk)/1024, dif2 = (scm_curbrk - scm_dumped_brk)/1024; - + lputs("initial brk = 0x", cur_errp); intprint(scm_init_brk, -16, cur_errp); if (dumped) { @@ -1234,9 +1470,6 @@ void scm_brk_report() lputs(" kb\n", cur_errp); } #endif -#ifdef NUM_HP -extern long num_hp_total; -#endif SCM lroom(opt) SCM opt; { @@ -1249,12 +1482,8 @@ SCM lroom(opt) intprint(mtrigger, 10, cur_errp); lputs(")\n", cur_errp); if (!UNBNDP(opt)) { -#ifdef NUM_HP - intprint(num_hp_total, 10, cur_errp); - lputs(" bytes allocated for flonums/bignums\n", cur_errp); -#endif #ifndef LACK_SBRK - scm_brk_report(); + if (scm_init_brk) scm_brk_report(); #endif scm_ecache_report(); heap_report(); @@ -1283,13 +1512,8 @@ void heap_report() } void scm_ecache_report() { - long n = LENGTH(scm_estk) - 1; - while (n-- && VELTS(scm_estk)[n]==UNSPECIFIED) - ; - intprint(n + 1L, 10 , cur_errp); - lputs(" out of ", cur_errp); - intprint(LENGTH(scm_estk), 10, cur_errp); - lputs(" env stack items touched, ", cur_errp); + intprint(scm_estk_size, 10 , cur_errp); + lputs(" env stack items, ", cur_errp); intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp); lputs(" out of ", cur_errp); intprint(scm_ecache_len, 10, cur_errp); @@ -1317,48 +1541,51 @@ SCM prolixity(arg) return MAKINUM(old); } -void repl() +SCM repl() { SCM x; int c; - repl_report(); - while(1) { - if OPOUTPORTP(cur_inp) { /* This case for curses window */ - lfflush(cur_outp); - if (verbose) lputs(PROMPT, cur_inp); - lfflush(cur_inp); - } - else { - if (verbose) lputs(PROMPT, cur_outp); - lfflush(cur_outp); - } - lcells_allocated = cells_allocated; - scm_env_work = scm_ecache_index - scm_ecache_len; - scm_egcs = scm_clo_moved = scm_stk_moved = 0; - lmallocated = mallocated; - x = lread(cur_inp); - rt = INUM(my_time()); - scm_gcs = 0; - gc_time_taken = 0; - if (EOF_VAL==x) break; - if (!CRDYP(cur_inp)) { /* assure newline read (and transcripted) */ - if (EOF==(c = lgetc(cur_inp))) break; - lungetc(c, cur_inp); - } + if OPINPORTP(cur_inp) { + repl_report(); + while(1) { + if OPOUTPORTP(cur_inp) { /* This case for curses window */ + lfflush(cur_outp); + if (verbose) lputs(PROMPT, cur_inp); + lfflush(cur_inp); + } + else { + if (verbose) lputs(PROMPT, cur_outp); + lfflush(cur_outp); + } + lcells_allocated = cells_allocated; + scm_env_work = scm_ecache_index - scm_ecache_len; + scm_egcs = scm_clo_moved = scm_stk_moved = 0; + lmallocated = mallocated; + x = lread(cur_inp); + rt = INUM(my_time()); + scm_gcs = 0; + gc_time_taken = 0; + if (EOF_VAL==x) return MAKINUM(EXIT_SUCCESS); + if (!CRDYP(cur_inp)) { /* assure newline read (and transcripted) */ + if (EOF==(c = lgetc(cur_inp))) break; + lungetc(c, cur_inp); + } #ifdef __HIGHC__ # define __MSDOS__ #endif #ifdef __MSDOS__ - if ('\n' != CGETUN(cur_inp)) - if OPOUTPORTP(cur_inp) /* This case for curses window */ - {lfflush(cur_outp); newline(cur_inp);} - else newline(cur_outp); + if ('\n' != CGETUN(cur_inp)) + if OPOUTPORTP(cur_inp) /* This case for curses window */ + {lfflush(cur_outp); newline(cur_inp);} + else newline(cur_outp); #endif - x = EVAL(x, (SCM)EOL); - repl_report(); - iprin1(x, cur_outp, 1); - lputc('\n', cur_outp); + x = EVAL(x, (SCM)EOL); + repl_report(); + iprin1(x, cur_outp, 1); + lputc('\n', cur_outp); + } } + return UNSPECIFIED; } SCM quit(n) SCM n; @@ -1367,55 +1594,27 @@ SCM quit(n) if INUMP(n) exitval = n; else exitval = MAKINUM(EXIT_FAILURE); if (errjmp_bad) exit(INUM(exitval)); - dowinds(EOL, ilength(dynwinds)); longjump(CONT(rootcont)->jmpbuf, COOKIE(-1)); } SCM abrt() { if (errjmp_bad) exit(EXIT_FAILURE); - dowinds(EOL, ilength(dynwinds)); longjump(CONT(rootcont)->jmpbuf, COOKIE(-2)); } char s_restart[] = "restart"; SCM restart() { /* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */ - dowinds(EOL, ilength(dynwinds)); longjump(CONT(rootcont)->jmpbuf, COOKIE(-3)); } -char s_no_ep[] = "no execpath"; -#define s_execpath (s_no_ep+3) -SCM scm_execpath(newpath) - SCM newpath; -{ - SCM retval = execpath ? makfrom0str(execpath) : BOOL_F; - if (UNBNDP(newpath)) - return retval; - if (FALSEP(newpath) || BOOL_T==newpath) { - if (execpath) free(execpath); - execpath = 0; - if (BOOL_T==newpath) { - execpath = scm_find_executable(); - return execpath ? makfrom0str(execpath) : BOOL_F; - } - else return retval; - } - ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath); - if (execpath) free(execpath); - execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1)); - ASSERT(execpath, newpath, NALLOC, s_execpath); - strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1); - return retval; -} - #ifdef CAN_DUMP char s_unexec[] = "unexec"; SCM scm_unexec(newpath) SCM newpath; { ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec); - ASSERT(execpath, UNSPECIFIED, s_no_ep, s_unexec); + ASSERT(execpath, UNSPECIFIED, s_no_execpath, s_unexec); *loc_errobj = newpath; longjump(CONT(rootcont)->jmpbuf, COOKIE(-4)); } @@ -1469,93 +1668,89 @@ void ints_warn(str1, str2, fname, linum) } #endif -#ifdef TAIL_RECURSIVE_LOAD SCM tryload(filename) SCM filename; { ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load); { SCM oloadpath = *loc_loadpath; - SCM oloadport = loadport; - long olninum = linum; - SCM port, newform = BOOL_F; - port = open_file(filename, makfromstr("r", (sizet)sizeof(char))); - if FALSEP(port) return port; - *loc_loadpath = filename; - loadport = port; - linum = 1; - while(1) { - SCM form = newform; - newform = lread(port); - if (EOF_VAL==newform) { - close_port(port); - linum = olninum; - loadport = oloadport; - *loc_loadpath = oloadpath; - SIDEVAL(form, EOL); - return BOOL_T; - } - SIDEVAL(form, EOL); - } - } -} -#else -SCM tryload(filename) - SCM filename; -{ - ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load); - { - SCM oloadpath = *loc_loadpath; - SCM oloadport = loadport; - long olninum = linum; + SCM oloadports = loadports; SCM form, port; - port = open_file(filename, makfromstr("r", (sizet)sizeof(char))); + port = open_file(filename, makfromstr("r?", (sizet)2*sizeof(char))); if FALSEP(port) return port; *loc_loadpath = filename; - loadport = port; - linum = 1; + loadports = cons(port, loadports); while(1) { form = lread(port); if (EOF_VAL==form) break; SIDEVAL(form, EOL); } close_port(port); - linum = olninum; - loadport = oloadport; + loadports = oloadports; *loc_loadpath = oloadpath; } return BOOL_T; } -#endif #ifdef CAUTIOUS -static void trace1(estk, n) +static long num_frames(estk, i) SCM estk; - int n; + int i; { - SCM ste = VELTS(estk)[SCM_ESTK_BASE + n*SCM_ESTK_FRLEN + 2]; - lputs("\n\n", cur_errp); - intprint(n, -10, cur_errp); - lputs(": ", cur_errp); - iprin1(ste, cur_errp, 1); + 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; } +extern SCM scm_trace; SCM scm_stack_trace() { - long n = (scm_estk_ptr - VELTS(scm_estk)); - n = (n - SCM_ESTK_BASE)/SCM_ESTK_FRLEN; - if (0>=n) return BOOL_F; + 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); - *scm_estk_ptr = scm_env; - if (n > 21) { - int i; - for (i = 0; i < 10; i++) trace1(scm_estk, n-i); - lputs("\n\n ...", cur_errp); - n = 10; + 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++; + } + i = INUM(SCM_ESTK_PARENT_INDEX(estk)); + estk = SCM_ESTK_PARENT(estk); } - do { - trace1(scm_estk, n); - } while (--n > 0); + lputc('\n', cur_errp); return BOOL_T; } #endif @@ -1563,25 +1758,28 @@ SCM scm_stack_trace() static void err_head(str) char *str; { + SCM lps; int oerrno = errno; exitval = MAKINUM(EXIT_FAILURE); if NIMP(cur_outp) lfflush(cur_outp); lputc('\n', cur_errp); - if(BOOL_F != *loc_loadpath) { - iprin1(*loc_loadpath, cur_errp, 1); + for (lps = loadports; NIMP(lps); lps = CDR(lps)) { + if (lps != loadports) + lputs("\n ;loaded from ", cur_errp); + iprin1(scm_port_filename(CAR(lps)), cur_errp, 1); lputs(", line ", cur_errp); - intprint((long)linum, 10, cur_errp); + iprin1(scm_port_line(CAR(lps)), cur_errp, 1); lputs(": ", cur_errp); } + if (NIMP(loadports) && NIMP(CDR(loadports))) + lputs("\n;", cur_errp); lfflush(cur_errp); errno = oerrno; - if (cur_errp==def_errp) { - if (errno>0) perror(str); - fflush(stderr); - return; - } + /* if (NIMP(cur_errp) && stderr==STREAM(cur_errp)) { ... } */ + if (errno>0) perror(str); + fflush(stderr); } -void warn(str1, str2) +void scm_warn(str1, str2) char *str1, *str2; { err_head("WARNING"); @@ -1614,56 +1812,67 @@ SCM lperror(arg) } static void def_err_response() { - SCM obj = *loc_errobj; + SCM env = err_env, obj = *loc_errobj; DEFER_INTS; + if (errjmp_recursive++) { + lputs("RECURSIVE ERROR: ", def_errp); + if (TYP16(cur_errp)==tc16_sfport) { + cur_errp = def_errp; + errjmp_recursive = 0; + lputs("reverting to default error port\n", def_errp); + } + else exit(EXIT_FAILURE); + } err_head("ERROR"); - lputs("ERROR: ", 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; #ifdef nosve if ((~0x1fL) & (short)err_pos) lputs(err_pos, cur_errp); - else if (WNA>(short)err_pos) { + else if (WNA > (short)err_pos) { lputs("Wrong type in arg", cur_errp); - lputc(err_pos ? '0'+(short)err_pos : ' ', cur_errp); + lputc((short)err_pos <= ARGn ? ' ' : '1' + (short)err_pos - ARG1, cur_errp); } #else if ((~0x1fL) & (long)err_pos) lputs(err_pos, cur_errp); - else if (WNA>(long)err_pos) { + else if (WNA > (long)err_pos) { lputs("Wrong type in arg", cur_errp); - lputc(err_pos ? '0'+(int)err_pos : ' ', cur_errp); + lputc((long)err_pos <= ARGn ? ' ' : '1' + (int)err_pos - ARG1, cur_errp); } #endif - else { - lputs(errmsgs[((int)err_pos)-WNA].msg, cur_errp); - goto outobj; - } - if (IMP(obj) || SYMBOLP(obj) || (TYP16(obj)==tc7_port) - || (NFALSEP(procedurep(obj))) || (NFALSEP(numberp(obj)))) { -outobj: - if (!UNBNDP(obj)) { - lputs(((long)err_pos==WNA)?" given ":" ", cur_errp); - iprin1(obj, cur_errp, 1); - } - } - else lputs(" (see errobj)", cur_errp); -#ifdef CAUTIOUS - scm_stack_trace(); -#endif + else lputs(errmsgs[((int)err_pos)-WNA].msg, cur_errp); + lputs(((long)err_pos==WNA)?" given ":" ", cur_errp); + err_pos = 0; + if (!UNBNDP(obj)) + if (reset_safeport(sys_safep, 55, cur_errp)) + if (0==setjmp(SAFEP_JMPBUF(sys_safep))) + iprin1(obj, sys_safep, 1); if UNBNDP(err_exp) goto getout; if NIMP(err_exp) { - lputs("\n; in expression: ", cur_errp); - if NCONSP(err_exp) iprin1(err_exp, cur_errp, 1); - else if (UNDEFINED==CDR(err_exp)) - iprin1(CAR(err_exp), cur_errp, 1); - else iprlist("(... ", err_exp, ')', cur_errp, 1); + 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); + else if (UNDEFINED==CDR(err_exp)) + iprin1(CAR(err_exp), sys_safep, 1); + else iprlist("(... ", err_exp, ')', sys_safep, 1); + } } - if NULLP(err_env) lputs("\n; in top level environment.", cur_errp); + 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 { - SCM env = err_env; - if (NIMP(env) && tc16_env==CAR(env)) env = CDR(env); lputs("\n; in scope:", cur_errp); while NNULLP(env) { lputc('\n', cur_errp); @@ -1673,15 +1882,17 @@ outobj: } } getout: +#ifdef CAUTIOUS + scm_stack_trace(); +#endif lputc('\n', cur_errp); lfflush(cur_errp); err_exp = err_env = UNDEFINED; if (errjmp_bad) { - lputs("\nerrobj: ", cur_errp); - iprin1(obj, cur_errp, 1); - newline(cur_errp); + lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION: ", cur_errp); + lputs(errjmp_bad, cur_errp); + lputc('\n', cur_errp); lroom(BOOL_T); - lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp); #ifdef vms exit(EXIT_FAILURE); #else @@ -1700,13 +1911,10 @@ void everr(exp, env, arg, pos, s_subr) *loc_errobj = arg; err_pos = pos; err_s_subr = s_subr; - if (((~0x1fL) & (long)pos) || (WNA>(long)pos) || errjmp_bad) { - def_err_response(); - abrt(); - } - if IMP(rootcont) exit(INUM(exitval)); - dowinds(EOL, ilength(dynwinds)); - longjump(CONT(rootcont)->jmpbuf, COOKIE((int)pos)); + if (errjmp_bad || errjmp_recursive) def_err_response(); + longjump(CONT(rootcont)->jmpbuf, + (~0x1fL) & (long)pos || (WNA > (long)pos) ? + COOKIE(1) : COOKIE((int)pos)); /* will do error processing at stack base */ } void wta(arg, pos, s_subr) @@ -1733,25 +1941,34 @@ char s_cur_errp[] = "set-current-error-port"; SCM set_inp(port) SCM port; { - SCM oinp = cur_inp; - ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_cur_inp); + SCM oinp; + ASSERT(NIMP(port) && INPORTP(port), port, ARG1, s_cur_inp); + DEFER_INTS; + oinp = cur_inp; cur_inp = port; + ALLOW_INTS; return oinp; } SCM set_outp(port) SCM port; { - SCM ooutp = cur_outp; - ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_outp); + SCM ooutp; + ASSERT(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_outp); + DEFER_INTS; + ooutp = cur_outp; cur_outp = port; + ALLOW_INTS; return ooutp; } SCM set_errp(port) SCM port; { - SCM oerrp = cur_errp; - ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_errp); + SCM oerrp; + ASSERT(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_errp); + DEFER_INTS; + oerrp = cur_errp; cur_errp = port; + ALLOW_INTS; return oerrp; } static char s_isatty[] = "isatty?"; @@ -1767,7 +1984,6 @@ static iproc subr0s[] = { {&s_cur_inp[4], cur_input_port}, {&s_cur_outp[4], cur_output_port}, {&s_cur_errp[4], cur_error_port}, - {"transcript-off", trans_off}, {"program-arguments", prog_args}, {"line-number", line_num}, {"abort", abrt}, @@ -1781,7 +1997,6 @@ static iproc subr1s[] = { {s_cur_inp, set_inp}, {s_cur_outp, set_outp}, {s_cur_errp, set_errp}, - {"transcript-on", trans_on}, {s_tryload, tryload}, {s_load_string, scm_load_string}, {s_eval_string, scm_eval_string}, @@ -1790,6 +2005,9 @@ static iproc subr1s[] = { {s_tryarb, tryarb}, {s_relarb, relarb}, {s_isatty, l_isatty}, + {s_port_line, scm_port_line}, + {s_port_col, scm_port_col}, + {s_port_filename, scm_port_filename}, {0, 0}}; static iproc subr1os[] = { @@ -1797,15 +2015,12 @@ static iproc subr1os[] = { {s_read_char, scm_read_char}, {s_peek_char, peek_char}, {s_newline, newline}, + {s_freshline, scm_freshline}, {s_flush, lflush}, -#ifndef GO32 {s_char_readyp, char_readyp}, -#endif {"quit", quit}, {"verbose", prolixity}, {"errno", lerrno}, - {s_execpath, scm_execpath}, - {"find-init-file", scm_find_impl}, {"room", lroom}, {0, 0}}; @@ -1827,17 +2042,15 @@ void init_repl( iverbose ) sysintern(s_ccl, MAKINUM(CHAR_CODE_LIMIT)); loc_errobj = &CDR(sysintern("errobj", UNDEFINED)); loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F)); - transcript = BOOL_F; - trans = 0; - linum = 1; + loc_readsharp = &CDR(sysintern("read:sharp", UNDEFINED)); + loc_readsharpc = &CDR(sysintern("read:sharp-char", 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); -#ifndef GO32 add_feature(s_char_readyp); -#endif + make_subr(s_wfi, tc7_lsubr, wait_for_input); #ifdef CAN_DUMP add_feature("dump"); scm_ldstr("\ @@ -1860,8 +2073,5 @@ void final_repl() { loc_errobj = (SCM *)&tmp_errobj; loc_loadpath = (SCM *)&tmp_loadpath; - loadport = UNDEFINED; - transcript = BOOL_F; - trans = 0; - linum = 1; + loadports = EOL; } diff --git a/requires.scm b/requires.scm new file mode 100644 index 0000000..bd4b8bf --- /dev/null +++ b/requires.scm @@ -0,0 +1,22 @@ +;;; "require.scm" Trampoline to slib/require.scm + +(set! library-vicinity + (let* ((vl (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((MACOS THINKC) '(#\:)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\])))) + (iv (implementation-vicinity)) + (vc (and (positive? (string-length iv)) + (string-ref iv (+ -1 (string-length iv))))) + (vs (if (memv vc vl) (string vc) "/")) + (lv (let loop ((pos (+ -2 (string-length iv)))) + (cond ((or (< pos 0) (not vs)) + (string-append iv ".." vs "slib" vs)) + ((memv (string-ref iv pos) vl) + (string-append (substring iv 0 (+ 1 pos)) "slib" vs)) + (else (loop (- pos 1))))))) + (lambda () lv))) +(load (in-vicinity (library-vicinity) "require")) @@ -1,18 +1,18 @@ /* Copyright (C) 1995, 1996, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,14 +36,18 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "rgx.c" regular expression matching using C regex library. Author: Aubrey Jaffer */ #include "scm.h" -#include "regex.h" +#ifdef __FreeBSD__ +# include "gnuregex.h" +#else +# include "regex.h" +#endif #include <stdio.h> /* added by Denys Duchier: for bcopy */ #ifdef sun @@ -51,7 +55,7 @@ #endif static char rcsid[] = - "$Id: rgx.c,v 1.4 1998/09/11 18:13:43 radey Exp $"; + "$Id: rgx.c,v 1.12 1999/09/07 16:55:54 jaffer Exp $"; #ifdef HAVE_ALLOCA # include <alloca.h> @@ -111,7 +115,7 @@ typedef struct regex_info { #ifndef _GNU_SOURCE int options; /* for anchored pattern when matching */ regex_t rgx_anchored; -#endif +#endif } regex_info; sizet fregex(ptr) @@ -120,11 +124,11 @@ sizet fregex(ptr) regfree(RGX(ptr)); #ifndef _GNU_SOURCE /* options are null => we compiled the anchored pattern */ - if (RGX_INFO(ptr)->options==NULL) + if (RGX_INFO(ptr)->options==0) regfree(RGX2(ptr)); -#endif - free(CHARS(ptr)); - return sizeof(regex_t); +#endif + must_free(CHARS(ptr), (sizet)LENGTH(ptr)); + return 0; } int prinregex(exp, port, writing) @@ -141,7 +145,6 @@ int prinregex(exp, port, writing) SCM markregex(ptr) SCM ptr; { - SETGC8MARK(ptr); SETGC8MARK(RGX_PATTERN(ptr)); return BOOL_F; } @@ -166,9 +169,9 @@ SCM lregerror(scode) #ifdef __REGEXP_LIBRARY_H__ /* XXX - gnu regexp doesn't use the re parameter, so we will ignore it in a very untidy way. */ - len = regerror(code, 0, 0, 0); + len = regerror(code, 0L, 0L, 0); str = makstr(len-1); - regerror(code, 0, CHARS(str), len); + regerror(code, 0L, CHARS(str), len); #else str = makfromstr(s_error, (sizet)5); #endif @@ -190,14 +193,13 @@ SCM lregcomp(pattern, flags) #endif ASSERT(NIMP(pattern) && STRINGP(pattern), pattern, ARG1, s_regcomp); - ASSERT(UNBNDP(flags) || (NIMP(flags) && STRINGP(flags)), + ASSERT(UNBNDP(flags) || (NIMP(flags) && STRINGP(flags)), flags, ARG2, s_regcomp); DEFER_INTS; - z = must_malloc_cell((long)sizeof(regex_info), s_regex); + z = must_malloc_cell((long)sizeof(regex_info), (SCM)tc16_rgx, s_regex); scm_protect_temp(&z); info=(regex_info*)CHARS(z); prog = &(info->rgx); - CAR(z) = tc16_rgx; #ifdef __REGEXP_LIBRARY_H__ for(i=sizeof(regex_t);i--;((char *)prog)[i] = 0); # ifndef _GNU_SOURCE @@ -223,7 +225,7 @@ SCM lregcomp(pattern, flags) for (i=0; i<LENGTH(flags); i++) switch (flagchars[i]) { #ifdef _GNU_SOURCE - case 'n': + case 'n': options |= RE_HAT_LISTS_NOT_NEWLINE; options &= (~RE_DOT_NEWLINE); break; @@ -237,7 +239,7 @@ SCM lregcomp(pattern, flags) fastmap = 1; break; #else - case 'n': + case 'n': options |= REG_NEWLINE; break; case 'i': @@ -252,17 +254,17 @@ SCM lregcomp(pattern, flags) if (fastmap) prog->fastmap = must_malloc(CHAR_SET_SIZE, s_regex); else - prog->fastmap = NULL; - + prog->fastmap = 0; + if (ignore_case) { prog->translate = must_malloc(CHAR_SET_SIZE, s_regex); for (i = 0; i < CHAR_SET_SIZE; i++) prog->translate[i] = ISUPPER (i) ? tolower (i) : i; } else - prog->translate = NULL; + prog->translate = 0; - prog->buffer = NULL; + prog->buffer = 0; prog->allocated = 0; re_set_syntax(options); @@ -287,7 +289,7 @@ SCM lregcomp(pattern, flags) z = MAKINUM(i); } #else - info->options = options; + info->options = options; i = regcomp(prog, CHARS(pattern), options); if (i) z = MAKINUM(i); #endif @@ -341,7 +343,7 @@ SCM lregmatp(prog, str) { int flags = 0; /* XXX - optional arg? */ - flags = regexec(RGX(prog), CHARS(str), 0, NULL, flags); + flags = regexec(RGX(prog), CHARS(str), 0, 0, flags); if (!flags) return BOOL_T; if (REG_NOMATCH!=flags) wta(MAKINUM(flags), s_error, s_regmatp); return BOOL_F; @@ -377,7 +379,7 @@ SCM lregsearchmatch(prog, str, args, search, vector) #ifdef _GNU_SOURCE { int ret, dir=1; - struct re_registers regs, *pregs=NULL; + struct re_registers regs, *pregs=0; if (search && start<0) start *= -1, dir = -1; @@ -395,7 +397,7 @@ SCM lregsearchmatch(prog, str, args, search, vector) ret = re_search(RGX(prog), CHARS(str), size, start, dir*size, pregs); else ret = re_match(RGX(prog), CHARS(str), size, start, pregs); - + if (ret < 0) return BOOL_F; @@ -464,7 +466,7 @@ SCM lregsearchmatch(prog, str, args, search, vector) return MAKINUM(pm[0].rm_eo - pm[0].rm_so); } -#endif /* _GNU_SOURCE */ +#endif /* _GNU_SOURCE */ } SCM lregsearch(prog, str, args) @@ -511,7 +513,7 @@ SCM stringsplitutil(prog, str, vector) next_break = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL)); while (next_break != BOOL_F) { - match_start = INUM(VELTS(next_break)[0]); + match_start = INUM(VELTS(next_break)[0]); match_end = INUM(VELTS(next_break)[1]); if (match_start < match_end) { @@ -560,7 +562,7 @@ SCM lstringsplitv(prog, str) { return stringsplitutil(prog, str, VECTOR); } - + typedef struct _item { struct _item *next; char *string; @@ -614,12 +616,12 @@ SCM lstringedit(prog, editspec, args) * of integers for substrings to be inserted and * integers representing matched subexpressions that * should be inserted. - */ + */ maxsubnum = RGX(prog)->re_nsub; anchor = 0; backslash = 0; - editlist = NULL; + editlist = 0; ptr = CHARS(editspec); for (i=0; i<LENGTH(editspec); i++) { @@ -638,11 +640,11 @@ SCM lstringedit(prog, editspec, args) if (anchor < LENGTH(editspec)) PUSH(editlist, CHARS(editspec), anchor, LENGTH(editspec)); - /* now, reverse the list of edit items */ + /* now, reverse the list of edit items */ { editItem prev, cur, next; - for (prev=NULL, cur=editlist; cur; prev=cur, cur=next) { + for (prev=0, cur=editlist; cur; prev=cur, cur=next) { next = cur->next; cur->next = prev; } @@ -652,7 +654,7 @@ SCM lstringedit(prog, editspec, args) anchor = 0; search_base = 0; editcount = 0; - substrings = NULL; + substrings = 0; next_edit = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL)); @@ -660,7 +662,7 @@ SCM lstringedit(prog, editspec, args) if (INUMP(count) && (editcount==INUM(count))) break; - match_start = INUM(VELTS(next_edit)[0]); + match_start = INUM(VELTS(next_edit)[0]); match_end = INUM(VELTS(next_edit)[1]); if (match_start < match_end) { @@ -671,10 +673,10 @@ SCM lstringedit(prog, editspec, args) for (edit=editlist; edit; edit=edit->next) { if (edit->end == -1) { /* A backslash number in the original editspec */ - PUSH(substrings, CHARS(str), - INUM(VELTS(next_edit)[edit->start*2+0]), + PUSH(substrings, CHARS(str), + INUM(VELTS(next_edit)[edit->start*2+0]), INUM(VELTS(next_edit)[edit->start*2+1])); - } else + } else /* normal string in the editspec */ PUSH(substrings, edit->string, edit->start, edit->end); } @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "rope.c" interface between C and SCM. @@ -159,6 +159,15 @@ long num2long(num, pos, s_caller) # endif errout: wta(num, pos, s_caller); } +short num2short(num, pos, s_caller) + SCM num; + char *pos, *s_caller; +{ + long lres = INUM((long)num); + short res = lres; + if (INUMP(num) && lres==res) return res; + wta(num, pos, s_caller); +} #ifdef FLOATS double num2dbl(num, pos, s_caller) SCM num; @@ -174,7 +183,6 @@ double num2dbl(num, pos, s_caller) } #endif - /* Convert (arrays of) strings to SCM */ SCM makfromstr(src, len) char *src; @@ -230,9 +238,11 @@ char **makargvfrmstrs(args, s_name) void must_free_argv(argv) char **argv; { - char **av = argv; - while(!(*av)) free(*(av++)); - free(argv); + sizet i; + for(i = 0; argv[i]; i++) { + must_free(argv[i], 1+strlen(argv[i])); + } + must_free((char *)argv, i*sizeof(char *)); } /* Hooks to call SCM from C */ @@ -321,6 +331,8 @@ unsigned long scm_addr(args, s_name) case tc7_ivect: case tc7_vector: ptr = (unsigned long)&(VELTS(v)[pos]); break; + case tc7_svect: ptr = (unsigned long)&(((short *)CDR(v))[pos]); + break; outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_name); default: badarg: wta(v, (char *)ARG1, s_name); @@ -328,6 +340,45 @@ unsigned long scm_addr(args, s_name) } return ptr; } +unsigned long scm_base_addr(v, s_name) + SCM v; + char *s_name; +{ + long pos = 0; + unsigned long ptr = 0; /* gratuitous assignment squelches cc warn. */ + if IMP(v) {goto badarg;} + else if ARRAYP(v) { + pos = ARRAY_BASE(v); + v = ARRAY_V(v); + } + switch TYP7(v) { + case tc7_string: + ptr = (unsigned long)&(CHARS(v)[pos]); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + ptr = (unsigned long)&(((float *)CDR(v))[pos]); + break; +# endif + case tc7_cvect: pos = 2 * pos; + case tc7_dvect: ptr = (unsigned long)&(((double *)CDR(v))[pos]); + break; +# endif + case tc7_bvect: ASRTGO(0==(pos%LONG_BIT), outrng); + pos = pos/LONG_BIT; + case tc7_uvect: + case tc7_ivect: + case tc7_vector: ptr = (unsigned long)&(VELTS(v)[pos]); + break; + case tc7_svect: ptr = (unsigned long)&(((short *)CDR(v))[pos]); + break; + outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_name); + default: + badarg: wta(v, (char *)ARG1, s_name); + } + return ptr; +} #endif /* ARRAYS */ /* scm_cell_p() returns !0 if the SCM argument `x' is cell-aligned and @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "sc2.c" R2RS and R3RS procedures not in R4RS. @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "scl.c" non-IEEE utility functions and non-integer arithmetic. @@ -47,6 +47,10 @@ #ifdef FLOATS # include <math.h> +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 char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar", s_magnitude[] = "magnitude", s_angle[] = "angle", s_real_part[] = "real-part", s_imag_part[] = "imag-part", @@ -74,24 +78,69 @@ static char s_list_tail[] = "list-tail"; static char s_str2list[] = "string->list"; static char s_st_copy[] = "string-copy", s_st_fill[] = "string-fill!"; static char s_vect2list[] = "vector->list", s_ve_fill[] = "vector-fill!"; +static char s_intexpt[] = "integer-expt"; + /*** NUMBERS -> STRINGS ***/ #ifdef FLOATS -int dblprec; -static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5, - 5e-6, 5e-7, 5e-8, 5e-9, 5e-10, - 5e-11,5e-12,5e-13,5e-14,5e-15, - 5e-16,5e-17,5e-18,5e-19,5e-20}; +static int dbl_mant_dig; +double dbl_prec(x) + double x; +{ + int expt; + 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); +# endif + 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) */ +static int apx_log10(x) + double x; +{ + int expt; + double frac = frexp(x, &expt); + expt -= 1; + if (expt >= 0) + return (int)(expt * llog2); + return -((int)( -expt * llog2)); +} + +static double p10[] = {1.0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7}; +static double lpow10(x, n) + double x; + int n; +{ + if (n >= 0) { + while (n > 7) { + x *= 1e8; + n -= 8; + } + return x*p10[n]; + } + while (n < -7) { + x /= 1e8; + n += 8; + } + return x/p10[-n]; +} + +/* DBL2STR_FUZZ is a somewhat arbitrary guard against + round off error in scaling f and fprec. */ +#define DBL2STR_FUZZ 0.9 +int dblprec; static sizet idbl2str(f, a) double f; char *a; { - int efmt, dpt, d, i, wp = dblprec; + double fprec = dbl_prec(f); + int efmt, dpt, d, i, exp; sizet ch = 0; - int exp = 0; - if (f==0.0) goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/ + if (f==0.0) {exp = 0; goto zero;} /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/ if (f < 0.0) {f = -f;a[ch++]='-';} else if (f > 0.0) ; else goto funny; @@ -99,22 +148,34 @@ static sizet idbl2str(f, a) if (ch==0) a[ch++]='+'; funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch; } -# ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from - make-uniform-vector, from causing infinite loops. */ - while (f < 1.0) {f *= 10.0; if (exp-- < DBL_MIN_10_EXP) goto funny;} - while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;} + exp = apx_log10(f); + f = lpow10(f, -exp); + fprec = lpow10(fprec, -exp); +# ifdef DBL_MIN_10_EXP /* Prevent random unnormalized values, as from + make-uniform-vector, from causing infinite loops, + but try to print gradually underflowing numbers. */ + while (f < 1.0) { + f *= 10.0; + fprec *= 10.0; + if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) goto funny; + } + while (f > 10.0) { + f /= 10.0; + fprec /= 10.0; + if (exp++ > DBL_MAX_10_EXP) goto funny;} # else - while (f < 1.0) {f *= 10.0; exp--;} - while (f > 10.0) {f /= 10.0; exp++;} + while (f < 1.0) {f *= 10.0; fprec *= 10.0; exp--;} + while (f > 10.0) {f /= 10.0; fprec /= 10.0; exp++;} # endif - if (f+fx[wp] >= 10.0) {f = 1.0; exp++;} + fprec *= 0.5; + if (f+fprec >= 10.0) {f = 1.0; exp++;} zero: # ifdef ENGNOT dpt = (exp+9999)%3; exp -= dpt++; efmt = 1; # else - efmt = (exp < -3) || (exp > wp+2); + efmt = (exp < -3) || (exp > dblprec+2); if (!efmt) if (exp < 0) { a[ch++] = '0'; @@ -127,18 +188,20 @@ static sizet idbl2str(f, a) dpt = 1; # endif - do { + for (i = 30; i--;) { + /* printf(" f = %.20g, fprec = %.20g, i = %d\n", f, fprec, i); */ d = f; f -= d; a[ch++] = d+'0'; - if (f < fx[wp]) break; - if (f+fx[wp] >= 1.0) { + if (f < fprec && f < DBL2STR_FUZZ*fprec) break; + if ((f + fprec) >= 1.0 && (f + DBL2STR_FUZZ*fprec) >= 1.0) { a[ch-1]++; break; } f *= 10.0; + fprec *= 10.0; if (!(--dpt)) a[ch++] = '.'; - } while (wp--); + } if (dpt > 0) # ifndef ENGNOT @@ -565,7 +628,9 @@ SCM istr2flo(str, len, radix) switch (c = str[i]) { case DIGITS: expon = expon*10 + c-'0'; - if (expon > MAXEXP) return BOOL_F; /* exponent too large */ + if (expon > MAXEXP) + if (1==expsgn || expon > (MAXEXP + dblprec + 1)) + return BOOL_F; /* exponent too large */ break; default: goto out4; @@ -682,37 +747,26 @@ SCM makdbl (x, y) { SCM z; if ((y==0.0) && (x==0.0)) return flo0; + DEFER_INTS; if (y==0.0) { # ifdef SINGLES - float fx; + float fx = x; /* David Yeh <theyeh@uclink.berkeley.edu> + changed this so that MSVC works */ # ifndef SINGLESONLY - if ((-FLTMAX < x) && (x < FLTMAX) && ((fx=x)==x)) + if ((-FLTMAX < x) && (x < FLTMAX) && ( (double)fx == x) ) # endif { NEWCELL(z); - DEFER_INTS; CAR(z) = tc_flo; FLO(z) = x; ALLOW_INTS; return z; } # endif /* def SINGLES */ - DEFER_INTS; -# ifdef NUM_HP - CDR(z) = (SCM)num_hp_alloc(sizeof(double)); -# else - z = must_malloc_cell(1L*sizeof(double), "real"); -# endif - CAR(z) = tc_dblr; + z = must_malloc_cell(1L*sizeof(double), (SCM)tc_dblr, "real"); } else { - DEFER_INTS; -# ifdef NUM_HP - CDR(z) = (SCM)num_hp_alloc(2L*sizeof(double)); -# else - z = must_malloc_cell(2L*sizeof(double), "complex"); -# endif - CAR(z) = tc_dblc; + z = must_malloc_cell(2L*sizeof(double), (SCM)tc_dblc, "complex"); IMAG(z) = y; } REAL(z) = x; @@ -844,23 +898,23 @@ static SCM vector_equal(x, y) if FALSEP(equal(VELTS(x)[i], VELTS(y)[i])) return BOOL_F; return BOOL_T; } +#ifdef BIGDIG SCM bigequal(x, y) SCM x, y; { -#ifdef BIGDIG if (0==bigcomp(x, y)) return BOOL_T; -#endif return BOOL_F; } +#endif +#ifdef FLOATS SCM floequal(x, y) SCM x, y; { -#ifdef FLOATS if (REALPART(x) != REALPART(y)) return BOOL_F; if (!(CPLXP(x) && (IMAG(x) != IMAG(y)))) return BOOL_T; -#endif return BOOL_F; } +#endif SCM equal(x, y) SCM x, y; { @@ -887,7 +941,8 @@ SCM equal(x, y) if (smobs[i].equalp) return (smobs[i].equalp)(x, y); else return BOOL_F; } - case tc7_bvect: case tc7_uvect: case tc7_ivect: + case tc7_bvect: + case tc7_uvect: case tc7_ivect: case tc7_svect: case tc7_fvect: case tc7_cvect: case tc7_dvect: { SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp; if (pred) return (*pred)(x, y); @@ -1615,9 +1670,8 @@ SCM product(x, y) if BIGP(y) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), BIGSIGN(x) ^ BIGSIGN(y)); ASRTGO(INEXP(y), bady); - bigreal: { - double bg = big2dbl(x); - return makdbl(bg*REALPART(y), CPLXP(y)?bg*IMAG(y):0.0); } + bigreal: + return bigdblop('*', x, REALPART(y), CPLXP(y) ? IMAG(y) : 0.0); } ASRTGO(INEXP(x), badx); # else @@ -1736,7 +1790,6 @@ SCM product(x, y) return y; } } - SCM divide(x, y) SCM x, y; { @@ -1767,7 +1820,7 @@ SCM divide(x, y) if (z < BIGRAD) { SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0)); return divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z) ? - makdbl(big2dbl(x)/INUM(y), 0.0) : normbig(w); + bigdblop('/', x, INUM(y), 0.0) : normbig(w); } # ifndef DIGSTOOBIG z = pseudolong(z); @@ -1779,25 +1832,23 @@ SCM divide(x, y) z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, BIGSIGN(x) ? (y>0) : (y<0), 3);} # endif - return z ? z : makdbl(big2dbl(x)/INUM(y), 0.0); + return z ? z : bigdblop('/', x, INUM(y), 0.0); } ASRTGO(NIMP(y), bady); if BIGP(y) { z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), BIGSIGN(x) ^ BIGSIGN(y), 3); - return z ? z : makdbl(big2dbl(x)/big2dbl(y), 0.0); + return z ? z : inex_divbigbig(x, y); } ASRTGO(INEXP(y), bady); - if REALP(y) return makdbl(big2dbl(x)/REALPART(y), 0.0); - a = big2dbl(x); - goto complex_div; + return bigdblop('/', x, REALPART(y), CPLXP(y) ? IMAG(y) : 0.0); } # endif ASRTGO(INEXP(x), badx); if INUMP(y) {d = INUM(y); goto basic_div;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) {d = big2dbl(y); goto basic_div;} + if BIGP(y) return bigdblop('\\', y, REALPART(x), CPLXP(x) ? IMAG(x) : 0.0); ASRTGO(INEXP(y), bady); # else ASRTGO(NIMP(y) && INEXP(y), bady); @@ -1818,7 +1869,7 @@ SCM divide(x, y) if NINUMP(y) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return makdbl(INUM(x)/big2dbl(y), 0.0); + if BIGP(y) return bigdblop('\\', y, INUM(x), 0.0); # ifndef RECKLESS if (!(INEXP(y))) bady: wta(y, (char *)ARG2, s_divide); @@ -1905,6 +1956,79 @@ SCM divide(x, y) } } +SCM scm_intexpt(z1, z2) + SCM z1, z2; +{ + SCM acc = MAKINUM(1L); +#ifdef BIGDIG + if (INUM0==z1 || acc==z1) return z1; + else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; +#endif + ASSERT(INUMP(z2), z2, ARG2, s_intexpt); + z2 = INUM(z2); + if (z2 < 0) { + z2 = -z2; + z1 = divide(z1, UNDEFINED); + } + if INUMP(z1) { + long tmp, iacc = 1, iz1 = INUM(z1); + while (1) { + if (0==z2) { + acc = long2num(iacc); +#ifndef RECKLESS + if (FALSEP(z1)) + errout: wta(UNDEFINED, (char *)OVFLOW, s_intexpt); +#endif + return acc; + } + if (1==z2) { + tmp = iacc*iz1; + if (tmp/iacc != iz1) { + overflow: + z1 = long2num(iz1); + acc = long2num(iacc); + ASRTGO(NFALSEP(z1) && NFALSEP(acc), errout); + goto gencase; + } + acc = long2num(tmp); + ASRTGO(NFALSEP(acc), errout); + return acc; + } + if (z2 & 1) { + tmp = iacc*iz1; + if (tmp/iacc != iz1) goto overflow; + iacc = tmp; + z2 = z2 - 1; /* so jumping to gencase works */ + } + tmp = iz1*iz1; + if (tmp/iz1 != iz1) goto overflow; + iz1 = tmp; + z2 >>= 1; + } + } + ASSERT(NIMP(z1), z1, ARG1, s_intexpt); +#ifdef FLOATS /* Move to scl.c ? */ + if REALP(z1) { + double dacc = 1.0, dz1 = REALPART(z1); + while(1) { + if (0==z2) return makdbl(dacc, 0.0); + if (1==z2) return makdbl(dacc*dz1, 0.0); + if (z2 & 1) dacc = dacc*dz1; + dz1 = dz1*dz1; + z2 >>= 1; + } + } +#endif + gencase: + while(1) { + if (0==z2) return acc; + if (1==z2) return product(acc, z1); + if (z2 & 1) acc = product(acc, z1); + z1 = product(z1, z1); + z2 >>= 1; + } +} + #ifdef FLOATS double lasinh(x) double x; @@ -2172,6 +2296,81 @@ double big2dbl(b) if (tc16_bigneg==TYP16(b)) return -ans; return ans; } +static double big2scaldbl(b, expt) + SCM b; + int expt; +{ + double ans = 0.0; + int i = NUMDIGS(b) - 1; + BIGDIG *digits = BDIGITS(b); + while (i > (expt/BITSPERDIG)) { + ans = digits[i] + BIGRAD*ans; + i--; + } + ans = ldexp(ans, BITSPERDIG - expt); + /* + if (expt = (expt % BITSPERDIG)) { + ans = (digits[i] >> expt) + + (1L << (BITSPERDIG - expt))*ans; + } + if ((1L << (BITSPERDIG - expt - 1)) & digits[i]) + ans += 1; + */ + if (tc16_bigneg==TYP16(b)) return -ans; + return ans; +} +static SCM bigdblop(op, b, re, im) + int op; + SCM b; + double re, im; +{ + double bm = 0.0; + int i = 0; + if (NUMDIGS(b)*BITSPERDIG < DBL_MAX_EXP) { + bm = big2dbl(b); + } + else { + i = INUM(scm_intlength(b)); + if (i < DBL_MAX_EXP) { + i = 0; + bm = big2dbl(b); + } + else { + i = i + 1 - DBL_MAX_EXP; + bm = big2scaldbl(b, i); + } + } + switch (op) { + case '*': + return makdbl(ldexp(bm*re, i), 0.0==im ? 0.0 : ldexp(bm*im, i)); + case '/': { + double d = re*re + im*im; + return makdbl(ldexp(bm*(re/d), i), ldexp(-bm*(im/d), i)); + } + case '\\': + return makdbl(ldexp(re/bm, -i), 0.0==im ? 0.0 : ldexp(im/bm, -i)); + } +} +static SCM inex_divbigbig(a, b) + SCM a, b; +{ + double r; + if ((NUMDIGS(a)*BITSPERDIG < DBL_MAX_EXP) && + (NUMDIGS(b)*BITSPERDIG < DBL_MAX_EXP)) + r = big2dbl(a) / big2dbl(b); + else { + int i = INUM(scm_intlength(a)); + int j = INUM(scm_intlength(b)); + i = (i > j) ? i : j; + if (i < DBL_MAX_EXP) + r = big2dbl(a) / big2dbl(b); + else { + i = i + 1 - DBL_MAX_EXP; + r = big2scaldbl(a, i) / big2scaldbl(b, i); + } + } + return makdbl(r, 0.0); +} # endif #endif @@ -2333,6 +2532,7 @@ static iproc subr2s[] = { {s_memv, memv}, {s_assv, assv}, #endif + {s_intexpt, scm_intexpt}, {s_list_tail, list_tail}, {s_ve_fill, vector_fill}, {s_st_fill, string_fill}, @@ -2386,13 +2586,13 @@ static dblproc cxrs[] = { #endif #ifdef FLOATS -# ifndef DBL_DIG +/* # ifndef DBL_DIG -- also needed for ifndef DBL_MANT_DIG */ static void add1(f, fsum) double f, *fsum; { *fsum = f + 1.0; } -# endif +/* #endif */ #endif void init_scl() @@ -2413,9 +2613,8 @@ void init_scl() FLO(flo0) = 0.0; # else DEFER_INTS; - flo0 = must_malloc_cell(1L*sizeof(double), "real"); + flo0 = must_malloc_cell(1L*sizeof(double), (SCM)tc_dblr, "real"); REAL(flo0) = 0.0; - CAR(flo0) = tc_dblr; ALLOW_INTS; # endif # ifdef DBL_DIG @@ -2432,5 +2631,19 @@ void init_scl() dblprec = dblprec-1; } # endif /* DBL_DIG */ +# ifdef DBL_MANT_DIG + dbl_mant_dig = DBL_MANT_DIG; +# else + { + double fsum = 0.0, eps = 1.0; + int i = 0; + while (fsum != 1.0) { + eps = 0.5 * eps; + add1(eps, &fsum); + i++; + } + dbl_mant_dig = i; + } +# endif /* DBL_MANT_DIG */ #endif } @@ -1,5 +1,5 @@ .\" dummy line -.TH SCM "Sep 2 1998" +.TH SCM "Dec 5 1998" .UC 4 .SH NAME scm \- a Scheme Language Interpreter @@ -295,13 +295,17 @@ 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 @ ai.mit.edu) .br -Radey Shouman (Radey.Shouman @splashtech.com) +Radey Shouman (Radey.Shouman @ splashtech.com) .SH BUGS .SH SEE ALSO +The SCM home-page: +.br +http://swissnet.ai.mit.edu/~jaffer/SCM.html +.PP The Scheme specifications for details on specific procedures -(swissnet.ai.mit.edu:archive/scheme-reports/) or +(http://swissnet.ai.mit.edu/ftpdir/scheme-reports/) or .PP IEEE Std 1178-1990, .br @@ -315,8 +319,7 @@ Brian Harvey and Matthew Wright .br Simply Scheme: Introducing Computer Science_ .br -MIT Press, 1994 -ISBN 0-262-08226-8 +MIT Press, 1994 ISBN 0-262-08226-8 .PP R. Kent Dybvig, The Scheme Programming Language, .br @@ -1,18 +1,18 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - * +/* Copyright (C) 1990-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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,10 +36,10 @@ * * 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. + * If you do not wish that, delete this exception notice. */ -/* "scm.c" top level and interrupt code. +/* "scm.c" Initialization and interrupt code. Author: Aubrey Jaffer */ #include <signal.h> @@ -50,6 +50,8 @@ # include <io.h> #endif +/* See scm.h for definition of P */ + #ifndef STDC_HEADERS int alarm P((unsigned int)); int pause P((void)); @@ -60,9 +62,13 @@ # ifdef SVR4 # include <unistd.h> # endif +# ifdef __amigados__ +# include <unistd.h> +# endif #endif -void final_repl P((void)); +void init_sbrk P((void)); + void init_dynl P((void)); void init_edline P((void)); void init_eval P((void)); @@ -86,12 +92,11 @@ void init_time P((void)); void init_types P((void)); void init_unif P((void)); void reset_time P((void)); +void final_repl P((void)); void init_banner() { - fputs("SCM version ", stderr); - fputs(SCMVERSION, stderr); - fputs(", Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 \ + fputs("SCM version "SCMVERSION", Copyright (C) 1990-1999 \ Free Software Foundation.\n\ SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.\n\ This is free software, and you are welcome to redistribute it\n\ @@ -101,9 +106,10 @@ under certain conditions; type `(terms)' for details.\n", stderr); SCM scm_init_extensions() { #ifdef COMPILED_INITS - COMPILED_INITS; /* initialize statically linked add-ons */ + COMPILED_INITS; /* initialize statically linked add-ons */ #endif - return UNSPECIFIED; + init_user_scm(); + return UNSPECIFIED; } #if (__TURBOC__==1) @@ -141,24 +147,25 @@ SCM scm_init_extensions() /* PROF_SIGNAL appears below because it is the last signal defined in scm.h and in errmsgs in repl.c */ static struct { - int signo; SIGRETTYPE (*osig)(); SIGRETTYPE (*nsig)(); + int signo; SIGRETTYPE (*osig)(); SIGRETTYPE (*nsig)(); } sigdesc[PROF_SIGNAL - SIGNAL_BASE + 1]; void process_signals() { - int i = NUM_SIGNALS; - unsigned long mask = (1L << (i-1)); + int i, n; + unsigned long mask = 1L; if (output_deferred) { output_deferred = 0; lflush(sys_errp); } - if (SIG_deferred) - while (i--) { - if (SIG_deferred & mask) { - SIG_deferred &= ~mask; - handle_it(i + SIGNAL_BASE); - } - mask >>= 1; + for (n = 0; SIG_deferred && n < NUM_SIGNALS; n++) { + if (SIG_deferred & mask) { + i = n + SIGNAL_BASE; + SIG_deferred &= ~mask; + if (i != handle_it(i)) + wta(UNDEFINED, (char *)i, ""); } + mask <<= 1; + } deferred_proc = 0; } static char s_unksig[] = "unknown signal"; @@ -189,7 +196,7 @@ static SIGRETTYPE scmable_signal(sig) sigset_t set; sigemptyset(&set); sigaddset(&set, sig); - sigprocmask(SIG_UNBLOCK, &set, 0); + sigprocmask(SIG_UNBLOCK, &set, 0L); #endif SIG_deferred &= ~(1L << i); i += SIGNAL_BASE; @@ -213,12 +220,12 @@ static SIGRETTYPE scmable_signal(sig) #ifdef atarist # undef SIGALRM /* only available via MiNT libs */ #endif -#ifdef GO32 -# undef SIGALRM -#endif #ifdef __HIGHC__ # undef SIGALRM #endif +#ifdef LACK_SETITIMER +# undef SIGPROF +#endif #ifdef SIGALRM static char s_alarm[] = "alarm"; SCM lalarm(i) @@ -231,26 +238,53 @@ SCM lalarm(i) } # ifdef SIGPROF # include <sys/time.h> -static char s_proftimer[] = "profile-timer"; -SCM scm_proftimer(interval) - SCM interval; +static char s_setitimer[] = "setitimer"; +static SCM setitimer_iv[3]; +/* VALUE and INTERVAL are milliseconds */ +SCM scm_setitimer(which, value, interval) + SCM which, value, interval; { struct itimerval tval, oval; int w; - if (UNBNDP(interval)) - SYSCALL(w = getitimer(ITIMER_PROF, &oval);); +# 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; + } +# 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, ARG2, s_proftimer); + 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; - tval.it_value.tv_sec = tval.it_interval.tv_sec; - tval.it_value.tv_usec = tval.it_interval.tv_usec; - SYSCALL(w = setitimer(ITIMER_PROF, &tval, &oval);); + SYSCALL(w = setitimer(w, &tval, &oval);); } if (w) return BOOL_F; - return MAKINUM(oval.it_interval.tv_usec/1000 + - oval.it_interval.tv_sec*1000); + 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 @@ -290,34 +324,32 @@ SCM l_sleep(i) #endif #ifndef _WIN32 -# ifndef GO32 -# ifndef sun -# ifndef THINK_C +# ifndef sun +# ifndef THINK_C /* 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 vms return MAKINUM(gsignal((int)INUM(sig))); -# else -# ifndef __TURBOC__ -# ifdef STDC_HEADERS -# ifndef __MWERKS__ +# else +# ifndef __TURBOC__ +# ifdef STDC_HEADERS +# ifndef __MWERKS__ 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 +# else + return raise((int)INUM(sig)) ? BOOL_F : BOOL_T; # endif -} # endif +} # endif # endif #endif @@ -346,9 +378,6 @@ static SIGRETTYPE (*oldpipe) (); #endif int dumped = 0; /* Is this an invocation of unexec exe? */ -#ifndef LACK_SBRK -long scm_init_brk, scm_dumped_brk; -#endif #ifdef SHORT_ALIGN typedef short STACKITEM; @@ -358,7 +387,7 @@ typedef long STACKITEM; /* See scm.h for definition of P */ void init_storage P((STACKITEM *stack_start_ptr, long init_heap_size)); -void init_scm( iverbose, buf0stdin, init_heap_size ) +void init_scm(iverbose, buf0stdin, init_heap_size) int iverbose; int buf0stdin; long init_heap_size; @@ -370,8 +399,8 @@ void init_scm( iverbose, buf0stdin, init_heap_size ) init_tables(); init_storage(&i, init_heap_size); /* CONT(rootcont)->stkbse gets set here */ } - if (buf0stdin) CAR(def_inp) |= BUF0; - else CAR(def_inp) &= ~BUF0; + if (buf0stdin) SCM_PORTFLAGS(def_inp) |= BUF0; + else SCM_PORTFLAGS(def_inp) &= ~BUF0; if (!dumped) { init_features(); init_subrs(); @@ -379,11 +408,18 @@ void init_scm( iverbose, buf0stdin, init_heap_size ) init_scl(); init_eval(); init_time(); - init_repl( iverbose ); + init_repl(iverbose); init_unif(); } - else { - reset_time(); + 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 } } @@ -419,6 +455,9 @@ void init_signals() # ifdef SIGPROF init_sig1(PROF_SIGNAL, SIGPROF, scmable_signal); # endif +# ifdef SIGVTALRM + init_sig1(VTALRM_SIGNAL, SIGVTALRM, scmable_signal); +# endif #endif #ifdef SIGPIPE oldpipe = signal(SIGPIPE, SIG_IGN); @@ -461,7 +500,7 @@ void ignore_signals() { sigset_t set; sigfillset(&set); - sigprocmask(SIG_UNBLOCK, &set, 0); + sigprocmask(SIG_UNBLOCK, &set, 0L); } #endif } @@ -469,7 +508,7 @@ void ignore_signals() void unignore_signals() { int i = NUM_SIGNALS; - while (i--) + while (i--) if (sigdesc[i].signo) signal(sigdesc[i].signo, sigdesc[i].nsig); #ifdef ultrix @@ -482,7 +521,7 @@ void unignore_signals() void restore_signals() { - int i = NUM_SIGNALS; + int i; #ifdef ultrix siginterrupt(SIGINT, 0); siginterrupt(SIGALRM, 0); @@ -490,75 +529,65 @@ void restore_signals() siginterrupt(SIGPIPE, 0); #endif /* ultrix */ #ifdef SIGALRM +# ifndef SIGPROF alarm(0); /* kill any pending ALRM interrupts */ -# ifdef SIGPROF - scm_proftimer(BOOL_F); /* Turn off interval timer interrupt */ +# else + i = sizeof(setitimer_iv)/sizeof(SCM); + while (i--) + scm_setitimer(setitimer_iv[i], BOOL_F, BOOL_F); # endif #endif + i = NUM_SIGNALS; while (i--) - if (sigdesc[i].signo) + if (sigdesc[i].signo) signal(sigdesc[i].signo, sigdesc[i].osig); #ifdef SIGPIPE oldpipe = signal(SIGPIPE, SIG_IGN); #endif } -int run_scm(argc, argv, iverbose, buf0stdin, initpath) + +void scm_init_from_argv(argc, argv, script_arg, iverbose, buf0stdin) int argc; char **argv; + char *script_arg; int iverbose; int buf0stdin; - char *initpath; { - SCM i; - do { - i = 0L; - if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) { - char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2]; - do { - switch (*str) { - case DIGITS: - i = i * 10 + (*str - '0'); - if (i <= 10000L) continue; /* the size limit should match Init.scm */ - default: - i = 0L; - } - break; - } while (* ++str); - } - init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in Kb */ - progargs = EOL; - progargs = makfromstrs(argc, argv); - -#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 - } - init_signals(); - i = repl_driver(initpath); - restore_signals(); + long i = 0L; + if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) { + char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2]; + do { + switch (*str) { + case DIGITS: + i = i * 10 + (*str - '0'); + if (i <= 10000L) continue; /* the size limit should match Init.scm */ + default: + i = 0L; + } + break; + } while (* ++str); + } + 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); +} +void final_scm(freeall) + int freeall; +{ #ifdef TICKS - ticken = 0; + ticken = 0; #endif #ifdef FINALS - FINALS; /* call shutdown of extensions files */ + FINALS; /* call shutdown of extensions files */ #endif /* for compatability with older modules */ - /* call finalization of user extensions */ - while (num_finals--) (finals[num_finals])(); - final_repl(); - free_storage(); /* free all allocated memory */ - if (i) break; - dumped = 0; - if (2 <= iverbose) fputs(";RESTART\n", stderr); - } while (!0); - if (2 <= iverbose) fputs(";EXIT\n", stderr); - fflush(stderr); - return (int)INUM(i); + /* call finalization of user extensions */ + { + int k = num_finals; + while (k--) (finals[k])(); + } + final_repl(); + if (freeall) free_storage(); /* free all allocated memory */ } #ifdef __CYGWIN32__ @@ -623,162 +652,84 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath) #ifdef nosve # define DIRSEP "." #endif +#ifdef __amigados__ +# define SYSTNAME "amiga" +# define DIRSEP "/" +#endif +const char dirsep[] = DIRSEP; SCM softtype() { #ifdef nosve - return CAR(intern("nosve", 5)); + return CAR(sysintern("nosve", UNDEFINED)); #else - return CAR(intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1)); + return CAR(sysintern(SYSTNAME, UNDEFINED)); #endif } -/* The argument giving the location of a script file, or NULL. */ -static char *script_arg = 0; -/* The original argv[0], used to find executable. */ -static char *arg0 = 0; -char *execpath = 0; - -#ifndef RTL - -# ifndef DIRSEP -# define DIRSEP "/" -# endif -# ifndef GENERIC_NAME -# define GENERIC_NAME "scm" -# endif - -int main(argc, argv) - int argc; - char **argv; +int init_buf0(inport) + FILE *inport; { - int retval, buf0stdin = 0, nargc; - char *getenvpath, *implpath = 0, **nargv; -# ifdef macintosh - char *foo[] = { "scm" }; - if (argc == 0) { - argc = 1; - argv = foo; - } -# endif - execpath = 0; - arg0 = argv[0]; - /*{ - char ** argvv = argv; - for (;*argvv;argvv++) { - fputs(*argvv,stderr); - fputs(" ",stderr); - } - fputs("\n",stderr); - }*/ - /* The following applies only to SCSH style scripts, execpath - does not (cannot?) work properly for simple #! scripts */ - if ((nargv = script_process_argv(argc, argv))) { - script_arg = argv[2]; - nargc = script_count_argv(nargv); - } - else { - nargv = argv; - nargc = argc; - } -# ifndef LACK_SBRK - if (dumped) - scm_dumped_brk = (long)sbrk(0); - else - scm_init_brk = (long)sbrk(0); -# endif - if (!dumped) { -# ifndef nosve - getenvpath = getenv("SCM_INIT_PATH"); - if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L); - if (implpath) { - /* The value of the environment variable supersedes other - locations, as long as the file exists. */ - implpath = scm_try_path(implpath); - if (!implpath) { - fputs("Value of SCM_INIT_PATH (=\"", stderr); - fputs(getenvpath, stderr); - fputs("\") not found; Trying elsewhere\n", stderr); - } - } -# endif - if (!implpath) { - execpath = scm_find_executable(); - if (execpath) { - implpath = scm_find_impl_file(execpath, - GENERIC_NAME, INIT_FILE_NAME, DIRSEP); - /* fprintf(stderr, "scm_find_impl_file returned \"%s\"\n", implpath); fflush(stderr); */ - } - } -# ifdef IMPLINIT - /* Should IMPLINIT somehow be visible if we've been dumped? */ - if (!implpath) implpath = scm_cat_path(0L, IMPLINIT, 0L); -# endif - } -# ifndef GO32 - if (isatty(fileno(stdin))) { - buf0stdin = !0; /* stdin gets marked BUF0 in init_scm() */ -# ifndef NOSETBUF -# ifndef _DCC -# ifndef ultrix -# ifndef __WATCOMC__ -# ifndef macintosh -# if (__TURBOC__ != 1) -# ifndef _Windows - setbuf(stdin, 0); /* Often setbuf isn't actually required */ -# endif -# endif + if (isatty(fileno(inport))) { +#ifndef NOSETBUF +# ifndef _DCC +# ifndef ultrix +# ifndef __WATCOMC__ +# ifndef macintosh +# if (__TURBOC__ != 1) +# ifndef _Windows + setbuf(inport, 0L); /* Often setbuf isn't actually required */ # endif # endif # endif # endif - } # endif # endif - retval = run_scm(nargc, nargv, - (isatty(fileno(stdin)) && isatty(fileno(stdout))) - ? (nargc <= 1) ? 2 : 1 : 0, - buf0stdin, - implpath ? implpath : ""); - if (implpath) free(implpath); + return !0; /* stdin gets marked BUF0 in init_scm() */ + } +#endif + return 0; +} + +char *execpath = 0; +char s_no_execpath[] = "no execpath"; +#define s_execpath (s_no_execpath+3) +SCM scm_execpath(newpath) + SCM newpath; +{ + SCM retval = execpath ? makfrom0str(execpath) : BOOL_F; + if (UNBNDP(newpath)) + return retval; + if (FALSEP(newpath)) { + if (execpath) free(execpath); + execpath = 0; + return retval; + } + ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath); if (execpath) free(execpath); - execpath = 0; + execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1)); + ASSERT(execpath, newpath, NALLOC, s_execpath); + strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1); return retval; } -#endif - -char *scm_find_executable() +char *scm_find_execpath(argc, argv, script_arg) + int argc; + char **argv; + char *script_arg; { - char *execpath = 0; + char *exepath = 0; #ifndef macintosh # ifdef unix # ifndef MSDOS - if (script_arg) - execpath = script_find_executable(script_arg); + if (script_arg) exepath = script_find_executable(script_arg); # endif # endif - if (!execpath && arg0) execpath = dld_find_executable(arg0); - /* fprintf(stderr, "scm_find_executable: execpath = %s\n", execpath); fflush(stderr); */ + if (!exepath && argv[0]) exepath = dld_find_executable(argv[0]); +/*fprintf(stderr, "scm_find_execpath: argv[0] = %s; script_arg = %s; exepath = %s\n", argv[0], script_arg, exepath); fflush(stderr); */ #endif - return execpath; -} - -/* Initialized in repl.c */ -char s_scm_find_impl[] = "find-init-file"; -SCM scm_find_impl(execpath) - SCM execpath; -{ - SCM res; - char *implpath = 0; - ASSERT(NIMP(execpath) && STRINGP(execpath), execpath, ARG1, "find-init-file"); - implpath = scm_find_impl_file(CHARS(execpath), - GENERIC_NAME, INIT_FILE_NAME, DIRSEP); - res = (implpath ? makfrom0str(implpath) : BOOL_F); - if (implpath) free(implpath); - return res; + return exepath; } - #ifndef _Windows char s_system[] = "system"; SCM lsystem(cmd) @@ -859,20 +810,15 @@ static iproc subr1s[] = { #endif #ifdef SIGALRM {s_alarm, lalarm}, -# ifdef SIGPROF - {s_proftimer, scm_proftimer}, -# endif #endif #ifndef AMIGA # ifndef _Windows {s_sleep, l_sleep}, # endif #endif -#ifndef GO32 -# ifndef sun -# ifndef _WIN32 +#ifndef sun +# ifndef _WIN32 {s_raise, l_raise}, -# endif # endif #endif {0, 0}}; @@ -881,13 +827,22 @@ SCM *loc_features; void add_feature(str) char* str; { - *loc_features = cons(CAR(intern(str, strlen(str))), *loc_features); + *loc_features = cons(CAR(sysintern(str, UNDEFINED)), *loc_features); } void init_features() { loc_features = &CDR(sysintern("*features*", EOL)); init_iprocs(subr0s, tc7_subr_0); init_iprocs(subr1s, tc7_subr_1); + make_subr(s_execpath, tc7_subr_1o, scm_execpath); +#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)); +# endif +#endif #ifdef TICKS loc_tick_signal = &CDR(sysintern("ticks-interrupt", UNDEFINED)); make_subr(s_ticks, tc7_subr_1o, lticks); @@ -1,7 +1,7 @@ -SCM(Sep 2 1998) SCM(Sep 2 1998) +SCM(Dec 5 1998) SCM(Dec 5 1998) NAME @@ -67,7 +67,7 @@ OPTIONS -SCM(Sep 2 1998) SCM(Sep 2 1998) +SCM(Dec 5 1998) SCM(Dec 5 1998) 2, 3, 4, or 5 scm will require the features necces- @@ -133,7 +133,7 @@ SCM(Sep 2 1998) SCM(Sep 2 1998) -SCM(Sep 2 1998) SCM(Sep 2 1998) +SCM(Dec 5 1998) SCM(Dec 5 1998) are to be treated as program aguments. @@ -199,7 +199,7 @@ EXAMPLES -SCM(Sep 2 1998) SCM(Sep 2 1998) +SCM(Dec 5 1998) SCM(Dec 5 1998) mode. @@ -265,19 +265,23 @@ FILES -SCM(Sep 2 1998) SCM(Sep 2 1998) +SCM(Dec 5 1998) SCM(Dec 5 1998) in other programs. AUTHORS - Aubrey Jaffer (jaffer @ai.mit.edu) - Radey Shouman (Radey.Shouman @splashtech.com) + Aubrey Jaffer (jaffer @ ai.mit.edu) + Radey Shouman (Radey.Shouman @ splashtech.com) BUGS SEE ALSO + The SCM home-page: + http://swissnet.ai.mit.edu/~jaffer/SCM.html + The Scheme specifications for details on specific proce- - dures (swissnet.ai.mit.edu:archive/scheme-reports/) or + dures (http://swissnet.ai.mit.edu/ftpdir/scheme-reports/) + or IEEE Std 1178-1990, IEEE Standard for the Scheme Programming Language, @@ -321,10 +325,6 @@ SEE ALSO - - - - 5 @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. +/* Copyright (C) 1990-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 @@ -12,7 +12,7 @@ * * 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -56,10 +56,19 @@ typedef struct {SCM car, cdr;} cell; typedef struct {long sname;SCM (*cproc)();} subr; typedef struct {long sname;double (*dproc)();} dsubr; typedef struct {const char *string;SCM (*cproc)();} iproc; +typedef struct {const char *name;} subr_info; #include <stdio.h> #include "scmfig.h" +typedef struct { + sizet eltsize; + sizet len; + sizet alloclen; + sizet maxlen; + char *what; + char *elts;} scm_gra; + #ifdef USE_ANSI_PROTOTYPES # define P(s) s #else @@ -78,19 +87,31 @@ typedef struct { } smobfuns; typedef struct { + char *name; 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 (*fputs)P((char *s, FILE *p)); */ +/* sizet (*fwrite)P((char *s, sizet siz, sizet num, FILE *p)); */ + int (*fputs)P((const char *s, FILE *p)); + sizet (*fwrite)P((const void *s, sizet siz, sizet num, FILE *p)); int (*fflush)P((FILE *stream)); int (*fgetc)P((FILE *p)); int (*fclose)P((FILE *p)); } ptobfuns; typedef struct { + long flags; + int unread; + long line; + short col; + short colprev; + SCM data; +} port_info; + +typedef struct { SCM v; sizet base; } array; @@ -100,11 +121,6 @@ typedef struct { long inc; } array_dim; -#ifndef INUMS_ONLY -# define NUM_HP_MAX_REQ 4*sizeof(double) - -#endif - #ifdef FLOATS typedef struct {char *string;double (*cproc)P((double));} dblproc; # ifdef SINGLES @@ -144,7 +160,7 @@ typedef struct {SCM type;double *real;} dbl; #define IFLAGP(n) ((0x87 & (int)(n))==4) #define ISYMNUM(n) (((int)((n)>>9)) & 0x7f) #define ISYMVAL(n) ((int)((n)>>16)) -#define ISYMSETVAL(isym, val) ((isym) | ((long)(val) <<16)) +#define MAKISYMVAL(isym, val) ((isym) | ((long)(val) <<16)) #define ISYMCHARS(n) (isymnames[ISYMNUM(n)]) #define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) #define MAKISYM(n) (((n)<<9)+0x74L) @@ -211,15 +227,16 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; # define EOL MAKIFLAG(NUM_ISYMS+4) #endif #define UNSPECIFIED MAKIFLAG(NUM_ISYMS+5) +#define NUM_IFLAGS NUM_ISYMS+6 -/* Now some unnamed flags used as magic cookies by repl_driver. */ +/* Now some unnamed flags used as magic cookies by scm_top_level. */ /* Argument n can range from -4 to 16 */ #ifdef SHORT_INT # define COOKIE(n) (n) # define UNCOOK(f) (f) #else -# define COOKIE(n) MAKIFLAG(NUM_ISYMS+6+4+n) -# define UNCOOK(f) (ISYMNUM(f)-(NUM_ISYMS+6+4)) +# define COOKIE(n) MAKIFLAG(NUM_IFLAGS+4+n) +# define UNCOOK(f) (ISYMNUM(f)-(NUM_IFLAGS+4)) #endif #define FALSEP(x) (BOOL_F==(x)) @@ -267,8 +284,12 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; #else # define SCM_ESTK_FRLEN 2 #endif -#define SCM_ESTK_BASE (2*SCM_ESTK_FRLEN) +#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; +#define ENVP(x) (tc16_env==TYP16(x)) #define PORTP(x) (TYP7(x)==tc7_port) #define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN)) @@ -286,14 +307,15 @@ extern long tc16_env; #define CLOSEDP(x) (!OPENP(x)) #define STREAM(x) ((FILE *)(CDR(x))) #define SETSTREAM SETCDR -#define CRDYP(port) (CAR(port) & CRDY) -#define CLRDY(port) {CAR(port) &= CUC;} -#define CGETUN(port) ((unsigned char)SRS(CAR(port), 22)) -#define CUNGET(c, port) {CAR(port) += ((long)c<<22) + CRDY;} +#define CRDYP(port) ((CAR(port) & CRDY) && (EOF != CGETUN(port))) +#define CLRDY(port) (CAR(port) &= (SCM_PORTFLAGS(port) | (~0xf0000))) + /* #define CRDYP(port) (CAR(port) & CRDY) + #define CLRDY(port) (CAR(port) &= (~CRDY)) */ +#define CGETUN(port) (scm_port_table[SCM_PORTNUM(port)].unread) #define tc_socket (tc7_port | OPN) #define SOCKP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc_socket)) -#define SOCKTYP(x) (CAR(x)>>24) +#define SOCKTYP(x) (INUM(SCM_PORTDATA(x))) #define DIRP(x) (NIMP(x) && (TYP16(x)==(tc16_dir))) #define OPDIRP(x) (NIMP(x) && (CAR(x)==(tc16_dir | OPN))) @@ -328,14 +350,16 @@ extern long tc16_env; #define BIGP(x) (TYP16S(x)==tc16_bigpos) #define BIGSIGN(x) (0x0100 & (int)CAR(x)) #define BDIGITS(x) ((BIGDIG *)(CDR(x))) -#define NUMDIGS(x) ((sizet)(CAR(x)>>16)) -#define SETNUMDIGS(x, v, t) CAR(x) = (((v)+0L)<<16)+(t) +#define NUMDIGS(x) ((sizet)(((unsigned long)CAR(x))>>16)) +#define MAKE_NUMDIGS(v, t) ((((v)+0L)<<16)+(t)) +#define SETNUMDIGS(x, v, t) CAR(x) = MAKE_NUMDIGS(v, t) -#define SNAME(x) ((CAR(x)>>8)?(SCM)(heap_org+(CAR(x)>>8)):nullstr) +#define SNAME(x) ((char *)(subr_table[NUMDIGS(x)].name)) #define SUBRF(x) (((subr *)(SCM2PTR(x)))->cproc) #define DSUBRF(x) (((dsubr *)(SCM2PTR(x)))->dproc) #define CCLO_SUBR(x) (VELTS(x)[0]) #define CCLO_LENGTH NUMDIGS +#define CXR_OP SMOBNUM #define SYMBOLP(x) (TYP7S(x)==tc7_ssymbol) #define STRINGP(x) (TYP7(x)==tc7_string) @@ -343,8 +367,9 @@ extern long tc16_env; #define VECTORP(x) (TYP7(x)==tc7_vector) #define NVECTORP(x) (!VECTORP(x)) #define LENGTH(x) (((unsigned long)CAR(x))>>8) -#define LENGTH_MAX (0xffffffL) -#define SETLENGTH(x, v, t) CAR(x) = ((v)<<8)+(t) +#define LENGTH_MAX (((unsigned long)-1L)>>8) +#define MAKE_LENGTH(v, t) ((((v)+0L)<<8) + (t)) +#define SETLENGTH(x, v, t) CAR(x) = MAKE_LENGTH(v, t) #define CHARS(x) ((char *)(CDR(x))) #define UCHARS(x) ((unsigned char *)(CDR(x))) #define VELTS(x) ((SCM *)CDR(x)) @@ -364,8 +389,11 @@ extern long tc16_array; #define FREEP(x) (CAR(x)==tc_free_cell) #define NFREEP(x) (!FREEP(x)) -#define SMOBNUM(x) (0x0ff & (CAR(x)>>8)); -#define PTOBNUM(x) (0x0ff & (CAR(x)>>8)); +#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_PORTFLAGS(x) (scm_port_table[SCM_PORTNUM(x)].flags) +#define SCM_PORTDATA(x) (scm_port_table[SCM_PORTNUM(x)].data) #define DIGITS '0':case '1':case '2':case '3':case '4':\ case '5':case '6':case '7':case '8':case '9' @@ -402,6 +430,9 @@ extern long tc16_array; case tc7_subr_2o:case tc7_lsubr_2:case tc7_lsubr #define tcs_symbols tc7_ssymbol:case tc7_msymbol #define tcs_bignums tc16_bigpos:case tc16_bigneg +#define tcs_uves tc7_string:case tc7_bvect:\ + case tc7_uvect:case tc7_ivect:case tc7_svect:\ + case tc7_fvect:case tc7_dvect:case tc7_cvect #define tc3_cons_nimcar 0 #define tc3_cons_imcar 2:case 4:case 6 @@ -416,7 +447,8 @@ extern long tc16_array; /* spare 23 */ #define tc7_ivect 29 #define tc7_uvect 31 -/* spare 37 39 */ +#define tc7_svect 37 +/* spare 39 */ #define tc7_fvect 45 #define tc7_dvect 47 #define tc7_cvect 53 @@ -444,6 +476,7 @@ extern long tc16_array; #define tc16_apply (tc7_specfun | (0L<<8)) #define tc16_call_cc (tc7_specfun | (1L<<8)) #define tc16_cclo (tc7_specfun | (2L<<8)) +#define tc16_eval (tc7_specfun | (3L<<8)) #define tc16_flo 0x017f #define tc_flo 0x017fL @@ -459,14 +492,26 @@ extern long tc16_array; #define OPN (1L<<16) #define RDNG (2L<<16) #define WRTNG (4L<<16) -#define BUF0 (8L<<16) -#define CRDY (32L<<16) -#define CUC 0x001fffffL - -extern sizet numsmob, numptob; -extern smobfuns *smobs; -extern ptobfuns *ptobs; -extern ptobfuns pipob; +#define CRDY (8L<<16) +#define TRACKED (16L<<16) +#define BINARY (32L<<16) +#define BUF0 (64L<<16) + /* LSB is used for gc mark */ + +extern scm_gra subr_table_gra; +#define subr_table ((subr_info *)(subr_table_gra.elts)) +/* extern sizet numsmob, numptob; + extern smobfuns *smobs; + extern ptobfuns *ptobs; + extern ptobfuns pipob; */ +extern scm_gra smobs_gra; +#define numsmob (smobs_gra.len) +#define smobs ((smobfuns *)(smobs_gra.elts)) +extern scm_gra ptobs_gra; +#define numptob (ptobs_gra.len) +#define ptobs ((ptobfuns *)(ptobs_gra.elts)) +extern port_info *scm_port_table; + #define tc16_fport (tc7_port + 0*256L) #define tc16_pipe (tc7_port + 1*256L) #define tc16_strport (tc7_port + 2*256L) @@ -481,25 +526,31 @@ extern SCM sys_protects[]; #define def_outp sys_protects[4] #define def_errp sys_protects[5] #define sys_errp sys_protects[6] -#define listofnull sys_protects[7] -#define undefineds sys_protects[8] -#define nullvect sys_protects[9] -#define nullstr sys_protects[10] -#define progargs sys_protects[11] -#define transcript sys_protects[12] -#define rootcont sys_protects[13] -#define dynwinds sys_protects[14] +#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[15] -# define NUM_PROTECTS 16 +# define flo0 sys_protects[16] +# define NUM_PROTECTS 17 #else -# define NUM_PROTECTS 15 +# define NUM_PROTECTS 16 #endif /* now for connects between source files */ -extern sizet num_finals; -extern void (**finals)P((void)); +/* extern sizet num_finals; + extern void (**finals)P((void)); + extern sizet num_finals; */ +extern scm_gra finals_gra; +#define num_finals (finals_gra.len) +#define finals ((void (**)())(finals_gra.elts)) + extern unsigned char upcase[], downcase[]; extern SCM symhash; extern int symhash_dim; @@ -513,17 +564,20 @@ extern long mtrigger; extern SCM *loc_loadpath; extern SCM *loc_errobj; extern SCM loadport; -extern long linum; -extern int errjmp_bad, ints_disabled, output_deferred; +extern char *errjmp_bad; +extern int ints_disabled, output_deferred; extern unsigned long SIG_deferred; extern SCM exitval; extern int cursinit; extern unsigned int poll_count, tick_count; extern int dumped; extern char *execpath; +extern char s_no_execpath[]; extern int scm_verbose; #define verbose (scm_verbose+0) +extern const char dirsep[]; + /* strings used in several source files */ extern char s_read[], s_write[], s_newline[], s_system[]; @@ -545,7 +599,7 @@ extern char s_call_cc[]; extern void (* deferred_proc) P((void)); void process_signals P((void)); int handle_it P((int i)); -SCM must_malloc_cell P((long len, char *what)); +SCM must_malloc_cell P((long len, SCM c, char *what)); void must_realloc_cell P((SCM z, long olen, long len, char *what)); char *must_malloc P((long len, char *what)); char *must_realloc P((char *where, long olen, long len, char *what)); @@ -559,12 +613,17 @@ SCM obhash P((SCM obj)); SCM obunhash P((SCM obj)); unsigned long strhash P((unsigned char *str, sizet len, unsigned long n)); unsigned long hasher P((SCM obj, unsigned long n, sizet d)); -SCM repl_driver P((char *initpath)); SCM lroom P((SCM args)); +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_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)); void prinport P((SCM exp, SCM port, char *type)); -void repl P((void)); +SCM repl 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)); @@ -579,34 +638,50 @@ void intprint P((long n, int radix, SCM port)); void iprlist P((char *hdr, SCM exp, int tlr, SCM port, int writing)); void lputc P((int c, SCM port)); void lputs P((char *s, SCM port)); -int lfwrite P((char *ptr, sizet size, sizet nitems, SCM port)); +sizet lfwrite P((char *ptr, sizet size, sizet nitems, SCM port)); int lgetc P((SCM port)); void lungetc P((int c, SCM port)); char *grow_tok_buf P((SCM tok_buf)); -long mode_bits P((char *modes)); +long mode_bits P((char *modes, char *cmodes)); long time_in_msec P((long x)); SCM my_time P((void)); SCM your_time P((void)); void init_iprocs P((iproc *subra, int type)); + +void init_sbrk P((void)); +int init_buf0 P((FILE *inport)); +void scm_init_from_argv P((int argc, char **argv, char *script_arg, + int iverbose, int buf0stdin)); +void init_signals P((void)); +SCM scm_top_level P((char *initpath, SCM (*toplvl_fun)())); +void restore_signals P((void)); +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)); SCM scm_init_extensions P((void)); +void init_user_scm P((void)); void ignore_signals P((void)); void unignore_signals P((void)); -void free_storage P((void)); + void add_feature P((char *str)); int raprin1 P((SCM exp, SCM port, int writing)); SCM markcdr P((SCM ptr)); -SCM mark0 P((SCM ptr)); +#define mark0 (0) /*SCM mark0 P((SCM ptr)); */ SCM equal0 P((SCM ptr1, SCM ptr2)); sizet free0 P((CELLPTR ptr)); -void warn P((char *str1, char *str2)); +void scm_warn P((char *str1, char *str2)); void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr)); void wta 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_gsubr P((const char *name, int req, int opt, int rst, + SCM (*fcn)())); SCM closure P((SCM code, int nargs)); SCM makprom P((SCM code)); SCM force P((SCM x)); @@ -616,6 +691,7 @@ SCM relarb P((SCM arb)); SCM ceval P((SCM x, SCM env)); 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 acons P((SCM w, SCM x, SCM y)); @@ -672,6 +748,8 @@ SCM string2number P((SCM str, SCM radix)); SCM istr2flo P((char *str, long len, long radix)); SCM mkbig P((sizet nlen, int sign)); SCM mkstrport P((SCM pos, SCM str, long modes, char *caller)); +SCM mksafeport P((int maxlen, SCM port)); +int reset_safeport P((SCM sfp, int maxlen, SCM port)); SCM long2big P((long n)); SCM ulong2big P((unsigned long n)); SCM big2inum P((SCM b, sizet l)); @@ -727,14 +805,17 @@ SCM vector2list P((SCM v)); SCM for_each P((SCM proc, SCM arg1, SCM args)); SCM procedurep P((SCM obj)); SCM apply P((SCM proc, SCM arg1, SCM args)); +SCM scm_cvapply P((SCM proc, long n, SCM *argv)); +int scm_arity_check P((SCM proc, long argc, char *what)); 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 identp P((SCM obj)); +SCM identp P((SCM obj)); SCM ident2sym P((SCM id)); -SCM ident_eqp P((SCM id1, SCM id2, SCM env)); -SCM renamed_ident P((SCM id, SCM env)); +SCM ident_eqp P((SCM id1, SCM id2, SCM env)); +SCM env2tree P((SCM env)); +SCM renamed_ident P((SCM id, SCM env)); SCM input_portp P((SCM x)); SCM output_portp P((SCM x)); SCM cur_input_port P((void)); @@ -754,6 +835,8 @@ SCM newline P((SCM port)); SCM write_char P((SCM chr, SCM port)); 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)); SCM lgetenv P((SCM nam)); SCM prog_args P((void)); SCM makacro P((SCM code)); @@ -783,6 +866,7 @@ void ints_warn P((char *s1, char* s2, char *fname, int linum)); void add_final P((void (*final)(void))); SCM makcclo P((SCM proc, long len)); SCM make_uve P((long k, SCM prot)); +long scm_prot2type P((SCM prot)); SCM ra2contig P((SCM ra, int copy)); SCM sc2array P((SCM s, SCM ra, SCM prot)); SCM array_copy P((SCM src, SCM dst)); @@ -790,9 +874,6 @@ long aind P((SCM ra, SCM args, char *what)); SCM scm_eval_string P((SCM str)); SCM scm_load_string P((SCM str)); void scm_print_stack P((SCM stk)); -char * dld_find_executable P((const char* command)); -char * scm_find_executable P((void)); -SCM scm_find_impl P((SCM execpath)); SCM scm_unexec P((const SCM pathname)); SCM scm_log_aref P((SCM args)); SCM scm_log_aset P((SCM ra, SCM obj, SCM args)); @@ -808,8 +889,8 @@ SCM scm_bitfield P((SCM n, SCM start, SCM end)); SCM scm_logcount P((SCM n)); SCM scm_intlength P((SCM n)); SCM scm_copybit P((SCM index, SCM j1, SCM bit)); -SCM scm_bitif P((SCM mask, SCM n0, SCM n1)); -SCM scm_copybitfield P((SCM to, SCM start, SCM rest)); +SCM scm_bitif P((SCM mask, SCM n0, SCM n1)); +SCM scm_copybitfield P((SCM to, SCM start, SCM rest)); /* Defined in "rope.c" */ SCM long2num P((long n)); @@ -818,6 +899,7 @@ unsigned char num2uchar P((SCM num, char *pos, char *s_caller)); unsigned short num2ushort P((SCM num, char *pos, char *s_caller)); unsigned long num2ulong P((SCM num, char *pos, char *s_caller)); long num2long P((SCM num, char *pos, char *s_caller)); + short num2short P((SCM num, char *pos, char *s_caller)); double num2dbl P((SCM num, char *pos, char *s_caller)); SCM makfromstr P((char *src, sizet len)); SCM makfromstrs P((int argc, char **argv)); @@ -829,6 +911,7 @@ void scm_ldstr P((char *str)); int scm_ldfile P((char *path)); int scm_ldprog P((char *path)); unsigned long scm_addr P((SCM args, char *name)); +unsigned long scm_base_addr P((SCM v, char *name)); int scm_cell_p P((SCM x)); #ifdef FLOATS @@ -865,16 +948,16 @@ char * scm_try_path P((char *path)); char * script_find_executable P((const char *command)); char ** script_process_argv P((int argc, char **argv)); int script_count_argv P((char **argv)); -char * scm_find_impl_file P((char *exec_path, const char *generic_name, - const char *initname, const char *sep)); +char * find_impl_file P((char *exec_path, const char *generic_name, + const char *initname, const char *sep)); /* environment cache functions */ void scm_ecache_report P((void)); -void scm_estk_reset P((void)); -void scm_estk_grow P((sizet inc)); +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_egc P((void)); @@ -883,9 +966,10 @@ extern CELLPTR scm_ecache; extern VOLATILE long scm_ecache_index, scm_ecache_len; extern SCM scm_env, scm_env_tmp; extern SCM scm_egc_roots[]; -extern long scm_egc_root_index; +extern VOLATILE long scm_egc_root_index; extern SCM scm_estk; extern SCM *scm_estk_v, *scm_estk_ptr; +extern long scm_estk_size; #ifdef RECKLESS # define ASSERT(_cond, _arg, _pos, _subr) ; @@ -895,26 +979,27 @@ extern SCM *scm_estk_v, *scm_estk_ptr; # define ASRTGO(_cond, _label) if(!(_cond)) goto _label; #endif -#define ARGn 0 -#define ARG1 1 -#define ARG2 2 -#define ARG3 3 -#define ARG4 4 -#define ARG5 5 +#define ARGn 1 +#define ARG1 2 +#define ARG2 3 +#define ARG3 4 +#define ARG4 5 +#define ARG5 6 /* following must match entry indexes in errmsgs[] */ -#define WNA 6 -#define OVFLOW 7 -#define OUTOFRANGE 8 -#define NALLOC 9 -#define THRASH 10 -#define EXIT 11 -#define HUP_SIGNAL 12 -#define INT_SIGNAL 13 -#define FPE_SIGNAL 14 -#define BUS_SIGNAL 15 -#define SEGV_SIGNAL 16 -#define ALRM_SIGNAL 17 -#define PROF_SIGNAL 18 +#define WNA 7 +#define OVFLOW 8 +#define OUTOFRANGE 9 +#define NALLOC 10 +#define THRASH 11 +#define EXIT 12 +#define HUP_SIGNAL 13 +#define INT_SIGNAL 14 +#define FPE_SIGNAL 15 +#define BUS_SIGNAL 16 +#define SEGV_SIGNAL 17 +#define ALRM_SIGNAL 18 +#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)) @@ -927,8 +1012,6 @@ extern SCM *scm_estk_v, *scm_estk_ptr; ALLOW_INTS;} */ -int run_scm P((int argc, char **argv, int iverbose, int buf0stdin, char *initpath)); - #ifdef __cplusplus } #endif diff --git a/scm.info b/scm.info new file mode 100644 index 0000000..421167d --- /dev/null +++ b/scm.info @@ -0,0 +1,8099 @@ +This is Info file scm.info, produced by Makeinfo version 1.68 from the +input file 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 | +5d2 was released December 1999. 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: + +* Copying:: +* SCM Features:: +* SCM Authors:: +* 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 + +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: Bibliography, Prev: SCM Features, Up: Overview + +Authors +======= + +Aubrey Jaffer (jaffer @ ai.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: Bibliography, Prev: SCM Authors, Up: Overview + +Bibliography +============ + +[IEEE] + `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, + 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. + +[GUILE] + Tom Lord. The Guile Architecture for Ubiquitous Computing. + `Usenix Symposium on Tcl/Tk', 1995. + +[SLIB] + Todd R. Eigenschink, Dave Love, and Aubrey Jaffer. SLIB, The + Portable Scheme Library. Version 2c5, Jan 1999. + + *Note Top: (slib)Top. + +[JACAL] + Aubrey Jaffer. JACAL Symbolic Mathematics System. Version 1a9, + Jan 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.scm'. `build.scm' 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: + + * Use SCM on a different platform to run `build.scm' to create a + script to build SCM; + + * Use another implementation of Scheme to run `build.scm' 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 + +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/slib2c7.tar.gz | + + * ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz | + + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz | + +Unpack SLIB (`tar xzf slib2c7.tar.gz' or `unzip -ao slib2c7.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 | +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.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. + +* 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.scm'. + +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. + +*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'. + +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 + -| + #!/bin/sh + rm -f scmflags.h + echo '#define IMPLINIT "/home/jaffer/scm/Init5d2.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 + +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 + -| + $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 + + +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 + () processor-family operating-system () | + 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 | + + - 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 `Init5d2.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 + + * 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/Init5d2.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/Init5d2.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 + AMIGA SAS/C 5.10 or Dice C on AMIGA + __amigados__ 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 + 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 + 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: 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 \). + + +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 mSec (0 in gc) 767 cells work, 233 bytes 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 + #<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. `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. + +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 @ ai.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] [-ibvqmu] [-p number] + [-c expression] [-e expression] [-f filename] + [-l filename] [-r feature] [-- | - | -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 `Init5d2.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, `Init5d2.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. + +`Init5d2.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 KB + specifies that `scm' should allocate an initial heapsize of KB + 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: -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 + 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: -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. + + - 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 + +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 `Init5d2.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 | + 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: *R4RS-macro* + 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. + + - 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 | + ftp.gnu.org:pub/gnu/jacal/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 `Init5d2.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 `Init5d2.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 `Init5d2.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 `Init5d2.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 `Init5d2.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 + the CPU time is printed after each top level form evaluated. + + >= 3 + messages about heap growth are printed. + + >= 4 + garbage collection (*note Garbage Collection::.) messages are + printed. + + >= 5 + a warning will be printed for each top-level symbol which is + defined more than one time. + + - 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. `5d2') 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:: +* 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::.). + `*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 + 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)'. + + +File: scm.info, Node: Process Synchronization, Next: Files and Ports, Prev: Interrupts, Up: The Language + +Process Synchronization +======================= + + - 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: Soft Ports, 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. + + - 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. | + | + - 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: 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 + 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. + + - 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'. | + | + +File: scm.info, Node: Soft Ports, Next: Syntax Extensions, Prev: Files and Ports, 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: + + (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: 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 + 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 `casev' 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 `casev' clause during macro + expansion. `defconst' constants should be defined before use. + `casev' can be substituted for any correct use of `case'. + + (defconst unit '1) + (defconst semivowels '(w y)) + (casev (* 2 3) + ((2 3 5 7) 'prime) + ((,unit 4 6 8 9) 'composite)) ==> composite + (casev (car '(c d)) + ((a) 'a) + ((b) 'b)) ==> *unspecified* + (casev (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. + + +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 + 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: + + (define 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: + + `((lambda (variable1 ...) ...) value1 ...)' + `(let ((variable1 value1) (variable2 value2) ...) ...)' + `(letrec ((variable1 value1) ...) ...)' + result in a single enviroment frame: + ((variable1 ...) value1 ...) + + `(let ((variable1 value1)) ...)' + `(let* ((variable1 value1) ...) ...)' + result in an environment frame for each variable: + (variable1 . value1) (variable2 . value2) ... + + - 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. + + - 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 + +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 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. + + - 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 + Returns `#t' if identifiers ID1 and ID2 denote the same binding in + lexical environment ENV, and `#f' otherwise. ENV must be a + lexical environment passed to a macro transformer during macro + expansion. + + 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: + +* Compiling And Linking:: Hobbit +* Dynamic Linking:: +* Dump:: Create Fast-Booting Executables +* Numeric:: Numeric Language Extensions +* Arrays:: As in APL +* I/O-Extensions:: i/o-extensions +* Posix Extensions:: posix +* Regular Expression Pattern Matching:: regex +* Line Editing:: edit-line +* Curses:: Screen Control +* Sockets:: Cruise the Net + +* Menu: + +* Xlib: (Xlibscm). X Window Graphics. + + +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 + +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. This procedure will 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 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. + + 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. + +These procedures augment the standard capabilities in *Note Numerical +operations: (r5rs)Numerical operations. + + - 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: I/O-Extensions, 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 + MAKE-UNIFORM-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-uniform-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. + +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 + +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" + +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 + == + #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. + + - 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. + + - 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 + Returns an object that would produce an array of the same type as + ARRAY, if used as the PROTOTYPE for `make-uniform-array'. + + - Function: list->uniform-array RANK PROT LST + - Function: list->uniform-vector 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: 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 + 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 + 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 + - 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, + 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: I/O-Extensions, Next: Posix Extensions, Prev: Arrays, 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: 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" + "Init5d2.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: Regular Expression Pattern Matching, 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: 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: 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 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. + + - 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'. + +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: + + - 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 pro-cess 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: Posix 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_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 + spare G0100111 +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 `Init5d2.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. 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 the 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::. + + - 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 "Init5d2_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, 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/Init5d2.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 + `Init5d2.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 `Init5d2.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: 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. +* @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. +* @macroexpand1: Syntactic Hooks for Hygienic Macros. +* _ionbf: Files and Ports. +* _tracked: Files and Ports. | +* abort: Internal State. +* access: I/O-Extensions. +* acct: Posix Extensions. +* acons: Miscellaneous Procedures. +* acosh: Numeric. +* add-alias: Configure Module Catalog. +* 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. +* box: Curses Miscellany. +* CAR: Cells. +* casev: Syntax Extensions. +* 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-io-port: Files and Ports. +* 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. | +* compile-file: Compiling And Linking. +* 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. +* 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. +* environment->tree: Low Level Syntactic Hooks. +* 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_mark: Marking Cells. +* GCCDR: Marking Cells. +* GCTYP16: Marking Cells. +* 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. +* 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. +* 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. +* link: Posix Extensions. +* link-named-scm: Compiling And Linking. +* list->uniform-array: Uniform Array. +* list->uniform-vector: 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: Posix 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-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_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: Posix 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: Posix 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-io-file: Files and Ports. +* open-output-pipe: Posix Extensions. +* open-pipe: Posix Extensions. +* 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. +* pipe: Posix Extensions. +* port-column: Miscellaneous Procedures. | +* port-filename: Miscellaneous Procedures. | +* port-line: Miscellaneous Procedures. | +* PORTP: Ptob Cells. +* print <1>: Miscellaneous Procedures. +* print: Debugging Scheme Code. +* print-args: Debugging Scheme Code. +* 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. +* quit: SCM Session. +* raw: Terminal Mode Setting. +* read-char <1>: Input. +* read-char: Files and Ports. +* read:sharp: Low Level Syntactic Hooks. +* read:sharp-char: Low Level Syntactic Hooks. +* readdir: I/O-Extensions. +* readlink: Posix Extensions. +* 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: Posix Extensions. +* sync: Posix Extensions. +* syntax-quote: Syntactic Hooks for Hygienic Macros. +* 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-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. +* 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. +* 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: + +* *argv*: SCM Variables. +* *execpath: Embedding SCM. +* *interactive* <1>: Internal State. +* *interactive*: SCM Variables. +* *load-pathname*: Miscellaneous Procedures. +* *R4RS-macro*: SCM Variables. +* *scm-version*: Internal State. +* 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. +* 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_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. | +* edit-line: Build Options. | +* Embedding SCM: Embedding SCM. +* engineering-notation: Build Options. | +* 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. | +* 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. | + + + +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 + +End Tag Table @@ -2,6 +2,7 @@ @c %**start of header @setfilename scm.info @settitle SCM +@include version.txi @setchapternewpage on @c Choices for setchapternewpage are {on,off,odd}. @paragraphindent 0 @@ -24,13 +25,12 @@ @titlepage @title SCM @subtitle Scheme Implementation -@subtitle Version 5c3 -@subtitle April 1998 +@subtitle Version @value{SCMVERSION} @author by Aubrey Jaffer @page @vskip 0pt plus 1filll -Copyright @copyright{} 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Free Software Foundation +Copyright @copyright{} 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 @@ -51,13 +51,14 @@ by the author. @ifinfo -This manual documents the SCM Scheme implementation. The most recent +This manual documents the SCM Scheme implementation. SCM version +@value{SCMVERSION} was released @value{SCMDATE}. 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} -Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Free Software Foundation +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 @@ -102,7 +103,14 @@ machine independent platform for [JACAL], a symbolic algebra system. @noindent The most recent information about SCM can be found on SCM's @dfn{WWW} home page: + +@ifset html +<A HREF="http://swissnet.ai.mit.edu/~jaffer/SCM.html"> +@end ifset @center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html} +@ifset html +</A> +@end ifset @end iftex @menu @@ -152,7 +160,7 @@ Cambridge, MA 02138 @center Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 @center Free Software Foundation, Inc. -@center 675 Mass Ave, Cambridge, MA 02139, USA +@center 59 Temple Place, Suite 330, Boston, MA 02111, USA @noindent Permission to use, copy, modify, distribute, and sell this software and @@ -190,10 +198,10 @@ OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. @itemize @bullet @item -Conforms to Revised^4 Report on the Algorithmic Language Scheme [R4RS] +Conforms to Revised^5 Report on the Algorithmic Language Scheme [R5RS] and the [IEEE] P1178 specification. @item -Support for [SICP], [R2RS], [R3RS], and (proposed) [R5RS] scheme code. +Support for [SICP], [R2RS], [R3RS], and [R5RS] scheme code. @item Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Unix and similar systems. Supports ASCII and EBCDIC character sets. @@ -239,10 +247,11 @@ timing information printed interactively (the @code{verbose} function). @section Authors @table @b -@item Aubrey Jaffer (jaffer@@ai.mit.edu) +@item Aubrey Jaffer (jaffer @@ ai.mit.edu) Most of SCM. @item Radey Shouman -Arrays. @code{gsubr}s, compiled closures, and records. +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. @item Hugh Secker-Walker @@ -264,12 +273,12 @@ file @file{ChangeLog}, a log of changes that have been made to scm. @table @asis @item [IEEE] -@pindex IEEE +@cindex IEEE @cite{IEEE Standard 1178-1990. IEEE Standard for the Scheme Programming Language.} IEEE, New York, 1991. @item [Simply] -@pindex Simply +@cindex Simply Brian Harvey and Matthew Wright. @ifset html <A HREF="http://HTTP.CS.Berkeley.EDU/~bh/simply-toc.html"> @@ -281,13 +290,13 @@ Brian Harvey and Matthew Wright. MIT Press, 1994 ISBN 0-262-08226-8 @item [SICP] -@pindex 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] -@pindex R4RS +@cindex R4RS William Clinger and Jonathan Rees, Editors. @ifset html <A HREF="r4rs_toc.html"> @@ -304,8 +313,40 @@ pp. 1-55. Scheme}. @end ifinfo +@item [R5RS] +@cindex R5RS +Richard Kelsey and William Clinger and Jonathan (Rees, editors) +@ifset html +<A HREF="r5rs_toc.html"> +@end ifset +Revised(5) Report on the Algorithmic Language Scheme. +@ifset html +</A> +@end ifset +@cite{Higher-Order and Symbolic Computation} Volume 11, Number 1 (1998), +pp. 7-105, and +@cite{ACM SIGPLAN Notices} 33(9), September 1998. +@ifinfo + +@ref{Top, , , r5rs, Revised(5) Report on the Algorithmic Language +Scheme}. +@end ifinfo + +@item [Exrename] +@cindex Exrename +William Clinger +@ifset html +<A HREF="http://www.cs.indiana.edu/scheme-repository/doc.proposals.html"> +@end ifset +Hygienic Macros Through Explicit Renaming +@ifset html +</A> +@end ifset +@cite{Lisp Pointers} Volume IV, Number 4 (December 1991), +pp 17-23. + @item [GUILE] -@pindex GUILE +@cindex GUILE Tom Lord. @ifset html <A HREF="http://www.cygnus.com/library/ctr/guile.html"> @@ -317,7 +358,7 @@ The Guile Architecture for Ubiquitous Computing. @cite{Usenix Symposium on Tcl/Tk}, 1995. @item [SLIB] -@pindex SLIB +@cindex SLIB Todd R. Eigenschink, Dave Love, and Aubrey Jaffer. @ifset html <A HREF="slib_toc.html"> @@ -326,14 +367,14 @@ SLIB, The Portable Scheme Library. @ifset html </A> @end ifset -Version 2a3, June 1995. +Version 2c5, Jan 1999. @ifinfo @ref{Top, , , slib, SLIB}. @end ifinfo @item [JACAL] -@pindex JACAL +@cindex JACAL Aubrey Jaffer. @ifset html <A HREF="jacal_toc.html"> @@ -342,7 +383,7 @@ JACAL Symbolic Mathematics System. @ifset html </A> @end ifset -Version 1a5, April 1994. +Version 1a9, Jan 1999. @ifinfo @ref{Top, , , jacal, JACAL}. @@ -355,6 +396,9 @@ Version 1a5, April 1994. Documentation of @code{scm} extensions (beyond Scheme standards). Documentation on the internal representation and how to extend or include @code{scm} in other programs. +@item Xlibscm.texi +@itemx Xlibscm.info +Documentation of the Xlib - SCM Language X Interface. @end table @node Installing SCM, Operational Features, Overview, Top @@ -401,7 +445,7 @@ script to build SCM; Create your own script or @file{Makefile}. @item -Buy a SCM executable from jaffer@@ai.mit.edu. See the end of the +Buy a SCM executable from jaffer @@ ai.mit.edu. See the end of the @file{ANNOUNCE} file in the distribution for details. @item @@ -430,41 +474,41 @@ low priority. SLIB is available from the same sites as SCM: @ifclear html @itemize @bullet @item -swissnet.ai.mit.edu:/pub/scm/slib2c3.tar.gz -@item -prep.ai.mit.edu:/pub/gnu/jacal/slib2c3.tar.gz +swissnet.ai.mit.edu:/pub/scm/slib2c7.tar.gz @item -ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c3.tar.gz +ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz @item -ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c3.tar.gz +ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz @end itemize @end ifclear @ifset html -<A HREF="file://swissnet.ai.mit.edu/pub/scm/slib2c3.tar.gz"> -swissnet.ai.mit.edu:/pub/scm/slib2c3.tar.gz -</A> -<A HREF="file://prep.ai.mit.edu/pub/gnu/jacal/slib2c3.tar.gz"> -prep.ai.mit.edu:/pub/gnu/jacal/slib2c3.tar.gz +@itemize @bullet +@item +<A HREF="http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip"> +http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip </A> -<A HREF="file://ftp.maths.tcd.ie/pub/bosullvn/jacal/slib2c3.tar.gz"> -ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c3.tar.gz +@item +<A HREF="ftp://ftp.gnu.org/pub/gnu/jacal/slib2c7.tar.gz"> +ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz </A> -<A HREF="file://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2c3.tar.gz"> -ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2c3.tar.gz +@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> +@end itemize @end ifset @noindent -Unpack SLIB (@samp{tar xzf slib2c3.tar.gz} or @samp{unzip -ao -slib2c3.zip}) in an appropriate directory for your system; both +Unpack SLIB (@samp{tar xzf slib2c7.tar.gz} or @samp{unzip -ao +slib2c7.zip}) in an appropriate directory for your system; both @code{tar} and @code{unzip} will create the directory @file{slib}. @noindent Then create a file @file{require.scm} in the SCM @dfn{implementation-vicinity} (this is the same directory as where the -file @file{Init5c3.scm} is installed). @file{require.scm} should have the -contents: +file @file{Init@value{SCMVERSION}.scm} is installed). +@file{require.scm} should have the contents: @example (define (library-vicinity) "/usr/local/lib/slib/") @@ -501,7 +545,7 @@ 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. +additions to jaffer @@ ai.mit.edu. @menu * Invoking Build:: @@ -542,7 +586,7 @@ bash$ ./build.scm @print{} #!/bin/sh rm -f scmflags.h -echo '#define IMPLINIT "/home/jaffer/scm/Init5c3.scm"'>>scmflags.h +echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -554,8 +598,8 @@ gcc -rdynamic -o scm continue.o scm.o findexec.o script.o time.o \ @noindent To cross compile for another platform, invoke build with the @samp{-p} -or @samp{---platform=} option. This will create a script for the -platform named in the @samp{-p} or @samp{---platform=} option. +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 @@ -563,7 +607,7 @@ bash$ ./build.scm -p vms $DELETE scmflags.h $CREATE scmflags.h $DECK -#define IMPLINIT "/home/jaffer/scm/Init5c3.scm" +#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm" #define BIGNUMS #define FLOATS #define ARRAYS @@ -594,40 +638,7 @@ are all lower-case. The platforms defined by table @dfn{platform} in @file{build.scm} are: @end deffn @example -name processor operating-system compiler -symbol processor-family operating-system symbol -symbol atom symbol symbol -================= ================= ================= ================= -*unknown* *unknown* unix *unknown* -acorn-unixlib acorn *unknown* *unknown* -aix powerpc aix *unknown* -amiga-aztec m68000 amiga aztec -amiga-dice-c m68000 amiga dice-c -amiga-gcc m68000 amiga gcc -amiga-sas/c-5.10 m68000 amiga sas/c -atari-st-gcc m68000 atari.st gcc -atari-st-turbo-c m68000 atari.st turbo-c -borland-c-3.1 8086 ms-dos borland-c -djgpp i386 ms-dos gcc -gcc *unknown* unix gcc -highc.31 i386 ms-dos highc -hp-ux hp-risc hp-ux *unknown* -linux i386 linux gcc -linux-aout i386 linux gcc -microsoft-c 8086 ms-dos microsoft-c -microsoft-c-nt i386 ms-dos microsoft-c -microsoft-quick-c 8086 ms-dos microsoft-quick-c -ms-dos 8086 ms-dos *unknown* -os/2-cset i386 os/2 c-set++ -os/2-emx i386 os/2 gcc -sunos sparc sunos *unknown* -svr4 *unknown* unix *unknown* -turbo-c-2 8086 ms-dos turbo-c -unicos cray unicos *unknown* -unix *unknown* unix *unknown* -vms vax vms *unknown* -vms-gcc vax vms gcc -watcom-9.0 i386 ms-dos watcom +@include platform.txi @end example @deffn {Build Option} -o @var{filename} @@ -666,10 +677,10 @@ specifies that that @var{flag} will be put on linker command-lines. @deffn {Build Option} -s @var{pathname} @deffnx {Build Option} ---scheme-initial=@var{pathname} specifies that @var{pathname} should be the default location of the SCM -initialization file @file{Init5c3.scm}. SCM tries several likely locations -before resorting to @var{pathname} (@pxref{File-System Habitat}). -If not specified, the current directory (where build is building) is -used. +initialization file @file{Init@value{SCMVERSION}.scm}. SCM tries +several likely locations before resorting to @var{pathname} +(@pxref{File-System Habitat}). If not specified, the current directory +(where build is building) is used. @end deffn @deffn {Build Option} -c @var{pathname} @dots{} @@ -720,6 +731,8 @@ dos @item vms @item +amigados +@item system This option executes the compilation and linking commands through the @@ -743,137 +756,11 @@ specifies to build the given features into the executable. The defined features are: @table @dfn -@item lit -@itemx none -Lightweight -- no features - -@item 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 careful-interrupt-masking -Define this for extra checking of interrupt masking. This is for -debugging C code in @file{sys.c} and @file{repl.c}. - -@item debug -Turns on features @samp{cautious} @samp{careful-interrupt-masking} -@samp{stack-limit} and uses @code{-g} flags for debugging SCM source -code. - -@item reckless -If your scheme code runs without any errors you can disable almost all -error checking by compiling all files with @samp{reckless}. - -@item 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 bignums -Large precision integers. - -@item arrays -Use if you want arrays, uniform-arrays and uniform-vectors. - -@item array-for-each -array-map! and array-for-each (arrays must also be defined). - -@item inexact -Use if you want floating point numbers. - -@item engineering-notation -Use if you want floats to display in engineering notation (exponents -always multiples of 3) instead of scientific notation. - -@item 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 sicp -Use if you want to run code from: - -H. Abelson, G. J. Sussman, and J. Sussman, -Structure and Interpretation of Computer Programs, -The MIT Press, Cambridge, Massachusetts, USA - -@code{(eq? '() '#f)} is the major difference. +@c @itemx none +@c @cindex none +@c Lightweight -- no features -@item rev2-procedures -These procedures were specified in the @cite{Revised^2 Report on Scheme} -but not in @cite{R4RS}. - -@item record -The Record package provides a facility for user to define their own -record data types. See SLIB for documentation. - -@item compiled-closure -Use if you want to use compiled closures. - -@item generalized-c-arguments -@code{make_gsubr} for arbitrary (< 11) arguments to C functions. - -@item tick-interrupts -Use if you want the ticks and ticks-interrupt functions. - -@item i/o-extensions -Commonly available I/O extensions: @dfn{exec}, line I/O, file -positioning, file delete and rename, and directory functions. - -@item turtlegr -@dfn{Turtle} graphics calls for both Borland-C and X11 from -sjm@@ee.tut.fi. - -@item curses -For the @dfn{curses} screen management package. - -@item edit-line -interface to the editline or GNU readline library. - -@item regex -String regular expression matching. - -@item socket -BSD @dfn{socket} interface. - -@item posix -Posix functions available on all @dfn{Unix-like} systems. fork and -process functions, user and group IDs, file permissions, and @dfn{link}. - -@item unix -Those unix features which have not made it into the Posix specs: nice, -acct, lstat, readlink, symlink, mknod and sync. - -@item windows -Microsoft Windows executable. - -@item dynamic-linking -Be able to load compiled files while running. - -@item dump -Convert a running scheme program into an executable file. - -@item heap-can-shrink -Use if you want segments of unused heap to not be freed up after garbage -collection. This may reduce time in GC for *very* large working sets. - -@item 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 macro -C level support for hygienic and referentially transparent macros (R4RS -macros). +@include features.txi @end table @end deffn @@ -894,6 +781,7 @@ or both? @noindent (@pxref{Changing Scm} has instructions describing the C code format). @cindex foo.c +@cindex Extending Scm Suppose a C file @dfn{foo.c} has functions you wish to add to SCM. To compile and link your file at compile time, use the @samp{-c} and @samp{-i} options to build: @@ -903,7 +791,7 @@ bash$ build -c foo.c -i init_foo @print{} #!/bin/sh rm -f scmflags.h -echo '#define IMPLINIT "/home/jaffer/scm/Init5c3.scm"'>>scmflags.h +echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h echo '#define COMPILED_INITS init_foo();'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h @@ -922,7 +810,7 @@ bash$ build -t dll -c foo.c @print{} #!/bin/sh rm -f scmflags.h -echo '#define IMPLINIT "/home/jaffer/scm/Init5c3.scm"'>>scmflags.h +echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -934,7 +822,7 @@ gcc -shared -o foo.so foo.o -lm -lc @noindent Once @file{foo.c} compiles correctly (and your SCM build supports dynamic-loading), you can load the compiled file with the Scheme command -@code{(load "./foo.so")}. @xref{Configure Module Catalog} for how to +@code{(load "./foo.so")}. See @ref{Configure Module Catalog} for how to add a compiled dll file to SLIB's catalog. @node Installing Dynamic Linking, Configure Module Catalog, Building SCM, Installing SCM @@ -957,13 +845,13 @@ available from: @ifclear html @itemize @bullet @item -prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz +ftp.gnu.org:pub/gnu/dld-3.3.tar.gz @end itemize @end ifclear @ifset html -<A HREF="ftp://prep.ai.mit.edu/pub/gnu/dld-3.3.tar.gz"> -prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz +<A HREF="ftp://ftp.gnu.org/pub/gnu/dld-3.3.tar.gz"> +ftp.gnu.org:pub/gnu/dld-3.3.tar.gz </A> @end ifset @@ -1081,7 +969,7 @@ the compilation command lines or add a @code{#define @var{flag}} line to ------- ---------- ARM_ULIB Huw Rogers free unix library for acorn archimedes AZTEC_C Aztec_C 5.2a -__CYGWIN32__ cygwin32(?) +__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 @@ -1102,6 +990,7 @@ _AIX AIX operating system AMIGA SAS/C 5.10 or Dice C on AMIGA __amigados__ 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 @@ -1123,7 +1012,7 @@ 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 under Windows-NT +_WIN32 MS VisualC++ 4.2 and Cygwin (Win32 API) vms (and VMS) VAX-11 C under VMS. __alpha DEC Alpha processor @@ -1143,86 +1032,104 @@ vax VAX processor @node Problems Compiling, Problems Linking, Automatic C Preprocessor Definitions, Installing SCM @section Problems Compiling -@table @asis -@item FILE: PROBLEM -HOW TO FIX -@item *.c: include file not found -Correct the status of STDC_HEADERS in @file{scmfig.h} - -fix #include statement or add #define for system type to -@file{scmfig.h}. -@item *.c: Function should return a value in @dots{} -@itemx *.c: Parameter '@dots{}' is never used in @dots{} -@itemx *.c: Condition is always false in @dots{} -@itemx *.c: Unreachable code in function @dots{} -Ignore. -@item scm.c: assignment between incompatible types -change SIGRETTYPE in @file{scm.c}. -@item time.c: CLK_TCK redefined -incompatablility between <stdlib.h> and <sys/types.h>. remove -STDC_HEADERS in @file{scmfig.h}. - -edit <sys/types.h> to remove incompatability. -@item subr.c: Possibly incorrect assignment in function lgcd -Ignore. -@item sys.c: statement not reached -@itemx sys.c: constant in conditional expression -ignore -@item sys.c: `???' undeclared, outside of functions -#undef STDC_HEADERS in @file{scmfig.h}. -@item scl.c: syntax error -#define SYSTNAME to your system type in @file{scl.c} (softtype) -@end table +@multitable @columnfractions .10 .45 .45 +@item FILE +@tab PROBLEM / MESSAGE +@tab HOW TO FIX +@item *.c +@tab include file not found. +@tab Correct the status of @t{STDC_HEADERS} in scmfig.h. +@item +@tab +@tab fix @t{#include} statement or add @t{#define} for system type to scmfig.h. +@item *.c +@tab Function should return a value. +@tab Ignore. +@item +@tab Parameter is never used. +@tab +@item +@tab Condition is always false. +@tab +@item +@tab Unreachable code in function. +@tab +@item scm.c +@tab assignment between incompatible types. +@tab Change @t{SIGRETTYPE} in scm.c. +@item time.c +@tab CLK_TCK redefined. +@tab incompatablility between <stdlib.h> and <sys/types.h>. +@item +@tab +@tab Remove @t{STDC_HEADERS} in scmfig.h. +@item +@tab +@tab Edit <sys/types.h> to remove incompatability. +@item subr.c +@tab Possibly incorrect assignment in function lgcd. +@tab Ignore. +@item sys.c +@tab statement not reached. +@tab Ignore. +@item +@tab constant in conditional expression. +@tab +@item sys.c +@tab undeclared, outside of functions. +@tab @t{#undef STDC_HEADERS} in scmfig.h. +@item scl.c +@tab syntax error. +@tab @t{#define SYSTNAME} to your system type in scl.c (softtype). +@end multitable @node Problems Linking, Problems Running, Problems Compiling, Installing SCM @section Problems Linking -@table @asis +@multitable @columnfractions .5 .5 @item PROBLEM -HOW TO FIX +@tab HOW TO FIX @item _sin etc. missing. -uncomment LIBS in makefile -@end table +@tab Uncomment @t{LIBS} in makefile. +@end multitable @node Problems Running, Testing, Problems Linking, Installing SCM @section Problems Running -@table @asis +@multitable @columnfractions .5 .5 @item PROBLEM -HOW TO FIX +@tab HOW TO FIX @item Opening message and then machine crashes. -Change memory model option to C compiler (or makefile). - -Make sure @code{sizet} definition is correct in @file{scmfig.h}. - -Reduce size of HEAP_SEG_SIZE in @file{setjump.h}. -@item Input hangs -#define NOSETBUF -@item ERROR: heap: need larger initial -Need to increase the initial heap allocation using -a<kb> or -INIT_HEAP_SIZE. -@item ERROR: Could not allocate @dots{} -Check @code{sizet} definition. - -Use 32 bit compiler mode. - -Don't try to run as subproccess -@item remove @dots{} in scmfig.h and recompile scm -@itemx add @dots{} in scmfig.h and recompile scm -Do it and recompile files. -@item ERROR: @file{Init5c3.scm} not found -Assign correct IMPLINIT in makefile or @file{scmfig.h} or define -environment variable @code{SCM_INIT_PATH} to be the full pathname of -@file{Init5c3.scm} (@pxref{Installing SCM}). -@item WARNING: require.scm not found -define environment variable @code{SCHEME_LIBRARY_PATH} to be the full -pathname of the scheme library [SLIB] or change @code{library-vicinity} in -@file{Init5c3.scm} to point to library or remove. @xref{Installation, , , slib, -SLIB}. - -Make sure the value of @code{(library-vicinity)} has a trailing file -separator (like @key{/} or @key{\}). -@end table +@tab Change memory model option to C compiler (or makefile). +@item +@tab Make sure @t{sizet} definition is correct in scmfig.h. +@item +@tab Reduce the size of @t{HEAP_SEG_SIZE} in setjump.h. +@item Input hangs. +@tab @t{#define NOSETBUF} +@item ERROR: heap: need larger initial. +@tab Increase initial heap allocation using -a<kb> or @t{INIT_HEAP_SIZE}. +@item ERROR: Could not allocate. +@tab Check @t{sizet} definition. +@item +@tab Use 32 bit compiler mode. +@item +@tab Don't try to run as subproccess. +@item remove <FLAG> in scmfig.h and recompile scm. +@tab Do so and recompile files. +@item add <FLAG> in scmfig.h and recompile scm. +@tab +@item ERROR: Init@value{SCMVERSION}.scm not found. +@tab Assign correct @t{IMPLINIT} in makefile or scmfig.h. +@item +@tab Define environment variable @t{SCM_INIT_PATH} to be the full pathname of Init@value{SCMVERSION}.scm. +@item WARNING: require.scm not found. +@tab Define environment variable @t{SCHEME_LIBRARY_PATH} to be the full pathname of the scheme library [SLIB]. +@item +@tab Change @t{library-vicinity} in Init@value{SCMVERSION}.scm to point to library or remove. +@item +@tab Make sure the value of @t{(library-vicinity)} has a trailing file separator (like @t{/} or @t{\}). +@end multitable @node Testing, Reporting Problems, Problems Running, Installing SCM @section Testing @@ -1268,33 +1175,35 @@ of SCM running @file{pi.scm}. @samp{make bench} or @samp{make benchlit} appends the performance report to the file @file{BenchLog}, facilitating tracking effects of changes to SCM on performance. -@table @asis +@multitable @columnfractions .5 .5 @item PROBLEM -HOW TO FIX +@tab HOW TO FIX @item Runs some and then machine crashes. -See above under machine crashes. -@item Runs some and then ERROR: @dots{} (after a GC has happened) -Remove optimization option to C compiler and recompile. - -@code{#define SHORT_ALIGN} in @file{scmfig.h}. +@tab See above under machine crashes. +@item Runs some and then ERROR: @dots{} (after a GC has happened). +@tab Remove optimization option to C compiler and recompile. +@item +@tab @t{#define SHORT_ALIGN} in @file{scmfig.h}. @item Some symbol names print incorrectly. -Change memory model option to C compiler (or makefile). - -Check that @code{HEAP_SEG_SIZE} fits within @code{sizet}. - -Increase size of @code{HEAP_SEG_SIZE} (or @code{INIT_HEAP_SIZE} if it is -smaller than @code{HEAP_SEG_SIZE}). +@tab Change memory model option to C compiler (or makefile). +@item +@tab Check that @t{HEAP_SEG_SIZE} fits within @t{sizet}. +@item +@tab Increase size of @t{HEAP_SEG_SIZE} (or @t{INIT_HEAP_SIZE} if it is smaller than @t{HEAP_SEG_SIZE}). @item ERROR: Rogue pointer in Heap. -See above under machine crashes. +@tab See above under machine crashes. @item Newlines don't appear correctly in output files. -Check file mode (define OPEN_@dots{} in @file{Init5c3.scm} -@item Spaces or control characters appear in symbol names -Check character defines in @file{scmfig.h}. +@tab Check file mode (define OPEN_@dots{} in @file{Init@value{SCMVERSION}.scm}). +@item Spaces or control characters appear in symbol names. +@tab Check character defines in @file{scmfig.h}. @item Negative numbers turn positive. -Check SRS in @file{scmfig.h}. -@item VMS: Couldn't unwind stack -@itemx VAX: botched longjmp -@code{#define CHEAP_CONTIUATIONS} in @file{scmfig.h}. +@tab Check SRS in @file{scmfig.h}. +@item VMS: Couldn't unwind stack. +@tab @t{#define CHEAP_CONTIUATIONS} in @file{scmfig.h}. +@item VAX: botched longjmp. +@end multitable + +@table @asis @item 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 @@ -1311,7 +1220,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 @@ ai.mit.edu}. The bug report should include: @enumerate @@ -1346,18 +1255,18 @@ vendor is recommended. * Errors:: * Memoized Expressions:: * Internal State:: -* Shell Scripts:: +* Scripting:: @end menu @node Invoking SCM, SCM Options, Operational Features, Operational Features @section Invoking SCM -@quotation +@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{}]} -@end quotation +@end example @noindent Upon startup @code{scm} loads the file specified by by the environment @@ -1367,9 +1276,10 @@ variable @var{SCM_INIT_PATH}. If @var{SCM_INIT_PATH} is not defined or if the file it names is not present, @code{scm} tries to find the directory containing the executable file. If it is able to locate the executable, @code{scm} -looks for the initialization file (usually @file{Init5c3.scm}) in -platform-dependent directories relative to this directory. -@xref{File-System Habitat} for a blow-by-blow description. +looks for the initialization file (usually +@file{Init@value{SCMVERSION}.scm}) in platform-dependent directories +relative to this directory. See @ref{File-System Habitat} for a +blow-by-blow description. @noindent As a last resort (if initialization file cannot be located), the C @@ -1378,15 +1288,15 @@ compile parameter @var{IMPLINIT} (defined in the makefile or @noindent Unless the option @code{-no-init-file} or @code{--no-init-file} occurs -in the command line, @file{Init5c3.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. +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. @noindent -@file{Init5c3.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. +@file{Init@value{SCMVERSION}.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. @noindent This explanation applies to SCMLIT or other builds of SCM. @@ -1410,7 +1320,7 @@ distribution sets at @code{25000*sizeof(cell)}. @end deffn @deffn {Command Option} -no-init-file -@deffnx {Command Option} --no-init-file +@deffnx {Command Option} ---no-init-file Inhibits the loading of @file{ScmInit.scm} as described above. @end deffn @@ -1426,7 +1336,7 @@ enclosed in quotes. For instance @samp{"-e(newline)"}. 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 proposed [R5RS], respectively. +[R3RS], [R4RS], or [R5RS], respectively. @end deffn @deffn {Command Option} -l filename @@ -1455,16 +1365,16 @@ information. This is the same as @code{-p0}. @deffn {Command Option} -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 @code{-r} -@var{macropackage} before @code{-m} on the command line. +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 [R4RS] macro capability. [R4RS] macro capability can -be restored by a subsequent @code{-m} on the command line or from Scheme -code. +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 @@ -1490,7 +1400,7 @@ treated as program aguments. @end deffn @deffn {Command Option} - -@deffnx {Command Option} -- +@deffnx {Command Option} --- specifies that there are no more options on the command line. @end deffn @@ -1509,11 +1419,11 @@ it is invoked. Otherwise the (new) command line is processed as usual when the saved image is invoked. @end deffn -@deffn {Command Option} --help +@deffn {Command Option} ---help prints usage information and URL; then exit. @end deffn -@deffn {Command Option} --version +@deffn {Command Option} ---version prints version information and exit. @end deffn @@ -1542,8 +1452,8 @@ Loads @code{pretty-print} and @code{format} and enters interactive session. @item % scm -r5 -Loads @code{dynamic-wind}, @code{values}, and [R4RS] macros and enters -interactive (with macros) session. +Loads @code{dynamic-wind}, @code{values}, and syntax-rules macros and +enters interactive (with macros) session. @item % scm -r5 -r4 Like above but @code{rev4-optional-procedures} are also loaded. @@ -1554,7 +1464,8 @@ 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{Init5c3.scm} in the source directory. +code. The default is the file @file{Init@value{SCMVERSION}.scm} in the +source directory. @end defvr @defvr {Environment Variable} SCHEME_LIBRARY_PATH @@ -1562,8 +1473,8 @@ is the [SLIB] Scheme library directory. @end defvr @defvr {Environment Variable} HOME -is the directory where @file{Init5c3.scm} will look for the user -initialization file @file{ScmInit.scm}. +is the directory where @file{Init@value{SCMVERSION}.scm} will look for +the user initialization file @file{ScmInit.scm}. @end defvr @defvr {Environment Variable} EDITOR @@ -1580,9 +1491,10 @@ to [SLIB] @code{getopt}. @end defvar @defvar *R4RS-macro* -controls whether loading and interaction support [R4RS] 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. +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 +@code{-u} options. @end defvar @defvar *interactive* @@ -1687,6 +1599,7 @@ Typing @samp{(e)} will invoke the editor with the file of interest. After editing, the modified file will be loaded. @end table + @node Debugging Scheme Code, Errors, Editing Scheme Code, Operational Features @section Debugging Scheme Code @@ -1700,7 +1613,7 @@ If SCM is built with the @samp{CAUTIOUS} flag, then when an error occurs, a @dfn{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. @xref{Memoized Expressions} for how to read memoized +builtin. See @ref{Memoized Expressions} for how to read memoized expressions. Also as the result of the @samp{CAUTIOUS} flag, both @code{error} and @@ -1785,8 +1698,8 @@ offers source code debugging from GNU Emacs. PSD runs slowly, so start by instrumenting only a few functions at a time. @lisp -swissnet.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz -prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz +http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz +ftp.gnu.org:pub/gnu/jacal/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 @@ -1812,42 +1725,48 @@ with callback names after them can also be handled by Scheme code level, the default error handler (C code) is invoked. There are many other error messages which are not treated specially. -@enumerate 0 -@item -Wrong type in arg 0 -@item -Wrong type in arg 1 -@item -Wrong type in arg 2 -@item -Wrong type in arg 3 -@item -Wrong type in arg 4 -@item -Wrong type in arg 5 -@item +@table @dfn +@item ARGn +Wrong type in argument +@item ARG1 +Wrong type in argument 1 +@item ARG2 +Wrong type in argument 2 +@item ARG3 +Wrong type in argument 3 +@item ARG4 +Wrong type in argument 4 +@item ARG5 +Wrong type in argument 5 +@item WNA Wrong number of args -@item +@item OVFLOW numerical overflow -@item +@item OUTOFRANGE Argument out of range -@item -Could not allocate @code{(out-of-storage)} -@item -EXIT @code{(end-of-program)} -@item -hang up @code{(hang-up)} -@item -user interrupt @code{(user-interrupt)} -@item -arithmetic error @code{(arithmetic-error)} -@item +@item NALLOC +@code{(out-of-storage)} +@item THRASH +GC is @code{(thrashing)} +@item EXIT +@code{(end-of-program)} +@item HUP_SIGNAL +@code{(hang-up)} +@item INT_SIGNAL +@code{(user-interrupt)} +@item FPE_SIGNAL +@code{(arithmetic-error)} +@item BUS_SIGNAL bus error -@item +@item SEGV_SIGNAL segment violation -@item -alarm @code{(alarm-interrupt)} -@end enumerate +@item ALRM_SIGNAL +@code{(alarm-interrupt)} +@item VTALRM_SIGNAL +@code{(virtual-alarm-interrupt)} +@item PROF_SIGNAL +@code{(profile-alarm-interrupt)} +@end table @defvar errobj When SCM encounters a non-fatal error, it aborts evaluation of the @@ -1884,14 +1803,14 @@ signal warnings and errors. @defun warn arg1 arg2 arg3 @dots{} Alias for @ref{System, slib:warn, , slib, SLIB}. Outputs an error message containing the arguments. @code{warn} is defined in -@file{Init5c3.scm}. +@file{Init@value{SCMVERSION}.scm}. @end defun @defun error arg1 arg2 arg3 @dots{} Alias for @ref{System, slib:error, , slib, SLIB}. Outputs an error message containing the arguments, aborts evaluation of the current form and resumes the top level read-eval-print loop. @code{Error} is defined -in @file{Init5c3.scm}. +in @file{Init@value{SCMVERSION}.scm}. @end defun @noindent @@ -1899,7 +1818,7 @@ If SCM is built with the @samp{CAUTIOUS} flag, then when an error occurs, a @dfn{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. @xref{Memoized Expressions} for how to read memoized +builtin. See @ref{Memoized Expressions} for how to read memoized expressions. @noindent @@ -1912,8 +1831,8 @@ systems. @defun stack-trace Prints information describing the stack of partially evaluated expressions. @code{stack-trace} returns @code{#t} if any lines were -printed and @code{#f} otherwise. See @file{Init5c3.scm} for an example of -the use of @code{stack-trace}. +printed and @code{#f} otherwise. See @file{Init@value{SCMVERSION}.scm} +for an example of the use of @code{stack-trace}. @end defun @node Memoized Expressions, Internal State, Errors, Operational Features @@ -1943,7 +1862,7 @@ top-level have @r{#@@} prepended. @noindent For instance, @code{open-input-file} is defined as follows in -@file{Init5c3.scm}: +@file{Init@value{SCMVERSION}.scm}: @example (define (open-input-file str) @@ -1992,7 +1911,7 @@ open-input-file @result{} @end example -@node Internal State, Shell Scripts, Memoized Expressions, Operational Features +@node Internal State, Scripting, Memoized Expressions, Operational Features @section Internal State @defvar *interactive* @@ -2001,7 +1920,7 @@ interactive, or should quit after the command line is processed. @var{*interactive*} is controlled directly by the command-line options @samp{-b}, @samp{-i}, and @samp{-s} (@pxref{Invoking SCM}). If none of these options are specified, the rules to determine interactivity are -more complicated; see @file{Init5c3.scm} for details. +more complicated; see @file{Init@value{SCMVERSION}.scm} for details. @end defvar @defun abort @@ -2057,7 +1976,7 @@ also gives the hexadecimal heap segment and stack bounds. @end defun @defvr Constant *scm-version* -Contains the version string (e.g. @file{5c3}) of SCM. +Contains the version string (e.g. @file{@value{SCMVERSION}}) of SCM. @end defvr @subsection Executable path @@ -2085,45 +2004,65 @@ For other configuration constants and procedures @xref{Configuration, , , slib, SLIB}. -@node Shell Scripts, , Internal State, Operational Features -@section Shell Scripts +@node Scripting, , Internal State, Operational Features +@section Scripting @menu -* Unix Shell Scripts:: Same old same old -* SCSH scripts:: From Olin Shivers' Scheme Shell -* MS-DOS Compatible Scripts:: Run under both MS-DOS and Unix +* 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 @end menu -@node Unix Shell Scripts, SCSH scripts, Shell Scripts, Shell Scripts -@subsection Unix Shell Scripts +@node Unix Scheme Scripts, MS-DOS Compatible Scripts, Scripting, Scripting +@subsection Unix Scheme Scripts @noindent In reading this section, keep in mind that the first line of a script file has (different) meanings to SCM and the operating system (@code{execve}). -@deftp file #! interpreter -@deftpx file #! interpreter arg +@deftp file #! interpreter \ @dots{} -@tindex Shell Script -@tindex Shell-Script +@tindex Scheme Script +@tindex Scheme-Script +@tindex meta-argument On unix systems, a @dfn{Shell-Script} is a file (with execute permissions) whose first two characters are @samp{#!}. The @var{interpreter} argument must be the pathname of the program to process the rest of the file. The directories named by environment variable @code{PATH} are @emph{not} searched to find @var{interpreter}. -The @var{arg} is an optional argument encapsulating the rest of the -first line's contents, if not just whitespace. When executing a shell-script, the operating system invokes -@var{interpreter} with (if present) @var{arg}, the pathname of the shell -script file, and then any arguments which the shell-script was invoked -with. +@var{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 @samp{#!} and the first character of +@var{interpreter} (@samp{/}). The @var{interpreter} name is followed by +@samp{ \}; SCM substitutes the second line of @var{file} for @samp{\} +(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 @var{*script*} will be +set to the script pathname. The last argument before @samp{!#} on the +second line should be @samp{-}; SCM will load the script file, preserve +the unprocessed arguments, and set @var{*argv*} to a list of the script +pathname and the unprocessed arguments. + +Note that the interpreter, not the operating system, provides the +@samp{\} substitution; this will only take place if @var{interpreter} is +a SCM or SCSH interpreter. @end deftp -@deffn {Read syntax} #! ignored -When the first two characters of the file being loaded are @code{#!}, -the first line of that file will be ignored. +@c @deffn {Read syntax} #! ignored +@c When the first two characters of the file being loaded are @code{#!}, +@c the first line of that file will be ignored. + +@deffn {Read syntax} #! ignored !# +When the first two characters of the file being loaded are @code{#!} and +a @samp{\} is present before a newline in the file, all characters up +to @samp{!#} will be ignored by SCM @code{read}. @end deffn @noindent @@ -2131,167 +2070,82 @@ 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 -@end example -or -@example -#!/usr/local/bin/scm -l +#!/usr/local/bin/scm \ @end example @noindent -When such a file is invoked, /usr/local/bin/scm is executed with the -name of this file as the first argument. -@example -#!/usr/local/bin/scm -(print (program-arguments)) -(quit) -@result{} ("scm" "./script") -@end example +The following Scheme-Script prints factorial of its argument: @example -#!/usr/local/bin/scm -l -(print (program-arguments)) -@result{} ("scm" "-l" "./script") -@end example +#! /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)))) -@noindent -The following shell-script will print factorial of its argument: -@example -#!/usr/local/bin/scm -l (define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n))))) -(print (fact (string->number (cadddr (program-arguments))))) +(go-script) @end example @example -./fact 6 -@result{} 720 +./fact 32 +@result{} +263130836933693530167218012160000000 @end example @noindent -Shell-scripts suffer from several drawbacks: -@itemize @bullet -@item -Some Unixes limit the length of the @samp{#!} interpreter line to the -size of an object file header, which can be as small as 32 bytes. -@item -A full, explicit pathname must be specified, perhaps requiring more than -32 bytes and making scripts vulnerable to breakage when programs are -moved. -@item -At most one argument is parsed from the first line of the shell-script. -Its position is fixed between the interpreter and any command line -arguments. -@end itemize - -@noindent -The following approach solves these problems at the expense of slower -startup. Make @samp{#!/bin/sh} the first line and prepend every -subsequent line to be executed by the shell with @code{:;} (@code{type;} -in older versions). The last line to be executed by the shell should -contain an @dfn{exec} command; @code{exec} tail-calls its argument. - -@noindent -@code{/bin/sh} is thus invoked with the name of the script file, which -it executes as a *sh script. Usually the second line starts -@samp{:;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. - -@noindent -The second line of the script file does not have the length restriction -mentioned above. Also, @code{/bin/sh} searches the directories listed -in the `PATH' environment variable for @samp{scm}, eliminating the need -to use absolute locations in order to invoke a program. +If the wrong number of arguments is given, @code{fact} prints its +@var{argv} with usage information. @example -#!/bin/sh -:;exec scm -l$0 $* -(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n))))) -(print (fact (string->number (caddr (program-arguments))))) -@end example - -@example -./fact 6 -@result{} 720 -@end example - -@node SCSH scripts, MS-DOS Compatible Scripts, Unix Shell Scripts, Shell Scripts -@subsection SCSH scripts - -@noindent -Olin Shivers' @dfn{Scheme Shell} project solves the one-argument -limitation by introducing @samp{\} as a @dfn{meta-argument}. This -extensions is also supported by SCM. - -@deftp file #! interpreter \ - -@tindex Shell Script -@tindex shell-script -@tindex meta-argument -This is an enhancement to the shell-script format. When the optional -@var{arg} is @samp{\}, the @var{interpreter} substitutes the second -line of @var{file} for @samp{\}, then appends any arguments given on -the command line invoking this shell-script. -@end deftp - -@deffn {Read syntax} #! ignored !# -When the first two characters of the file being loaded are @code{#!} and -a @samp{\} is present before a newline in the file, all characters up -to @samp{!#} will be ignored by SCM @code{read}. -@end deffn - -@noindent -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 \ -@end example - -@noindent -The following shell-script will print its expanded argument list, then -factorial of its argument: - -@example -#!/usr/local/bin/scm \ - -p0 -l !# -(print (program-arguments)) -(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n))))) -(print (fact (string->number (list-ref (program-arguments) *optind*)))) -@end example +./fact 3 2 +@print{} +("./fact" "3" "2") +Usage: fact n + Returns the factorial of N. -@example -./fact 5 -@result{} ("scm" "-p0" "-l" "./fact" "5") -120 +http://swissnet.ai.mit.edu/~jaffer/SLIB.html @end example -@node MS-DOS Compatible Scripts, , SCSH scripts, Shell Scripts +@node MS-DOS Compatible Scripts, Unix Shell Scripts, Unix Scheme Scripts, Scripting @subsection MS-DOS Compatible Scripts @noindent -It turns out that we can create shell-scripts which run both under unix +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: @code{#!.bat} and @code{!#.exe}. -@pindex !# -@pindex !#.exe -@pindex #! -@pindex #!.bat +@cindex !# +@cindex !#.exe +@cindex #! +@cindex #!.bat @noindent With these two programs installed in a @code{PATH} directory, we have the following syntax for @var{<program>.BAT} files. -@deftp file #! interpreter \ %0 %1 %2 %3 %4 %5 %6 %7 %8 +@deftp file #! interpreter \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 -@tindex Shell Script -@tindex shell-script -The first two characters of the shell-script are @samp{#!}. The +@tindex Scheme Script +@tindex Scheme-Script +The first two characters of the Scheme-Script are @samp{#!}. The @var{interpreter} can be either a unix style program path (using @samp{/} between filename components) or a DOS program name or path. -The rest of the first line of the shell-script should be literally -@samp{\ %0 %1 %2 %3 %4 %5 %6 %7 %8}, as shown. +The rest of the first line of the Scheme-Script should be literally +@w{@samp{\ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9}}, as shown. If @var{interpreter} has @samp{/} in it, @var{interpreter} is converted to a DOS style filename (@samp{/} @result{} @samp{\}). @@ -2307,22 +2161,85 @@ Once the @var{interpreter} executable path is found, arguments are processed in the manner of scheme-shell, with the all the text after the @samp{\} taken as part of the meta-argument. More precisely, @code{#!} calls @var{interpreter} with any options on the second line of the -shell-script up to @samp{!#}, the name of the shell-script file, and +Scheme-Script up to @samp{!#}, the name of the Scheme-Script file, and then any of at most 8 arguments given on the command line invoking this -shell-script. +Scheme-Script. @end deftp @noindent -The following shell-script will print its expanded argument list, then -factorial of its argument. This shell-script in both MS-DOS and unix +The previous example Scheme-Script works in both MS-DOS and unix systems. + + +@node Unix Shell Scripts, , MS-DOS Compatible Scripts, Scripting +@subsection Unix Shell Scripts + +@noindent +Scheme-scripts suffer from two drawbacks: +@itemize @bullet +@item +Some Unixes limit the length of the @samp{#!} interpreter line to the +size of an object file header, which can be as small as 32 bytes. +@item +A full, explicit pathname must be specified, perhaps requiring more than +32 bytes and making scripts vulnerable to breakage when programs are +moved. +@end itemize + +@noindent +The following approach solves these problems at the expense of slower +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. + +@noindent +@code{/bin/sh} is thus invoked with the name of the script file, which +it executes as a *sh script. Usually the second line starts +@samp{:;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. + +@noindent +The second line of the script file does not have the length restriction +mentioned above. Also, @code{/bin/sh} searches the directories listed +in the `PATH' environment variable for @samp{scm}, eliminating the need +to use absolute locations in order to invoke a program. + +@noindent +The following example additionally sets @var{*script*} to the script +argument, making it compatible with the scheme code of the previous +example. + @example -#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 - -p1 -l !# -(print (program-arguments)) +#! /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))))) -(print (fact (string->number (list-ref (program-arguments) *optind*)))) + +(go-script) +@end example + +@example +./fact 6 +@result{} 720 @end example @@ -2330,7 +2247,7 @@ systems. @chapter The Language @menu -* Standards Compliance:: Links to sections in [R4RS] and [SLIB] +* Standards Compliance:: Links to sections in [R5RS] and [SLIB] * Miscellaneous Procedures:: * Time:: Both real time and processor time * Interrupts:: and exceptions @@ -2357,41 +2274,22 @@ Language.} @end ifclear and @ifset html -[R4RS], <A HREF="r4rs_toc.html"> +[R5RS], <A HREF="r5rs_toc.html"> @end ifset -@cite{Revised(4) Report on the Algorithmic Language Scheme}. +@cite{Revised(5) Report on the Algorithmic Language Scheme}. @ifset html </A> @end ifset @ifinfo -@ref{Top, , , r4rs, Revised(4) Report on the Algorithmic Language +@ref{Top, , , r5rs, Revised(5) Report on the Algorithmic Language Scheme}. @end ifinfo All the required features of these specifications are supported. Many of the optional features are supported as well. -@subheading Optionals of [R4RS] Supported by SCM +@subheading Optionals of [R5RS] Supported by SCM @table @asis -@item two clause @code{if}: @code{(if <test> <consequent>)} -@xref{Conditionals, , , r4rs, Revised(4) Scheme}. -@item @code{let*} -@itemx named @code{let} -@xref{Binding constructs, , , r4rs, Revised(4) Scheme}. -@item @code{do} -@xref{Iteration, , , r4rs, Revised(4) Scheme}. -@item All varieties of @code{define} -@xref{Definitions, , , r4rs, Revised(4) Scheme}. -@item @code{list-tail} -@xref{Pairs and lists, , , r4rs, Revised(4) Scheme}. -@item @code{string-copy} -@itemx @code{string-fill!} -@xref{Strings, , , r4rs, Revised(4) Scheme}. -@item @code{make-vector} of two arguments -@itemx @code{vector-fill!} -@xref{Vectors, , , r4rs, Revised(4) Scheme}. -@item @code{apply} of more than 2 arguments -@xref{Control features, , , r4rs, Revised(4) Scheme}. @item @code{-} and @code{/} of more than 2 arguments @itemx @code{exp} @itemx @code{log} @@ -2411,29 +2309,23 @@ Many of the optional features are supported as well. @itemx @code{angle} @itemx @code{exact->inexact} @itemx @code{inexact->exact} -@xref{Numerical operations, , , r4rs, Revised(4) Scheme}. -@item @code{delay} -@itemx @code{force} -@xref{Control features, , , r4rs, Revised(4) Scheme}. +@xref{Numerical operations, , , r5rs, Revised(5) Scheme}. @itemx @code{with-input-from-file} @itemx @code{with-output-to-file} -@xref{Ports, , , r4rs, Revised(4) Scheme}. -@itemx @code{char-ready?} -@xref{Input, , , r4rs, Revised(4) Scheme}. +@xref{Ports, , , r5rs, Revised(5) Scheme}. +@itemx @code{load} @itemx @code{transcript-on} @itemx @code{transcript-off} -@xref{System interface, , , r4rs, Revised(4) Scheme}. +@xref{System interface, , , r5rs, Revised(5) Scheme}. @end table -@subheading Optionals of [R4RS] not Supported by SCM +@subheading Optionals of [R5RS] not Supported by SCM @table @asis @item @code{numerator} @itemx @code{denominator} @itemx @code{rationalize} -@xref{Numerical operations, , , r4rs, Revised(4) Scheme}. -@item [R4RS] appendix Macros -@xref{Macros, , , r4rs, Revised(4) Scheme}. +@xref{Numerical operations, , , r5rs, Revised(5) Scheme}. @end table @subheading [SLIB] Features of SCM and SCMLIT @@ -2450,10 +2342,6 @@ See SLIB file @file{Template.scm}. @xref{Time, , , slib, SLIB}. @item defmacro @xref{Defmacro, , , slib, SLIB}. -@item dynamic-wind -@xref{Dynamic-Wind, , , slib, SLIB}. -@item eval -@xref{System, , , slib, SLIB}. @item getenv @itemx system @xref{System Interface, , , slib, SLIB}. @@ -2517,6 +2405,18 @@ program-vicinity, , slib, SLIB}. Returns the current line number of the file currently being loaded. @end defun +@defun port-filename port +Returns the filename @var{port} was opened with. If @var{port} is +not open to a file the result is unspecified. +@end defun + +@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. +@end defun + @defun eval obj Alias for @ref{System, eval, , slib, SLIB}. @end defun @@ -2529,7 +2429,7 @@ evaluating it. @code{eval-string} does not change @defun load-string str Reads and evaluates all the expressions from @var{str}. As with -@code{load}, the value returned is unspecified. @code{eval-string} does +@code{load}, the value returned is unspecified. @code{load-string} does not change @code{*load-pathname*} or @code{line-number}. @end defun @@ -2627,13 +2527,36 @@ If @var{secs} is 0, any alarm request is canceled. Otherwise an time. ALARM is not supported on all systems. @end defun +@defun milli-alarm millisecs interval +@defunx virtual-alarm millisecs interval +@defunx profile-alarm millisecs interval +@code{milli-alarm} is similar to @code{alarm}, except that the first +argument @var{millisecs}, and the return value are measured in +milliseconds rather than seconds. If the optional argument +@var{interval} is supplied then alarm interrupts will be scheduled every +@var{interval} milliseconds until turned off by a call to +@code{milli-alarm} or @code{alarm}. + +@code{virtual-alarm} and @code{profile-alarm} are similar. +@code{virtual-alarm} decrements process execution time rather than real +time, and causes @code{SIGVTALRM} to be signaled. +@code{profile-alarm} decrements both process execution time and +system execution time on behalf of the process, and causes +@code{SIGPROF} to be signaled. + +@code{milli-alarm}, @code{virtual-alarm}, and @code{profile-alarm} are +supported only on systems providing the @code{setitimer} system call. +@end defun + @deffn {Callback procedure} user-interrupt @dots{} @deffnx {Callback procedure} alarm-interrupt @dots{} +@deffnx {Callback procedure} virtual-alarm-interrupt @dots{} +@deffnx {Callback procedure} profile-alarm-interrupt @dots{} Establishes a response for @code{SIGINT} (control-C interrupt) and -@code{SIGALRM} interrupts. Program execution will resume if the handler -returns. This procedure should @code{(abort)} or some other action -which does not return if it does not want processing to continue after -it returns. +@code{SIGALRM}, @code{SIGVTALRM}, and @code{SIGPROF} interrupts. +Program execution will resume if the handler returns. This procedure +should @code{(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 @code{system} and @code{ed} procedures. @@ -2684,7 +2607,7 @@ Otherwise, returns @code{#f}. @noindent These procedures generalize and extend the standard capabilities in -@ref{Ports, , ,r4rs, Revised(4) Scheme}. +@ref{Ports, , ,r5rs, Revised(5) Scheme}. @defun open-file string modes @defunx try-open-file string modes @@ -2706,11 +2629,18 @@ reading, writing, and both reading and writing respectively. @end defvr @defun _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? to work correctly -on it. The initial value of (current-input-port) is unbuffered if the -platform supports it. +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 +@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 + +@defun _tracked modestr +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}. @end defun @defun close-port port @@ -2764,7 +2694,8 @@ not to hang. If the @var{port} is at end of file then the value returned by @code{current-input-port}. @findex current-input-port -@emph{Rationale:} @code{Char-ready?} exists to make it possible for a program to +@emph{Rationale:} @code{Char-ready?} exists to make it possible for a +program to @findex char-ready? accept characters from interactive ports without getting stuck waiting for input. Any input editors associated with such ports must ensure @@ -2776,10 +2707,29 @@ interactive port that has no ready characters. @c end rationale @end deffn +@deffn {procedure} wait-for-input x +@deffnx {procedure} wait-for-input x port1 @dots{} +Returns a list those ports @var{port1} @dots{} which are @code{char-ready?}. +@findex char-ready? +If none of @var{port1} @dots{} become @code{char-ready?} within the time +interval of @var{x} seconds, then #f is returned. The +@var{port1} @dots{} arguments may be omitted, in which case they default +to the list of the value returned by @code{current-input-port}. +@findex current-input-port +@end deffn + @defun isatty? port Returns @code{#t} if @var{port} is input or output to a serial non-file device. @end defun +@defun freshline port +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{freshline} is equivalent to @code{newline}. +@end defun + @node Soft Ports, Syntax Extensions, Files and Ports, The Language @section Soft Ports @@ -2813,7 +2763,7 @@ procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful operation for them to perform. If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, -eof-object?, ,r4rs, Revised(4) Scheme}) it indicates that the port has +eof-object?, ,r5rs, Revised(5) Scheme}) it indicates that the port has reached end-of-file. For example: @example @@ -2854,6 +2804,18 @@ internal definitions) is a string, then that string is the @end example @end deffn +@defun comment string1 @dots{} +Appends @var{string1} @dots{} to the strings given as arguments to +previous calls @code{comment}. +@defunx comment +Returns the (appended) strings given as arguments to previous calls +@code{comment} and empties the current string collection. +@end defun + +@deffn {Read syntax} #;text-till-end-of-line +Behaves as @code{(comment "@var{text-till-end-of-line}")}. +@end deffn + @deffn {Read syntax} #. expression Is read as the object resulting from the evaluation of @var{expression}. This substitution occurs even inside quoted structure. @@ -2896,12 +2858,23 @@ ignored by the @code{read}. Nested @code{#|@dots{}|#} can occur inside @noindent A similar read syntax @dfn{#!} (exclamation rather than vertical bar) is -supported for Posix shell-scripts (@pxref{Shell Scripts}). +supported for Posix shell-scripts (@pxref{Scripting}). + +@deffn {Read syntax} #\token +If @var{token} is a sequence of two or more digits, then this syntax is +equivalent to @code{#.(integer->char (string->number token 8))}. + +If @var{token} is @code{C-}, @code{c-}, or @code{^} followed by a +character, then this syntax is read as a control character. If +@var{token} is @code{M-} or @code{m-} followed by a character, then a +meta character is read. @code{c-} and @code{m-} prefixes may be +combined. +@end deffn @defspec defined? symbol Equivalent to @code{#t} if @var{symbol} is a syntactic keyword (such as @code{if}) or a symbol with a value in the top level environment -(@pxref{Variables and regions, , ,r4rs, Revised(4) Scheme}). Otherwise +(@pxref{Variables and regions, , ,r5rs, Revised(5) Scheme}). Otherwise equivalent to @code{#f}. @end defspec @@ -2925,6 +2898,25 @@ value is not changed, and an error is signaled. @code{defconst} is valid only when used at top-level. @end defspec +@defspec set! (variable1 variable2 @dots{}) @r{<expression>} + +The identifiers @var{variable1}, @var{variable2}, @dots{} must be bound +either in some region enclosing the @samp{set!} expression or at top +level. + +@r{<Expression>} is evaluated, and the elements of the resulting list +are stored in the locations to which each corresponding @var{variable} +is bound. The result of the @samp{set!} expression is unspecified. + +@example +(define x 2) +(define y 3) +(+ x y) @result{} 5 +(set! (x y) (list 4 5)) @result{} @emph{unspecified} +(+ x y) @result{} 9 +@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 @@ -2989,14 +2981,24 @@ read from. The value returned by this function will be the value of @code{#<unspecified>} in which case the expression will be treated as whitespace. @code{#<unspecified>} is the value returned by the expression @code{(if #f #f)}. +@end deffn -@emph{Note:} When adding new @key{#} syntaxes, have your code save the -previous value of @code{read:sharp} when 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}). +@deffn {Callback procedure} read:sharp-char token +If the sequence @key{#\} followed by a non-standard character name is +encountered by @code{read}, @code{read} will call the value of the +symbol @code{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 @code{read} for this expression, otherwise an error +will be signaled. @end deffn +@emph{Note:} When adding new @key{#} syntaxes, have your code save the +previous value of @code{read:sharp} or @code{read:sharp-char} when +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 @@ -3061,7 +3063,7 @@ Thus a mutable environment can be treated as both a list and local bindings. @end defspec -@defspec @@call-with-current-continuation procedure) +@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 @@ -3075,7 +3077,7 @@ procedure)}. SCM provides a synthetic identifier type for efficient implementation of hygienic macros (for example, @code{syntax-rules} @pxref{Macros, , , -r4rs, Revised(4) Scheme}) A synthetic identifier may be inserted in +r5rs, Revised(5) Scheme}) 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 @emph{identifiers}. @@ -3101,11 +3103,16 @@ macro expander. @code{renamed-identifier} returns a distinct object for each call, even if passed identical arguments. @end defun -There is no direct way to access the data internal to a synthetic +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. +@defun identifier->symbol id +Returns the symbol obtained by recursively extracting the parent of +@var{id}, which must be an identifier. +@end defun + @subsection Use of synthetic identifiers @code{renamed-identifier} may be used as a replacement for @code{gentemp}: @lisp @@ -3185,6 +3192,25 @@ For example, @end lisp @end defun +@defun @@macroexpand1 expr env +If the @code{car} of @var{expr} denotes a macro in @var{env}, then +if that macro is a primitive, @var{expr} will be returned, if the +macro was defined in Scheme, then a macro expansion will be returned. +If the @code{car} of @var{expr} does not denote a macro, the @code{#f} +is returned. +@end defun + +@defun extended-environment names values env +Returns a new environment object, equivalent to @var{env}, which must +either be an environment object or null, extended by one frame. +@var{names} must be an identifier, or an improper list of identifiers, +usable as a formals list in a @code{lambda} expression. @var{values} +must be a list of objects long enough to provide a binding for each of +the identifiers in @var{names}. If @var{names} is an identifier or an +improper list then @var{vals} may be, respectively, any object or an +improper list of objects. +@end defun + @defspec syntax-quote obj Synthetic identifiers are converted to their parent symbols by @code{quote} and @code{quasiquote} so that literal data in macro definitions will be @@ -3208,6 +3234,20 @@ redefinition, for example: @end lisp @end defspec +@defspec 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 @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 +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. +@var{compare} accepts two identifiers and returns true if and only if +both denote the same binding in the usage environment of the new syntax. +@end defspec + @node Packages, The Implementation, The Language, Top @chapter Packages @@ -3225,6 +3265,10 @@ redefinition, for example: * Sockets:: Cruise the Net @end menu +@menu +* Xlib: (Xlibscm). X Window Graphics. +@end menu + @node Compiling And Linking, Dynamic Linking, Packages, Packages @section Compiling And Linking @@ -3251,7 +3295,7 @@ scm -e'(link-named-scm"cute""cube")' (lambda (fp) (for-each (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"/home/jaffer/scm/Init5c3.scm\"" + '("#define IMPLINIT \"/home/jaffer/scm/Init@value{SCMVERSION}.scm\"" "#define COMPILED_INITS init_cube();" "#define BIGNUMS" "#define FLOATS" @@ -3302,7 +3346,7 @@ of the X11 library. @end defun @defun load filename lib1 @dots{} -In addition to the [R4RS] requirement of loading Scheme expressions if +In addition to the [R5RS] requirement of loading Scheme expressions if @var{filename} is a Scheme source file, @code{load} will also dynamically load/link object files (produced by @code{compile-file}, for instance). The object-suffix need not be given to load. For example, @@ -3532,7 +3576,7 @@ The immediate integer closest to negative infinity. @noindent These procedures augment the standard capabilities in @ref{Numerical -operations, , ,r4rs, Revised(4) Scheme}. +operations, , ,r5rs, Revised(5) Scheme}. @defun sinh z @defunx cosh z @@ -3597,18 +3641,24 @@ is not real. @subsection Conventional Arrays @dfn{Arrays} read and write as a @code{#} followed by the @dfn{rank} -(number of dimensions) followed by 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. +@cindex array +(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. @example (make-array 'ho 3 3) @result{} -#2((ho ho ho) (ho ho ho) (ho ho ho)) +#2A((ho ho ho) (ho ho ho) (ho ho ho)) +@end example + +The rank may be elided, in which case it is read as one. +@example +'#A(a b c) @equiv{} '#(a b c) @end example Unshared conventional (not uniform) 0-based arrays of rank 1 (dimension) are equivalent to (and can't be distinguished from) vectors. @example -(make-array 'ho 3) @result{} (ho ho ho) +(make-array 'ho 3) @result{} #(ho ho ho) @end example When constructing an array, @var{bound} is either an inclusive range of @@ -3675,10 +3725,10 @@ in which case the returned array will have smaller rank than examples: @example -(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) -(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) -(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} - #2((a 4) (b 5) (c 6)) +(transpose-array '#2A((a b) (c d)) 1 0) @result{} #2A((a c) (b d)) +(transpose-array '#2A((a b) (c d)) 0 0) @result{} #1A(a d) +(transpose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} + #2A((a 4) (b 5) (c 6)) @end example @end defun @@ -3698,11 +3748,11 @@ enclosed array is unspecified. examples: @example -(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} - #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))> +(enclose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} + #<enclosed-array (#1A(a d) #1A(b e) #1A(c f)) (#1A(1 4) #1A(2 5) #1A(3 6))> -(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} - #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))> +(enclose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} + #<enclosed-array #2A((a 1) (d 4)) #2A((b 2) (e 5)) #2A((c 3) (f 6))> @end example @end defun @@ -3728,6 +3778,7 @@ array, @code{0} is returned. @defun array->list array Returns a list consisting of all the elements, in order, of @var{array}. +In the case of a rank-0 array, returns the single element. @end defun @defun array-copy! source destination @@ -3845,14 +3896,14 @@ according to the table: @example prototype type display prefix -#t boolean (bit-vector) #b -#\a char (string) #a -integer >0 unsigned integer #u -integer <0 signed integer #e -1.0 float (single precision) #s -1/3 double (double precision float) #i -+i complex (double precision) #c -() conventional vector # +#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 @noindent @@ -3869,16 +3920,16 @@ bit-vectors}. @example (make-uniform-array #t 3) @result{} #*000 @equiv{} -#b(#f #f #f) @result{} #*000 +#At(#f #f #f) @result{} #*000 @equiv{} -#1b(#f #f #f) @result{} #*000 +#1At(#f #f #f) @result{} #*000 @end example @noindent -Other uniform vectors are written in a form similar to that of vectors, -except that a single character from the above table is put between -@code{#} and @code{(}. For example, @code{'#e(3 5 9)} returns a uniform -vector of signed integers. +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. @defun uniform-vector-ref uve index Returns the element at the @var{index} element in @var{uve}. @@ -3911,6 +3962,14 @@ Returns an object that would produce an array of the same type as 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. + +In, for example, the case of a rank-2 array, @var{lst} must be a list of +lists, all of the same length. The length of @var{lst} will be the +first dimension of the result array, and the length of each element the +second dimension. + +If @var{rank} is zero, @var{lst}, which need not be a list, is the +single element of the returned array. @end defun @defun uniform-vector-fill! uve fill @@ -3978,8 +4037,8 @@ If an @var{index} is provided for each dimension of @var{array} sets the @var{index1}, @var{index2}, @dots{}'th element of @var{array} to @var{val}. If one more @var{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 @var{bool} is @code{#t} -and to 0 if @var{bool} is @code{#f} if 0. In this case it is an error +integer array element, setting the bit to 1 if @var{val} is @code{#t} +and to 0 if @var{val} is @code{#f}. In this case it is an error if the array element is not an exact integer or if @var{val} is not boolean. @end defun @@ -3993,7 +4052,7 @@ Bit vectors can be written and read as a sequence of @code{0}s and @code{1}s prefixed by @code{#*}. @example -#b(#f #f #f #t #f #t #f) @result{} #*0001010 +#At(#f #f #f #t #f #t #f) @result{} #*0001010 @end example @noindent @@ -4135,6 +4194,36 @@ Closes @var{dir} and returns @code{#t}. If @var{dir} is already closed,, @code{closedir} returns a @code{#f}. @end defun +@defun directory-for-each proc directory +The @var{list}s must be lists, and @var{proc} must be a procedure taking +one argument. @samp{Directory-For-Each} applies @var{proc} to the +(string) name of each file in @var{directory}. The dynamic order in +which @var{proc} is applied to the elements of the @var{list}s is +unspecified. The value returned by @samp{directory-for-each} is +unspecified. + +@defunx directory-for-each proc directory pred +Applies @var{proc} only to those filenames for which the procedure +@var{pred} returns a non-false value. + +@defunx directory-for-each proc directory match +Applies @var{proc} only to those filenames for which +@code{(filename:match?? @var{match})} would return a non-false value +(@pxref{Filenames, , , slib, SLIB}). + +@example +(require 'directory-for-each) +(directory-for-each print "." "[A-Z]*.scm") +@print{} +"Init.scm" +"Iedline.scm" +"Link.scm" +"Macro.scm" +"Transcen.scm" +"Init@value{SCMVERSION}.scm" +@end example +@end defun + @defun mkdir path mode The @code{mkdir} function creates a new, empty directory whose name is @var{path}. The integer argument @var{mode} specifies the file @@ -4256,7 +4345,7 @@ invariably uppercase. @code{Putenv} is used to set up the environment before calls to @code{execl}, @code{execlp}, @code{execv}, @code{execvp}, @code{system}, -or @code{open-pipe} (@pxref{I/O-Extensions, open-pipe}). +or @code{open-pipe} (@pxref{Posix Extensions, open-pipe}). To access environment variables, use @code{getenv} (@pxref{System Interface, getenv, , slib, SLIB}). @@ -4397,23 +4486,19 @@ whether all of them did. @defun waitpid pid options The @code{waitpid} function suspends execution of the current process -until a child as specified by the @var{pid} argument has exited, or until a -signal is deliverd whose action is to terminate the current process or -to call a signal handling function. If a child as requested by @var{pid} has -already exited by the time of the call (a so-called @dfn{zombie} -process), the function returns immediately. Any system resources used -by the child are freed. +until a child as specified by the @var{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 @var{pid} has already exited by the time of the call (a so-called +@dfn{zombie} process), the function returns immediately. Any system +resources used by the child are freed. -The value of @var{pid} can be one of: +The value of @var{pid} can be: @table @asis @item < -1 which means to wait for any child process whose process group ID is -equal to the absolute value of - -@item -1 -which means to wait for any child process whose process group ID is -equal to the @code{(abs @var{pid})}. +equal to the absolute value of @var{pid}. @item -1 which means to wait for any child process; this is the same behaviour @@ -4633,7 +4718,7 @@ writing is done. The value returned is unspecified. These functions are defined in @file{rgx.c} using a POSIX or GNU @dfn{regex} library. If your computer does not support regex, a package is available via ftp from -@file{prep.ai.mit.edu:/pub/gnu/regex-0.12.tar.gz}. For a description of +@file{ftp.gnu.org:/pub/gnu/regex-0.12.tar.gz}. For a description of regular expressions, @xref{syntax, , , regex, "regex" regular expression matching library}. @@ -4772,9 +4857,9 @@ using the @dfn{editline} or GNU @dfn{readline} (@pxref{Top, , Overview @end ifset @item @ifset html -<A HREF="ftp://prep.ai.mit.edu/pub/gnu/readline-2.0.tar.gz"> +<A HREF="ftp://ftp.gnu.org/pub/gnu/readline-2.0.tar.gz"> @end ifset -@code{prep.ai.mit.edu:/pub/gnu/readline-2.0.tar.gz} +@code{ftp.gnu.org:/pub/gnu/readline-2.0.tar.gz} @ifset html </A> @end ifset @@ -5491,35 +5576,39 @@ sockets for multiple connections without input blocking. (connections '())) (socket:listen listener-socket 5) (do () (#f) - (cond ((char-ready? listener-socket) - (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 ((char-ready? con) - (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)))))))))))) + (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))))))))))))) @end example @noindent @@ -5541,16 +5630,43 @@ or you can use a client written in scheme: (define con (make-stream-socket af_inet)) (set! con (socket:connect con (inet:string->address "localhost") 8001)) -(do ((cs #f (and (char-ready? con) (read-char con))) - (ct #f (and (char-ready?) (read-char)))) - ((or (eof-object? cs) (eof-object? ct)) - (close-port con)) - (cond (cs (display cs))) - (cond (ct (file-set-position con 0) - (display ct con) - (file-set-position con 0)))) +(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))) @end example +@iftex +@section Xlibscm + +@ifset html +<A HREF="Xlibscm_toc.html"> +@code{(require 'Xlib)} + +@dfn{Xlibscm} +</A> +is a SCM interface to the +<A HREF="http://www.x.org/"> X Window System.</A> +@end ifset + +@ifclear html +@xref{Top, ,SCM Language X Interface , Xlibscm, Xlibscm}, for the SCM +interface to the @dfn{X Window System}. +@end ifclear +@end iftex + @node The Implementation, Index, Packages, Top @chapter The Implementation @@ -5911,11 +6027,16 @@ uniform vector of double precision inexact complex numbers applicable object produced by call-with-current-continuation @end deftp -@deftp Header tc7_cclo -Subr and environment for compiled closure +@deftp Header tc7_specfun +subr that is treated specially within the evaluator -A cclo is similar to a vector (and is GCed like one), but can be applied -as a function: +@code{apply} and @code{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: @enumerate @item @@ -5930,6 +6051,10 @@ makes a closure from the @emph{subr} @var{proc} with @var{len}-1 extra locations for @code{SCM} data. Elements of a @var{cclo} are referenced using @code{VELTS(cclo)[n]} just as for vectors. @end defun + +@defmac CCLO_LENGTH cclo +Expands to the length of @var{cclo}. +@end defmac @end deftp @node Subr Cells, Ptob Cells, Header Cells, Data Types @@ -6013,7 +6138,8 @@ C function of list of @code{SCM} arguments. @noindent A @dfn{ptob} is a port object, capable of delivering or accepting -characters. @xref{Ports, , , r4rs, Revised(4) Report on the Algorithmic +@tindex ptob +characters. @xref{Ports, , , r5rs, Revised(5) Report on the Algorithmic Language Scheme}. Unlike the types described so far, new varieties of ptobs can be defined dynamically (@pxref{Defining Ptobs}). These are the initial ptobs: @@ -6083,6 +6209,7 @@ open output-port, respectively. @noindent A @dfn{smob} is a miscellaneous datatype. The type code and GCMARK bit +@tindex smob occupy the lower order 16 bits of the @code{CAR} half of the cell. The rest of the @code{CAR} can be used for sub-type or other information. The @code{CDR} contains data of size long and is often a pointer to @@ -6132,10 +6259,36 @@ bigpos and bigneg. The magnitude is stored as a @code{malloc}ed array of type @code{BIGDIG} which must be an unsigned integral type with size smaller than @code{long}. @code{BIGRAD} is the radix associated with @code{BIGDIG}. + +@code{NUMDIGS_MAX} (defined in @file{scmfig.h}) limits the number of +digits of a bignum to 1000. These digits are base @code{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 @emph{some multiple} of the product of the +number of digits of the two multiplicands. + +@example +digits * digits ==> operations + 5 x + 50 100 * x + 500 10000 * x + 5000 1000000 * x +@end example + +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: + +@center @url{ftp://megrez.math.u-bordeaux.fr/pub/pari/} + + + @end deftp @deftp smob tc16_promise -made by DELAY. @xref{Control features, , , r4rs, Revised(4) Scheme}. +made by DELAY. @xref{Control features, , , r5rs, Revised(5) Scheme}. @end deftp @deftp smob tc16_arbiter @@ -6196,7 +6349,18 @@ dvect .........long length....G0101111 ........double *words........... cvect .........long length....G0110101 ........double *words........... contin .........long length....G0111101 .............*regs.............. -cclo .........long length....G0111111 ...........SCM **elts...........} +specfun ................xxxxxxxxG1111111 ...........SCM name............. +cclo ..short length..xxxxxx10G1111111 ...........SCM **elts...........} +@r{ PTOBs:} +@t{ 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..........} @r{ SUBRs:} @t{ spare 010001x1 spare 010011x1 @@ -6209,17 +6373,8 @@ 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)()...........} -@r{ PTOBs:} -@t{ port 0bwroxxxxxxxxG1110111 ..........FILE *stream.......... - socket ttttttt 00001xxxxxxxxG1110111 ..........FILE *stream.......... - inport uuuuuuuuuuU00011xxxxxxxxG1110111 ..........FILE *stream.......... -outport 0000000000000101xxxxxxxxG1110111 ..........FILE *stream.......... - ioport uuuuuuuuuuU00111xxxxxxxxG1110111 ..........FILE *stream.......... -fport 00 00000000G1110111 ..........FILE *stream.......... -pipe 00 00000001G1110111 ..........FILE *stream.......... -strport 00 00000010G1110111 ..........FILE *stream.......... -sfport 00 00000011G1110111 ..........FILE *stream..........} @r{ SMOBs:} @t{free_cell 000000000000000000000000G1111111 ...........*free_cell........000 @@ -6248,7 +6403,8 @@ array ...short rank..cxxxxxxxxG1111111 ............*array..............} * Defining Subrs:: * Defining Smobs:: * Defining Ptobs:: -* Calling Scheme From C:: +* Allocating memory:: +* Embedding SCM:: In other programs * Callbacks:: * Type Conversions:: For use with C code. * Continuations:: For C and SCM @@ -6393,7 +6549,7 @@ allocate all short-lived objects from the copying-heap, at no extra cost in allocation time. @end quotation - + @subsubheading Implementation Details A separate heap (@code{ecache_v}) is maintained for the copying @@ -6451,6 +6607,7 @@ of literature is available. @node Signals, C Macros, Memory Management for Environments, Operations @subsection Signals +@cindex signals @defun init_signals (in @file{scm.c}) initializes handlers for @code{SIGINT} and @@ -6650,8 +6807,8 @@ will append a symbol @code{'@i{foo}} to the (list) value of put any scheme code which needs to be run as part of your package into @file{I@i{foo}.scm}. @item -put an @code{if} into @file{Init5c3.scm} which loads @file{I@i{foo}.scm} if -your package is included: +put an @code{if} into @file{Init@value{SCMVERSION}.scm} which loads +@file{I@i{foo}.scm} if your package is included: @example (if (defined? twiddle-bits!) @@ -6777,13 +6934,18 @@ typedef struct @{ is a function of one argument of type @code{SCM} (the cell to mark) and returns type @code{SCM} which will then be marked. If no further objects need to be marked then return an immediate object such as -@code{BOOL_F}. 2 functions are provided: +@code{BOOL_F}. The smob cell itself will already have been marked. +@emph{Note:} This is different from SCM versions prior to 5c5. Only +additional data specific to a smob type need be marked by @code{smob.mark}. + + 2 functions are provided: @table @code @item markcdr(ptr) -which marks the current cell and returns @code{CDR(ptr)}. +returns @code{CDR(ptr)}. @item mark0(ptr) -which marks the current cell and returns @code{BOOL_F}. +is a no-op used for smobs containing no additional @code{SCM} data. 0 +may also be used in this case. @end table @item smob.free @@ -6815,8 +6977,10 @@ line goes in an @code{init_} routine. @noindent Promises and macros in @file{eval.c} and arbiters in @file{repl.c} provide examples of SMOBs. There are a maximum of 256 SMOBs. +Smobs that must allocate blocks of memory should use, for example, +@code{must_malloc} rather than @code{malloc} @xref{Allocating memory}. -@node Defining Ptobs, Calling Scheme From C, Defining Smobs, Operations +@node Defining Ptobs, Allocating memory, Defining Smobs, Operations @subsection Defining Ptobs @noindent @@ -6845,49 +7009,201 @@ other C construct as its argument, unlike @code{.free} in a smob, which takes the whole smob cell. Often, @code{.free} and @code{.fclose} can be the same function. See @code{fptob} and @code{pipob} in @file{sys.c} for examples of how to define ptobs. +Ptobs that must allocate blocks of memory should use, for example, +@code{must_malloc} rather than @code{malloc} @xref{Allocating memory}. + +@node Allocating memory, Embedding SCM, Defining Ptobs, Operations +@subsection 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, @code{malloc} and @code{free} should +not be called directly to manage memory freeable by garbage collection. +The following functions are provided for that purpose: + +@deftypefun SCM must_malloc_cell (long @var{len}, SCM @var{c}, char *@var{what}) +@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 +newly allocated cell whose @code{car} is @var{c} and whose @code{cdr} is +a pointer to newly allocated memory. +@end deftypefun + +@deftypefun void must_realloc_cell (SCM @var{z}, long @var{olen}, long @var{len}, char *@var{what}) +@deftypefunx {char *} must_realloc (char *@var{where}, long @var{olen}, long @var{len}, char *@var{what}) +@code{must_realloc_cell} takes as argument @var{z} a cell whose +@code{cdr} should be a pointer to a block of memory of length @var{olen} +allocated with @code{must_malloc_cell} and modifies the @code{cdr} to point +to a block of memory of length @var{len}. @code{must_realloc} takes as +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 +minimum of the old and new sizes. + +@var{what} is a pointer to a string used for error and gc messages. +@end deftypefun + +@code{must_malloc}, @code{must_malloc_cell}, @code{must_realloc}, and +@code{must_realloc_cell} must be called with interrupts deferred +@xref{Signals}. + +@deftypefun void must_free (char *@var{ptr}, sizet @var{len}) +@code{must_free} is used to free a block of memory allocated by the +above functions and pointed to by @var{ptr}. @var{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. +@end deftypefun + -@node Calling Scheme From C, Callbacks, Defining Ptobs, Operations -@subsection Calling Scheme From C + +@node Embedding SCM, Callbacks, Allocating memory, Operations +@subsection Embedding SCM +@cindex Embedding SCM @noindent -To use SCM as a whole from another program call @code{init_scm} or -@code{run_scm} as is done in @code{main()} in @file{scm.c}. +The file @file{scmmain.c} contains the definition of main(). +When SCM is compiled as a library @file{scmmain.c} is not included in +the library; a copy of @file{scmmain.c} can be modified to use SCM as an +embedded library module. + +@deftypefun int main (int @var{argc}, char **@var{argv}) +This is the top level C routine. The value of the @var{argc} argument +is the number of command line arguments. The @var{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: +@code{@var{argv}[@var{argc}]} is this null pointer. +@end deftypefun + +@deftypevar char *execpath +This string is the pathname of the executable file being run. This +variable can be examined and set from Scheme (@pxref{Internal State}). +@var{execpath} must be set to executable's path in order to use DUMP +(@pxref{Dump}) or DLD. +@end deftypevar @noindent -In order to call indivdual Scheme procedures from C code more is -required; SCM's storage system needs to be initialized. The simplest -way to do this for a statically linked single-thread program is to: +Rename main() and arrange your code to call it with an @var{argv} which +sets up SCM as you want it. -@enumerate -@item -make a SCM procedure which calls your code's startup routine. -@item -use the @code{#define RTL} flag when compiling @file{scm.c} to elide -SCM's @code{main()}. -@item -In your @code{main()}, call @code{run_scm} with arguments (@code{argc} -and @code{argv}) to invoke your code's startup routine. -@item -link your code with SCM at compile time. -@end enumerate +@noindent +If you need more control than is possible through @var{argv}, here are +descriptions of the functions which main() calls. + +@deftypefun void init_sbrk (void) +Call this before SCM calls malloc(). Value returned from sbrk() is used +to gauge how much storage SCM uses. +@end deftypefun + +@deftypefun {char *} scm_find_execpath (int @var{argc}, char **@var{argv}, char *@var{script_arg}) +@var{argc} and @var{argv} are as described in main(). @var{script_arg} +is the pathname of the SCSH-style script (@pxref{Scripting}) being +invoked; 0 otherwise. @code{scm_find_execpath} returns the pathname of +the executable being run; if @code{scm_find_execpath} cannot determine +the pathname, then it returns 0. +@end deftypefun @noindent -For a dynamically linked single-thread program: +@code{scm_find_implpath} is defined in @file{scmmain.c}. Preceeding +this are definitions of@var{GENERIC_NAME} and @var{INIT_GETENV}. These, +along with @var{IMPLINIT} and @var{dirsep} control scm_find_implpath()'s +operation. -@enumerate -@item -make an @code{init_} procedure for your code which will set up any Scheme -definitions you need and then call your startup routine -(@pxref{Changing Scm}). -@item -Start SCM with command line arguments to dynamically link your code. -After your module is linked, the @code{init_} procedure will be called, and -hence your startup routine. -@end enumerate +@noindent +If your application has an easier way to locate initialization code for +SCM, then you can replace @code{scm_find_implpath}. + +@deftypefun {char *} scm_find_implpath (char *@var{execpath}) +Returns the full pathname of the Scheme initialization file or 0 if it +cannot find it. + +The string value of the preprocessor variable @var{INIT_GETENV} names an +environment variable (default @samp{"SCM_INIT_PATH"}). If this +environment variable is defined, its value will be returned from +@code{scm_find_implpath}. Otherwise find_impl_file() is called with the +arguments @var{execpath}, @var{GENERIC_NAME} (default "scm"), +@var{INIT_FILE_NAME} (default "Init@value{SCMVERSION}_scm"), and the +directory separator string @var{dirsep}. If find_impl_file() returns 0 +and @var{IMPLINIT} is defined, then a copy of the string @var{IMPLINIT} +is returned. +@end deftypefun + +@deftypefun int init_buf0 (FILE *@var{inport}) +Tries to determine whether @var{inport} (usually stdin) is an +interactive input port which should be used in an unbuffered mode. If +so, @var{inport} is set to unbuffered and non-zero is returned. +Otherwise, 0 is returned. + +@code{init_buf0} should be called before any input is read from +@var{inport}. Its value can be used as the last argument to +scm_init_from_argv(). +@end deftypefun + +@deftypefun void scm_init_from_argv (int @var{argc}, char **@var{argv}, char *@var{script_arg}, int @var{iverbose}, int @var{buf0stdin}) +Initializes SCM storage and creates a list of the argument strings +@var{program-arguments} from @var{argv}. @var{argc} and @var{argv} must +already be processed to accomodate Scheme Scripts (if desired). The +scheme variable @var{*script*} is set to the string @var{script_arg}, or +#f if @var{script_arg} is 0. +@var{iverbose} is the initial prolixity level. If @var{buf0stdin} is +non-zero, stdin is treated as an unbuffered port. +@end deftypefun + +@noindent +Call @code{init_signals} and @code{restore_signals} only if you want SCM +to handle interrupts and signals. + +@deftypefun void init_signals (void) +Initializes handlers for @code{SIGINT} and @code{SIGALRM} if they are +supported by the C implementation. All of the signal handlers +immediately reestablish themselves by a call to @code{signal()}. +@end deftypefun + +@deftypefun void restore_signals (void) +Restores the handlers in effect when @code{init_signals} was called. +@end deftypefun + +@deftypefun SCM scm_top_level (char *@var{initpath}, SCM (*toplvl_fun)()) +This is SCM's top-level. Errors longjmp here. @var{toplvl_fun} is a +callback function of zero arguments that is called by +@code{scm_top_level} to do useful work -- if zero, then @code{repl}, +which implements a read-eval-print loop, is called. + +If @var{toplvl_fun} returns, then @code{scm_top_level} will return as +well. If the return value of @var{toplvl_fun} is an immediate integer +then it will be used as the return value of @code{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 @var{initpath} is @samp{;}, @samp{(} or +whitespace, then scm_ldstr() is called with @var{initpath} to initialize +SCM; otherwise @var{initpath} names a file of Scheme code to be loaded +to initialize SCM. + +When a Scheme error is signaled; control will pass into +@code{scm_top_level} by @code{longjmp}, error messages will be printed +to @code{current-error-port}, and then @var{toplvl_fun} will be called +again. @var{toplvl_fun} must maintain enough state to prevent errors +from being resignalled. If @code{toplvl_fun} can not recover from an +error situation it may simply return. +@end deftypefun + +@deftypefun void final_scm (int @var{freeall}) +Calls all finalization routines registered with add_final(). If +@var{freeall} is non-zero, then all memory which SCM allocated with +malloc() will be freed. +@end deftypefun @noindent -Now use @code{apply} (and perhaps @code{intern}) to call Scheme -procedures from your C code. For example: +You can call indivdual Scheme procedures from C code in the +@var{toplvl_fun} argument passed to scm_top_level(), or from module +subrs (registered by an @code{init_} function, @pxref{Changing Scm}). + +@noindent +Use @code{apply} to call Scheme procedures from your C code. For +example: @example /* If this apply fails, SCM will catch the error */ @@ -6899,8 +7215,61 @@ func = CDR(intern(rpcname,strlen(rpcname))); retval = apply(func, cons(mksproc(srvproc), args), EOL); @end example -@node Callbacks, Type Conversions, Calling Scheme From C, Operations +Functions for loading Scheme files and evaluating Scheme code given +as C strings are described in the next section, (@pxref{Callbacks}). + +Here is a minimal embedding program @file{libtest.c}: + +@example +/* 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, 0, 0); + + retval = scm_top_level(implpath, user_main); + + final_scm(!0); + return (int)INUM(retval); +@} + +@print{} +dld_find_executable(./libtest): /home/jaffer/scm/libtest +implpath: /home/jaffer/scm/Init@value{SCMVERSION}.scm +This is init_user_scm +hello world +@end example + + +@node Callbacks, Type Conversions, Embedding SCM, Operations @subsection Callbacks +@cindex callbacks @noindent SCM now has routines to make calling back to Scheme procedures easier. @@ -6909,7 +7278,7 @@ The source code for these routines are found in @file{rope.c}. @deftypefun int scm_ldfile (char *@var{file}) Loads the Scheme source file @var{file}. Returns 0 if successful, non-0 if not. This function is used to load SCM's initialization file -@file{Init5c3.scm}. +@file{Init@value{SCMVERSION}.scm}. @end deftypefun @deftypefun int scm_ldprog (char *@var{file}) @@ -6984,7 +7353,7 @@ of useful predefined @var{pos} macros, @xref{C Macros}. @emph{Note:} Inexact numbers are accepted only by @code{num2long} and @code{num2ulong} (for when @code{SCM} is compiled without bignums). To convert inexact numbers to exact numbers, @xref{Numerical operations, -inexact->exact, , r4rs, Revised(4) Scheme}. +inexact->exact, , r5rs, Revised(5) Scheme}. @end deftypefun @deftypefun unsigned long scm_addr (SCM @var{args}, char *@var{s_name}) @@ -7013,13 +7382,13 @@ null-terminated string @var{src} or the string @var{src} of length Returns a newly allocated @code{SCM} list of strings corresponding to the @var{argc} length array of null-terminated strings @var{argv}. If @var{argv} is less than @code{0}, @var{argv} is assumed to be -@code{NULL} terminated. @code{makfromstrs} is used by @code{run_scm} to -convert the arguments SCM was called with to a @code{SCM} list which is -the value of SCM procedure calls to @code{program-arguments} -(@pxref{SCM Session, program-arguments}). +@code{NULL} terminated. @code{makfromstrs} is used by +@code{scm_init_from_argv} to convert the arguments SCM was called with +to a @code{SCM} list which is the value of SCM procedure calls to +@code{program-arguments} (@pxref{SCM Session, program-arguments}). @end deftypefun -@deftypefun char **makargvfrmstrs (SCM @var{args}, char *@var{s_name}) +@deftypefun {char **} makargvfrmstrs (SCM @var{args}, char *@var{s_name}) Returns a @code{NULL} terminated list of null-terminated strings copied from the @code{SCM} list of strings @var{args}. The string @var{s_name} is used in messages from error calls by @code{makargvfrmstrs}. @@ -7035,13 +7404,14 @@ Frees the storage allocated to create @var{argv} by a call to @node Continuations, Evaluation, Type Conversions, Operations @subsection Continuations +@cindex continuations @noindent The source files @file{continue.h} and @file{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 @ref{Control features, -call-with-current-continuation, , r4rs, Revised(4) Scheme}. +call-with-current-continuation, , r5rs, Revised(5) Scheme}. @noindent The C constructs @code{jmp_buf}, @code{setjmp}, and @code{longjmp} @@ -7100,7 +7470,7 @@ routine to ensure that @var{start} is actually in the current stack segment. @end deftypefun -@deftypefun CONTINUATION *make_root_continuation (STACKITEM *@var{stack_base}) +@deftypefun {CONTINUATION *} make_root_continuation (STACKITEM *@var{stack_base}) Allocates (@code{malloc}) storage for a @code{CONTINUATION} of the current extent of stack. This newly allocated @code{CONTINUATION} is returned if successful, @code{0} if not. After @@ -7109,7 +7479,7 @@ to @code{setjump(@var{new_continuation}->jmpbuf)} in order to complete the capture of this continuation. @end deftypefun -@deftypefun CONTINUATION *make_continuation (CONTINUATION *@var{parent_cont}) +@deftypefun {CONTINUATION *} make_continuation (CONTINUATION *@var{parent_cont}) Allocates storage for the current @code{CONTINUATION}, copying (or encapsulating) the stack state from @code{@var{parent_cont}->stkbse} to the current top of stack. The newly allocated @code{CONTINUATION} is @@ -7291,7 +7661,7 @@ Programs of the world unite! You have nothing to lose but loss itself. @end quotation @noindent -The function @code{scm_find_impl_file} in @file{scm.c} is an attempt to +The function @code{find_impl_file} in @file{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 @@ -7299,13 +7669,13 @@ for which this information is either not available or unrelated to the locations of support files, then a higher level interface will be needed. -@deftypefun char *scm_find_impl_file(char *@var{exec_path}, char -*@var{generic_name}, char *@var{initname}, char *@var{sep}) Given the -pathname of this executable (@var{exec_path}), test for the existence of -@var{initname} in the implementation-vicinity of this program. Return a -newly allocated string of the path if successful, 0 if not. The -@var{sep} argument is a @emph{null-terminated string} of the character -used to separate directory components. +@deftypefun {char *} find_impl_file (char *@var{exec_path}, char *@var{generic_name}, char *@var{initname}, char *@var{sep}) + +Given the pathname of this executable (@var{exec_path}), test for the +existence of @var{initname} in the implementation-vicinity of this +program. Return a newly allocated string of the path if successful, 0 +if not. The @var{sep} argument is a @emph{null-terminated string} of +the character used to separate directory components. @end deftypefun @itemize @bullet @@ -7353,20 +7723,20 @@ subdirectory. For example, the executable might be @subsection Executable Pathname @noindent -For purposes of finding @file{Init5c3.scm}, dumping an executable, and -dynamic linking, a SCM session needs the pathname of its executable -image. +For purposes of finding @file{Init@value{SCMVERSION}.scm}, dumping an +executable, and dynamic linking, a SCM session needs the pathname of its +executable image. @noindent When a program is executed by MS-DOS, the full pathname of that executable is available in @code{argv[0]}. This value can be passed -directly to @code{scm_find_impl_file} (@pxref{File-System Habitat}). +directly to @code{find_impl_file} (@pxref{File-System Habitat}). @noindent In order to find the habitat for a unix program, we first need to know the full pathname for the associated executable file. -@deftypefun char *dld_find_executable (const char *@var{command}) +@deftypefun {char *} dld_find_executable (const char *@var{command}) @code{dld_find_executable} returns the absolute path name of the file that would be executed if @var{command} were given as a command. It looks up the environment variable @var{PATH}, searches in each of the @@ -7401,19 +7771,19 @@ in any of the directories listed in @code{PATH}. @noindent Source code for these C functions is in the file @file{script.c}. -@ref{Shell Scripts} for a description of script argument processing. +@ref{Scripting} for a description of script argument processing. @noindent @code{script_find_executable} is only defined on unix systems. -@deftypefun char *script_find_executable (const char *@var{name}) +@deftypefun {char *} script_find_executable (const char *@var{name}) @code{script_find_executable} returns the path name of the -executable which will is invoked by the script file @var{name}; +executable which is invoked by the script file @var{name}; @var{name} if it is a binary executable (not a script); or 0 if @var{name} does not exist or is not executable. @end deftypefun -@deftypefun char **script_process_argv(int @var{argc}; char **@var{argv}) +@deftypefun {char **} script_process_argv (int @var{argc}; char **@var{argv}) Given an @dfn{main} style argument vector @var{argv} and the number of arguments, @var{argc}, @code{script_process_argv} returns a newly allocated argument vector in which the second line of the script being @@ -7428,7 +7798,7 @@ is returned. nested script invocations. @end deftypefun -@deftypefun int script_count_argv(char **@var{argv}) +@deftypefun int script_count_argv (char **@var{argv}) Returns the number of argument strings in @var{argv}. @end deftypefun @@ -7450,10 +7820,6 @@ generates more. @code{divide()} could use shifts instead of multiply and divide when scaling. @item -If an open fails because there are no unused file handles, GC should -be done so that file handles which are no longer used can be -collected. -@item Currently, @code{dump}ing an executable does not preserve ports. When loading a @code{dump}ed executable, disk files could be reopened to the same file and position as they had when the executable was dumped. @@ -7464,24 +7830,6 @@ 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. @item -The @code{must-} or @code{make-} routines need some sort of C macros or -conditionalization so that they check: - -@itemize @bullet -@item -that the @code{LENGTH} field fits into a @code{size_t} (as is checked -now) for platforms with @code{(sizeof(size_t) < sizeof(SCM))}. -@item -that the @code{LENGTH} field fits into 24 (or 56) bits on machines where -@code{size_t} is 32 bits or more. -@end itemize - -This is trickier than it first looks because the must_malloc() routine -is also used for allocating heap segments, which do not have the -@code{LENGTH} field restriction. Putting the 24 bit test into -@code{must_malloc()} should be tested for speed impact. - -@item In the quest for speed, there has been some discussion about a "Forth" style Scheme interpreter. @@ -7781,5 +8129,10 @@ This is an alphabetical list of data types and feature names in SCM. @printindex tp +This is an alphabetical list of concepts introduced in this manual. + +@unnumbered Concept Index +@printindex cp + @contents @bye @@ -1,18 +1,18 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc. - * +/* Copyright (C) 1990-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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "scmfig.h" system-dependent configuration. @@ -54,7 +54,7 @@ /* IMPLINIT is the full pathname (surrounded by double quotes) of Init.scm, the Scheme initialization code. This is best defined in - the makefile. If available, scm uses the value of environment + the makefile. If available, SCM uses the value of environment variable SCM_INIT_PATH instead of IMPLINIT. */ /* #define IMPLINIT "/usr/jaffer/scm/Init.scm" */ @@ -92,7 +92,9 @@ rgx.c init_rgx(); regcomp and regexec. */ (sizeof(float)==sizeof(long)) */ #ifdef FLOATS -# define SINGLES +# ifndef _MSC_VER +# define SINGLES +# endif #endif /* #define SINGLESONLY */ @@ -153,6 +155,12 @@ rgx.c init_rgx(); regcomp and regexec. */ # define GC_FREE_SEGMENTS #endif +/* MEMOIZE_LOCALS means to convert references to local variables to ILOCs, + (relative lexical addresses into the environment). This memoization + makes evaluated Scheme code harder to read, so you may want to undefine + this flag for debugging -- but SCM will run 3 to 5 times slower */ +#define MEMOIZE_LOCALS + /* #define CHEAP_CONTINUATIONS */ /* #define TICKS */ @@ -165,11 +173,11 @@ rgx.c init_rgx(); regcomp and regexec. */ /* #define PROT386 */ -/* #define NON_PREEMPTIVE and RTL if you are using an non-preemptive - operating system in which periodic polling for interrupts is - necessary. Provide your own main procedure (e.g., WinMain, in - Windows). Define and initialize unsigned int poll_count, and - provide a procedure named poll_routine(), which POLL calls each +/* #define NON_PREEMPTIVE if you are using an non-preemptive operating + system in which periodic polling for interrupts is necessary. + Provide your own main procedure (e.g., WinMain, in Windows) or + modify "scmmain.c". Define and initialize unsigned int poll_count, + and provide a procedure named poll_routine(), which POLL calls each time poll_count reaches zero. poll_routine() must reinitialize poll_count. It may also check for external actions, such as Windows messages. The value assigned to poll_count can be quite @@ -228,16 +236,22 @@ rgx.c init_rgx(); regcomp and regexec. */ # endif # endif #endif +#ifdef __alpha +# define SHORT_INT +#endif #ifdef MSDOS /* Microsoft C 5.10 and 6.00A */ # ifndef GO32 # define SHORT_INT +# define SHORT_SIZET # endif #endif #ifdef _QC # define SHORT_INT +# define SHORT_SIZET #endif #ifdef __TURBOC__ # define SHORT_INT +# define SHORT_SIZET # define LACK_SBRK # ifndef __TOS__ # define MSDOS @@ -266,7 +280,7 @@ rgx.c init_rgx(); regcomp and regexec. */ #ifdef linux # define HAVE_SELECT # define HAVE_SYS_TIME_H -# define STDC_HEADERS +# define STDC_HEADERS #endif #ifdef _UNICOS @@ -282,11 +296,14 @@ rgx.c init_rgx(); regcomp and regexec. */ # define LACK_FTIME # define STDC_HEADERS # define USE_ANSI_PROTOTYPES -# define HAVE_SELECT # define HAVE_SYS_TIME_H # define __svr4__ #endif +#ifdef __svr4__ +# define HAVE_SELECT +#endif + #ifdef hpux # define LACK_E_IDs #endif @@ -299,9 +316,17 @@ rgx.c init_rgx(); regcomp and regexec. */ #ifdef __CYGWIN32__ # define LACK_FTIME +# define HAVE_SELECT +# define HAVE_SYS_TIME_H # undef MSDOS #endif +#ifdef __amigados__ +# define HAVE_SELECT +# define HAVE_SYS_TIME_H +# define LACK_SBRK +#endif + /* PROMPT is the prompt string printed at top level */ #ifndef PROMPT @@ -351,6 +376,10 @@ rgx.c init_rgx(); regcomp and regexec. */ # define BIGUP(x) ((unsigned long)(x) << BITSPERDIG) # define BIGDN(x) ((x) >> BITSPERDIG) # define BIGLO(x) ((x) & (BIGRAD-1)) +/* NUMDIGS_MAX is the maximum number of digits for BIGNUMS */ +# ifndef NUMDIGS_MAX +# define NUMDIGS_MAX 1000 +# endif #endif #ifndef BIGDIG @@ -541,15 +570,13 @@ extern ints_infot *ints_info; # define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*CHAR_BIT*3+9)/10) #endif /* FLOATS */ -/* MAXEXP is the maximum double precision expontent */ +/* MAXEXP is the maximum double precision exponent */ /* FLTMAX is less than or equal the largest single precision float */ #ifdef FLOATS # ifdef STDC_HEADERS -# ifndef GO32 -# ifndef macintosh -# include <float.h> -# endif +# ifndef macintosh +# include <float.h> # endif # endif # ifdef DBL_MAX_10_EXP @@ -557,6 +584,12 @@ extern ints_infot *ints_info; # else # define MAXEXP 308 /* IEEE doubles */ # endif +# ifndef DBL_DIG +# define DBL_DIG 15 +# endif +# ifndef DBL_MAX_EXP +# define DBL_MAX_EXP 1024 +# endif # ifdef FLT_MAX # define FLTMAX FLT_MAX # else @@ -571,9 +604,7 @@ extern ints_infot *ints_info; #endif #ifdef unix /* DJGPP (gcc for i386) defines unix! */ -# ifndef GO32 -# define HAVE_PIPE -# endif +# define HAVE_PIPE #endif /* IS_INF tests its floating point number for infiniteness */ @@ -632,7 +663,7 @@ typedef SCM *SCMPTR; #endif /* On VMS, GNU C's errno.h contains a special hack to get link attributes - for errno correct for linking to the C RTL. */ + for errno correct for linking with libc. */ #include <errno.h> @@ -640,23 +671,37 @@ typedef SCM *SCMPTR; #ifdef vms # ifndef __GNUC__ # include <ssdef.h> -# define SYSCALL(line) do{errno = 0;line} \ - while(EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3)) +# define SCM_INTERRUPTED(errno) (EVMSERR==errno && \ + (vaxc$errno>>3)==(SS$_CONTROLC>>3)) # endif #endif -#ifndef SYSCALL +#ifndef SCM_INTERRUPTED # ifdef EINTR # if (EINTR > 0) -# define SYSCALL(line) do{errno = 0;line}while(EINTR==errno) +# define SCM_INTERRUPTED(errno) (EINTR==errno) # endif # endif #endif -#ifndef SYSCALL -# define SYSCALL(line) {line} +#ifndef SCM_INTERRUPTED +# define SCM_INTERRUPTED(errno) (0) #endif +#define SYSCALL(line) do{errno = 0;line}while(SCM_INTERRUPTED(errno)) + +#ifdef EMFILE +# define SCM_NEED_FDS(errno) (EMFILE==errno || ENFILE==errno) +#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();\ + else if (!SCM_INTERRUPTED(errno)) break;}} + #ifndef MSDOS # ifdef ARM_ULIB extern volatile int errno; diff --git a/scmmain.c b/scmmain.c new file mode 100644 index 0000000..3f920dd --- /dev/null +++ b/scmmain.c @@ -0,0 +1,145 @@ +/* Copyright (C) 1990-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. + */ + +/* "scmmain.c" main() for SCM. + Author: Aubrey Jaffer */ + +#include "scm.h" +#include "patchlvl.h" + +#ifndef GENERIC_NAME +# define GENERIC_NAME "scm" +#endif +#ifndef INIT_GETENV +# define INIT_GETENV "SCM_INIT_PATH" +#endif + +char *scm_find_implpath(execpath) + char *execpath; +{ + char *implpath = 0; +#ifndef nosve + char *getenvpath = getenv(INIT_GETENV); + /* fprintf(stderr, "%s=%s\n", INIT_GETENV, getenvpath); fflush(stderr); */ + if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L); + if (implpath) {/* The value of the environment variable supersedes + other locations, only if the file exists. */ + implpath = scm_try_path(implpath); + if (!implpath) { + fputs("Value of "INIT_GETENV" (=\"", stderr); + fputs(getenvpath, stderr); + fputs("\") not found; Trying elsewhere\n", stderr); + } + } +#endif + if (!implpath && execpath) + implpath = find_impl_file(execpath, GENERIC_NAME, INIT_FILE_NAME, dirsep); +#ifdef IMPLINIT + if (!implpath) implpath = scm_cat_path(0L, IMPLINIT, 0L); +#endif + return implpath; +} +char *generic_name[] = { GENERIC_NAME }; + +int main(argc, argv) + int argc; + char **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; + +/* {char ** argvv = argv; */ +/* 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 + 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 */ + nargc = script_count_argv(nargv); + } + else {nargv = argv; nargc = argc;} + /* execpath must be set to executable's path in order to use DUMP or DLD. */ + execpath = scm_find_execpath(nargc, nargv, script_arg); + implpath = scm_find_implpath(execpath); + if (isatty(fileno(stdin)) && isatty(fileno(stdout))) + iverbose = (nargc <= 1) ? 2 : 1; + buf0stdin = init_buf0(stdin); + do { /* You must call scm_init_from_argv() + or init_scm() to initialize SCM */ + scm_init_from_argv(nargc, nargv, script_arg, iverbose, buf0stdin); + init_signals(); /* signals are optional */ + /* Now we are ready to run Scheme code! */ + retval = scm_top_level(implpath, 0L); + restore_signals(); /* signals are optional */ + /* final_scm() when you are done with SCM. */ + if (retval) break; + dumped = 0; + if (2 <= iverbose) fputs(";RESTART\n", stderr); + final_scm(!0); + } while (!0); + final_scm( +#ifdef CAREFUL_INTS + 1 +#else + freeall || (2 <= verbose) +#endif + ); + if (2 <= iverbose) fputs(";EXIT\n", stderr); + fflush(stderr); + if (implpath) free(implpath); + if (execpath) free(execpath); + execpath = 0; + return (int)INUM(retval); +} + +/* init_user_scm() is called by the scheme procedure + SCM_INIT_EXTENSIONS in "Init5xx.scm" */ +void init_user_scm() +{ + /* Put calls to your C initialization routines here. */ +} @@ -1,18 +1,18 @@ -/* Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - * +/* Copyright (C) 1994-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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "script.c" argv tricks for `#!' scripts. @@ -140,10 +140,13 @@ char *script_find_executable(name) if (!f) return 0L; if ((fgetc(f)=='#') && (fgetc(f)=='!')) { while (1) switch (tbuf[i++] = fgetc(f)) { - case /*WHITE_SPACES*/ ' ':case '\t':case '\r':case '\f': + case ' ': + if (1==i) {i--; break;} + case '\t':case '\r':case '\f': case EOF: tbuf[--i] = 0; fclose(f); + if (0==i) return 0L; return scm_cat_path(0L, tbuf, 0L); } } @@ -172,7 +175,7 @@ char *dld_find_executable(file) implementation-vicinity of this program. Returns a newly allocated string if successful, 0 if not */ -char *scm_find_impl_file(exec_path, generic_name, initname, sep) +char *find_impl_file(exec_path, generic_name, initname, sep) char *exec_path; const char *generic_name, *initname, *sep; { @@ -234,13 +237,35 @@ char *scm_find_impl_file(exec_path, generic_name, initname, sep) for(peer="lib";!0;peer="src") { path = scm_cat_path(0L, exec_path, sepind); if (path) { - strncpy(path + sepind - 4, "lib", 3); + strncpy(path + sepind - 4, peer, 3); path = scm_cat_path(path, generic_name, 0L); path = scm_sep_init_try(path, sep, initname); if (path) return path; } if (!strcmp(peer,"src")) break; - }}} + }} + + /* Look for initname in executable-name peer directory. */ + path = scm_cat_path(0L, exec_path, sepind); + if (path) { + path[sepind - 4] = 0; + path = scm_cat_path(path, &exec_path[sepind], 0L); + path = scm_sep_init_try(path, sep, initname); + if (path) return path; + } + + if (generic_name) { + + /* Look for initname in generic peer directory. */ + path = scm_cat_path(0L, exec_path, sepind); + if (path) { + path[sepind - 4] = 0; + path = scm_cat_path(path, generic_name, 0L); + path = scm_sep_init_try(path, sep, initname); + if (path) return path; + } + } + } #ifdef MSDOS if (strlen(extptr)) { @@ -367,8 +392,8 @@ char **script_process_argv(argc, argv) if (!(nargv = (char **)realloc(nargv, (1 + ++nargc) * sizeof(char*)))) return 0L; else nargv[nargi++] = narg; - fclose(f); - nargv[nargi++] = argv[argi++]; + fclose(f); + nargv[nargi++] = argv[argi++]; } } while (argi <= argc) nargv[nargi++] = argv[argi++]; @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "setjump.h" memory and stack parameters. @@ -125,11 +125,21 @@ /* other.dynenv and other.parent get GCed just by being there. */ struct scm_other {SCM dynenv; SCM parent; - SCM env; + SCM stkframe[2]; + SCM estk; + SCM *estk_ptr; }; #define CONTINUATION_OTHER struct scm_other #define CONT(x) ((CONTINUATION *)CDR(x)) #define SETCONT SETCDR -void dowinds P((SCM to, long delta)); +void dowinds P((SCM to)); #include "continue.h" + +typedef struct safeport { + SCM port; + jmp_buf jmpbuf; /* The usual C jmp_buf, not SCM's jump_buf */ + int ccnt; +} safeport; + +#define SAFEP_JMPBUF(sfp) (((safeport *)STREAM(sfp))->jmpbuf) @@ -1,18 +1,18 @@ /* Copyright (C) 1994, 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "socket.c" internet stream socket support for client/server in SCM @@ -308,11 +308,13 @@ SCM l_socket(fam, proto) SYSCALL(sd = socket(tp, SOCK_STREAM, INUM(proto));); if (-1==sd) wta(UNDEFINED, (char *)NALLOC, s_socket); SYSCALL(f = fdopen(sd, "r+");); + /* SCM_OPENCALL(f = fdopen(sd, "r+")); */ if (!f) { close(sd); wta(MAKINUM(sd), (char *)NALLOC, s_port_type); } - CAR(port) = tc_socket | (tp<<24) | BUF0; + CAR(port) = scm_port_entry(tc_socket, BUF0); + SCM_PORTDATA(port) = fam; SETSTREAM(port, f); i_setbuf0(port); ALLOW_INTS; @@ -341,18 +343,19 @@ SCM l_socketpair(fam, proto) DEFER_INTS; SYSCALL(sts = socketpair(tp, SOCK_STREAM, INUM(proto), sv);); if (-1==sts) wta(UNDEFINED, (char *)NALLOC, s_socketpair); - SYSCALL(f[0] = fdopen(sv[0], "r+");); + SCM_OPENCALL(f[0] = fdopen(sv[0], "r+")); if (!f[0]) { close(sv[0]); wta(MAKINUM(sv[0]), (char *)NALLOC, s_port_type); } - SYSCALL(f[1] = fdopen(sv[1], "r+");); + SCM_OPENCALL(f[1] = fdopen(sv[1], "r+")); if (!f[1]) { fclose(f[0]); close(sv[1]); wta(MAKINUM(sv[1]), (char *)NALLOC, s_port_type); } - CAR(port[0]) = CAR(port[1]) = tc16_fport | mode_bits("r+0"); + 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]); i_setbuf0(port[0]); i_setbuf0(port[1]); ALLOW_INTS; @@ -364,7 +367,7 @@ SCM l_shutdown(port, how) SCM port, how; { int sts; - ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_shutdown); + ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_shutdown); ASSERT(INUMP(how) && 0 <= INUM(how) && 2 >= INUM(how), how, ARG2, s_shutdown); SYSCALL(sts = shutdown(fileno(STREAM(port)), INUM(how));); @@ -416,7 +419,8 @@ SCM l_connect (sockpt, address, arg) break; } if (sts) return BOOL_F; - CAR(sockpt) = tc16_fport | mode_bits("r+0"); + CAR(sockpt) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0)); + SCM_PORTDATA(sockpt) = cons(address, arg); return sockpt; } @@ -465,7 +469,9 @@ SCM l_listen(port, backlog) ASSERT(INUMP(backlog), backlog, ARG2, s_listen); SYSCALL(sts = listen(fileno(STREAM(port)), INUM(backlog));); if (sts) return BOOL_F; - CAR(port) = tc16_fport | mode_bits("r0"); + DEFER_INTS; + CAR(port) = scm_port_entry(tc16_fport, mode_bits("r0", (char *)0)); + ALLOW_INTS; return port; } @@ -489,12 +495,12 @@ SCM l_accept(sockpt) wta(sockpt, "couldn't", s_accept); } DEFER_INTS; - SYSCALL(newfd = fdopen(newsd, "r+");); + SCM_OPENCALL(newfd = fdopen(newsd, "r+")); if (!newfd) { close(newsd); wta(MAKINUM(newsd), (char *)NALLOC, s_port_type); } - CAR(newpt) = tc16_fport | mode_bits("r+0"); + CAR(newpt) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0)); SETSTREAM(newpt, newfd); i_setbuf0(newpt); ALLOW_INTS; @@ -527,7 +533,7 @@ sizet sknm_free(p) CELLPTR p; { must_free(CHARS((SCM)p), sizeof(struct sockaddr)); - return sizeof(struct sockaddr); + return 0; } long tc16_sknm; static smobfuns sknm_smob = {mark0, sknm_free, sknm_print, 0}; @@ -574,10 +580,9 @@ SCM maksknm(sad) SCM sknm; struct sockaddr *msknm; DEFER_INTS; - sknm = must_malloc_cell(0L+sizeof(struct sockaddr), "sknm"); + sknm = must_malloc_cell(0L+sizeof(struct sockaddr), (SCM)tc16_sknm, "sknm"); msknm = (struct sockaddr *)CDR(sknm); *msknm = *sad; - CAR(sknm) = tc16_sknm; ALLOW_INTS; return sknm; } @@ -589,7 +594,7 @@ SCM l_getpeername(sockpt) struct sockaddr_in sad; int sts, sadlen = sizeof(sad); bzero((char *) &sad, sizeof(sad)); - ASSERT(NIMP(sockpt) && OPPORTP(sockpt), sockpt, ARG1, s_getpeername); + ASSERT(NIMP(sockpt) && OPFPORTP(sockpt), sockpt, ARG1, s_getpeername); SYSCALL(sts = getpeername(fileno(STREAM(sockpt)), (struct sockaddr*)&sad, &sadlen);); if (sts || sizeof(sad) != sadlen) return BOOL_F; @@ -603,7 +608,7 @@ SCM l_getsockname(sockpt) struct sockaddr_in sad; int sts, sadlen = sizeof(sad); bzero((char *) &sad, sizeof(sad)); - ASSERT(NIMP(sockpt) && OPPORTP(sockpt), sockpt, ARG1, s_getsockname); + ASSERT(NIMP(sockpt) && OPFPORTP(sockpt), sockpt, ARG1, s_getsockname); SYSCALL(sts = getsockname(fileno(STREAM(sockpt)), (struct sockaddr*)&sad, &sadlen);); if (sts || sizeof(sad) != sadlen) return BOOL_F; @@ -12,7 +12,7 @@ ;; ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "subr.c" integer and other Scheme procedures @@ -268,6 +268,13 @@ SCM assoc(x, alist) return BOOL_F; } +extern long tc16_promise; +SCM promisep(x) + SCM x; +{ + return NIMP(x) && (TYP16(x)==tc16_promise) ? BOOL_T : BOOL_F; +} + SCM symbolp(x) SCM x; { @@ -802,7 +809,6 @@ static char s_logand[] = "logand", s_lognot[] = "lognot", s_copybitfield[] = "copy-bit-field", s_ash[] = "ash", s_logcount[] = "logcount", s_intlength[] = "integer-length", - s_intexpt[] = "integer-expt", s_bitfield[] = "bit-field", s_bitif[] = "bitwise-if"; @@ -1042,28 +1048,6 @@ SCM scm_lognot(n) return difference(MAKINUM(-1L), n); } -SCM scm_intexpt(z1, z2) - SCM z1, z2; -{ - SCM acc = MAKINUM(1L); -#ifdef BIGDIG - if (INUM0==z1 || acc==z1) return z1; - else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; -#endif - ASSERT(INUMP(z2), z2, ARG2, s_intexpt); - z2 = INUM(z2); - if (z2 < 0) { - z2 = -z2; - z1 = divide(z1, UNDEFINED); - } - while(1) { - if (0==z2) return acc; - if (1==z2) return product(acc, z1); - if (z2 & 1) acc = product(acc, z1); - z1 = product(z1, z1); - z2 >>= 1; - } -} SCM scm_ash(n, cnt) SCM n, cnt; { @@ -1144,7 +1128,7 @@ SCM scm_copybitfield(to, start, rest) if (NINUMP(from) || NINUMP(to) || (INUM(end) >= LONG_BIT - 2)) { SCM mask = difference(scm_intexpt(MAKINUM(2), MAKINUM(len)), MAKINUM(1L)); mask = scm_ash(mask, start); - return scm_logior(scm_logand(mask, scm_ash(from, start)), + return scm_logior(scm_logand(mask, scm_ash(from, start)), scm_logand(scm_lognot(mask), to)); } #else @@ -1576,12 +1560,16 @@ SCM make_vector(k, fill) SCM v; register long i; register SCM *velts; +#ifdef SHORT_SIZET ASSERT(INUMP(k), k, ARG1, s_make_vector); +#else + ASSERT(INUMP(k) && (!(~LENGTH_MAX & INUM(k))), k, ARG1, s_make_vector); +#endif if UNBNDP(fill) fill = UNSPECIFIED; i = INUM(k); DEFER_INTS; - v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L, s_vector); - SETLENGTH(v, i, tc7_vector); + v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L, + MAKE_LENGTH(i, tc7_vector), s_vector); velts = VELTS(v); while(--i >= 0) (velts)[i] = fill; ALLOW_INTS; @@ -1593,19 +1581,12 @@ SCM mkbig(nlen, sign) sizet nlen; int sign; { - SCM v = nlen; - if (((v << 16) >> 16) != nlen) - wta(MAKINUM(v), (char *)NALLOC, s_bignum); + SCM v; + if (NUMDIGS_MAX <= nlen) wta(MAKINUM(nlen), (char *)NALLOC, s_bignum); DEFER_INTS; -#ifdef NUM_HP - if (nlen*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) { - NEWCELL(v); - SETCHARS(v, num_hp_alloc(nlen*sizeof(BIGDIG))); - } - else -#endif - v = must_malloc_cell((long)(nlen*sizeof(BIGDIG)), s_bignum); - SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos); + v = must_malloc_cell((0L+nlen)*sizeof(BIGDIG), + MAKE_NUMDIGS(nlen, sign?tc16_bigneg:tc16_bigpos), + s_bignum); ALLOW_INTS; return v; } @@ -1631,14 +1612,8 @@ SCM adjbig(b, nlen) if (((nsiz << 16) >> 16) != nlen) wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig); DEFER_INTS; -#ifdef NUM_HP - SETCHARS(b, (BIGDIG *)num_hp_realloc((char *)CHARS(b), - (long)NUMDIGS(b)*sizeof(BIGDIG), - nsiz*sizeof(BIGDIG), s_adjbig)); -#else must_realloc_cell(b, (long)(NUMDIGS(b)*sizeof(BIGDIG)), (long)(nsiz*sizeof(BIGDIG)), s_adjbig); -#endif SETNUMDIGS(b, nsiz, TYP16(b)); ALLOW_INTS; return b; @@ -1954,6 +1929,7 @@ SCM divbigbig(x, nx, y, ny, sgn, modes) #endif static iproc cxrs[] = { + {"cr", 0}, {"car", 0}, {"cdr", 0}, {"caar", 0}, {"cadr", 0}, {"cdar", 0}, {"cddr", 0}, {"caaar", 0}, {"caadr", 0}, {"cadar", 0}, {"caddr", 0}, @@ -1997,6 +1973,7 @@ static iproc subr1s[] = { {"vector?", vectorp}, {s_ve_length, vector_length}, {"procedure?", procedurep}, + {"promise?", promisep}, {0, 0}}; static char s_acons[] = "acons"; @@ -2015,7 +1992,6 @@ static iproc subr2s[] = { {s_logtest, scm_logtest}, {s_logbitp, scm_logbitp}, {s_ash, scm_ash}, - {s_intexpt, scm_intexpt}, {s_st_ref, st_ref}, {"string<=?", st_leqp}, {"string-ci<=?", stci_leqp}, @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "sys.c" opening and closing files, storage, and GC. */ @@ -114,11 +114,12 @@ char s_close_port[] = "close-port"; SCM i_setbuf0(port) /* should be called with DEFER_INTS active */ SCM port; { + VERIFY_INTS("i_setbuf0", 0L); #ifndef NOSETBUF # ifndef MSDOS # ifdef FIONREAD # ifndef ultrix - SYSCALL(setbuf(STREAM(port), 0);); + SYSCALL(setbuf(STREAM(port), 0L);); # endif # endif # endif @@ -126,12 +127,26 @@ SCM i_setbuf0(port) /* should be called with DEFER_INTS active */ return UNSPECIFIED; } -long mode_bits(modes) - char *modes; -{ - return OPN | (strchr(modes, 'r') || strchr(modes, '+') ? RDNG : 0) - | (strchr(modes, 'w') || strchr(modes, 'a') || strchr(modes, '+') ? WRTNG : 0) - | (strchr(modes, '0') ? BUF0 : 0); +/* The CRDY bit is overloaded to indicate that additional processing + is needed when reading or writing, such as updating line and column + numbers. */ +long mode_bits(modes, cmodes) + char *modes, *cmodes; +{ + int iout = 0; + long bits = OPN; + for (; *modes; modes++) + switch (*modes) { + case 'r': bits |= RDNG; goto outc; + case 'w': case 'a': bits |= WRTNG; goto outc; + case '+': bits |= (RDNG | WRTNG); goto outc; + case 'b': bits |= BINARY; goto outc; + case '0': bits |= BUF0; break; + case '?': bits |= (TRACKED | CRDY); break; + outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break; + } + if (cmodes) cmodes[iout] = 0; + return bits; } SCM try_open_file(filename, modes) @@ -139,18 +154,22 @@ SCM try_open_file(filename, modes) { register SCM port; FILE *f; + char cmodes[4]; + long flags = mode_bits(CHARS(modes), cmodes); ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file); ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file); NEWCELL(port); DEFER_INTS; - SYSCALL(f = fopen(CHARS(filename), CHARS(modes));); - if (!f) port = BOOL_F; - else { - SETSTREAM(port, f); - if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes)))) - i_setbuf0(port); + 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); + if (BUF0 & flags) i_setbuf0(port); ALLOW_INTS; + SCM_PORTDATA(port) = filename; return port; } @@ -195,7 +214,7 @@ SCM output_portp(x) # undef L_tmpnam /* Not supported in TURBOC V1.0 */ #endif #ifdef GO32 -# undef L_tmpnam +# undef L_tmpnam /* Would put files in %TMPDIR% = %DJDIR%/tmp */ #endif #ifdef MWC # undef L_tmpnam @@ -300,24 +319,6 @@ void prinport(exp, port, type) else intprint(CDR(exp), -16, port); lputc('>', port); } -static int prinfport(exp, port, writing) - SCM exp; SCM port; int writing; -{ - prinport(exp, port, s_port_type); - return !0; -} -static int prinstpt(exp, port, writing) - SCM exp; SCM port; int writing; -{ - prinport(exp, port, s_string); - return !0; -} -static int prinsfpt(exp, port, writing) - SCM exp; SCM port; int writing; -{ - prinport(exp, port, "soft"); - return !0; -} static int stputc(c, p) int c; SCM p; @@ -374,7 +375,7 @@ SCM mkstrport(pos, str, modes, caller) NEWCELL(z); DEFER_INTS; SETCHARS(z, str); - CAR(z) = tc16_strport | modes; + CAR(z) = scm_port_entry(tc16_strport, modes); ALLOW_INTS; return z; } @@ -412,9 +413,10 @@ sizet pwrite(ptr, size, nitems, port) #endif static ptobfuns fptob = { + s_port_type, mark0, fclose, - prinfport, + 0, 0, fputc, #ifdef __MWERKS__ @@ -428,9 +430,10 @@ static ptobfuns fptob = { fgetc, fclose}; ptobfuns pipob = { + 0, mark0, - 0, /* replaced by pclose in init_ioext() */ - 0, /* replaced by prinpipe in init_ioext() */ + 0, /* replaced by pclose in init_ioext() */ + 0, 0, fputc, #ifdef __MWERKS__ @@ -441,19 +444,20 @@ ptobfuns pipob = { ffwrite, #endif fflush, - fgetc, - 0}; /* replaced by pclose in init_ioext() */ + fgetc}; static ptobfuns stptob = { + s_string, markcdr, noop0, - prinstpt, + 0, 0, stputc, stputs, stwrite, noop0, stgetc, - 0}; + 0}; /* stungetc */ + /* Soft ports */ @@ -465,7 +469,8 @@ static ptobfuns stptob = { static int sfputc(c, p) int c; SCM p; { - apply(VELTS(p)[0], MAKICHR(c), listofnull); + SCM arg = MAKICHR(c); + scm_cvapply(VELTS(p)[0], 1L, &arg); errno = 0; return c; } @@ -475,7 +480,7 @@ sizet sfwrite(str, siz, num, p) { SCM sstr; sstr = makfromstr(str, siz * num); - apply(VELTS(p)[1], sstr, listofnull); + scm_cvapply(VELTS(p)[1], 1L, &sstr); errno = 0; return num; } @@ -498,7 +503,7 @@ static int sfgetc(p) SCM p; { SCM ans; - ans = apply(VELTS(p)[3], EOL, EOL); + ans = scm_cvapply(VELTS(p)[3], 0L, (SCM *)0); errno = 0; if (FALSEP(ans) || EOF_VAL==ans) return EOF; ASSERT(ICHRP(ans), ans, ARG1, "getc"); @@ -518,20 +523,31 @@ SCM mksfpt(pv, modes) SCM pv, modes; { SCM z; - ASSERT(NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv), pv, ARG1, s_mksfpt); + static long arities[] = {1, 1, 0, 0, 0}; +#ifndef RECKLESS + int i; + if (! (NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv))) + badarg: wta(pv, (char *)ARG1, s_mksfpt); + for (i = 0; i < 5; i++) { + ASRTGO(FALSEP(VELTS(pv)[i]) || + scm_arity_check(VELTS(pv)[i], arities[i], (char *)0), + badarg); + } +#endif ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt); NEWCELL(z); DEFER_INTS; - CAR(z) = tc16_sfport | mode_bits(CHARS(modes)); + CAR(z) = scm_port_entry(tc16_sfport, mode_bits(CHARS(modes), (char *)0)); SETSTREAM(z, pv); ALLOW_INTS; return z; } static ptobfuns sfptob = { + "soft", markcdr, noop0, - prinsfpt, + 0, 0, sfputc, sfputs, @@ -567,7 +583,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) { - warn("output buffer", " overflowed"); + scm_warn("output buffer", " overflowed"); intprint((long)errbuf_end, 10, cur_errp); lputs(" chars needed\n", cur_errp); errbuf_end = errbuf_end % SYS_ERRP_SIZE; @@ -603,6 +619,7 @@ static int sysflush(p) return 0; } static ptobfuns sysptob = { + 0, mark0, noop0, 0, @@ -614,6 +631,105 @@ static ptobfuns sysptob = { noop0, noop0}; +/* A `safeport' is used for writing objects as part of an error response. + Since these objects may be very large or circular, the safeport will + output only a fixed number of characters before exiting via longjmp. + A setjmp must be done before each use of the safeport. */ + +static char s_msp[] = "mksafeport"; +int tc16_safeport; +SCM mksafeport(maxlen, port) + int maxlen; + SCM port; +{ + SCM z; + if UNBNDP(port) port = cur_errp; + else { + ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp); + } + DEFER_INTS; + 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) + int maxlen; + SCM sfp, port; +{ + if (NIMP(sfp) && tc16_safeport==TYP16(sfp)) { + ((safeport *)STREAM(sfp))->ccnt = maxlen; + if NIMP(port) + ((safeport *)STREAM(sfp))->port = port; + return !0; + } + return 0; +} +static sizet safewrite(str, siz, num, p) + sizet siz, num; + char *str; safeport *p; +{ + int count = p->ccnt; + sizet n = siz*num; + if (n < count) { + p->ccnt = count - n; + lfwrite(str, siz, num, p->port); + } + else if (count) { + num = count / siz; + p->ccnt = 0; + lfwrite(str, siz, num, p->port); + lputs(" ...", p->port); + longjmp(p->jmpbuf, !0); /* The usual C longjmp, not SCM's longjump */ + } + return siz; +} +static int safeputs(s, p) + char *s; safeport *p; +{ + safewrite(s, 1, strlen(s), p); + return 0; +} +static int safeputc(c, p) + int c; safeport *p; +{ + char cc = c; + safewrite(&cc, 1, 1, p); + return c; +} +static int safeflush(p) + safeport *p; +{ + lflush(p->port); + return 0; +} +static SCM marksafep(ptr) + SCM ptr; +{ + return ((safeport *)STREAM(ptr))->port; +} +static int freesafep(ptr) + FILE *ptr; +{ + must_free((char *)ptr, sizeof(safeport)); + return 0; +} +static ptobfuns safeptob = { + 0, + marksafep, + freesafep, + 0, + 0, + safeputc, + safeputs, + safewrite, + safeflush, + noop0, + noop0}; + static int freeprint(exp, port, writing) SCM exp; SCM port; int writing; { @@ -644,48 +760,72 @@ static smobfuns flob = { mark0, /*flofree*/0, floprint, - floequal}; +#ifdef FLOATS + floequal +#else + 0 +#endif +}; static smobfuns bigob = { mark0, /*bigfree*/0, bigprint, - bigequal}; -void (**finals)() = 0; -sizet num_finals = 0; +#ifdef BIGDIG + bigequal +#else + 0 +#endif +}; + +scm_gra finals_gra; static char s_final[] = "final"; +/* statically allocated ports for diagnostic messages */ +static cell tmp_errpbuf[3]; +static SCM tmp_errp; +extern sizet num_protects; /* sys_protects now in scl.c */ void init_types() { - numptob = 0; - ptobs = (ptobfuns *)malloc(4*sizeof(ptobfuns)); + sizet j = num_protects; + /* Because not all protects may get initialized */ + while(j) sys_protects[--j] = BOOL_F; + + /* We need to set up tmp_errp before any errors may be + thrown, the port_table index will be zero, usable + 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); + 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"); /* 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_sysport = newptob(&sysptob); - numsmob = 0; - smobs = (smobfuns *)malloc(7*sizeof(smobfuns)); + tc16_safeport = newptob(&safeptob); + scm_init_gra(&smobs_gra, sizeof(smobfuns), 7, 255, "smobs"); /* These newsmob calls must be done in this order */ newsmob(&freecell); newsmob(&flob); newsmob(&bigob); newsmob(&bigob); - finals = (void(**)())malloc(2 * sizeof(finals[0])); - num_finals = 0; + scm_init_gra(&finals_gra, sizeof(void (*)()), 2, 0, s_final); } +#ifdef TEST_FINAL +void test_final() +{ + fputs("test_final ok\n", stderr); +} +#endif void add_final(final) void (* final)(); { - DEFER_INTS; - finals = (void (**)()) must_realloc((char *)finals, - (long)(num_finals)*sizeof(finals[0]), - (1L+num_finals)*sizeof(finals[0]), - s_final); - finals[num_finals++] = final; - ALLOW_INTS; - return; + scm_grow_gra(&finals_gra, (char *)&final); } static char s_estk[] = "environment stack"; @@ -694,100 +834,131 @@ SCM scm_egc_roots[ECACHE_SIZE/20]; CELLPTR scm_ecache; VOLATILE long scm_ecache_index, scm_ecache_len, scm_egc_root_index; SCM scm_estk = UNDEFINED, *scm_estk_ptr; -void scm_estk_reset() +static SCM estk_pool = EOL; +long scm_estk_size; +static SCM make_stk_seg(size, contents) + sizet size; + SCM contents; { - SCM nstk = scm_estk, *v; + SCM seg = BOOL_F, *src, *dst; sizet i; - VERIFY_INTS("scm_estk_reset", 0); - /* We might be here because we blew the stack, or got tired of - watching it grow, so make sure the stack size is sane. */ - if (IMP(nstk) || 50*SCM_ESTK_FRLEN < LENGTH(nstk)) { - i = 50L*SCM_ESTK_FRLEN + 1; - nstk = must_malloc_cell((long)i*sizeof(SCM), s_estk); - SETLENGTH(nstk, i, tc7_vector); + VERIFY_INTS("make_stk_seg", 0L); + while NIMP(estk_pool) { + if (size==LENGTH(estk_pool)) { + seg = estk_pool; + estk_pool = SCM_ESTK_PARENT(seg); + break; + } + estk_pool = SCM_ESTK_PARENT(estk_pool); + } + if IMP(seg) seg = must_malloc_cell((long)size*sizeof(SCM), + MAKE_LENGTH(size, tc7_vector), s_estk); + dst = VELTS(seg); + if NIMP(contents) { + src = VELTS(contents); + for (i = size; i--;) dst[i] = src[i]; + } + else { + for (i = size; i--;) dst[i] = UNSPECIFIED; + SCM_ESTK_PARENT(seg) = BOOL_F; + SCM_ESTK_PARENT_INDEX(seg) = INUM0; + dst[SCM_ESTK_BASE - 1] = UNDEFINED; /* underflow sentinel */ + } + dst[size - 1] = UNDEFINED; /* overflow sentinel */ + return seg; +} +/* size is a number of SCM elements, or zero for a default size. + If nonzero, size must be SCM_ESTK_BASE + N * SCM_ESTK_FRLEN + 1 + for some reasonable number of stackframes N */ +void scm_estk_reset(size) + sizet size; +{ + VERIFY_INTS("scm_estk_reset", 0L); + 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; +} +void scm_estk_grow() +{ + /* 40 and 10 below are adjustable parameters: the number of frames + in a stack segment, and the number of frames to overlap between + stack segments. */ + sizet size = 40 * SCM_ESTK_FRLEN + SCM_ESTK_BASE + 1; + sizet overlap = 10*SCM_ESTK_FRLEN; + SCM estk = make_stk_seg(size, UNDEFINED); + SCM *newv, *oldv; + sizet i, j; + newv = VELTS(estk); + oldv = VELTS(scm_estk); + j = scm_estk_ptr - VELTS(scm_estk) + 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); + for (i = SCM_ESTK_BASE; i < SCM_ESTK_BASE + overlap; i++, j++) { + newv[i] = oldv[j]; + oldv[j] = BOOL_F; } - i = LENGTH(nstk); - v = VELTS(nstk); - while (i--) v[i] = UNSPECIFIED; - v[LENGTH(nstk)-1] = INUM0; /* overflow sentinel */ - v[0] = INUM0; /* underflow sentinel */ - /* The following are for a (future) segmented - stack implementation. */ - v[1] = BOOL_T; /* writable? */ - v[SCM_ESTK_FRLEN] = EOL; /* Must look like an environment */ - v[SCM_ESTK_FRLEN + 1] = EOL; /* next stack segment */ - scm_estk = nstk; - scm_estk_ptr = &(v[SCM_ESTK_BASE - SCM_ESTK_FRLEN]); -} - -void scm_estk_grow(inc) - sizet inc; -{ - SCM estk = make_vector(MAKINUM(LENGTH(scm_estk) + inc*SCM_ESTK_FRLEN), - UNSPECIFIED); - sizet n, i; - DEFER_INTS; - n = scm_estk_ptr - VELTS(scm_estk); - ASSERT(n<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", "scm_estk_grow"); - for (i = n + 1; i--;) - VELTS(estk)[i] = VELTS(scm_estk)[i]; - /* Sentinel for stack overflow. */ - VELTS(estk)[LENGTH(estk)-1] = INUM0; scm_estk = estk; - scm_estk_ptr = &(VELTS(estk)[n + SCM_ESTK_FRLEN]); - ALLOW_INTS; - growth_mon(s_estk, LENGTH(scm_estk), "locations", !0); + scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]); + scm_estk_size += size; + /* growth_mon(s_estk, scm_estk_size, "locations", !0); */ } - -/* Will be useful when segmented stack is implemented. */ void scm_estk_shrink() { -#if 0 - SCM next = VELTS(scm_estk)[SCM_ESTK_FRLEN]; - int istrt; - if IMP(next) wta(UNDEFINED, "underflow", "stack"); - istrt = INUM(CDR(next)); - next = CAR(next); - if (BOOL_T != VELTS(next)[1]) { - SCM new_estk = make_vector(MAKINUM(LENGTH(scm_estk)), UNSPECIFIED); - int i = istrt; - while (--i) VELTS(new_estk)[i] = VELTS(next)[i]; - VELTS(new_estk)[1] = BOOL_T; - VELTS(new_estk)[LENGTH(new_estk)-1] = INUM0; - next = new_estk; - } - scm_estk = next; - scm_estk_ptr = &(VELTS(scm_estk)[istrt]); -#else - wta(UNDEFINED, "underflow", s_estk); -#endif + SCM parent, *v; + 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); + SCM_ESTK_PARENT(scm_estk) = estk_pool; + estk_pool = scm_estk; + scm_estk_size -= LENGTH(scm_estk); + scm_estk = parent; + scm_estk_ptr = &(VELTS(parent)[i]); + /* growth_mon(s_estk, scm_estk_size, "locations", 0); */ } void scm_env_cons(x, y) SCM x, y; { register SCM z; + register int i; DEFER_INTS_EGC; - if (1>scm_ecache_index) scm_egc(); - z = PTR2SCM(&(scm_ecache[--scm_ecache_index])); + i = scm_ecache_index; + if (1>i) { + scm_egc(); + i = scm_ecache_index; + } + z = PTR2SCM(&(scm_ecache[--i])); CAR(z) = x; CDR(z) = y; scm_env_tmp = z; + scm_ecache_index = i; } void scm_env_cons2(w, x, y) SCM w, x, y; { SCM z1, z2; + register int i; DEFER_INTS_EGC; - if (2>scm_ecache_index) scm_egc(); - z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index])); + i = scm_ecache_index; + if (2>i) { + scm_egc(); + i = scm_ecache_index; + } + z1 = PTR2SCM(&(scm_ecache[--i])); CAR(z1) = x; CDR(z1) = y; - z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index])); + z2 = PTR2SCM(&(scm_ecache[--i])); CAR(z2) = w; CDR(z2) = z1; - scm_env_tmp = z2; + scm_env_tmp = z2; + scm_ecache_index = i; } /* scm_env_tmp = cons(x, scm_env_tmp) */ @@ -795,12 +966,41 @@ void scm_env_cons_tmp(x) SCM x; { register SCM z; + register int i; DEFER_INTS_EGC; - if (1>scm_ecache_index) scm_egc(); - z = PTR2SCM(&(scm_ecache[--scm_ecache_index])); + i = scm_ecache_index; + if (1>i) { + scm_egc(); + i = scm_ecache_index; + } + z = PTR2SCM(&(scm_ecache[--i])); CAR(z) = x; CDR(z) = scm_env_tmp; scm_env_tmp = z; + scm_ecache_index = i; +} + +void scm_env_v2lst(argc, argv) + int argc; + SCM *argv; +{ + SCM z1, z2; + register int i; + DEFER_INTS_EGC; + i = scm_ecache_index; + if (argc>i) { + scm_egc(); + i = scm_ecache_index; + } + z1 = z2 = scm_env_tmp; /* set z1 just in case argc is zero */ + while (argc--) { + z1 = PTR2SCM(&(scm_ecache[--i])); + CAR(z1) = argv[argc]; + CDR(z1) = z2; + z2 = z1; + } + scm_env_tmp = z1; + scm_ecache_index = i; } /* scm_env = acons(names, scm_env_tmp, scm_env) */ @@ -808,15 +1008,21 @@ void scm_extend_env(names) SCM names; { SCM z1, z2; + register int i; DEFER_INTS_EGC; - if (2>scm_ecache_index) scm_egc(); - z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index])); + i = scm_ecache_index; + if (2>i) { + scm_egc(); + i = scm_ecache_index; + } + z1 = PTR2SCM(&(scm_ecache[--i])); CAR(z1) = names; CDR(z1) = scm_env_tmp; - z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index])); + z2 = PTR2SCM(&(scm_ecache[--i])); CAR(z2) = z1; CDR(z2) = scm_env; scm_env = z2; + scm_ecache_index = i; } char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc"; char s_recursive[] = "recursive"; @@ -853,10 +1059,13 @@ void init_io() init_iprocs(subr2s, tc7_subr_2); loc_open_file = &CDR(sysintern(s_open_file, - CDR(intern(s_try_open_file, sizeof(s_try_open_file)-1)))); + CDR(sysintern(s_try_open_file, UNDEFINED)))); #ifndef CHEAP_CONTINUATIONS add_feature("full-continuation"); #endif +#ifdef TEST_FINAL + add_final(test_final); +#endif } void grew_lim(nm) @@ -869,9 +1078,9 @@ sizet hplim_ind = 0; long heap_cells = 0; CELLPTR *hplims, heap_org; VOLATILE SCM freelist = EOL; -long mtrigger, mltrigger; +long mltrigger, mtrigger = INIT_MALLOC_LIMIT; -/* Ints should be deferred when calling igc_for_malloc. */ +/* Ints should be deferred when calling igc_for_alloc. */ static char *igc_for_alloc(where, olen, size, what) char *where; long olen; @@ -880,6 +1089,8 @@ 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); igc(what, CONT(rootcont)->stkbse); nm = mallocated + size - olen; if (nm > mltrigger) { @@ -896,6 +1107,7 @@ static char *igc_for_alloc(where, olen, size, what) else mtrigger += mtrigger/2; mltrigger = mtrigger - MIN_MALLOC_YIELD; } + mallocated = nm; return ptr; } char *must_malloc(len, what) @@ -906,17 +1118,22 @@ char *must_malloc(len, what) sizet size = len; long nm = mallocated + size; VERIFY_INTS("must_malloc", 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(0, 0, size, what); - mallocated = nm; + if (!ptr) + ptr = igc_for_alloc(0L, 0L, size, what); + else + mallocated = nm; return ptr; } -SCM must_malloc_cell(len, what) +SCM must_malloc_cell(len, c, what) long len; + SCM c; char *what; { SCM z; @@ -924,15 +1141,20 @@ SCM must_malloc_cell(len, what) sizet size = len; long nm = mallocated + size; VERIFY_INTS("must_malloc_cell", what); +#ifdef SHORT_SIZET 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(0, 0, size, what); - mallocated = nm; + if (!ptr) + ptr = igc_for_alloc(0L, 0L, size, what); + else + mallocated = nm; SETCHARS(z, ptr); + CAR(z) = c; return z; } char *must_realloc(where, olen, len, what) @@ -944,13 +1166,17 @@ char *must_realloc(where, olen, len, what) sizet size = len; long nm = mallocated + size - olen; VERIFY_INTS("must_realloc", 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); - mallocated = nm; + if (!ptr) + ptr = igc_for_alloc(where, olen, size, what); + else + mallocated = nm; return ptr; } void must_realloc_cell(z, olen, len, what) @@ -962,13 +1188,17 @@ void must_realloc_cell(z, olen, len, what) sizet size = len; long nm = mallocated + size - olen; VERIFY_INTS("must_realloc_cell", 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); - mallocated = nm; + if (!ptr) + ptr = igc_for_alloc(where, olen, size, what); + else + mallocated = nm; SETCHARS(z, ptr); } void must_free(obj, len) @@ -980,124 +1210,11 @@ void must_free(obj, len) while (len--) obj[len] = '#'; #endif free(obj); + mallocated = mallocated - len; } else wta(INUM0, "already free", ""); } -#ifdef NUM_HP -# define NUM_HP_SIZE 240*sizeof(double) - -struct num_hp { - struct num_hp *next; /* Next heap in list */ - sizet size; /* Size of one half-heap, in doubles */ - sizet offset; /* 0 or size, depending on which half-heap is in use */ - sizet ind; /* index of next available double */ - double hp[1]; /* Make sure we are optimally aligned for doubles, more - follow */ -}; -typedef struct num_hp num_hp; -static num_hp *num_hp_head = 0, *num_hp_cur = 0; -long num_hp_total = 0; - -/* size is in bytes */ -static char s_num_hp[] = "flonum/bignum heap"; -static void num_hp_add(size) - sizet size; -{ - num_hp *new_hp; - sizet dsz = size / sizeof(double); - tail: - new_hp = (num_hp_cur ? num_hp_cur->next : 0); - if (new_hp) { - new_hp->ind = new_hp->size; - num_hp_cur = new_hp; - return; - } - new_hp = (num_hp *)must_malloc(sizeof(num_hp) + (2*dsz-1)*sizeof(double), - s_num_hp); - num_hp_total += sizeof(num_hp) + (2*dsz-1)*sizeof(double) ; - growth_mon(s_num_hp, num_hp_total, "doubles", !0); - new_hp->next = 0; - new_hp->size = dsz; - new_hp->offset = 0; - new_hp->ind = new_hp->size; - /* must_malloc might have called gc, moving num_hp_cur. */ - if (num_hp_cur) { - num_hp *hp = num_hp_cur; - while (hp->next) hp = hp->next; - hp->next = new_hp; - } - else - num_hp_cur = new_hp; - if (num_hp_cur->ind >= NUM_HP_MAX_REQ/sizeof(double)) return; - goto tail; -} - -static void num_hp_switch() -{ - num_hp *hp = num_hp_head; - while (hp) { - hp->offset = (hp->offset + hp->size) % (2*hp->size); - hp->ind = hp->size; - hp = hp->next; - } - num_hp_cur = num_hp_head; -} - -/* len is in bytes */ -char *num_hp_alloc(len) - sizet len; -{ - num_hp *hp = num_hp_cur; - len = (len + sizeof(double) - 1)/sizeof(double); - if ((!hp) || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) { - num_hp_add(NUM_HP_SIZE); - hp = num_hp_cur; - } - hp->ind -= len; - return (char *)&(hp->hp[hp->ind + hp->offset]); -} - -char *num_hp_realloc(where, olen, len, what) - char *where, *what; - long olen, len; -{ - char *ret; - sizet i; - if (len <= NUM_HP_MAX_REQ) { - num_hp *hp = num_hp_cur; - if (len <= olen) return where; - if (!hp || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) { - num_hp_add(NUM_HP_SIZE); - hp = num_hp_cur; - } - hp->ind -= (len + sizeof(double) - 1)/sizeof(double); - ret = (char *)&(hp->hp[hp->ind + hp->offset]); - for (i = len; i--;) - ret[i] = where[i]; - if (olen > NUM_HP_MAX_REQ) must_free(where, (long)olen); - return ret; - } - if (olen > NUM_HP_MAX_REQ) - return must_realloc(where, olen, len, what); - ret = must_malloc((long)len, what); - for (i = len; i--;) - ret[i] = where[i]; - return ret; -} -void num_hp_free(hp) - num_hp *hp; -{ - num_hp *next; - while (hp) { - next = hp->next; - num_hp_total -= 2*hp->size; - must_free((char *)hp, sizeof(num_hp) + hp->size*2 - sizeof(double)); - hp = next; - } -} -#endif /* NUM_HP */ - SCM symhash; /* This used to be a sys_protect, but Radey Shouman <shouman@zianet.com> added GC for unused, UNDEFINED @@ -1126,21 +1243,25 @@ 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); */ + DEFER_INTS; for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { z = CAR(lsym); z = CAR(z); tmp = UCHARS(z); if (LENGTH(z) != len) goto trynext; for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; + ALLOW_INTS; return CAR(lsym); trynext: ; } - lsym = makfromstr(name, len); - DEFER_INTS; - SETLENGTH(lsym, (long)len, tc7_msymbol); - ALLOW_INTS; + /* lsym = makfromstr(name, len); */ + lsym = must_malloc_cell(len+1L, + MAKE_LENGTH((long)len, tc7_msymbol), s_string); + i = len; + CHARS(lsym)[len] = 0; + while (i--) CHARS(lsym)[i] = name[i]; z = acons(lsym, UNDEFINED, UNDEFINED); - DEFER_INTS; /* Operations on symhash must be atomic. */ CDR(z) = VELTS(symhash)[hash]; VELTS(symhash)[hash] = z; z = CAR(z); @@ -1163,7 +1284,8 @@ 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); - CDR(lsym) = val; + if (!UNBNDP(val)) + CDR(lsym) = val; return lsym; trynext: ; } @@ -1218,40 +1340,64 @@ SCM makstr(len) long len; { SCM s; +#ifndef SHORT_SIZET + ASSERT(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string); +#endif DEFER_INTS; - s = must_malloc_cell(len+1, s_string); - SETLENGTH(s, len, tc7_string); + s = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_string), s_string); CHARS(s)[len] = 0; - ALLOW_INTS; + ALLOW_INTS; return s; } -SCM make_subr(name, type, fcn) +scm_gra subr_table_gra; +SCM scm_maksubr(name, type, fcn) const char *name; int type; SCM (*fcn)(); { - SCM symcell = sysintern(name, UNDEFINED); - long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8); + subr_info info; + int isubr; register SCM z; - if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org)) - tmp = 0; + info.name = name; + isubr = scm_grow_gra(&subr_table_gra, (char *)&info); NEWCELL(z); - CAR(z) = tmp + type; + if (!fcn && tc7_cxr==type) { + const char *p = name; + int code = 0; + while (*++p != 'r') + switch (*p) { + default: wta(UNDEFINED, "bad cxr name", (char *)name); + case 'a': code = (code<<2) + 1; continue; + case 'd': code = (code<<2) + 2; continue; + } + type += (code << 8); + } + CAR(z) = (isubr<<16) + type; SUBRF(z) = fcn; - CDR(symcell) = z; return z; } +SCM make_subr(name, type, fcn) + const char *name; + int type; + SCM (*fcn)(); +{ + return CDR(sysintern(name, scm_maksubr(name, type, fcn))); +} #ifdef CCLO +char s_comp_clo[] = "compiled-closure"; SCM makcclo(proc, len) SCM proc; long len; { SCM s; +# ifndef SHORT_SIZET + ASSERT(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo); +# endif DEFER_INTS; - s = must_malloc_cell(len*sizeof(SCM), "compiled-closure"); - SETNUMDIGS(s, len, tc16_cclo); + s = must_malloc_cell(len*sizeof(SCM), MAKE_NUMDIGS(len, tc16_cclo), + s_comp_clo); while (--len) VELTS(s)[len] = UNSPECIFIED; CCLO_SUBR(s) = proc; ALLOW_INTS; @@ -1298,14 +1444,14 @@ SCM dynwind(thunk1, thunk2, thunk3) apply(thunk3, EOL, EOL); return ans; } -void dowinds(to, delta) +void downd(to, delta) SCM to; long delta; { tail: if (dynwinds==to); else if (0 > delta) { - dowinds(CDR(to), 1+delta); + downd(CDR(to), 1+delta); apply(CAR(CAR(to)), EOL, EOL); dynwinds = to; } @@ -1313,61 +1459,80 @@ void dowinds(to, delta) SCM from = CDR(CAR(dynwinds)); dynwinds = CDR(dynwinds); apply(from, EOL, EOL); - delta--; goto tail; /* dowinds(to, delta-1); */ + delta--; goto tail; /* downd(to, delta-1); */ } } +void dowinds(to) + SCM to; +{ + downd(to, ilength(dynwinds) - ilength(to)); +} /* Remember that setjump needs to be called after scm_make_cont */ SCM scm_make_cont() { - SCM cont, env, *from, *to; + SCM cont, estk, *from; CONTINUATION *ncont; sizet n; - VERIFY_INTS("scm_make_cont", 0); + VERIFY_INTS("scm_make_cont", 0L); NEWCELL(cont); from = VELTS(scm_estk); - n = scm_estk_ptr - from + SCM_ESTK_FRLEN + 2; - env = must_malloc_cell((long)n*sizeof(SCM), s_cont); - SETLENGTH(env, (long)n, tc7_vector); - to = VELTS(env); - to[--n] = scm_env; - to[--n] = scm_env_tmp; - while(n--) to[n] = from[n]; + n = scm_estk_ptr - from + SCM_ESTK_FRLEN; +#ifdef CHEAP_CONTINUATIONS + estk = scm_estk; +#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); + { + SCM *to = VELTS(estk); + while(n--) to[n] = from[n]; + } +#endif ncont = make_continuation(CONT(rootcont)); if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont); ncont->other.parent = rootcont; SETCONT(cont, ncont); SETLENGTH(cont, ncont->length, tc7_contin); ncont->other.dynenv = dynwinds; - ncont->other.env = env; + ncont->other.stkframe[0] = scm_env; + ncont->other.stkframe[1] = scm_env_tmp; + ncont->other.estk = estk; + ncont->other.estk_ptr = scm_estk_ptr; return cont; } static char s_sstale[] = "strangely stale"; -void scm_dynthrow(cont, val) - CONTINUATION *cont; +void scm_dynthrow(tocont, val) + SCM tocont; SCM val; { + CONTINUATION *cont = CONT(tocont); if (cont->stkbse != CONT(rootcont)->stkbse) - wta(cont->other.dynenv, &s_sstale[10], s_cont); - dowinds(cont->other.dynenv, - ilength(dynwinds)-ilength(cont->other.dynenv)); + wta(tocont, &s_sstale[10], s_cont); + dowinds(cont->other.dynenv); { - SCM *from, *to; - sizet n = LENGTH(cont->other.env); - if (LENGTH(scm_estk) < n) - scm_estk_grow((n - (LENGTH(scm_estk))) / SCM_ESTK_FRLEN + 20); DEFER_INTS; - from = VELTS(cont->other.env); - to = VELTS(scm_estk); - scm_env = from[--n]; - scm_env_tmp = from[--n]; - scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN; - while(n--) to[n] = from[n]; +#ifdef CHEAP_CONTINUATIONS + scm_estk = cont->other.estk; + scm_estk_ptr = cont->other.estk_ptr; +#else + { + 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)); + 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]; ALLOW_INTS; } throw_to_continuation(cont, val, CONT(rootcont)); - wta(cont->other.dynenv, s_sstale, s_cont); + wta(tocont, s_sstale, s_cont); } SCM obhash(obj) @@ -1523,67 +1688,132 @@ badhplims: wta(UNDEFINED, s_nogrow, s_heap); } -smobfuns *smobs; -sizet numsmob; -long newsmob(smob) - smobfuns *smob; +/* Initialize a Growable arRAy, of initial size LEN, growing to at most + MAXLEN elements of size ELTSIZE */ +void scm_init_gra(gra, eltsize, len, maxlen, what) + scm_gra *gra; + sizet eltsize, len, maxlen; + char *what; +{ + char *nelts; + 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; + gra->elts = nelts; + gra->alloclen = len; + gra->maxlen = maxlen; + gra->what = what; + ALLOW_INTS; +} +/* Returns the index into the elt array */ +int scm_grow_gra(gra, elt) + scm_gra *gra; + char *elt; { + int i; char *tmp; - if (255 <= numsmob) goto smoberr; DEFER_INTS; - SYSCALL(tmp = (char *)realloc((char *)smobs, (1+numsmob)*sizeof(smobfuns));); - if (tmp) { - smobs = (smobfuns *)tmp; - smobs[numsmob].mark = smob->mark; - smobs[numsmob].free = smob->free; - smobs[numsmob].print = smob->print; - smobs[numsmob].equalp = smob->equalp; - numsmob++; + 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); + /* + SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize);); + if (!tmp) goto growerr; + mallocated += (nlen - gra->alloclen)*gra->eltsize; + */ + tmp = must_realloc(gra->elts, (long)gra->alloclen*gra->eltsize, + (long)nlen*gra->eltsize, gra->what); + gra->elts = tmp; + gra->alloclen = nlen; } + tmp = &gra->elts[gra->len*gra->eltsize]; + gra->len += 1; + for (i = 0; i < gra->eltsize; i++) + tmp[i] = elt[i]; ALLOW_INTS; - if (!tmp) smoberr: wta(MAKINUM((long)numsmob), (char *)NALLOC, "newsmob"); - return tc7_smob + (numsmob-1)*256; + return gra->len - 1; +} +void scm_free_gra(gra) + scm_gra *gra; +{ + free(gra->elts); + gra->elts = 0; + mallocated -= gra->maxlen*gra->eltsize; +} +scm_gra smobs_gra; +long newsmob(smob) + smobfuns *smob; +{ + return tc7_smob + 256*scm_grow_gra(&smobs_gra, (char *)smob); } -ptobfuns *ptobs; -sizet numptob; +scm_gra ptobs_gra; long newptob(ptob) ptobfuns *ptob; { - char *tmp; - if (255 <= numptob) goto ptoberr; - DEFER_INTS; - SYSCALL(tmp = (char *)realloc((char *)ptobs, (1+numptob)*sizeof(ptobfuns));); - if (tmp) { - ptobs = (ptobfuns *)tmp; - ptobs[numptob].mark = ptob->mark; - ptobs[numptob].free = ptob->free; - ptobs[numptob].print = ptob->print; - ptobs[numptob].equalp = ptob->equalp; - ptobs[numptob].fputc = ptob->fputc; - ptobs[numptob].fputs = ptob->fputs; - ptobs[numptob].fwrite = ptob->fwrite; - ptobs[numptob].fflush = ptob->fflush; - ptobs[numptob].fgetc = ptob->fgetc; - ptobs[numptob].fclose = ptob->fclose; - numptob++; + 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 char s_port_table[] = "port table"; +SCM scm_port_entry(ptype, flags) + long ptype, flags; +{ + int 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++) + 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); } - ALLOW_INTS; - if (!tmp) ptoberr: wta(MAKINUM((long)numptob), (char *)NALLOC, "newptob"); - return tc7_port + (numptob-1)*256; + else if (scm_port_table_len < PORT_TABLE_MAXLEN) { + nlen = scm_port_table_len + (scm_port_table_len / 2); + if (nlen > PORT_TABLE_MAXLEN) nlen = PORT_TABLE_MAXLEN; + scm_port_table = (port_info *) + must_realloc((char *)scm_port_table, + (long)scm_port_table_len*sizeof(port_info), + nlen*sizeof(port_info)+0L, + s_port_table); + scm_port_table_len = nlen; + 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; + } + } + else { + igc(s_port_table, CONT(rootcont)->stkbse); + for (i = 0; i < scm_port_table_len; i++) + if (0L==scm_port_table[i].flags) goto ret; + wta(UNDEFINED, s_nogrow, s_port_table); + } + ret: + 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 markcdr(ptr) SCM ptr; { - if GC8MARKP(ptr) return BOOL_F; - SETGC8MARK(ptr); return CDR(ptr); } -SCM mark0(ptr) - SCM ptr; -{ - SETGC8MARK(ptr); - return BOOL_F; -} sizet free0(ptr) CELLPTR ptr; { @@ -1595,31 +1825,30 @@ SCM equal0(ptr1, ptr2) return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F; } -/* statically allocated ports for diagnostic messages */ -static cell tmp_errpbuf[3]; -static SCM tmp_errp; - -static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define "; -extern sizet num_protects; /* sys_protects now in scl.c */ +static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ", + rdmsg[] = "reduce"; void init_storage(stack_start_ptr, init_heap_size) STACKITEM *stack_start_ptr; long init_heap_size; { - sizet j = num_protects; + sizet j; /* Because not all protects may get initialized */ - while(j) sys_protects[--j] = BOOL_F; - tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0])); - CAR(tmp_errp) = (SCM)(tc16_fport|OPN|WRTNG); - CDR(tmp_errp) = (SCM)stderr; freelist = EOL; expmem = 0; +#ifdef SHORT_SIZET + if (sizeof(sizet) >= sizeof(long)) + fixconfig(remsg, "SHORT_SIZET", 0); +#else + if (sizeof(sizet) < sizeof(long)) + fixconfig(addmsg, "SHORT_SIZET", 0); +#endif #ifdef SHORT_INT if (sizeof(int) >= sizeof(long)) - fixconfig(remsg, "SHORT_INT", 1); + fixconfig(remsg, "SHORT_INT", 0); #else if (sizeof(int) < sizeof(long)) - fixconfig(addmsg, "SHORT_INT", 1); + fixconfig(addmsg, "SHORT_INT", 0); #endif #ifdef CDR_DOUBLES if (sizeof(double) != sizeof(long)) @@ -1640,6 +1869,8 @@ void init_storage(stack_start_ptr, init_heap_size) if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long)) fixconfig(addmsg, "DIGSTOOBIG", 0); # endif + if (NUMDIGS_MAX > (((unsigned long)-1L)>>16)) + fixconfig(rdmsg, "NUMDIGS_MAX", 0); #endif #ifdef STACK_GROWS_UP if (((STACKITEM *)&j - stack_start_ptr) < 0) @@ -1650,7 +1881,7 @@ void init_storage(stack_start_ptr, init_heap_size) #endif j = HEAP_SEG_SIZE; if (HEAP_SEG_SIZE != j) - fixconfig("reduce", "size of HEAP_SEG_SIZE", 0); + fixconfig(rdmsg, "size of HEAP_SEG_SIZE", 0); mtrigger = INIT_MALLOC_LIMIT; mltrigger = mtrigger - MIN_MALLOC_YIELD; @@ -1667,10 +1898,10 @@ void init_storage(stack_start_ptr, init_heap_size) /* hplims[0] can change. do not remove heap_org */ NEWCELL(def_inp); - CAR(def_inp) = (tc16_fport|OPN|RDNG); + CAR(def_inp) = scm_port_entry(tc16_fport, OPN|RDNG); SETSTREAM(def_inp, stdin); NEWCELL(def_outp); - CAR(def_outp) = (tc16_fport|OPN|WRTNG); + CAR(def_outp) = scm_port_entry(tc16_fport, OPN|WRTNG|TRACKED); SETSTREAM(def_outp, stdout); NEWCELL(def_errp); CAR(def_errp) = (tc16_fport|OPN|WRTNG); @@ -1681,6 +1912,7 @@ void init_storage(stack_start_ptr, init_heap_size) NEWCELL(sys_errp); CAR(sys_errp) = (tc16_sysport|OPN|WRTNG); SETSTREAM(sys_errp, 0); + sys_safep = mksafeport(0, def_errp); dynwinds = EOL; NEWCELL(rootcont); SETCONT(rootcont, make_root_continuation(stack_start_ptr)); @@ -1708,14 +1940,8 @@ void init_storage(stack_start_ptr, init_heap_size) scm_ecache_len = CELL_DN(ecache_v + scm_ecache_len - 1) - scm_ecache + 1; scm_ecache_index = scm_ecache_len; scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM); - scm_estk_reset(); - -#ifdef NUM_HP - /* Allocate a very small initial num_hp in case - we need it only for flo0. */ - num_hp_add(10*sizeof(double)); - num_hp_head = num_hp_cur; -#endif /* def NUM_HP */ + scm_estk = BOOL_F; + scm_estk_reset(0); } /* The way of garbage collecting which allows use of the cstack is due to */ @@ -1766,6 +1992,11 @@ SCM gc_for_newcell() return fl; } +void gc_for_open_files() +{ + igc("open files", CONT(rootcont)->stkbse); +} + void scm_fill_freelist() { while IMP(freelist) { @@ -1783,7 +2014,10 @@ 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 sweep_symhash P((SCM v)); +static void mark_port_table P((SCM port)); +static void sweep_port_table P((void)); static void egc_mark P((void)); static void egc_sweep P((void)); @@ -1804,12 +2038,14 @@ void igc(what, stackbase) { int j = num_protects; long oheap_cells = heap_cells; - gc_start(what); - if (++errjmp_bad > 1) - wta(MAKINUM(errjmp_bad), s_recursive, s_gc); -#ifdef NUM_HP - num_hp_switch(); /* Switch half-heaps for flonums/bignums */ +#ifdef DEBUG_GMALLOC + int err = check_frag_blocks(); + if (err) wta(MAKINUM(err), "malloc corrupted", what); #endif + gc_start(what); + if (errjmp_bad) + wta(UNDEFINED, s_recursive, s_gc); + errjmp_bad = s_gc; #ifdef NO_SYM_GC gc_mark(symhash); #else @@ -1821,6 +2057,7 @@ void igc(what, stackbase) /* mark_sym_values() can be called anytime after mark_syms. */ mark_sym_values(symhash); #endif + mark_subr_table(); egc_mark(); if (stackbase) { FLUSH_REGISTER_WINDOWS; @@ -1855,15 +2092,10 @@ void igc(what, stackbase) sweep_symhash(symhash); #endif gc_sweep(!stackbase); + sweep_port_table(); egc_sweep(); -#if 0 /* def NUM_HP */ - if (num_hp_cur) { - num_hp *hp = num_hp_cur->next; - num_hp_cur->next = 0; - if (hp) num_hp_free(hp); - } -#endif - --errjmp_bad; + estk_pool = EOL; + errjmp_bad = (char *)0; gc_end(); if (oheap_cells != heap_cells) { int grewp = heap_cells > oheap_cells; @@ -1877,8 +2109,8 @@ void free_storage() { DEFER_INTS; gc_start("free"); - ++errjmp_bad; - cur_inp = BOOL_F; cur_outp = BOOL_F; + errjmp_bad = "free_storage"; + cur_inp = BOOL_F; cur_outp = BOOL_F; cur_errp = tmp_errp; sys_errp = tmp_errp; gc_mark(def_inp); /* don't want to close stdin */ gc_mark(def_outp); /* don't want to close stdout */ @@ -1899,23 +2131,18 @@ void free_storage() if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims); /* Not all cells get freed (see gc_mark() calls above). */ /* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */ -#ifdef NUM_HP - num_hp_free(num_hp_head); -#endif /* either there is a small memory leak or I am counting wrong. */ must_free((char *)hplims, 0); /* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */ hplims = 0; - /* must_free((char *)smobs, numsmob * sizeof(smobfuns)); */ - free((char *)smobs); - smobs = 0; - gc_end(); + scm_free_gra(&finals_gra); + scm_free_gra(&smobs_gra); + scm_free_gra(&subr_table_gra); + gc_end(); ALLOW_INTS; /* A really bad idea, but printing does it anyway. */ exit_report(); lflush(sys_errp); - /* must_free((char *)ptobs, numptob * sizeof(ptobfuns)); */ - free((char *)ptobs); - ptobs = 0; + scm_free_gra(&ptobs_gra); lmallocated = mallocated = 0; /* Can't do gc_end() here because it uses ptobs which have been freed */ fflush(stdout); /* in lieu of close */ @@ -2015,6 +2242,7 @@ void gc_mark(p) case tc7_bvect: case tc7_ivect: case tc7_uvect: + case tc7_svect: case tc7_fvect: case tc7_dvect: case tc7_cvect: @@ -2022,59 +2250,36 @@ void gc_mark(p) case tcs_subrs: break; case tc7_port: + if GC8MARKP(ptr) break; + SETGC8MARK(ptr); i = PTOBNUM(ptr); if (!(i < numptob)) goto def; + mark_port_table(ptr); + if (!ptobs[i].mark) break; ptr = (ptobs[i].mark)(ptr); goto gc_mark_loop; case tc7_smob: if GC8MARKP(ptr) break; + SETGC8MARK(ptr); switch TYP16(ptr) { /* should be faster than going through smobs */ case tc_free_cell: /* printf("found free_cell %X ", ptr); fflush(stdout); */ - SETGC8MARK(ptr); ASSERT(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc); /* CDR(ptr) = UNDEFINED */; break; #ifdef BIGDIG case tcs_bignums: -#ifdef NUM_HP - if (NUMDIGS(ptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) { - sizet i = NUMDIGS(ptr); - BIGDIG *nw = (BIGDIG *)num_hp_alloc(i*sizeof(BIGDIG)); - while (i--) nw[i] = BDIGITS(ptr)[i]; - } -#endif - SETGC8MARK(ptr); break; #endif #ifdef FLOATS case tc16_flo: -# ifdef NUM_HP - { - double *nw; - switch ((int)(CAR(ptr)>>16)) { - default: goto def; - case (IMAG_PART | REAL_PART)>>16: - nw = (double *)num_hp_alloc(2*sizeof(double)); - nw[0] = REAL(ptr); - nw[1] = IMAG(ptr); - CDR(ptr) = (SCM)nw; - break; - case REAL_PART>>16: case IMAG_PART>>16: - nw = (double *)num_hp_alloc(sizeof(double)); - nw[0] = REAL(ptr); - CDR(ptr) = (SCM)nw; - break; - case 0: break; - } - } -# endif /* def NUM_HP */ - SETGC8MARK(ptr); break; #endif default: i = SMOBNUM(ptr); if (!(i < numsmob)) goto def; + SETGC8MARK(ptr); + if (!smobs[i].mark) break; ptr = (smobs[i].mark)(ptr); goto gc_mark_loop; } @@ -2122,8 +2327,9 @@ static void gc_sweep(contin_bad) # define scmptr (SCM)ptr #endif register SCM nfreelist = EOL; - register long n = 0, m = 0; + register long n = 0; register sizet j, minc; + long pre_m = mallocated; sizet i = 0; sizet seg_cells; while (i<hplim_ind) { @@ -2153,7 +2359,6 @@ static void gc_sweep(contin_bad) if GC8MARKP(scmptr) goto c8mrkcontinue; minc = (LENGTH(scmptr)*sizeof(SCM)); freechars: - m += minc; must_free(CHARS(scmptr), minc); /* SETCHARS(scmptr, 0);*/ break; @@ -2166,6 +2371,10 @@ static void gc_sweep(contin_bad) if GC8MARKP(scmptr) goto c8mrkcontinue; minc = HUGE_LENGTH(scmptr)*sizeof(long); goto freechars; + case tc7_svect: + if GC8MARKP(scmptr) goto c8mrkcontinue; + minc = HUGE_LENGTH(scmptr)*sizeof(short); + goto freechars; case tc7_fvect: if GC8MARKP(scmptr) goto c8mrkcontinue; minc = HUGE_LENGTH(scmptr)*sizeof(float); @@ -2189,7 +2398,7 @@ static void gc_sweep(contin_bad) case tc7_contin: if GC8MARKP(scmptr) { if (contin_bad && CONT(scmptr)->length) { - warn("uncollected ", (char *)0); + scm_warn("uncollected ", (char *)0); iprin1(scmptr, cur_errp, 1); lputc('\n', cur_errp); lfflush(cur_errp); @@ -2197,6 +2406,7 @@ static void gc_sweep(contin_bad) goto c8mrkcontinue; } minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION); + mallocated = mallocated - minc; free_continuation(CONT(scmptr)); break; /* goto freechars; */ case tc7_ssymbol: if GC8MARKP(scmptr) goto c8mrkcontinue; @@ -2211,7 +2421,7 @@ static void gc_sweep(contin_bad) int k = PTOBNUM(scmptr); if (!(k < numptob)) goto sweeperr; /* Yes, I really do mean ptobs[k].free */ - /* rather than ftobs[k].close. .close */ + /* rather than ptobs[k].close. .close */ /* is for explicit CLOSE-PORT by user */ (ptobs[k].free)(STREAM(scmptr)); gc_ports_collected++; @@ -2227,16 +2437,12 @@ static void gc_sweep(contin_bad) #ifdef BIGDIG case tcs_bignums: if GC8MARKP(scmptr) goto c8mrkcontinue; -# ifdef NUM_HP - if (NUMDIGS(scmptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) break; -# endif /* def NUM_HP */ - minc = (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT); + minc = (NUMDIGS(scmptr)*sizeof(BIGDIG)); goto freechars; #endif /* def BIGDIG */ #ifdef FLOATS case tc16_flo: if GC8MARKP(scmptr) goto c8mrkcontinue; -# ifndef NUM_HP switch ((int)(CAR(scmptr)>>16)) { case (IMAG_PART | REAL_PART)>>16: minc = 2*sizeof(double); @@ -2250,7 +2456,6 @@ static void gc_sweep(contin_bad) default: goto sweeperr; } -# endif /* ndef NUM_HP */ #endif /* def FLOATS */ break; default: @@ -2296,9 +2501,8 @@ static void gc_sweep(contin_bad) } lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated); cells_allocated = (heap_cells - gc_cells_collected); - lmallocated -= m; - mallocated -= m; - gc_malloc_collected = m; + gc_malloc_collected = (pre_m - mallocated); + lmallocated = lmallocated - gc_malloc_collected; } #ifndef NO_SYM_GC @@ -2376,6 +2580,37 @@ static void sweep_symhash(v) } #endif +static void mark_subr_table() +{ + subr_info *table = subr_table; + int k = subr_table_gra.len; + /* while (k--) { } */ +} +static void mark_port_table(port) + SCM port; +{ + int i = SCM_PORTNUM(port); + ASSERT(i>=0 && i<scm_port_table_len, MAKINUM(i), "bad port", s_gc); + if (i) { + scm_port_table[i].flags |= 1; + if (NIMP(scm_port_table[i].data)) + gc_mark(scm_port_table[i].data); + } +} +static void sweep_port_table() +{ + int k; + /* tmp_errp gets entry 0, so we never clear its flags. */ + for(k = scm_port_table_len - 1; k > 0; k--) { + if (scm_port_table[k].flags & 1) + scm_port_table[k].flags &= (~1L); + else { + scm_port_table[k].flags = 0L; + scm_port_table[k].data = EOL; + } + } +} + /* Environment cache GC routines */ /* This is called during a non-cache gc. We only mark those stack frames that are in use. */ @@ -2386,7 +2621,7 @@ static void egc_mark() gc_mark(scm_env); gc_mark(scm_env_tmp); if IMP(scm_estk) return; /* Can happen when moving estk. */ - if GC8MARKP(scm_estk) return; + if GC8MARKP(scm_estk) return; v = VELTS(scm_estk); SETGC8MARK(scm_estk); i = scm_estk_ptr - v + SCM_ESTK_FRLEN; @@ -2407,6 +2642,13 @@ static void egc_sweep() CLRGC8MARK(z); } } + /* Under some circumstances I don't fully understand, continuations may + point to dead ecache cells. This prevents gc marked cells from causing + errors during ecache gc. */ + for (i = scm_ecache_index; i--;) { + scm_ecache[i].car = UNSPECIFIED; + scm_ecache[i].cdr = UNSPECIFIED; + } } #define ECACHEP(x) (PTR_LE((CELLPTR)(ecache_v), (CELLPTR)SCM2PTR(x)) && \ @@ -2437,7 +2679,7 @@ static void egc_copy(px) } while (NIMP(x) && ECACHEP(x)); } -static void egc_copy_stack(ve, len) +static void egc_copy_locations(ve, len) SCM *ve; sizet len; { @@ -2451,7 +2693,18 @@ static void egc_copy_stack(ve, len) egc_copy(&(ve[len])); } } - +static void egc_copy_stack(stk, len) + SCM stk; + sizet len; +{ + while (!0) { + egc_copy_locations(VELTS(stk), len); + len = INUM(SCM_ESTK_PARENT_INDEX(stk)) + SCM_ESTK_FRLEN; + stk =SCM_ESTK_PARENT(stk); + if IMP(stk) return; + /* len = LENGTH(stk); */ + } +} extern long tc16_env, tc16_promise; static void egc_copy_roots() { @@ -2476,17 +2729,20 @@ static void egc_copy_roots() case tc3_cons_nimcar: /* These are environment frames that have been destructively altered by DEFINE or LETREC. This is only a problem if a - non-cache cell was made to point into the + non-cache cell was made to point into the cache. */ if ECACHEP(x) break; e = CDR(x); - if (NIMP(e) && ECACHEP(e)) + if (NIMP(e) && ECACHEP(e)) egc_copy(&(CDR(x))); break; default: if (tc7_contin==TYP7(x)) { - x = CONT(x)->other.env; - egc_copy_stack(VELTS(x), (sizet)LENGTH(x)); + egc_copy_locations(CONT(x)->other.stkframe, 2); +#ifndef CHEAP_CONTINUATIONS + x = CONT(x)->other.estk; + egc_copy_stack(x, LENGTH(x)); +#endif break; } if (tc16_env==CAR(x)) { @@ -2504,12 +2760,26 @@ static void egc_copy_roots() scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM); } extern long scm_stk_moved, scm_clo_moved, scm_env_work; +static int egc_need_gc() +{ + SCM fl = freelist; + int n; + if (heap_cells - cells_allocated <= scm_ecache_len) + return 1; + /* Interrupting a NEWCELL could leave cells_allocated inconsistent with + freelist, see handle_it() in repl.c */ + for (n = 4; n; n--) { + if IMP(fl) return 1; + fl = CDR(fl); + } + return 0; +} void scm_egc() { - VERIFY_INTS("scm_egc", 0); + VERIFY_INTS("scm_egc", 0L); /* We need to make sure there are enough cells available to migrate the entire environment cache, gc does not work properly during ecache gc */ - while ((heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) { + while (egc_need_gc()) { igc("ecache", CONT(rootcont)->stkbse); if ((gc_cells_collected < MIN_GC_YIELD) || (heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) { @@ -2518,8 +2788,8 @@ void scm_egc() growth_mon(s_heap, heap_cells, s_cells, !0); } } - if (++errjmp_bad > 1) - wta(MAKINUM(errjmp_bad), s_recursive, s_cache_gc); + if (errjmp_bad) + wta(UNDEFINED, s_recursive, s_cache_gc); { SCM stkframe[2]; long lcells = cells_allocated; @@ -2531,8 +2801,8 @@ void scm_egc() egc_copy_roots(); scm_clo_moved += cells_allocated - lcells; lcells = cells_allocated; - egc_copy_stack(stkframe, sizeof(stkframe)/sizeof(SCM)); - egc_copy_stack(VELTS(scm_estk), nstk); + egc_copy_locations(stkframe, sizeof(stkframe)/sizeof(SCM)); + egc_copy_stack(scm_estk, nstk); scm_env = stkframe[0]; scm_env_tmp = stkframe[1]; scm_stk_moved += cells_allocated - lcells; @@ -2540,6 +2810,5 @@ void scm_egc() scm_env_work += scm_ecache_len; scm_egc_end(); } - --errjmp_bad; + errjmp_bad = (char *)0; } - @@ -1,18 +1,18 @@ /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "time.c" functions dealing with time. @@ -103,7 +103,7 @@ # include <sys/timeb.h> # define USE_GETTIMEOFDAY #endif -#ifdef freebsd +#ifdef __FreeBSD__ # include <sys/types.h> # include <sys/time.h> # include <sys/timeb.h> @@ -160,6 +160,12 @@ #ifdef _UNICOS # define LACK_FTIME #endif +#ifdef __amigados__ +# include <sys/time.h> +# include <sys/timeb.h> +# include <sys/times.h> +# define USE_GETTIMEOFDAY +#endif #ifndef LACK_FTIME # ifdef unix @@ -329,14 +335,11 @@ SCM your_time() else if ((1 + time_buffer1.time)==time_buffer2.time) ; else if (cnt < TIMETRIES) goto tryagain; else { - 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",0L); return MAKINUM(-1); } - time_buffer2.time -= your_base.time; - tmp = time_buffer2.millitm - your_base.millitm; - tmp = time_buffer2.time*1000L + tmp; - tmp *= CLKTCK; - tmp /= 1000; + tmp = CLKTCK*(time_buffer2.millitm - your_base.millitm); + tmp = CLKTCK*(time_buffer2.time - your_base.time) + tmp/1000; return MAKINUM(tmp); } #endif /* LACK_FTIME */ diff --git a/unexsgi.c b/unexsgi.c new file mode 100644 index 0000000..9c14441 --- /dev/null +++ b/unexsgi.c @@ -0,0 +1,888 @@ +/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 + Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs 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. + +GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. + * ELF support added. + * + * Basic theory: the data space of the running process needs to be + * dumped to the output file. Normally we would just enlarge the size + * of .data, scooting everything down. But we can't do that in ELF, + * because there is often something between the .data space and the + * .bss space. + * + * In the temacs dump below, notice that the Global Offset Table + * (.got) and the Dynamic link data (.dynamic) come between .data1 and + * .bss. It does not work to overlap .data with these fields. + * + * The solution is to create a new .data segment. This segment is + * filled with data from the current process. Since the contents of + * various sections refer to sections by index, the new .data segment + * is made the last in the table to avoid changing any existing index. + + * This is an example of how the section headers are changed. "Addr" + * is a process virtual address. "Offset" is a file offset. + +raid:/nfs/raid/src/dist-18.56/src> dump -h temacs + +temacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80a98f4 0x608f4 0x449c .bss + 0 0 0x4 0 + +[17] 2 0 0 0x608f4 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x6a484 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x729aa 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x72a3d 0x68b7 .comment + 0 0 0x1 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs + +xemacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[17] 2 0 0 0x7d800 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + +[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + + * This is an example of how the file header is changed. "Shoff" is + * the section header offset within the file. Since that table is + * after the new .data section, it is moved. "Shnum" is the number of + * sections, which we increment. + * + * "Phoff" is the file offset to the program header. "Phentsize" and + * "Shentsz" are the program and section header entries sizes respectively. + * These can be larger than the apparent struct sizes. + +raid:/nfs/raid/src/dist-18.56/src> dump -f temacs + +temacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x792f4 0 0x34 +0x20 5 0x28 21 19 + +raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs + +xemacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x96200 0 0x34 +0x20 5 0x28 22 19 + + * These are the program headers. "Offset" is the file offset to the + * segment. "Vaddr" is the memory load address. "Filesz" is the + * segment size as it appears in the file, and "Memsz" is the size in + * memory. Below, the third segment is the code and the fourth is the + * data: the difference between Filesz and Memsz is .bss + +raid:/nfs/raid/src/dist-18.56/src> dump -o temacs + +temacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x215c4 0x25a60 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs + +xemacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x3e4d0 0x3e4d0 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + + + */ + +/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. + * + * The above mechanism does not work if the unexeced ELF file is being + * re-layout by other applications (such as `strip'). All the applications + * that re-layout the internal of ELF will layout all sections in ascending + * order of their file offsets. After the re-layout, the data2 section will + * still be the LAST section in the section header vector, but its file offset + * is now being pushed far away down, and causes part of it not to be mapped + * in (ie. not covered by the load segment entry in PHDR vector), therefore + * causes the new binary to fail. + * + * The solution is to modify the unexec algorithm to insert the new data2 + * section header right before the new bss section header, so their file + * offsets will be in the ascending order. Since some of the section's (all + * sections AFTER the bss section) indexes are now changed, we also need to + * modify some fields to make them point to the right sections. This is done + * by macro PATCH_INDEX. All the fields that need to be patched are: + * + * 1. ELF header e_shstrndx field. + * 2. section header sh_link and sh_info field. + * 3. symbol table entry st_shndx field. + * + * The above example now should look like: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + +[17] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[18] 2 0 0 0x7d800 0x9b90 .symtab + 19 371 0x4 0x10 + +[19] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[20] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[21] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + + */ + +#include <sys/types.h> +#include <stdio.h> +#include <sys/stat.h> +#include <memory.h> +#include <string.h> +#include <errno.h> +#include <unistd.h> +#include <fcntl.h> +#include <elf.h> +#include <syms.h> /* for HDRR declaration */ +#include <sys/mman.h> + +#ifndef emacs +#define fatal(a, b, c) fprintf(stderr, a, b, c), exit(1) +#else +extern void fatal(char *, ...); +#endif + +/* Get the address of a particular section or program header entry, + * accounting for the size of the entries. + */ + +#define OLD_SECTION_H(n) \ + (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) +#define NEW_SECTION_H(n) \ + (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) +#define OLD_PROGRAM_H(n) \ + (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) +#define NEW_PROGRAM_H(n) \ + (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) + +#define PATCH_INDEX(n) \ + do { \ + if ((n) >= old_bss_index) \ + (n)++; } while (0) +typedef unsigned char byte; + +/* Round X up to a multiple of Y. */ + +int +round_up (x, y) + int x, y; +{ + int rem = x % y; + if (rem == 0) + return x; + return x - rem + y; +} + +/* Return the index of the section named NAME. + SECTION_NAMES, FILE_NAME and FILE_H give information + about the file we are looking in. + + If we don't find the section NAME, that is a fatal error + if NOERROR is 0; we return -1 if NOERROR is nonzero. */ + +static int +find_section (name, section_names, file_name, old_file_h, old_section_h, noerror) + char *name; + char *section_names; + char *file_name; + Elf32_Ehdr *old_file_h; + Elf32_Shdr *old_section_h; + int noerror; +{ + int idx; + + for (idx = 1; idx < old_file_h->e_shnum; idx++) + { +#ifdef DEBUG + fprintf (stderr, "Looking for %s - found %s\n", name, + section_names + OLD_SECTION_H (idx).sh_name); +#endif + if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name, + name)) + break; + } + if (idx == old_file_h->e_shnum) + { + if (noerror) + return -1; + else + fatal ("Can't find .bss in %s.\n", file_name, 0); + } + + return idx; +} + +/* **************************************************************** + * unexec + * + * driving logic. + * + * In ELF, this works by replacing the old .bss section with a new + * .data section, and inserting an empty .bss immediately afterwards. + * + */ +void +unexec (new_name, old_name, data_start, bss_start, entry_address) + char *new_name, *old_name; + unsigned data_start, bss_start, entry_address; +{ + extern unsigned long scm_dumped_brk; + int new_file, old_file, new_file_size; + + /* Pointers to the base of the image of the two files. */ + caddr_t old_base, new_base; + + /* Pointers to the file, program and section headers for the old and new + files. */ + Elf32_Ehdr *old_file_h, *new_file_h; + Elf32_Phdr *old_program_h, *new_program_h; + Elf32_Shdr *old_section_h, *new_section_h; + + /* Point to the section name table in the old file. */ + char *old_section_names; + + Elf32_Addr old_bss_addr, new_bss_addr; + Elf32_Word old_bss_size, new_data2_size; + Elf32_Off new_data2_offset; + Elf32_Addr new_data2_addr; + Elf32_Addr new_offsets_shift; + + int n, nn, old_bss_index, old_data_index, new_data2_index; + int old_mdebug_index; + struct stat stat_buf; + + /* Open the old file & map it into the address space. */ + + old_file = open (old_name, O_RDONLY); + + if (old_file < 0) + fatal ("Can't open %s for reading: errno %d\n", old_name, errno); + + if (fstat (old_file, &stat_buf) == -1) + fatal ("Can't fstat(%s): errno %d\n", old_name, errno); + + old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0); + + if (old_base == (caddr_t) -1) + fatal ("Can't mmap(%s): errno %d\n", old_name, errno); + +#ifdef DEBUG + fprintf (stderr, "mmap(%s, %x) -> %x\n", old_name, stat_buf.st_size, + old_base); +#endif + + /* Get pointers to headers & section names. */ + + old_file_h = (Elf32_Ehdr *) old_base; + old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff); + old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff); + old_section_names + = (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; + + /* Find the mdebug section, if any. */ + + old_mdebug_index = find_section (".mdebug", old_section_names, + old_name, old_file_h, old_section_h, 1); + + /* Find the old .bss section. */ + + old_bss_index = find_section (".bss", old_section_names, + old_name, old_file_h, old_section_h, 0); + + /* Find the old .data section. Figure out parameters of + the new data2 and bss sections. */ + + old_data_index = find_section (".data", old_section_names, + old_name, old_file_h, old_section_h, 0); + + old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; + old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; +#if defined(emacs) || !defined(DEBUG) + scm_dumped_brk = (unsigned long) sbrk (0); + new_bss_addr = (Elf32_Addr) scm_dumped_brk; +#else + new_bss_addr = old_bss_addr + old_bss_size + 0x1234; +#endif + new_data2_addr = old_bss_addr; + new_data2_size = new_bss_addr - old_bss_addr; + new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset + + (new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr); + new_offsets_shift = new_bss_addr - + ((old_bss_addr & ~0xfff) + ((old_bss_addr & 0xfff) ? 0x1000 : 0)); + +#ifdef DEBUG + fprintf (stderr, "old_bss_index %d\n", old_bss_index); + fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); + fprintf (stderr, "old_bss_size %x\n", old_bss_size); + fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); + fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); + fprintf (stderr, "new_data2_size %x\n", new_data2_size); + fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); + fprintf (stderr, "new_offsets_shift %x\n", new_offsets_shift); +#endif + + if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) + fatal (".bss shrank when undumping???\n", 0, 0); + + /* Set the output file to the right size and mmap it. Set + pointers to various interesting objects. stat_buf still has + old_file data. */ + + new_file = open (new_name, O_RDWR | O_CREAT, 0666); + if (new_file < 0) + fatal ("Can't creat (%s): errno %d\n", new_name, errno); + + new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_offsets_shift; + + if (ftruncate (new_file, new_file_size)) + fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); + + new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED, + new_file, 0); + + if (new_base == (caddr_t) -1) + fatal ("Can't mmap (%s): errno %d\n", new_name, errno); + + new_file_h = (Elf32_Ehdr *) new_base; + new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff); + new_section_h + = (Elf32_Shdr *) ((byte *) new_base + old_file_h->e_shoff + + new_offsets_shift); + + /* Make our new file, program and section headers as copies of the + originals. */ + + memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); + memcpy (new_program_h, old_program_h, + old_file_h->e_phnum * old_file_h->e_phentsize); + + /* Modify the e_shstrndx if necessary. */ + PATCH_INDEX (new_file_h->e_shstrndx); + + /* Fix up file header. We'll add one section. Section header is + further away now. */ + + new_file_h->e_shoff += new_offsets_shift; + new_file_h->e_shnum += 1; + +#ifdef DEBUG + fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); + fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); + fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); + fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); +#endif + + /* Fix up a new program header. Extend the writable data segment so + that the bss area is covered too. Find that segment by looking + for a segment that ends just before the .bss area. Make sure + that no segments are above the new .data2. Put a loop at the end + to adjust the offset and address of any segment that is above + data2, just in case we decide to allow this later. */ + + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + /* Compute maximum of all requirements for alignment of section. */ + int alignment = (NEW_PROGRAM_H (n)).p_align; + if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) + alignment = OLD_SECTION_H (old_bss_index).sh_addralign; + + /* Supposedly this condition is okay for the SGI. */ +#if 0 + if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr) + fatal ("Program segment above .bss in %s\n", old_name, 0); +#endif + + if (NEW_PROGRAM_H (n).p_type == PT_LOAD + && (round_up ((NEW_PROGRAM_H (n)).p_vaddr + + (NEW_PROGRAM_H (n)).p_filesz, + alignment) + == round_up (old_bss_addr, alignment))) + break; + } + if (n < 0) + fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0); + + NEW_PROGRAM_H (n).p_filesz += new_offsets_shift; + NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; + +#if 1 /* Maybe allow section after data2 - does this ever happen? */ + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + if (NEW_PROGRAM_H (n).p_vaddr + && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) + NEW_PROGRAM_H (n).p_vaddr += new_offsets_shift - old_bss_size; + + if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) + NEW_PROGRAM_H (n).p_offset += new_offsets_shift; + } +#endif + + /* Fix up section headers based on new .data2 section. Any section + whose offset or virtual address is after the new .data2 section + gets its value adjusted. .bss size becomes zero and new address + is set. data2 section header gets added by copying the existing + .data header and modifying the offset, address and size. */ + for (old_data_index = 1; old_data_index < old_file_h->e_shnum; + old_data_index++) + if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, + ".data")) + break; + if (old_data_index == old_file_h->e_shnum) + fatal ("Can't find .data in %s.\n", old_name, 0); + + /* Walk through all section headers, insert the new data2 section right + before the new bss section. */ + for (n = 1, nn = 1; n < old_file_h->e_shnum; n++, nn++) + { + caddr_t src; + + /* If it is bss section, insert the new data2 section before it. */ + if (n == old_bss_index) + { + /* Steal the data section header for this data2 section. */ + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), + new_file_h->e_shentsize); + + NEW_SECTION_H (nn).sh_addr = new_data2_addr; + NEW_SECTION_H (nn).sh_offset = new_data2_offset; + NEW_SECTION_H (nn).sh_size = new_data2_size; + /* Use the bss section's alignment. This will assure that the + new data2 section always be placed in the same spot as the old + bss section by any other application. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; + + /* Now copy over what we have in the memory now. */ + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, + (caddr_t) OLD_SECTION_H (n).sh_addr, + new_data2_size); + nn++; + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), + old_file_h->e_shentsize); + + /* The new bss section's size is zero, and its file offset and virtual + address should be off by NEW_OFFSETS_SHIFT. */ + NEW_SECTION_H (nn).sh_offset += new_offsets_shift; + NEW_SECTION_H (nn).sh_addr = new_bss_addr; + /* Let the new bss section address alignment be the same as the + section address alignment followed the old bss section, so + this section will be placed in exactly the same place. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; + NEW_SECTION_H (nn).sh_size = 0; + } + else + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), + old_file_h->e_shentsize); + + /* Any section that was original placed AFTER the bss + section must now be adjusted by NEW_OFFSETS_SHIFT. */ + + if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) + NEW_SECTION_H (nn).sh_offset += new_offsets_shift; + + /* If any section hdr refers to the section after the new .data + section, make it refer to next one because we have inserted + a new section in between. */ + + PATCH_INDEX (NEW_SECTION_H (nn).sh_link); + /* For symbol tables, info is a symbol table index, + so don't change it. */ + if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB + && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) + PATCH_INDEX (NEW_SECTION_H (nn).sh_info); + + /* Now, start to copy the content of sections. */ + if (NEW_SECTION_H (nn).sh_type == SHT_NULL + || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) + continue; + + /* Write out the sections. .data and .data1 (and data2, called + ".data" in the strings table) get copied from the current process + instead of the old file. */ + if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data") + || !strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data1") + || !strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".got")) + src = (caddr_t) OLD_SECTION_H (n).sh_addr; + else + src = old_base + OLD_SECTION_H (n).sh_offset; + + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, + NEW_SECTION_H (nn).sh_size); + + /* Adjust the HDRR offsets in .mdebug and copy the + line data if it's in its usual 'hole' in the object. + Makes the new file debuggable with dbx. + patches up two problems: the absolute file offsets + in the HDRR record of .mdebug (see /usr/include/syms.h), and + the ld bug that gets the line table in a hole in the + elf file rather than in the .mdebug section proper. + David Anderson. davea@sgi.com Jan 16,1994. */ + if (n == old_mdebug_index) + { +#define MDEBUGADJUST(__ct,__fileaddr) \ + if (n_phdrr->__ct > 0) \ + { \ + n_phdrr->__fileaddr += movement; \ + } + + HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset); + HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset); + unsigned movement = new_offsets_shift; + + MDEBUGADJUST (idnMax, cbDnOffset); + MDEBUGADJUST (ipdMax, cbPdOffset); + MDEBUGADJUST (isymMax, cbSymOffset); + MDEBUGADJUST (ioptMax, cbOptOffset); + MDEBUGADJUST (iauxMax, cbAuxOffset); + MDEBUGADJUST (issMax, cbSsOffset); + MDEBUGADJUST (issExtMax, cbSsExtOffset); + MDEBUGADJUST (ifdMax, cbFdOffset); + MDEBUGADJUST (crfd, cbRfdOffset); + MDEBUGADJUST (iextMax, cbExtOffset); + /* The Line Section, being possible off in a hole of the object, + requires special handling. */ + if (n_phdrr->cbLine > 0) + { + if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset + + OLD_SECTION_H (n).sh_size)) + { + /* line data is in a hole in elf. do special copy and adjust + for this ld mistake. + */ + n_phdrr->cbLineOffset += movement; + + memcpy (n_phdrr->cbLineOffset + new_base, + o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); + } + else + { + /* somehow line data is in .mdebug as it is supposed to be. */ + MDEBUGADJUST (cbLine, cbLineOffset); + } + } + } + + /* If it is the symbol table, its st_shndx field needs to be patched. */ + if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB + || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) + { + Elf32_Shdr *spt = &NEW_SECTION_H (nn); + unsigned int num = spt->sh_size / spt->sh_entsize; + Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset + + new_base); + for (; num--; sym++) + { + if (sym->st_shndx == SHN_UNDEF + || sym->st_shndx == SHN_ABS + || sym->st_shndx == SHN_COMMON) + continue; + + PATCH_INDEX (sym->st_shndx); + } + } + } + + /* Close the files and make the new file executable. */ + + if (close (old_file)) + fatal ("Can't close (%s): errno %d\n", old_name, errno); + + if (close (new_file)) + fatal ("Can't close (%s): errno %d\n", new_name, errno); + + if (stat (new_name, &stat_buf) == -1) + fatal ("Can't stat (%s): errno %d\n", new_name, errno); + + n = umask (777); + umask (n); + stat_buf.st_mode |= 0111 & ~n; + if (chmod (new_name, stat_buf.st_mode) == -1) + fatal ("Can't chmod (%s): errno %d\n", new_name, errno); +} @@ -9,10 +9,10 @@ * 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "unif.c" Uniform vectors and arrays @@ -61,19 +61,22 @@ complex double cvect #endif long tc16_array = 0; +static SCM i_short; char s_resizuve[] = "vector-set-length!"; SCM resizuve(vect, len) SCM vect, len; { - long l = INUM(len); + long ol, l = INUM(len); sizet siz, sz; ASRTGO(NIMP(vect), badarg1); + ol = LENGTH(vect); switch TYP7(vect) { default: badarg1: wta(vect, (char *)ARG1, s_resizuve); case tc7_string: ASRTGO(vect != nullstr, badarg1); sz = sizeof(char); + ol++; l++; break; case tc7_vector: @@ -82,17 +85,19 @@ SCM resizuve(vect, len) break; #ifdef ARRAYS case tc7_bvect: + ol = (ol+LONG_BIT-1)/LONG_BIT; l = (l+LONG_BIT-1)/LONG_BIT; case tc7_uvect: case tc7_ivect: sz = sizeof(long); break; + case tc7_svect: + sz = sizeof(short); + break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: sz = sizeof(float); break; -# endif case tc7_dvect: sz = sizeof(double); break; @@ -107,13 +112,12 @@ 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)LENGTH(vect)*sz, - (long)siz, s_resizuve); - if VECTORP(vect) { - sz = LENGTH(vect); - while(l > sz) VELTS(vect)[--l] = UNSPECIFIED; - } - else if STRINGP(vect) CHARS(vect)[l-1] = 0; + must_realloc_cell(vect, (long)ol*sz, (long)siz, s_resizuve); + if VECTORP(vect) + while(l > ol) + VELTS(vect)[--l] = UNSPECIFIED; + else if STRINGP(vect) + CHARS(vect)[l-1] = 0; SETLENGTH(vect, INUM(len), TYP7(vect)); ALLOW_INTS; return vect; @@ -135,64 +139,85 @@ SCM makflo (x) ALLOW_INTS; return z; } +# else +# define makflo(x) makdbl((double)(x), 0.0) # endif # endif +long scm_prot2type(prot) + SCM 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 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; + } +# endif +} + SCM make_uve(k, prot) long k; SCM prot; { SCM v; - long i, type; - if (BOOL_T==prot) { + long i; + long type = scm_prot2type(prot); + switch (type) { + default: + case tc7_vector: /* Huge non-unif vectors are NOT supported. */ + return make_vector(MAKINUM(k), UNDEFINED); /* no special vector */ + case tc7_bvect: i = sizeof(long)*((k+LONG_BIT-1)/LONG_BIT); - type = tc7_bvect; - } - else if ICHRP(prot) { + break; + case tc7_string: i = sizeof(char)*(k + 1); - type = tc7_string; - } - else if INUMP(prot) { + break; + case tc7_uvect: + case tc7_ivect: i = sizeof(long)*k; - if (INUM(prot)>0) type = tc7_uvect; - else type = tc7_ivect; - } - else -# ifdef FLOATS - if (IMP(prot) || !INEXP(prot)) -# endif - /* Huge non-unif vectors are NOT supported. */ - return make_vector(MAKINUM(k), UNDEFINED); /* no special vector */ + break; + case tc7_svect: + i = sizeof(short)*k; # ifdef FLOATS -# ifdef SINGLES - else if SINGP(prot) { -# ifdef CDR_DOUBLES - double x = FLO(prot); - float fx = x; - if (x != fx) { - i = sizeof(double)*k; - type = tc7_dvect; - } - else -# endif - { - i = sizeof(float)*k; - type = tc7_fvect; - } - } -# endif - else if (CPLXP(prot)) { - i = 2*sizeof(double)*k; - type = tc7_cvect; - } - else { + case tc7_fvect: + i = sizeof(float)*k; + break; + case tc7_dvect: i = sizeof(double)*k; - type = tc7_dvect; - } + break; + case tc7_cvect: + i = 2*sizeof(double)*k; + break; # endif + } DEFER_INTS; - v = must_malloc_cell((i ? i : 1L), s_vector); - SETLENGTH(v, (k<LENGTH_MAX ? k : LENGTH_MAX), type); + v = must_malloc_cell((i ? i : 1L), + MAKE_LENGTH((k<LENGTH_MAX ? k : LENGTH_MAX), type), + s_vector); if (tc7_string==type) CHARS(v)[k] = 0; ALLOW_INTS; return v; @@ -205,14 +230,8 @@ SCM uve_len(v) ASRTGO(NIMP(v), badarg1); switch TYP7(v) { default: badarg1: wta(v, (char *)ARG1, s_uve_len); - case tc7_bvect: - case tc7_string: - case tc7_uvect: - case tc7_ivect: - case tc7_fvect: - case tc7_dvect: - case tc7_cvect: case tc7_vector: + case tcs_uves: return MAKINUM(LENGTH(v)); } } @@ -220,30 +239,28 @@ SCM uve_len(v) SCM arrayp(v, prot) SCM v, prot; { - int nprot = UNBNDP(prot), enclosed = 0; + int enclosed = 0; + long typ; if IMP(v) return BOOL_F; + typ = TYP7(v); loop: - switch TYP7(v) { + switch (typ) { case tc7_smob: if (!ARRAYP(v)) return BOOL_F; - if (nprot) return BOOL_T; + if (UNBNDP(prot)) return BOOL_T; if (enclosed++) return BOOL_F; v = ARRAY_V(v); goto loop; - case tc7_bvect: return nprot || BOOL_T==prot ? BOOL_T : BOOL_F; - case tc7_string: return nprot || ICHRP(prot) ? BOOL_T : BOOL_F; + case tc7_bvect: + case tc7_string: case tc7_uvect: - return nprot || (INUMP(prot) && INUM(prot)>0) ? BOOL_T : BOOL_F; case tc7_ivect: - return nprot || (INUMP(prot) && INUM(prot)<=0) ? BOOL_T : BOOL_F; -# ifdef FLOATS -# ifdef SINGLES - case tc7_fvect: return nprot || (NIMP(prot) && SINGP(prot)) ? BOOL_T : BOOL_F; -# endif - case tc7_dvect: return nprot || (NIMP(prot) && REALP(prot)) ? BOOL_T : BOOL_F; - case tc7_cvect: return nprot || (NIMP(prot) && CPLXP(prot)) ? BOOL_T : BOOL_F; -# endif - case tc7_vector: return nprot || NULLP(prot) ? BOOL_T : BOOL_F; - default:; + case tc7_svect: + case tc7_fvect: + case tc7_dvect: + case tc7_cvect: + case tc7_vector: + if (UNBNDP(prot)) return BOOL_T; + if (scm_prot2type(prot)==typ) return BOOL_T; } return BOOL_F; } @@ -253,9 +270,8 @@ SCM array_rank(ra) if IMP(ra) return INUM0; switch (TYP7(ra)) { default: return INUM0; - case tc7_string: case tc7_vector: case tc7_bvect: - case tc7_uvect: case tc7_ivect: case tc7_fvect: - case tc7_cvect: case tc7_dvect: + case tc7_vector: + case tcs_uves: return MAKINUM(1L); case tc7_smob: if ARRAYP(ra) return MAKINUM(ARRAY_NDIM(ra)); @@ -272,9 +288,8 @@ SCM array_dims(ra) if IMP(ra) return BOOL_F; switch (TYP7(ra)) { default: return BOOL_F; - case tc7_string: case tc7_vector: case tc7_bvect: - case tc7_uvect: case tc7_ivect: case tc7_fvect: - case tc7_cvect: case tc7_dvect: + case tc7_vector: + case tcs_uves: return cons(MAKINUM(LENGTH(ra)), EOL); case tc7_smob: if (!ARRAYP(ra)) return BOOL_F; @@ -323,8 +338,9 @@ SCM make_ra(ndim) { SCM ra; DEFER_INTS; - ra = must_malloc_cell((long)(sizeof(array)+ndim*sizeof(array_dim)), "array"); - CAR(ra) = ((long)ndim << 17) + tc16_array; + ra = must_malloc_cell(sizeof(array)+((long)ndim)*sizeof(array_dim), + (((long)ndim) << 17) + tc16_array, + "array"); ARRAY_V(ra) = nullvect; ALLOW_INTS; return ra; @@ -355,7 +371,7 @@ SCM shap2ra(args, what) ASSERT(CONSP(spec) && INUMP(CAR(spec)), spec, s_bad_spec, what); s->lbnd = INUM(CAR(spec)); sp = CDR(spec); - ASSERT(INUMP(CAR(sp)) && NULLP(CDR(sp)), + ASSERT(NIMP(sp) && INUMP(CAR(sp)) && NULLP(CDR(sp)), spec, s_bad_spec, what); s->ubnd = INUM(CAR(sp)); s->inc = 1; @@ -444,7 +460,6 @@ int rafill(ra, fill, ignore) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *ve = (float *)VELTS(ra); float f = num2dbl(fill, (char *)ARG2, s_uve_fill); @@ -452,7 +467,6 @@ int rafill(ra, fill, ignore) ve[i] = f; break; } -# endif /* SINGLES */ case tc7_dvect: { double *ve = (double *)VELTS(ra); double f = num2dbl(fill, (char *)ARG2, s_uve_fill); @@ -564,9 +578,8 @@ SCM make_sh_array(oldra, mapfunc, dims) SCM mapfunc; SCM dims; { - SCM ra; - SCM inds, indptr; - SCM imap; + SCM ra, imap, auto_indv[5], hp_indv; + SCM *indv = auto_indv; sizet i, k; long old_min, new_min, old_max, new_max; array_dim *s; @@ -590,10 +603,14 @@ SCM make_sh_array(oldra, mapfunc, dims) old_min = 0; old_max = (long)LENGTH(oldra) - 1; } - inds = EOL; + if (ARRAY_NDIM(ra) > 5) { + scm_protect_temp(&hp_indv); + hp_indv = make_vector(MAKINUM(ARRAY_NDIM(ra)), BOOL_F); + indv = VELTS(hp_indv); + } s = ARRAY_DIMS(ra); for (k = 0; k < ARRAY_NDIM(ra); k++) { - inds = cons(MAKINUM(s[k].lbnd), inds); + indv[k] = MAKINUM(s[k].lbnd); if (s[k].ubnd < s[k].lbnd) { if (1==ARRAY_NDIM(ra)) ra = make_uve(0L, array_prot(ra)); @@ -602,7 +619,7 @@ SCM make_sh_array(oldra, mapfunc, dims) return ra; } } - imap = apply(mapfunc, reverse(inds), EOL); + imap = scm_cvapply(mapfunc, ARRAY_NDIM(ra), indv); if ARRAYP(oldra) i = (sizet)aind(oldra, imap, s_make_sh_array); else { @@ -614,12 +631,13 @@ SCM make_sh_array(oldra, mapfunc, dims) i = INUM(imap); } ARRAY_BASE(ra) = new_min = new_max = i; - indptr = inds; k = ARRAY_NDIM(ra); while (k--) { if (s[k].ubnd > s[k].lbnd) { - CAR(indptr) = MAKINUM(INUM(CAR(indptr))+1); - imap = apply(mapfunc, reverse(inds), EOL); + /* CAR(indptr) = MAKINUM(INUM(CAR(indptr))+1); + imap = apply(mapfunc, reverse(inds), EOL); */ + indv[k] = MAKINUM(INUM(indv[k]) + 1); + imap = scm_cvapply(mapfunc, ARRAY_NDIM(ra), indv); if ARRAYP(oldra) s[k].inc = aind(oldra, imap, s_make_sh_array) - i; else { @@ -638,7 +656,6 @@ SCM make_sh_array(oldra, mapfunc, dims) } else s[k].inc = new_max - new_min + 1; /* contiguous by default */ - indptr = CDR(indptr); } ASSERT(old_min <= new_min && old_max >= new_max, UNDEFINED, "mapping out of range", s_make_sh_array); @@ -664,8 +681,8 @@ SCM trans_array(args) args = CDR(args); switch TYP7(ra) { default: badarg: wta(ra, (char *)ARG1, s_trans_array); - case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: - case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + case tc7_vector: + case tcs_uves: ASSERT(NIMP(args) && NULLP(CDR(args)), UNDEFINED, WNA, s_trans_array); ASSERT(INUM0==CAR(args), CAR(args), ARG1, s_trans_array); return ra; @@ -732,8 +749,8 @@ SCM encl_array(axes) ASRTGO(NIMP(ra), badarg1); switch TYP7(ra) { default: badarg1: wta(ra, (char *)ARG1, s_encl_array); - case tc7_string: case tc7_bvect: case tc7_uvect: case tc7_ivect: - case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + case tc7_vector: + case tcs_uves: s->lbnd = 0; s->ubnd = LENGTH(ra) - 1; s->inc = 1; @@ -785,7 +802,7 @@ SCM array_inbp(args) if IMP(v) goto scalar; switch TYP7(v) { wna: wta(UNDEFINED, (char *)WNA, s_array_inbp); - default: scalar: + default: scalar: if NULLP(args) return BOOL_T; wta(v, (char *)ARG1, s_array_inbp); case tc7_smob: @@ -806,8 +823,8 @@ SCM array_inbp(args) return ret; } else goto scalar; - case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: - case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + case tc7_vector: + case tcs_uves: ASRTGO(NIMP(args) && NULLP(CDR(args)), wna); ind = CAR(args); ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp); @@ -867,6 +884,8 @@ SCM aref(v, args) else return BOOL_F; case tc7_string: return MAKICHR(CHARS(v)[pos]); + case tc7_svect: + return MAKINUM(((short *)CDR(v))[pos]); # ifdef INUMS_ONLY case tc7_uvect: case tc7_ivect: @@ -878,10 +897,8 @@ SCM aref(v, args) return long2num(VELTS(v)[pos]); # endif # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: return makflo(((float *)CDR(v))[pos]); -# endif case tc7_dvect: return makdbl(((double *)CDR(v))[pos], 0.0); case tc7_cvect: @@ -914,6 +931,8 @@ SCM cvref(v, pos, last) else return BOOL_F; case tc7_string: return MAKICHR(CHARS(v)[pos]); + case tc7_svect: + return MAKINUM(((short *)CDR(v))[pos]); # ifdef INUMS_ONLY case tc7_uvect: case tc7_ivect: @@ -925,13 +944,19 @@ SCM cvref(v, pos, last) return long2num(VELTS(v)[pos]); # endif # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: +# ifdef SINGLES if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) { FLO(last) = ((float *)CDR(v))[pos]; return last; } return makflo(((float *)CDR(v))[pos]); +# else /* ndef SINGLES */ + if (NIMP(last) && (last != flo0) && (tc_dblr==CAR(last))) { + REAL(last) = ((float *)CDR(v))[pos]; + return last; + } + return makdbl((double)((float *)CDR(v))[pos], 0.0); # endif case tc7_cvect: if (0.0!=((double *)CDR(v))[2*pos+1]) { @@ -1021,6 +1046,8 @@ SCM aset(v, obj, args) case tc7_string: ASRTGO(ICHRP(obj), badarg2); CHARS(v)[pos] = ICHR(obj); break; + case tc7_svect: + ((short *)VELTS(v))[pos] = num2short(obj, (char *)ARG2, s_aset); break; # ifdef INUMS_ONLY case tc7_uvect: ASRTGO(INUM(obj) >= 0, badarg2); @@ -1033,10 +1060,8 @@ SCM aset(v, obj, args) VELTS(v)[pos] = num2long(obj, (char *)ARG2, s_aset); break; # endif # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: ((float*)VELTS(v))[pos] = (float)num2dbl(obj, (char *)ARG2, s_aset); break; -# endif case tc7_dvect: ((double*)VELTS(v))[pos] = num2dbl(obj, (char *)ARG2, s_aset); break; case tc7_cvect: @@ -1065,8 +1090,8 @@ SCM array_contents(ra, strict) switch TYP7(ra) { default: return BOOL_F; - case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect: - case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect: + case tc7_vector: + case tcs_uves: return ra; case tc7_smob: { sizet k, ndim = ARRAY_NDIM(ra), len = 1; @@ -1128,12 +1153,13 @@ SCM uve_read(v, port) case tc7_ivect: sz = sizeof(long); break; + case tc7_svect: + sz = sizeof(short); + break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: sz = sizeof(float); break; -# endif case tc7_dvect: sz = sizeof(double); break; @@ -1142,11 +1168,15 @@ SCM uve_read(v, port) break; # endif } - /* An ungetc before an fread will not work on some systems if setbuf(0). - do #define NOSETBUF in scmfig.h to fix this. */ - if CRDYP(port) { /* UGGH!!! */ - ungetc(CGETUN(port), STREAM(port)); - CLRDY(port); /* Clear ungetted char */ + if (0==len) return INUM0; + /* An ungetc before an fread will not work on some systems if setbuf(0), + so we read one element char by char. */ + if CRDYP(port) { + int i; + for (i = 0; i < sz; i++) + CHARS(v)[start*sz + i] = lgetc(port); + start += 1; + len -= 1; } SYSCALL(ans = fread(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port));); if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; @@ -1188,12 +1218,13 @@ SCM uve_write(v, port) case tc7_ivect: sz = sizeof(long); break; + case tc7_svect: + sz = sizeof(short); + break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: sz = sizeof(float); break; -# endif case tc7_dvect: sz = sizeof(double); break; @@ -1321,7 +1352,7 @@ SCM position(item, v, k) else { long inc = ARRAY_DIMS(v)->inc; long ubnd = ARRAY_DIMS(v)->ubnd; - if (ubnd < ARRAY_DIMS(v)->lbnd) + if (ubnd < ARRAY_DIMS(v)->lbnd) return MAKINUM(ARRAY_DIMS(v)->lbnd - 1); i = ARRAY_BASE(v) + (pos - ARRAY_DIMS(v)->lbnd)*inc; v = ARRAY_V(v); @@ -1560,8 +1591,15 @@ SCM array2list(v) register long k; ASRTGO(NIMP(v), badarg1); switch TYP7(v) { - default: badarg1: wta(v, (char *)ARG1, s_array2list); + default: + if (BOOL_T==arrayp(v, UNDEFINED)) { + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(cvref(v, k, UNDEFINED), res); + return res; + } + badarg1: wta(v, (char *)ARG1, s_array2list); case tc7_smob: ASRTGO(ARRAYP(v), badarg1); + if (0==ARRAY_NDIM(v)) return aref(v, EOL); return ra2l(v, ARRAY_BASE(v), 0); case tc7_vector: return vector2list(v); case tc7_string: return string2list(v); @@ -1598,14 +1636,12 @@ SCM array2list(v) } # endif # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *data = (float *)VELTS(v); for (k = LENGTH(v) - 1; k >= 0; k--) res = cons(makflo(data[k]), res); return res; } -# endif /*SINGLES*/ case tc7_dvect: { double *data = (double *)VELTS(v); for (k = LENGTH(v) - 1; k >= 0; k--) @@ -1643,20 +1679,19 @@ SCM list2ura(ndim, prot, lst) shp = cons(MAKINUM(n), shp); } ra = dims2ura(reverse(shp), prot, EOL); - if NULLP(shp) { - ASRTGO(1==ilength(lst), badlst); - aset(ra, CAR(lst), EOL); - return ra; - } if (!ARRAYP(ra)) { for (k = 0; k < LENGTH(ra); k++, lst = CDR(lst)) aset(ra, CAR(lst), MAKINUM(k)); return ra; } + if NULLP(shp) { + aset(ra, lst, EOL); + return ra; + } if (l2ra(lst, ra, ARRAY_BASE(ra), 0)) return ra; else - badlst: wta(lst, s_bad_ralst, s_list2ura); + wta(lst, s_bad_ralst, s_list2ura); return BOOL_F; } @@ -1775,9 +1810,7 @@ static void rapr1(ra, j, k, port, writing) } break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: -# endif /*SINGLES*/ case tc7_dvect: case tc7_cvect: if (n-- > 0) { @@ -1840,27 +1873,35 @@ int raprin1(exp, port, writing) return 1; } else - lputc('b', port); break; + lputs("At", port); break; + case tc7_vector: + lputc('A', port); break; case tc7_string: - lputc('a', port); break; + lputs("A\\", port); break; case tc7_uvect: - lputc('u', port); break; + lputs("Au", port); break; case tc7_ivect: - lputc('e', port); break; + lputs("Ae", port); break; + case tc7_svect: + lputs("Aes", port); break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: - lputc('s', port); break; -# endif /*SINGLES*/ + lputs("Aif", port); break; case tc7_dvect: - lputc('i', port); break; + lputs("Ai", port); break; case tc7_cvect: - lputc('c', port); break; + lputs("Aic", port); break; # endif /*FLOATS*/ } - lputc('(', port); - rapr1(exp, base, 0, port, writing); - lputc(')', port); + if ((v != exp) && 0==ARRAY_NDIM(exp)) { + lputc(' ', port); + iprin1(aref(exp, EOL), port, writing); + } + else { + lputc('(', port); + rapr1(exp, base, 0, port, writing); + lputc(')', port); + } return 1; } @@ -1880,12 +1921,11 @@ 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); # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: return makflo(1.0); -# endif case tc7_dvect: return makdbl(1.0/3.0, 0.0); case tc7_cvect: return makdbl(0.0, 1.0); # endif @@ -1969,7 +2009,7 @@ SCM scm_logaset(ra, obj, args) scm_logand(oval, MAKINUM(~(1<<INUM(ibit)))); #ifndef RECKLESS else wta(obj, (char *)ARG2, s_logaset); -#endif +#endif } return aset(ra, obj, inds); } @@ -2026,15 +2066,13 @@ static iproc subr2os[] = { static SCM markra(ptr) SCM ptr; { - if GC8MARKP(ptr) return BOOL_F; - SETGC8MARK(ptr); return ARRAY_V(ptr); } static sizet freera(ptr) CELLPTR ptr; { must_free(CHARS(ptr), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim)); - return sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim); + return 0; } static smobfuns rasmob = {markra, freera, raprin1, 0}; /* 0 replaced by raequal in init_ramap() */ @@ -2049,6 +2087,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"); } @@ -1,18 +1,18 @@ /* Copyright (C) 1994, 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. + * 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. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "unix.c" functions only in Unix (unix). @@ -0,0 +1,2114 @@ +/* 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. + */ + +/* "x.c" SCM interface to Xlib. + * Authors: Aubrey Jaffer (I have rewritten nearly all of it) and: + * + * Modified by Shigenobu Kimura (skimu@izanagi.phys.s.u-tokyo.ac.jp) + * Author: Larry Campbell (campbell@world.std.com) + * + * Copyright 1992 by The Boston Software Works, Inc. + * Permission to use for any purpose whatsoever granted, as long + * as this copyright notice remains intact. Please send bug fixes + * or enhancements to the above email address. + * + * Generic X and Xlib functions for scm. + * These functions do not depend on any toolkit. + */ + +#include <stdio.h> +#include <X11/X.h> +#include <X11/Xlib.h> +#include <X11/Xutil.h> + +#include "scm.h" + +/* These structs are mallocated for use in SMOBS. */ + +struct xs_Display { + SCM after; + int screen_count; + Display *dpy; +}; + +/* An array of struct xs_screen (following xs_Display) holds the + root-windows and default colormaps. */ + +struct xs_screen { + SCM root_window; + SCM default_gcontext; + SCM default_visual; + SCM default_colormap; +}; + +struct xs_Window { + SCM display; + int screen_number; + Display *dpy; + union { + Window win; + Pixmap pm; + Drawable drbl; + } p; +}; + +struct xs_GContext { + SCM display; + int screen_number; + Display *dpy; + GC gc; + SCM font; + SCM tile; + SCM stipple; + SCM clipmask; +}; + +struct xs_Cursor { + SCM display; + Cursor cursor; +}; + +struct xs_Font { + SCM display; + Font font; + SCM name; +}; + +struct xs_Colormap { + SCM display; + Display *dpy; + Colormap cm; +}; + +/* These structs are for returning multiple values when processing + procedure arguments. */ + +struct display_screen{ + SCM display; + Display *dpy; + int screen_number; +}; + +/* The cproto program fills x.h with ANSI-C prototypes of the + functions in x.c. */ + +#include "x.h" + + /* Macros for accessing these structs */ + +#define DISPLAY(x) ((struct xs_Display *) CDR(x)) +#define WINDOW(x) ((struct xs_Window *) CDR(x)) +#define CURSOR(x) ((struct xs_Cursor *) CDR(x)) +#define FONT(x) ((struct xs_Font *) CDR(x)) +#define COLORMAP(x) ((struct xs_Colormap *) CDR(x)) +#define GCONTEXT(x) ((struct xs_GContext *) CDR(x)) + +#define XDISPLAY(x) (DISPLAY(x)->dpy) +#define XWINDOW(x) (WINDOW(x)->p.win) +#define XWINDISPLAY(x) (WINDOW(x)->dpy) +#define XCURSOR(x) (CURSOR(x)->cursor) +#define XFONT(x) (FONT(x)->font) +#define XGCONTEXT(x) (GCONTEXT(x)->gc) +#define XCOLORMAP(x) (COLORMAP(x)->cm) +#define XGCONDISPLAY(x) (GCONTEXT(x)->dpy) + +/* Notice that types Visual and XEvent don't have struct wrappers. */ + +#define XVISUAL(x) ((Visual *) CDR(x)) +#define XEVENT(x) ((XEvent *) CDR(x)) + + /* Type predicates */ + +#define DISPLAYP(x) (TYP16(x)==tc16_xdisplay) +#define OPDISPLAYP(x) (((0xffff | OPN) & (int)CAR(x))==(tc16_xdisplay | OPN)) +#define WINDOWP(x) (TYP16(x)==tc16_xwindow) +#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 CURSORP(x) (TYP16(x)==tc16_xcursor) +#define FONTP(x) (TYP16(x)==tc16_xfont) +#define VISUALP(x) (TYP16(x)==tc16_xvisual) +#define XEVENTP(x) (TYP16(x)==tc16_xevent) + + /* Scheme Procedure Names */ + +static char s_x_open_display[] = "x:open-display"; +static char s_x_close[] = "x:close"; +static char s_x_display_debug[] = "x:display-debug"; +static char s_x_default_screen[] = "x:default-screen"; +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_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_create_pixmap[] = "x:create-pixmap"; + +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"; + +static char s_x_create_gc[] = "x:create-gc"; +static char s_x_gc_set[] = "x:gc-set!"; +static char s_x_gc_ref[] = "x:gc-ref"; +static char s_x_copy_gc[] = "x:copy-gc-fields!"; + +static char s_x_create_cursor[] = "x:create-cursor"; + +static char s_x_load_font[] = "x:load-font"; + +static char s_x_protocol_version[] = "x:protocol-version"; +static char s_x_vendor_release[] = "x:vendor-release"; +static char s_x_server_vendor[] = "x:server-vendor"; +static char s_x_next_event[] = "x:next-event"; +static char s_x_peek_event[] = "x:peek-event"; +static char s_x_events_queued[] = "x:events-queued"; +static char s_x_q_length[] = "x:q-length"; +static char s_x_pending[] = "x:pending"; +static char s_x_screen_count[] = "x:screen-count"; +static char s_x_screen_cells[] = "x:screen-cells"; +static char s_x_screen_depths[] = "x:screen-depths"; +static char s_x_screen_depth[] = "x:screen-depth"; +static char s_x_screen_size[] = "x:screen-size"; +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_window_geometry[] = "x:window-geometry"; + +static char s_x_create_colormap[] = "x:create-colormap"; +static char s_x_recreate_colormap[] = "x:copy-colormap-and-free"; +static char s_x_alloc_color_cells[] = "x:alloc-colormap-cells"; +static char s_x_free_color_cells[] = "x:free-colormap-cells"; +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_clear_area[] = "x:clear-area"; +static char s_x_fill_rectangle[] = "x:fill-rectangle"; +/* static char s_x_copy_area[] = "x:copy-area"; */ +static char s_x_draw_points[] = "x:draw-points"; +static char s_x_draw_segments[] = "x:draw-segments"; +static char s_x_draw_lines[] = "x:draw-lines"; +static char s_x_fill_poly[] = "x:fill-polygon"; +static char s_x_draw_string[] = "x:draw-string"; +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"; + + /* Type-name strings */ + +static char s_gc[] = "graphics-context"; +#define s_display (&s_x_open_display[7]) +#define s_window (&s_x_root_window[7]) +#define s_cursor (&s_x_create_cursor[9]) +#define s_font (&s_x_load_font[7]) +#define s_colormap (&s_x_create_colormap[9]) + + /* Scheme (SMOB) types defined in this module */ + +long tc16_xdisplay; +long tc16_xgcontext; +long tc16_xcolormap; +long tc16_xwindow; +long tc16_xcursor; +long tc16_xfont; +long tc16_xvisual; +long tc16_xevent; + +/* 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. + The type xs_Window includes screen root-windows and pixmaps. The + SMOB (CAR) header bits SCROOT and PXMP keep track of which type of + window the SMOB is. */ + +/* #define OPN (1L<<16) */ +/* #define RDNG (2L<<16) */ +/* #define WRTNG (4L<<16) */ +#define SCROOT (8L<<16) +#define PXMP (16L<<16) + +/* Utility routines for creating SCM-wrapped X structs and the SMOB + routines for collecting them. */ + +SCM make_xwindow(display, screen_number, win, pxmp, rootp) + SCM display; + int screen_number; + Drawable win; + char pxmp, rootp; +{ + SCM z; + struct xs_Window *xsw; + DEFER_INTS; + z = must_malloc_cell((long)sizeof(struct xs_Window), + (SCM)(tc16_xwindow | OPN + | (pxmp ? PXMP : 0L) + | (rootp ? SCROOT : 0L)), + s_window); + xsw = WINDOW(z); + xsw->display = display; + xsw->dpy = XDISPLAY(display); + xsw->screen_number = screen_number; + if (pxmp) xsw->p.pm = (Pixmap)win; + else xsw->p.win = (Window)win; + ALLOW_INTS; + return z; +} +static SCM mark_xwindow(ptr) + SCM ptr; +{ + if CLOSEDP(ptr) return BOOL_F; + return WINDOW(ptr)->display; +} +static sizet free_xwindow(ptr) + CELLPTR ptr; +{ + SCM td = CAR((SCM)ptr); + if (!(td & OPN)) return 0; + if (!(td & SCROOT)) { + struct xs_Window *xsw = WINDOW((SCM)ptr); + SCM sd = xsw->display; + if (NIMP(sd) && OPDISPLAYP(sd)) { + if (td & PXMP) XFreePixmap(xsw->dpy, xsw->p.pm); + else XDestroyWindow(xsw->dpy, xsw->p.win); + } + } + must_free((char *)CDR((SCM)ptr), sizeof(struct xs_Window)); + CAR((SCM)ptr) = td & ~OPN; + return sizeof(struct xs_Window); +} + +SCM make_xcolormap(sdpy, cmp) + SCM sdpy; + Colormap cmp; +{ + SCM z; + struct xs_Colormap *xcm; + DEFER_INTS; + z = must_malloc_cell((long)sizeof(struct xs_Colormap), + (SCM)tc16_xcolormap, + s_colormap); + xcm = COLORMAP(z); + xcm->display = sdpy; + xcm->dpy = DISPLAY(xcm->display)->dpy; + xcm->cm = cmp; + ALLOW_INTS; + return z; +} +static SCM mark_xcolormap(ptr) + SCM ptr; +{ + if CLOSEDP(ptr) return BOOL_F; + return COLORMAP(ptr)->display; +} +static sizet free_xcolormap(ptr) + CELLPTR ptr; +{ + struct xs_Colormap *xcmp = COLORMAP((SCM)ptr); + SCM sdpy = xcmp->display; + if (NIMP(sdpy) && OPDISPLAYP(sdpy)) + XFreeColormap(xcmp->dpy, xcmp->cm); + must_free((char *)CDR((SCM)ptr), sizeof(struct xs_Colormap)); + return sizeof(struct xs_Colormap); +} + +SCM make_xdisplay(d) + Display *d; +{ + SCM z; + struct xs_screen *scrns; + struct xs_Display *xsd; + int idx = ScreenCount(d); + DEFER_INTS; + z = must_malloc_cell((long)sizeof(struct xs_Display) + + idx * sizeof(struct xs_screen), + (SCM)tc16_xdisplay | OPN, + s_display); + xsd = DISPLAY(z); + xsd->after = BOOL_F; + xsd->screen_count = idx; + xsd->dpy = d; + scrns = (struct xs_screen *)(xsd + 1); + while (idx--) { + scrns[idx].root_window = BOOL_F; + scrns[idx].default_gcontext = BOOL_F; + scrns[idx].default_visual = BOOL_F; + scrns[idx].default_colormap = BOOL_F; + } + ALLOW_INTS; + idx = xsd->screen_count; + while (idx--) { + scrns[idx].root_window = + 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_colormap = + make_xcolormap(z, DefaultColormap(d, idx)); + scrns[idx].default_visual = + make_xvisual(DefaultVisual(d, idx)); + } + return z; +} +static SCM mark_xdisplay(ptr) + SCM ptr; +{ + if CLOSEDP(ptr) return BOOL_F; + { + struct xs_Display *xsd = DISPLAY((SCM)ptr); + struct xs_screen *scrns = (struct xs_screen *)(xsd + 1); + int idx = xsd->screen_count; + while (--idx) { + 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(scrns[idx].root_window); + gc_mark(scrns[idx].default_gcontext); + gc_mark(scrns[idx].default_visual); + return scrns[idx].default_colormap; + } +} +static sizet free_xdisplay(ptr) + CELLPTR ptr; +{ + SCM td = CAR((SCM)ptr); + if (!(td & OPN)) return 0; + { + struct xs_Display *xsd = DISPLAY((SCM)ptr); + sizet len = sizeof(struct xs_Display) + + xsd->screen_count * sizeof(struct xs_screen); + XCloseDisplay(xsd->dpy); + must_free((char *)xsd, len); + CAR((SCM)ptr) = td & ~OPN; + return len; + } +} + +SCM make_xgcontext(d, screen_number, gc, rootp) + SCM d; + int screen_number; + GC gc; + int rootp; +{ + SCM z; + struct xs_GContext *xgc; + DEFER_INTS; + z = must_malloc_cell((long)sizeof(struct xs_GContext), + (SCM)tc16_xgcontext | (rootp ? SCROOT : 0L), + s_gc); + xgc = GCONTEXT(z); + xgc->display = d; + xgc->screen_number = screen_number; + xgc->dpy = XDISPLAY(d); + xgc->gc = gc; + xgc->font = BOOL_F; + xgc->tile = BOOL_F; + xgc->stipple = BOOL_F; + xgc->clipmask = BOOL_F; + ALLOW_INTS; + return z; +} +static SCM mark_xgcontext(ptr) + SCM ptr; +{ + struct xs_GContext *xgc = GCONTEXT(ptr); + gc_mark(xgc->font); + gc_mark(xgc->tile); + gc_mark(xgc->stipple); + gc_mark(xgc->clipmask); + return xgc->display; +} +static sizet free_xgcontext(ptr) + CELLPTR ptr; +{ + SCM td = CAR((SCM)ptr); + if (!(td & OPN)) return 0; + if (!(td & SCROOT)) { + struct xs_GContext *xgc = GCONTEXT((SCM)ptr); + SCM sd = xgc->display; + if (NIMP(sd) && OPDISPLAYP(sd)) XFreeGC(xgc->dpy, xgc->gc); + } + must_free((char *)CDR((SCM)ptr), sizeof(struct xs_GContext)); + return sizeof(struct xs_GContext); +} + +SCM make_xcursor(display, cursor) + SCM display; + Cursor cursor; +{ + SCM z; + struct xs_Cursor *xcsr; + DEFER_INTS; + z = must_malloc_cell((long)sizeof(struct xs_Cursor), + (SCM)tc16_xcursor, + s_cursor); + xcsr = CURSOR(z); + xcsr->display = display; + xcsr->cursor = cursor; + ALLOW_INTS; + return z; +} +static SCM mark_xcursor(ptr) + SCM ptr; +{ + if CLOSEDP(ptr) return BOOL_F; + return CURSOR(ptr)->display; +} +static sizet free_xcursor(ptr) + CELLPTR ptr; +{ + struct xs_Cursor *xcsr = CURSOR((SCM)ptr); + SCM sdpy = xcsr->display; + if (NIMP(sdpy) && OPDISPLAYP(sdpy)) { + struct xs_Display *xdp = DISPLAY(sdpy); + XFreeCursor(xdp->dpy, xcsr->cursor); + } + must_free((char *)CDR((SCM)ptr), sizeof(struct xs_Cursor)); + return sizeof(struct xs_Cursor); +} +SCM make_xfont(display, font, name) + SCM display; + Font font; + SCM name; +{ + SCM z; + struct xs_Font *xfnt; + DEFER_INTS; + z = must_malloc_cell((long)sizeof(struct xs_Font), + (SCM)tc16_xfont, + s_font); + xfnt = FONT(z); + xfnt->display = display; + xfnt->font = font; + xfnt->name = name; + ALLOW_INTS; + return z; +} +static SCM mark_xfont(ptr) + SCM ptr; +{ + struct xs_Font *xfn = FONT(ptr); + gc_mark(xfn->name); + return xfn->display; +} +static sizet free_xfont(ptr) + CELLPTR ptr; +{ + struct xs_Font *xfnt = FONT((SCM)ptr); + SCM sdpy = xfnt->display; + if (NIMP(sdpy) && OPDISPLAYP(sdpy)) { + struct xs_Display *xdp = DISPLAY(sdpy); + XUnloadFont(xdp->dpy, xfnt->font); + } + must_free((char *)CDR((SCM)ptr), sizeof(struct xs_Font)); + return sizeof(struct xs_Font); +} + +SCM make_xvisual(vsl) + Visual *vsl; +{ + SCM s_vsl; + NEWCELL(s_vsl); + DEFER_INTS; + CAR(s_vsl) = tc16_xvisual; + SETCDR(s_vsl, vsl); + ALLOW_INTS; + return s_vsl; +} + +SCM make_xevent(e) +XEvent *e; +{ + SCM w; + XEvent *ec; + + ec = (XEvent *) must_malloc(sizeof(XEvent), "X event"); + (void)memcpy(ec, e, sizeof(XEvent)); + NEWCELL(w); + DEFER_INTS; + CAR(w) = tc16_xevent; + SETCDR(w,ec); + ALLOW_INTS; + return w; +} +sizet x_free_xevent(ptr) + CELLPTR ptr; +{ + must_free(CHARS(ptr), sizeof(XEvent)); + return sizeof(XEvent); +} + +/* Utility macro and functions for checking and coercing SCM arguments. */ + +#define GET_NEXT_INT(result, args, err, rtn) \ + ASSERT(NIMP(args) && CONSP(args) && INUMP(CAR(args)), args, err, rtn); \ + result = INUM(CAR(args)); \ + args = CDR(args); + +void scm2XPoint(signp, dat, ipr, pos, s_caller) + int signp; + SCM dat; + XPoint *ipr; + char *pos, *s_caller; +{ + SCM x, y; + if IMP(dat) badarg: wta(dat, pos, s_caller); + if CONSP(dat) { + if INUMP(CDR(dat)) { + x = CAR(dat); + y = CDR(dat); + } + else { + ASRTGO(2==ilength(dat), badarg); + x = CAR(dat); + y = CAR(CDR(dat)); + } + } + else switch TYP7(dat) { + default: goto badarg; + case tc7_vector: + ASRTGO(2==LENGTH(dat), badarg); + x = VELTS(dat)[0]; + y = VELTS(dat)[1]; + break; + case tc7_uvect: case tc7_ivect: + ASRTGO(2==LENGTH(dat), badarg); + x = MAKINUM(((long *)VELTS(dat))[0]); + y = MAKINUM(((long *)VELTS(dat))[1]); + break; + case tc7_svect: + ASRTGO(2==LENGTH(dat), badarg); + x = MAKINUM(((short *)VELTS(dat))[0]); + y = MAKINUM(((short *)VELTS(dat))[1]); + break; + case tc7_smob: + ASRTGO(ARRAYP(dat) && 1==ARRAY_NDIM(dat) && + 0==ARRAY_DIMS(dat)[0].lbnd && 1==ARRAY_DIMS(dat)[0].ubnd, + badarg); + x = aref(dat, MAKINUM(0)); + y = aref(dat, MAKINUM(1)); + break; + } + ASRTGO(INUMP(x) && INUMP(y), badarg); + ipr->x = INUM(x); + ipr->y = INUM(y); + ASRTGO((ipr->x==INUM(x)) && (ipr->y==INUM(y)) + && (signp ? !0 : ((x >= 0) && (y >= 0))), badarg); +} +int scm2XColor(s_dat, xclr) + SCM s_dat; + XColor *xclr; +{ + SCM dat = s_dat; + unsigned int ura[3]; + int idx; +/* if INUMP(dat) { */ +/* xclr->red = (dat>>16 & 0x00ff) * 0x0101; */ +/* xclr->green = (dat>>8 & 0x00ff) * 0x0101; */ +/* xclr->blue = (dat & 0x00ff) * 0x0101; */ +/* } */ +/* else */ + if IMP(dat) return 0; + else if (3==ilength(dat)) + for (idx = 0; idx < 3; idx++) { + SCM clr = CAR(dat); + if (!INUMP(clr)) return 0; + ura[idx] = INUM(clr); + dat = CDR(dat); + } + else if (VECTORP(dat) && (3==LENGTH(dat))) + for (idx = 0; idx < 3; idx++) { + if (!INUMP(VELTS(dat)[idx])) return 0; + ura[idx] = INUM(VELTS(dat)[idx]); + } + else return 0; + xclr->red = ura[0]; + xclr->green = ura[1]; + xclr->blue = ura[2]; + return !0; +} +int scm2xpointslen(sara, s_caller) + SCM sara; + char *s_caller; +{ + array_dim *adm; + int len; + if (!(NIMP(sara) && ARRAYP(sara) && 2==ARRAY_NDIM(sara))) return -1; + adm = ARRAY_DIMS(sara); + if (!((1==(adm[1].ubnd - adm[1].lbnd)) + && (1==adm[1].inc) + && ARRAY_CONTP(sara) + && (tc7_svect==TYP7(ARRAY_V(sara))))) return -1; + len = adm[0].ubnd - adm[0].lbnd; + if (len < 0) return 0; + return len; +} +void scm2display_screen(dat, optidx, dspscn, s_caller) + SCM dat; + SCM optidx; + struct display_screen *dspscn; + char *s_caller; +{ + ASRTGO(NIMP(dat), badarg); + if OPDISPLAYP(dat) { + dspscn->display = dat; + dspscn->dpy = XDISPLAY(dat); + if UNBNDP(optidx) dspscn->screen_number = DefaultScreen(dspscn->dpy); + else if (INUMP(optidx) && (INUM(optidx) < DISPLAY(dat)->screen_count)) + dspscn->screen_number = INUM(optidx); + else wta(optidx, (char *)ARG2, s_caller); + } + else if OPWINDOWP(dat) { + struct xs_Window *xsw = WINDOW(dat); + dspscn->display = xsw->display; + dspscn->dpy = xsw->dpy; + dspscn->screen_number = xsw->screen_number; + ASRTGO(UNBNDP(optidx), badarg); + } + else badarg: wta(dat, (char *)ARG1, s_caller); +} + +#define OpPxmpMask (0xffff | OPN | PXMP) +#define OpPxmp (tc16_xwindow | OPN | PXMP) + +SCM thevalue(obj) + SCM obj; +{ + if (NIMP(obj) && SYMBOLP(obj)) + return ceval(obj, (SCM)EOL); + else return obj; +} + +Pixmap thepxmap(obj, s_caller) + SCM obj; + char *s_caller; +{ + if (FALSEP(obj) || (INUM0==obj)) return 0L; + ASSERT(NIMP(obj) && ((OpPxmpMask & (int)CAR(obj))==OpPxmp), + obj, ARGn, s_caller); + return WINDOW(obj)->p.pm; +} +Font thefont(obj, s_caller) + SCM obj; + char *s_caller; +{ + ASSERT(NIMP(obj) && FONTP(obj), obj, ARGn, s_caller); + return FONT(obj)->font; +} +Colormap thecmap(obj, s_caller) + SCM obj; + char *s_caller; +{ + if (FALSEP(obj) || (INUM0==obj)) return 0L; + ASSERT(NIMP(obj) && COLORMAPP(obj), obj, ARGn, s_caller); + return COLORMAP(obj)->cm; +} +Cursor thecsr(obj, s_caller) + SCM obj; + char *s_caller; +{ + if (FALSEP(obj) || (INUM0==obj)) return 0L; + ASSERT(NIMP(obj) && CURSORP(obj), obj, ARGn, s_caller); + return CURSOR(obj)->cursor; +} +Bool thebool(obj, s_caller) + SCM obj; + char *s_caller; +{ + SCM val = thevalue(obj); + ASSERT(BOOL_F==val || BOOL_T==val, obj, ARGn, s_caller); + return NFALSEP(val); +} +int theint(obj, s_caller) + SCM obj; + char *s_caller; +{ + SCM val = thevalue(obj); + ASSERT(INUMP(val), obj, ARGn, s_caller); + return INUM(val); +} +int theuint(obj, s_caller) + SCM obj; + char *s_caller; +{ + SCM val = thevalue(obj); + ASSERT(INUMP(val) && (0 <= INUM(val)), obj, ARGn, s_caller); + return INUM(val); +} + +static int args2xgcvalmask(oargs) + SCM oargs; +{ + 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); + attr_mask |= attr; + len -= 1; + } + return attr_mask; +} +static int args2xgcvalues(sgc, vlu, oargs) + SCM sgc; + XGCValues *vlu; + SCM oargs; +{ + struct xs_GContext *xgc = GCONTEXT(sgc); + SCM sval, args = oargs; + int attr, len, attr_mask = 0; +/* (void)memset((char *)vlu, 0, sizeof(XGCValues)); */ + if (!(len = ilength(args))) return 0; + ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_gc); + while (len) { + ASSERT(NIMP(args), oargs, WNA, s_gc); + attr = theint(CAR(args), s_gc); args = CDR(args); + ASSERT(NIMP(args), oargs, WNA, s_gc); + sval = CAR(args); args = CDR(args); + attr_mask |= attr; + switch (attr) { + + case GCFunction: vlu->function = theint(sval, s_gc); break; + case GCPlaneMask: vlu->plane_mask = theuint(sval, s_gc); break; + case GCForeground: vlu->foreground = theuint(sval, s_gc); break; + case GCBackground: vlu->background = theuint(sval, s_gc); break; + case GCLineWidth: vlu->line_width = theint(sval, s_gc); break; + case GCLineStyle: vlu->line_style = theint(sval, s_gc); break; + case GCCapStyle: vlu->cap_style = theint(sval, s_gc); break; + case GCJoinStyle: vlu->join_style = theint(sval, s_gc); break; + case GCFillStyle: vlu->fill_style = theint(sval, s_gc); break; + case GCFillRule: vlu->fill_rule = theint(sval, s_gc); break; + case GCTile: vlu->tile = thepxmap(sval, s_gc); + xgc->tile = sval; + break; + case GCStipple: vlu->stipple = thepxmap(sval, s_gc); + xgc->stipple = sval; + break; + case GCTileStipXOrigin: vlu->ts_x_origin = theint(sval, s_gc); break; + case GCTileStipYOrigin: vlu->ts_y_origin = theint(sval, s_gc); break; + case (GCTileStipXOrigin | GCTileStipYOrigin): { + XPoint position; + scm2XPoint(!0, sval, &position, (char *)ARGn, s_gc); + vlu->ts_x_origin = position.x; + vlu->ts_y_origin = position.y; + } break; + case GCFont: vlu->font = thefont(sval, s_gc); + xgc->font = sval; + break; + case GCSubwindowMode: vlu->subwindow_mode = theint(sval, s_gc); break; + case GCGraphicsExposures: vlu->graphics_exposures = thebool(sval, s_gc); break; + case GCClipXOrigin: vlu->clip_x_origin = theint(sval, s_gc); break; + case GCClipYOrigin: vlu->clip_y_origin = theint(sval, s_gc); break; + case (GCClipXOrigin | GCClipYOrigin): { + XPoint position; + scm2XPoint(!0, sval, &position, (char *)ARGn, s_gc); + vlu->clip_x_origin = position.x; + vlu->clip_y_origin = position.y; + } break; + case GCClipMask: vlu->clip_mask = thepxmap(sval, s_gc); + xgc->clipmask = sval; + break; + case GCDashOffset: vlu->dash_offset = theint(sval, s_gc); break; + case GCDashList: vlu->dashes = (char)theint(sval, s_gc); break; + case GCArcMode: vlu->arc_mode = theint(sval, s_gc); break; + + default: ASSERT(0, MAKINUM(attr), ARGn, s_gc); + } + len -= 2; + } + return attr_mask; +} +static int args2winattribs(vlu, oargs) + XSetWindowAttributes *vlu; + SCM oargs; +{ + SCM sval, args = oargs; + int attr, len, attr_mask = 0; + /* (void)memset((char *)vlu, 0, sizeof(XSetWindowAttributes)); */ + if (!(len = ilength(args))) return 0; + ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_window); + while (len) { + ASSERT(NIMP(args), oargs, WNA, s_window); + attr = theint(CAR(args), s_window); args = CDR(args); + ASSERT(NIMP(args), oargs, WNA, s_window); + sval = CAR(args); args = CDR(args); + attr_mask |= attr; + switch (attr) { + + case CWBackPixmap: vlu->background_pixmap=thepxmap(sval, s_window); break; + case CWBackPixel: vlu->background_pixel = theuint(sval, s_window); break; + case CWBorderPixmap:vlu->border_pixmap =thepxmap(sval, s_window); break; + case CWBorderPixel: vlu->border_pixel = theuint(sval, s_window); break; + case CWBitGravity: vlu->bit_gravity = theint(sval, s_window); break; + case CWWinGravity: vlu->win_gravity = theint(sval, s_window); break; + case CWBackingStore:vlu->backing_store = theint(sval, s_window); break; + case CWBackingPlanes:vlu->backing_planes = theuint(sval, s_window); break; + case CWBackingPixel:vlu->backing_pixel = theuint(sval, s_window); break; + case CWOverrideRedirect:vlu->override_redirect = + thebool(sval, s_window); break; + case CWSaveUnder: vlu->save_under = thebool(sval, s_window); break; + case CWEventMask: vlu->event_mask = theint(sval, s_window); break; + case CWDontPropagate:vlu->do_not_propagate_mask = + thebool(sval, s_window); break; + case CWColormap: vlu->colormap = thecmap(sval, s_window); break; + case CWCursor: vlu->cursor = thecsr(sval, s_window); break; + + default: ASSERT(0, MAKINUM(attr), ARGn, s_window); + } + len -= 2; + } + return attr_mask; +} + + /* Scheme-visible procedures */ + +SCM x_open_display(dpy_name) + SCM dpy_name; +{ + Display *display; + if FALSEP(dpy_name) dpy_name = nullstr; + ASSERT(NIMP(dpy_name) && STRINGP(dpy_name), dpy_name, ARG1, s_x_open_display); + display = XOpenDisplay(CHARS(dpy_name)); + return (display ? make_xdisplay(display) : BOOL_F); +} +SCM x_display_debug(sd, si) + SCM sd, si; +{ + int (*previous_after_function)(); + struct display_screen dspscn; + scm2display_screen(sd, UNDEFINED, &dspscn, s_x_display_debug); + previous_after_function = + XSynchronize(dspscn.dpy, thebool(si, s_x_display_debug)); + return UNSPECIFIED; +} +SCM x_default_screen(sdpy) + SCM sdpy; +{ + ASSERT(NIMP(sdpy) && OPDISPLAYP(sdpy), sdpy, ARG1, s_x_default_screen); + return MAKINUM(DefaultScreen(XDISPLAY(sdpy))); +} + +SCM x_create_window(swin, spos, sargs) + SCM swin, spos, sargs; +{ + XPoint position, size; + unsigned int border_width; + Window window; + int len = ilength(sargs); + + ASSERT(NIMP(swin) && OPWINDOWP(swin), swin, ARG1, s_x_create_window); + scm2XPoint(!0, spos, &position, (char *)ARG2, s_x_create_window); + scm2XPoint(0, CAR(sargs), &size, (char *)ARG3, s_x_create_window); + sargs = CDR(sargs); + GET_NEXT_INT(border_width, sargs, ARG4, s_x_create_window); + if (4==len) { + unsigned long border; + unsigned long background; + GET_NEXT_INT(border, sargs, ARG5, s_x_create_window); + GET_NEXT_INT(background, sargs, ARGn, s_x_create_window); + window = XCreateSimpleWindow(XWINDISPLAY(swin), XWINDOW(swin), + position.x, position.y, /* initial placement */ + size.x, size.y, + border_width, + border, background); /* pixel values */ + } else { + int depth; + unsigned int class; + SCM svis; + unsigned long valuemask; + XSetWindowAttributes attributes; + ASSERT(5 <= len, sargs, WNA, s_x_create_window); + GET_NEXT_INT(depth, sargs, ARG5, s_x_create_window); + GET_NEXT_INT(class, sargs, ARGn, s_x_create_window); + svis = CAR(sargs); sargs = CDR(sargs); + ASSERT(NIMP(svis) && VISUALP(svis), svis, ARGn, s_x_create_window); + valuemask = args2winattribs(&attributes, sargs); + window = XCreateWindow(XWINDISPLAY(swin), XWINDOW(swin), + position.x, position.y, /* initial placement */ + size.x, size.y, + border_width, + depth, + class, + XVISUAL(svis), + valuemask, + &attributes); + } + return window ? make_xwindow(WINDOW(swin)->display, + WINDOW(swin)->screen_number, + window, (char) 0, (char) 0) + : BOOL_F; +} +SCM x_create_pixmap(obj, s_size, s_depth) + SCM obj, s_size, s_depth; +{ + unsigned int depth = INUM(s_depth); + SCM display; + Display *dpy; + int scn; + Drawable drawable; + Pixmap p; + XPoint size; + if IMP(obj) badarg1: wta(obj, (char *)ARG1, s_x_create_pixmap); + if OPDISPLAYP(obj) { + display = obj; + dpy = XDISPLAY(display); + scn = DefaultScreen(dpy); + drawable = RootWindow(dpy, scn); + } + else if OPWINDOWP(obj) { + display = WINDOW(obj)->display; + dpy = XDISPLAY(display); + scn = WINDOW(obj)->screen_number; + drawable = WINDOW(obj)->p.drbl; + } + else goto badarg1; + scm2XPoint(0, s_size, &size, (char *)ARG2, s_x_create_pixmap); + ASSERT(INUMP(s_depth) && depth >= 0, s_depth, ARG3, s_x_create_pixmap); + p = XCreatePixmap(dpy, drawable, size.x, size.y, depth); + return make_xwindow(display, scn, p, (char) 1, (char) 0); +} +SCM x_window_set(args) + SCM args; +{ + SCM swn; + struct xs_Window *xwn; + XSetWindowAttributes vlu; + unsigned long mask; + + ASSERT(NIMP(args), args, WNA, s_x_window_set); + swn = CAR(args); args = CDR(args); + ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_set); + xwn = WINDOW(swn); + mask = args2winattribs(&vlu, args); + XChangeWindowAttributes(xwn->dpy, xwn->p.win, mask, &vlu); + return UNSPECIFIED; +} + +SCM x_window_geometry(swin) + SCM swin; +{ + struct xs_Window *sxw; + Window root; + Status sts; + int x, y; + unsigned int w, h, border_width, depth; + + ASSERT(NIMP(swin) && OPWINDOWP(swin), swin, ARG1, s_x_window_geometry); + sxw = WINDOW(swin); + sts = XGetGeometry(sxw->dpy, sxw->p.drbl, &root, &x, &y, + &w, &h, &border_width, &depth); + if (!sts) return BOOL_F; + return cons2(cons2(MAKINUM(x), MAKINUM(y), EOL), + cons2(MAKINUM(w), MAKINUM(h), EOL), + cons2(MAKINUM(border_width), MAKINUM(depth), EOL)); +} + +SCM x_close(obj) + SCM obj; +{ + ASSERT(NIMP(obj), obj, ARG1, s_x_close); + if WINDOWP(obj) { + Display *dpy; + ASSERT(!(CAR((SCM)obj) & SCROOT), obj, ARG1, s_x_close); + if CLOSEDP(obj) return UNSPECIFIED; + DEFER_INTS; + dpy = XWINDISPLAY(obj); + free_xwindow((CELLPTR)obj); + XFlush(dpy); + ALLOW_INTS; + } else { + ASSERT(DISPLAYP(obj), obj, ARG1, s_x_close); + DEFER_INTS; + free_xdisplay((CELLPTR)obj); + ALLOW_INTS; + } + return UNSPECIFIED; +} +SCM x_flush(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + if (NIMP(sd) && UNBNDP(si) && GCONTEXTP(sd)) { + dspscn.dpy = XGCONDISPLAY(sd); + XFlushGC(dspscn.dpy, XGCONTEXT(sd)); + } else { + scm2display_screen(sd, si, &dspscn, s_x_flush); + XFlush(dspscn.dpy); + } + return UNSPECIFIED; +} + /* Colormaps */ + +SCM x_create_colormap(swin, s_vis, s_alloc) + SCM swin, s_vis, s_alloc; +{ + SCM alloc; + int allo; + struct xs_Window *sxw; + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_create_colormap); + sxw = WINDOW(swin); + ASSERT(NIMP(s_vis) && VISUALP(s_vis), s_vis, ARG2, s_x_create_colormap); + alloc = thevalue(s_alloc); + allo = INUM(alloc); + ASSERT(INUMP(alloc) && (allo==AllocNone || allo==AllocAll), + s_alloc, ARG3, s_x_create_colormap); + return make_xcolormap(sxw->display, + XCreateColormap(sxw->dpy, sxw->p.win, + XVISUAL(s_vis), allo)); +} +SCM x_recreate_colormap(s_cm) + SCM s_cm; +{ + struct xs_Colormap *sxw; + ASSERT(NIMP(s_cm) && COLORMAPP(s_cm), s_cm, ARG1, s_x_recreate_colormap); + sxw = COLORMAP(s_cm); + return make_xcolormap(sxw->display, + XCopyColormapAndFree(XDISPLAY(sxw->display), sxw->cm)); +} +SCM x_install_colormap(s_cm, s_flg) + SCM s_cm, s_flg; +{ + struct xs_Colormap *xcm; + ASSERT(NIMP(s_cm) && COLORMAPP(s_cm), s_cm, ARG1, s_x_install_colormap); + if UNBNDP(s_flg) s_flg = BOOL_T; + xcm = COLORMAP(s_cm); + if FALSEP(s_flg) XUninstallColormap(XDISPLAY(xcm->display), xcm->cm); + XInstallColormap(XDISPLAY(xcm->display), xcm->cm); + return UNSPECIFIED; +} + /* Colors in Colormap */ + +SCM x_alloc_color_cells(scmap, spxls, sargs) + SCM scmap, spxls, sargs; +{ + XColor xclr; + Status sts; + struct xs_Colormap *xcm; + Bool contig = 0; + SCM pxra, plra; + unsigned int npixels, nplanes; + ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_alloc_color_cells); + xcm = COLORMAP(scmap); + npixels = INUM(spxls); + ASSERT(INUMP(spxls) && npixels > 0, spxls, ARG2, s_x_alloc_color_cells); + pxra = make_uve(npixels, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */ + switch (ilength(sargs) + 2) { + default: wta(sargs, (char *)WNA, s_x_alloc_color_cells); + case 3: case 4: + if (scm2XColor(CAR(sargs), &xclr)) { + unsigned long rmask_return, gmask_return, bmask_return; + sargs = CDR(sargs); + if NNULLP(sargs) contig = thebool(CAR(sargs), s_x_alloc_color_cells); + sts = XAllocColorPlanes(xcm->dpy, xcm->cm, contig, + VELTS(pxra), npixels, + xclr.red, xclr.green, xclr.blue, + &rmask_return, &gmask_return, &bmask_return); + if (!sts) return BOOL_F; + return cons2(pxra, MAKINUM(rmask_return), + cons2(MAKINUM(gmask_return), + MAKINUM(bmask_return), EOL)); + } + nplanes = theuint(CAR(sargs), s_x_alloc_color_cells); + sargs = CDR(sargs); + if NNULLP(sargs) contig = thebool(CAR(sargs), s_x_alloc_color_cells); + plra = make_uve(nplanes, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */ + sts = XAllocColorCells(xcm->dpy, xcm->cm, contig, + VELTS(plra), nplanes, VELTS(pxra), npixels); + if (!sts) return BOOL_F; + return cons2(pxra, plra, EOL); + } +} +SCM x_free_color_cells(scmap, spxls, sargs) + SCM scmap, spxls, sargs; +{ + struct xs_Colormap *xcm; + unsigned int planes = 0; + ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_free_color_cells); + xcm = COLORMAP(scmap); + ASSERT(NIMP(spxls) && (TYP7(spxls)==tc7_uvect), spxls, ARG2, + s_x_free_color_cells); + switch (ilength(sargs) + 2) { + default: wta(sargs, (char *)WNA, s_x_free_color_cells); + case 4: + planes = theuint(CAR(sargs), s_x_free_color_cells); + case 3: + XFreeColors(xcm->dpy, xcm->cm, VELTS(spxls), INUM(spxls), planes); + return UNSPECIFIED; + } +} + +SCM x_find_color(scmap, dat) + SCM scmap, dat; +{ + XColor xclr; + struct xs_Colormap *xcm; + (void)memset((char *)&xclr, 0, sizeof(xclr)); + ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_find_color); + xcm = COLORMAP(scmap); + if (!scm2XColor(dat, &xclr)) { + ASSERT(NIMP(dat) && STRINGP(dat), dat, (char*)ARG2, s_x_find_color); + if (XAllocNamedColor(xcm->dpy, xcm->cm, CHARS(dat), &xclr, &xclr)) + return MAKINUM(xclr.pixel); + else return BOOL_F; + } + if (XAllocColor(xcm->dpy, xcm->cm, &xclr)) + return MAKINUM(xclr.pixel); + else return BOOL_F; +} +SCM x_color_set(scmap, s_pix, dat) + SCM scmap, s_pix, dat; +{ + XColor xclr; + struct xs_Colormap *xcm; + (void)memset((char *)&xclr, 0, sizeof(xclr)); + ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_color_set); + ASSERT(INUMP(s_pix), s_pix, ARG2, s_x_color_set); + xcm = COLORMAP(scmap); + xclr.pixel = INUM(s_pix); + xclr.flags = DoRed | DoGreen | DoBlue; + if (!scm2XColor(dat, &xclr)) { + ASSERT(NIMP(dat) && STRINGP(dat), dat, (char*)ARG3, s_x_color_set); + XStoreNamedColor(xcm->dpy, xcm->cm, CHARS(dat), xclr.pixel, xclr.flags); + } + else XStoreColor(xcm->dpy, xcm->cm, &xclr); + return UNSPECIFIED; +} +SCM x_color_ref(scmap, sidx) + SCM scmap, sidx; +{ + XColor xclr; + struct xs_Colormap *xcm; + (void)memset((char *)&xclr, 0, sizeof(xclr)); + ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_color_ref); + xcm = COLORMAP(scmap); + ASSERT(INUMP(sidx), sidx, (char*)ARG2, s_x_color_ref); + xclr.pixel = INUM(sidx); + XQueryColor(xcm->dpy, xcm->cm, &xclr); + if (xclr.flags==(DoRed | DoGreen | DoBlue)) + return cons2(MAKINUM(xclr.red), MAKINUM(xclr.green), + cons(MAKINUM(xclr.blue), EOL)); + else return BOOL_F; +} + + /* Window Mapping */ + +SCM x_map_window(swin) + SCM swin; +{ + struct xs_Window *w; + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window); + w = 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; +{ + struct xs_Window *w; + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_subwindows); + w = WINDOW(swin); + XMapSubwindows(w->dpy, w->p.win); + return UNSPECIFIED; +} +SCM x_unmap_window(swin) + SCM swin; +{ + struct xs_Window *w; + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_unmap_window); + w = WINDOW(swin); + XUnmapWindow(w->dpy, w->p.win); + return UNSPECIFIED; +} +SCM x_unmap_subwindows(swin) + SCM swin; +{ + struct xs_Window *w; + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_unmap_subwindows); + w = WINDOW(swin); + XUnmapSubwindows(w->dpy, w->p.win); + return UNSPECIFIED; +} + +SCM x_create_gc(args) + SCM args; +{ + SCM swin; + struct xs_Window *xsw; + struct xs_GContext *xgc; + XGCValues v; + unsigned long mask; + SCM ans; + + ASSERT(NIMP(args), args, WNA, s_x_create_gc); + swin = CAR(args); args = CDR(args); + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_create_gc); + xsw = WINDOW(swin); + ans = make_xgcontext(xsw->display, xsw->screen_number, + XCreateGC(xsw->dpy, xsw->p.drbl, 0L, &v), 0); + xgc = GCONTEXT(ans); + mask = args2xgcvalues(ans, &v, args); + XChangeGC(xgc->dpy, xgc->gc, mask, &v); + return ans; +} +SCM x_gc_set(args) + SCM args; +{ + SCM sgc; + struct xs_GContext *xgc; + XGCValues v; + unsigned long mask; + + ASSERT(NIMP(args), args, WNA, s_x_gc_set); + sgc = CAR(args); args = CDR(args); + ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG1, s_x_gc_set); + xgc = GCONTEXT(sgc); + mask = args2xgcvalues(sgc, &v, args); + XChangeGC(xgc->dpy, xgc->gc, mask, &v); + return UNSPECIFIED; +} +SCM x_copy_gc(dst, src, args) + SCM dst; + SCM src; + SCM args; +{ + struct xs_GContext *dgc, *sgc; + unsigned long mask; + + ASSERT(NIMP(dst) && GCONTEXTP(dst), dst, ARG1, s_x_copy_gc); + ASSERT(NIMP(src) && GCONTEXTP(src), src, ARG2, s_x_copy_gc); + dgc = GCONTEXT(dst); + sgc = GCONTEXT(src); + mask = args2xgcvalmask(args); + XCopyGC(dgc->dpy, sgc->gc, mask, dgc->gc); + return UNSPECIFIED; +} +SCM x_gc_ref(oargs) + SCM oargs; +{ + SCM sgc, args = oargs, sval = BOOL_F; + SCM vals = cons(BOOL_T, EOL), valend = vals; + struct xs_GContext *xgc; + unsigned long valuemask; + XGCValues vlu; + int attr, len = ilength(args); +/* (void)memset((char *)&vlu, 0, sizeof(XGCValues)); */ + ASSERT(len > 0, oargs, WNA, s_x_gc_ref); + if (1==len--) return EOL; + sgc = CAR(args); args = CDR(args); + xgc = GCONTEXT(sgc); + valuemask = args2xgcvalmask(args); +/* printf("valuemask = %lx\n", valuemask); */ + valuemask &= (GCFunction | GCPlaneMask | GCForeground | GCBackground | + GCLineWidth | GCLineStyle | GCCapStyle | GCJoinStyle | + GCFillStyle | GCFillRule | + GCTileStipXOrigin | GCTileStipYOrigin | + GCSubwindowMode | GCGraphicsExposures | + GCClipXOrigin | GCClipYOrigin | GCDashOffset | GCArcMode); + if (!XGetGCValues(xgc->dpy, xgc->gc, valuemask, &vlu)) return BOOL_F; + while (len) { + attr = theint(CAR(args), s_gc); args = CDR(args); + switch (attr) { + + case GCFunction: sval = MAKINUM(vlu.function ); break; + case GCPlaneMask: sval = MAKINUM(vlu.plane_mask); break; + case GCForeground: sval = MAKINUM(vlu.foreground); break; + case GCBackground: sval = MAKINUM(vlu.background); break; + case GCLineWidth: sval = MAKINUM(vlu.line_width); break; + case GCLineStyle: sval = MAKINUM(vlu.line_style); break; + case GCCapStyle: sval = MAKINUM(vlu.cap_style ); break; + case GCJoinStyle: sval = MAKINUM(vlu.join_style); break; + case GCFillStyle: sval = MAKINUM(vlu.fill_style); break; + case GCFillRule: sval = MAKINUM(vlu.fill_rule ); break; + case GCTile: sval = xgc->tile; break; + case GCStipple: sval = xgc->stipple; break; + case GCTileStipXOrigin: sval = MAKINUM(vlu.ts_x_origin); break; + case GCTileStipYOrigin: sval = MAKINUM(vlu.ts_y_origin); break; + case (GCTileStipXOrigin | GCTileStipYOrigin): + sval = cons2(MAKINUM(vlu.ts_x_origin), MAKINUM(vlu.ts_y_origin), EOL); + break; + case GCFont: sval = xgc->font; break; + case GCSubwindowMode: sval = MAKINUM(vlu.subwindow_mode); break; + case GCGraphicsExposures: + sval = x_make_bool(vlu.graphics_exposures); break; + case GCClipXOrigin: sval = MAKINUM(vlu.clip_x_origin); break; + case GCClipYOrigin: sval = MAKINUM(vlu.clip_y_origin); break; + case (GCClipXOrigin | GCClipYOrigin): + sval = cons2(MAKINUM(vlu.clip_x_origin), + MAKINUM(vlu.clip_y_origin), EOL); + break; + case GCClipMask: sval = xgc->clipmask; break; + case GCDashOffset: sval = MAKINUM(vlu.dash_offset); break; + case GCDashList: sval = MAKINUM(vlu.dashes); break; + case GCArcMode: sval = MAKINUM(vlu.arc_mode); break; + + default: ASSERT(0, MAKINUM(attr), ARGn, s_x_gc_ref); + } + CAR(valend) = sval; + CDR(valend) = cons(BOOL_T, EOL); + valend = CDR(valend); + len -= 1; + } + return vals; +} + +SCM x_create_cursor(sdpy, scsr, sargs) + SCM sdpy, scsr, sargs; +{ + Cursor cursor; + + switch (ilength(sargs)) { + default: ASSERT(0, sargs, WNA, s_x_create_cursor); + case 0: { + SCM shape; + ASSERT(NIMP(sdpy) && DISPLAYP(sdpy), sdpy, ARG1, s_x_create_cursor); + shape = thevalue(scsr); + ASSERT(INUMP(shape) && 0 <= INUM(shape), scsr, ARG2, s_x_create_cursor); + cursor = XCreateFontCursor(XDISPLAY(sdpy), INUM(shape)); + return make_xcursor(sdpy, cursor); + } + case 3: { + XColor foreground_color, background_color; + XPoint origin; + int sts; + ASSERT(NIMP(sdpy) && WINDOWP(sdpy), sdpy, ARG1, s_x_create_cursor); + ASSERT(FALSEP(scsr) || (NIMP(scsr) && WINDOWP(scsr)), scsr, ARG2, + s_x_create_cursor); + sts = scm2XColor(CAR(sargs), &foreground_color); + ASSERT(sts, CAR(sargs), ARG3, s_x_create_cursor); + sargs = CDR(sargs); + sts = scm2XColor(CAR(sargs), &background_color); + ASSERT(sts, CAR(sargs), ARG4, s_x_create_cursor); + sargs = CDR(sargs); + scm2XPoint(0, CAR(sargs), &origin, (char*)ARG5, s_x_create_cursor); + cursor = XCreatePixmapCursor(XWINDISPLAY(sdpy), XWINDOW(sdpy), + FALSEP(scsr) ? 0L : XWINDOW(scsr), + &foreground_color, &background_color, + origin.x, origin.y); + return make_xcursor(WINDOW(sdpy)->display, cursor); + } + case 4: { + XColor foreground_color, background_color; + Font source_font, mask_font = 0; + unsigned int source_char, mask_char = 0; + int sts; + source_font = thefont(sdpy, s_x_create_cursor); + GET_NEXT_INT(source_char, sargs, ARG2, s_x_create_cursor); + if FALSEP(CAR(sargs)) { + sargs = CDR(sargs); + ASSERT(FALSEP(CAR(sargs)), sargs, ARG4, s_x_create_cursor); + sargs = CDR(sargs); + } else { + mask_font = thefont(CAR(sargs), s_x_create_cursor); + sargs = CDR(sargs); + GET_NEXT_INT(mask_char, sargs, ARG4, s_x_create_cursor); + } + sts = scm2XColor(CAR(sargs), &foreground_color); + ASSERT(sts, CAR(sargs), ARG5, s_x_create_cursor); + sargs = CDR(sargs); + sts = scm2XColor(CAR(sargs), &background_color); + ASSERT(sts, CAR(sargs), ARGn, s_x_create_cursor); + cursor = XCreateGlyphCursor(XWINDISPLAY(sdpy), + source_font, mask_font, source_char, mask_char, + &foreground_color, &background_color); + return make_xcursor(FONT(sdpy)->display, cursor); + }} +} + +SCM x_load_font(sdpy, fntnam) + SCM sdpy, fntnam; +{ + Font font; + + ASSERT(NIMP(sdpy) && DISPLAYP(sdpy), sdpy, ARG1, s_x_load_font); + ASSERT(NIMP(fntnam) && STRINGP(fntnam), fntnam, ARG2, s_x_load_font); + font = XLoadFont(XDISPLAY(sdpy), CHARS(fntnam)); + return make_xfont(sdpy, font, fntnam); +} + + /* Xlib information functions. */ + +SCM x_protocol_version(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_protocol_version); + return cons(MAKINUM(ProtocolVersion(dspscn.dpy)), + MAKINUM(ProtocolRevision(dspscn.dpy))); +} +SCM x_server_vendor(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_server_vendor); + return makfrom0str(ServerVendor(dspscn.dpy)); +} +SCM x_vendor_release(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_vendor_release); + return MAKINUM(VendorRelease(dspscn.dpy)); +} +int x_scm_error_handler(display, xee) + Display *display; + XErrorEvent *xee; +{ + char buffer_return[1024]; + fflush(stdout); + XGetErrorText(display, xee->error_code, buffer_return, sizeof buffer_return); + *loc_errobj = MAKINUM((xee->request_code<<8) + xee->minor_code); + fputs(buffer_return, stderr); + fputc('\n', stderr); + fflush(stderr); + return 0; +} +SCM x_q_length(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_q_length); + return MAKINUM(QLength(dspscn.dpy)); +} +SCM x_pending(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_pending); + return MAKINUM(XPending(dspscn.dpy)); +} +SCM x_events_queued(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_events_queued); + return MAKINUM(XEventsQueued(dspscn.dpy, QueuedAfterReading)); +} +SCM x_next_event(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + XEvent event_return; + scm2display_screen(sd, si, &dspscn, s_x_next_event); + XNextEvent(dspscn.dpy, &event_return); + return make_xevent(&event_return); +} +SCM x_peek_event(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + XEvent event_return; + scm2display_screen(sd, si, &dspscn, s_x_peek_event); + XPeekEvent(dspscn.dpy, &event_return); + return make_xevent(&event_return); +} + /* Screen information functions */ + +SCM x_screen_count(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_screen_count); + return MAKINUM(ScreenCount(dspscn.dpy)); +} +SCM x_screen_cells(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_screen_cells); + return MAKINUM(DisplayCells(dspscn.dpy, dspscn.screen_number)); +} +SCM x_screen_depth(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_screen_depth); + return MAKINUM(DisplayPlanes(dspscn.dpy, dspscn.screen_number)); +} +SCM x_screen_depths(sd, si) + SCM sd, si; +{ + int count_return = 0; + int *depths; + SCM depra; + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_screen_depths); + depths = XListDepths(dspscn.dpy, dspscn.screen_number, &count_return); + if (!depths) return BOOL_F; + depra = make_uve(count_return, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */ + for (;count_return--;) VELTS(depra)[count_return] = depths[count_return]; + XFree(depths); + return depra; +} +SCM x_screen_size(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_screen_size); + return cons2(MAKINUM(DisplayWidth(dspscn.dpy, dspscn.screen_number)), + MAKINUM(DisplayHeight(dspscn.dpy, dspscn.screen_number)), + EOL); +} +SCM x_screen_dimm(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + scm2display_screen(sd, si, &dspscn, s_x_screen_dimm); + return cons2(MAKINUM(DisplayWidthMM(dspscn.dpy, dspscn.screen_number)), + MAKINUM(DisplayHeightMM(dspscn.dpy, dspscn.screen_number)), + EOL); +} +SCM x_screen_black(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + Screen *scn; + scm2display_screen(sd, si, &dspscn, s_x_screen_black); + scn = ScreenOfDisplay(dspscn.dpy, dspscn.screen_number); + return ulong2num(BlackPixelOfScreen(scn)); +} +SCM x_screen_white(sd, si) + SCM sd, si; +{ + struct display_screen dspscn; + Screen *scn; + scm2display_screen(sd, si, &dspscn, s_x_screen_white); + scn = ScreenOfDisplay(dspscn.dpy, dspscn.screen_number); + return ulong2num(WhitePixelOfScreen(scn)); +} + +SCM x_make_visual(sd, sdepth, sclass) + SCM sd, sdepth, sclass; +{ + struct display_screen dspscn; + XVisualInfo vis; + Status sts; + 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); +} +SCM x_root_window(sdpy, sscr) + SCM sdpy, sscr; +{ + struct display_screen dspscn; + struct xs_Display *xsd; + struct xs_screen *scrns; + scm2display_screen(sdpy, sscr, &dspscn, s_x_root_window); + xsd = DISPLAY(dspscn.display); + scrns = (struct xs_screen *)(xsd + 1); + return scrns[dspscn.screen_number].root_window; +} +SCM x_default_colormap(sdpy, sscr) + SCM sdpy, sscr; +{ + struct display_screen dspscn; + struct xs_Display *xsd; + struct xs_screen *scrns; + scm2display_screen(sdpy, sscr, &dspscn, s_x_default_colormap); + xsd = DISPLAY(dspscn.display); + scrns = (struct xs_screen *)(xsd + 1); + return scrns[dspscn.screen_number].default_colormap; +} +SCM x_default_gcontext(sdpy, sscr) + SCM sdpy, sscr; +{ + struct display_screen dspscn; + struct xs_Display *xsd; + struct xs_screen *scrns; + scm2display_screen(sdpy, sscr, &dspscn, s_x_default_gcontext); + xsd = DISPLAY(dspscn.display); + scrns = (struct xs_screen *)(xsd + 1); + return scrns[dspscn.screen_number].default_gcontext; +} +SCM x_default_visual(sdpy, sscr) + SCM sdpy, sscr; +{ + struct display_screen dspscn; + struct xs_Display *xsd; + struct xs_screen *scrns; + scm2display_screen(sdpy, sscr, &dspscn, s_x_default_visual); + xsd = DISPLAY(dspscn.display); + scrns = (struct xs_screen *)(xsd + 1); + return scrns[dspscn.screen_number].default_visual; +} + + /* Rendering */ + +SCM x_clear_area(swin, spos, sargs) + SCM swin, spos, sargs; +{ + XPoint position, size; + ASSERT(2==ilength(sargs), sargs, WNA, s_x_clear_area); + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_clear_area); + scm2XPoint(!0, spos, &position, (char *)ARG2, s_x_clear_area); + scm2XPoint(0, CAR(sargs), &size, (char *)ARG3, s_x_clear_area); + sargs = CDR(sargs); + XClearArea(XWINDISPLAY(swin), XWINDOW(swin), + position.x, position.y, size.x, size.y, + NFALSEP(CAR(sargs))); + return UNSPECIFIED; +} +SCM x_fill_rectangle(swin, sgc, sargs) + SCM swin, sgc, sargs; +{ + XPoint position, size; + ASSERT(2==ilength(sargs), sargs, WNA, s_x_fill_rectangle); + ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_fill_rectangle); + ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_x_fill_rectangle); + scm2XPoint(!0, CAR(sargs), &position, (char *)ARG3, s_x_fill_rectangle); + sargs = CDR(sargs); + scm2XPoint(0, CAR(sargs), &size, (char *)ARG4, s_x_fill_rectangle); + XFillRectangle(XWINDISPLAY(swin), XWINDOW(swin), XGCONTEXT(sgc), + position.x, position.y, size.x, size.y); + return UNSPECIFIED; +} + +void xldraw_string(sdbl, sgc, sargs, proc, s_caller) + SCM sdbl, sgc, sargs; + int (*proc)(); + char *s_caller; +{ + XPoint position; + ASSERT(2==ilength(sargs), sargs, WNA, s_caller); + ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_caller); + ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_caller); + scm2XPoint(!0, CAR(sargs), &position, (char *)ARG3, s_caller); + sargs = CDR(sargs); + sargs = CAR(sargs); + ASSERT(NIMP(sargs) && STRINGP(sargs), sargs, ARG4, s_caller); + proc(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc), + position.x, position.y, CHARS(sargs), LENGTH(sargs)); +} +SCM x_draw_string(sdbl, sgc, sargs) + SCM sdbl, sgc, sargs; +{ + xldraw_string(sdbl, sgc, sargs, &XDrawString, s_x_draw_string); + return UNSPECIFIED; +} +SCM x_image_string(sdbl, sgc, sargs) + SCM sdbl, sgc, sargs; +{ + xldraw_string(sdbl, sgc, sargs, &XDrawImageString, s_x_image_string); + return UNSPECIFIED; +} + +SCM x_draw_points(sdbl, sgc, sargs) + SCM sdbl, sgc, sargs; +{ + XPoint pos[1]; + int len; + SCM sarg; + ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_x_draw_points); + ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_x_draw_points); + loop: + if NULLP(sargs) return UNSPECIFIED; + sarg = CAR(sargs); sargs = CDR(sargs); + if (INUMP(sarg)) { + ASSERT(NNULLP(sargs), sargs, WNA, s_x_draw_points); + pos[0].x = INUM(sarg); + GET_NEXT_INT(pos[0].y, sargs, ARGn, s_x_draw_points); + goto drawshort; + } + len = scm2xpointslen(sarg, s_x_draw_points); + if (len < 0) { + scm2XPoint(!0, sarg, &(pos[0]), (char *)ARG3, s_x_draw_points); + drawshort: + XDrawPoints(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc), + &(pos[0]), 1, CoordModeOrigin); + goto loop; + } else { + ASSERT(NULLP(sargs), sargs, WNA, s_x_draw_points); + XDrawPoints(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc), + (XPoint *)scm_base_addr(sarg, s_x_draw_points), len, + CoordModeOrigin); + return UNSPECIFIED; + } +} +SCM xldraw_lines(sdbl, sgc, sargs, funcod, s_caller) + SCM sdbl, sgc, sargs; + int funcod; + char *s_caller; +{ + XPoint pos[2]; + int len; + SCM sarg; + ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_caller); + ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_caller); + loop: + if NULLP(sargs) return UNSPECIFIED; + sarg = CAR(sargs); sargs = CDR(sargs); + if (INUMP(sarg)) { + ASSERT(NNULLP(sargs), sargs, WNA, s_caller); + pos[0].x = INUM(sarg); + GET_NEXT_INT(pos[0].y, sargs, ARGn, s_caller); + GET_NEXT_INT(pos[1].x, sargs, ARGn, s_caller); + GET_NEXT_INT(pos[1].y, sargs, ARGn, s_caller); + goto drawshort; + } + len = scm2xpointslen(sarg, s_caller); + if (len < 0) { + scm2XPoint(!0, sarg, &(pos[0]), (char *)ARG3, s_caller); + scm2XPoint(!0, sarg, &(pos[1]), (char *)ARG4, s_caller); + drawshort: + switch (funcod) { + default: wna: wta(sargs, (char *)WNA, s_caller); + case 0: + XDrawSegments(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc), + (XSegment *) &(pos[0]), 1); + goto loop; + case 1: + XDrawLines(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc), + &(pos[0]), 2, CoordModeOrigin); + goto loop; + } + } else { + unsigned long rabase; + ASRTGO(NULLP(sargs), wna); + rabase = scm_base_addr(sarg, s_caller); + switch (funcod) { + default: goto wna; + case 0: + XDrawSegments(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc), + (XSegment *)rabase, len/2); + return UNSPECIFIED; + case 1: + XDrawLines(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc), + (XPoint *)rabase, len, CoordModeOrigin); + return UNSPECIFIED; + case 2: + XFillPolygon(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc), + (XPoint *)rabase, len, Complex, CoordModeOrigin); + return UNSPECIFIED; + } + } +} + +SCM x_draw_segments(sdbl, sgc, sargs) + SCM sdbl, sgc, sargs; +{ + return xldraw_lines(sdbl, sgc, sargs, 0, s_x_draw_segments); +} +SCM x_draw_lines(sdbl, sgc, sargs) + SCM sdbl, sgc, sargs; +{ + return xldraw_lines(sdbl, sgc, sargs, 1, s_x_draw_lines); +} +SCM x_fill_poly(sdbl, sgc, sargs) + SCM sdbl, sgc, sargs; +{ + return xldraw_lines(sdbl, sgc, sargs, 2, s_x_fill_poly); +} + + /* XEvents */ + +/* x_make_bool() is used in xevent.h */ +SCM x_make_bool(f) + Bool f; +{ + return f ? BOOL_F : BOOL_T; +} + +SCM x_event_ref(sevent, sfield) + SCM sevent, sfield; +{ + void *x; + ASSERT(NIMP(sevent) && XEVENTP(sevent), sevent, ARG1, s_x_event_ref); + ASSERT(INUMP(sfield), sfield, ARG2, s_x_event_ref); + x = (void *) CHARS(sevent); + switch (((((XEvent*)x)->type)<<8)+INUM(sfield)) { + default: wta(sevent, "Incompatible field for", s_x_event_ref); +#define SCM_EVENT_FIELDS +#include "xevent.h" + } +} + +static struct { + int type; + char *name; +} event_names[] = { +#undef SCM_EVENT_FIELDS +#include "xevent.h" +}; + +static char *x__event_name(type) + int type; +{ + int i; + for (i = 0; i < sizeof(event_names) / sizeof(event_names[0]); i++) + if (type==event_names[i].type) return event_names[i].name; + return "unknown"; +} + /* SMOB print routines */ + +static int print_xevent(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + lputs("#<X event: ", f); + lputs(x__event_name(XEVENT(exp)->type), f); + lputc('>', f); + return 1; +} +static int print_xdisplay(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + if CLOSEDP(exp) lputs("#<closed-X display>", f); + else { + lputs("#<X display \"", f); + lputs(DisplayString(XDISPLAY(exp)), f); + lputs("\">", f); + } + return 1; +} +static int print_xwindow(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + lputs(CLOSEDP(exp) ? "#<closed-X " : "#<X ", f); + lputs((CAR(exp) & PXMP) ? "pixmap #x" : "window #x", f); + intprint((long) XWINDOW(exp), 16, f); + lputc('>', f); + return 1; +} +static int print_xcursor(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + lputs("#<X cursor #x", f); + intprint((long) XCURSOR(exp), 16, f); + lputc('>', f); + return 1; +} +static int print_xfont(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + lputs("#<X font \"", f); + lputs(CHARS((FONT(exp))->name), f); + lputs("\">", f); + return 1; +} +static int print_xcolormap(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + lputs("#<X colormap ID #x", f); + intprint((long) XCOLORMAP(exp), 16, f); + lputc('>', f); + return 1; +} +static int print_xgcontext(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + lputs("#<X graphics context, ID #x", f); + /* intprint((long) GCONTEXT(exp)->gid, 16, f); skimu */ + intprint((long) XGContextFromGC(XGCONTEXT(exp)), 16, f); + lputc('>', f); + return 1; +} +static int print_xvisual(exp, f, writing) + SCM exp; + SCM f; + int writing; +{ + lputs("#<X visual #x", f); + intprint((long) XVisualIDFromVisual(XVISUAL(exp)), 16, f); + lputc('>', f); + return 1; +} + +static smobfuns smob_xdisplay = {mark_xdisplay, free_xdisplay, print_xdisplay, 0}; +static smobfuns smob_xwindow = {mark_xwindow, free_xwindow, print_xwindow, 0}; +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_xevent = {mark0, x_free_xevent, print_xevent, 0}; + +static iproc x_subr3s[] = { + {s_x_make_visual, x_make_visual}, + {s_x_create_pixmap, x_create_pixmap}, + {s_x_create_colormap, x_create_colormap}, + {s_x_color_set, x_color_set}, + {0, 0} +}; + +static iproc x_lsubr2s[] = { + {s_x_create_window, x_create_window}, + {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_clear_area, x_clear_area}, + {s_x_fill_rectangle, x_fill_rectangle}, + {s_x_draw_string, x_draw_string}, + {s_x_image_string, x_image_string}, + {s_x_draw_points, x_draw_points}, + {s_x_draw_segments, x_draw_segments}, + {s_x_draw_lines, x_draw_lines}, + {s_x_fill_poly, x_fill_poly}, + {0, 0} +}; + +static iproc x_lsubrs[] = { + {s_x_create_gc, x_create_gc}, + {s_x_gc_set, x_gc_set}, + {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}, */ + {0, 0} +}; + +static iproc x_subr2s[] = { + {s_x_event_ref, x_event_ref}, + {s_x_find_color, x_find_color}, + {s_x_color_ref, x_color_ref}, + {s_x_load_font, x_load_font}, + {0, 0} +}; + +static iproc x_subr2os[] = { + {s_x_display_debug, x_display_debug}, + {s_x_screen_cells, x_screen_cells}, + {s_x_screen_depth, x_screen_depth}, + {s_x_screen_depths, x_screen_depths}, + {s_x_screen_size, x_screen_size}, + {s_x_screen_dimm, x_screen_dimm}, + {s_x_screen_black, x_screen_black}, + {s_x_screen_white, x_screen_white}, + {s_x_protocol_version, x_protocol_version}, + {s_x_vendor_release, x_vendor_release}, + {s_x_server_vendor, x_server_vendor}, + {s_x_screen_count, x_screen_count}, + {s_x_events_queued, x_events_queued}, + {s_x_next_event, x_next_event}, + {s_x_peek_event, x_peek_event}, + {s_x_pending, x_pending}, + {s_x_q_length, x_q_length}, + {s_x_root_window, x_root_window}, + {s_x_default_gcontext, x_default_gcontext}, + {s_x_default_visual, x_default_visual}, + {s_x_default_colormap, x_default_colormap}, + {s_x_install_colormap, x_install_colormap}, + {s_x_flush, x_flush}, + {0, 0} +}; + +static iproc x_subr1s[] = { + {s_x_open_display, x_open_display}, + {s_x_close, x_close}, + {s_x_default_screen, x_default_screen}, + {s_x_window_geometry, x_window_geometry}, + {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}, + {0, 0} +}; + +int (*x_scm_prev_error_handler)() = 0; +void x_scm_final() +{ + if (x_scm_prev_error_handler) XSetErrorHandler(x_scm_prev_error_handler); + x_scm_prev_error_handler = 0; +} + +void init_x() +{ + init_iprocs(x_subr3s, tc7_subr_3); + init_iprocs(x_lsubr2s, tc7_lsubr_2); + init_iprocs(x_lsubrs, tc7_lsubr); + init_iprocs(x_subr2s, tc7_subr_2); + init_iprocs(x_subr2os, tc7_subr_2o); + init_iprocs(x_subr1s, tc7_subr_1); + + tc16_xdisplay = newsmob(&smob_xdisplay); + tc16_xwindow = newsmob(&smob_xwindow); + tc16_xcursor = newsmob(&smob_xcursor); + tc16_xfont = newsmob(&smob_xfont); + tc16_xcolormap = newsmob(&smob_xcolormap); + tc16_xgcontext = newsmob(&smob_xgcontext); + tc16_xvisual = newsmob(&smob_xvisual); + tc16_xevent = newsmob(&smob_xevent); + + scm_ldprog("x11.scm"); + scm_ldprog("xevent.scm"); + scm_ldstr("\ +(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\ +"); + add_feature("xlib"); + + add_final(x_scm_final); + XSetErrorHandler(x_scm_error_handler); +} @@ -0,0 +1,86 @@ +/* x.c */ +SCM make_xwindow(SCM display, int screen_number, Drawable win, int pxmp, int rootp); +SCM make_xcolormap(SCM sdpy, Colormap cmp); +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_xevent(XEvent *e); +size_t x_free_xevent(CELLPTR ptr); +void scm2XPoint(int signp, SCM dat, XPoint *ipr, char *pos, char *s_caller); +int scm2XColor(SCM s_dat, XColor *xclr); +int scm2xpointslen(SCM sara, char *s_caller); +void scm2display_screen(SCM dat, SCM optidx, struct display_screen *dspscn, char *s_caller); +SCM thevalue(SCM obj); +Pixmap thepxmap(SCM obj, char *s_caller); +Font thefont(SCM obj, char *s_caller); +Colormap thecmap(SCM obj, char *s_caller); +Cursor thecsr(SCM obj, char *s_caller); +int thebool(SCM obj, char *s_caller); +int theint(SCM obj, char *s_caller); +int theuint(SCM obj, char *s_caller); +SCM x_open_display(SCM dpy_name); +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_set(SCM args); +SCM x_window_geometry(SCM swin); +SCM x_close(SCM obj); +SCM x_flush(SCM sd, SCM si); +SCM x_create_colormap(SCM swin, SCM s_vis, SCM s_alloc); +SCM x_recreate_colormap(SCM s_cm); +SCM x_install_colormap(SCM s_cm, SCM s_flg); +SCM x_alloc_color_cells(SCM scmap, SCM spxls, SCM sargs); +SCM x_free_color_cells(SCM scmap, SCM spxls, SCM sargs); +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); +SCM x_create_gc(SCM args); +SCM x_gc_set(SCM args); +SCM x_copy_gc(SCM dst, SCM src, SCM args); +SCM x_gc_ref(SCM oargs); +SCM x_create_cursor(SCM sdpy, SCM scsr, SCM sargs); +SCM x_load_font(SCM sdpy, SCM fntnam); +SCM x_protocol_version(SCM sd, SCM si); +SCM x_server_vendor(SCM sd, SCM si); +SCM x_vendor_release(SCM sd, SCM si); +int x_scm_error_handler(Display *display, XErrorEvent *xee); +SCM x_q_length(SCM sd, SCM si); +SCM x_pending(SCM sd, SCM si); +SCM x_events_queued(SCM sd, SCM si); +SCM x_next_event(SCM sd, SCM si); +SCM x_peek_event(SCM sd, SCM si); +SCM x_screen_count(SCM sd, SCM si); +SCM x_screen_cells(SCM sd, SCM si); +SCM x_screen_depth(SCM sd, SCM si); +SCM x_screen_depths(SCM sd, SCM si); +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); +SCM x_make_visual(SCM sd, SCM sdepth, SCM sclass); +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_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); +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); +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_make_bool(int f); +SCM x_event_ref(SCM sevent, SCM sfield); +void x_scm_final(void); +void init_x(void); @@ -0,0 +1,587 @@ +;;inc2scm extracted #define values from /usr/include/X11/X.h +(define X:PROTOCOL 11) +(define X:PROTOCOL-REVISION 0) +(define x:None 0) +(define x:Parent-Relative 1) +(define x:Copy-From-Parent 0) +(define x:Pointer-Window 0) +(define x:Input-Focus 1) +(define x:Pointer-Root 1) +(define x:Any-Property-Type 0) +(define x:Any-Key 0) +(define x:Any-Button 0) +(define x:All-Temporary 0) +(define x:Current-Time 0) +(define x:No-Symbol 0) +(define x:No-Event-Mask 0) +(define x:Key-Press-Mask 1) +(define x:Key-Release-Mask 2) +(define x:Button-Press-Mask 4) +(define x:Button-Release-Mask 8) +(define x:Enter-Window-Mask 16) +(define x:Leave-Window-Mask 32) +(define x:Pointer-Motion-Mask 64) +(define x:Pointer-Motion-Hint-Mask 128) +(define x:Button1-Motion-Mask 256) +(define x:Button2-Motion-Mask 512) +(define x:Button3-Motion-Mask 1024) +(define x:Button4-Motion-Mask 2048) +(define x:Button5-Motion-Mask 4096) +(define x:Button-Motion-Mask 8192) +(define x:Keymap-State-Mask 16384) +(define x:Exposure-Mask 32768) +(define x:Visibility-Change-Mask 65536) +(define x:Structure-Notify-Mask 131072) +(define x:Resize-Redirect-Mask 262144) +(define x:Substructure-Notify-Mask 524288) +(define x:Substructure-Redirect-Mask 1048576) +(define x:Focus-Change-Mask 2097152) +(define x:Property-Change-Mask 4194304) +(define x:Colormap-Change-Mask 8388608) +(define x:Owner-Grab-Button-Mask 16777216) +(define x:Key-Press 2) +(define x:Key-Release 3) +(define x:Button-Press 4) +(define x:Button-Release 5) +(define x:Motion-Notify 6) +(define x:Enter-Notify 7) +(define x:Leave-Notify 8) +(define x:Focus-In 9) +(define x:Focus-Out 10) +(define x:Keymap-Notify 11) +(define x:Expose 12) +(define x:Graphics-Expose 13) +(define x:No-Expose 14) +(define x:Visibility-Notify 15) +(define x:Create-Notify 16) +(define x:Destroy-Notify 17) +(define x:Unmap-Notify 18) +(define x:Map-Notify 19) +(define x:Map-Request 20) +(define x:Reparent-Notify 21) +(define x:Configure-Notify 22) +(define x:Configure-Request 23) +(define x:Gravity-Notify 24) +(define x:Resize-Request 25) +(define x:Circulate-Notify 26) +(define x:Circulate-Request 27) +(define x:Property-Notify 28) +(define x:Selection-Clear 29) +(define x:Selection-Request 30) +(define x:Selection-Notify 31) +(define x:Colormap-Notify 32) +(define x:Client-Message 33) +(define x:Mapping-Notify 34) +(define x:LAST-Event 35) +(define x:Shift-Mask 1) +(define x:Lock-Mask 2) +(define x:Control-Mask 4) +(define x:Mod1-Mask 8) +(define x:Mod2-Mask 16) +(define x:Mod3-Mask 32) +(define x:Mod4-Mask 64) +(define x:Mod5-Mask 128) +(define x:Shift-Map-Index 0) +(define x:Lock-Map-Index 1) +(define x:Control-Map-Index 2) +(define x:Mod1-Map-Index 3) +(define x:Mod2-Map-Index 4) +(define x:Mod3-Map-Index 5) +(define x:Mod4-Map-Index 6) +(define x:Mod5-Map-Index 7) +(define x:Button1-Mask 256) +(define x:Button2-Mask 512) +(define x:Button3-Mask 1024) +(define x:Button4-Mask 2048) +(define x:Button5-Mask 4096) +(define x:Any-Modifier 32768) +(define x:Button1 1) +(define x:Button2 2) +(define x:Button3 3) +(define x:Button4 4) +(define x:Button5 5) +(define x:Notify-Normal 0) +(define x:Notify-Grab 1) +(define x:Notify-Ungrab 2) +(define x:Notify-While-Grabbed 3) +(define x:Notify-Hint 1) +(define x:Notify-Ancestor 0) +(define x:Notify-Virtual 1) +(define x:Notify-Inferior 2) +(define x:Notify-Nonlinear 3) +(define x:Notify-Nonlinear-Virtual 4) +(define x:Notify-Pointer 5) +(define x:Notify-Pointer-Root 6) +(define x:Notify-Detail-None 7) +(define x:Visibility-Unobscured 0) +(define x:Visibility-Partially-Obscured 1) +(define x:Visibility-Fully-Obscured 2) +(define x:Place-On-Top 0) +(define x:Place-On-Bottom 1) +(define x:Family-Internet 0) +(define x:Family-DE-Cnet 1) +(define x:Family-Chaos 2) +(define x:Property-New-Value 0) +(define x:Property-Delete 1) +(define x:Colormap-Uninstalled 0) +(define x:Colormap-Installed 1) +(define x:Grab-Mode-Sync 0) +(define x:Grab-Mode-Async 1) +(define x:Grab-Success 0) +(define x:Already-Grabbed 1) +(define x:Grab-Invalid-Time 2) +(define x:Grab-Not-Viewable 3) +(define x:Grab-Frozen 4) +(define x:Async-Pointer 0) +(define x:Sync-Pointer 1) +(define x:Replay-Pointer 2) +(define x:Async-Keyboard 3) +(define x:Sync-Keyboard 4) +(define x:Replay-Keyboard 5) +(define x:Async-Both 6) +(define x:Sync-Both 7) +(define x:Revert-To-None 0) +(define x:Revert-To-Pointer-Root 1) +(define x:Revert-To-Parent 2) +(define x:Success 0) +(define x:Bad-Request 1) +(define x:Bad-Value 2) +(define x:Bad-Window 3) +(define x:Bad-Pixmap 4) +(define x:Bad-Atom 5) +(define x:Bad-Cursor 6) +(define x:Bad-Font 7) +(define x:Bad-Match 8) +(define x:Bad-Drawable 9) +(define x:Bad-Access 10) +(define x:Bad-Alloc 11) +(define x:Bad-Color 12) +(define x:Bad-GC 13) +(define x:Bad-ID-Choice 14) +(define x:Bad-Name 15) +(define x:Bad-Length 16) +(define x:Bad-Implementation 17) +(define x:First-Extension-Error 128) +(define x:Last-Extension-Error 255) +(define x:Input-Output 1) +(define x:Input-Only 2) +(define x:CW-Back-Pixmap 1) +(define x:CW-Back-Pixel 2) +(define x:CW-Border-Pixmap 4) +(define x:CW-Border-Pixel 8) +(define x:CW-Bit-Gravity 16) +(define x:CW-Win-Gravity 32) +(define x:CW-Backing-Store 64) +(define x:CW-Backing-Planes 128) +(define x:CW-Backing-Pixel 256) +(define x:CW-Override-Redirect 512) +(define x:CW-Save-Under 1024) +(define x:CW-Event-Mask 2048) +(define x:CW-Dont-Propagate 4096) +(define x:CW-Colormap 8192) +(define x:CW-Cursor 16384) +(define x:CWX 1) +(define x:CWY 2) +(define x:CW-Width 4) +(define x:CW-Height 8) +(define x:CW-Border-Width 16) +(define x:CW-Sibling 32) +(define x:CW-Stack-Mode 64) +(define x:Forget-Gravity 0) +(define x:North-West-Gravity 1) +(define x:North-Gravity 2) +(define x:North-East-Gravity 3) +(define x:West-Gravity 4) +(define x:Center-Gravity 5) +(define x:East-Gravity 6) +(define x:South-West-Gravity 7) +(define x:South-Gravity 8) +(define x:South-East-Gravity 9) +(define x:Static-Gravity 10) +(define x:Unmap-Gravity 0) +(define x:Not-Useful 0) +(define x:When-Mapped 1) +(define x:Always 2) +(define x:Is-Unmapped 0) +(define x:Is-Unviewable 1) +(define x:Is-Viewable 2) +(define x:Set-Mode-Insert 0) +(define x:Set-Mode-Delete 1) +(define x:Destroy-All 0) +(define x:Retain-Permanent 1) +(define x:Retain-Temporary 2) +(define x:Above 0) +(define x:Below 1) +(define x:Top-If 2) +(define x:Bottom-If 3) +(define x:Opposite 4) +(define x:Raise-Lowest 0) +(define x:Lower-Highest 1) +(define x:Prop-Mode-Replace 0) +(define x:Prop-Mode-Prepend 1) +(define x:Prop-Mode-Append 2) +(define x:G-Xclear 0) +(define x:G-Xand 1) +(define x:G-Xand-Reverse 2) +(define x:G-Xcopy 3) +(define x:G-Xand-Inverted 4) +(define x:G-Xnoop 5) +(define x:G-Xxor 6) +(define x:G-Xor 7) +(define x:G-Xnor 8) +(define x:G-Xequiv 9) +(define x:G-Xinvert 10) +(define x:G-Xor-Reverse 11) +(define x:G-Xcopy-Inverted 12) +(define x:G-Xor-Inverted 13) +(define x:G-Xnand 14) +(define x:G-Xset 15) +(define x:Line-Solid 0) +(define x:Line-On-Off-Dash 1) +(define x:Line-Double-Dash 2) +(define x:Cap-Not-Last 0) +(define x:Cap-Butt 1) +(define x:Cap-Round 2) +(define x:Cap-Projecting 3) +(define x:Join-Miter 0) +(define x:Join-Round 1) +(define x:Join-Bevel 2) +(define x:Fill-Solid 0) +(define x:Fill-Tiled 1) +(define x:Fill-Stippled 2) +(define x:Fill-Opaque-Stippled 3) +(define x:Even-Odd-Rule 0) +(define x:Winding-Rule 1) +(define x:Clip-By-Children 0) +(define x:Include-Inferiors 1) +(define x:Unsorted 0) +(define x:Y-Sorted 1) +(define x:YX-Sorted 2) +(define x:YX-Banded 3) +(define x:Coord-Mode-Origin 0) +(define x:Coord-Mode-Previous 1) +(define x:Complex 0) +(define x:Nonconvex 1) +(define x:Convex 2) +(define x:Arc-Chord 0) +(define x:Arc-Pie-Slice 1) +(define x:GC-Function 1) +(define x:GC-Plane-Mask 2) +(define x:GC-Foreground 4) +(define x:GC-Background 8) +(define x:GC-Line-Width 16) +(define x:GC-Line-Style 32) +(define x:GC-Cap-Style 64) +(define x:GC-Join-Style 128) +(define x:GC-Fill-Style 256) +(define x:GC-Fill-Rule 512) +(define x:GC-Tile 1024) +(define x:GC-Stipple 2048) +(define x:GC-Tile-Stip-X-Origin 4096) +(define x:GC-Tile-Stip-Y-Origin 8192) +(define x:GC-Font 16384) +(define x:GC-Subwindow-Mode 32768) +(define x:GC-Graphics-Exposures 65536) +(define x:GC-Clip-X-Origin 131072) +(define x:GC-Clip-Y-Origin 262144) +(define x:GC-Clip-Mask 524288) +(define x:GC-Dash-Offset 1048576) +(define x:GC-Dash-List 2097152) +(define x:GC-Arc-Mode 4194304) +(define x:GC-Last-Bit 22) +(define x:Font-Left-To-Right 0) +(define x:Font-Right-To-Left 1) +(define x:Font-Change 255) +(define x:XY-Bitmap 0) +(define x:XY-Pixmap 1) +(define x:Z-Pixmap 2) +(define x:Alloc-None 0) +(define x:Alloc-All 1) +(define x:Do-Red 1) +(define x:Do-Green 2) +(define x:Do-Blue 4) +(define x:Cursor-Shape 0) +(define x:Tile-Shape 1) +(define x:Stipple-Shape 2) +(define x:Auto-Repeat-Mode-Off 0) +(define x:Auto-Repeat-Mode-On 1) +(define x:Auto-Repeat-Mode-Default 2) +(define x:Led-Mode-Off 0) +(define x:Led-Mode-On 1) +(define x:KB-Key-Click-Percent 1) +(define x:KB-Bell-Percent 2) +(define x:KB-Bell-Pitch 4) +(define x:KB-Bell-Duration 8) +(define x:KB-Led 16) +(define x:KB-Led-Mode 32) +(define x:KB-Key 64) +(define x:KB-Auto-Repeat-Mode 128) +(define x:Mapping-Success 0) +(define x:Mapping-Busy 1) +(define x:Mapping-Failed 2) +(define x:Mapping-Modifier 0) +(define x:Mapping-Keyboard 1) +(define x:Mapping-Pointer 2) +(define x:Dont-Prefer-Blanking 0) +(define x:Prefer-Blanking 1) +(define x:Default-Blanking 2) +(define x:Disable-Screen-Saver 0) +(define x:Disable-Screen-Interval 0) +(define x:Dont-Allow-Exposures 0) +(define x:Allow-Exposures 1) +(define x:Default-Exposures 2) +(define x:Screen-Saver-Reset 0) +(define x:Screen-Saver-Active 1) +(define x:Host-Insert 0) +(define x:Host-Delete 1) +(define x:Enable-Access 1) +(define x:Disable-Access 0) +(define x:Static-Gray 0) +(define x:Gray-Scale 1) +(define x:Static-Color 2) +(define x:Pseudo-Color 3) +(define x:True-Color 4) +(define x:Direct-Color 5) +(define x:LSB-First 0) +(define x:MSB-First 1) +;;inc2scm extracted #define values from /usr/include/X11/cursorfont.h +(define XC:num-glyphs 154) +(define XC:X-cursor 0) +(define XC:arrow 2) +(define XC:based-arrow-down 4) +(define XC:based-arrow-up 6) +(define XC:boat 8) +(define XC:bogosity 10) +(define XC:bottom-left-corner 12) +(define XC:bottom-right-corner 14) +(define XC:bottom-side 16) +(define XC:bottom-tee 18) +(define XC:box-spiral 20) +(define XC:center-ptr 22) +(define XC:circle 24) +(define XC:clock 26) +(define XC:coffee-mug 28) +(define XC:cross 30) +(define XC:cross-reverse 32) +(define XC:crosshair 34) +(define XC:diamond-cross 36) +(define XC:dot 38) +(define XC:dotbox 40) +(define XC:double-arrow 42) +(define XC:draft-large 44) +(define XC:draft-small 46) +(define XC:draped-box 48) +(define XC:exchange 50) +(define XC:fleur 52) +(define XC:gobbler 54) +(define XC:gumby 56) +(define XC:hand1 58) +(define XC:hand2 60) +(define XC:heart 62) +(define XC:icon 64) +(define XC:iron-cross 66) +(define XC:left-ptr 68) +(define XC:left-side 70) +(define XC:left-tee 72) +(define XC:leftbutton 74) +(define XC:ll-angle 76) +(define XC:lr-angle 78) +(define XC:man 80) +(define XC:middlebutton 82) +(define XC:mouse 84) +(define XC:pencil 86) +(define XC:pirate 88) +(define XC:plus 90) +(define XC:question-arrow 92) +(define XC:right-ptr 94) +(define XC:right-side 96) +(define XC:right-tee 98) +(define XC:rightbutton 100) +(define XC:rtl-logo 102) +(define XC:sailboat 104) +(define XC:sb-down-arrow 106) +(define XC:sb-h-double-arrow 108) +(define XC:sb-left-arrow 110) +(define XC:sb-right-arrow 112) +(define XC:sb-up-arrow 114) +(define XC:sb-v-double-arrow 116) +(define XC:shuttle 118) +(define XC:sizing 120) +(define XC:spider 122) +(define XC:spraycan 124) +(define XC:star 126) +(define XC:target 128) +(define XC:tcross 130) +(define XC:top-left-arrow 132) +(define XC:top-left-corner 134) +(define XC:top-right-corner 136) +(define XC:top-side 138) +(define XC:top-tee 140) +(define XC:trek 142) +(define XC:ul-angle 144) +(define XC:umbrella 146) +(define XC:ur-angle 148) +(define XC:watch 150) +(define XC:xterm 152) +;;inc2scm extracted #define values from /usr/include/X11/Xlib.h +(define x:Xlib-Specification-Release 6) +(define x:True 1) +(define x:False 0) +(define x:Queued-Already 0) +(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:XIM-Preedit-Area 1) +(define x:XIM-Preedit-Callbacks 2) +(define x:XIM-Preedit-Position 4) +(define x:XIM-Preedit-Nothing 8) +(define x:XIM-Preedit-None 16) +(define x:XIM-Status-Area 256) +(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:X-Buffer-Overflow -1) +(define x:X-Lookup-None 1) +(define x:X-Lookup-Chars 2) +(define x:X-Lookup-Key-Sym 3) +(define x:X-Lookup-Both 4) +(define x:XIM-Reverse 1) +(define x:XIM-Underline 2) +(define x:XIM-Highlight 4) +(define x:XIM-Primary 32) +(define x:XIM-Secondary 64) +(define x:XIM-Tertiary 128) +(define x:XIM-Visible-To-Forward 256) +(define x:XIM-Visible-To-Backword 512) +(define x:XIM-Visible-To-Center 1024) +(define x:XIM-Preedit-Un-Known 0) +(define x:XIM-Preedit-Enable 1) +(define x:XIM-Preedit-Disable 2) +(define x:XIM-Initial-State 1) +(define x:XIM-Preserve-State 2) +(define x:XIM-String-Conversion-Left-Edge 1) +(define x:XIM-String-Conversion-Right-Edge 2) +(define x:XIM-String-Conversion-Top-Edge 4) +(define x:XIM-String-Conversion-Bottom-Edge 8) +(define x:XIM-String-Conversion-Concealed 16) +(define x:XIM-String-Conversion-Wrapped 32) +(define x:XIM-String-Conversion-Buffer 1) +(define x:XIM-String-Conversion-Line 2) +(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-Hot-Key-State-ON 1) +(define x:XIM-Hot-Key-State-OFF 2) +;;inc2scm extracted #define values from /usr/include/X11/Xutil.h +(define x:No-Value 0) +(define x:X-Value 1) +(define x:Y-Value 2) +(define x:Width-Value 4) +(define x:Height-Value 8) +(define x:All-Values 15) +(define x:X-Negative 16) +(define x:Y-Negative 32) +(define x:US-Position 1) +(define x:US-Size 2) +(define x:P-Position 4) +(define x:P-Size 8) +(define x:P-Min-Size 16) +(define x:P-Max-Size 32) +(define x:P-Resize-Inc 64) +(define x:P-Aspect 128) +(define x:P-Base-Size 256) +(define x:P-Win-Gravity 512) +(define x:P-All-Hints 252) +(define x:Input-Hint 1) +(define x:State-Hint 2) +(define x:Icon-Pixmap-Hint 4) +(define x:Icon-Window-Hint 8) +(define x:Icon-Position-Hint 16) +(define x:Icon-Mask-Hint 32) +(define x:Window-Group-Hint 64) +(define x:All-Hints 127) +(define x:X-Urgency-Hint 256) +(define x:Withdrawn-State 0) +(define x:Normal-State 1) +(define x:Iconic-State 3) +(define x:Dont-Care-State 0) +(define x:Zoom-State 2) +(define x:Inactive-State 4) +(define x:X-No-Memory -1) +(define x:X-Locale-Not-Supported -2) +(define x:X-Converter-Not-Found -3) +(define x:Rectangle-Out 0) +(define x:Rectangle-In 1) +(define x:Rectangle-Part 2) +(define x:Visual-No-Mask 0) +(define x:Visual-ID-Mask 1) +(define x:Visual-Screen-Mask 2) +(define x:Visual-Depth-Mask 4) +(define x:Visual-Class-Mask 8) +(define x:Visual-Red-Mask-Mask 16) +(define x:Visual-Green-Mask-Mask 32) +(define x:Visual-Blue-Mask-Mask 64) +(define x:Visual-Colormap-Size-Mask 128) +(define x:Visual-Bits-Per-RGB-Mask 256) +(define x:Visual-All-Mask 511) +(define x:Release-By-Freeing-Colormap 1) +(define x:Bitmap-Success 0) +(define x:Bitmap-Open-Failed 1) +(define x:Bitmap-File-Invalid 2) +(define x:Bitmap-No-Memory 3) +(define x:XCSUCCESS 0) +(define x:XCNOMEM 1) +(define x:XCNOENT 2) diff --git a/xevent.h b/xevent.h new file mode 100644 index 0000000..733c6c9 --- /dev/null +++ b/xevent.h @@ -0,0 +1,217 @@ +/* ./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); + case (KeyPress<<8)+0x12: case (KeyRelease<<8)+0x12: return x_make_bool(((XKeyEvent *) x)->send_event); + case (KeyPress<<8)+0x13: case (KeyRelease<<8)+0x13: return ulong2num(((XKeyEvent *) x)->time); + case (KeyPress<<8)+0x14: case (KeyRelease<<8)+0x14: return MAKINUM(((XKeyEvent *) x)->x); + case (KeyPress<<8)+0x15: case (KeyRelease<<8)+0x15: return MAKINUM(((XKeyEvent *) x)->y); + case (KeyPress<<8)+0x16: case (KeyRelease<<8)+0x16: return MAKINUM(((XKeyEvent *) x)->x_root); + case (KeyPress<<8)+0x17: case (KeyRelease<<8)+0x17: return MAKINUM(((XKeyEvent *) x)->y_root); + case (KeyPress<<8)+0x18: case (KeyRelease<<8)+0x18: return MAKINUM(((XKeyEvent *) x)->state); + case (KeyPress<<8)+0x19: case (KeyRelease<<8)+0x19: return MAKINUM(((XKeyEvent *) x)->keycode); + case (KeyPress<<8)+0x1a: case (KeyRelease<<8)+0x1a: return x_make_bool(((XKeyEvent *) x)->same_screen); + case (ButtonPress<<8)+0x10: case (ButtonRelease<<8)+0x10: return MAKINUM(((XButtonEvent *) x)->type); + case (ButtonPress<<8)+0x11: case (ButtonRelease<<8)+0x11: return MAKINUM(((XButtonEvent *) x)->serial); + case (ButtonPress<<8)+0x12: case (ButtonRelease<<8)+0x12: return x_make_bool(((XButtonEvent *) x)->send_event); + case (ButtonPress<<8)+0x13: case (ButtonRelease<<8)+0x13: return ulong2num(((XButtonEvent *) x)->time); + case (ButtonPress<<8)+0x14: case (ButtonRelease<<8)+0x14: return MAKINUM(((XButtonEvent *) x)->x); + case (ButtonPress<<8)+0x15: case (ButtonRelease<<8)+0x15: return MAKINUM(((XButtonEvent *) x)->y); + case (ButtonPress<<8)+0x16: case (ButtonRelease<<8)+0x16: return MAKINUM(((XButtonEvent *) x)->x_root); + case (ButtonPress<<8)+0x17: case (ButtonRelease<<8)+0x17: return MAKINUM(((XButtonEvent *) x)->y_root); + case (ButtonPress<<8)+0x18: case (ButtonRelease<<8)+0x18: return MAKINUM(((XButtonEvent *) x)->state); + case (ButtonPress<<8)+0x1b: case (ButtonRelease<<8)+0x1b: return MAKINUM(((XButtonEvent *) x)->button); + case (ButtonPress<<8)+0x1a: case (ButtonRelease<<8)+0x1a: return x_make_bool(((XButtonEvent *) x)->same_screen); + case (MotionNotify<<8)+0x10: return MAKINUM(((XMotionEvent *) x)->type); + case (MotionNotify<<8)+0x11: return MAKINUM(((XMotionEvent *) x)->serial); + case (MotionNotify<<8)+0x12: return x_make_bool(((XMotionEvent *) x)->send_event); + case (MotionNotify<<8)+0x13: return ulong2num(((XMotionEvent *) x)->time); + case (MotionNotify<<8)+0x14: return MAKINUM(((XMotionEvent *) x)->x); + case (MotionNotify<<8)+0x15: return MAKINUM(((XMotionEvent *) x)->y); + case (MotionNotify<<8)+0x16: return MAKINUM(((XMotionEvent *) x)->x_root); + case (MotionNotify<<8)+0x17: return MAKINUM(((XMotionEvent *) x)->y_root); + case (MotionNotify<<8)+0x18: return MAKINUM(((XMotionEvent *) x)->state); + case (MotionNotify<<8)+0x1c: return MAKINUM(((XMotionEvent *) x)->is_hint); + case (MotionNotify<<8)+0x1a: return x_make_bool(((XMotionEvent *) x)->same_screen); + case (EnterNotify<<8)+0x10: case (LeaveNotify<<8)+0x10: return MAKINUM(((XCrossingEvent *) x)->type); + case (EnterNotify<<8)+0x11: case (LeaveNotify<<8)+0x11: return MAKINUM(((XCrossingEvent *) x)->serial); + case (EnterNotify<<8)+0x12: case (LeaveNotify<<8)+0x12: return x_make_bool(((XCrossingEvent *) x)->send_event); + case (EnterNotify<<8)+0x13: case (LeaveNotify<<8)+0x13: return ulong2num(((XCrossingEvent *) x)->time); + case (EnterNotify<<8)+0x14: case (LeaveNotify<<8)+0x14: return MAKINUM(((XCrossingEvent *) x)->x); + case (EnterNotify<<8)+0x15: case (LeaveNotify<<8)+0x15: return MAKINUM(((XCrossingEvent *) x)->y); + case (EnterNotify<<8)+0x16: case (LeaveNotify<<8)+0x16: return MAKINUM(((XCrossingEvent *) x)->x_root); + case (EnterNotify<<8)+0x17: case (LeaveNotify<<8)+0x17: return MAKINUM(((XCrossingEvent *) x)->y_root); + case (EnterNotify<<8)+0x1d: case (LeaveNotify<<8)+0x1d: return MAKINUM(((XCrossingEvent *) x)->mode); + case (EnterNotify<<8)+0x1e: case (LeaveNotify<<8)+0x1e: return MAKINUM(((XCrossingEvent *) x)->detail); + case (EnterNotify<<8)+0x1a: case (LeaveNotify<<8)+0x1a: return x_make_bool(((XCrossingEvent *) x)->same_screen); + case (EnterNotify<<8)+0x1f: case (LeaveNotify<<8)+0x1f: return x_make_bool(((XCrossingEvent *) x)->focus); + case (EnterNotify<<8)+0x18: case (LeaveNotify<<8)+0x18: return MAKINUM(((XCrossingEvent *) x)->state); + case (FocusIn<<8)+0x10: case (FocusOut<<8)+0x10: return MAKINUM(((XFocusChangeEvent *) x)->type); + case (FocusIn<<8)+0x11: case (FocusOut<<8)+0x11: return MAKINUM(((XFocusChangeEvent *) x)->serial); + case (FocusIn<<8)+0x12: case (FocusOut<<8)+0x12: return x_make_bool(((XFocusChangeEvent *) x)->send_event); + case (FocusIn<<8)+0x1d: case (FocusOut<<8)+0x1d: return MAKINUM(((XFocusChangeEvent *) x)->mode); + case (FocusIn<<8)+0x1e: case (FocusOut<<8)+0x1e: return MAKINUM(((XFocusChangeEvent *) x)->detail); + case (KeymapNotify<<8)+0x10: return MAKINUM(((XKeymapEvent *) x)->type); + case (KeymapNotify<<8)+0x11: return MAKINUM(((XKeymapEvent *) x)->serial); + case (KeymapNotify<<8)+0x12: return x_make_bool(((XKeymapEvent *) x)->send_event); + case (Expose<<8)+0x10: return MAKINUM(((XExposeEvent *) x)->type); + case (Expose<<8)+0x11: return MAKINUM(((XExposeEvent *) x)->serial); + case (Expose<<8)+0x12: return x_make_bool(((XExposeEvent *) x)->send_event); + case (Expose<<8)+0x14: return MAKINUM(((XExposeEvent *) x)->x); + case (Expose<<8)+0x15: return MAKINUM(((XExposeEvent *) x)->y); + case (Expose<<8)+0x20: return MAKINUM(((XExposeEvent *) x)->width); + case (Expose<<8)+0x21: return MAKINUM(((XExposeEvent *) x)->height); + case (Expose<<8)+0x22: return MAKINUM(((XExposeEvent *) x)->count); + case (GraphicsExpose<<8)+0x10: return MAKINUM(((XGraphicsExposeEvent *) x)->type); + case (GraphicsExpose<<8)+0x11: return MAKINUM(((XGraphicsExposeEvent *) x)->serial); + case (GraphicsExpose<<8)+0x12: return x_make_bool(((XGraphicsExposeEvent *) x)->send_event); + case (GraphicsExpose<<8)+0x14: return MAKINUM(((XGraphicsExposeEvent *) x)->x); + case (GraphicsExpose<<8)+0x15: return MAKINUM(((XGraphicsExposeEvent *) x)->y); + case (GraphicsExpose<<8)+0x20: return MAKINUM(((XGraphicsExposeEvent *) x)->width); + case (GraphicsExpose<<8)+0x21: return MAKINUM(((XGraphicsExposeEvent *) x)->height); + case (GraphicsExpose<<8)+0x22: return MAKINUM(((XGraphicsExposeEvent *) x)->count); + case (GraphicsExpose<<8)+0x23: return MAKINUM(((XGraphicsExposeEvent *) x)->major_code); + case (GraphicsExpose<<8)+0x24: return MAKINUM(((XGraphicsExposeEvent *) x)->minor_code); + case (NoExpose<<8)+0x10: return MAKINUM(((XNoExposeEvent *) x)->type); + case (NoExpose<<8)+0x11: return MAKINUM(((XNoExposeEvent *) x)->serial); + case (NoExpose<<8)+0x12: return x_make_bool(((XNoExposeEvent *) x)->send_event); + case (NoExpose<<8)+0x23: return MAKINUM(((XNoExposeEvent *) x)->major_code); + case (NoExpose<<8)+0x24: return MAKINUM(((XNoExposeEvent *) x)->minor_code); + case (VisibilityNotify<<8)+0x10: return MAKINUM(((XVisibilityEvent *) x)->type); + case (VisibilityNotify<<8)+0x11: return MAKINUM(((XVisibilityEvent *) x)->serial); + case (VisibilityNotify<<8)+0x12: return x_make_bool(((XVisibilityEvent *) x)->send_event); + case (VisibilityNotify<<8)+0x18: return MAKINUM(((XVisibilityEvent *) x)->state); + case (CreateNotify<<8)+0x10: return MAKINUM(((XCreateWindowEvent *) x)->type); + case (CreateNotify<<8)+0x11: return MAKINUM(((XCreateWindowEvent *) x)->serial); + case (CreateNotify<<8)+0x12: return x_make_bool(((XCreateWindowEvent *) x)->send_event); + case (CreateNotify<<8)+0x14: return MAKINUM(((XCreateWindowEvent *) x)->x); + case (CreateNotify<<8)+0x15: return MAKINUM(((XCreateWindowEvent *) x)->y); + case (CreateNotify<<8)+0x20: return MAKINUM(((XCreateWindowEvent *) x)->width); + case (CreateNotify<<8)+0x21: return MAKINUM(((XCreateWindowEvent *) x)->height); + case (CreateNotify<<8)+0x25: return MAKINUM(((XCreateWindowEvent *) x)->border_width); + case (CreateNotify<<8)+0x26: return x_make_bool(((XCreateWindowEvent *) x)->override_redirect); + case (DestroyNotify<<8)+0x10: return MAKINUM(((XDestroyWindowEvent *) x)->type); + case (DestroyNotify<<8)+0x11: return MAKINUM(((XDestroyWindowEvent *) x)->serial); + case (DestroyNotify<<8)+0x12: return x_make_bool(((XDestroyWindowEvent *) x)->send_event); + case (UnmapNotify<<8)+0x10: return MAKINUM(((XUnmapEvent *) x)->type); + case (UnmapNotify<<8)+0x11: return MAKINUM(((XUnmapEvent *) x)->serial); + case (UnmapNotify<<8)+0x12: return x_make_bool(((XUnmapEvent *) x)->send_event); + case (UnmapNotify<<8)+0x27: return x_make_bool(((XUnmapEvent *) x)->from_configure); + case (MapNotify<<8)+0x10: return MAKINUM(((XMapEvent *) x)->type); + case (MapNotify<<8)+0x11: return MAKINUM(((XMapEvent *) x)->serial); + case (MapNotify<<8)+0x12: return x_make_bool(((XMapEvent *) x)->send_event); + case (MapNotify<<8)+0x26: return x_make_bool(((XMapEvent *) x)->override_redirect); + case (MapRequest<<8)+0x10: return MAKINUM(((XMapRequestEvent *) x)->type); + case (MapRequest<<8)+0x11: return MAKINUM(((XMapRequestEvent *) x)->serial); + case (MapRequest<<8)+0x12: return x_make_bool(((XMapRequestEvent *) x)->send_event); + case (ReparentNotify<<8)+0x10: return MAKINUM(((XReparentEvent *) x)->type); + case (ReparentNotify<<8)+0x11: return MAKINUM(((XReparentEvent *) x)->serial); + case (ReparentNotify<<8)+0x12: return x_make_bool(((XReparentEvent *) x)->send_event); + case (ReparentNotify<<8)+0x14: return MAKINUM(((XReparentEvent *) x)->x); + case (ReparentNotify<<8)+0x15: return MAKINUM(((XReparentEvent *) x)->y); + case (ReparentNotify<<8)+0x26: return x_make_bool(((XReparentEvent *) x)->override_redirect); + case (ConfigureNotify<<8)+0x10: return MAKINUM(((XConfigureEvent *) x)->type); + case (ConfigureNotify<<8)+0x11: return MAKINUM(((XConfigureEvent *) x)->serial); + case (ConfigureNotify<<8)+0x12: return x_make_bool(((XConfigureEvent *) x)->send_event); + case (ConfigureNotify<<8)+0x14: return MAKINUM(((XConfigureEvent *) x)->x); + case (ConfigureNotify<<8)+0x15: return MAKINUM(((XConfigureEvent *) x)->y); + case (ConfigureNotify<<8)+0x20: return MAKINUM(((XConfigureEvent *) x)->width); + case (ConfigureNotify<<8)+0x21: return MAKINUM(((XConfigureEvent *) x)->height); + case (ConfigureNotify<<8)+0x25: return MAKINUM(((XConfigureEvent *) x)->border_width); + case (ConfigureNotify<<8)+0x26: return x_make_bool(((XConfigureEvent *) x)->override_redirect); + case (GravityNotify<<8)+0x10: return MAKINUM(((XGravityEvent *) x)->type); + case (GravityNotify<<8)+0x11: return MAKINUM(((XGravityEvent *) x)->serial); + case (GravityNotify<<8)+0x12: return x_make_bool(((XGravityEvent *) x)->send_event); + case (GravityNotify<<8)+0x14: return MAKINUM(((XGravityEvent *) x)->x); + case (GravityNotify<<8)+0x15: return MAKINUM(((XGravityEvent *) x)->y); + case (ResizeRequest<<8)+0x10: return MAKINUM(((XResizeRequestEvent *) x)->type); + case (ResizeRequest<<8)+0x11: return MAKINUM(((XResizeRequestEvent *) x)->serial); + case (ResizeRequest<<8)+0x12: return x_make_bool(((XResizeRequestEvent *) x)->send_event); + case (ResizeRequest<<8)+0x20: return MAKINUM(((XResizeRequestEvent *) x)->width); + case (ResizeRequest<<8)+0x21: return MAKINUM(((XResizeRequestEvent *) x)->height); + case (ConfigureRequest<<8)+0x10: return MAKINUM(((XConfigureRequestEvent *) x)->type); + case (ConfigureRequest<<8)+0x11: return MAKINUM(((XConfigureRequestEvent *) x)->serial); + case (ConfigureRequest<<8)+0x12: return x_make_bool(((XConfigureRequestEvent *) x)->send_event); + case (ConfigureRequest<<8)+0x14: return MAKINUM(((XConfigureRequestEvent *) x)->x); + case (ConfigureRequest<<8)+0x15: return MAKINUM(((XConfigureRequestEvent *) x)->y); + case (ConfigureRequest<<8)+0x20: return MAKINUM(((XConfigureRequestEvent *) x)->width); + case (ConfigureRequest<<8)+0x21: return MAKINUM(((XConfigureRequestEvent *) x)->height); + case (ConfigureRequest<<8)+0x25: return MAKINUM(((XConfigureRequestEvent *) x)->border_width); + case (ConfigureRequest<<8)+0x1e: return MAKINUM(((XConfigureRequestEvent *) x)->detail); + case (ConfigureRequest<<8)+0x28: return MAKINUM(((XConfigureRequestEvent *) x)->value_mask); + case (CirculateNotify<<8)+0x10: return MAKINUM(((XCirculateEvent *) x)->type); + case (CirculateNotify<<8)+0x11: return MAKINUM(((XCirculateEvent *) x)->serial); + case (CirculateNotify<<8)+0x12: return x_make_bool(((XCirculateEvent *) x)->send_event); + case (CirculateNotify<<8)+0x29: return MAKINUM(((XCirculateEvent *) x)->place); + case (CirculateRequest<<8)+0x10: return MAKINUM(((XCirculateRequestEvent *) x)->type); + case (CirculateRequest<<8)+0x11: return MAKINUM(((XCirculateRequestEvent *) x)->serial); + case (CirculateRequest<<8)+0x12: return x_make_bool(((XCirculateRequestEvent *) x)->send_event); + case (CirculateRequest<<8)+0x29: return MAKINUM(((XCirculateRequestEvent *) x)->place); + case (PropertyNotify<<8)+0x10: return MAKINUM(((XPropertyEvent *) x)->type); + case (PropertyNotify<<8)+0x11: return MAKINUM(((XPropertyEvent *) x)->serial); + case (PropertyNotify<<8)+0x12: return x_make_bool(((XPropertyEvent *) x)->send_event); + case (PropertyNotify<<8)+0x13: return ulong2num(((XPropertyEvent *) x)->time); + case (PropertyNotify<<8)+0x18: return MAKINUM(((XPropertyEvent *) x)->state); + case (SelectionClear<<8)+0x10: return MAKINUM(((XSelectionClearEvent *) x)->type); + case (SelectionClear<<8)+0x11: return MAKINUM(((XSelectionClearEvent *) x)->serial); + case (SelectionClear<<8)+0x12: return x_make_bool(((XSelectionClearEvent *) x)->send_event); + case (SelectionClear<<8)+0x13: return ulong2num(((XSelectionClearEvent *) x)->time); + case (SelectionRequest<<8)+0x10: return MAKINUM(((XSelectionRequestEvent *) x)->type); + case (SelectionRequest<<8)+0x11: return MAKINUM(((XSelectionRequestEvent *) x)->serial); + case (SelectionRequest<<8)+0x12: return x_make_bool(((XSelectionRequestEvent *) x)->send_event); + case (SelectionRequest<<8)+0x13: return ulong2num(((XSelectionRequestEvent *) x)->time); + case (SelectionNotify<<8)+0x10: return MAKINUM(((XSelectionEvent *) x)->type); + case (SelectionNotify<<8)+0x11: return MAKINUM(((XSelectionEvent *) x)->serial); + case (SelectionNotify<<8)+0x12: return x_make_bool(((XSelectionEvent *) x)->send_event); + case (SelectionNotify<<8)+0x13: return ulong2num(((XSelectionEvent *) x)->time); + case (ColormapNotify<<8)+0x10: return MAKINUM(((XColormapEvent *) x)->type); + case (ColormapNotify<<8)+0x11: return MAKINUM(((XColormapEvent *) x)->serial); + case (ColormapNotify<<8)+0x12: return x_make_bool(((XColormapEvent *) x)->send_event); + case (ColormapNotify<<8)+0x2a: return x_make_bool(((XColormapEvent *) x)->new); + case (ColormapNotify<<8)+0x18: return MAKINUM(((XColormapEvent *) x)->state); + case (ClientMessage<<8)+0x10: return MAKINUM(((XClientMessageEvent *) x)->type); + case (ClientMessage<<8)+0x11: return MAKINUM(((XClientMessageEvent *) x)->serial); + case (ClientMessage<<8)+0x12: return x_make_bool(((XClientMessageEvent *) x)->send_event); + case (ClientMessage<<8)+0x2b: return MAKINUM(((XClientMessageEvent *) x)->format); + case (MappingNotify<<8)+0x10: return MAKINUM(((XMappingEvent *) x)->type); + case (MappingNotify<<8)+0x11: return MAKINUM(((XMappingEvent *) x)->serial); + case (MappingNotify<<8)+0x12: return x_make_bool(((XMappingEvent *) x)->send_event); + case (MappingNotify<<8)+0x2c: return MAKINUM(((XMappingEvent *) x)->request); + case (MappingNotify<<8)+0x2d: return MAKINUM(((XMappingEvent *) x)->first_keycode); + case (MappingNotify<<8)+0x22: return MAKINUM(((XMappingEvent *) x)->count); +#else + {MotionNotify, "MotionNotify"}, + {KeyPress, "KeyPress"}, + {KeyRelease, "KeyRelease"}, + {ButtonPress, "ButtonPress"}, + {ButtonRelease, "ButtonRelease"}, + {MotionNotify, "MotionNotify"}, + {EnterNotify, "EnterNotify"}, + {LeaveNotify, "LeaveNotify"}, + {FocusIn, "FocusIn"}, + {FocusOut, "FocusOut"}, + {KeymapNotify, "KeymapNotify"}, + {Expose, "Expose"}, + {GraphicsExpose, "GraphicsExpose"}, + {NoExpose, "NoExpose"}, + {VisibilityNotify, "VisibilityNotify"}, + {CreateNotify, "CreateNotify"}, + {DestroyNotify, "DestroyNotify"}, + {UnmapNotify, "UnmapNotify"}, + {MapNotify, "MapNotify"}, + {MapRequest, "MapRequest"}, + {ReparentNotify, "ReparentNotify"}, + {ConfigureNotify, "ConfigureNotify"}, + {ConfigureRequest, "ConfigureRequest"}, + {GravityNotify, "GravityNotify"}, + {ResizeRequest, "ResizeRequest"}, + {CirculateNotify, "CirculateNotify"}, + {CirculateRequest, "CirculateRequest"}, + {PropertyNotify, "PropertyNotify"}, + {SelectionClear, "SelectionClear"}, + {SelectionRequest, "SelectionRequest"}, + {SelectionNotify, "SelectionNotify"}, + {ColormapNotify, "ColormapNotify"}, + {ClientMessage, "ClientMessage"}, + {MappingNotify, "MappingNotify"}, +#endif diff --git a/xevent.scm b/xevent.scm new file mode 100644 index 0000000..6436a36 --- /dev/null +++ b/xevent.scm @@ -0,0 +1,31 @@ +;; ./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) +(define X-event:time #x13) +(define X-event:x #x14) +(define X-event:y #x15) +(define X-event:x-root #x16) +(define X-event:y-root #x17) +(define X-event:state #x18) +(define X-event:keycode #x19) +(define X-event:same-screen #x1a) +(define X-event:button #x1b) +(define X-event:is-hint #x1c) +(define X-event:mode #x1d) +(define X-event:detail #x1e) +(define X-event:focus #x1f) +(define X-event:width #x20) +(define X-event:height #x21) +(define X-event:count #x22) +(define X-event:major-code #x23) +(define X-event:minor-code #x24) +(define X-event:border-width #x25) +(define X-event:override-redirect #x26) +(define X-event:from-configure #x27) +(define X-event:value-mask #x28) +(define X-event:place #x29) +(define X-event:new #x2a) +(define X-event:format #x2b) +(define X-event:request #x2c) +(define X-event:first-keycode #x2d) diff --git a/xgen.scm b/xgen.scm new file mode 100755 index 0000000..19db1cc --- /dev/null +++ b/xgen.scm @@ -0,0 +1,297 @@ +#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 +- !# +;; Copyright (C) 1991-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. + +;;;; "xgen.scm", Convert C Event structs to xevent.h and xevent.scm. +;;; Author: Aubrey Jaffer. + +(define (go-script) + (cond ((not *script*)) + ((>= 1 (- (length *argv*) *optind*)) + (apply xgen.scm (list-tail *argv* *optind*))) + (else + (display "\ +\ +Usage: xgen.scm /usr/include/X11/Xlib.h +\ + Creates xevent.h and xevent.scm, from the `typedef struct's + in /usr/include/X11/xlib.h. +" + (current-error-port)) + (exit #f)))) + +(require 'common-list-functions) +(require 'string-search) +(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) + +;; SCHEMEIFY-NAME: +;; * Changes _ to - +;; * Changes the first - to : if it is within the first 3 characters. +;; * inserts dashes between `StudlyCaps' + +(define (schemeify-name pre name) + (define nstr (string-subst name "_" "-")) + (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))))) + +(define (extract-structs port) + (define typedef-struct (string-append (string #\newline) "typedef struct {")) + (define structs '()) + (do ((find? (find-string-from-port? typedef-struct port) + (find-string-from-port? typedef-struct port))) + ((not find?) (reverse structs)) + (set! structs (cons (extract-struct port) structs)))) + +(define (extract-struct port) + (define elts '()) + (do ((typ (read-token port) (read-token port))) + ((or (eof-object? typ) (eq? #\} typ)) + (let ((name (read-token port))) + (let ((chr (read-token port))) + (cond ((eqv? #\; chr)) + (else (slib:error 'expected #\; 'but-read chr))) + (cons name (reverse elts))))) + (letrec ((loop + (lambda (name) + ;;(print 'typ= typ 'name= name) + (case name + ((#\*) + (case (string->symbol typ) + ((char) (set! typ "string")) + (else (set! typ (string-append typ "*")))) + (loop (read-token port))) + (else + (let loop2 ((chr (read-token port))) + (case chr + ((#\;) + (set! elts (cons (list typ name) elts))) + ((#\,) + (set! elts (cons (list typ name) elts)) + (loop (read-token port))) + ((#\[) + (find-string-from-port? "]" port) + (case (string->symbol typ) + ((char) (set! typ "string")) + (else (set! typ (string-append typ "*")))) + (loop2 (read-token port))) + (else (slib:error 'expected #\; 'read chr)))))) + ))) + (case (string->symbol typ) + ((unsigned) + (set! typ (read-token port)) + (case (string->symbol typ) + ((long short char int) (set! typ "int") + (loop (read-token port))) + (else (loop typ)))) + ((struct) + (set! typ (read-token port)) + (loop (read-token port))) + ((union) + (find-string-from-port? close-brace-string port) + ;;(set! typ "union") + (loop (read-token port))) + (else (loop (read-token port))))))) + +(define close-brace-string (string #\})) + +(define (read-token port) + (let ((chr (peek-char port))) + (cond ((eqv? chr #\newline) + (read-char port) + (do ((fchr (peek-char port) (peek-char port))) + ((not (eqv? #\# fchr))) + (read-char port) + (if (eq? 'if (read port)) + (do ((fchr (peek-char port) (peek-char port))) + ((eqv? #\# fchr)) + (read-line port))) + (read-line port)) + (read-token port)) + ((char-whitespace? chr) + (read-char port) + (read-token port)) + ((eqv? #\/ chr) + (cond ((and (find-string-from-port? "/*" port) + (find-string-from-port? "*/" port + ;;(lambda (chr) (display chr) #f) + )) + ;;(newline) + (read-token port)) + (else + (slib:error 'botched-comment (read-line port))))) + ((or (char-alphabetic? chr) (eqv? #\_ chr)) + (car (scanf-read-list "%[a-zA-Z_0-9]" port))) + ;;((string-index "[]*" chr) (string->symbol (string chr))) + (else (read-char port))))) + +(defconst Bool (string->symbol "Bool")) +(defconst Time (string->symbol "Time")) + +(define event-map + '( + ("XMotionEvent" "MotionNotify") + ("XKeyEvent" "KeyPress" "KeyRelease") + ("XButtonEvent" "ButtonPress" "ButtonRelease") + ("XPointerMovedEvent" "MotionNotify") + ("XCrossingEvent" "EnterNotify" "LeaveNotify") + ("XFocusChangeEvent" "FocusIn" "FocusOut") + ("XKeymapEvent" "KeymapNotify") + ("XExposeEvent" "Expose") + ("XGraphicsExposeEvent" "GraphicsExpose") + ("XNoExposeEvent" "NoExpose") + ("XVisibilityEvent" "VisibilityNotify") + ("XCreateWindowEvent" "CreateNotify") + ("XDestroyWindowEvent" "DestroyNotify") + ("XUnmapEvent" "UnmapNotify") + ("XMapEvent" "MapNotify") + ("XMapRequestEvent" "MapRequest") + ("XReparentEvent" "ReparentNotify") + ("XConfigureEvent" "ConfigureNotify") + ("XConfigureRequestEvent" "ConfigureRequest") + ("XGravityEvent" "GravityNotify") + ("XResizeRequestEvent" "ResizeRequest") + ("XCirculateEvent" "CirculateNotify") + ("XCirculateRequestEvent" "CirculateRequest") + ("XPropertyEvent" "PropertyNotify") + ("XSelectionClearEvent" "SelectionClear") + ("XSelectionRequestEvent" "SelectionRequest") + ("XSelectionEvent" "SelectionNotify") + ("XColormapEvent" "ColormapNotify") + ("XClientMessageEvent" "ClientMessage") + ("XMappingEvent" "MappingNotify") + )) + +(define event-fields '()) +(define event-field-idx #x10) +(define (do-field xevent.scm fname) + (define apr (assoc fname event-fields)) + (cond (apr (cdr apr)) + (else + (set! event-fields (acons fname event-field-idx event-fields)) + (fprintf xevent.scm "(define X-event:%s #x%02x)\n" + (schemeify-name #f fname) + event-field-idx) + (set! event-field-idx (+ 1 event-field-idx)) + (+ -1 event-field-idx)))) + +(define (xgen.scm . filename) + (set! filename (if (null? filename) "/usr/include/X11/Xlib.h" (car filename))) + (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"))))) + +(go-script) + +;;; Local Variables: +;;; mode:scheme +;;; End: |