[gimp-tiny-fu] Merge of TinyScheme from git master of GIMP as of commit 262cc1c9
- From: Kevin Cozens <kcozens src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [gimp-tiny-fu] Merge of TinyScheme from git master of GIMP as of commit 262cc1c9
- Date: Sat, 11 Jun 2022 19:12:17 +0000 (UTC)
commit 83f1bcfbe638cb0a709814d86da1d06d825bedc4
Author: Kevin Cozens <kcozens svn gnome org>
Date: Fri Nov 18 21:23:54 2011 -0500
Merge of TinyScheme from git master of GIMP as of commit 262cc1c9
tinyscheme/BUILDING | 83 ++-
tinyscheme/CHANGES | 501 +++++++++-------
tinyscheme/Manual.txt | 53 +-
tinyscheme/dynload.c | 52 +-
tinyscheme/init.scm | 239 ++++++--
tinyscheme/opdefines.h | 9 +-
tinyscheme/scheme-private.h | 42 +-
tinyscheme/scheme.c | 1316 ++++++++++++++++++++++++++++---------------
tinyscheme/scheme.h | 47 +-
9 files changed, 1564 insertions(+), 778 deletions(-)
---
diff --git a/tinyscheme/BUILDING b/tinyscheme/BUILDING
index 022aa6b..5c00236 100644
--- a/tinyscheme/BUILDING
+++ b/tinyscheme/BUILDING
@@ -1,5 +1,5 @@
- Building TinyScheme
- -------------------
+ Building TinyScheme
+ -------------------
The included makefile includes logic for Linux, Solaris and Win32, and can
readily serve as an example for other OSes, especially Unixes. There are
@@ -11,8 +11,8 @@ Autoconfing TinyScheme was once proposed, but the distribution would not be
so small anymore. There are few platform dependencies in TinyScheme, and in
general compiles out of the box.
- Customizing
- -----------
+ Customizing
+ -----------
The following symbols are defined to default values in scheme.h.
Use the -D flag of cc to set to either 1 or 0.
@@ -62,3 +62,78 @@ general compiles out of the box.
Shortcut to disable USE_MATH, USE_CHAR_CLASSIFIERS, USE_ASCII_NAMES,
USE_STRING_PORTS, USE_ERROR_HOOK, USE_TRACING, USE_COLON_HOOK,
USE_DL.
+
+ USE_SCHEME_STACK
+ Enables 'cons' stack (the alternative is a faster calling scheme, which
+ breaks continuations). Undefine it if you don't care about strict compatibility
+ but you do care about faster execution.
+
+
+ OS-X tip
+ --------
+ I don't have access to OS-X, but Brian Maher submitted the following tip:
+
+[1] Download and install fink (I installed fink in
+/usr/local/fink)
+[2] Install the 'dlcompat' package using fink as such:
+> fink install dlcompat
+[3] Make the following changes to the
+tinyscheme-1.32.tar.gz
+
+diff -r tinyscheme-1.32/dynload.c
+tinyscheme-1.32-new/dynload.c
+24c24
+< #define SUN_DL
+---
+>
+Only in tinyscheme-1.32-new/: dynload.o
+Only in tinyscheme-1.32-new/: libtinyscheme.a Only in tinyscheme-1.32-new/: libtinyscheme.so diff -r
tinyscheme-1.32/makefile tinyscheme-1.32-new/makefile
+33,34c33,43
+< LD = gcc
+< LDFLAGS = -shared
+---
+> #LD = gcc
+> #LDFLAGS = -shared
+> #DEBUG=-g -Wno-char-subscripts -O
+> #SYS_LIBS= -ldl
+> #PLATFORM_FEATURES= -DSUN_DL=1
+>
+> # Mac OS X
+> CC = gcc
+> CFLAGS = -I/usr/local/fink/include
+> LD = gcc
+> LDFLAGS = -L/usr/local/fink/lib
+37c46
+< PLATFORM_FEATURES= -DSUN_DL=1
+---
+> PLATFORM_FEATURES= -DSUN_DL=1 -DOSX
+60c69
+< $(CC) -I. -c $(DEBUG) $(FEATURES)
+$(DL_FLAGS) $<
+---
+> $(CC) $(CFLAGS) -I. -c $(DEBUG)
+$(FEATURES) $(DL_FLAGS) $<
+66c75
+< $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS)
+---
+> $(CC) $(LDFLAGS) -o $@ $(DEBUG) $(OBJS)
+$(SYS_LIBS)
+Only in tinyscheme-1.32-new/: scheme
+diff -r tinyscheme-1.32/scheme.c
+tinyscheme-1.32-new/scheme.c
+60,61c60,61
+< #ifndef macintosh
+< # include <malloc.h>
+---
+> #ifdef OSX
+> /* Do nothing */
+62a63,65
+> # ifndef macintosh
+> # include <malloc.h>
+> # else
+77c80,81
+< #endif /* macintosh */
+---
+> # endif /* macintosh */
+> #endif /* !OSX */
+Only in tinyscheme-1.32-new/: scheme.o
diff --git a/tinyscheme/CHANGES b/tinyscheme/CHANGES
index dd42080..fcbe942 100644
--- a/tinyscheme/CHANGES
+++ b/tinyscheme/CHANGES
@@ -1,206 +1,295 @@
- Change Log
- ----------
- Version 1.38
- Interim release until the rewrite, mostly incorporating modifications from
- Kevin Cozens. Small addition for Cygwin in the makefile, and modifications
- by Andrew Guenther for Apple platforms.
- Version 1.37
- Joe Buehler submitted reserve_cells.
- Version 1.36
- Joe Buehler fixed a patch in the allocator.
- Alexander Shendi moved the comment handling in the scanner, which
- fixed an obscure bug for which Mike E had provided a patch as well.
- Kevin Cozens has submitted some fixes and modifications which have not
- been incorporated yet in their entirety.
- Version 1.35
- Todd Showalter discovered that the number of free cells reported
- after GC was incorrect, which could also cause unnecessary allocations.
- Version 1.34
- Long missing version. Lots of bugfixes have accumulated in my email, so
- I had to start using them. In this version, Keenan Pepper has submitted
- a bugfix for the string comparison library procedure, Wouter Boeke
- modified some code that was casting to the wrong type and crashed on
- some machines, "SheppardCo" submitted a replacement "modulo" code and
- Scott Fenton submitted lots of corrections that shut up some compiler
- warnings. Brian Maher submitted instructions on how to build on OS-X.
- I have to dig deeper into my mailbox and find earlier emails, too.
- Version 1.33
- Charles Hayden fixed a nasty GC bug of the new stack frame, while in
- the process of porting TinyScheme to C++. He also submitted other
- changes, and other people also had comments or requests, but the GC
- bug was so important that this version is put through the door to
- correct it.
- Version 1.32
- Stephen Gildea put some quality time on TinyScheme again, and made
- a whole lot of changes to the interpreter that made it noticeably
- faster.
- Version 1.31
- Patches to the hastily-done version 1.30. Stephen Gildea fixed
- some things done wrongly, and Richard Russo fixed the makefile
- for building on Windows. Property lists (heritage from MiniScheme)
- are now optional and have dissappeared from the interface. They
- should be considered as deprecated.
- Version 1.30
- After many months, I followed Preston Bannister's advice of
- using macros and a single source text to keep the enums and the
- dispatch table in sync, and I used his contributed "opdefines.h".
- Timothy Downs contributed a helpful function, "scheme_call".
- Stephen Gildea contributed new versions of the makefile and
- practically all other sources. He created a built-in STRING-APPEND,
- and fixed a lot of other bugs.
- Ruhi Bloodworth reported fixes necessary for OS X and a small
- bug in dynload.c.
- Version 1.29
- The previous version contained a lot of corrections, but there
- were a lot more that still wait on a sheet of paper lost in a
- carton someplace after my house move... Manuel Heras-Gilsanz
- noticed this and resent his own contribution, which relies on
- another bugfix that v.1.28 was missing: a problem with string
- output, that this version fixes. I hope other people will take
- the time to resend their contributions, if they didn't make it
- to v.1.28.
- Version 1.28
- Many people have contacted me with bugfixes or remarks in
- the three months I was inactive. A lot of them spotted that
- scheme_deinit crashed while reporting gc results. They suggested
- that sc->outport be set to NIL in scheme_deinit, which I did.
- Dennis Taylor remarked that OP_VALUEPRINT reset sc->value instead
- of preserving it. He submitted a modification which I adopted
- partially. David Hovemeyer sent me many little changes, that you
- will find in version 1.28, and Partice Stoessel modified the
- float reader to conform to R5RS.
- Version 1.27
- Version 1.27 is the successor of 1.25. Bug fixes only, but I had to
- release them so that everybody can profit. 'Backchar' tried to write
- back to the string, which obviously didn't work for const strings.
- 'Substring' didn't check for crossed start and end indices. Defines
- changed to restore the ability to compile under MSVC.
- Version 1.26
- Version 1.26 was never released. I changed a lot of things, in fact
- too much, even the garbage collector, and hell broke loose. I'll
- try a more gradual approach next time.
- Version 1.25
- Types have been homogenized to be able to accomodate a different
- representation. Plus, promises are no longer closures. Unfortunately,
- I discovered that continuations and force/delay do not pass the SCM
- test (and never did)... However, on the bright side, what little
- modifications I did had a large impact on the footprint:
- USE_NO_FEATURES now produces an object file of 63960 bytes on Linux!
- Version 1.24
- SCM tests now pass again after change in atom2str.
- Version 1.23
- Finally I managed to mess it up with my version control. Version
- 1.22 actually lacked some of the things I have been fixing in the
- meantime. This should be considered as a complete replacement for
- 1.22.
- Version 1.22
- The new ports had a bug in LOAD. MK_CLOSURE is introduced.
- Shawn Wagner inquired about string->number and number->string.
- I added string->atom and atom->string and defined the number
- functions from them. Doing that, I fixed WRITE applied to symbols
- (it didn't quote them). Unfortunately, minimum build is now
- slightly larger than 64k... I postpone action because Jason's idea
- might solve it elegantly.
- Version 1.21
- Jason Felice submitted a radically different datatype representation
- which he had implemented. While discussing its pros and cons, it
- became apparent that the current implementation of ports suffered
- from a grave fault: ports were not garbage-collected. I changed the
- ports to be heap-allocated, which enabled the use of string ports
- for loading. Jason also fixed errors in the garbage collection of
- vectors. USE_VERBATIM is gone. "ssp_compiler.c" has a better solution
- on HTML generation. A bug involving backslash notation in strings
- has been fixed. '-c' flag now executes next argument as a stream of
- Scheme commands. Foreign functions are now also heap allocated,
- and scheme_define is used to define everything.
- Version 1.20
- Tracing has been added. The toplevel loop has been slightly
- rearranged. Backquote reading for vector templates has been
- sanitized. Symbol interning is now correct. Arithmetic functions
- have been corrected. APPLY, MAP, FOR-EACH, numeric comparison
- functions fixed. String reader/writer understands \xAA notation.
- Version 1.19
- Carriage Return now delimits identifiers. DOS-formatted Scheme files
- can be used by Unix. Random number generator added to library.
- Fixed some glitches of the new type-checking scheme. Fixed erroneous
- (append '() 'a) behavior. Will continue with r4rstest.scm to
- fix errors.
- Version 1.18
- The FFI has been extended. USE_VERBOSE_GC has gone. Anyone wanting
- the same functionality can put (gcverbose #t) in init.scm.
- print-width was removed, along with three corresponding op-codes.
- Extended character constants with ASCII names were added.
- mk_counted_string paves the way for full support of binary strings.
- As much as possible of the type-checking chores were delegated
- to the inner loop, thus reducing the code size to less than 4200 loc!
- Version 1.17
- Dynamically-loaded extensions are more fully integrated.
- TinyScheme is now distributed under the BSD open-source license.
- Version 1.16
- Dynamically-loaded extensions introduced (USE_DL).
- Santeri Paavolainen found a race condition: When a cons is executed,
- and each of the two arguments is a constructing function, GC could
- happen before all arguments are evaluated and cons() is called, and
- the evaluated arguments would all be reclaimed!
- Fortunately, such a case was rare in the code, although it is
- a pitfall in new code and code in foreign functions. Currently, only
- one such case remains, when COLON_HOOK is defined.
- Version 1.15
- David Gould also contributed some changes that speed up operation.
- Kirk Zurell fixed HASPROP.
- The Garbage Collection didn't collect all the garbage...fixed.
- Version 1.14
- Unfortunately, after Andre fixed the GC it became obvious that the
- algorithm was too slow... Fortunately, David Gould found a way to
- speed it up.
- Version 1.13
- Silly bug involving division by zero resolved by Roland Kaufman.
- Macintoch support from Shmulik Regev.
- Float parser bug fixed by Alexander Shendi.
- GC bug from Andru Luvisi.
- Version 1.12
- Cis* incorrectly called isalpha() instead of isascii()
- Added USE_CHAR_CLASSIFIERS, USE_STRING_PORTS.
- Version 1.11
- BSDI defines isnumber... changed all similar functions to is_*
- EXPT now has correct definition. Added FLOOR,CEILING,TRUNCATE
- and ROUND, courtesy of Bengt Kleberg. Preprocessor symbols now
- have values 1 or 0, and can be set as compiler defines (proposed
- by Andy Ganor *months* ago). 'prompt' and 'InitFile' can now be
- defined during compilation, too.
- Version 1.10
- Another bug when file ends with comment!
- Added DEFINE-MACRO in init.scm, courtesy of Andy Gaynor.
- Version 1.09
- Removed bug when READ met EOF. lcm.
- Version 1.08
- quotient,remainder and modulo. gcd.
- Version 1.07
- '=>' in cond now exists
- list? now checks for circularity
- some reader bugs removed
- Reader is more consistent wrt vectors
- Quote and Quasiquote work with vectors
- Version 1.06
- #! is now skipped
- generic-assoc bug removed
- strings are now managed differently, hack.txt is removed
- various delicate points fixed
- Version 1.05
- Support for scripts, *args*, "-1" option.
- Various R5RS procedures.
- *sharp-hook*
- Handles unmatched parentheses.
- New architecture for procedures.
- Version 1.04
- Added missing T_ATOM bits...
- Added vectors
- Free-list is sorted by address, since vectors need consecutive cells.
- (quit <exitcode>) for use with scripts
- Version 1.03 (26 Aug 1998):
- Extended .h with useful functions for FFI
- Library: with-input-* etc.
- Finished R5RS I/O, added string ports.
- Version 1.02 (25 Aug 1998):
- First part of R5RS I/O.
-
\ No newline at end of file
+Change Log
+----------
+
+Version 1.40
+ Bugs fixed:
+ #1964950 - Stop core dumps due to bad syntax in LET (and variants)
+ #2826594 - allow reverse to work on empty list (Tony Garnock-Jones)
+ Potential problem of arglist to foreign calls being wrongly GC'ed.
+ Fixed bug that read could loop forever (tehom).
+
+ API changes:
+ Exposed is_list and list_length.
+ Added scheme_register_foreign_func_list and declarations for it (tehom)
+ Defined *compile-hook* (tehom)
+
+ Other changes:
+ Updated is_list and list_length to handle circular lists.
+ Nested calling thru C has been made now safer (tehom)
+ Peter Michaux cleaned up port_rep_from_file
+ Added unwind-protect (tehom)
+ Some cleanups to in/outport and Eval_Cycle by Peter Michaux
+ Report error line number (Mostly by Sanel Zukan, back-compatibility by Tehom)
+
+ Contributors:
+ Kevin Cozens, Dimitrios Souflis, Tom Breton, Peter Michaux, Sanel Zukan,
+ and Tony Garnock-Jones.
+
+Version 1.39
+ Bugs fixed:
+ Fix for the load bug
+ Fixed parsing of octal coded characters. Fixes bug #1818018.
+ Added tests for when mk_vector is out of memory. Can't rely on sc->sink.
+ Fix for bug #1794369
+ Finished feature-request 1599947: scheme_apply0 etc return values.
+ Partly provided feature-request 1599947: Expose list_length, eqv, etc
+ Provided feature-request 1599945, Scheme->C->Scheme calling.
+ Fix for bug 1593861 (behavior of is_integer)
+ Fix for bug 1589711
+ Error checking of binding spec syntax in LET and LETREC. The bad syntax
+ was causing a segmentation fault in Linux. Complete fixes for bug #1817986.
+ Error checking of binding spec syntax in LET*
+ Bad syntax was causing core dump in Linux.
+ Fix for nasty gc bug
+
+ R5RS changes:
+ R5RS requires numbers to be of equal value AND of the same type (ie. both
+ exact or inexact) in order to return #t from eqv?. R5RS compliance fix.
+ String output ports now conform to SRFI-6
+
+ Other changes:
+ Drew Yao fixed buffer overflow problems in mk_sharp_const.
+ put OP_T0LVL in charge of reacting to EOF
+ file_push checks array bounds (patch from Ray Lehtiniemi)
+ Changed to always use snprintf (Patch due to Ramiro bsd1628)
+ Updated usage information using text from the Manual.txt file.
+
+Version 1.38
+ Interim release until the rewrite, mostly incorporating modifications
+ from Kevin Cozens. Small addition for Cygwin in the makefile, and
+ modifications by Andrew Guenther for Apple platforms.
+
+Version 1.37
+ Joe Buehler submitted reserve_cells.
+
+Version 1.36
+ Joe Buehler fixed a patch in the allocator.
+ Alexander Shendi moved the comment handling in the scanner, which
+ fixed an obscure bug for which Mike E had provided a patch as well.
+ Kevin Cozens has submitted some fixes and modifications which have
+ not been incorporated yet in their entirety.
+
+Version 1.35
+ Todd Showalter discovered that the number of free cells reported
+ after GC was incorrect, which could also cause unnecessary allocations.
+
+Version 1.34
+ Long missing version. Lots of bugfixes have accumulated in my email, so
+ I had to start using them. In this version, Keenan Pepper has submitted
+ a bugfix for the string comparison library procedure, Wouter Boeke
+ modified some code that was casting to the wrong type and crashed on
+ some machines, "SheppardCo" submitted a replacement "modulo" code and
+ Scott Fenton submitted lots of corrections that shut up some compiler
+ warnings. Brian Maher submitted instructions on how to build on OS-X.
+ I have to dig deeper into my mailbox and find earlier emails, too.
+
+Version 1.33
+ Charles Hayden fixed a nasty GC bug of the new stack frame, while in
+ the process of porting TinyScheme to C++. He also submitted other
+ changes, and other people also had comments or requests, but the GC
+ bug was so important that this version is put through the door to
+ correct it.
+
+Version 1.32
+ Stephen Gildea put some quality time on TinyScheme again, and made
+ a whole lot of changes to the interpreter that made it noticeably
+ faster.
+
+Version 1.31
+ Patches to the hastily-done version 1.30. Stephen Gildea fixed
+ some things done wrongly, and Richard Russo fixed the makefile
+ for building on Windows. Property lists (heritage from MiniScheme)
+ are now optional and have dissappeared from the interface. They
+ should be considered as deprecated.
+
+Version 1.30
+ After many months, I followed Preston Bannister's advice of
+ using macros and a single source text to keep the enums and the
+ dispatch table in sync, and I used his contributed "opdefines.h".
+ Timothy Downs contributed a helpful function, "scheme_call".
+ Stephen Gildea contributed new versions of the makefile and
+ practically all other sources. He created a built-in STRING-APPEND,
+ and fixed a lot of other bugs.
+ Ruhi Bloodworth reported fixes necessary for OS X and a small
+ bug in dynload.c.
+
+Version 1.29
+ The previous version contained a lot of corrections, but there
+ were a lot more that still wait on a sheet of paper lost in a
+ carton someplace after my house move... Manuel Heras-Gilsanz
+ noticed this and resent his own contribution, which relies on
+ another bugfix that v.1.28 was missing: a problem with string
+ output, that this version fixes. I hope other people will take
+ the time to resend their contributions, if they didn't make it
+ to v.1.28.
+
+Version 1.28
+ Many people have contacted me with bugfixes or remarks in
+ the three months I was inactive. A lot of them spotted that
+ scheme_deinit crashed while reporting gc results. They suggested
+ that sc->outport be set to NIL in scheme_deinit, which I did.
+ Dennis Taylor remarked that OP_VALUEPRINT reset sc->value instead
+ of preserving it. He submitted a modification which I adopted
+ partially. David Hovemeyer sent me many little changes, that you
+ will find in version 1.28, and Partice Stoessel modified the
+ float reader to conform to R5RS.
+
+Version 1.27
+ Version 1.27 is the successor of 1.25. Bug fixes only, but I had to
+ release them so that everybody can profit. 'Backchar' tried to write
+ back to the string, which obviously didn't work for const strings.
+ 'Substring' didn't check for crossed start and end indices. Defines
+ changed to restore the ability to compile under MSVC.
+
+Version 1.26
+ Version 1.26 was never released. I changed a lot of things, in fact
+ too much, even the garbage collector, and hell broke loose. I'll
+ try a more gradual approach next time.
+
+Version 1.25
+ Types have been homogenized to be able to accomodate a different
+ representation. Plus, promises are no longer closures. Unfortunately,
+ I discovered that continuations and force/delay do not pass the SCM
+ test (and never did)... However, on the bright side, what little
+ modifications I did had a large impact on the footprint:
+ USE_NO_FEATURES now produces an object file of 63960 bytes on Linux!
+
+Version 1.24
+ SCM tests now pass again after change in atom2str.
+
+Version 1.23
+ Finally I managed to mess it up with my version control. Version
+ 1.22 actually lacked some of the things I have been fixing in the
+ meantime. This should be considered as a complete replacement for
+ 1.22.
+
+Version 1.22
+ The new ports had a bug in LOAD. MK_CLOSURE is introduced.
+ Shawn Wagner inquired about string->number and number->string.
+ I added string->atom and atom->string and defined the number
+ functions from them. Doing that, I fixed WRITE applied to symbols
+ (it didn't quote them). Unfortunately, minimum build is now
+ slightly larger than 64k... I postpone action because Jason's idea
+ might solve it elegantly.
+
+Version 1.21
+ Jason Felice submitted a radically different datatype representation
+ which he had implemented. While discussing its pros and cons, it
+ became apparent that the current implementation of ports suffered
+ from a grave fault: ports were not garbage-collected. I changed the
+ ports to be heap-allocated, which enabled the use of string ports
+ for loading. Jason also fixed errors in the garbage collection of
+ vectors. USE_VERBATIM is gone. "ssp_compiler.c" has a better solution
+ on HTML generation. A bug involving backslash notation in strings
+ has been fixed. '-c' flag now executes next argument as a stream of
+ Scheme commands. Foreign functions are now also heap allocated,
+ and scheme_define is used to define everything.
+
+Version 1.20
+ Tracing has been added. The toplevel loop has been slightly
+ rearranged. Backquote reading for vector templates has been
+ sanitized. Symbol interning is now correct. Arithmetic functions
+ have been corrected. APPLY, MAP, FOR-EACH, numeric comparison
+ functions fixed. String reader/writer understands \xAA notation.
+
+Version 1.19
+ Carriage Return now delimits identifiers. DOS-formatted Scheme files
+ can be used by Unix. Random number generator added to library.
+ Fixed some glitches of the new type-checking scheme. Fixed erroneous
+ (append '() 'a) behavior. Will continue with r4rstest.scm to
+ fix errors.
+
+Version 1.18
+ The FFI has been extended. USE_VERBOSE_GC has gone. Anyone wanting
+ the same functionality can put (gcverbose #t) in init.scm.
+ print-width was removed, along with three corresponding op-codes.
+ Extended character constants with ASCII names were added.
+ mk_counted_string paves the way for full support of binary strings.
+ As much as possible of the type-checking chores were delegated
+ to the inner loop, thus reducing the code size to less than 4200 loc!
+
+Version 1.17
+ Dynamically-loaded extensions are more fully integrated.
+ TinyScheme is now distributed under the BSD open-source license.
+
+Version 1.16
+ Dynamically-loaded extensions introduced (USE_DL).
+ Santeri Paavolainen found a race condition: When a cons is executed,
+ and each of the two arguments is a constructing function, GC could
+ happen before all arguments are evaluated and cons() is called, and
+ the evaluated arguments would all be reclaimed!
+ Fortunately, such a case was rare in the code, although it is
+ a pitfall in new code and code in foreign functions. Currently, only
+ one such case remains, when COLON_HOOK is defined.
+
+Version 1.15
+ David Gould also contributed some changes that speed up operation.
+ Kirk Zurell fixed HASPROP.
+ The Garbage Collection didn't collect all the garbage...fixed.
+
+Version 1.14
+ Unfortunately, after Andre fixed the GC it became obvious that the
+ algorithm was too slow... Fortunately, David Gould found a way to
+ speed it up.
+
+Version 1.13
+ Silly bug involving division by zero resolved by Roland Kaufman.
+ Macintoch support from Shmulik Regev.
+ Float parser bug fixed by Alexander Shendi.
+ GC bug from Andru Luvisi.
+
+Version 1.12
+ Cis* incorrectly called isalpha() instead of isascii()
+ Added USE_CHAR_CLASSIFIERS, USE_STRING_PORTS.
+
+Version 1.11
+ BSDI defines isnumber... changed all similar functions to is_*
+ EXPT now has correct definition. Added FLOOR,CEILING,TRUNCATE
+ and ROUND, courtesy of Bengt Kleberg. Preprocessor symbols now
+ have values 1 or 0, and can be set as compiler defines (proposed
+ by Andy Ganor *months* ago). 'prompt' and 'InitFile' can now be
+ defined during compilation, too.
+
+Version 1.10
+ Another bug when file ends with comment!
+ Added DEFINE-MACRO in init.scm, courtesy of Andy Gaynor.
+
+Version 1.09
+ Removed bug when READ met EOF. lcm.
+
+Version 1.08
+ quotient,remainder and modulo. gcd.
+
+Version 1.07
+ '=>' in cond now exists
+ list? now checks for circularity
+ some reader bugs removed
+ Reader is more consistent wrt vectors
+ Quote and Quasiquote work with vectors
+
+Version 1.06
+ #! is now skipped
+ generic-assoc bug removed
+ strings are now managed differently, hack.txt is removed
+ various delicate points fixed
+
+Version 1.05
+ Support for scripts, *args*, "-1" option.
+ Various R5RS procedures.
+ *sharp-hook*
+ Handles unmatched parentheses.
+ New architecture for procedures.
+
+Version 1.04
+ Added missing T_ATOM bits...
+ Added vectors
+ Free-list is sorted by address, since vectors need consecutive cells.
+ (quit <exitcode>) for use with scripts
+
+Version 1.03 (26 Aug 1998):
+ Extended .h with useful functions for FFI
+ Library: with-input-* etc.
+ Finished R5RS I/O, added string ports.
+
+Version 1.02 (25 Aug 1998):
+ First part of R5RS I/O.
diff --git a/tinyscheme/Manual.txt b/tinyscheme/Manual.txt
index 77bea11..e395e79 100644
--- a/tinyscheme/Manual.txt
+++ b/tinyscheme/Manual.txt
@@ -1,12 +1,12 @@
- TinySCHEME Version 1.38
+ TinySCHEME Version 1.40
"Safe if used as prescribed"
-- Philip K. Dick, "Ubik"
This software is open source, covered by a BSD-style license.
-Please read accompanying file COPYING.
+Please read accompanying file COPYING.
-------------------------------------------------------------------------------
This Scheme interpreter is based on MiniSCHEME version 0.85k4
@@ -31,7 +31,7 @@ Please read accompanying file COPYING.
coexist in the same program, without any interference between them.
Programmatically, foreign functions in C can be added and values
can be defined in the Scheme environment. Being a quite small program,
- it is easy to comprehend, get to grips with, and use.
+ it is easy to comprehend, get to grips with, and use.
Known bugs
----------
@@ -47,7 +47,7 @@ Please read accompanying file COPYING.
Maybe (a subset of) SLIB will work with TinySCHEME...
- Decent debugging facilities are missing. Only tracing is supported
+ Decent debugging facilities are missing. Only tracing is supported
natively.
@@ -158,7 +158,7 @@ Please read accompanying file COPYING.
14 #\so 31 #\us
15 #\si
16 #\dle 127 #\del
-
+
Numeric literals support #x #o #b and #d. Flonums are currently read only
in decimal notation. Full grammar will be supported soon.
@@ -180,9 +180,9 @@ Please read accompanying file COPYING.
Also open-input-output-file, set-input-port, set-output-port (not R5RS)
Library: call-with-input-file, call-with-output-file,
with-input-from-file, with-output-from-file and
- with-input-output-from-to-files, close-port and input-output-port?
+ with-input-output-from-to-files, close-port and input-output-port?
(not R5RS).
- String Ports: open-input-string, open-output-string,
+ String Ports: open-input-string, open-output-string, get-output-string,
open-input-output-string. Strings can be used with I/O routines.
Vectors
@@ -227,8 +227,11 @@ Please read accompanying file COPYING.
Dynamically-loaded extensions
(load-extension <filename without extension>)
- Loads a DLL declaring foreign procedures.
-
+ Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use
+ of the ld.so.conf file or the LD_RUN_PATH system variable in order to place
+ the library in a directory other than the current one. Please refer to the
+ appropriate 'man' page.
+
Esoteric procedures
(oblist)
Returns the oblist, an immutable list of all the symbols.
@@ -253,23 +256,23 @@ Please read accompanying file COPYING.
Makes a new closure in the given environment.
Obsolete procedures
- (print-width <object>)
-
+ (print-width <object>)
+
Programmer's Reference
----------------------
The interpreter state is initialized with "scheme_init".
Custom memory allocation routines can be installed with an alternate
- initialization function: "scheme_init_custom_alloc".
+ initialization function: "scheme_init_custom_alloc".
Files can be loaded with "scheme_load_file". Strings containing Scheme
- code can be loaded with "scheme_load_string". It is a good idea to
+ code can be loaded with "scheme_load_string". It is a good idea to
"scheme_load" init.scm before anything else.
External data for keeping external state (of use to foreign functions)
can be installed with "scheme_set_external_data".
- Foreign functions are installed with "assign_foreign". Additional
- definitions can be added to the interpreter state, with "scheme_define"
- (this is the way HTTP header data and HTML form data are passed to the
+ Foreign functions are installed with "assign_foreign". Additional
+ definitions can be added to the interpreter state, with "scheme_define"
+ (this is the way HTTP header data and HTML form data are passed to the
Scheme script in the Altera SQL Server). If you wish to define the
foreign function in a specific environment (to enhance modularity),
use "assign_foreign_env".
@@ -292,7 +295,7 @@ Please read accompanying file COPYING.
established standard, this library is supposed to be installed in
a directory mirroring its name under the TinyScheme location.
-
+
Foreign Functions
-----------------
@@ -309,13 +312,13 @@ Please read accompanying file COPYING.
return sc->NIL;
}
- Foreign functions are now defined as closures:
+ Foreign functions are now defined as closures:
- sc->interface->scheme_define(
- sc,
- sc->global_env,
- sc->interface->mk_symbol(sc,"square"),
- sc->interface->mk_foreign_func(sc, square));
+ sc->interface->scheme_define(
+ sc,
+ sc->global_env,
+ sc->interface->mk_symbol(sc,"square"),
+ sc->interface->mk_foreign_func(sc, square));
Foreign functions can use the external data in the "scheme" struct
@@ -330,8 +333,8 @@ Please read accompanying file COPYING.
Standalone
----------
- Usage: tinyscheme -?
- or: tinyscheme [<file1> <file2> ...]
+ Usage: tinyscheme -?
+ or: tinyscheme [<file1> <file2> ...]
followed by
-1 <file> [<arg1> <arg2> ...]
-c <Scheme commands> [<arg1> <arg2> ...]
diff --git a/tinyscheme/dynload.c b/tinyscheme/dynload.c
index 6541b1c..6440a13 100644
--- a/tinyscheme/dynload.c
+++ b/tinyscheme/dynload.c
@@ -13,8 +13,8 @@
# define MAXPATHLEN 1024
#endif
-static void make_filename(const char *name, char *filename);
-static void make_init_fn(const char *name, char *init_fn);
+static void make_filename(const char *name, char *filename);
+static void make_init_fn(const char *name, char *init_fn);
#ifdef _WIN32
# include <windows.h>
@@ -28,27 +28,27 @@ typedef void (*FARPROC)();
#define PREFIX ""
#define SUFFIX ".dll"
- static void display_w32_error_msg(const char *additional_message)
- {
- LPVOID msg_buf;
-
- FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
- NULL, GetLastError(), 0,
- (LPTSTR)&msg_buf, 0, NULL);
- fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf);
- LocalFree(msg_buf);
- }
+ static void display_w32_error_msg(const char *additional_message)
+ {
+ LPVOID msg_buf;
+
+ FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
+ NULL, GetLastError(), 0,
+ (LPTSTR)&msg_buf, 0, NULL);
+ fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf);
+ LocalFree(msg_buf);
+ }
static HMODULE dl_attach(const char *module) {
HMODULE dll = LoadLibrary(module);
- if (!dll) display_w32_error_msg(module);
- return dll;
+ if (!dll) display_w32_error_msg(module);
+ return dll;
}
static FARPROC dl_proc(HMODULE mo, const char *proc) {
- FARPROC procedure = GetProcAddress(mo,proc);
- if (!procedure) display_w32_error_msg(proc);
- return procedure;
+ FARPROC procedure = GetProcAddress(mo,proc);
+ if (!procedure) display_w32_error_msg(proc);
+ return procedure;
}
static void dl_detach(HMODULE mo) {
@@ -65,7 +65,7 @@ static void dl_detach(HMODULE mo) {
static HMODULE dl_attach(const char *module) {
HMODULE so=dlopen(module,RTLD_LAZY);
if(!so) {
- fprintf(stderr, "Error loading scheme extension \"%s\": %s\n", module, dlerror());
+ fprintf(stderr, "Error loading scheme extension \"%s\": %s\n", module, dlerror());
}
return so;
}
@@ -93,11 +93,11 @@ pointer scm_load_ext(scheme *sc, pointer args)
char *name;
HMODULE dll_handle;
void (*module_init)(scheme *sc);
-
+
if ((args != sc->NIL) && is_string((first_arg = pair_car(args)))) {
name = string_value(first_arg);
- make_filename(name,filename);
- make_init_fn(name,init_fn);
+ make_filename(name,filename);
+ make_init_fn(name,init_fn);
dll_handle = dl_attach(filename);
if (dll_handle == 0) {
retval = sc -> F;
@@ -116,14 +116,14 @@ pointer scm_load_ext(scheme *sc, pointer args)
else {
retval = sc -> F;
}
-
+
return(retval);
}
static void make_filename(const char *name, char *filename) {
strcpy(filename,name);
strcat(filename,SUFFIX);
-}
+}
static void make_init_fn(const char *name, char *init_fn) {
const char *p=strrchr(name,'/');
@@ -135,9 +135,3 @@ static void make_init_fn(const char *name, char *init_fn) {
strcpy(init_fn,"init_");
strcat(init_fn,p);
}
-
-
-
-
-
-
diff --git a/tinyscheme/init.scm b/tinyscheme/init.scm
index bdf15b1..120ecc7 100644
--- a/tinyscheme/init.scm
+++ b/tinyscheme/init.scm
@@ -1,4 +1,4 @@
-; Initialization file for TinySCHEME 1.38
+; Initialization file for TinySCHEME 1.40
; Per R5RS, up to four deep compositions should be defined
(define (caar x) (car (car x)))
@@ -30,6 +30,18 @@
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+;;;; Utility to ease macro creation
+(define (macro-expand form)
+ ((eval (get-closure-code (eval (car form)))) form))
+
+(define (macro-expand-all form)
+ (if (macro? form)
+ (macro-expand-all (macro-expand form))
+ form))
+
+(define *compile-hook* macro-expand-all)
+
+
(macro (unless form)
`(if (not ,(cadr form)) (begin ,@(cddr form))))
@@ -58,24 +70,42 @@
(define (abs n) (if (>= n 0) n (- n)))
(define (exact->inexact n) (* n 1.0))
(define (<> n1 n2) (not (= n1 n2)))
+
+; min and max must return inexact if any arg is inexact; use (+ n 0.0)
(define (max . lst)
- (foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst)))
+ (foldr (lambda (a b)
+ (if (> a b)
+ (if (exact? b) a (+ a 0.0))
+ (if (exact? a) b (+ b 0.0))))
+ (car lst) (cdr lst)))
(define (min . lst)
- (foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst)))
+ (foldr (lambda (a b)
+ (if (< a b)
+ (if (exact? b) a (+ a 0.0))
+ (if (exact? a) b (+ b 0.0))))
+ (car lst) (cdr lst)))
+
(define (succ x) (+ x 1))
(define (pred x) (- x 1))
-(define (gcd a b)
- (let ((aa (abs a))
- (bb (abs b)))
- (if (= bb 0)
- aa
- (gcd bb (remainder aa bb)))))
-(define (lcm a b)
- (if (or (= a 0) (= b 0))
- 0
- (abs (* (quotient a (gcd a b)) b))))
+(define gcd
+ (lambda a
+ (if (null? a)
+ 0
+ (let ((aa (abs (car a)))
+ (bb (abs (cadr a))))
+ (if (= bb 0)
+ aa
+ (gcd bb (remainder aa bb)))))))
+(define lcm
+ (lambda a
+ (if (null? a)
+ 1
+ (let ((aa (abs (car a)))
+ (bb (abs (cadr a))))
+ (if (or (= aa 0) (= bb 0))
+ 0
+ (abs (* (quotient aa (gcd aa bb)) bb)))))))
-(define call/cc call-with-current-continuation)
(define (string . charlist)
(list->string charlist))
@@ -110,7 +140,7 @@
(define (string->anyatom str pred)
(let* ((a (string->atom str)))
(if (pred a) a
- (error "string->xxx: not a xxx" a))))
+ (error "string->xxx: not a xxx" a))))
(define (string->number str) (string->anyatom str number?))
@@ -118,9 +148,9 @@
(if (pred n)
(atom->string n)
(error "xxx->string: not a xxx" n)))
-
-(define (number->string n) (anyatom->string n number?))
+
+(define (number->string n) (anyatom->string n number?))
(define (char-cmp? cmp a b)
(cmp (char->integer a) (char->integer b)))
@@ -180,31 +210,31 @@
(if (null? lists)
(cons cars cdrs)
(let ((car1 (caar lists))
- (cdr1 (cdar lists)))
- (unzip1-with-cdr-iterative
- (cdr lists)
- (append cars (list car1))
- (append cdrs (list cdr1))))))
+ (cdr1 (cdar lists)))
+ (unzip1-with-cdr-iterative
+ (cdr lists)
+ (append cars (list car1))
+ (append cdrs (list cdr1))))))
(define (map proc . lists)
(if (null? lists)
(apply proc)
(if (null? (car lists))
- '()
- (let* ((unz (apply unzip1-with-cdr lists))
- (cars (car unz))
- (cdrs (cdr unz)))
- (cons (apply proc cars) (apply map (cons proc cdrs)))))))
+ '()
+ (let* ((unz (apply unzip1-with-cdr lists))
+ (cars (car unz))
+ (cdrs (cdr unz)))
+ (cons (apply proc cars) (apply map (cons proc cdrs)))))))
(define (for-each proc . lists)
(if (null? lists)
(apply proc)
(if (null? (car lists))
- #t
- (let* ((unz (apply unzip1-with-cdr lists))
- (cars (car unz))
- (cdrs (cdr unz)))
- (apply proc cars) (apply map (cons proc cdrs))))))
+ #t
+ (let* ((unz (apply unzip1-with-cdr lists))
+ (cars (car unz))
+ (cdrs (cdr unz)))
+ (apply proc cars) (apply map (cons proc cdrs))))))
(define (list-tail x k)
(if (zero? k)
@@ -306,6 +336,116 @@
(foo level (cdr form)))))))))
(foo 0 (car (cdr l)))))
+;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom)
+(define (shared-tail x y)
+ (let ((len-x (length x))
+ (len-y (length y)))
+ (define (shared-tail-helper x y)
+ (if
+ (eq? x y)
+ x
+ (shared-tail-helper (cdr x) (cdr y))))
+
+ (cond
+ ((> len-x len-y)
+ (shared-tail-helper
+ (list-tail x (- len-x len-y))
+ y))
+ ((< len-x len-y)
+ (shared-tail-helper
+ x
+ (list-tail y (- len-y len-x))))
+ (#t (shared-tail-helper x y)))))
+
+;;;;;Dynamic-wind by Tom Breton (Tehom)
+
+;;Guarded because we must only eval this once, because doing so
+;;redefines call/cc in terms of old call/cc
+(unless (defined? 'dynamic-wind)
+ (let
+ ;;These functions are defined in the context of a private list of
+ ;;pairs of before/after procs.
+ ( (*active-windings* '())
+ ;;We'll define some functions into the larger environment, so
+ ;;we need to know it.
+ (outer-env (current-environment)))
+
+ ;;Poor-man's structure operations
+ (define before-func car)
+ (define after-func cdr)
+ (define make-winding cons)
+
+ ;;Manage active windings
+ (define (activate-winding! new)
+ ((before-func new))
+ (set! *active-windings* (cons new *active-windings*)))
+ (define (deactivate-top-winding!)
+ (let ((old-top (car *active-windings*)))
+ ;;Remove it from the list first so it's not active during its
+ ;;own exit.
+ (set! *active-windings* (cdr *active-windings*))
+ ((after-func old-top))))
+
+ (define (set-active-windings! new-ws)
+ (unless (eq? new-ws *active-windings*)
+ (let ((shared (shared-tail new-ws *active-windings*)))
+
+ ;;Define the looping functions.
+ ;;Exit the old list. Do deeper ones last. Don't do
+ ;;any shared ones.
+ (define (pop-many)
+ (unless (eq? *active-windings* shared)
+ (deactivate-top-winding!)
+ (pop-many)))
+ ;;Enter the new list. Do deeper ones first so that the
+ ;;deeper windings will already be active. Don't do any
+ ;;shared ones.
+ (define (push-many new-ws)
+ (unless (eq? new-ws shared)
+ (push-many (cdr new-ws))
+ (activate-winding! (car new-ws))))
+
+ ;;Do it.
+ (pop-many)
+ (push-many new-ws))))
+
+ ;;The definitions themselves.
+ (eval
+ `(define call-with-current-continuation
+ ;;It internally uses the built-in call/cc, so capture it.
+ ,(let ((old-c/cc call-with-current-continuation))
+ (lambda (func)
+ ;;Use old call/cc to get the continuation.
+ (old-c/cc
+ (lambda (continuation)
+ ;;Call func with not the continuation itself
+ ;;but a procedure that adjusts the active
+ ;;windings to what they were when we made
+ ;;this, and only then calls the
+ ;;continuation.
+ (func
+ (let ((current-ws *active-windings*))
+ (lambda (x)
+ (set-active-windings! current-ws)
+ (continuation x)))))))))
+ outer-env)
+ ;;We can't just say "define (dynamic-wind before thunk after)"
+ ;;because the lambda it's defined to lives in this environment,
+ ;;not in the global environment.
+ (eval
+ `(define dynamic-wind
+ ,(lambda (before thunk after)
+ ;;Make a new winding
+ (activate-winding! (make-winding before after))
+ (let ((result (thunk)))
+ ;;Get rid of the new winding.
+ (deactivate-top-winding!)
+ ;;The return value is that of thunk.
+ result)))
+ outer-env)))
+
+(define call/cc call-with-current-continuation)
+
;;;;; atom? and equal? written by a.k
@@ -385,10 +525,6 @@
(define (acons x y z) (cons (cons x y) z))
-;;;; Utility to ease macro creation
-(define (macro-expand form)
- ((eval (get-closure-code (eval (car form)))) form))
-
;;;; Handy for imperative programs
;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
(macro (define-with-return form)
@@ -453,8 +589,8 @@
(let* ((env (if (null? envl) (current-environment) (eval (car envl))))
(xval (eval x env)))
(if (closure? xval)
- (make-closure (get-closure-code xval) env)
- xval)))
+ (make-closure (get-closure-code xval) env)
+ xval)))
; Redefine this if you install another package infrastructure
; Also redefine 'package'
@@ -466,7 +602,7 @@
(and (input-port? p) (output-port? p)))
(define (close-port p)
- (cond
+ (cond
((input-output-port? p) (close-input-port (close-output-port p)))
((input-port? p) (close-input-port p))
((output-port? p) (close-output-port p))
@@ -539,7 +675,7 @@
(* (quotient *seed* q) r)))
(if (< *seed* 0) (set! *seed* (+ *seed* m)))
*seed*))
-;; SRFI-0
+;; SRFI-0
;; COND-EXPAND
;; Implemented as a macro
(define *features* '(srfi-0))
@@ -561,16 +697,17 @@
(foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
(define (cond-eval condition)
- (cond ((symbol? condition)
- (if (member condition *features*) #t #f))
- ((eq? condition #t) #t)
- ((eq? condition #f) #f)
- (else (case (car condition)
- ((and) (cond-eval-and (cdr condition)))
- ((or) (cond-eval-or (cdr condition)))
- ((not) (if (not (null? (cddr condition)))
- (error "cond-expand : 'not' takes 1 argument")
- (not (cond-eval (cadr condition)))))
- (else (error "cond-expand : unknown operator" (car condition)))))))
+ (cond
+ ((symbol? condition)
+ (if (member condition *features*) #t #f))
+ ((eq? condition #t) #t)
+ ((eq? condition #f) #f)
+ (else (case (car condition)
+ ((and) (cond-eval-and (cdr condition)))
+ ((or) (cond-eval-or (cdr condition)))
+ ((not) (if (not (null? (cddr condition)))
+ (error "cond-expand : 'not' takes 1 argument")
+ (not (cond-eval (cadr condition)))))
+ (else (error "cond-expand : unknown operator" (car condition)))))))
(gc-verbose #f)
diff --git a/tinyscheme/opdefines.h b/tinyscheme/opdefines.h
index 57c5433..3101eef 100644
--- a/tinyscheme/opdefines.h
+++ b/tinyscheme/opdefines.h
@@ -17,6 +17,7 @@
#endif
_OP_DEF(opexe_0, 0, 0, 0, 0,
OP_DOMACRO )
_OP_DEF(opexe_0, 0, 0, 0, 0,
OP_LAMBDA )
+ _OP_DEF(opexe_0, 0, 0, 0, 0,
OP_LAMBDA1 )
_OP_DEF(opexe_0, "make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT,
OP_MKCLOSURE )
_OP_DEF(opexe_0, 0, 0, 0, 0,
OP_QUOTE )
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF0
)
@@ -131,7 +132,6 @@
_OP_DEF(opexe_3, "list?", 1, 1, TST_ANY,
OP_LISTP )
_OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP
)
_OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY,
OP_VECTORP )
- _OP_DEF(opexe_3, "array?", 1, 1, TST_ANY,
OP_ARRAYP )
_OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ
)
_OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV
)
_OP_DEF(opexe_4, "force", 1, 1, TST_ANY,
OP_FORCE )
@@ -142,11 +142,13 @@
_OP_DEF(opexe_4, "newline", 0, 1, TST_OUTPORT,
OP_NEWLINE )
_OP_DEF(opexe_4, "error", 1, INF_ARG, TST_NONE, OP_ERR0
)
_OP_DEF(opexe_4, 0, 0, 0, 0, OP_ERR1
)
- _OP_DEF(opexe_4, "reverse", 1, 1, TST_PAIR,
OP_REVERSE )
+ _OP_DEF(opexe_4, "reverse", 1, 1, TST_LIST,
OP_REVERSE )
_OP_DEF(opexe_4, "list*", 1, INF_ARG, TST_NONE,
OP_LIST_STAR )
_OP_DEF(opexe_4, "append", 0, INF_ARG, TST_NONE,
OP_APPEND )
+#if USE_PLIST
_OP_DEF(opexe_4, "put", 3, 3, TST_NONE, OP_PUT
)
_OP_DEF(opexe_4, "get", 2, 2, TST_NONE, OP_GET
)
+#endif
_OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT
)
_OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC
)
_OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE,
OP_GCVERB )
@@ -159,8 +161,9 @@
_OP_DEF(opexe_4, "open-input-output-file", 1, 1, TST_STRING,
OP_OPEN_INOUTFILE )
#if USE_STRING_PORTS
_OP_DEF(opexe_4, "open-input-string", 1, 1, TST_STRING,
OP_OPEN_INSTRING )
- _OP_DEF(opexe_4, "open-output-string", 1, 1, TST_STRING,
OP_OPEN_OUTSTRING )
_OP_DEF(opexe_4, "open-input-output-string", 1, 1, TST_STRING,
OP_OPEN_INOUTSTRING )
+ _OP_DEF(opexe_4, "open-output-string", 0, 1, TST_STRING,
OP_OPEN_OUTSTRING )
+ _OP_DEF(opexe_4, "get-output-string", 1, 1, TST_OUTPORT,
OP_GET_OUTSTRING )
#endif
_OP_DEF(opexe_4, "close-input-port", 1, 1, TST_INPORT,
OP_CLOSE_INPORT )
_OP_DEF(opexe_4, "close-output-port", 1, 1, TST_OUTPORT,
OP_CLOSE_OUTPORT )
diff --git a/tinyscheme/scheme-private.h b/tinyscheme/scheme-private.h
index 8607a33..08c2e59 100644
--- a/tinyscheme/scheme-private.h
+++ b/tinyscheme/scheme-private.h
@@ -11,8 +11,10 @@ enum scheme_port_kind {
port_free=0,
port_file=1,
port_string=2,
+ port_srfi6=4,
port_input=16,
- port_output=32
+ port_output=32,
+ port_saw_EOF=64
};
typedef struct port {
@@ -21,6 +23,10 @@ typedef struct port {
struct {
FILE *file;
int closeit;
+#if SHOW_ERROR_LINE
+ int curr_line;
+ char *filename;
+#endif
} stdio;
struct {
char *start;
@@ -57,6 +63,7 @@ func_dealloc free;
int retcode;
int tracing;
+
#define CELL_SEGSIZE 25000 /* # of cells in one segment */
#define CELL_NSEGMENT 50 /* # of segments for cells */
char *alloc_seg[CELL_NSEGMENT];
@@ -68,7 +75,6 @@ pointer args; /* register for arguments of function */
pointer envir; /* stack register for current environment */
pointer code; /* register for current code */
pointer dump; /* stack register for next evaluation */
-pointer safe_foreign; /* register to avoid gc problems */
pointer foreign_error; /* used for foreign functions to signal an error */
int interactive_repl; /* are we in an interactive REPL? */
@@ -87,17 +93,20 @@ pointer EOF_OBJ; /* special cell representing end-of-file object */
pointer oblist; /* pointer to symbol table */
pointer global_env; /* pointer to global environment */
+pointer c_nest; /* stack for nested calls from C */
+
/* global pointers to special symbols */
-pointer LAMBDA; /* pointer to syntax lambda */
+pointer LAMBDA; /* pointer to syntax lambda */
pointer QUOTE; /* pointer to syntax quote */
-pointer QQUOTE; /* pointer to symbol quasiquote */
+pointer QQUOTE; /* pointer to symbol quasiquote */
pointer UNQUOTE; /* pointer to symbol unquote */
pointer UNQUOTESP; /* pointer to symbol unquote-splicing */
pointer FEED_TO; /* => */
pointer COLON_HOOK; /* *colon-hook* */
pointer ERROR_HOOK; /* *error-hook* */
-pointer SHARP_HOOK; /* *sharp-hook* */
+pointer SHARP_HOOK; /* *sharp-hook* */
+pointer COMPILE_HOOK; /* *compile-hook* */
pointer free_cell; /* pointer to top of free cells */
long fcells; /* # of free cells */
@@ -108,7 +117,7 @@ pointer save_inport;
pointer loadport;
#define MAXFIL 64
-port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */
+port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */
int nesting_stack[MAXFIL];
int file_i;
int nesting;
@@ -117,7 +126,9 @@ char gc_verbose; /* if gc_verbose is not zero, print gc status */
char no_memory; /* Whether mem. alloc. has failed */
#define LINESIZE 1024
-char strbuff[LINESIZE];
+char linebuff[LINESIZE];
+#define STRBUFFSIZE 1024
+char strbuff[STRBUFFSIZE];
FILE *tmpfp;
int tok;
@@ -125,7 +136,7 @@ int print_flag;
pointer value;
int op;
-void *ext_data; /* For the benefit of foreign functions */
+void *ext_data; /* For the benefit of foreign functions */
long gensym_cnt;
struct scheme_interface *vptr;
@@ -143,6 +154,9 @@ enum scheme_opcodes {
OP_MAXDEFINED
};
+#ifdef __cplusplus
+extern "C" {
+#endif
#define cons(sc,a,b) _cons(sc,a,b,0)
#define immutable_cons(sc,a,b) _cons(sc,a,b,1)
@@ -161,6 +175,8 @@ gunichar charvalue(pointer p);
int is_vector(pointer p);
int is_port(pointer p);
+int is_inport(pointer p);
+int is_outport(pointer p);
int is_pair(pointer p);
pointer pair_car(pointer p);
@@ -188,4 +204,14 @@ int is_environment(pointer p);
int is_immutable(pointer p);
void setimmutable(pointer p);
+#ifdef __cplusplus
+}
#endif
+
+#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/
diff --git a/tinyscheme/scheme.c b/tinyscheme/scheme.c
index 1ae1683..39c42f4 100644
--- a/tinyscheme/scheme.c
+++ b/tinyscheme/scheme.c
@@ -1,4 +1,4 @@
-/* T I N Y S C H E M E 1 . 3 8
+/* T I N Y S C H E M E 1 . 4 0
* Dimitrios Souflis (dsouflis acm org)
* Based on MiniScheme (original credits follow)
* (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
@@ -17,7 +17,7 @@
/* character strings. As a result, the length of a string in bytes */
/* may not be the same as the length of a string in characters. You */
/* must keep this in mind at all times while making any changes to */
-/* the routines in this file, or when adding new features. */
+/* the routines in this file and when adding new features. */
/* */
/* UTF-8 modifications made by Kevin Cozens (kcozens interlog com) */
/* **************************************************************** */
@@ -30,7 +30,9 @@
#endif
#ifdef WIN32
# include <io.h>
-# define access(f,a) _access(f,a)
+#endif
+#ifdef WIN32
+#define snprintf _snprintf
#endif
#if USE_DL
# include "dynload.h"
@@ -38,12 +40,13 @@
#if USE_MATH
# include <math.h>
#endif
+
#include <limits.h>
#include <float.h>
#include <ctype.h>
#include <string.h>
-#include <libintl.h>
+#include "../tiny-fu/tiny-fu-intl.h"
#include "scheme-private.h"
@@ -90,6 +93,7 @@ ts_output_string (TsOutputType type,
#define TOK_SHARP 10
#define TOK_SHARP_CONST 11
#define TOK_VEC 12
+#define TOK_USCORE 13
# define BACKQUOTE '`'
@@ -97,7 +101,7 @@ ts_output_string (TsOutputType type,
* Basic memory allocation units
*/
-#define banner "TinyScheme 1.38 (with UTF-8 support)"
+#define banner "TinyScheme 1.40 (with UTF-8 support)"
#include <string.h>
#include <stdlib.h>
@@ -131,7 +135,7 @@ static int utf8_stricmp(const char *s1, const char *s2)
#endif
#ifndef prompt
-# define prompt "> "
+# define prompt "ts> "
#endif
#ifndef InitFile
@@ -188,6 +192,9 @@ static int num_le(num a, num b);
static double round_per_R5RS(double x);
#endif
static int is_zero_double(double x);
+static INLINE int num_is_integer(pointer p) {
+ return ((p)->_object._number.is_fixnum);
+}
static num num_zero;
static num num_one;
@@ -200,34 +207,39 @@ INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); }
#define strvalue(p) ((p)->_object._string._svalue)
#define strlength(p) ((p)->_object._string._length)
-INTERFACE static int is_list(scheme *sc, pointer p);
+INTERFACE static int is_list(scheme *sc, pointer a);
INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
INTERFACE static void fill_vector(pointer vec, pointer obj);
INTERFACE static pointer vector_elem(pointer vec, int ielem);
INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
INTERFACE INLINE int is_integer(pointer p) {
- return ((p)->_object._number.is_fixnum);
+ if (!is_number(p))
+ return 0;
+ if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
+ return 1;
+ return 0;
}
+
INTERFACE INLINE int is_real(pointer p) {
- return (!(p)->_object._number.is_fixnum);
+ return is_number(p) && (!(p)->_object._number.is_fixnum);
}
INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
INTERFACE INLINE int string_length(pointer p) { return strlength(p); }
INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
INLINE num nvalue(pointer p) { return ((p)->_object._number); }
-INTERFACE long ivalue(pointer p) { return
(is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
-INTERFACE double rvalue(pointer p) { return
(!is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
+INTERFACE long ivalue(pointer p) { return
(num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
+INTERFACE double rvalue(pointer p) { return
(!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue)
#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue)
-#define set_integer(p) (p)->_object._number.is_fixnum=1;
-#define set_real(p) (p)->_object._number.is_fixnum=0;
+#define set_num_integer(p) (p)->_object._number.is_fixnum=1;
+#define set_num_real(p) (p)->_object._number.is_fixnum=0;
INTERFACE gunichar charvalue(pointer p) { return (gunichar)ivalue_unchecked(p); }
INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); }
-#define is_inport(p) (type(p)==T_PORT && p->_object._port->kind&port_input)
-#define is_outport(p) (type(p)==T_PORT && p->_object._port->kind&port_output)
+INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; }
+INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); }
#define car(p) ((p)->_object._cons._car)
@@ -283,6 +295,7 @@ INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
#define cddr(p) cdr(cdr(p))
#define cadar(p) car(cdr(car(p)))
#define caddr(p) car(cdr(cdr(p)))
+#define cdaar(p) cdr(car(car(p)))
#define cadaar(p) car(cdr(car(car(p))))
#define cadddr(p) car(cdr(cdr(cdr(p))))
#define cddddr(p) cdr(cdr(cdr(cdr(p))))
@@ -372,7 +385,6 @@ static void finalize_cell(scheme *sc, pointer a);
static int count_consecutive_cells(pointer x, int needed);
static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
static pointer mk_number(scheme *sc, num n);
-static pointer mk_empty_string(scheme *sc, int len, gunichar fill);
static char *store_string(scheme *sc, int len, const char *str, gunichar fill);
static pointer mk_vector(scheme *sc, int len);
static pointer mk_atom(scheme *sc, char *q);
@@ -387,11 +399,12 @@ static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, i
static void port_close(scheme *sc, pointer p, int flag);
static void mark(pointer a);
static void gc(scheme *sc, pointer a, pointer b);
+static gunichar basic_inchar(port *pt);
static gunichar inchar(scheme *sc);
static void backchar(scheme *sc, gunichar c);
static char *readstr_upto(scheme *sc, char *delim);
static pointer readstrexp(scheme *sc);
-static INLINE void skipspace(scheme *sc);
+static INLINE int skipspace(scheme *sc);
static int token(scheme *sc);
static void printslashstring(scheme *sc, char *s, int len);
static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
@@ -401,9 +414,10 @@ static pointer mk_closure(scheme *sc, pointer c, pointer e);
static pointer mk_continuation(scheme *sc, pointer d);
static pointer reverse(scheme *sc, pointer a);
static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
-static pointer append(scheme *sc, pointer a, pointer b);
-static int list_length(scheme *sc, pointer a);
-static int eqv(pointer a, pointer b);
+static pointer revappend(scheme *sc, pointer a, pointer b);
+int list_length(scheme *sc, pointer a);
+int eqv(pointer a, pointer b);
+
static INLINE void dump_stack_mark(scheme *);
static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
@@ -417,9 +431,6 @@ static void assign_syntax(scheme *sc, char *name);
static int syntaxnum(pointer p);
static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
scheme *scheme_init_new(void);
-#if !STANDALONE
-void scheme_call(scheme *sc, pointer func, pointer args);
-#endif
#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
@@ -486,7 +497,7 @@ static num num_rem(num a, num b) {
e1=num_ivalue(a);
e2=num_ivalue(b);
res=e1%e2;
- /* modulo should have same sign as second operand */
+ /* remainder should have same sign as second operand */
if (res > 0) {
if (e1 < 0) {
res -= labs(e2);
@@ -507,13 +518,9 @@ static num num_mod(num a, num b) {
e1=num_ivalue(a);
e2=num_ivalue(b);
res=e1%e2;
- if(res*e2<0) { /* modulo should have same sign as second operand */
- e2=labs(e2);
- if(res>0) {
- res-=e2;
- } else {
- res+=e2;
- }
+ /* modulo should have same sign as second operand */
+ if (res * e2 < 0) {
+ res+=e2;
}
ret.value.ivalue=res;
return ret;
@@ -621,7 +628,7 @@ static int alloc_cellseg(scheme *sc, int n) {
i = ++sc->last_cell_seg ;
sc->alloc_seg[i] = cp;
/* adjust in TYPE_BITS-bit boundary */
- if (((unsigned long) cp) % adj != 0) {
+ if(((unsigned long)cp)%adj!=0) {
cp=(char*)(adj*((unsigned long)cp/adj+1));
}
/* insert new segment in address order */
@@ -654,7 +661,7 @@ static int alloc_cellseg(scheme *sc, int n) {
return n;
}
-static INLINE pointer get_cell(scheme *sc, pointer a, pointer b) {
+static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
if (sc->free_cell != sc->NIL) {
pointer x = sc->free_cell;
sc->free_cell = cdr(x);
@@ -674,8 +681,9 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) {
}
if (sc->free_cell == sc->NIL) {
+ const int min_to_be_recovered = sc->last_cell_seg*8;
gc(sc,a, b);
- if (sc->fcells < sc->last_cell_seg*8
+ if (sc->fcells < min_to_be_recovered
|| sc->free_cell == sc->NIL) {
/* if only a few recovered, get more to avoid fruitless gc's */
if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
@@ -719,31 +727,30 @@ static pointer reserve_cells(scheme *sc, int n) {
static pointer get_consecutive_cells(scheme *sc, int n) {
pointer x;
- if(sc->no_memory) {
- return sc->sink;
- }
+ if(sc->no_memory) { return sc->sink; }
/* Are there any cells available? */
x=find_consecutive_cells(sc,n);
- if (x == sc->NIL) {
- /* If not, try gc'ing some */
- gc(sc, sc->NIL, sc->NIL);
- x=find_consecutive_cells(sc,n);
- if (x == sc->NIL) {
- /* If there still aren't, try getting more heap */
- if (!alloc_cellseg(sc,1)) {
- sc->no_memory=1;
- return sc->sink;
- }
- }
- x=find_consecutive_cells(sc,n);
- if (x == sc->NIL) {
- /* If all fail, report failure */
+ if (x != sc->NIL) { return x; }
+
+ /* If not, try gc'ing some */
+ gc(sc, sc->NIL, sc->NIL);
+ x=find_consecutive_cells(sc,n);
+ if (x != sc->NIL) { return x; }
+
+ /* If there still aren't, try getting more heap */
+ if (!alloc_cellseg(sc,1))
+ {
sc->no_memory=1;
return sc->sink;
}
- }
- return (x);
+
+ x=find_consecutive_cells(sc,n);
+ if (x != sc->NIL) { return x; }
+
+ /* If all fail, report failure */
+ sc->no_memory=1;
+ return sc->sink;
}
static int count_consecutive_cells(pointer x, int needed) {
@@ -774,6 +781,76 @@ static pointer find_consecutive_cells(scheme *sc, int n) {
return sc->NIL;
}
+/* To retain recent allocs before interpreter knows about them -
+ Tehom */
+
+static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
+{
+ pointer holder = get_cell_x(sc, recent, extra);
+ typeflag(holder) = T_PAIR | T_IMMUTABLE;
+ car(holder) = recent;
+ cdr(holder) = car(sc->sink);
+ car(sc->sink) = holder;
+}
+
+
+static pointer get_cell(scheme *sc, pointer a, pointer b)
+{
+ pointer cell = get_cell_x(sc, a, b);
+ /* For right now, include "a" and "b" in "cell" so that gc doesn't
+ think they are garbage. */
+ /* Tentatively record it as a pair so gc understands it. */
+ typeflag(cell) = T_PAIR;
+ car(cell) = a;
+ cdr(cell) = b;
+ push_recent_alloc(sc, cell, sc->NIL);
+ return cell;
+}
+
+static pointer get_vector_object(scheme *sc, int len, pointer init)
+{
+ pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
+ if(sc->no_memory) { return sc->sink; }
+ /* Record it as a vector so that gc understands it. */
+ typeflag(cells) = (T_VECTOR | T_ATOM);
+ ivalue_unchecked(cells)=len;
+ set_num_integer(cells);
+ fill_vector(cells,init);
+ push_recent_alloc(sc, cells, sc->NIL);
+ return cells;
+}
+
+static INLINE void ok_to_freely_gc(scheme *sc)
+{
+ car(sc->sink) = sc->NIL;
+}
+
+
+#if defined TSGRIND
+static void check_cell_alloced(pointer p, int expect_alloced)
+{
+ /* Can't use putstr(sc,str) because callers have no access to
+ sc. */
+ if(typeflag(p) & !expect_alloced)
+ {
+ fprintf(stderr,"Cell is already allocated!\n");
+ }
+ if(!(typeflag(p)) & expect_alloced)
+ {
+ fprintf(stderr,"Cell is not allocated!\n");
+ }
+}
+static void check_range_alloced(pointer p, int n, int expect_alloced)
+{
+ int i;
+ for(i = 0;i<n;i++)
+ { (void)check_cell_alloced(p+i,expect_alloced); }
+}
+
+#endif
+
+/* Medium level cell allocation */
+
/* get new cons cell */
pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
pointer x = get_cell(sc,a, b);
@@ -907,7 +984,7 @@ INTERFACE pointer mk_character(scheme *sc, gunichar c) {
typeflag(x) = (T_CHARACTER | T_ATOM);
ivalue_unchecked(x)= c;
- set_integer(x);
+ set_num_integer(x);
return (x);
}
@@ -917,7 +994,7 @@ INTERFACE pointer mk_integer(scheme *sc, long num) {
typeflag(x) = (T_NUMBER | T_ATOM);
ivalue_unchecked(x)= num;
- set_integer(x);
+ set_num_integer(x);
return (x);
}
@@ -926,7 +1003,7 @@ INTERFACE pointer mk_real(scheme *sc, double n) {
typeflag(x) = (T_NUMBER | T_ATOM);
rvalue_unchecked(x)= n;
- set_real(x);
+ set_num_real(x);
return (x);
}
@@ -938,27 +1015,16 @@ static pointer mk_number(scheme *sc, num n) {
}
}
-void set_safe_foreign (scheme *sc, pointer data) {
- if (sc->safe_foreign == sc->NIL) {
- fprintf (stderr, "get_safe_foreign called outside a foreign function\n");
- } else {
- car (sc->safe_foreign) = data;
- }
-}
-
pointer foreign_error (scheme *sc, const char *s, pointer a) {
- if (sc->safe_foreign == sc->NIL) {
- fprintf (stderr, "set_foreign_error_flag called outside a foreign function\n");
- } else {
- sc->foreign_error = cons (sc, mk_string (sc, s), a);
- }
+ sc->foreign_error = cons (sc, mk_string (sc, s), a);
return sc->T;
}
-
/* char_cnt is length of string in chars. */
/* str points to a NUL terminated string. */
/* Only uses fill_char if str is NULL. */
+/* This routine automatically adds 1 byte */
+/* to allow space for terminating NUL. */
static char *store_string(scheme *sc, int char_cnt,
const char *str, gunichar fill) {
int len;
@@ -975,11 +1041,11 @@ static char *store_string(scheme *sc, int char_cnt,
else
len = q2 - str;
q=(gchar*)sc->malloc(len+1);
- }
- else {
+ } else {
len = g_unichar_to_utf8(fill, utf8);
q=(gchar*)sc->malloc(char_cnt*len+1);
}
+
if(q==0) {
sc->no_memory=1;
return sc->strbuff;
@@ -1004,33 +1070,29 @@ INTERFACE pointer mk_string(scheme *sc, const char *str) {
return mk_counted_string(sc,str,g_utf8_strlen(str, -1));
}
+/* str points to a NUL terminated string. */
/* len is the length of str in characters */
INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
pointer x = get_cell(sc, sc->NIL, sc->NIL);
- strvalue(x) = store_string(sc,len,str,0);
typeflag(x) = (T_STRING | T_ATOM);
+ strvalue(x) = store_string(sc,len,str,0);
strlength(x) = len;
return (x);
}
-static pointer mk_empty_string(scheme *sc, int len, gunichar fill) {
+/* len is the length for the empty string in characters */
+INTERFACE pointer mk_empty_string(scheme *sc, int len, gunichar fill) {
pointer x = get_cell(sc, sc->NIL, sc->NIL);
- strvalue(x) = store_string(sc,len,0,fill);
typeflag(x) = (T_STRING | T_ATOM);
+ strvalue(x) = store_string(sc,len,0,fill);
strlength(x) = len;
return (x);
}
-INTERFACE static pointer mk_vector(scheme *sc, int len) {
- pointer x=get_consecutive_cells(sc,len/2+len%2+1);
- typeflag(x) = (T_VECTOR | T_ATOM);
- ivalue_unchecked(x)=len;
- set_integer(x);
- fill_vector(x,sc->NIL);
- return x;
-}
+INTERFACE static pointer mk_vector(scheme *sc, int len)
+{ return get_vector_object(sc,len,sc->NIL); }
INTERFACE static void fill_vector(pointer vec, pointer obj) {
int i;
@@ -1080,7 +1142,7 @@ INTERFACE pointer gensym(scheme *sc) {
char name[40];
for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
- sprintf(name,"gensym-%ld",sc->gensym_cnt);
+ snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
/* first check oblist */
x = oblist_find_by_name(sc, name);
@@ -1165,21 +1227,21 @@ static pointer mk_atom(scheme *sc, char *q) {
/* make constant */
static pointer mk_sharp_const(scheme *sc, char *name) {
long x;
- char tmp[256];
+ char tmp[STRBUFFSIZE];
if (!strcmp(name, "t"))
return (sc->T);
else if (!strcmp(name, "f"))
return (sc->F);
else if (*name == 'o') {/* #o (octal) */
- sprintf(tmp, "0%s", name+1);
+ snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
sscanf(tmp, "%lo", &x);
return (mk_integer(sc, x));
} else if (*name == 'd') { /* #d (decimal) */
sscanf(name+1, "%ld", &x);
return (mk_integer(sc, x));
} else if (*name == 'x') { /* #x (hex) */
- sprintf(tmp, "0x%s", name+1);
+ snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
sscanf(tmp, "%lx", &x);
return (mk_integer(sc, x));
} else if (*name == 'b') { /* #b (binary) */
@@ -1197,7 +1259,7 @@ static pointer mk_sharp_const(scheme *sc, char *name) {
c='\t';
} else if(name[1]=='x' && name[2]!=0) {
int c1=0;
- if(sscanf(name+2,"%x",&c1)==1 && c1<256) {
+ if(sscanf(name+2,"%x",&c1)==1 && c1 < UCHAR_MAX) {
c=c1;
} else {
return sc->NIL;
@@ -1292,12 +1354,16 @@ static void gc(scheme *sc, pointer a, pointer b) {
mark(sc->code);
dump_stack_mark(sc);
mark(sc->value);
- mark(sc->safe_foreign);
mark(sc->inport);
mark(sc->save_inport);
mark(sc->outport);
mark(sc->loadport);
+ /* Mark recent objects the interpreter doesn't know about yet. */
+ mark(car(sc->sink));
+ /* Mark any older stuff above nested C calls */
+ mark(sc->c_nest);
+
/* mark variables a, b */
mark(a);
mark(b);
@@ -1332,7 +1398,7 @@ static void gc(scheme *sc, pointer a, pointer b) {
if (sc->gc_verbose) {
char msg[80];
- sprintf(msg,"done: %ld cells were recovered.\n", sc->fcells);
+ snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
putstr(sc,msg);
}
}
@@ -1352,7 +1418,11 @@ static void finalize_cell(scheme *sc, pointer a) {
/* ========== Routines for Reading ========== */
static int file_push(scheme *sc, const char *fname) {
- FILE *fin=fopen(fname,"rb");
+ FILE *fin = NULL;
+ if (sc->file_i == MAXFIL-1)
+ return 0;
+
+ fin=g_fopen(fname,"rb");
if(fin!=0) {
sc->file_i++;
sc->load_stack[sc->file_i].kind=port_file|port_input;
@@ -1360,20 +1430,24 @@ static int file_push(scheme *sc, const char *fname) {
sc->load_stack[sc->file_i].rep.stdio.closeit=1;
sc->nesting_stack[sc->file_i]=0;
sc->loadport->_object._port=sc->load_stack+sc->file_i;
+
+#if SHOW_ERROR_LINE
+ sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
+ if(fname)
+ sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
+#endif
+
}
return fin!=0;
}
static void file_pop(scheme *sc) {
- sc->nesting=sc->nesting_stack[sc->file_i];
- if(sc->file_i!=0) {
- port_close(sc,sc->loadport,port_input);
- sc->file_i--;
- sc->loadport->_object._port=sc->load_stack+sc->file_i;
- if(file_interactive(sc)) {
- putstr(sc,prompt);
+ if(sc->file_i != 0) {
+ sc->nesting=sc->nesting_stack[sc->file_i];
+ port_close(sc,sc->loadport,port_input);
+ sc->file_i--;
+ sc->loadport->_object._port=sc->load_stack+sc->file_i;
}
- }
}
static int file_interactive(scheme *sc) {
@@ -1392,12 +1466,19 @@ static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
} else {
rw="rb";
}
- f=fopen(fn,rw);
+ f=g_fopen(fn,rw);
if(f==0) {
return 0;
}
pt=port_rep_from_file(sc,f,prop);
pt->rep.stdio.closeit=1;
+
+#if SHOW_ERROR_LINE
+ if(fn)
+ pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
+
+ pt->rep.stdio.curr_line = 0;
+#endif
return pt;
}
@@ -1410,24 +1491,18 @@ static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
return mk_port(sc,pt);
}
-static port *port_rep_from_file(scheme *sc, FILE *f, int prop) {
- char *rw;
- port *pt;
- pt=(port*)sc->malloc(sizeof(port));
- if(pt==0) {
- return 0;
- }
- if(prop==(port_input|port_output)) {
- rw="a+";
- } else if(prop==port_output) {
- rw="w";
- } else {
- rw="r";
- }
- pt->kind=port_file|prop;
- pt->rep.stdio.file=f;
- pt->rep.stdio.closeit=0;
- return pt;
+static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
+{
+ port *pt;
+
+ pt = (port *)sc->malloc(sizeof *pt);
+ if (pt == NULL) {
+ return NULL;
+ }
+ pt->kind = port_file | prop;
+ pt->rep.stdio.file = f;
+ pt->rep.stdio.closeit = 0;
+ return pt;
}
static pointer port_from_file(scheme *sc, FILE *f, int prop) {
@@ -1461,93 +1536,132 @@ static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int
return mk_port(sc,pt);
}
+#define BLOCK_SIZE 256
+
+static port *port_rep_from_scratch(scheme *sc) {
+ port *pt;
+ char *start;
+ pt=(port*)sc->malloc(sizeof(port));
+ if(pt==0) {
+ return 0;
+ }
+ start=sc->malloc(BLOCK_SIZE);
+ if(start==0) {
+ return 0;
+ }
+ memset(start,' ',BLOCK_SIZE-1);
+ start[BLOCK_SIZE-1]='\0';
+ pt->kind=port_string|port_output|port_srfi6;
+ pt->rep.string.start=start;
+ pt->rep.string.curr=start;
+ pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
+ return pt;
+}
+
+static pointer port_from_scratch(scheme *sc) {
+ port *pt;
+ pt=port_rep_from_scratch(sc);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
static void port_close(scheme *sc, pointer p, int flag) {
port *pt=p->_object._port;
pt->kind&=~flag;
if((pt->kind & (port_input|port_output))==0) {
if(pt->kind&port_file) {
+
+#if SHOW_ERROR_LINE
+ /* Cleanup is here so (close-*-port) functions could work too */
+ pt->rep.stdio.curr_line = 0;
+
+ if(pt->rep.stdio.filename)
+ sc->free(pt->rep.stdio.filename);
+#endif
+
fclose(pt->rep.stdio.file);
}
pt->kind=port_free;
}
}
+/* This routine will ignore byte sequences that are not valid UTF-8 */
static gunichar basic_inchar(port *pt) {
- int len;
-
- if(pt->kind&port_file) {
- unsigned char utf8[7];
+ if(pt->kind & port_file) {
int c;
- int i;
c = fgetc(pt->rep.stdio.file);
- if (c == EOF) return EOF;
- utf8[0] = c;
while (TRUE)
{
- if (utf8[0] <= 0x7f)
+ if (c == EOF) return EOF;
+
+ if (c <= 0x7f)
+ return (gunichar) c;
+
+ /* Is this byte an invalid lead per RFC-3629? */
+ if (c < 0xc2 || c > 0xf4)
{
- return (gunichar) utf8[0];
+ /* Ignore invalid lead byte and get the next characer */
+ c = fgetc(pt->rep.stdio.file);
}
-
- /* Check for valid lead byte per RFC-3629 */
- if (utf8[0] >= 0xc2 && utf8[0] <= 0xf4)
+ else /* Byte is valid lead */
{
- len = utf8_length[utf8[0] & 0x3F];
+ unsigned char utf8[7];
+ int len;
+ int i;
+
+ utf8[0] = c; /* Save the lead byte */
+
+ len = utf8_length[c & 0x3F];
for (i = 1; i <= len; i++)
{
c = fgetc(pt->rep.stdio.file);
- if (c == EOF) return EOF;
- utf8[i] = c;
- if ((utf8[i] & 0xc0) != 0x80)
- {
+
+ /* Stop reading if this is not a continuation character */
+ if ((c & 0xc0) != 0x80)
break;
- }
+
+ utf8[i] = c;
}
- if (i > len)
+ if (i > len) /* Read the expected number of bytes? */
{
- return g_utf8_get_char ((char *) utf8);
+ return g_utf8_get_char_validated ((char *) utf8,
+ sizeof(utf8));
}
- /* we did not get enough continuation characters. */
- utf8[0] = utf8[i]; /* ignore and restart */
+ /* Not enough continuation characters so ignore and restart */
}
- else
- {
- /* Everything else is invalid and will be ignored */
- c = fgetc(pt->rep.stdio.file);
- if (c == EOF) return EOF;
- utf8[0] = c;
- }
- }
+ } /* end of while (TRUE) */
} else {
- if(*pt->rep.string.curr==0
- || pt->rep.string.curr==pt->rep.string.past_the_end) {
- return EOF;
- } else {
- gunichar c;
+ gunichar c;
+ int len;
+
+ while (TRUE)
+ {
+ /* Found NUL or at end of input buffer? */
+ if (*pt->rep.string.curr == 0 ||
+ pt->rep.string.curr == pt->rep.string.past_the_end) {
+ return EOF;
+ }
len = pt->rep.string.past_the_end - pt->rep.string.curr;
c = g_utf8_get_char_validated(pt->rep.string.curr, len);
- if (c < 0)
- {
- pt->rep.string.curr = g_utf8_find_next_char(pt->rep.string.curr,
- pt->rep.string.past_the_end);
- if (pt->rep.string.curr == NULL)
- pt->rep.string.curr = pt->rep.string.past_the_end;
- c = ' ';
- }
- else
+ if (c >= 0) /* Valid UTF-8 character? */
{
- len = g_unichar_to_utf8(c, NULL);
+ len = g_unichar_to_utf8(c, NULL); /* Length of UTF-8 sequence */
pt->rep.string.curr += len;
+ return c;
}
- return c;
- }
+ /* Look for next valid UTF-8 character in buffer */
+ pt->rep.string.curr = g_utf8_find_next_char(pt->rep.string.curr,
+ pt->rep.string.past_the_end);
+ } /* end of while (TRUE) */
}
}
@@ -1555,25 +1669,26 @@ static gunichar basic_inchar(port *pt) {
static gunichar inchar(scheme *sc) {
gunichar c;
port *pt;
- again:
- pt=sc->inport->_object._port;
+
+ pt = sc->inport->_object._port;
+ if(pt->kind & port_saw_EOF)
+ { return(EOF); }
if(pt->kind&port_file)
{
if (sc->bc_flag)
c = sc->backchar[--sc->bc_flag];
else
- c=basic_inchar(pt);
+ c = basic_inchar(pt);
}
else
- c=basic_inchar(pt);
- if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) {
- file_pop(sc);
- if(sc->nesting!=0) {
- return EOF;
- } else {
- return '\n';
- }
- goto again;
+ c = basic_inchar(pt);
+ if(c == EOF && sc->inport == sc->loadport) {
+ /* Instead, set port_saw_EOF */
+ pt->kind |= port_saw_EOF;
+
+ /* file_pop(sc); */
+ return EOF;
+ /* NOTREACHED */
}
return c;
}
@@ -1599,6 +1714,25 @@ static void backchar(scheme *sc, gunichar c) {
}
}
+static int realloc_port_string(scheme *sc, port *p)
+{
+ char *start=p->rep.string.start;
+ size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
+ char *str=sc->malloc(new_size);
+ if(str) {
+ memset(str,' ',new_size-1);
+ str[new_size-1]='\0';
+ strcpy(str,start);
+ p->rep.string.start=str;
+ p->rep.string.past_the_end=str+new_size-1;
+ p->rep.string.curr-=start-str;
+ sc->free(start);
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
/* len is number of UTF-8 characters in string pointed to by chars */
static void putchars(scheme *sc, const char *chars, int char_cnt) {
int free_bytes; /* Space remaining in buffer (in bytes) */
@@ -1626,13 +1760,20 @@ static void putchars(scheme *sc, const char *chars, int char_cnt) {
}
#endif
} else {
- free_bytes = pt->rep.string.past_the_end - pt->rep.string.curr;
- if (free_bytes > 0)
+ if (pt->rep.string.past_the_end != pt->rep.string.curr)
{
+ free_bytes = pt->rep.string.past_the_end - pt->rep.string.curr;
l = min(char_cnt, free_bytes);
memcpy(pt->rep.string.curr, chars, l);
pt->rep.string.curr += l;
}
+ else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt))
+ {
+ free_bytes = pt->rep.string.past_the_end - pt->rep.string.curr;
+ l = min(char_cnt, free_bytes);
+ memcpy(pt->rep.string.curr, chars, char_cnt);
+ pt->rep.string.curr += l;
+ }
}
}
@@ -1652,33 +1793,23 @@ static char *readstr_upto(scheme *sc, char *delim) {
char *p = sc->strbuff;
gunichar c = 0;
gunichar c_prev = 0;
- int len = 0;
+ int len = 0;
-#if 0
- while (!is_one_of(delim, (*p++ = inchar(sc))))
- ;
- if(p==sc->strbuff+2 && p[-2]=='\\') {
- *p=0;
- } else {
- backchar(sc,p[-1]);
- *--p = '\0';
- }
-#else
do {
c_prev = c;
c = inchar(sc);
len = g_unichar_to_utf8(c, p);
p += len;
- } while (c && !is_one_of(delim, c));
+ } while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
+ (c && !is_one_of(delim, c)));
- if(p==sc->strbuff+2 && c_prev=='\\')
+ if(p == sc->strbuff+2 && c_prev == '\\')
*p = '\0';
else
{
backchar(sc,c); /* put back the delimiter */
p[-len] = '\0';
}
-#endif
return sc->strbuff;
}
@@ -1692,7 +1823,7 @@ static pointer readstrexp(scheme *sc) {
for (;;) {
c=inchar(sc);
- if(c==EOF || p-sc->strbuff>sizeof(sc->strbuff)-1) {
+ if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
return sc->F;
}
switch(state) {
@@ -1703,7 +1834,8 @@ static pointer readstrexp(scheme *sc) {
break;
case '"':
*p=0;
- return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
+ return mk_counted_string(sc,sc->strbuff,
+ g_utf8_strlen(sc->strbuff, sizeof(sc->strbuff)));
default:
len = g_unichar_to_utf8(c, p);
p += len;
@@ -1804,19 +1936,35 @@ static INLINE int is_one_of(char *s, gunichar c) {
}
/* skip white characters */
-static INLINE void skipspace(scheme *sc) {
+static INLINE int skipspace(scheme *sc) {
gunichar c;
- while (g_unichar_isspace(c=inchar(sc)))
- ;
+ int curr_line = 0;
+ do {
+ c=inchar(sc);
+#if SHOW_ERROR_LINE
+ if(c=='\n')
+ curr_line++;
+#endif
+ } while (g_unichar_isspace(c));
+
+/* record it */
+#if SHOW_ERROR_LINE
+ sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
+#endif
+
if(c!=EOF) {
backchar(sc,c);
+ return 1;
}
+ else
+ { return EOF; }
}
/* get token */
static int token(scheme *sc) {
gunichar c;
- skipspace(sc);
+ c = skipspace(sc);
+ if(c == EOF) { return (TOK_EOF); }
switch (c=inchar(sc)) {
case EOF:
return (TOK_EOF);
@@ -1838,20 +1986,29 @@ static int token(scheme *sc) {
case ';':
while ((c=inchar(sc)) != '\n' && c!=EOF)
;
- return (token(sc));
+
+#if SHOW_ERROR_LINE
+ if(c == '\n')
+ sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+#endif
+
+ if(c == EOF)
+ { return (TOK_EOF); }
+ else
+ { return (token(sc));}
case '"':
return (TOK_DQUOTE);
case '_':
if ((c=inchar(sc)) == '"')
- return (TOK_DQUOTE);
+ return (TOK_USCORE);
backchar(sc,c);
return (TOK_ATOM);
case BACKQUOTE:
return (TOK_BQUOTE);
case ',':
- if ((c=inchar(sc)) == '@')
+ if ((c=inchar(sc)) == '@') {
return (TOK_ATMARK);
- else {
+ } else {
backchar(sc,c);
return (TOK_COMMA);
}
@@ -1862,7 +2019,16 @@ static int token(scheme *sc) {
} else if(c == '!') {
while ((c=inchar(sc)) != '\n' && c!=EOF)
;
- return (token(sc));
+
+#if SHOW_ERROR_LINE
+ if(c == '\n')
+ sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+#endif
+
+ if(c == EOF)
+ { return (TOK_EOF); }
+ else
+ { return (token(sc));}
} else {
backchar(sc,c);
if(is_one_of(" tfodxb\\",c)) {
@@ -1956,14 +2122,20 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
p = "#<EOF>";
} else if (is_port(l)) {
p = sc->strbuff;
- strcpy(p, "#<PORT>");
+ snprintf(p, STRBUFFSIZE, "#<PORT>");
} else if (is_number(l)) {
p = sc->strbuff;
- if(is_integer(l)) {
- sprintf(p, "%ld", ivalue_unchecked(l));
+ if(num_is_integer(l)) {
+ snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
} else {
- g_ascii_formatd (p, sizeof (sc->strbuff), "%.10g",
- rvalue_unchecked(l));
+ snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
+ /* R5RS says there must be a '.' (unless 'e'?) */
+ f = strcspn(p, ".e");
+ if (p[f] == 0) {
+ p[f] = '.'; // not found, so add '.0' at the end
+ p[f+1] = '0';
+ p[f+2] = 0;
+ }
}
} else if (is_string(l)) {
if (!f) {
@@ -1984,33 +2156,36 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
} else {
switch(c) {
case ' ':
- sprintf(p,"#\\space"); break;
+ snprintf(p,STRBUFFSIZE,"#\\space"); break;
case '\n':
- sprintf(p,"#\\newline"); break;
+ snprintf(p,STRBUFFSIZE,"#\\newline"); break;
case '\r':
- sprintf(p,"#\\return"); break;
+ snprintf(p,STRBUFFSIZE,"#\\return"); break;
case '\t':
- sprintf(p,"#\\tab"); break;
+ snprintf(p,STRBUFFSIZE,"#\\tab"); break;
default:
#if USE_ASCII_NAMES
if(c==127) {
- strcpy(p,"#\\del"); break;
+ snprintf(p,STRBUFFSIZE, "#\\del");
+ break;
} else if(c<32) {
- strcpy(p,"#\\"); strcat(p,charnames[c]); break;
- }
+ snprintf(p,STRBUFFSIZE, "#\\%s", charnames[c]);
+ break;
+ }
#else
if(c<32) {
- sprintf(p,"#\\x%x",c); break;
+ snprintf(p,STRBUFFSIZE,"#\\x%x",c); break;
}
#endif
- sprintf(p,"#\\%c",c); break;
+ snprintf(p,STRBUFFSIZE,"#\\x%c",c); break;
}
}
} else if (is_symbol(l)) {
p = symname(l);
} else if (is_proc(l)) {
p = sc->strbuff;
- sprintf(p, "#<%s PROCEDURE %ld>", procname(l),procnum(l));
+ snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>",
+ procname(l),procnum(l));
} else if (is_macro(l)) {
p = "#<MACRO>";
} else if (is_closure(l)) {
@@ -2019,7 +2194,7 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
p = "#<PROMISE>";
} else if (is_foreign(l)) {
p = sc->strbuff;
- sprintf(p, "#<FOREIGN PROCEDURE %ld>", procnum(l));
+ snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
} else if (is_continuation(l)) {
p = "#<CONTINUATION>";
} else {
@@ -2091,33 +2266,35 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
}
/* append list -- produce new list */
-static pointer append(scheme *sc, pointer a, pointer b) {
- pointer p = b, q;
-
- if (a != sc->NIL) {
- a = reverse(sc, a);
- while (a != sc->NIL) {
- q = cdr(a);
- cdr(a) = p;
- p = a;
- a = q;
- }
- }
- return (p);
+static pointer revappend(scheme *sc, pointer a, pointer b) {
+ pointer result = a;
+ pointer p = b;
+
+ while (is_pair(p)) {
+ result = cons(sc, car(p), result);
+ p = cdr(p);
+ }
+
+ if (p == sc->NIL) {
+ return result;
+ }
+
+ return sc->F; /* signal an error */
}
/* equivalence of atoms */
-static int eqv(pointer a, pointer b) {
+int eqv(pointer a, pointer b) {
if (is_string(a)) {
if (is_string(b))
return (strvalue(a) == strvalue(b));
else
return (0);
} else if (is_number(a)) {
- if (is_number(b))
- return num_eq(nvalue(a),nvalue(b));
- else
- return (0);
+ if (is_number(b)) {
+ if (num_is_integer(a) == num_is_integer(b))
+ return num_eq(nvalue(a),nvalue(b));
+ }
+ return (0);
} else if (is_character(a)) {
if (is_character(b))
return charvalue(a)==charvalue(b);
@@ -2147,9 +2324,6 @@ static int eqv(pointer a, pointer b) {
#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
-#ifdef __GNUC__
-#warning FIXME: Update hash_fn() to handle UTF-8 coded keys
-#endif
static int hash_fn(const char *key, int table_size)
{
unsigned int hashed = 0;
@@ -2292,10 +2466,32 @@ static INLINE pointer slot_value_in_env(pointer slot)
static pointer _Error_1(scheme *sc, const char *s, pointer a) {
+ const char *str = s;
#if USE_ERROR_HOOK
pointer x;
pointer hdl=sc->ERROR_HOOK;
+#endif
+
+#if SHOW_ERROR_LINE
+ char sbuf[STRBUFFSIZE];
+
+ /* make sure error is not in REPL */
+ if(sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
+ int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
+ const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+
+ /* should never happen */
+ if(!fname) fname = "<unknown>";
+ /* we started from 0 */
+ ln++;
+ snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
+
+ str = (const char*)sbuf;
+ }
+#endif
+
+#if USE_ERROR_HOOK
x=find_slot_in_env(sc,sc->envir,hdl,1);
if (x != sc->NIL) {
if(a!=0) {
@@ -2303,7 +2499,7 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
} else {
sc->code = sc->NIL;
}
- sc->code = cons(sc, mk_string(sc, (s)), sc->code);
+ sc->code = cons(sc, mk_string(sc, str), sc->code);
setimmutable(car(sc->code));
sc->code = cons(sc, slot_value_in_env(x), sc->code);
sc->op = (int)OP_EVAL;
@@ -2316,7 +2512,7 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
} else {
sc->args = sc->NIL;
}
- sc->args = cons(sc, mk_string(sc, (s)), sc->args);
+ sc->args = cons(sc, mk_string(sc, str), sc->args);
setimmutable(car(sc->args));
sc->op = (int)OP_ERR0;
return sc->T;
@@ -2472,24 +2668,46 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
if (!file_push(sc,strvalue(car(sc->args)))) {
Error_1(sc,"unable to open", car(sc->args));
}
- s_goto(sc,OP_T0LVL);
+ else
+ {
+ sc->args = mk_integer(sc,sc->file_i);
+ s_goto(sc,OP_T0LVL);
+ }
case OP_T0LVL: /* top level */
- if(file_interactive(sc)) {
- putstr(sc,"\n");
- }
- sc->nesting=0;
- dump_stack_reset(sc);
- sc->envir = sc->global_env;
- sc->save_inport=sc->inport;
- sc->inport = sc->loadport;
- s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
- s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
- s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
- if (file_interactive(sc)) {
- putstr(sc,prompt);
- }
- s_goto(sc,OP_READ_INTERNAL);
+ /* If we reached the end of file, this loop is done. */
+ if(sc->loadport->_object._port->kind & port_saw_EOF)
+ {
+ if(sc->file_i == 0)
+ {
+ sc->args=sc->NIL;
+ s_goto(sc,OP_QUIT);
+ }
+ else
+ {
+ file_pop(sc);
+ s_return(sc,sc->value);
+ }
+ /* NOTREACHED */
+ }
+
+ /* If interactive, be nice to user. */
+ if(file_interactive(sc))
+ {
+ sc->envir = sc->global_env;
+ dump_stack_reset(sc);
+ putstr(sc,"\n");
+ putstr(sc,prompt);
+ }
+
+ /* Set up another iteration of REPL */
+ sc->nesting=0;
+ sc->save_inport=sc->inport;
+ sc->inport = sc->loadport;
+ s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
+ s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
+ s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
+ s_goto(sc,OP_READ_INTERNAL);
case OP_T1LVL: /* top level */
sc->code = sc->value;
@@ -2498,14 +2716,8 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
case OP_READ_INTERNAL: /* internal read */
sc->tok = token(sc);
- if(sc->tok==TOK_EOF) {
- if(sc->inport==sc->loadport) {
- sc->args=sc->NIL;
- s_goto(sc,OP_QUIT);
- } else {
- s_return(sc,sc->EOF_OBJ);
- }
- }
+ if(sc->tok==TOK_EOF)
+ { s_return(sc,sc->EOF_OBJ); }
s_goto(sc,OP_RDSEXPR);
case OP_GENSYM:
@@ -2597,7 +2809,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
if(sc->tracing) {
s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
sc->print_flag = 1;
- /* sc->args=cons(sc,sc->code,sc->args);*/
+ /* sc->args=cons(sc,sc->code,sc->args);*/
putstr(sc,"\nApply to: ");
s_goto(sc,OP_P0LIST);
}
@@ -2606,11 +2818,12 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
#endif
if (is_proc(sc->code)) {
s_goto(sc,procnum(sc->code)); /* PROCEDURE */
- } else if (is_foreign(sc->code)) {
- sc->safe_foreign = cons (sc, sc->NIL, sc->safe_foreign);
+ } else if (is_foreign(sc->code))
+ {
+ /* Keep nested calls from GC'ing the arglist */
+ push_recent_alloc(sc,sc->args,sc->NIL);
sc->foreign_error = sc->NIL;
x=sc->code->_object._ff(sc,sc->args);
- sc->safe_foreign = cdr (sc->safe_foreign);
if (sc->foreign_error == sc->NIL) {
s_return(sc,x);
} else {
@@ -2656,9 +2869,32 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
sc->code = sc->value;
s_goto(sc,OP_EVAL);
+#if 1
+ case OP_LAMBDA: /* lambda */
+ /* If the hook is defined, apply it to sc->code, otherwise
+ set sc->value fall thru */
+ {
+ pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
+ if(f==sc->NIL) {
+ sc->value = sc->code;
+ /* Fallthru */
+ } else {
+ s_save(sc,OP_LAMBDA1,sc->args,sc->code);
+ sc->args=cons(sc,sc->code,sc->NIL);
+ sc->code=slot_value_in_env(f);
+ s_goto(sc,OP_APPLY);
+ }
+ }
+
+ case OP_LAMBDA1:
+ s_return(sc,mk_closure(sc, sc->value, sc->envir));
+
+#else
case OP_LAMBDA: /* lambda */
s_return(sc,mk_closure(sc, sc->code, sc->envir));
+#endif
+
case OP_MKCLOSURE: /* make-closure */
x=car(sc->args);
if(car(x)==sc->LAMBDA) {
@@ -2672,12 +2908,12 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_return(sc,mk_closure(sc, x, y));
case OP_QUOTE: /* quote */
- x=car(sc->code);
s_return(sc,car(sc->code));
case OP_DEF0: /* define */
if(is_immutable(car(sc->code)))
Error_1(sc,"define: unable to alter immutable", car(sc->code));
+
if (is_pair(car(sc->code))) {
x = caar(sc->code);
sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
@@ -2692,7 +2928,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_goto(sc,OP_EVAL);
case OP_DEF1: /* define */
- x=find_slot_in_env(sc,sc->envir,sc->code,0);
+ x=find_slot_in_env(sc,sc->envir,sc->code,0);
if (x != sc->NIL) {
set_slot_in_env(sc, x, sc->value);
} else {
@@ -2710,7 +2946,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
case OP_SET0: /* set! */
if(is_immutable(car(sc->code)))
- Error_1(sc,"set!: unable to alter immutable variable", car(sc->code));
+ Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
s_save(sc,OP_SET1, sc->NIL, car(sc->code));
sc->code = cadr(sc->code);
s_goto(sc,OP_EVAL);
@@ -2756,6 +2992,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
case OP_LET1: /* let (calculate parameters) */
sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code)) { /* continue */
+ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
+ Error_1(sc, "Bad syntax of binding spec in let :", car(sc->code));
+ }
s_save(sc,OP_LET1, sc->args, cdr(sc->code));
sc->code = cadar(sc->code);
sc->args = sc->NIL;
@@ -2775,7 +3014,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
}
if (is_symbol(car(sc->code))) { /* named let */
for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
-
+ if (!is_pair(x))
+ Error_1(sc, "Bad syntax of binding in let :", x);
+ if (!is_list(sc, car(x)))
+ Error_1(sc, "Bad syntax of binding in let :", car(x));
sc->args = cons(sc, caar(x), sc->args);
}
x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)),
sc->envir);
@@ -2794,6 +3036,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
sc->code = cdr(sc->code);
s_goto(sc,OP_BEGIN);
}
+ if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
+ Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
+ }
s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
sc->code = cadaar(sc->code);
s_goto(sc,OP_EVAL);
@@ -2816,7 +3061,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_goto(sc,OP_BEGIN);
}
default:
- sprintf(sc->strbuff, "%d: illegal operator", sc->op);
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
Error_0(sc,sc->strbuff);
}
return sc->T;
@@ -2836,6 +3081,9 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
case OP_LET1REC: /* letrec (calculate parameters) */
sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code)) { /* continue */
+ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
+ Error_1(sc,"Bad syntax of binding spec in letrec :",car(sc->code));
+ }
s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
sc->code = cadar(sc->code);
sc->args = sc->NIL;
@@ -3023,7 +3271,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_goto(sc,OP_APPLY);
default:
- sprintf(sc->strbuff, "%d: illegal operator", sc->op);
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
Error_0(sc,sc->strbuff);
}
return sc->T;
@@ -3040,7 +3288,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
#if USE_MATH
case OP_INEX2EX: /* inexact->exact */
x=car(sc->args);
- if(is_integer(x)) {
+ if(num_is_integer(x)) {
s_return(sc,x);
} else if(modf(rvalue_unchecked(x),&dd)==0.0) {
s_return(sc,mk_integer(sc,ivalue(x)));
@@ -3089,14 +3337,34 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
x=car(sc->args);
s_return(sc, mk_real(sc, sqrt(rvalue(x))));
- case OP_EXPT:
+ case OP_EXPT: {
+ double result;
+ int real_result=1;
+ pointer y=cadr(sc->args);
x=car(sc->args);
- if(cdr(sc->args)==sc->NIL) {
- Error_0(sc,"expt: needs two arguments");
+ if (num_is_integer(x) && num_is_integer(y))
+ real_result=0;
+ /* This 'if' is an R5RS compatability fix. */
+ /* NOTE: Remove this 'if' fix for R6RS. */
+ if (rvalue(x) == 0 && rvalue(y) < 0) {
+ result = 0.0;
} else {
- pointer y=cadr(sc->args);
- s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y))));
+ result = pow(rvalue(x),rvalue(y));
+ }
+ /* Before returning integer result make sure we can. */
+ /* If the test fails, result is too big for integer. */
+ if (!real_result)
+ {
+ long result_as_long = (long)result;
+ if (result != (double)result_as_long)
+ real_result = 1;
+ }
+ if (real_result) {
+ s_return(sc, mk_real(sc, result));
+ } else {
+ s_return(sc, mk_integer(sc, result));
}
+ }
case OP_FLOOR:
x=car(sc->args);
@@ -3118,8 +3386,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
case OP_ROUND:
- x=car(sc->args);
- s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
+ x=car(sc->args);
+ if (num_is_integer(x))
+ s_return(sc, x);
+ s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
#endif
case OP_ADD: /* + */
@@ -3359,7 +3629,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
free(strvalue(a));
strvalue(a)=newstr;
- strlength(a)=newlen;
+ strlength(a)=g_utf8_strlen(newstr, -1);
s_return(sc,a);
}
@@ -3367,24 +3637,39 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
case OP_STRAPPEND: { /* string-append */
/* in 1.29 string-append was in Scheme in init.scm but was too slow */
int len = 0;
- pointer newstr;
pointer car_x;
+ char *newstr;
char *pos;
+ char *end;
/* compute needed length for new string */
for (x = sc->args; x != sc->NIL; x = cdr(x)) {
- len += strlength(car(x));
+ car_x = car(x);
+ end = g_utf8_offset_to_pointer(strvalue(car_x), (long)strlength(car_x));
+ len += end - strvalue(car_x);
}
- newstr = mk_empty_string(sc, len, ' ');
+
+ newstr = (char *)sc->malloc(len+1);
+ if (newstr == NULL) {
+ sc->no_memory=1;
+ Error_1(sc,"string-set!: No memory to append strings:",car(sc->args));
+ }
+
/* store the contents of the argument strings into the new string */
- pos = strvalue(newstr);
+ pos = newstr;
for (x = sc->args; x != sc->NIL; x = cdr(x)) {
car_x = car(x);
- memcpy(pos, strvalue(car_x), strlength(car_x));
- pos += strlength(car_x);
+ end = g_utf8_offset_to_pointer(strvalue(car_x), (long)strlength(car_x));
+ len = end - strvalue(car_x);
+ memcpy(pos, strvalue(car_x), len);
+ pos += len;
}
*pos = '\0';
- s_return(sc, newstr);
+
+ car_x = mk_string(sc, newstr);
+ g_free(newstr);
+
+ s_return(sc, car_x);
}
case OP_SUBSTR: { /* substring */
@@ -3413,12 +3698,22 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
index1=g_utf8_strlen(str, -1);
}
+ /* store the contents of the argument strings into the new string */
beg = g_utf8_offset_to_pointer(str, (long)index0);
end = g_utf8_offset_to_pointer(str, (long)index1);
len=end-beg;
- x=mk_empty_string(sc,len,' ');
- memcpy(strvalue(x),beg,len);
- strvalue(x)[len] = '\0';
+
+ str = (char *)sc->malloc(len+1);
+ if (str == NULL) {
+ sc->no_memory=1;
+ Error_1(sc,"string-set!: No memory to extract substring:",car(sc->args));
+ }
+
+ memcpy(str, beg, len);
+ str[len] = '\0';
+
+ x = mk_string(sc, str);
+ g_free(str);
s_return(sc,x);
}
@@ -3431,6 +3726,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
Error_1(sc,"vector: not a proper list:",sc->args);
}
vec=mk_vector(sc,len);
+ if(sc->no_memory) { s_return(sc, sc->sink); }
for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
set_vector_elem(vec,i,car(x));
}
@@ -3448,6 +3744,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
fill=cadr(sc->args);
}
vec=mk_vector(sc,len);
+ if(sc->no_memory) { s_return(sc, sc->sink); }
if(fill!=sc->NIL) {
fill_vector(vec,fill);
}
@@ -3486,69 +3783,52 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
default:
- sprintf(sc->strbuff, "%d: illegal operator", sc->op);
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
Error_0(sc,sc->strbuff);
}
return sc->T;
}
-static int is_list(scheme *sc, pointer a) {
- pointer slow, fast;
+static int is_list(scheme *sc, pointer a)
+{ return list_length(sc,a) >= 0; }
- slow = fast = a;
- while (1)
- {
- if (fast == sc->NIL)
- return 1;
- if (!is_pair(fast))
- return 0;
- fast = cdr(fast);
- if (fast == sc->NIL)
- return 1;
- if (!is_pair(fast))
- return 0;
- fast = cdr(fast);
-
- slow = cdr(slow);
- if (fast == slow)
- {
- /* the fast pointer has looped back around and caught up
- with the slow pointer, hence the structure is circular,
- not of finite length, and therefore not a list */
- return 0;
- }
- }
-}
-
-static int list_length(scheme *sc, pointer a) {
+/* Result is:
+ proper list: length
+ circular list: -1
+ not even a pair: -2
+ dotted list: -2 minus length before dot
+*/
+int list_length(scheme *sc, pointer p) {
int i=0;
- pointer slow, fast;
+ pointer slow, fast;
- slow = fast = a;
- while (1)
+ slow = fast = p;
+ while (1)
+ {
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return -2 - i;
+ fast = cdr(fast);
+ ++i;
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return -2 - i;
+ ++i;
+ fast = cdr(fast);
+
+ /* Safe because we would have already returned if `fast'
+ encountered a non-pair. */
+ slow = cdr(slow);
+ if (fast == slow)
{
- if (fast == sc->NIL)
- return i;
- if (!is_pair(fast))
- return i;
- fast = cdr(fast);
- ++i;
- if (fast == sc->NIL)
- return i;
- if (!is_pair(fast))
- return i;
- ++i;
- fast = cdr(fast);
-
- slow = cdr(slow);
- if (fast == slow)
- {
- /* the fast pointer has looped back around and caught up
- with the slow pointer, hence the structure is circular,
- not of finite length, and therefore not a list */
- return -1;
- }
+ /* the fast pointer has looped back around and caught up
+ with the slow pointer, hence the structure is circular,
+ not of finite length, and therefore not a list */
+ return -1;
}
+ }
}
static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
@@ -3596,7 +3876,7 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
case OP_STRINGP: /* string? */
s_retbool(is_string(car(sc->args)));
case OP_INTEGERP: /* integer? */
- s_retbool(is_number(car(sc->args)) && is_integer(car(sc->args)));
+ s_retbool(is_integer(car(sc->args)));
case OP_REALP: /* real? */
s_retbool(is_number(car(sc->args))); /* All numbers are real */
case OP_CHARP: /* char? */
@@ -3630,7 +3910,7 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
case OP_PAIRP: /* pair? */
s_retbool(is_pair(car(sc->args)));
case OP_LISTP: /* list? */
- s_retbool(is_list(sc, car(sc->args)));
+ s_retbool(list_length(sc,car(sc->args)) >= 0);
case OP_ENVP: /* environment? */
s_retbool(is_environment(car(sc->args)));
case OP_VECTORP: /* vector? */
@@ -3640,7 +3920,7 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
case OP_EQV: /* eqv? */
s_retbool(eqv(car(sc->args), cadr(sc->args)));
default:
- sprintf(sc->strbuff, "%d: illegal operator", sc->op);
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
Error_0(sc,sc->strbuff);
}
return sc->T;
@@ -3721,24 +4001,30 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
}
}
- case OP_REVERSE: /* reverse */
+ case OP_REVERSE: /* reverse */
s_return(sc,reverse(sc, car(sc->args)));
case OP_LIST_STAR: /* list* */
- s_return(sc,list_star(sc,sc->args));
+ s_return(sc,list_star(sc,sc->args));
- case OP_APPEND: /* append */
- if(sc->args==sc->NIL) {
- s_return(sc,sc->NIL);
- }
- x=car(sc->args);
- if(cdr(sc->args)==sc->NIL) {
- s_return(sc,sc->args);
+ case OP_APPEND: /* append */
+ x = sc->NIL;
+ y = sc->args;
+ if (y == x) {
+ s_return(sc, x);
}
- for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) {
- x=append(sc,x,car(y));
+
+ /* cdr() in the while condition is not a typo. If car() */
+ /* is used (append '() 'a) will return the wrong result.*/
+ while (cdr(y) != sc->NIL) {
+ x = revappend(sc, x, car(y));
+ y = cdr(y);
+ if (x == sc->F) {
+ Error_0(sc, "non-list argument to append");
+ }
}
- s_return(sc,x);
+
+ s_return(sc, reverse_in_place(sc, car(y), x));
#if USE_PLIST
case OP_PUT: /* put */
@@ -3825,23 +4111,60 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
#if USE_STRING_PORTS
case OP_OPEN_INSTRING: /* open-input-string */
- case OP_OPEN_OUTSTRING: /* open-output-string */
case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
int prop=0;
pointer p;
switch(op) {
case OP_OPEN_INSTRING: prop=port_input; break;
- case OP_OPEN_OUTSTRING: prop=port_output; break;
case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break;
default: break; /* Quiet the compiler */
}
p=port_from_string(sc, strvalue(car(sc->args)),
- strvalue(car(sc->args))+strlength(car(sc->args)), prop);
+ g_utf8_offset_to_pointer(strvalue(car(sc->args)),
+ strlength(car(sc->args))), prop);
if(p==sc->NIL) {
s_return(sc,sc->F);
}
s_return(sc,p);
}
+ case OP_OPEN_OUTSTRING: /* open-output-string */ {
+ pointer p;
+ if(car(sc->args)==sc->NIL) {
+ p=port_from_scratch(sc);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ } else {
+ p=port_from_string(sc, strvalue(car(sc->args)),
+ strvalue(car(sc->args))+strlength(car(sc->args)),
+ port_output);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ }
+ s_return(sc,p);
+ }
+ case OP_GET_OUTSTRING: /* get-output-string */ {
+ port *p;
+
+ if ((p=car(sc->args)->_object._port)->kind&port_string) {
+ off_t size;
+ char *str;
+
+ size=p->rep.string.curr-p->rep.string.start+1;
+ str=sc->malloc(size);
+ if(str != NULL) {
+ pointer s;
+
+ memcpy(str,p->rep.string.start,size-1);
+ str[size-1]='\0';
+ s=mk_string(sc,str);
+ sc->free(str);
+ s_return(sc,s);
+ }
+ }
+ s_return(sc,sc->F);
+ }
#endif
case OP_CLOSE_INPORT: /* close-input-port */
@@ -3867,6 +4190,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
pointer x;
+ char *trans_str;
if(sc->nesting!=0) {
int n=sc->nesting;
@@ -3935,12 +4259,8 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
case OP_RDSEXPR:
switch (sc->tok) {
case TOK_EOF:
- if(sc->inport==sc->loadport) {
- sc->args=sc->NIL;
- s_goto(sc,OP_QUIT);
- } else {
- s_return(sc,sc->EOF_OBJ);
- }
+ s_return(sc,sc->EOF_OBJ);
+ /* NOTREACHED */
/*
* Commented out because we now skip comments in the scanner
*
@@ -3997,6 +4317,19 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
}
setimmutable(x);
s_return(sc,x);
+ case TOK_USCORE:
+ x=readstrexp(sc);
+ if(x==sc->F) {
+ Error_0(sc,"Error reading string");
+ }
+ trans_str = gettext (strvalue (x));
+ if (trans_str != strvalue(x)) {
+ sc->free(strvalue(x));
+ strlength(x) = g_utf8_strlen(trans_str, -1);
+ strvalue(x) = store_string(sc, strlength(x), trans_str, 0);
+ }
+ setimmutable(x);
+ s_return(sc,x);
case TOK_SHARP: {
pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
if(f==sc->NIL) {
@@ -4028,9 +4361,16 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
sc->tok = token(sc);
}
*/
- if (sc->tok == TOK_RPAREN) {
+ if (sc->tok == TOK_EOF)
+ { s_return(sc,sc->EOF_OBJ); }
+ else if (sc->tok == TOK_RPAREN) {
gunichar c = inchar(sc);
- if (c != '\n') backchar(sc,c);
+ if (c != '\n')
+ backchar(sc,c);
+#if SHOW_ERROR_LINE
+ else
+ sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+#endif
sc->nesting_stack[sc->file_i]--;
s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
} else if (sc->tok == TOK_DOT) {
@@ -4058,7 +4398,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
case OP_RDQQUOTEVEC:
- s_return(sc,cons(sc, mk_symbol(sc,"apply"),
+ s_return(sc,cons(sc, mk_symbol(sc,"apply"),
cons(sc, mk_symbol(sc,"vector"),
cons(sc,cons(sc, sc->QQUOTE,
cons(sc,sc->value,sc->NIL)),
@@ -4073,13 +4413,13 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
case OP_RDVEC:
/*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
s_goto(sc,OP_EVAL); Cannot be quoted*/
- /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
- s_return(sc,x); Cannot be part of pairs*/
- /*sc->code=mk_proc(sc,OP_VECTOR);
- sc->args=sc->value;
- s_goto(sc,OP_APPLY);*/
- sc->args=sc->value;
- s_goto(sc,OP_VECTOR);
+ /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
+ s_return(sc,x); Cannot be part of pairs*/
+ /*sc->code=mk_proc(sc,OP_VECTOR);
+ sc->args=sc->value;
+ s_goto(sc,OP_APPLY);*/
+ sc->args=sc->value;
+ s_goto(sc,OP_VECTOR);
/* ========== printing part ========== */
case OP_P0LIST:
@@ -4139,20 +4479,21 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
pointer vec=car(sc->args);
int len=ivalue_unchecked(vec);
if(i==len) {
- putstr(sc," )");
+ putstr(sc,")");
s_return(sc,sc->T);
} else {
pointer elem=vector_elem(vec,i);
ivalue_unchecked(cdr(sc->args))=i+1;
s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
sc->args=elem;
- putstr(sc," ");
+ if (i > 0)
+ putstr(sc," ");
s_goto(sc,OP_P0LIST);
}
}
default:
- sprintf(sc->strbuff, "%d: illegal operator", sc->op);
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
Error_0(sc,sc->strbuff);
}
@@ -4207,7 +4548,7 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
case OP_MACROP: /* macro? */
s_retbool(is_macro(car(sc->args)));
default:
- sprintf(sc->strbuff, "%d: illegal operator", sc->op);
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
Error_0(sc,sc->strbuff);
}
return sc->T; /* NOTREACHED */
@@ -4217,11 +4558,9 @@ typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
typedef int (*test_predicate)(pointer);
static int is_any(pointer p) { return 1;}
-static int is_num_integer(pointer p) {
- return is_number(p) && ((p)->_object._number.is_fixnum);
-}
+
static int is_nonneg(pointer p) {
- return is_num_integer(p) && ivalue(p)>=0;
+ return ivalue(p)>=0 && is_integer(p);
}
/* Correspond carefully with following defines! */
@@ -4234,16 +4573,16 @@ static struct {
{is_string, "string"},
{is_symbol, "symbol"},
{is_port, "port"},
- {0,"input port"},
- {0,"output_port"},
+ {is_inport,"input port"},
+ {is_outport,"output port"},
{is_environment, "environment"},
{is_pair, "pair"},
{0, "pair or '()"},
{is_character, "character"},
{is_vector, "vector"},
{is_number, "number"},
- {is_num_integer, "integer"},
- {is_nonneg, "non-negative integer"},
+ {is_integer, "integer"},
+ {is_nonneg, "non-negative integer"}
};
#define TST_NONE 0
@@ -4289,31 +4628,28 @@ static const char *procname(pointer x) {
/* kernel of this interpreter */
static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
- int count=0;
- int old_op;
-
sc->op = op;
for (;;) {
op_code_info *pcd=dispatch_table+sc->op;
if (pcd->name!=0) { /* if built-in function, check arguments */
- char msg[512];
+ char msg[STRBUFFSIZE];
int ok=1;
int n=list_length(sc,sc->args);
/* Check number of arguments */
if(n<pcd->min_arity) {
ok=0;
- sprintf(msg,"%s: needs%s %d argument(s)",
- pcd->name,
- pcd->min_arity==pcd->max_arity?"":" at least",
- pcd->min_arity);
+ snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
+ pcd->name,
+ pcd->min_arity==pcd->max_arity?"":" at least",
+ pcd->min_arity);
}
if(ok && n>pcd->max_arity) {
ok=0;
- sprintf(msg,"%s: needs%s %d argument(s)",
- pcd->name,
- pcd->min_arity==pcd->max_arity?"":" at most",
- pcd->max_arity);
+ snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
+ pcd->name,
+ pcd->min_arity==pcd->max_arity?"":" at most",
+ pcd->max_arity);
}
if(ok) {
if(pcd->arg_tests_encoding!=0) {
@@ -4324,11 +4660,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
do {
pointer arg=car(arglist);
j=(int)t[0];
- if(j==TST_INPORT[0]) {
- if(!is_inport(arg)) break;
- } else if(j==TST_OUTPORT[0]) {
- if(!is_outport(arg)) break;
- } else if(j==TST_LIST[0]) {
+ if(j==TST_LIST[0]) {
if(arg!=sc->NIL && !is_pair(arg)) break;
} else {
if(!tests[j].fct(arg)) break;
@@ -4342,10 +4674,10 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
} while(i<n);
if(i<n) {
ok=0;
- sprintf(msg,"%s: argument %d must be: %s",
- pcd->name,
- i+1,
- tests[j].kind);
+ snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
+ pcd->name,
+ i+1,
+ tests[j].kind);
}
}
}
@@ -4356,7 +4688,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
pcd=dispatch_table+sc->op;
}
}
- old_op=sc->op;
+ ok_to_freely_gc(sc);
if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
return;
}
@@ -4364,7 +4696,6 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
fprintf(stderr,"No memory!\n");
return;
}
- count++;
}
}
@@ -4391,7 +4722,7 @@ static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
y = get_cell(sc, sc->NIL, sc->NIL);
typeflag(y) = (T_PROC | T_ATOM);
ivalue_unchecked(y) = (long) op;
- set_integer(y);
+ set_num_integer(y);
return y;
}
@@ -4475,9 +4806,7 @@ static struct scheme_interface vtbl ={
fill_vector,
vector_elem,
set_vector_elem,
-
is_port,
-
is_pair,
pair_car,
pair_cdr,
@@ -4573,7 +4902,6 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
sc->code = sc->NIL;
sc->tracing=0;
sc->bc_flag = 0;
- sc->safe_foreign = sc->NIL;
/* init sc->NIL */
typeflag(sc->NIL) = (T_ATOM | MARK);
@@ -4584,6 +4912,12 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
/* init F */
typeflag(sc->F) = (T_ATOM | MARK);
car(sc->F) = cdr(sc->F) = sc->F;
+ /* init sink */
+ typeflag(sc->sink) = (T_PAIR | MARK);
+ car(sc->sink) = sc->NIL;
+ /* init c_nest */
+ sc->c_nest = sc->NIL;
+
sc->oblist = oblist_initial_value(sc);
/* init global_env */
new_frame_in_env(sc, sc->NIL);
@@ -4625,6 +4959,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
+ sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
return !sc->no_memory;
}
@@ -4652,6 +4987,10 @@ void scheme_set_external_data(scheme *sc, void *p) {
void scheme_deinit(scheme *sc) {
int i;
+#if SHOW_ERROR_LINE
+ char *fname;
+#endif
+
sc->oblist=sc->NIL;
sc->global_env=sc->NIL;
dump_stack_free(sc);
@@ -4678,9 +5017,21 @@ void scheme_deinit(scheme *sc) {
for(i=0; i<=sc->last_cell_seg; i++) {
sc->free(sc->alloc_seg[i]);
}
+
+#if SHOW_ERROR_LINE
+ fname = sc->load_stack[i].rep.stdio.filename;
+
+ for(i=0; i<sc->file_i; i++) {
+ if(fname)
+ sc->free(fname);
+ }
+#endif
}
-void scheme_load_file(scheme *sc, FILE *fin) {
+void scheme_load_file(scheme *sc, FILE *fin)
+{ scheme_load_named_file(sc,fin,0); }
+
+void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
dump_stack_reset(sc);
sc->envir = sc->global_env;
sc->file_i=0;
@@ -4691,7 +5042,15 @@ void scheme_load_file(scheme *sc, FILE *fin) {
if(fin==stdin) {
sc->interactive_repl=1;
}
+
+#if SHOW_ERROR_LINE
+ sc->load_stack[0].rep.stdio.curr_line = 0;
+ if(fin!=stdin && filename)
+ sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
+#endif
+
sc->inport=sc->loadport;
+ sc->args = mk_integer(sc,sc->file_i);
Eval_Cycle(sc, OP_T0LVL);
typeflag(sc->loadport)=T_ATOM;
if(sc->retcode==0) {
@@ -4711,6 +5070,7 @@ void scheme_load_string(scheme *sc, const char *cmd) {
sc->retcode=0;
sc->interactive_repl=0;
sc->inport=sc->loadport;
+ sc->args = mk_integer(sc,sc->file_i);
Eval_Cycle(sc, OP_T0LVL);
typeflag(sc->loadport)=T_ATOM;
if(sc->retcode==0) {
@@ -4730,27 +5090,83 @@ void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
}
#if !STANDALONE
-void scheme_apply0(scheme *sc, const char *procname) {
- pointer carx=mk_symbol(sc,procname);
- pointer cdrx=sc->NIL;
-
- dump_stack_reset(sc);
- sc->envir = sc->global_env;
- sc->code = cons(sc,carx,cdrx);
- sc->interactive_repl=0;
- sc->retcode=0;
- Eval_Cycle(sc,OP_EVAL);
- }
+void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
+{
+ scheme_define(sc,
+ sc->global_env,
+ mk_symbol(sc,sr->name),
+ mk_foreign_func(sc, sr->f));
+}
+
+void scheme_register_foreign_func_list(scheme * sc,
+ scheme_registerable * list,
+ int count)
+{
+ int i;
+ for(i = 0; i < count; i++)
+ {
+ scheme_register_foreign_func(sc, list + i);
+ }
+}
-void scheme_call(scheme *sc, pointer func, pointer args) {
- dump_stack_reset(sc);
- sc->envir = sc->global_env;
- sc->args = args;
- sc->code = func;
- sc->interactive_repl =0;
- sc->retcode = 0;
- Eval_Cycle(sc, OP_APPLY);
+pointer scheme_apply0(scheme *sc, const char *procname)
+{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
+
+static void save_from_C_call(scheme *sc)
+{
+ pointer saved_data =
+ cons(sc,
+ car(sc->sink),
+ cons(sc,
+ sc->envir,
+ sc->dump));
+ /* Push */
+ sc->c_nest = cons(sc, saved_data, sc->c_nest);
+ /* Truncate the dump stack so TS will return here when done, not
+ directly resume pre-C-call operations. */
+ dump_stack_reset(sc);
}
+
+static void restore_from_C_call(scheme *sc)
+{
+ car(sc->sink) = caar(sc->c_nest);
+ sc->envir = cadar(sc->c_nest);
+ sc->dump = cdr(cdar(sc->c_nest));
+ /* Pop */
+ sc->c_nest = cdr(sc->c_nest);
+}
+
+/* "func" and "args" are assumed to be already eval'ed. */
+pointer scheme_call(scheme *sc, pointer func, pointer args)
+{
+ int old_repl = sc->interactive_repl;
+ sc->interactive_repl = 0;
+ save_from_C_call(sc);
+ sc->envir = sc->global_env;
+ sc->args = args;
+ sc->code = func;
+ sc->retcode = 0;
+ Eval_Cycle(sc, OP_APPLY);
+ sc->interactive_repl = old_repl;
+ restore_from_C_call(sc);
+ return sc->value;
+}
+
+pointer scheme_eval(scheme *sc, pointer obj)
+{
+ int old_repl = sc->interactive_repl;
+ sc->interactive_repl = 0;
+ save_from_C_call(sc);
+ sc->args = sc->NIL;
+ sc->code = obj;
+ sc->retcode = 0;
+ Eval_Cycle(sc, OP_EVAL);
+ sc->interactive_repl = old_repl;
+ restore_from_C_call(sc);
+ return sc->value;
+}
+
+
#endif
/* ========== Main ========== */
@@ -4799,7 +5215,7 @@ int main(int argc, char **argv) {
scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
#endif
argv++;
- if(access(file_name,0)!=0) {
+ if(g_access(file_name,0)!=0) {
char *p=getenv("TINYSCHEMEINIT");
if(p!=0) {
file_name=p;
@@ -4854,7 +5270,7 @@ int main(int argc, char **argv) {
if(strcmp(file_name,"-")==0) {
fin=stdin;
} else if(isfile) {
- fin=fopen(file_name,"rb");
+ fin=g_fopen(file_name,"r");
}
for(;*argv;argv++) {
pointer value=mk_string(&sc,*argv);
@@ -4864,13 +5280,13 @@ int main(int argc, char **argv) {
scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
} else {
- fin=fopen(file_name,"rb");
+ fin=g_fopen(file_name,"r");
}
if(isfile && fin==0) {
fprintf(stderr,"Could not open file %s\n",file_name);
} else {
if(isfile) {
- scheme_load_file(&sc,fin);
+ scheme_load_named_file(&sc,fin,file_name);
} else {
scheme_load_string(&sc,file_name);
}
@@ -4886,7 +5302,7 @@ int main(int argc, char **argv) {
file_name=*argv++;
} while(file_name!=0);
if(argc==1) {
- scheme_load_file(&sc,stdin);
+ scheme_load_named_file(&sc,stdin,0);
}
retcode=sc.retcode;
scheme_deinit(&sc);
@@ -4895,3 +5311,9 @@ int main(int argc, char **argv) {
}
#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/
diff --git a/tinyscheme/scheme.h b/tinyscheme/scheme.h
index 7ca1669..5b60dff 100644
--- a/tinyscheme/scheme.h
+++ b/tinyscheme/scheme.h
@@ -5,6 +5,11 @@
#include <stdio.h>
#include <glib.h>
+#include <glib/gstdio.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
/*
* Default values for #define'd symbols
@@ -99,6 +104,10 @@
# define USE_INTERFACE 0
#endif
+#ifndef SHOW_ERROR_LINE /* Show error line in file */
+# define SHOW_ERROR_LINE 1
+#endif
+
typedef struct scheme scheme;
typedef struct cell *pointer;
@@ -130,7 +139,7 @@ SCHEME_EXPORT void ts_output_string (TsOutputType type,
int len);
#endif
-SCHEME_EXPORT scheme *scheme_init_new();
+SCHEME_EXPORT scheme *scheme_init_new(void);
SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free);
SCHEME_EXPORT int scheme_init(scheme *sc);
SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc);
@@ -140,9 +149,11 @@ void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end);
SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin);
void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end);
SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin);
+SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename);
SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd);
-void scheme_apply0(scheme *sc, const char *procname);
-SCHEME_EXPORT pointer scheme_apply1(scheme *sc, const char *procname, pointer);
+SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname);
+SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args);
+SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj);
void scheme_set_external_data(scheme *sc, void *p);
SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value);
@@ -155,12 +166,14 @@ pointer mk_symbol(scheme *sc, const char *name);
pointer gensym(scheme *sc);
pointer mk_string(scheme *sc, const char *str);
pointer mk_counted_string(scheme *sc, const char *str, int len);
+pointer mk_empty_string(scheme *sc, int len, gunichar fill);
pointer mk_character(scheme *sc, gunichar c);
pointer mk_foreign_func(scheme *sc, foreign_func f);
void putcharacter(scheme *sc, gunichar c);
void putstr(scheme *sc, const char *s);
+int list_length(scheme *sc, pointer a);
+int eqv(pointer a, pointer b);
-SCHEME_EXPORT void set_safe_foreign (scheme *sc, pointer data);
SCHEME_EXPORT pointer foreign_error (scheme *sc, const char *s, pointer a);
#if USE_INTERFACE
@@ -195,7 +208,7 @@ struct scheme_interface {
gunichar (*charvalue)(pointer p);
int (*is_list)(scheme *sc, pointer p);
int (*is_vector)(pointer p);
- int (*list_length)(scheme *sc, pointer a);
+ int (*list_length)(scheme *sc, pointer p);
long (*vector_length)(pointer vec);
void (*fill_vector)(pointer vec, pointer elem);
pointer (*vector_elem)(pointer vec, int ielem);
@@ -232,5 +245,29 @@ struct scheme_interface {
};
#endif
+#if !STANDALONE
+typedef struct scheme_registerable
+{
+ foreign_func f;
+ char * name;
+}
+scheme_registerable;
+
+void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr);
+void scheme_register_foreign_func_list(scheme * sc,
+ scheme_registerable * list,
+ int n);
+
+#endif /* !STANDALONE */
+
+#ifdef __cplusplus
+}
+#endif
+
#endif
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
