├── tinyscheme-1.40-mingw ├── scheme.o ├── dynload.o ├── scheme.exe ├── libtinyscheme.a ├── libtinyscheme.dll ├── dynload.h ├── COPYING ├── makefile ├── dynload.c ├── MiniSCHEMETribute.txt ├── BUILDING ├── scheme-private.h ├── scheme.h └── hack.txt ├── oops-0.1.1 ├── Makefile ├── README ├── oops.c └── oops.scm ├── re ├── regerror.ih ├── debug.ih ├── main.ih ├── utils.h ├── re.scm ├── regfree.c ├── COPYRIGHT ├── cclass.h ├── re.makefile ├── README.1st ├── README ├── engine.ih ├── mkh ├── regcomp.ih ├── regex.h ├── cname.h ├── re.c ├── Makefile.in ├── regerror.c ├── regex.001 ├── regexec.c ├── WHATSNEW ├── regex2.h ├── debug.c ├── split.c └── regex.7 ├── tsx-1.1 ├── Makefile ├── tsx.h ├── LICENSE ├── listhome.scm ├── srepl.scm ├── README ├── smtp.scm └── tsx-functions.txt ├── tinyscheme-1.40 ├── dynload.h ├── COPYING ├── makefile ├── dynload.c ├── MiniSCHEMETribute.txt ├── BUILDING ├── scheme-private.h ├── scheme.h └── hack.txt └── minischeme ├── makefile ├── nextleaf.scm ├── init.scm ├── README └── tools.scm /tinyscheme-1.40-mingw/scheme.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sungit/TinyScheme/HEAD/tinyscheme-1.40-mingw/scheme.o -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/dynload.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sungit/TinyScheme/HEAD/tinyscheme-1.40-mingw/dynload.o -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/scheme.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sungit/TinyScheme/HEAD/tinyscheme-1.40-mingw/scheme.exe -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/libtinyscheme.a: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sungit/TinyScheme/HEAD/tinyscheme-1.40-mingw/libtinyscheme.a -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/libtinyscheme.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sungit/TinyScheme/HEAD/tinyscheme-1.40-mingw/libtinyscheme.dll -------------------------------------------------------------------------------- /oops-0.1.1/Makefile: -------------------------------------------------------------------------------- 1 | #DEBUG=-g 2 | DEBUG= 3 | SCHEME_H_DIR=.. 4 | CC=gcc 5 | CFLAGS=-DUSE_DL=1 -I$(SCHEME_H_DIR) 6 | 7 | oops.so : oops.c Makefile 8 | $(CC) -shared -Wall -fPIC $(CFLAGS) -o $@ $(DEBUG) oops.c 9 | strip oops.so 10 | 11 | .PHONY : clean 12 | clean: 13 | rm -f *.so 14 | rm -f *~ 15 | -------------------------------------------------------------------------------- /re/regerror.ih: -------------------------------------------------------------------------------- 1 | /* ========= begin header generated by ./mkh ========= */ 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | 6 | /* === regerror.c === */ 7 | static char *regatoi(const regex_t *preg, char *localbuf); 8 | 9 | #ifdef __cplusplus 10 | } 11 | #endif 12 | /* ========= end header generated by ./mkh ========= */ 13 | -------------------------------------------------------------------------------- /tsx-1.1/Makefile: -------------------------------------------------------------------------------- 1 | #DEBUG=-g 2 | DEBUG= 3 | SCHEME_H_DIR=.. 4 | CC=gcc 5 | CFLAGS=-DUSE_DL=1 -I $(SCHEME_H_DIR) 6 | 7 | tsx.so : tsx.c tsx.h Makefile 8 | $(CC) -shared -Wall -fPIC $(CFLAGS) -o tsx.so $(DEBUG) tsx.c 9 | strip tsx.so 10 | ls -l tsx.so 11 | 12 | .PHONY : clean 13 | clean: 14 | rm -f *.o 15 | rm -f tsx.so 16 | rm -f *~ -------------------------------------------------------------------------------- /tinyscheme-1.40/dynload.h: -------------------------------------------------------------------------------- 1 | /* dynload.h */ 2 | /* Original Copyright (c) 1999 Alexander Shendi */ 3 | /* Modifications for NT and dl_* interface: D. Souflis */ 4 | 5 | #ifndef DYNLOAD_H 6 | #define DYNLOAD_H 7 | 8 | #include "scheme-private.h" 9 | 10 | SCHEME_EXPORT pointer scm_load_ext(scheme *sc, pointer arglist); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/dynload.h: -------------------------------------------------------------------------------- 1 | /* dynload.h */ 2 | /* Original Copyright (c) 1999 Alexander Shendi */ 3 | /* Modifications for NT and dl_* interface: D. Souflis */ 4 | 5 | #ifndef DYNLOAD_H 6 | #define DYNLOAD_H 7 | 8 | #include "scheme-private.h" 9 | 10 | SCHEME_EXPORT pointer scm_load_ext(scheme *sc, pointer arglist); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /re/debug.ih: -------------------------------------------------------------------------------- 1 | /* ========= begin header generated by ./mkh ========= */ 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | 6 | /* === debug.c === */ 7 | void regprint(regex_t *r, FILE *d); 8 | static void s_print(register struct re_guts *g, FILE *d); 9 | static char *regchar(int ch); 10 | 11 | #ifdef __cplusplus 12 | } 13 | #endif 14 | /* ========= end header generated by ./mkh ========= */ 15 | -------------------------------------------------------------------------------- /minischeme/makefile: -------------------------------------------------------------------------------- 1 | # Makefile for System-V flavoured UNIX 2 | # 3 | #CC = gcc # you may use both ANSI and pre-ANSI 4 | 5 | # 6 | # Please see source and/or README for system defition 7 | # 8 | #CFLAGS = -g -DSYSV -traditional -traditional-cpp -Wid-clash-8 9 | CFLAGS = -O -DSYSV 10 | 11 | all : miniscm 12 | 13 | miniscm : miniscm.c Makefile 14 | $(CC) $(CFLAGS) -o miniscm miniscm.c 15 | 16 | clean : 17 | rm -f core *.o miniscm *~ 18 | 19 | -------------------------------------------------------------------------------- /re/main.ih: -------------------------------------------------------------------------------- 1 | /* ========= begin header generated by ./mkh ========= */ 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | 6 | /* === main.c === */ 7 | void regress(FILE *in); 8 | void try(char *f0, char *f1, char *f2, char *f3, char *f4, int opts); 9 | int options(int type, char *s); 10 | int opt(int c, char *s); 11 | void fixstr(register char *p); 12 | char *check(char *str, regmatch_t sub, char *should); 13 | static char *eprint(int err); 14 | static int efind(char *name); 15 | 16 | #ifdef __cplusplus 17 | } 18 | #endif 19 | /* ========= end header generated by ./mkh ========= */ 20 | -------------------------------------------------------------------------------- /re/utils.h: -------------------------------------------------------------------------------- 1 | /* utility definitions */ 2 | #ifndef _POSIX2_RE_DUP_MAX 3 | #define _POSIX2_RE_DUP_MAX 255 4 | #endif 5 | 6 | #define DUPMAX _POSIX2_RE_DUP_MAX /* xxx is this right? */ 7 | #define INFINITY (DUPMAX + 1) 8 | #define NC (CHAR_MAX - CHAR_MIN + 1) 9 | typedef unsigned char uch; 10 | 11 | /* switch off assertions (if not already off) if no REDEBUG */ 12 | #ifndef REDEBUG 13 | #ifndef NDEBUG 14 | #define NDEBUG /* no assertions please */ 15 | #endif 16 | #endif 17 | #include 18 | 19 | /* for old systems with bcopy() but no memmove() */ 20 | #ifdef USEBCOPY 21 | #define memmove(d, s, c) bcopy(s, d, c) 22 | #endif 23 | -------------------------------------------------------------------------------- /re/re.scm: -------------------------------------------------------------------------------- 1 | ;; return the substring of STRING matched in MATCH-VECTOR, 2 | ;; the Nth subexpression match (default 0). 3 | (define (re-match-nth string match-vector . n) 4 | (let ((n (if (pair? n) (car n) 0))) 5 | (substring string (car (vector-ref match-vector n)) 6 | (cdr (vector-ref match-vector n))))) 7 | 8 | (define (re-before-nth string match-vector . n) 9 | (let ((n (if (pair? n) (car n) 0))) 10 | (substring string 0 (car (vector-ref match-vector n))))) 11 | 12 | (define (re-after-nth string match-vector . n) 13 | (let ((n (if (pair? n) (car n) 0))) 14 | (substring string (cdr (vector-ref match-vector n)) 15 | (string-length string)))) -------------------------------------------------------------------------------- /oops-0.1.1/README: -------------------------------------------------------------------------------- 1 | TinyScheme OOPS (Object Oriented Programming System) extension version 0.1 2 | for TinyScheme 1.38 3 | 4 | (c) 2007 Sergey Cherepanov (s-cherepanov@users.sourceforge.net) 5 | 6 | 7 | TinyScheme OOPS is a port of Elk Scheme (http://sam.zoy.org/elk/) OOPS. This 8 | extension provide two foreign functions: 'set-closure-environment!' and 9 | 'environment->list'. 10 | 11 | Synopsis: 12 | (set-closure-environment! ) 13 | (environment->list ) 14 | 15 | Programs that make use of the OOPS package should load OOPS extension and file 16 | 'oops.scm' 17 | 18 | File 'oops.scm' is a port of Elk Scheme 'oops.scm'. Elk Scheme OOPS described in 19 | file 'oops.html'. 20 | -------------------------------------------------------------------------------- /tsx-1.1/tsx.h: -------------------------------------------------------------------------------- 1 | /* TinyScheme Extensions 2 | * (c) 2001 Manuel Heras-Gilsanz 3 | * 4 | * This software is subject to the terms stated in the 5 | * LICENSE file. 6 | */ 7 | 8 | /* Comment those #defines whose functionality you don't 9 | * want to include. 10 | */ 11 | 12 | /* Comment the following line if you don't need sockets */ 13 | #define HAVE_SOCKETS 14 | 15 | /* Comment the following line if you don't need filesystem 16 | * functionality (file-size, file-exists?, etc). 17 | */ 18 | #define HAVE_FILESYSTEM 19 | 20 | /* Comment the following line if you don't need time functions */ 21 | #define HAVE_TIME 22 | 23 | /* Comment the following line if you don't need getenv and system */ 24 | #define HAVE_MISC 25 | -------------------------------------------------------------------------------- /minischeme/nextleaf.scm: -------------------------------------------------------------------------------- 1 | ;;;; Sample of co-routine by call/cc 2 | (define (apply-to-next-leaf proc tree endmark) 3 | (letrec 4 | ((return #f) 5 | (cont (lambda (l) 6 | (recurse l) 7 | (set! cont (lambda (d) (return endmark))) 8 | (cont #f))) 9 | (recurse (lambda (l) 10 | (if (pair? l) 11 | (for-each recurse l) 12 | (call/cc (lambda (c) (set! cont c) (return (proc l)))))))) 13 | (lambda () 14 | (call/cc (lambda (c) (set! return c) (cont tree)))))) 15 | 16 | (define (foo lis) 17 | (let ((bar (apply-to-next-leaf (lambda (x) (* x x)) lis '()))) 18 | (let loop ((n (bar))) 19 | (if (not (null? n)) 20 | (begin 21 | (display n) 22 | (newline) 23 | (loop (bar))))))) 24 | 25 | ;; foo prints each elements (leaves) squared 26 | (foo '(1 2 (3 (4 5) (6 (7)) 8) 9 10)) 27 | 28 | -------------------------------------------------------------------------------- /re/regfree.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include "utils.h" 4 | #include "regex2.h" 5 | 6 | /* 7 | - regfree - free everything 8 | = API_EXPORT(void) regfree(regex_t *); 9 | */ 10 | API_EXPORT(void) 11 | regfree(preg) 12 | regex_t *preg; 13 | { 14 | register struct re_guts *g; 15 | 16 | if (preg->re_magic != MAGIC1) /* oops */ 17 | return; /* nice to complain, but hard */ 18 | 19 | g = preg->re_g; 20 | if (g == NULL || g->magic != MAGIC2) /* oops again */ 21 | return; 22 | preg->re_magic = 0; /* mark it invalid */ 23 | g->magic = 0; /* mark it invalid */ 24 | 25 | if (g->strip != NULL) 26 | free((char *)g->strip); 27 | if (g->sets != NULL) 28 | free((char *)g->sets); 29 | if (g->setbits != NULL) 30 | free((char *)g->setbits); 31 | if (g->must != NULL) 32 | free(g->must); 33 | free((char *)g); 34 | } 35 | -------------------------------------------------------------------------------- /re/COPYRIGHT: -------------------------------------------------------------------------------- 1 | Copyright 1992, 1993, 1994 Henry Spencer. All rights reserved. 2 | This software is not subject to any license of the American Telephone 3 | and Telegraph Company or of the Regents of the University of California. 4 | 5 | Permission is granted to anyone to use this software for any purpose on 6 | any computer system, and to alter it and redistribute it, subject 7 | to the following restrictions: 8 | 9 | 1. The author is not responsible for the consequences of use of this 10 | software, no matter how awful, even if they arise from flaws in it. 11 | 12 | 2. The origin of this software must not be misrepresented, either by 13 | explicit claim or by omission. Since few users ever read sources, 14 | credits must appear in the documentation. 15 | 16 | 3. Altered versions must be plainly marked as such, and must not be 17 | misrepresented as being the original software. Since few users 18 | ever read sources, credits must appear in the documentation. 19 | 20 | 4. This notice may not be removed or altered. 21 | -------------------------------------------------------------------------------- /re/cclass.h: -------------------------------------------------------------------------------- 1 | /* character-class table */ 2 | static struct cclass { 3 | char *name; 4 | char *chars; 5 | char *multis; 6 | } cclasses[] = { 7 | { "alnum", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 8 | 0123456789", "" }, 9 | { "alpha", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", 10 | "" }, 11 | { "blank", " \t", "" }, 12 | { "cntrl", "\007\b\t\n\v\f\r\1\2\3\4\5\6\16\17\20\21\22\23\24\ 13 | \25\26\27\30\31\32\33\34\35\36\37\177", "" }, 14 | { "digit", "0123456789", "" }, 15 | { "graph", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 16 | 0123456789!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~", 17 | "" }, 18 | { "lower", "abcdefghijklmnopqrstuvwxyz", 19 | "" }, 20 | { "print", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 21 | 0123456789!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~ ", 22 | "" }, 23 | { "punct", "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~", 24 | "" }, 25 | { "space", "\t\n\v\f\r ", "" }, 26 | { "upper", "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 27 | "" }, 28 | { "xdigit", "0123456789ABCDEFabcdef", 29 | "" }, 30 | { NULL, 0, "" } 31 | }; 32 | -------------------------------------------------------------------------------- /re/re.makefile: -------------------------------------------------------------------------------- 1 | # Makefile for TinyScheme's extension library "re" (regular expressions) 2 | # Time-stamp: <2002-06-24 14:13:42 gildea> 3 | 4 | SCHEME_H_DIR=../tinyscheme-1.30 5 | 6 | # Windows/2000 7 | # CC = cl -nologo 8 | # DEBUG = -W3 -Z7 -MD 9 | # SYS_LIBS= 10 | # Osuf=obj 11 | # SOsuf=dll 12 | # LD = link -nologo 13 | # LDFLAGS = -debug -map -dll -incremental:no 14 | # OUT = -out:$@ 15 | 16 | # Unix, generally 17 | CC = gcc -fpic 18 | DEBUG=-g -Wall -Wno-char-subscripts -O 19 | Osuf=o 20 | SOsuf=so 21 | OUT = -o $@ 22 | 23 | # Linux 24 | LD = gcc 25 | LDFLAGS = -shared 26 | SYS_LIBS= 27 | 28 | # Solaris 29 | # LD = /usr/ccs/bin/ld 30 | ## -Bsymbolic nec. because we have fns w same name as in libc. 31 | # LDFLAGS = -G -Bsymbolic -z text 32 | # SYS_LIBS= -lc 33 | 34 | SRCS = re.c debug.c regcomp.c regerror.c regexec.c regfree.c split.c 35 | OBJS = $(SRCS:.c=.$(Osuf)) 36 | 37 | all: re.$(SOsuf) 38 | 39 | %.$(Osuf): %.c 40 | $(CC) -c $(DEBUG) -DUSE_DL -I. -I$(SCHEME_H_DIR) $+ 41 | 42 | re.$(SOsuf): $(OBJS) 43 | $(LD) $(LDFLAGS) $(OUT) $+ $(SYS_LIBS) 44 | 45 | clean: 46 | -rm -f $(OBJS) re.$(SOsuf) 47 | -------------------------------------------------------------------------------- /re/README.1st: -------------------------------------------------------------------------------- 1 | TinyScheme RE (Regular Expressions) extension 2 | --------------------------------------------- 3 | Version 1.2, August 2002 4 | 5 | The bulk of this directory is the regular expression library written 6 | by Henry Spencer (see file README and COPYRIGHT). 7 | 8 | Two files were added to produce the TinyScheme regular expression 9 | library, re.so: re.c and re.makefile. The included re.makefile was contributed 10 | initially by Stephen Gildea and should be adaptable to all Unix systems. 11 | 12 | The makefile produces a DLL named re.so. For now, it contains just 13 | a single foreign function (re-match ). It returns 14 | true (string matches pattern) or false. If it is called with an 15 | extra parameter, which should be a vector, overwrites as many elements 16 | of the vector as needed with the strings that matched the corresponding 17 | parenthesized subexpressions inside . 18 | 19 | It is not fully tested, so use with caution. 20 | 21 | Load the extension from inside TinyScheme using 22 | (load-extension "re/re") 23 | assuming that re.so is in the directory "re". 24 | 25 | Load "re.scm" if you wish to use v.1.1 behavior. 26 | 27 | dsouflis@acm.org 28 | -------------------------------------------------------------------------------- /re/README: -------------------------------------------------------------------------------- 1 | alpha3.4 release. 2 | Thu Mar 17 23:17:18 EST 1994 3 | henry@zoo.toronto.edu 4 | 5 | See WHATSNEW for change listing. 6 | 7 | installation notes: 8 | -------- 9 | Read the comments at the beginning of Makefile before running. 10 | 11 | Utils.h contains some things that just might have to be modified on 12 | some systems, as well as a nested include (ugh) of . 13 | 14 | The "fake" directory contains quick-and-dirty fakes for some header 15 | files and routines that old systems may not have. Note also that 16 | -DUSEBCOPY will make utils.h substitute bcopy() for memmove(). 17 | 18 | After that, "make r" will build regcomp.o, regexec.o, regfree.o, 19 | and regerror.o (the actual routines), bundle them together into a test 20 | program, and run regression tests on them. No output is good output. 21 | 22 | "make lib" builds just the .o files for the actual routines (when 23 | you're happy with testing and have adjusted CFLAGS for production), 24 | and puts them together into libregex.a. You can pick up either the 25 | library or *.o ("make lib" makes sure there are no other .o files left 26 | around to confuse things). 27 | 28 | Main.c, debug.c, split.c are used for regression testing but are not part 29 | of the RE routines themselves. 30 | 31 | Regex.h goes in /usr/include. All other .h files are internal only. 32 | -------- 33 | -------------------------------------------------------------------------------- /re/engine.ih: -------------------------------------------------------------------------------- 1 | /* ========= begin header generated by ./mkh ========= */ 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | 6 | /* === engine.c === */ 7 | static int matcher(register struct re_guts *g, char *string, size_t nmatch, regmatch_t pmatch[], int eflags); 8 | static char *dissect(register struct match *m, char *start, char *stop, sopno startst, sopno stopst); 9 | static char *backref(register struct match *m, char *start, char *stop, sopno startst, sopno stopst, sopno lev); 10 | static char *fast(register struct match *m, char *start, char *stop, sopno startst, sopno stopst); 11 | static char *slow(register struct match *m, char *start, char *stop, sopno startst, sopno stopst); 12 | static states step(register struct re_guts *g, sopno start, sopno stop, register states bef, int ch, register states aft); 13 | #define BOL (OUT+1) 14 | #define EOL (BOL+1) 15 | #define BOLEOL (BOL+2) 16 | #define NOTHING (BOL+3) 17 | #define BOW (BOL+4) 18 | #define EOW (BOL+5) 19 | #define CODEMAX (BOL+5) /* highest code used */ 20 | #define NONCHAR(c) ((c) > CHAR_MAX) 21 | #define NNONCHAR (CODEMAX-CHAR_MAX) 22 | #ifdef REDEBUG 23 | static void print(struct match *m, char *caption, states st, int ch, FILE *d); 24 | #endif 25 | #ifdef REDEBUG 26 | static void at(struct match *m, char *title, char *start, char *stop, sopno startst, sopno stopst); 27 | #endif 28 | #ifdef REDEBUG 29 | static char *pchar(int ch); 30 | #endif 31 | 32 | #ifdef __cplusplus 33 | } 34 | #endif 35 | /* ========= end header generated by ./mkh ========= */ 36 | -------------------------------------------------------------------------------- /tinyscheme-1.40/COPYING: -------------------------------------------------------------------------------- 1 | LICENSE TERMS 2 | 3 | Copyright (c) 2000, Dimitrios Souflis 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are 8 | met: 9 | 10 | Redistributions of source code must retain the above copyright notice, 11 | this list of conditions and the following disclaimer. 12 | 13 | Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | Neither the name of Dimitrios Souflis nor the names of the 18 | contributors may be used to endorse or promote products derived from 19 | this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR 25 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 26 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 27 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/COPYING: -------------------------------------------------------------------------------- 1 | LICENSE TERMS 2 | 3 | Copyright (c) 2000, Dimitrios Souflis 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are 8 | met: 9 | 10 | Redistributions of source code must retain the above copyright notice, 11 | this list of conditions and the following disclaimer. 12 | 13 | Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | Neither the name of Dimitrios Souflis nor the names of the 18 | contributors may be used to endorse or promote products derived from 19 | this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR 25 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 26 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 27 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /tsx-1.1/LICENSE: -------------------------------------------------------------------------------- 1 | LICENSE TERMS 2 | 3 | (c) 2002 Manuel Heras-Gilsanz (manuel@heras-gilsanz.com) 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are 8 | met: 9 | 10 | Redistributions of source code must retain the above copyright notice, 11 | this list of conditions and the following disclaimer. 12 | 13 | Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | Neither the name of Manuel Heras-Gilsanz nor the names of the 18 | contributors may be used to endorse or promote products derived from 19 | this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR 25 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 26 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 27 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /tsx-1.1/listhome.scm: -------------------------------------------------------------------------------- 1 | ; listhome.scm 2 | ; Sample usage of TinyScheme Extension 3 | ; This simple program lists the directory entries on the 4 | ; user's home directory. 5 | 6 | ; It uses the following TinyScheme Extension functions: 7 | ; getenv 8 | ; Used to get HOME environment variable. 9 | ; open-dir-stream 10 | ; Used to open directory stream. 11 | ; read-dir-entry 12 | ; Used to read directory entries. 13 | ; close-dir-entry 14 | ; Used at the end, to close directory stream when done. 15 | 16 | ; check that extensions are enabled 17 | (if (not (defined? 'load-extension)) 18 | (begin 19 | (display "TinyScheme has extensions disabled. Enable them!!") 20 | (newline) 21 | (quit))) 22 | 23 | ; load TinyScheme extension 24 | (load-extension "tsx-1.0/tsx") 25 | 26 | ; check that the necessary functions are available (the user 27 | ; might have removed some functionality...) 28 | (if (or 29 | (not (defined? 'getenv)) 30 | (not (defined? 'open-dir-stream)) 31 | (not (defined? 'read-dir-entry)) 32 | (not (defined? 'close-dir-stream))) 33 | (begin 34 | (display "Some necessary functions are not available. Exiting!") 35 | (newline) 36 | (quit))) 37 | 38 | ; get user's home dir from HOME environment var 39 | (define homedir (getenv "HOME")) 40 | (display "Listing contents of ") (display homedir) (newline) 41 | 42 | ; create directory stream to read dir entries 43 | (define dirstream (open-dir-stream homedir)) 44 | (if (not dirstream) 45 | (begin 46 | (display "Unable to open home directory!! Check value of HOME environment var.") 47 | (quit))) 48 | 49 | (let listentry ((entry (read-dir-entry dirstream))) 50 | (if (eof-object? entry) 51 | #t 52 | (begin 53 | (display entry) 54 | (newline) 55 | (listentry (read-dir-entry dirstream))))) 56 | 57 | (close-dir-stream dirstream) 58 | 59 | -------------------------------------------------------------------------------- /oops-0.1.1/oops.c: -------------------------------------------------------------------------------- 1 | /* 2 | * TinyScheme OOPS (Object Oriented Programming System) extension version 0.1 3 | * for TinyScheme 1.38 4 | * 5 | * (c) 2007 Sergey Cherepanov (s-cherepanov@users.sourceforge.net) 6 | */ 7 | 8 | #include "scheme-private.h" 9 | 10 | static pointer set_closure_environment(scheme *sc, pointer args) 11 | { 12 | if (sc->vptr->is_pair(args)) { 13 | pointer p1 = sc->vptr->pair_car(args); 14 | 15 | if (sc->vptr->is_closure(p1)) { 16 | pointer p2 = sc->vptr->pair_cdr(args); 17 | 18 | if (sc->vptr->pair_cdr(p2) == sc->NIL) { 19 | pointer p3 = sc->vptr->pair_car(p2); 20 | 21 | if (sc->vptr->is_environment(p3)) { 22 | sc->vptr->set_cdr(p1, p3); 23 | return sc->T; 24 | } 25 | } 26 | } 27 | } 28 | return sc->F; 29 | } 30 | 31 | #undef cons 32 | 33 | static pointer copy_list(scheme *sc, pointer l) 34 | { 35 | if (sc->vptr->is_pair(l)) { 36 | pointer car = sc->NIL, cdr = sc->NIL; 37 | 38 | car = copy_list(sc, sc->vptr->pair_car(l)); 39 | cdr = copy_list(sc, sc->vptr->pair_cdr(l)); 40 | l = sc->vptr->cons(sc, car, cdr); 41 | } 42 | return l; 43 | } 44 | 45 | #define settype(p,t) (p)->_flag=((p)->_flag&~31)|t 46 | 47 | static pointer environment_to_list(scheme *sc, pointer arg) 48 | { 49 | pointer e = sc->vptr->pair_car(arg); 50 | 51 | if (sc->vptr->is_environment(e)) { 52 | pointer l; 53 | 54 | settype(e, 5); /* T_PAIR */ 55 | l = copy_list(sc, e); 56 | settype(e, 14); /* T_ENVIRONMENT */ 57 | return l; 58 | } 59 | return sc->NIL; 60 | } 61 | 62 | SCHEME_EXPORT void init_oops(scheme *sc) 63 | { 64 | sc->vptr->scheme_define(sc, sc->global_env, 65 | sc->vptr->mk_symbol(sc, "set-closure-environment!"), 66 | sc->vptr->mk_foreign_func(sc, set_closure_environment)); 67 | sc->vptr->scheme_define(sc, sc->global_env, 68 | sc->vptr->mk_symbol(sc, "environment->list"), 69 | sc->vptr->mk_foreign_func(sc, environment_to_list)); 70 | } 71 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/makefile: -------------------------------------------------------------------------------- 1 | # Makefile for TinyScheme 2 | # Time-stamp: <2002-06-24 14:13:27 gildea> 3 | 4 | # Windows/2000 5 | #CC = cl -nologo 6 | #DEBUG= -W3 -Z7 -MD 7 | #DL_FLAGS= 8 | #SYS_LIBS= 9 | #Osuf=obj 10 | #SOsuf=dll 11 | #LIBsuf=.lib 12 | #EXE_EXT=.exe 13 | #LD = link -nologo 14 | #LDFLAGS = -debug -map -dll -incremental:no 15 | #LIBPREFIX = 16 | #OUT = -out:$@ 17 | #RM= -del 18 | #AR= echo 19 | 20 | # Unix, generally 21 | CC = gcc -fpic 22 | DEBUG=-g -Wall -Wno-char-subscripts -O 23 | Osuf=o 24 | SOsuf=so 25 | LIBsuf=a 26 | EXE_EXT= 27 | LIBPREFIX=lib 28 | OUT = -o $@ 29 | RM= -rm -f 30 | AR= ar crs 31 | 32 | # Linux 33 | LD = gcc 34 | LDFLAGS = -shared 35 | DEBUG=-g -Wno-char-subscripts -O 36 | SYS_LIBS= 37 | PLATFORM_FEATURES= -DSUN_DL=1 38 | 39 | # Cygwin 40 | #PLATFORM_FEATURES = -DUSE_STRLWR=0 41 | 42 | 43 | # Solaris 44 | #SYS_LIBS= -ldl -lc 45 | #Osuf=o 46 | #SOsuf=so 47 | #EXE_EXT= 48 | #LD = ld 49 | #LDFLAGS = -G -Bsymbolic -z text 50 | #LIBPREFIX = lib 51 | #OUT = -o $@ 52 | 53 | FEATURES = $(PLATFORM_FEATURES) -DUSE_DL=1 -DUSE_MATH=0 -DUSE_ASCII_NAMES=0 54 | 55 | OBJS = scheme.$(Osuf) dynload.$(Osuf) 56 | 57 | LIBTARGET = $(LIBPREFIX)tinyscheme.$(SOsuf) 58 | STATICLIBTARGET = $(LIBPREFIX)tinyscheme.$(LIBsuf) 59 | 60 | all: $(LIBTARGET) $(STATICLIBTARGET) scheme$(EXE_EXT) 61 | 62 | %.$(Osuf): %.c 63 | $(CC) -I. -c $(DEBUG) $(FEATURES) $(DL_FLAGS) $< 64 | 65 | $(LIBTARGET): $(OBJS) 66 | $(LD) $(LDFLAGS) $(OUT) $(OBJS) $(SYS_LIBS) 67 | 68 | scheme$(EXE_EXT): $(OBJS) 69 | $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS) 70 | 71 | $(STATICLIBTARGET): $(OBJS) 72 | $(AR) $@ $(OBJS) 73 | 74 | $(OBJS): scheme.h scheme-private.h opdefines.h 75 | dynload.$(Osuf): dynload.h 76 | 77 | clean: 78 | $(RM) $(OBJS) $(LIBTARGET) $(STATICLIBTARGET) scheme$(EXE_EXT) 79 | $(RM) tinyscheme.ilk tinyscheme.map tinyscheme.pdb tinyscheme.exp 80 | $(RM) scheme.ilk scheme.map scheme.pdb scheme.lib scheme.exp 81 | $(RM) *~ 82 | 83 | TAGS_SRCS = scheme.h scheme.c dynload.h dynload.c 84 | 85 | tags: TAGS 86 | TAGS: $(TAGS_SRCS) 87 | etags $(TAGS_SRCS) 88 | -------------------------------------------------------------------------------- /tinyscheme-1.40/makefile: -------------------------------------------------------------------------------- 1 | # Makefile for TinyScheme 2 | # Time-stamp: <2002-06-24 14:13:27 gildea> 3 | 4 | # Windows/2000 5 | #CC = cl -nologo 6 | #DEBUG= -W3 -Z7 -MD 7 | #DL_FLAGS= 8 | #SYS_LIBS= 9 | #Osuf=obj 10 | #SOsuf=dll 11 | #LIBsuf=.lib 12 | #EXE_EXT=.exe 13 | #LD = link -nologo 14 | #LDFLAGS = -debug -map -dll -incremental:no 15 | #LIBPREFIX = 16 | #OUT = -out:$@ 17 | #RM= -del 18 | #AR= echo 19 | 20 | # Unix, generally 21 | CC = gcc -fpic 22 | DEBUG=-g -Wall -Wno-char-subscripts -O 23 | Osuf=o 24 | SOsuf=so 25 | LIBsuf=a 26 | EXE_EXT= 27 | LIBPREFIX=lib 28 | OUT = -o $@ 29 | RM= -rm -f 30 | AR= ar crs 31 | 32 | # Linux 33 | LD = gcc 34 | LDFLAGS = -shared 35 | DEBUG=-g -Wno-char-subscripts -O 36 | SYS_LIBS= -ldl 37 | PLATFORM_FEATURES= -DSUN_DL=1 38 | 39 | # Cygwin 40 | #PLATFORM_FEATURES = -DUSE_STRLWR=0 41 | 42 | 43 | # Solaris 44 | #SYS_LIBS= -ldl -lc 45 | #Osuf=o 46 | #SOsuf=so 47 | #EXE_EXT= 48 | #LD = ld 49 | #LDFLAGS = -G -Bsymbolic -z text 50 | #LIBPREFIX = lib 51 | #OUT = -o $@ 52 | 53 | FEATURES = $(PLATFORM_FEATURES) -DUSE_DL=1 -DUSE_MATH=0 -DUSE_ASCII_NAMES=0 54 | 55 | OBJS = scheme.$(Osuf) dynload.$(Osuf) 56 | 57 | LIBTARGET = $(LIBPREFIX)tinyscheme.$(SOsuf) 58 | STATICLIBTARGET = $(LIBPREFIX)tinyscheme.$(LIBsuf) 59 | 60 | all: $(LIBTARGET) $(STATICLIBTARGET) scheme$(EXE_EXT) 61 | 62 | %.$(Osuf): %.c 63 | $(CC) -I. -c $(DEBUG) $(FEATURES) $(DL_FLAGS) $< 64 | 65 | $(LIBTARGET): $(OBJS) 66 | $(LD) $(LDFLAGS) $(OUT) $(OBJS) $(SYS_LIBS) 67 | 68 | scheme$(EXE_EXT): $(OBJS) 69 | $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS) 70 | 71 | $(STATICLIBTARGET): $(OBJS) 72 | $(AR) $@ $(OBJS) 73 | 74 | $(OBJS): scheme.h scheme-private.h opdefines.h 75 | dynload.$(Osuf): dynload.h 76 | 77 | clean: 78 | $(RM) $(OBJS) $(LIBTARGET) $(STATICLIBTARGET) scheme$(EXE_EXT) 79 | $(RM) tinyscheme.ilk tinyscheme.map tinyscheme.pdb tinyscheme.exp 80 | $(RM) scheme.ilk scheme.map scheme.pdb scheme.lib scheme.exp 81 | $(RM) *~ 82 | 83 | TAGS_SRCS = scheme.h scheme.c dynload.h dynload.c 84 | 85 | tags: TAGS 86 | TAGS: $(TAGS_SRCS) 87 | etags $(TAGS_SRCS) 88 | -------------------------------------------------------------------------------- /re/mkh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | # mkh - pull headers out of C source 3 | PATH=/bin:/usr/bin ; export PATH 4 | 5 | # egrep pattern to pick out marked lines 6 | egrep='^ =([ ]|$)' 7 | 8 | # Sed program to process marked lines into lines for the header file. 9 | # The markers have already been removed. Two things are done here: removal 10 | # of backslashed newlines, and some fudging of comments. The first is done 11 | # because -o needs to have prototypes on one line to strip them down. 12 | # Getting comments into the output is tricky; we turn C++-style // comments 13 | # into /* */ comments, after altering any existing */'s to avoid trouble. 14 | peel=' /\\$/N 15 | /\\\n[ ]*/s///g 16 | /\/\//s;\*/;* /;g 17 | /\/\//s;//\(.*\);/*\1 */;' 18 | 19 | for a 20 | do 21 | case "$a" in 22 | -o) # old (pre-function-prototype) compiler 23 | # add code to comment out argument lists 24 | peel="$peel 25 | "'/^\([^#\/][^\/]*[a-zA-Z0-9_)]\)(\(.*\))/s;;\1(/*\2*/);' 26 | shift 27 | ;; 28 | -b) # funny Berkeley __P macro 29 | peel="$peel 30 | "'/^\([^#\/][^\/]*[a-zA-Z0-9_)]\)(\(.*\))/s;;\1 __P((\2));' 31 | shift 32 | ;; 33 | -s) # compiler doesn't like `static foo();' 34 | # add code to get rid of the `static' 35 | peel="$peel 36 | "'/^static[ ][^\/]*[a-zA-Z0-9_)](.*)/s;static.;;' 37 | shift 38 | ;; 39 | -p) # private declarations 40 | egrep='^ ==([ ]|$)' 41 | shift 42 | ;; 43 | -i) # wrap in #ifndef, argument is name 44 | ifndef="$2" 45 | shift ; shift 46 | ;; 47 | *) break 48 | ;; 49 | esac 50 | done 51 | 52 | if test " $ifndef" != " " 53 | then 54 | echo "#ifndef $ifndef" 55 | echo "#define $ifndef /* never again */" 56 | fi 57 | echo "/* ========= begin header generated by $0 ========= */" 58 | echo '#ifdef __cplusplus' 59 | echo 'extern "C" {' 60 | echo '#endif' 61 | for f 62 | do 63 | echo 64 | echo "/* === $f === */" 65 | egrep "$egrep" $f | sed 's/^ ==*[ ]//;s/^ ==*$//' | sed "$peel" 66 | echo 67 | done 68 | echo '#ifdef __cplusplus' 69 | echo '}' 70 | echo '#endif' 71 | echo "/* ========= end header generated by $0 ========= */" 72 | if test " $ifndef" != " " 73 | then 74 | echo "#endif" 75 | fi 76 | exit 0 77 | -------------------------------------------------------------------------------- /tsx-1.1/srepl.scm: -------------------------------------------------------------------------------- 1 | ; srepl.scm 2 | ; Sample usage of TinyScheme Extensions 3 | ; This program provides a socket-based read-eval-print-loop. 4 | 5 | ; It uses the following TinyScheme Extension functions: 6 | ; make-server-socket 7 | ; used to create server socket on port 9000 8 | ; accept 9 | ; used to accept client requests for connection 10 | ; recv-new-string 11 | ; used to receive user's requests 12 | ; send 13 | ; used to send evaluation results 14 | ; close-socket 15 | ; used to free socket at the end 16 | 17 | ; check that string ports are available... 18 | (if (not (defined? 'open-output-string)) 19 | (begin 20 | (display "We need string ports!! Recompile TinyScheme with string ports,") 21 | (display " if you want to run this sample...") 22 | (quit))) 23 | 24 | ; check that extensions are enabled 25 | (if (not (defined? 'load-extension)) 26 | (begin 27 | (display "TinyScheme has extensions disabled. Enable them!!") 28 | (newline) 29 | (quit))) 30 | 31 | ; load TinyScheme Extensions 32 | (load-extension "tsx-1.0/tsx") 33 | 34 | ; check that the necessary functions are available (the user 35 | ; might have removed some functionality...) 36 | (if (or 37 | (not (defined? 'make-server-socket)) 38 | (not (defined? 'accept)) 39 | (not (defined? 'send)) 40 | (not (defined? 'close-socket)) 41 | (not (defined? 'recv-new-string))) 42 | (begin 43 | (display "Some necessary functions are not available. Exiting!") 44 | (newline) 45 | (quit))) 46 | 47 | ; create server socket on port 9000 48 | (define server-socket (make-server-socket 9000)) 49 | 50 | ; wait for client requests 51 | (define connected-socket (accept server-socket)) 52 | 53 | ; send welcome message 54 | (send connected-socket "Welcome to TinyScheme Extensions socket-REPL!\n") 55 | 56 | ; define auxiliary variables 57 | (define command '()) 58 | (define command-port '()) 59 | (define result '()) 60 | (define result-port '()) 61 | (define to-eval '()) 62 | 63 | (define extenv (current-environment)) 64 | (let repl () 65 | (send connected-socket "> ") 66 | (set! command (recv-new-string connected-socket)) 67 | (set! command-port (open-input-string command)) 68 | (set! to-eval (read command-port)) 69 | (set! result (make-string 250)) 70 | (set! result-port (open-output-string result)) 71 | (display (eval to-eval) result-port) 72 | (send connected-socket result) 73 | (send connected-socket "\n") 74 | (close-input-port command-port) 75 | (close-output-port result-port) 76 | (repl) 77 | ) 78 | -------------------------------------------------------------------------------- /re/regcomp.ih: -------------------------------------------------------------------------------- 1 | /* ========= begin header generated by ./mkh ========= */ 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | 6 | /* === regcomp.c === */ 7 | static void p_ere(register struct parse *p, int stop); 8 | static void p_ere_exp(register struct parse *p); 9 | static void p_str(register struct parse *p); 10 | static void p_bre(register struct parse *p, register int end1, register int end2); 11 | static int p_simp_re(register struct parse *p, int starordinary); 12 | static int p_count(register struct parse *p); 13 | static void p_bracket(register struct parse *p); 14 | static void p_b_term(register struct parse *p, register cset *cs); 15 | static void p_b_cclass(register struct parse *p, register cset *cs); 16 | static void p_b_eclass(register struct parse *p, register cset *cs); 17 | static char p_b_symbol(register struct parse *p); 18 | static char p_b_coll_elem(register struct parse *p, int endc); 19 | static char othercase(int ch); 20 | static void bothcases(register struct parse *p, int ch); 21 | static void ordinary(register struct parse *p, register int ch); 22 | static void nonnewline(register struct parse *p); 23 | static void repeat(register struct parse *p, sopno start, int from, int to); 24 | static int seterr(register struct parse *p, int e); 25 | static cset *allocset(register struct parse *p); 26 | static void freeset(register struct parse *p, register cset *cs); 27 | static int freezeset(register struct parse *p, register cset *cs); 28 | static int firstch(register struct parse *p, register cset *cs); 29 | static int nch(register struct parse *p, register cset *cs); 30 | static void mcadd(register struct parse *p, register cset *cs, register char *cp); 31 | static void mcinvert(register struct parse *p, register cset *cs); 32 | static void mccase(register struct parse *p, register cset *cs); 33 | static int isinsets(register struct re_guts *g, int c); 34 | static int samesets(register struct re_guts *g, int c1, int c2); 35 | static void categorize(struct parse *p, register struct re_guts *g); 36 | static sopno dupl(register struct parse *p, sopno start, sopno finish); 37 | static void doemit(register struct parse *p, sop op, size_t opnd); 38 | static void doinsert(register struct parse *p, sop op, size_t opnd, sopno pos); 39 | static void dofwd(register struct parse *p, sopno pos, sop value); 40 | static void enlarge(register struct parse *p, sopno size); 41 | static void stripsnug(register struct parse *p, register struct re_guts *g); 42 | static void findmust(register struct parse *p, register struct re_guts *g); 43 | static sopno pluscount(register struct parse *p, register struct re_guts *g); 44 | 45 | #ifdef __cplusplus 46 | } 47 | #endif 48 | /* ========= end header generated by ./mkh ========= */ 49 | -------------------------------------------------------------------------------- /re/regex.h: -------------------------------------------------------------------------------- 1 | #ifndef _REGEX_H_ 2 | #define _REGEX_H_ /* never again */ 3 | 4 | /* Added by dsouflis - include files should be self contained */ 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | /* ========= begin header generated by ././mkh ========= */ 13 | #ifdef __cplusplus 14 | extern "C" { 15 | #endif 16 | 17 | /* === regex2.h === */ 18 | #ifdef WIN32 19 | #define API_EXPORT(type) __declspec(dllexport) type __stdcall 20 | #else 21 | #define API_EXPORT(type) type 22 | #endif 23 | 24 | typedef off_t regoff_t; 25 | typedef struct { 26 | int re_magic; 27 | size_t re_nsub; /* number of parenthesized subexpressions */ 28 | const char *re_endp; /* end pointer for REG_PEND */ 29 | struct re_guts *re_g; /* none of your business :-) */ 30 | } regex_t; 31 | typedef struct { 32 | regoff_t rm_so; /* start of match */ 33 | regoff_t rm_eo; /* end of match */ 34 | } regmatch_t; 35 | 36 | 37 | /* === regcomp.c === */ 38 | API_EXPORT(int) regcomp(regex_t *, const char *, int); 39 | #define REG_BASIC 0000 40 | #define REG_EXTENDED 0001 41 | #define REG_ICASE 0002 42 | #define REG_NOSUB 0004 43 | #define REG_NEWLINE 0010 44 | #define REG_NOSPEC 0020 45 | #define REG_PEND 0040 46 | #define REG_DUMP 0200 47 | 48 | 49 | /* === regerror.c === */ 50 | #define REG_NOMATCH 1 51 | #define REG_BADPAT 2 52 | #define REG_ECOLLATE 3 53 | #define REG_ECTYPE 4 54 | #define REG_EESCAPE 5 55 | #define REG_ESUBREG 6 56 | #define REG_EBRACK 7 57 | #define REG_EPAREN 8 58 | #define REG_EBRACE 9 59 | #define REG_BADBR 10 60 | #define REG_ERANGE 11 61 | #define REG_ESPACE 12 62 | #define REG_BADRPT 13 63 | #define REG_EMPTY 14 64 | #define REG_ASSERT 15 65 | #define REG_INVARG 16 66 | #define REG_ATOI 255 /* convert name to number (!) */ 67 | #define REG_ITOA 0400 /* convert number to name (!) */ 68 | API_EXPORT(size_t) regerror(int, const regex_t *, char *, size_t); 69 | 70 | 71 | /* === regexec.c === */ 72 | API_EXPORT(int) regexec(const regex_t *, const char *, size_t, regmatch_t [], int); 73 | #define REG_NOTBOL 00001 74 | #define REG_NOTEOL 00002 75 | #define REG_STARTEND 00004 76 | #define REG_TRACE 00400 /* tracing of execution */ 77 | #define REG_LARGE 01000 /* force large representation */ 78 | #define REG_BACKR 02000 /* force use of backref code */ 79 | 80 | 81 | /* === regfree.c === */ 82 | API_EXPORT(void) regfree(regex_t *); 83 | 84 | #ifdef __cplusplus 85 | } 86 | #endif 87 | /* ========= end header generated by ././mkh ========= */ 88 | #endif 89 | -------------------------------------------------------------------------------- /re/cname.h: -------------------------------------------------------------------------------- 1 | /* character-name table */ 2 | static struct cname { 3 | char *name; 4 | char code; 5 | } cnames[] = { 6 | { "NUL", '\0' }, 7 | { "SOH", '\001' }, 8 | { "STX", '\002' }, 9 | { "ETX", '\003' }, 10 | { "EOT", '\004' }, 11 | { "ENQ", '\005' }, 12 | { "ACK", '\006' }, 13 | { "BEL", '\007' }, 14 | { "alert", '\007' }, 15 | { "BS", '\010' }, 16 | { "backspace", '\b' }, 17 | { "HT", '\011' }, 18 | { "tab", '\t' }, 19 | { "LF", '\012' }, 20 | { "newline", '\n' }, 21 | { "VT", '\013' }, 22 | { "vertical-tab", '\v' }, 23 | { "FF", '\014' }, 24 | { "form-feed", '\f' }, 25 | { "CR", '\015' }, 26 | { "carriage-return", '\r' }, 27 | { "SO", '\016' }, 28 | { "SI", '\017' }, 29 | { "DLE", '\020' }, 30 | { "DC1", '\021' }, 31 | { "DC2", '\022' }, 32 | { "DC3", '\023' }, 33 | { "DC4", '\024' }, 34 | { "NAK", '\025' }, 35 | { "SYN", '\026' }, 36 | { "ETB", '\027' }, 37 | { "CAN", '\030' }, 38 | { "EM", '\031' }, 39 | { "SUB", '\032' }, 40 | { "ESC", '\033' }, 41 | { "IS4", '\034' }, 42 | { "FS", '\034' }, 43 | { "IS3", '\035' }, 44 | { "GS", '\035' }, 45 | { "IS2", '\036' }, 46 | { "RS", '\036' }, 47 | { "IS1", '\037' }, 48 | { "US", '\037' }, 49 | { "space", ' ' }, 50 | { "exclamation-mark", '!' }, 51 | { "quotation-mark", '"' }, 52 | { "number-sign", '#' }, 53 | { "dollar-sign", '$' }, 54 | { "percent-sign", '%' }, 55 | { "ampersand", '&' }, 56 | { "apostrophe", '\'' }, 57 | { "left-parenthesis", '(' }, 58 | { "right-parenthesis", ')' }, 59 | { "asterisk", '*' }, 60 | { "plus-sign", '+' }, 61 | { "comma", ',' }, 62 | { "hyphen", '-' }, 63 | { "hyphen-minus", '-' }, 64 | { "period", '.' }, 65 | { "full-stop", '.' }, 66 | { "slash", '/' }, 67 | { "solidus", '/' }, 68 | { "zero", '0' }, 69 | { "one", '1' }, 70 | { "two", '2' }, 71 | { "three", '3' }, 72 | { "four", '4' }, 73 | { "five", '5' }, 74 | { "six", '6' }, 75 | { "seven", '7' }, 76 | { "eight", '8' }, 77 | { "nine", '9' }, 78 | { "colon", ':' }, 79 | { "semicolon", ';' }, 80 | { "less-than-sign", '<' }, 81 | { "equals-sign", '=' }, 82 | { "greater-than-sign", '>' }, 83 | { "question-mark", '?' }, 84 | { "commercial-at", '@' }, 85 | { "left-square-bracket", '[' }, 86 | { "backslash", '\\' }, 87 | { "reverse-solidus", '\\' }, 88 | { "right-square-bracket", ']' }, 89 | { "circumflex", '^' }, 90 | { "circumflex-accent", '^' }, 91 | { "underscore", '_' }, 92 | { "low-line", '_' }, 93 | { "grave-accent", '`' }, 94 | { "left-brace", '{' }, 95 | { "left-curly-bracket", '{' }, 96 | { "vertical-line", '|' }, 97 | { "right-brace", '}' }, 98 | { "right-curly-bracket", '}' }, 99 | { "tilde", '~' }, 100 | { "DEL", '\177' }, 101 | { NULL, 0 } 102 | }; 103 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/dynload.c: -------------------------------------------------------------------------------- 1 | /* dynload.c Dynamic Loader for TinyScheme */ 2 | /* Original Copyright (c) 1999 Alexander Shendi */ 3 | /* Modifications for NT and dl_* interface, scm_load_ext: D. Souflis */ 4 | /* Refurbished by Stephen Gildea */ 5 | 6 | #define _SCHEME_SOURCE 7 | #include "dynload.h" 8 | #include 9 | #include 10 | #include 11 | 12 | #ifndef MAXPATHLEN 13 | # define MAXPATHLEN 1024 14 | #endif 15 | 16 | static void make_filename(const char *name, char *filename); 17 | static void make_init_fn(const char *name, char *init_fn); 18 | 19 | # include 20 | 21 | #define PREFIX "" 22 | #define SUFFIX ".dll" 23 | 24 | static void display_w32_error_msg(const char *additional_message) 25 | { 26 | LPVOID msg_buf; 27 | 28 | FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, 29 | NULL, GetLastError(), 0, 30 | (LPTSTR)&msg_buf, 0, NULL); 31 | fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf); 32 | LocalFree(msg_buf); 33 | } 34 | 35 | static HMODULE dl_attach(const char *module) { 36 | HMODULE dll = LoadLibrary(module); 37 | if (!dll) display_w32_error_msg(module); 38 | return dll; 39 | } 40 | 41 | static FARPROC dl_proc(HMODULE mo, const char *proc) { 42 | FARPROC procedure = GetProcAddress(mo,proc); 43 | if (!procedure) display_w32_error_msg(proc); 44 | return procedure; 45 | } 46 | 47 | static void dl_detach(HMODULE mo) { 48 | (void)FreeLibrary(mo); 49 | } 50 | 51 | pointer scm_load_ext(scheme *sc, pointer args) 52 | { 53 | pointer first_arg; 54 | pointer retval; 55 | char filename[MAXPATHLEN], init_fn[MAXPATHLEN+6]; 56 | char *name; 57 | HMODULE dll_handle; 58 | void (*module_init)(scheme *sc); 59 | 60 | if ((args != sc->NIL) && is_string((first_arg = pair_car(args)))) { 61 | name = string_value(first_arg); 62 | make_filename(name,filename); 63 | make_init_fn(name,init_fn); 64 | dll_handle = dl_attach(filename); 65 | if (dll_handle == 0) { 66 | retval = sc -> F; 67 | } 68 | else { 69 | module_init = (void(*)(scheme *))dl_proc(dll_handle, init_fn); 70 | if (module_init != 0) { 71 | (*module_init)(sc); 72 | retval = sc -> T; 73 | } 74 | else { 75 | retval = sc->F; 76 | } 77 | } 78 | } 79 | else { 80 | retval = sc -> F; 81 | } 82 | 83 | return(retval); 84 | } 85 | 86 | static void make_filename(const char *name, char *filename) { 87 | strcpy(filename,name); 88 | strcat(filename,SUFFIX); 89 | } 90 | 91 | static void make_init_fn(const char *name, char *init_fn) { 92 | const char *p=strrchr(name,'/'); 93 | if(p==0) { 94 | p=name; 95 | } else { 96 | p++; 97 | } 98 | strcpy(init_fn,"init_"); 99 | strcat(init_fn,p); 100 | } 101 | 102 | 103 | /* 104 | Local variables: 105 | c-file-style: "k&r" 106 | End: 107 | */ 108 | -------------------------------------------------------------------------------- /re/re.c: -------------------------------------------------------------------------------- 1 | /* re.c */ 2 | /* Henry Spencer's implementation of Regular Expressions, 3 | used for TinyScheme */ 4 | /* Refurbished by Stephen Gildea */ 5 | #include "regex.h" 6 | #include "scheme.h" 7 | #include "scheme-private.h" 8 | 9 | #if defined(_WIN32) 10 | #define EXPORT __declspec( dllexport ) 11 | #else 12 | #define EXPORT 13 | #endif 14 | 15 | /* Since not exported */ 16 | #define T_STRING 1 17 | 18 | static void set_vector_elem(pointer vec, int ielem, pointer newel) { 19 | int n=ielem/2; 20 | if(ielem%2==0) { 21 | vec[1+n]._object._cons._car=newel; 22 | } else { 23 | vec[1+n]._object._cons._cdr=newel; 24 | } 25 | } 26 | 27 | pointer foreign_re_match(scheme *sc, pointer args) { 28 | pointer retval=sc->F; 29 | int retcode; 30 | regex_t rt; 31 | pointer first_arg, second_arg; 32 | pointer third_arg=sc->NIL; 33 | char *string; 34 | char *pattern; 35 | int num=0; 36 | 37 | if(!((args != sc->NIL) && sc->vptr->is_string((first_arg = sc->vptr->pair_car(args))) 38 | && (args=sc->vptr->pair_cdr(args)) 39 | && sc->vptr->is_pair(args) && sc->vptr->is_string((second_arg = sc->vptr->pair_car(args))))) { 40 | return sc->F; 41 | } 42 | pattern = sc->vptr->string_value(first_arg); 43 | string = sc->vptr->string_value(second_arg); 44 | 45 | args=sc->vptr->pair_cdr(args); 46 | if(args!=sc->NIL) { 47 | if(!(sc->vptr->is_pair(args) && sc->vptr->is_vector((third_arg = sc->vptr->pair_car(args))))) { 48 | return sc->F; 49 | } else { 50 | num=third_arg->_object._number.value.ivalue; 51 | } 52 | } 53 | 54 | 55 | if(regcomp(&rt,pattern,REG_EXTENDED)!=0) { 56 | return sc->F; 57 | } 58 | 59 | if(num==0) { 60 | retcode=regexec(&rt,string,0,0,0); 61 | } else { 62 | regmatch_t *pmatch=malloc((num+1)*sizeof(regmatch_t)); 63 | if(pmatch!=0) { 64 | retcode=regexec(&rt,string,num+1,pmatch,0); 65 | if(retcode==0) { 66 | int i; 67 | for(i=0; ivptr->cons(sc, sc->vptr->mk_integer(sc, pmatch[i].rm_so), 71 | sc->vptr->mk_integer(sc, pmatch[i].rm_eo))); 72 | 73 | } 74 | } 75 | free(pmatch); 76 | } else { 77 | sc->no_memory=1; 78 | retcode=-1; 79 | } 80 | } 81 | 82 | if(retcode==0) { 83 | retval=sc->T; 84 | } 85 | 86 | regfree(&rt); 87 | 88 | return(retval); 89 | } 90 | 91 | static char* utilities=";; return the substring of STRING matched in MATCH-VECTOR, \n" 92 | ";; the Nth subexpression match (default 0).\n" 93 | "(define (re-match-nth string match-vector . n)\n" 94 | " (let ((n (if (pair? n) (car n) 0)))\n" 95 | " (substring string (car (vector-ref match-vector n))\n" 96 | " (cdr (vector-ref match-vector n)))))\n" 97 | "(define (re-before-nth string match-vector . n)\n" 98 | " (let ((n (if (pair? n) (car n) 0)))\n" 99 | " (substring string 0 (car (vector-ref match-vector n)))))\n" 100 | "(define (re-after-nth string match-vector . n)\n" 101 | " (let ((n (if (pair? n) (car n) 0)))\n" 102 | " (substring string (cdr (vector-ref match-vector n))\n" 103 | " (string-length string))))\n"; 104 | 105 | EXPORT void init_re(scheme *sc) { 106 | sc->vptr->scheme_define(sc,sc->global_env,sc->vptr->mk_symbol(sc,"re-match"),sc->vptr->mk_foreign_func(sc, foreign_re_match)); 107 | /* sc->vptr->load_string(sc,utilities);*/ 108 | } 109 | -------------------------------------------------------------------------------- /tsx-1.1/README: -------------------------------------------------------------------------------- 1 | TinyScheme Extensions (TSX) 1.1 [September, 2002] 2 | (c) 2002 Manuel Heras-Gilsanz (manuel@heras-gilsanz.com) 3 | 4 | This software is subject to the license terms contained in the 5 | LICENSE file. 6 | 7 | Changelog: 8 | 1.1 (Sept. 2002) Updated to tinyscheme 1.31 9 | 1.0 (April 2002) First released version 10 | 11 | 12 | WHAT IS TSX? 13 | 14 | TinyScheme Extensions is a set of dynamic libraries incorporating 15 | additional funcionality to TinyScheme, a lightweight 16 | implementation of the Scheme programming language. TinyScheme 17 | (http://tinyscheme.sourceforge.net) is maintained by D. Souflis 18 | (dsouflis@acm.org), and is based on MiniSCHEME version 0.85k4. 19 | 20 | Scheme is a very nice and powerful programming language, but the 21 | basic language is very minimalistic in terms of library functions; 22 | only basic file input / output functionality is specified. 23 | Different implementations of the language (MIT Scheme, GUILE, 24 | Bigloo...) provide their own extension libraries. TSX attempts to 25 | provide commonly needed functions at a small cost in terms of 26 | additional program footprint. The library is modularized, so that 27 | it is possible (and easy!) to select desired functionality via 28 | #defines in tsx.h. 29 | 30 | 31 | INSTALLATION 32 | 33 | TSX has been tested on GNU/Linux 2.4.2 with gcc 2.96 and 34 | libc-2.2.2, with TinyScheme 1.31. 35 | 36 | To install, copy the distribution file to the directory 37 | where TinyScheme is installed (and where scheme.h lies), 38 | and run make. If building succeeds, a file called tsx.so 39 | should be created. This file can be loaded as a TinyScheme 40 | extension with 41 | 42 | (load-extension "tsx-1.0/tsx") 43 | 44 | After loading TSX, you can make use of its functions. 45 | To reduce footprint, you can choose the functionality which 46 | will be included. To do so, have a look at tsx.h and 47 | comment the #defines for unneeded modules. 48 | 49 | If you get compiler errors, make sure you have enabled 50 | dynamic modules in your tinyscheme runtime (define USE_DL 51 | somewhere near the top in scheme.h). 52 | 53 | 54 | SAMPLE APPLICATIONS 55 | 56 | Three sample applications are distributed with TSX 1.0. 57 | The code is not particularly elegant, nor written in proper 58 | functional style, but is provided for illustration of the 59 | implemented calls. 60 | 61 | -smtp.scm 62 | Sends an email to the user getting the username from 63 | the USER shell variable, connecting to the SMTP port 64 | on the local machine. 65 | 66 | -listhome.scm 67 | Provides a list of all the files on the user's home 68 | directory (obtained with the HOME environment variable). 69 | 70 | -srepl.scm 71 | Provides a socket-based read-eval-print-loop. It listens 72 | for connections on the 9000 port of the local machines, 73 | and executes the commands received. To test it, run 74 | 75 | telnet localhost 9000 76 | 77 | after starting the sample application, and type Scheme 78 | expressions. You will get the evaluations. To exit the 79 | session, type "quit" and TinyScheme will exit, closing 80 | the socket. The output of some functions will not 81 | be the same as you would obtain on TinyScheme's 82 | "command line", because standard output is not 83 | redirected to the socket, but most commands work ok. 84 | 85 | You should copy these applications to the directory where 86 | TinyScheme is installed (i.e., where the "scheme" binary 87 | file resides), and can be runned with: 88 | 89 | ./scheme listhome.scm 90 | ./scheme smtp.scm 91 | ./scheme srepl.scm 92 | 93 | 94 | TSX FUNCTIONS 95 | 96 | The extension functions implemented by TinyScheme Extensions are 97 | documented in the file "tsx-functions.txt". 98 | 99 | END 100 | -------------------------------------------------------------------------------- /tinyscheme-1.40/dynload.c: -------------------------------------------------------------------------------- 1 | /* dynload.c Dynamic Loader for TinyScheme */ 2 | /* Original Copyright (c) 1999 Alexander Shendi */ 3 | /* Modifications for NT and dl_* interface, scm_load_ext: D. Souflis */ 4 | /* Refurbished by Stephen Gildea */ 5 | 6 | #define _SCHEME_SOURCE 7 | #include "dynload.h" 8 | #include 9 | #include 10 | #include 11 | 12 | #ifndef MAXPATHLEN 13 | # define MAXPATHLEN 1024 14 | #endif 15 | 16 | static void make_filename(const char *name, char *filename); 17 | static void make_init_fn(const char *name, char *init_fn); 18 | 19 | #ifdef _WIN32 20 | # include 21 | #else 22 | typedef void *HMODULE; 23 | typedef void (*FARPROC)(); 24 | #define SUN_DL 25 | #include 26 | #endif 27 | 28 | #ifdef _WIN32 29 | 30 | #define PREFIX "" 31 | #define SUFFIX ".dll" 32 | 33 | static void display_w32_error_msg(const char *additional_message) 34 | { 35 | LPVOID msg_buf; 36 | 37 | FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, 38 | NULL, GetLastError(), 0, 39 | (LPTSTR)&msg_buf, 0, NULL); 40 | fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf); 41 | LocalFree(msg_buf); 42 | } 43 | 44 | static HMODULE dl_attach(const char *module) { 45 | HMODULE dll = LoadLibrary(module); 46 | if (!dll) display_w32_error_msg(module); 47 | return dll; 48 | } 49 | 50 | static FARPROC dl_proc(HMODULE mo, const char *proc) { 51 | FARPROC procedure = GetProcAddress(mo,proc); 52 | if (!procedure) display_w32_error_msg(proc); 53 | return procedure; 54 | } 55 | 56 | static void dl_detach(HMODULE mo) { 57 | (void)FreeLibrary(mo); 58 | } 59 | 60 | #elif defined(SUN_DL) 61 | 62 | #include 63 | 64 | #define PREFIX "lib" 65 | #define SUFFIX ".so" 66 | 67 | static HMODULE dl_attach(const char *module) { 68 | HMODULE so=dlopen(module,RTLD_LAZY); 69 | if(!so) { 70 | fprintf(stderr, "Error loading scheme extension \"%s\": %s\n", module, dlerror()); 71 | } 72 | return so; 73 | } 74 | 75 | static FARPROC dl_proc(HMODULE mo, const char *proc) { 76 | const char *errmsg; 77 | FARPROC fp=(FARPROC)dlsym(mo,proc); 78 | if ((errmsg = dlerror()) == 0) { 79 | return fp; 80 | } 81 | fprintf(stderr, "Error initializing scheme module \"%s\": %s\n", proc, errmsg); 82 | return 0; 83 | } 84 | 85 | static void dl_detach(HMODULE mo) { 86 | (void)dlclose(mo); 87 | } 88 | #endif 89 | 90 | pointer scm_load_ext(scheme *sc, pointer args) 91 | { 92 | pointer first_arg; 93 | pointer retval; 94 | char filename[MAXPATHLEN], init_fn[MAXPATHLEN+6]; 95 | char *name; 96 | HMODULE dll_handle; 97 | void (*module_init)(scheme *sc); 98 | 99 | if ((args != sc->NIL) && is_string((first_arg = pair_car(args)))) { 100 | name = string_value(first_arg); 101 | make_filename(name,filename); 102 | make_init_fn(name,init_fn); 103 | dll_handle = dl_attach(filename); 104 | if (dll_handle == 0) { 105 | retval = sc -> F; 106 | } 107 | else { 108 | module_init = (void(*)(scheme *))dl_proc(dll_handle, init_fn); 109 | if (module_init != 0) { 110 | (*module_init)(sc); 111 | retval = sc -> T; 112 | } 113 | else { 114 | retval = sc->F; 115 | } 116 | } 117 | } 118 | else { 119 | retval = sc -> F; 120 | } 121 | 122 | return(retval); 123 | } 124 | 125 | static void make_filename(const char *name, char *filename) { 126 | strcpy(filename,name); 127 | strcat(filename,SUFFIX); 128 | } 129 | 130 | static void make_init_fn(const char *name, char *init_fn) { 131 | const char *p=strrchr(name,'/'); 132 | if(p==0) { 133 | p=name; 134 | } else { 135 | p++; 136 | } 137 | strcpy(init_fn,"init_"); 138 | strcat(init_fn,p); 139 | } 140 | 141 | 142 | /* 143 | Local variables: 144 | c-file-style: "k&r" 145 | End: 146 | */ 147 | -------------------------------------------------------------------------------- /tinyscheme-1.40/MiniSCHEMETribute.txt: -------------------------------------------------------------------------------- 1 | TinyScheme would not exist if it wasn't for MiniScheme. I had just 2 | written the HTTP server for Ovrimos SQL Server, and I was lamenting the 3 | lack of a scripting language. Server-side Javascript would have been the 4 | preferred solution, had there been a Javascript interpreter I could 5 | lay my hands on. But there weren't. Perl would have been another solution, 6 | but it was probably ten times bigger that the program it was supposed to 7 | be embedded in. There would also be thorny licencing issues. 8 | 9 | So, the obvious thing to do was find a trully small interpreter. Forth 10 | was a language I had once quasi-implemented, but the difficulty of 11 | handling dynamic data and the weirdness of the language put me off. I then 12 | looked around for a LISP interpreter, the next thing I knew was easy to 13 | implement. Alas, the LeLisp I knew from my days in UPMC (Universite Pierre 14 | et Marie Curie) had given way to Common Lisp, a megalith of a language! 15 | Then my search lead me to Scheme, a language I knew was very orthogonal 16 | and clean. When I found Mini-Scheme, a single C file of some 2400 loc, I 17 | fell in love with it! What if it lacked floating-point numbers and 18 | strings! The rest, as they say, is history. 19 | 20 | Below are the original credits. Don't email Akira KIDA, the address has 21 | changed. 22 | 23 | ---------- Mini-Scheme Interpreter Version 0.85 ---------- 24 | 25 | coded by Atsushi Moriwaki (11/5/1989) 26 | 27 | E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 28 | 29 | THIS SOFTWARE IS IN THE PUBLIC DOMAIN 30 | ------------------------------------ 31 | This software is completely free to copy, modify and/or re-distribute. 32 | But I would appreciate it if you left my name on the code as the author. 33 | 34 | This version has been modified by R.C. Secrist. 35 | 36 | Mini-Scheme is now maintained by Akira KIDA. 37 | 38 | This is a revised and modified version by Akira KIDA. 39 | current version is 0.85k4 (15 May 1994) 40 | 41 | Please send suggestions, bug reports and/or requests to: 42 | 43 | 44 | 45 | Features compared to MiniSCHEME 46 | ------------------------------- 47 | 48 | All code is now reentrant. Interpreter state is held in a 'scheme' 49 | struct, and many interpreters can coexist in the same program, possibly 50 | in different threads. The user can specify user-defined memory allocation 51 | primitives. (see "Programmer's Reference") 52 | 53 | The reader is more consistent. 54 | 55 | Strings, characters and flonums are supported. (see "Types") 56 | 57 | Files being loaded can be nested up to some depth. 58 | 59 | R5RS I/O is there, plus String Ports. (see "Scheme Reference","I/O") 60 | 61 | Vectors exist. 62 | 63 | As a standalone application, it supports command-line arguments. 64 | (see "Standalone") 65 | 66 | Running out of memory is now handled. 67 | 68 | The user can add foreign functions in C. (see "Foreign Functions") 69 | 70 | The code has been changed slightly, core functions have been moved 71 | to the library, behavior has been aligned with R5RS etc. 72 | 73 | Support has been added for user-defined error recovery. 74 | (see "Error Handling") 75 | 76 | Support has been added for modular programming. 77 | (see "Colon Qualifiers - Packages") 78 | 79 | To enable this, EVAL has changed internally, and can 80 | now take two arguments, as per R5RS. Environments are supported. 81 | (see "Colon Qualifiers - Packages") 82 | 83 | Promises are now evaluated once only. 84 | 85 | (macro (foo form) ...) is now equivalent to (macro foo (lambda(form) ...)) 86 | 87 | The reader can be extended using new #-expressions 88 | (see "Reader extensions") 89 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/MiniSCHEMETribute.txt: -------------------------------------------------------------------------------- 1 | TinyScheme would not exist if it wasn't for MiniScheme. I had just 2 | written the HTTP server for Ovrimos SQL Server, and I was lamenting the 3 | lack of a scripting language. Server-side Javascript would have been the 4 | preferred solution, had there been a Javascript interpreter I could 5 | lay my hands on. But there weren't. Perl would have been another solution, 6 | but it was probably ten times bigger that the program it was supposed to 7 | be embedded in. There would also be thorny licencing issues. 8 | 9 | So, the obvious thing to do was find a trully small interpreter. Forth 10 | was a language I had once quasi-implemented, but the difficulty of 11 | handling dynamic data and the weirdness of the language put me off. I then 12 | looked around for a LISP interpreter, the next thing I knew was easy to 13 | implement. Alas, the LeLisp I knew from my days in UPMC (Universite Pierre 14 | et Marie Curie) had given way to Common Lisp, a megalith of a language! 15 | Then my search lead me to Scheme, a language I knew was very orthogonal 16 | and clean. When I found Mini-Scheme, a single C file of some 2400 loc, I 17 | fell in love with it! What if it lacked floating-point numbers and 18 | strings! The rest, as they say, is history. 19 | 20 | Below are the original credits. Don't email Akira KIDA, the address has 21 | changed. 22 | 23 | ---------- Mini-Scheme Interpreter Version 0.85 ---------- 24 | 25 | coded by Atsushi Moriwaki (11/5/1989) 26 | 27 | E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 28 | 29 | THIS SOFTWARE IS IN THE PUBLIC DOMAIN 30 | ------------------------------------ 31 | This software is completely free to copy, modify and/or re-distribute. 32 | But I would appreciate it if you left my name on the code as the author. 33 | 34 | This version has been modified by R.C. Secrist. 35 | 36 | Mini-Scheme is now maintained by Akira KIDA. 37 | 38 | This is a revised and modified version by Akira KIDA. 39 | current version is 0.85k4 (15 May 1994) 40 | 41 | Please send suggestions, bug reports and/or requests to: 42 | 43 | 44 | 45 | Features compared to MiniSCHEME 46 | ------------------------------- 47 | 48 | All code is now reentrant. Interpreter state is held in a 'scheme' 49 | struct, and many interpreters can coexist in the same program, possibly 50 | in different threads. The user can specify user-defined memory allocation 51 | primitives. (see "Programmer's Reference") 52 | 53 | The reader is more consistent. 54 | 55 | Strings, characters and flonums are supported. (see "Types") 56 | 57 | Files being loaded can be nested up to some depth. 58 | 59 | R5RS I/O is there, plus String Ports. (see "Scheme Reference","I/O") 60 | 61 | Vectors exist. 62 | 63 | As a standalone application, it supports command-line arguments. 64 | (see "Standalone") 65 | 66 | Running out of memory is now handled. 67 | 68 | The user can add foreign functions in C. (see "Foreign Functions") 69 | 70 | The code has been changed slightly, core functions have been moved 71 | to the library, behavior has been aligned with R5RS etc. 72 | 73 | Support has been added for user-defined error recovery. 74 | (see "Error Handling") 75 | 76 | Support has been added for modular programming. 77 | (see "Colon Qualifiers - Packages") 78 | 79 | To enable this, EVAL has changed internally, and can 80 | now take two arguments, as per R5RS. Environments are supported. 81 | (see "Colon Qualifiers - Packages") 82 | 83 | Promises are now evaluated once only. 84 | 85 | (macro (foo form) ...) is now equivalent to (macro foo (lambda(form) ...)) 86 | 87 | The reader can be extended using new #-expressions 88 | (see "Reader extensions") 89 | -------------------------------------------------------------------------------- /re/Makefile.in: -------------------------------------------------------------------------------- 1 | SHELL = /bin/sh 2 | 3 | srcdir=@srcdir@ 4 | VPATH=@srcdir@ 5 | 6 | CC=@CC@ 7 | RANLIB=@RANLIB@ 8 | 9 | # You probably want to take -DREDEBUG out of CFLAGS, and put something like 10 | # -O in, *after* testing (-DREDEBUG strengthens testing by enabling a lot of 11 | # internal assertion checking and some debugging facilities). 12 | # Put -Dconst= in for a pre-ANSI compiler. 13 | # Do not take -DPOSIX_MISTAKE out. 14 | # REGCFLAGS isn't important to you (it's for my use in some special contexts). 15 | CFLAGS=-I$(srcdir) -I. -DPOSIX_MISTAKE @CFLAGS@ 16 | 17 | # If you have a pre-ANSI compiler, put -o into MKHFLAGS. If you want 18 | # the Berkeley __P macro, put -b in. 19 | MKHFLAGS= 20 | 21 | # Flags for linking but not compiling, if any. 22 | LDFLAGS=@LDFLAGS@ 23 | 24 | # Extra libraries for linking, if any. 25 | LIBS= 26 | 27 | # Internal stuff, should not need changing. 28 | OBJPRODN=regcomp.o regexec.o regerror.o regfree.o 29 | OBJS=$(OBJPRODN) split.o debug.o main.o 30 | H=cclass.h cname.h regex2.h utils.h 31 | REGSRC=regcomp.c regerror.c regexec.c regfree.c 32 | ALLSRC=$(REGSRC) engine.c debug.c main.c split.c 33 | 34 | # Stuff that matters only if you're trying to lint the package. 35 | LINTFLAGS=-I. -Dstatic= -Dconst= -DREDEBUG 36 | LINTC=regcomp.c regexec.c regerror.c regfree.c debug.c main.c 37 | JUNKLINT=possible pointer alignment|null effect 38 | 39 | # arrangements to build forward-reference header files 40 | .SUFFIXES: .ih .h 41 | .c.ih: 42 | sh $(srcdir)/mkh $(MKHFLAGS) -p $< >$@ 43 | 44 | all lib: libregex.a 45 | 46 | libregex.a: $(OBJPRODN) 47 | rm -f libregex.a 48 | ar cr libregex.a $(OBJPRODN) 49 | $(RANLIB) libregex.a 50 | 51 | default: r 52 | 53 | purge: 54 | rm -f *.o 55 | 56 | # stuff to build regex.h 57 | REGEXH=regex.h 58 | REGEXHSRC=regex2.h $(REGSRC) 59 | $(REGEXH): $(REGEXHSRC) mkh 60 | sh $(srcdir)/./mkh $(MKHFLAGS) -i _REGEX_H_ $(REGEXHSRC) >regex.h 61 | #cmp -s regex.tmp regex.h 2>/dev/null || cp regex.tmp regex.h 62 | #rm -f regex.tmp 63 | 64 | # dependencies 65 | $(OBJPRODN) debug.o: utils.h regex.h regex2.h 66 | regcomp.o: cclass.h cname.h regcomp.ih 67 | regexec.o: engine.c engine.ih 68 | regerror.o: regerror.ih 69 | debug.o: debug.ih 70 | main.o: main.ih 71 | 72 | # tester 73 | re: $(OBJS) 74 | $(CC) $(CFLAGS) $(LDFLAGS) $(OBJS) $(LIBS) -o $@ 75 | 76 | # regression test 77 | r: re tests 78 | ./re &1 | egrep -v '$(JUNKLINT)' | tee lint 101 | 102 | fullprint: 103 | ti README WHATSNEW notes todo | list 104 | ti *.h | list 105 | list *.c 106 | list regex.3 regex.7 107 | 108 | print: 109 | ti README WHATSNEW notes todo | list 110 | ti *.h | list 111 | list reg*.c engine.c 112 | 113 | 114 | mf.tmp: Makefile 115 | sed '/^REGEXH=/s/=.*/=regex.h/' Makefile | sed '/#DEL$$/d' >$@ 116 | 117 | DTRH=cclass.h cname.h regex2.h utils.h 118 | PRE=COPYRIGHT README WHATSNEW 119 | POST=mkh regex.3 regex.7 tests $(DTRH) $(ALLSRC) fake/*.[ch] 120 | FILES=$(PRE) Makefile $(POST) 121 | DTR=$(PRE) Makefile=mf.tmp $(POST) 122 | dtr: $(FILES) mf.tmp 123 | makedtr $(DTR) >$@ 124 | rm mf.tmp 125 | 126 | cio: $(FILES) 127 | cio $(FILES) 128 | 129 | rdf: $(FILES) 130 | rcsdiff -c $(FILES) 2>&1 | p 131 | 132 | # various forms of cleanup 133 | tidy: 134 | rm -f junk* core core.* *.core dtr *.tmp lint 135 | 136 | clean: tidy 137 | rm -f *.o *.s re libregex.a 138 | 139 | # don't do this one unless you know what you're doing 140 | spotless: clean 141 | rm -f mkh regex.h 142 | -------------------------------------------------------------------------------- /re/regerror.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include "utils.h" 4 | #include "regerror.ih" 5 | 6 | /* 7 | = #define REG_NOMATCH 1 8 | = #define REG_BADPAT 2 9 | = #define REG_ECOLLATE 3 10 | = #define REG_ECTYPE 4 11 | = #define REG_EESCAPE 5 12 | = #define REG_ESUBREG 6 13 | = #define REG_EBRACK 7 14 | = #define REG_EPAREN 8 15 | = #define REG_EBRACE 9 16 | = #define REG_BADBR 10 17 | = #define REG_ERANGE 11 18 | = #define REG_ESPACE 12 19 | = #define REG_BADRPT 13 20 | = #define REG_EMPTY 14 21 | = #define REG_ASSERT 15 22 | = #define REG_INVARG 16 23 | = #define REG_ATOI 255 // convert name to number (!) 24 | = #define REG_ITOA 0400 // convert number to name (!) 25 | */ 26 | static struct rerr { 27 | int code; 28 | char *name; 29 | char *explain; 30 | } rerrs[] = { 31 | { REG_NOMATCH, "REG_NOMATCH", "regexec() failed to match" }, 32 | { REG_BADPAT, "REG_BADPAT", "invalid regular expression" }, 33 | { REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element" }, 34 | { REG_ECTYPE, "REG_ECTYPE", "invalid character class" }, 35 | { REG_EESCAPE, "REG_EESCAPE", "trailing backslash (\\)" }, 36 | { REG_ESUBREG, "REG_ESUBREG", "invalid backreference number" }, 37 | { REG_EBRACK, "REG_EBRACK", "brackets ([ ]) not balanced" }, 38 | { REG_EPAREN, "REG_EPAREN", "parentheses not balanced" }, 39 | { REG_EBRACE, "REG_EBRACE", "braces not balanced" }, 40 | { REG_BADBR, "REG_BADBR", "invalid repetition count(s)" }, 41 | { REG_ERANGE, "REG_ERANGE", "invalid character range" }, 42 | { REG_ESPACE, "REG_ESPACE", "out of memory" }, 43 | { REG_BADRPT, "REG_BADRPT", "repetition-operator operand invalid" }, 44 | { REG_EMPTY, "REG_EMPTY", "empty (sub)expression" }, 45 | { REG_ASSERT, "REG_ASSERT", "\"can't happen\" -- you found a bug" }, 46 | { REG_INVARG, "REG_INVARG", "invalid argument to regex routine" }, 47 | { 0, "", "*** unknown regexp error code ***" } 48 | }; 49 | 50 | /* 51 | - regerror - the interface to error numbers 52 | = API_EXPORT(size_t) regerror(int, const regex_t *, char *, size_t); 53 | */ 54 | /* ARGSUSED */ 55 | API_EXPORT(size_t) 56 | regerror(errcode, preg, errbuf, errbuf_size) 57 | int errcode; 58 | const regex_t *preg; 59 | char *errbuf; 60 | size_t errbuf_size; 61 | { 62 | register struct rerr *r; 63 | register size_t len; 64 | register int target = errcode &~ REG_ITOA; 65 | register char *s; 66 | char convbuf[50]; 67 | 68 | if (errcode == REG_ATOI) 69 | s = regatoi(preg, convbuf); 70 | else { 71 | for (r = rerrs; r->code != 0; r++) 72 | if (r->code == target) 73 | break; 74 | 75 | if (errcode®_ITOA) { 76 | if (r->code != 0) 77 | (void) strcpy(convbuf, r->name); 78 | else 79 | sprintf(convbuf, "REG_0x%x", target); 80 | assert(strlen(convbuf) < sizeof(convbuf)); 81 | s = convbuf; 82 | } else 83 | s = r->explain; 84 | } 85 | 86 | len = strlen(s) + 1; 87 | if (errbuf_size > 0) { 88 | if (errbuf_size > len) 89 | (void) strcpy(errbuf, s); 90 | else { 91 | (void) strncpy(errbuf, s, errbuf_size-1); 92 | errbuf[errbuf_size-1] = '\0'; 93 | } 94 | } 95 | 96 | return(len); 97 | } 98 | 99 | /* 100 | - regatoi - internal routine to implement REG_ATOI 101 | == static char *regatoi(const regex_t *preg, char *localbuf); 102 | */ 103 | static char * 104 | regatoi(preg, localbuf) 105 | const regex_t *preg; 106 | char *localbuf; 107 | { 108 | register struct rerr *r; 109 | 110 | for (r = rerrs; r->code != 0; r++) 111 | if (strcmp(r->name, preg->re_endp) == 0) 112 | break; 113 | if (r->code == 0) 114 | return("0"); 115 | 116 | sprintf(localbuf, "%d", r->code); 117 | return(localbuf); 118 | } 119 | -------------------------------------------------------------------------------- /re/regex.001: -------------------------------------------------------------------------------- 1 | # Microsoft Developer Studio Project File - Name="regex" - Package Owner=<4> 2 | # Microsoft Developer Studio Generated Build File, Format Version 5.00 3 | # ** DO NOT EDIT ** 4 | 5 | # TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 6 | 7 | CFG=regex - Win32 Debug 8 | !MESSAGE This is not a valid makefile. To build this project using NMAKE, 9 | !MESSAGE use the Export Makefile command and run 10 | !MESSAGE 11 | !MESSAGE NMAKE /f "regex.mak". 12 | !MESSAGE 13 | !MESSAGE You can specify a configuration when running NMAKE 14 | !MESSAGE by defining the macro CFG on the command line. For example: 15 | !MESSAGE 16 | !MESSAGE NMAKE /f "regex.mak" CFG="regex - Win32 Debug" 17 | !MESSAGE 18 | !MESSAGE Possible choices for configuration are: 19 | !MESSAGE 20 | !MESSAGE "regex - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") 21 | !MESSAGE "regex - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") 22 | !MESSAGE 23 | 24 | # Begin Project 25 | # PROP Scc_ProjName "" 26 | # PROP Scc_LocalPath "" 27 | CPP=cl.exe 28 | MTL=midl.exe 29 | RSC=rc.exe 30 | 31 | !IF "$(CFG)" == "regex - Win32 Release" 32 | 33 | # PROP BASE Use_MFC 0 34 | # PROP BASE Use_Debug_Libraries 0 35 | # PROP BASE Output_Dir "Release" 36 | # PROP BASE Intermediate_Dir "Release" 37 | # PROP BASE Target_Dir "" 38 | # PROP Use_MFC 0 39 | # PROP Use_Debug_Libraries 0 40 | # PROP Output_Dir "Release" 41 | # PROP Intermediate_Dir "Release" 42 | # PROP Ignore_Export_Lib 0 43 | # PROP Target_Dir "" 44 | # ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /YX /FD /c 45 | # ADD CPP /nologo /MT /W3 /GX /O2 /I "." /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /YX /FD /c 46 | # ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /o NUL /win32 47 | # ADD MTL /nologo /D "NDEBUG" /mktyplib203 /o NUL /win32 48 | # ADD BASE RSC /l 0x409 /d "NDEBUG" 49 | # ADD RSC /l 0x409 /d "NDEBUG" 50 | BSC32=bscmake.exe 51 | # ADD BASE BSC32 /nologo 52 | # ADD BSC32 /nologo 53 | LINK32=link.exe 54 | # ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /machine:I386 55 | # ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /machine:I386 56 | 57 | !ELSEIF "$(CFG)" == "regex - Win32 Debug" 58 | 59 | # PROP BASE Use_MFC 0 60 | # PROP BASE Use_Debug_Libraries 1 61 | # PROP BASE Output_Dir "Debug" 62 | # PROP BASE Intermediate_Dir "Debug" 63 | # PROP BASE Target_Dir "" 64 | # PROP Use_MFC 0 65 | # PROP Use_Debug_Libraries 1 66 | # PROP Output_Dir "Debug" 67 | # PROP Intermediate_Dir "Debug" 68 | # PROP Ignore_Export_Lib 0 69 | # PROP Target_Dir "" 70 | # ADD BASE CPP /nologo /MTd /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /YX /FD /c 71 | # ADD CPP /nologo /MTd /W3 /Gm /GX /Zi /Od /I "." /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /YX /FD /c 72 | # ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /o NUL /win32 73 | # ADD MTL /nologo /D "_DEBUG" /mktyplib203 /o NUL /win32 74 | # ADD BASE RSC /l 0x409 /d "_DEBUG" 75 | # ADD RSC /l 0x409 /d "_DEBUG" 76 | BSC32=bscmake.exe 77 | # ADD BASE BSC32 /nologo 78 | # ADD BSC32 /nologo 79 | LINK32=link.exe 80 | # ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /debug /machine:I386 /pdbtype:sept 81 | # ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /debug /machine:I386 /pdbtype:sept 82 | 83 | !ENDIF 84 | 85 | # Begin Target 86 | 87 | # Name "regex - Win32 Release" 88 | # Name "regex - Win32 Debug" 89 | # Begin Source File 90 | 91 | SOURCE=.\regcomp.c 92 | # End Source File 93 | # Begin Source File 94 | 95 | SOURCE=.\regerror.c 96 | # End Source File 97 | # Begin Source File 98 | 99 | SOURCE=.\regexec.c 100 | # End Source File 101 | # Begin Source File 102 | 103 | SOURCE=.\regfree.c 104 | # End Source File 105 | # End Target 106 | # End Project 107 | -------------------------------------------------------------------------------- /tsx-1.1/smtp.scm: -------------------------------------------------------------------------------- 1 | ; smtp.scm 2 | ; Sample usage of TinyScheme Extensions 3 | ; This very simple program sends a message using SMTP to the local machine. 4 | 5 | ; It uses the following TinyScheme Extension functions: 6 | ; getenv 7 | ; used to get name of current user, wich is the recipient 8 | ; of the message. 9 | ; make-client-socket 10 | ; used to connect to SMTP port on local machine 11 | ; send 12 | ; used to send commands and email message 13 | ; recv-new-string 14 | ; used to read responses from SMTP server 15 | ; close-socket 16 | ; used to free socket at the end 17 | 18 | ; check that string ports are available... 19 | (if (not (defined? 'open-output-string)) 20 | (begin 21 | (display "We need string ports!! Recompile TinyScheme with string ports, if you want to run this sample...") 22 | (quit))) 23 | 24 | ; check that extensions are enabled 25 | (if (not (defined? 'load-extension)) 26 | (begin 27 | (display "TinyScheme has extensions disabled. Enable them!!") 28 | (newline) 29 | (quit))) 30 | 31 | ; load TinyScheme Extensions 32 | (load-extension "tsx-1.0/tsx") 33 | 34 | ; check that the necessary functions are available (the user 35 | ; might have removed some functionality...) 36 | (if (or 37 | (not (defined? 'getenv)) 38 | (not (defined? 'make-client-socket)) 39 | (not (defined? 'send)) 40 | (not (defined? 'close-socket)) 41 | (not (defined? 'recv-new-string))) 42 | (begin 43 | (display "Some necessary functions are not available. Exiting!") 44 | (newline) 45 | (quit))) 46 | 47 | ; get current user name 48 | (define user-name (getenv "USER")) 49 | 50 | ; if unable to get user name, use "nobody" 51 | (if (not user-name) 52 | (set! user-name "nobody")) 53 | 54 | ; create client socket to SMTP port (25) 55 | (define sock (make-client-socket "localhost" 25)) 56 | (display "Socket: ") (display sock) (newline) 57 | 58 | ; if unable to open socket, exit TinyScheme 59 | (if (not sock) 60 | (begin 61 | (display "Unable to open socket! Is SMTP enabled on this machine?") 62 | (quit))) 63 | 64 | ; define string buffers to send and receive 65 | (define recv-buf '()) 66 | 67 | ; receive SMTP welcome message onto recv-buf var 68 | (set! recv-buf (recv-new-string sock)) 69 | 70 | (display "Received:") (display recv-buf) (newline) 71 | 72 | (define helo "HELO localhost\n") 73 | (display "Sending HELO...") (newline) 74 | (send sock helo) 75 | 76 | ; receive response from server 77 | (set! recv-buf (recv-new-string sock)) 78 | (display "Received:") (display recv-buf) (newline) 79 | 80 | (define mailfrom (make-string (+ 20 (string-length user-name)))) 81 | (define mailfromport (open-output-string mailfrom)) 82 | (display "MAIL FROM: " mailfromport) 83 | (display user-name mailfromport) 84 | (display "\n" mailfromport) 85 | (close-output-port mailfromport) 86 | 87 | ; send MAIL FROM: command and receive response 88 | (display "Sending MAIL FROM:...") (newline) 89 | (send sock mailfrom) 90 | (set! recv-buf (recv-new-string sock)) 91 | (display "Received:") (display recv-buf) (newline) 92 | 93 | ; send RCPT TO: command and receive response 94 | (display "Sending RCPT TO:...") (newline) 95 | (define rcptto (make-string (+ 20 (string-length user-name)))) 96 | (define rcpttoport (open-output-string rcptto)) 97 | (display "RCPT TO: " rcpttoport) 98 | (display user-name rcpttoport) 99 | (display "\n" rcpttoport) 100 | (close-output-port rcpttoport) 101 | (send sock rcptto) 102 | (set! recv-buf (recv-new-string sock)) 103 | (display "Received:") (display recv-buf) (newline) 104 | 105 | 106 | ; send DATA command 107 | (display "Sending DATA...") (newline) 108 | (define data "DATA\n") 109 | (send sock data) 110 | (set! recv-buf (recv-new-string sock)) 111 | (display "Received:") (display recv-buf) (newline) 112 | 113 | ; send message 114 | (display "Sending message...") (newline) 115 | (define message "Hello!\nThis is a sample message sent from TinyScheme!\n\n.\n") 116 | (send sock message) 117 | (set! recv-buf (recv-new-string sock)) 118 | (display "Received:") (display recv-buf) (newline) 119 | 120 | ; send QUIT command 121 | (display "Sending QUIT command...") (newline) 122 | (define quit "QUIT\n") 123 | (send sock quit) 124 | (set! recv-buf (recv-new-string sock)) 125 | (display "Received:") (display recv-buf) (newline) 126 | 127 | ; close socket 128 | (close-socket sock) 129 | 130 | -------------------------------------------------------------------------------- /tinyscheme-1.40/BUILDING: -------------------------------------------------------------------------------- 1 | Building TinyScheme 2 | ------------------- 3 | 4 | The included makefile includes logic for Linux, Solaris and Win32, and can 5 | readily serve as an example for other OSes, especially Unixes. There are 6 | a lot of compile-time flags in TinyScheme (preprocessor defines) that can trim 7 | unwanted features. See next section. 'make all' and 'make clean' function as 8 | expected. 9 | 10 | Autoconfing TinyScheme was once proposed, but the distribution would not be 11 | so small anymore. There are few platform dependencies in TinyScheme, and in 12 | general compiles out of the box. 13 | 14 | Customizing 15 | ----------- 16 | 17 | The following symbols are defined to default values in scheme.h. 18 | Use the -D flag of cc to set to either 1 or 0. 19 | 20 | STANDALONE 21 | Define this to produce a standalone interpreter. 22 | 23 | USE_MATH 24 | Includes math routines. 25 | 26 | USE_CHAR_CLASSIFIERS 27 | Includes character classifier procedures. 28 | 29 | USE_ASCII_NAMES 30 | Enable extended character notation based on ASCII names. 31 | 32 | USE_STRING_PORTS 33 | Enables string ports. 34 | 35 | USE_ERROR_HOOK 36 | To force system errors through user-defined error handling. 37 | (see "Error handling") 38 | 39 | USE_TRACING 40 | To enable use of TRACING. 41 | 42 | USE_COLON_HOOK 43 | Enable use of qualified identifiers. (see "Colon Qualifiers - Packages") 44 | Defining this as 0 has the rather drastic consequence that any code using 45 | packages will stop working, and will have to be modified. It should only 46 | be used if you *absolutely* need to use '::' in identifiers. 47 | 48 | USE_STRCASECMP 49 | Defines stricmp as strcasecmp, for Unix. 50 | 51 | STDIO_ADDS_CR 52 | Informs TinyScheme that stdio translates "\n" to "\r\n". For DOS/Windows. 53 | 54 | USE_DL 55 | Enables dynamically loaded routines. If you define this symbol, you 56 | should also include dynload.c in your compile. 57 | 58 | USE_PLIST 59 | Enables property lists (not Standard Scheme stuff). Off by default. 60 | 61 | USE_NO_FEATURES 62 | Shortcut to disable USE_MATH, USE_CHAR_CLASSIFIERS, USE_ASCII_NAMES, 63 | USE_STRING_PORTS, USE_ERROR_HOOK, USE_TRACING, USE_COLON_HOOK, 64 | USE_DL. 65 | 66 | USE_SCHEME_STACK 67 | Enables 'cons' stack (the alternative is a faster calling scheme, which 68 | breaks continuations). Undefine it if you don't care about strict compatibility 69 | but you do care about faster execution. 70 | 71 | 72 | OS-X tip 73 | -------- 74 | I don't have access to OS-X, but Brian Maher submitted the following tip: 75 | 76 | [1] Download and install fink (I installed fink in 77 | /usr/local/fink) 78 | [2] Install the 'dlcompat' package using fink as such: 79 | > fink install dlcompat 80 | [3] Make the following changes to the 81 | tinyscheme-1.32.tar.gz 82 | 83 | diff -r tinyscheme-1.32/dynload.c 84 | tinyscheme-1.32-new/dynload.c 85 | 24c24 86 | < #define SUN_DL 87 | --- 88 | > 89 | Only in tinyscheme-1.32-new/: dynload.o 90 | 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 91 | 33,34c33,43 92 | < LD = gcc 93 | < LDFLAGS = -shared 94 | --- 95 | > #LD = gcc 96 | > #LDFLAGS = -shared 97 | > #DEBUG=-g -Wno-char-subscripts -O 98 | > #SYS_LIBS= -ldl 99 | > #PLATFORM_FEATURES= -DSUN_DL=1 100 | > 101 | > # Mac OS X 102 | > CC = gcc 103 | > CFLAGS = -I/usr/local/fink/include 104 | > LD = gcc 105 | > LDFLAGS = -L/usr/local/fink/lib 106 | 37c46 107 | < PLATFORM_FEATURES= -DSUN_DL=1 108 | --- 109 | > PLATFORM_FEATURES= -DSUN_DL=1 -DOSX 110 | 60c69 111 | < $(CC) -I. -c $(DEBUG) $(FEATURES) 112 | $(DL_FLAGS) $< 113 | --- 114 | > $(CC) $(CFLAGS) -I. -c $(DEBUG) 115 | $(FEATURES) $(DL_FLAGS) $< 116 | 66c75 117 | < $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS) 118 | --- 119 | > $(CC) $(LDFLAGS) -o $@ $(DEBUG) $(OBJS) 120 | $(SYS_LIBS) 121 | Only in tinyscheme-1.32-new/: scheme 122 | diff -r tinyscheme-1.32/scheme.c 123 | tinyscheme-1.32-new/scheme.c 124 | 60,61c60,61 125 | < #ifndef macintosh 126 | < # include 127 | --- 128 | > #ifdef OSX 129 | > /* Do nothing */ 130 | 62a63,65 131 | > # ifndef macintosh 132 | > # include 133 | > # else 134 | 77c80,81 135 | < #endif /* macintosh */ 136 | --- 137 | > # endif /* macintosh */ 138 | > #endif /* !OSX */ 139 | Only in tinyscheme-1.32-new/: scheme.o 140 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/BUILDING: -------------------------------------------------------------------------------- 1 | Building TinyScheme 2 | ------------------- 3 | 4 | The included makefile includes logic for Linux, Solaris and Win32, and can 5 | readily serve as an example for other OSes, especially Unixes. There are 6 | a lot of compile-time flags in TinyScheme (preprocessor defines) that can trim 7 | unwanted features. See next section. 'make all' and 'make clean' function as 8 | expected. 9 | 10 | Autoconfing TinyScheme was once proposed, but the distribution would not be 11 | so small anymore. There are few platform dependencies in TinyScheme, and in 12 | general compiles out of the box. 13 | 14 | Customizing 15 | ----------- 16 | 17 | The following symbols are defined to default values in scheme.h. 18 | Use the -D flag of cc to set to either 1 or 0. 19 | 20 | STANDALONE 21 | Define this to produce a standalone interpreter. 22 | 23 | USE_MATH 24 | Includes math routines. 25 | 26 | USE_CHAR_CLASSIFIERS 27 | Includes character classifier procedures. 28 | 29 | USE_ASCII_NAMES 30 | Enable extended character notation based on ASCII names. 31 | 32 | USE_STRING_PORTS 33 | Enables string ports. 34 | 35 | USE_ERROR_HOOK 36 | To force system errors through user-defined error handling. 37 | (see "Error handling") 38 | 39 | USE_TRACING 40 | To enable use of TRACING. 41 | 42 | USE_COLON_HOOK 43 | Enable use of qualified identifiers. (see "Colon Qualifiers - Packages") 44 | Defining this as 0 has the rather drastic consequence that any code using 45 | packages will stop working, and will have to be modified. It should only 46 | be used if you *absolutely* need to use '::' in identifiers. 47 | 48 | USE_STRCASECMP 49 | Defines stricmp as strcasecmp, for Unix. 50 | 51 | STDIO_ADDS_CR 52 | Informs TinyScheme that stdio translates "\n" to "\r\n". For DOS/Windows. 53 | 54 | USE_DL 55 | Enables dynamically loaded routines. If you define this symbol, you 56 | should also include dynload.c in your compile. 57 | 58 | USE_PLIST 59 | Enables property lists (not Standard Scheme stuff). Off by default. 60 | 61 | USE_NO_FEATURES 62 | Shortcut to disable USE_MATH, USE_CHAR_CLASSIFIERS, USE_ASCII_NAMES, 63 | USE_STRING_PORTS, USE_ERROR_HOOK, USE_TRACING, USE_COLON_HOOK, 64 | USE_DL. 65 | 66 | USE_SCHEME_STACK 67 | Enables 'cons' stack (the alternative is a faster calling scheme, which 68 | breaks continuations). Undefine it if you don't care about strict compatibility 69 | but you do care about faster execution. 70 | 71 | 72 | OS-X tip 73 | -------- 74 | I don't have access to OS-X, but Brian Maher submitted the following tip: 75 | 76 | [1] Download and install fink (I installed fink in 77 | /usr/local/fink) 78 | [2] Install the 'dlcompat' package using fink as such: 79 | > fink install dlcompat 80 | [3] Make the following changes to the 81 | tinyscheme-1.32.tar.gz 82 | 83 | diff -r tinyscheme-1.32/dynload.c 84 | tinyscheme-1.32-new/dynload.c 85 | 24c24 86 | < #define SUN_DL 87 | --- 88 | > 89 | Only in tinyscheme-1.32-new/: dynload.o 90 | 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 91 | 33,34c33,43 92 | < LD = gcc 93 | < LDFLAGS = -shared 94 | --- 95 | > #LD = gcc 96 | > #LDFLAGS = -shared 97 | > #DEBUG=-g -Wno-char-subscripts -O 98 | > #SYS_LIBS= -ldl 99 | > #PLATFORM_FEATURES= -DSUN_DL=1 100 | > 101 | > # Mac OS X 102 | > CC = gcc 103 | > CFLAGS = -I/usr/local/fink/include 104 | > LD = gcc 105 | > LDFLAGS = -L/usr/local/fink/lib 106 | 37c46 107 | < PLATFORM_FEATURES= -DSUN_DL=1 108 | --- 109 | > PLATFORM_FEATURES= -DSUN_DL=1 -DOSX 110 | 60c69 111 | < $(CC) -I. -c $(DEBUG) $(FEATURES) 112 | $(DL_FLAGS) $< 113 | --- 114 | > $(CC) $(CFLAGS) -I. -c $(DEBUG) 115 | $(FEATURES) $(DL_FLAGS) $< 116 | 66c75 117 | < $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS) 118 | --- 119 | > $(CC) $(LDFLAGS) -o $@ $(DEBUG) $(OBJS) 120 | $(SYS_LIBS) 121 | Only in tinyscheme-1.32-new/: scheme 122 | diff -r tinyscheme-1.32/scheme.c 123 | tinyscheme-1.32-new/scheme.c 124 | 60,61c60,61 125 | < #ifndef macintosh 126 | < # include 127 | --- 128 | > #ifdef OSX 129 | > /* Do nothing */ 130 | 62a63,65 131 | > # ifndef macintosh 132 | > # include 133 | > # else 134 | 77c80,81 135 | < #endif /* macintosh */ 136 | --- 137 | > # endif /* macintosh */ 138 | > #endif /* !OSX */ 139 | Only in tinyscheme-1.32-new/: scheme.o 140 | -------------------------------------------------------------------------------- /re/regexec.c: -------------------------------------------------------------------------------- 1 | /* 2 | * the outer shell of regexec() 3 | * 4 | * This file includes engine.c *twice*, after muchos fiddling with the 5 | * macros that code uses. This lets the same code operate on two different 6 | * representations for state sets. 7 | */ 8 | #include 9 | 10 | #include "utils.h" 11 | #include "regex2.h" 12 | 13 | #ifndef NDEBUG 14 | static int nope = 0; /* for use in asserts; shuts lint up */ 15 | #endif 16 | 17 | /* macros for manipulating states, small version */ 18 | #define states long 19 | #define states1 states /* for later use in regexec() decision */ 20 | #define CLEAR(v) ((v) = 0) 21 | #define SET0(v, n) ((v) &= ~(1 << (n))) 22 | #define SET1(v, n) ((v) |= 1 << (n)) 23 | #define ISSET(v, n) ((v) & (1 << (n))) 24 | #define ASSIGN(d, s) ((d) = (s)) 25 | #define EQ(a, b) ((a) == (b)) 26 | #define STATEVARS int dummy /* dummy version */ 27 | #define STATESETUP(m, n) /* nothing */ 28 | #define STATETEARDOWN(m) /* nothing */ 29 | #define SETUP(v) ((v) = 0) 30 | #define onestate int 31 | #define INIT(o, n) ((o) = (unsigned)1 << (n)) 32 | #define INC(o) ((o) <<= 1) 33 | #define ISSTATEIN(v, o) ((v) & (o)) 34 | /* some abbreviations; note that some of these know variable names! */ 35 | /* do "if I'm here, I can also be there" etc without branches */ 36 | #define FWD(dst, src, n) ((dst) |= ((unsigned)(src)&(here)) << (n)) 37 | #define BACK(dst, src, n) ((dst) |= ((unsigned)(src)&(here)) >> (n)) 38 | #define ISSETBACK(v, n) ((v) & ((unsigned)here >> (n))) 39 | /* function names */ 40 | #define SNAMES /* engine.c looks after details */ 41 | 42 | #include "engine.c" 43 | 44 | /* now undo things */ 45 | #undef states 46 | #undef CLEAR 47 | #undef SET0 48 | #undef SET1 49 | #undef ISSET 50 | #undef ASSIGN 51 | #undef EQ 52 | #undef STATEVARS 53 | #undef STATESETUP 54 | #undef STATETEARDOWN 55 | #undef SETUP 56 | #undef onestate 57 | #undef INIT 58 | #undef INC 59 | #undef ISSTATEIN 60 | #undef FWD 61 | #undef BACK 62 | #undef ISSETBACK 63 | #undef SNAMES 64 | 65 | /* macros for manipulating states, large version */ 66 | #define states char * 67 | #define CLEAR(v) memset(v, 0, m->g->nstates) 68 | #define SET0(v, n) ((v)[n] = 0) 69 | #define SET1(v, n) ((v)[n] = 1) 70 | #define ISSET(v, n) ((v)[n]) 71 | #define ASSIGN(d, s) memcpy(d, s, m->g->nstates) 72 | #define EQ(a, b) (memcmp(a, b, m->g->nstates) == 0) 73 | #define STATEVARS int vn; char *space 74 | #define STATESETUP(m, nv) { (m)->space = malloc((nv)*(m)->g->nstates); \ 75 | if ((m)->space == NULL) return(REG_ESPACE); \ 76 | (m)->vn = 0; } 77 | #define STATETEARDOWN(m) { free((m)->space); } 78 | #define SETUP(v) ((v) = &m->space[m->vn++ * m->g->nstates]) 79 | #define onestate int 80 | #define INIT(o, n) ((o) = (n)) 81 | #define INC(o) ((o)++) 82 | #define ISSTATEIN(v, o) ((v)[o]) 83 | /* some abbreviations; note that some of these know variable names! */ 84 | /* do "if I'm here, I can also be there" etc without branches */ 85 | #define FWD(dst, src, n) ((dst)[here+(n)] |= (src)[here]) 86 | #define BACK(dst, src, n) ((dst)[here-(n)] |= (src)[here]) 87 | #define ISSETBACK(v, n) ((v)[here - (n)]) 88 | /* function names */ 89 | #define LNAMES /* flag */ 90 | 91 | #include "engine.c" 92 | 93 | /* 94 | - regexec - interface for matching 95 | = API_EXPORT(int) regexec(const regex_t *, const char *, size_t, \ 96 | = regmatch_t [], int); 97 | = #define REG_NOTBOL 00001 98 | = #define REG_NOTEOL 00002 99 | = #define REG_STARTEND 00004 100 | = #define REG_TRACE 00400 // tracing of execution 101 | = #define REG_LARGE 01000 // force large representation 102 | = #define REG_BACKR 02000 // force use of backref code 103 | * 104 | * We put this here so we can exploit knowledge of the state representation 105 | * when choosing which matcher to call. Also, by this point the matchers 106 | * have been prototyped. 107 | */ 108 | API_EXPORT(int) /* 0 success, REG_NOMATCH failure */ 109 | regexec(preg, string, nmatch, pmatch, eflags) 110 | const regex_t *preg; 111 | const char *string; 112 | size_t nmatch; 113 | regmatch_t pmatch[]; 114 | int eflags; 115 | { 116 | register struct re_guts *g = preg->re_g; 117 | #ifdef REDEBUG 118 | # define GOODFLAGS(f) (f) 119 | #else 120 | # define GOODFLAGS(f) ((f)&(REG_NOTBOL|REG_NOTEOL|REG_STARTEND)) 121 | #endif 122 | 123 | if (preg->re_magic != MAGIC1 || g->magic != MAGIC2) 124 | return(REG_BADPAT); 125 | assert(!(g->iflags&BAD)); 126 | if (g->iflags&BAD) /* backstop for no-debug case */ 127 | return(REG_BADPAT); 128 | eflags = GOODFLAGS(eflags); 129 | 130 | if (g->nstates <= CHAR_BIT*sizeof(states1) && !(eflags®_LARGE)) 131 | return(smatcher(g, (char *)string, nmatch, pmatch, eflags)); 132 | else 133 | return(lmatcher(g, (char *)string, nmatch, pmatch, eflags)); 134 | } 135 | -------------------------------------------------------------------------------- /minischeme/init.scm: -------------------------------------------------------------------------------- 1 | ; This is a init file for Mini-Scheme. 2 | 3 | ;; fake pre R^3 boolean values 4 | (define nil #f) 5 | (define t #t) 6 | 7 | (define (caar x) (car (car x))) 8 | (define (cadr x) (car (cdr x))) 9 | (define (cdar x) (cdr (car x))) 10 | (define (cddr x) (cdr (cdr x))) 11 | (define (caaar x) (car (car (car x)))) 12 | (define (caadr x) (car (car (cdr x)))) 13 | (define (cadar x) (car (cdr (car x)))) 14 | (define (caddr x) (car (cdr (cdr x)))) 15 | (define (cdaar x) (cdr (car (car x)))) 16 | (define (cdadr x) (cdr (car (cdr x)))) 17 | (define (cddar x) (cdr (cdr (car x)))) 18 | (define (cdddr x) (cdr (cdr (cdr x)))) 19 | 20 | (define call/cc call-with-current-continuation) 21 | 22 | (define (list . x) x) 23 | 24 | (define (map proc list) 25 | (if (pair? list) 26 | (cons (proc (car list)) (map proc (cdr list))))) 27 | 28 | (define (for-each proc list) 29 | (if (pair? list) 30 | (begin (proc (car list)) (for-each proc (cdr list))) 31 | #t )) 32 | 33 | (define (list-tail x k) 34 | (if (zero? k) 35 | x 36 | (list-tail (cdr x) (- k 1)))) 37 | 38 | (define (list-ref x k) 39 | (car (list-tail x k))) 40 | 41 | (define (last-pair x) 42 | (if (pair? (cdr x)) 43 | (last-pair (cdr x)) 44 | x)) 45 | 46 | (define (head stream) (car stream)) 47 | 48 | (define (tail stream) (force (cdr stream))) 49 | 50 | ;; The following quasiquote macro is due to Eric S. Tiedemann. 51 | ;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. 52 | ;; 53 | ;; --- If you don't use macro or quasiquote, cut below. --- 54 | 55 | (macro 56 | quasiquote 57 | (lambda (l) 58 | (define (mcons f l r) 59 | (if (and (pair? r) 60 | (eq? (car r) 'quote) 61 | (eq? (car (cdr r)) (cdr f)) 62 | (pair? l) 63 | (eq? (car l) 'quote) 64 | (eq? (car (cdr l)) (car f))) 65 | (list 'quote f) 66 | (list 'cons l r))) 67 | (define (mappend f l r) 68 | (if (or (null? (cdr f)) 69 | (and (pair? r) 70 | (eq? (car r) 'quote) 71 | (eq? (car (cdr r)) '()))) 72 | l 73 | (list 'append l r))) 74 | (define (foo level form) 75 | (cond ((not (pair? form)) (list 'quote form)) 76 | ((eq? 'quasiquote (car form)) 77 | (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) 78 | (#t (if (zero? level) 79 | (cond ((eq? (car form) 'unquote) (car (cdr form))) 80 | ((eq? (car form) 'unquote-splicing) 81 | (error "Unquote-splicing wasn't in a list:" 82 | form)) 83 | ((and (pair? (car form)) 84 | (eq? (car (car form)) 'unquote-splicing)) 85 | (mappend form (car (cdr (car form))) 86 | (foo level (cdr form)))) 87 | (#t (mcons form (foo level (car form)) 88 | (foo level (cdr form))))) 89 | (cond ((eq? (car form) 'unquote) 90 | (mcons form ''unquote (foo (- level 1) 91 | (cdr form)))) 92 | ((eq? (car form) 'unquote-splicing) 93 | (mcons form ''unquote-splicing 94 | (foo (- level 1) (cdr form)))) 95 | (#t (mcons form (foo level (car form)) 96 | (foo level (cdr form))))))))) 97 | (foo 0 (car (cdr l))))) 98 | 99 | ;;;;; following part is written by a.k 100 | 101 | ;;;; atom? 102 | (define (atom? x) 103 | (not (pair? x))) 104 | 105 | ;;;; memq 106 | (define (memq obj lst) 107 | (cond 108 | ((null? lst) #f) 109 | ((eq? obj (car lst)) lst) 110 | (else (memq obj (cdr lst))))) 111 | 112 | ;;;; equal? 113 | (define (equal? x y) 114 | (if (pair? x) 115 | (and (pair? y) 116 | (equal? (car x) (car y)) 117 | (equal? (cdr x) (cdr y))) 118 | (and (not (pair? y)) 119 | (eqv? x y)))) 120 | 121 | 122 | ;;;; (do ((var init inc) ...) (endtest result ...) body ...) 123 | ;; 124 | (macro do 125 | (lambda (do-macro) 126 | (apply (lambda (do vars endtest . body) 127 | (let ((do-loop (gensym))) 128 | `(letrec ((,do-loop 129 | (lambda ,(map (lambda (x) 130 | (if (pair? x) (car x) x)) 131 | `,vars) 132 | (if ,(car endtest) 133 | (begin ,@(cdr endtest)) 134 | (begin 135 | ,@body 136 | (,do-loop 137 | ,@(map (lambda (x) 138 | (cond 139 | ((not (pair? x)) x) 140 | ((< (length x) 3) (car x)) 141 | (else (car (cdr (cdr x)))))) 142 | `,vars))))))) 143 | (,do-loop 144 | ,@(map (lambda (x) 145 | (if (and (pair? x) (cdr x)) 146 | (car (cdr x)) 147 | nil)) 148 | `,vars))))) 149 | do-macro))) 150 | 151 | -------------------------------------------------------------------------------- /re/WHATSNEW: -------------------------------------------------------------------------------- 1 | New in 1.3: Include scheme-private.h in re.c to fix compilation errors 2 | when used with TinyScheme 1.40 and later. 3 | 4 | New in alpha3.4: The complex bug alluded to below has been fixed (in a 5 | slightly kludgey temporary way that may hurt efficiency a bit; this is 6 | another "get it out the door for 4.4" release). The tests at the end of 7 | the tests file have accordingly been uncommented. The primary sign of 8 | the bug was that something like a?b matching ab matched b rather than ab. 9 | (The bug was essentially specific to this exact situation, else it would 10 | have shown up earlier.) 11 | 12 | New in alpha3.3: The definition of word boundaries has been altered 13 | slightly, to more closely match the usual programming notion that "_" 14 | is an alphabetic. Stuff used for pre-ANSI systems is now in a subdir, 15 | and the makefile no longer alludes to it in mysterious ways. The 16 | makefile has generally been cleaned up some. Fixes have been made 17 | (again!) so that the regression test will run without -DREDEBUG, at 18 | the cost of weaker checking. A workaround for a bug in some folks' 19 | has been added. And some more things have been added to 20 | tests, including a couple right at the end which are commented out 21 | because the code currently flunks them (complex bug; fix coming). 22 | Plus the usual minor cleanup. 23 | 24 | New in alpha3.2: Assorted bits of cleanup and portability improvement 25 | (the development base is now a BSDI system using GCC instead of an ancient 26 | Sun system, and the newer compiler exposed some glitches). Fix for a 27 | serious bug that affected REs using many [] (including REG_ICASE REs 28 | because of the way they are implemented), *sometimes*, depending on 29 | memory-allocation patterns. The header-file prototypes no longer name 30 | the parameters, avoiding possible name conflicts. The possibility that 31 | some clot has defined CHAR_MIN as (say) `-128' instead of `(-128)' is 32 | now handled gracefully. "uchar" is no longer used as an internal type 33 | name (too many people have the same idea). Still the same old lousy 34 | performance, alas. 35 | 36 | New in alpha3.1: Basically nothing, this release is just a bookkeeping 37 | convenience. Stay tuned. 38 | 39 | New in alpha3.0: Performance is no better, alas, but some fixes have been 40 | made and some functionality has been added. (This is basically the "get 41 | it out the door in time for 4.4" release.) One bug fix: regfree() didn't 42 | free the main internal structure (how embarrassing). It is now possible 43 | to put NULs in either the RE or the target string, using (resp.) a new 44 | REG_PEND flag and the old REG_STARTEND flag. The REG_NOSPEC flag to 45 | regcomp() makes all characters ordinary, so you can match a literal 46 | string easily (this will become more useful when performance improves!). 47 | There are now primitives to match beginnings and ends of words, although 48 | the syntax is disgusting and so is the implementation. The REG_ATOI 49 | debugging interface has changed a bit. And there has been considerable 50 | internal cleanup of various kinds. 51 | 52 | New in alpha2.3: Split change list out of README, and moved flags notes 53 | into Makefile. Macro-ized the name of regex(7) in regex(3), since it has 54 | to change for 4.4BSD. Cleanup work in engine.c, and some new regression 55 | tests to catch tricky cases thereof. 56 | 57 | New in alpha2.2: Out-of-date manpages updated. Regerror() acquires two 58 | small extensions -- REG_ITOA and REG_ATOI -- which avoid debugging kludges 59 | in my own test program and might be useful to others for similar purposes. 60 | The regression test will now compile (and run) without REDEBUG. The 61 | BRE \$ bug is fixed. Most uses of "uchar" are gone; it's all chars now. 62 | Char/uchar parameters are now written int/unsigned, to avoid possible 63 | portability problems with unpromoted parameters. Some unsigned casts have 64 | been introduced to minimize portability problems with shifting into sign 65 | bits. 66 | 67 | New in alpha2.1: Lots of little stuff, cleanup and fixes. The one big 68 | thing is that regex.h is now generated, using mkh, rather than being 69 | supplied in the distribution; due to circularities in dependencies, 70 | you have to build regex.h explicitly by "make h". The two known bugs 71 | have been fixed (and the regression test now checks for them), as has a 72 | problem with assertions not being suppressed in the absence of REDEBUG. 73 | No performance work yet. 74 | 75 | New in alpha2: Backslash-anything is an ordinary character, not an 76 | error (except, of course, for the handful of backslashed metacharacters 77 | in BREs), which should reduce script breakage. The regression test 78 | checks *where* null strings are supposed to match, and has generally 79 | been tightened up somewhat. Small bug fixes in parameter passing (not 80 | harmful, but technically errors) and some other areas. Debugging 81 | invoked by defining REDEBUG rather than not defining NDEBUG. 82 | 83 | New in alpha+3: full prototyping for internal routines, using a little 84 | helper program, mkh, which extracts prototypes given in stylized comments. 85 | More minor cleanup. Buglet fix: it's CHAR_BIT, not CHAR_BITS. Simple 86 | pre-screening of input when a literal string is known to be part of the 87 | RE; this does wonders for performance. 88 | 89 | New in alpha+2: minor bits of cleanup. Notably, the number "32" for the 90 | word width isn't hardwired into regexec.c any more, the public header 91 | file prototypes the functions if __STDC__ is defined, and some small typos 92 | in the manpages have been fixed. 93 | 94 | New in alpha+1: improvements to the manual pages, and an important 95 | extension, the REG_STARTEND option to regexec(). 96 | -------------------------------------------------------------------------------- /tinyscheme-1.40/scheme-private.h: -------------------------------------------------------------------------------- 1 | /* scheme-private.h */ 2 | 3 | #ifndef _SCHEME_PRIVATE_H 4 | #define _SCHEME_PRIVATE_H 5 | 6 | #include "scheme.h" 7 | /*------------------ Ugly internals -----------------------------------*/ 8 | /*------------------ Of interest only to FFI users --------------------*/ 9 | 10 | #ifdef __cplusplus 11 | extern "C" { 12 | #endif 13 | 14 | enum scheme_port_kind { 15 | port_free=0, 16 | port_file=1, 17 | port_string=2, 18 | port_srfi6=4, 19 | port_input=16, 20 | port_output=32, 21 | port_saw_EOF=64, 22 | }; 23 | 24 | typedef struct port { 25 | unsigned char kind; 26 | union { 27 | struct { 28 | FILE *file; 29 | int closeit; 30 | #if SHOW_ERROR_LINE 31 | int curr_line; 32 | char *filename; 33 | #endif 34 | } stdio; 35 | struct { 36 | char *start; 37 | char *past_the_end; 38 | char *curr; 39 | } string; 40 | } rep; 41 | } port; 42 | 43 | /* cell structure */ 44 | struct cell { 45 | unsigned int _flag; 46 | union { 47 | struct { 48 | char *_svalue; 49 | int _length; 50 | } _string; 51 | num _number; 52 | port *_port; 53 | foreign_func _ff; 54 | struct { 55 | struct cell *_car; 56 | struct cell *_cdr; 57 | } _cons; 58 | } _object; 59 | }; 60 | 61 | struct scheme { 62 | /* arrays for segments */ 63 | func_alloc malloc; 64 | func_dealloc free; 65 | 66 | /* return code */ 67 | int retcode; 68 | int tracing; 69 | 70 | 71 | #define CELL_SEGSIZE 5000 /* # of cells in one segment */ 72 | #define CELL_NSEGMENT 10 /* # of segments for cells */ 73 | char *alloc_seg[CELL_NSEGMENT]; 74 | pointer cell_seg[CELL_NSEGMENT]; 75 | int last_cell_seg; 76 | 77 | /* We use 4 registers. */ 78 | pointer args; /* register for arguments of function */ 79 | pointer envir; /* stack register for current environment */ 80 | pointer code; /* register for current code */ 81 | pointer dump; /* stack register for next evaluation */ 82 | 83 | int interactive_repl; /* are we in an interactive REPL? */ 84 | 85 | struct cell _sink; 86 | pointer sink; /* when mem. alloc. fails */ 87 | struct cell _NIL; 88 | pointer NIL; /* special cell representing empty cell */ 89 | struct cell _HASHT; 90 | pointer T; /* special cell representing #t */ 91 | struct cell _HASHF; 92 | pointer F; /* special cell representing #f */ 93 | struct cell _EOF_OBJ; 94 | pointer EOF_OBJ; /* special cell representing end-of-file object */ 95 | pointer oblist; /* pointer to symbol table */ 96 | pointer global_env; /* pointer to global environment */ 97 | pointer c_nest; /* stack for nested calls from C */ 98 | 99 | /* global pointers to special symbols */ 100 | pointer LAMBDA; /* pointer to syntax lambda */ 101 | pointer QUOTE; /* pointer to syntax quote */ 102 | 103 | pointer QQUOTE; /* pointer to symbol quasiquote */ 104 | pointer UNQUOTE; /* pointer to symbol unquote */ 105 | pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ 106 | pointer FEED_TO; /* => */ 107 | pointer COLON_HOOK; /* *colon-hook* */ 108 | pointer ERROR_HOOK; /* *error-hook* */ 109 | pointer SHARP_HOOK; /* *sharp-hook* */ 110 | pointer COMPILE_HOOK; /* *compile-hook* */ 111 | 112 | pointer free_cell; /* pointer to top of free cells */ 113 | long fcells; /* # of free cells */ 114 | 115 | pointer inport; 116 | pointer outport; 117 | pointer save_inport; 118 | pointer loadport; 119 | 120 | #define MAXFIL 64 121 | port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ 122 | int nesting_stack[MAXFIL]; 123 | int file_i; 124 | int nesting; 125 | 126 | char gc_verbose; /* if gc_verbose is not zero, print gc status */ 127 | char no_memory; /* Whether mem. alloc. has failed */ 128 | 129 | #define LINESIZE 1024 130 | char linebuff[LINESIZE]; 131 | #define STRBUFFSIZE 256 132 | char strbuff[STRBUFFSIZE]; 133 | 134 | FILE *tmpfp; 135 | int tok; 136 | int print_flag; 137 | pointer value; 138 | int op; 139 | 140 | void *ext_data; /* For the benefit of foreign functions */ 141 | long gensym_cnt; 142 | 143 | struct scheme_interface *vptr; 144 | void *dump_base; /* pointer to base of allocated dump stack */ 145 | int dump_size; /* number of frames allocated for dump stack */ 146 | }; 147 | 148 | /* operator code */ 149 | enum scheme_opcodes { 150 | #define _OP_DEF(A,B,C,D,E,OP) OP, 151 | #include "opdefines.h" 152 | OP_MAXDEFINED 153 | }; 154 | 155 | 156 | #define cons(sc,a,b) _cons(sc,a,b,0) 157 | #define immutable_cons(sc,a,b) _cons(sc,a,b,1) 158 | 159 | int is_string(pointer p); 160 | char *string_value(pointer p); 161 | int is_number(pointer p); 162 | num nvalue(pointer p); 163 | long ivalue(pointer p); 164 | double rvalue(pointer p); 165 | int is_integer(pointer p); 166 | int is_real(pointer p); 167 | int is_character(pointer p); 168 | long charvalue(pointer p); 169 | int is_vector(pointer p); 170 | 171 | int is_port(pointer p); 172 | 173 | int is_pair(pointer p); 174 | pointer pair_car(pointer p); 175 | pointer pair_cdr(pointer p); 176 | pointer set_car(pointer p, pointer q); 177 | pointer set_cdr(pointer p, pointer q); 178 | 179 | int is_symbol(pointer p); 180 | char *symname(pointer p); 181 | int hasprop(pointer p); 182 | 183 | int is_syntax(pointer p); 184 | int is_proc(pointer p); 185 | int is_foreign(pointer p); 186 | char *syntaxname(pointer p); 187 | int is_closure(pointer p); 188 | #ifdef USE_MACRO 189 | int is_macro(pointer p); 190 | #endif 191 | pointer closure_code(pointer p); 192 | pointer closure_env(pointer p); 193 | 194 | int is_continuation(pointer p); 195 | int is_promise(pointer p); 196 | int is_environment(pointer p); 197 | int is_immutable(pointer p); 198 | void setimmutable(pointer p); 199 | 200 | #ifdef __cplusplus 201 | } 202 | #endif 203 | 204 | #endif 205 | 206 | /* 207 | Local variables: 208 | c-file-style: "k&r" 209 | End: 210 | */ 211 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/scheme-private.h: -------------------------------------------------------------------------------- 1 | /* scheme-private.h */ 2 | 3 | #ifndef _SCHEME_PRIVATE_H 4 | #define _SCHEME_PRIVATE_H 5 | 6 | #include "scheme.h" 7 | /*------------------ Ugly internals -----------------------------------*/ 8 | /*------------------ Of interest only to FFI users --------------------*/ 9 | 10 | #ifdef __cplusplus 11 | extern "C" { 12 | #endif 13 | 14 | enum scheme_port_kind { 15 | port_free=0, 16 | port_file=1, 17 | port_string=2, 18 | port_srfi6=4, 19 | port_input=16, 20 | port_output=32, 21 | port_saw_EOF=64, 22 | }; 23 | 24 | typedef struct port { 25 | unsigned char kind; 26 | union { 27 | struct { 28 | FILE *file; 29 | int closeit; 30 | #if SHOW_ERROR_LINE 31 | int curr_line; 32 | char *filename; 33 | #endif 34 | } stdio; 35 | struct { 36 | char *start; 37 | char *past_the_end; 38 | char *curr; 39 | } string; 40 | } rep; 41 | } port; 42 | 43 | /* cell structure */ 44 | struct cell { 45 | unsigned int _flag; 46 | union { 47 | struct { 48 | char *_svalue; 49 | int _length; 50 | } _string; 51 | num _number; 52 | port *_port; 53 | foreign_func _ff; 54 | struct { 55 | struct cell *_car; 56 | struct cell *_cdr; 57 | } _cons; 58 | } _object; 59 | }; 60 | 61 | struct scheme { 62 | /* arrays for segments */ 63 | func_alloc malloc; 64 | func_dealloc free; 65 | 66 | /* return code */ 67 | int retcode; 68 | int tracing; 69 | 70 | 71 | #define CELL_SEGSIZE 5000 /* # of cells in one segment */ 72 | #define CELL_NSEGMENT 10 /* # of segments for cells */ 73 | char *alloc_seg[CELL_NSEGMENT]; 74 | pointer cell_seg[CELL_NSEGMENT]; 75 | int last_cell_seg; 76 | 77 | /* We use 4 registers. */ 78 | pointer args; /* register for arguments of function */ 79 | pointer envir; /* stack register for current environment */ 80 | pointer code; /* register for current code */ 81 | pointer dump; /* stack register for next evaluation */ 82 | 83 | int interactive_repl; /* are we in an interactive REPL? */ 84 | 85 | struct cell _sink; 86 | pointer sink; /* when mem. alloc. fails */ 87 | struct cell _NIL; 88 | pointer NIL; /* special cell representing empty cell */ 89 | struct cell _HASHT; 90 | pointer T; /* special cell representing #t */ 91 | struct cell _HASHF; 92 | pointer F; /* special cell representing #f */ 93 | struct cell _EOF_OBJ; 94 | pointer EOF_OBJ; /* special cell representing end-of-file object */ 95 | pointer oblist; /* pointer to symbol table */ 96 | pointer global_env; /* pointer to global environment */ 97 | pointer c_nest; /* stack for nested calls from C */ 98 | 99 | /* global pointers to special symbols */ 100 | pointer LAMBDA; /* pointer to syntax lambda */ 101 | pointer QUOTE; /* pointer to syntax quote */ 102 | 103 | pointer QQUOTE; /* pointer to symbol quasiquote */ 104 | pointer UNQUOTE; /* pointer to symbol unquote */ 105 | pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ 106 | pointer FEED_TO; /* => */ 107 | pointer COLON_HOOK; /* *colon-hook* */ 108 | pointer ERROR_HOOK; /* *error-hook* */ 109 | pointer SHARP_HOOK; /* *sharp-hook* */ 110 | pointer COMPILE_HOOK; /* *compile-hook* */ 111 | 112 | pointer free_cell; /* pointer to top of free cells */ 113 | long fcells; /* # of free cells */ 114 | 115 | pointer inport; 116 | pointer outport; 117 | pointer save_inport; 118 | pointer loadport; 119 | 120 | #define MAXFIL 64 121 | port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ 122 | int nesting_stack[MAXFIL]; 123 | int file_i; 124 | int nesting; 125 | 126 | char gc_verbose; /* if gc_verbose is not zero, print gc status */ 127 | char no_memory; /* Whether mem. alloc. has failed */ 128 | 129 | #define LINESIZE 1024 130 | char linebuff[LINESIZE]; 131 | #define STRBUFFSIZE 256 132 | char strbuff[STRBUFFSIZE]; 133 | 134 | FILE *tmpfp; 135 | int tok; 136 | int print_flag; 137 | pointer value; 138 | int op; 139 | 140 | void *ext_data; /* For the benefit of foreign functions */ 141 | long gensym_cnt; 142 | 143 | struct scheme_interface *vptr; 144 | void *dump_base; /* pointer to base of allocated dump stack */ 145 | int dump_size; /* number of frames allocated for dump stack */ 146 | }; 147 | 148 | /* operator code */ 149 | enum scheme_opcodes { 150 | #define _OP_DEF(A,B,C,D,E,OP) OP, 151 | #include "opdefines.h" 152 | OP_MAXDEFINED 153 | }; 154 | 155 | 156 | #define cons(sc,a,b) _cons(sc,a,b,0) 157 | #define immutable_cons(sc,a,b) _cons(sc,a,b,1) 158 | 159 | int is_string(pointer p); 160 | char *string_value(pointer p); 161 | int is_number(pointer p); 162 | num nvalue(pointer p); 163 | long ivalue(pointer p); 164 | double rvalue(pointer p); 165 | int is_integer(pointer p); 166 | int is_real(pointer p); 167 | int is_character(pointer p); 168 | long charvalue(pointer p); 169 | int is_vector(pointer p); 170 | 171 | int is_port(pointer p); 172 | 173 | int is_pair(pointer p); 174 | pointer pair_car(pointer p); 175 | pointer pair_cdr(pointer p); 176 | pointer set_car(pointer p, pointer q); 177 | pointer set_cdr(pointer p, pointer q); 178 | 179 | int is_symbol(pointer p); 180 | char *symname(pointer p); 181 | int hasprop(pointer p); 182 | 183 | int is_syntax(pointer p); 184 | int is_proc(pointer p); 185 | int is_foreign(pointer p); 186 | char *syntaxname(pointer p); 187 | int is_closure(pointer p); 188 | #ifdef USE_MACRO 189 | int is_macro(pointer p); 190 | #endif 191 | pointer closure_code(pointer p); 192 | pointer closure_env(pointer p); 193 | 194 | int is_continuation(pointer p); 195 | int is_promise(pointer p); 196 | int is_environment(pointer p); 197 | int is_immutable(pointer p); 198 | void setimmutable(pointer p); 199 | 200 | #ifdef __cplusplus 201 | } 202 | #endif 203 | 204 | #endif 205 | 206 | /* 207 | Local variables: 208 | c-file-style: "k&r" 209 | End: 210 | */ 211 | -------------------------------------------------------------------------------- /re/regex2.h: -------------------------------------------------------------------------------- 1 | /* 2 | * First, the stuff that ends up in the outside-world include file 3 | = #ifdef WIN32 4 | = #define API_EXPORT(type) __declspec(dllexport) type __stdcall 5 | = #else 6 | = #define API_EXPORT(type) type 7 | = #endif 8 | = 9 | = typedef off_t regoff_t; 10 | = typedef struct { 11 | = int re_magic; 12 | = size_t re_nsub; // number of parenthesized subexpressions 13 | = const char *re_endp; // end pointer for REG_PEND 14 | = struct re_guts *re_g; // none of your business :-) 15 | = } regex_t; 16 | = typedef struct { 17 | = regoff_t rm_so; // start of match 18 | = regoff_t rm_eo; // end of match 19 | = } regmatch_t; 20 | */ 21 | /* 22 | * internals of regex_t 23 | */ 24 | #define MAGIC1 ((('r'^0200)<<8) | 'e') 25 | 26 | /* 27 | * The internal representation is a *strip*, a sequence of 28 | * operators ending with an endmarker. (Some terminology etc. is a 29 | * historical relic of earlier versions which used multiple strips.) 30 | * Certain oddities in the representation are there to permit running 31 | * the machinery backwards; in particular, any deviation from sequential 32 | * flow must be marked at both its source and its destination. Some 33 | * fine points: 34 | * 35 | * - OPLUS_ and O_PLUS are *inside* the loop they create. 36 | * - OQUEST_ and O_QUEST are *outside* the bypass they create. 37 | * - OCH_ and O_CH are *outside* the multi-way branch they create, while 38 | * OOR1 and OOR2 are respectively the end and the beginning of one of 39 | * the branches. Note that there is an implicit OOR2 following OCH_ 40 | * and an implicit OOR1 preceding O_CH. 41 | * 42 | * In state representations, an operator's bit is on to signify a state 43 | * immediately *preceding* "execution" of that operator. 44 | */ 45 | typedef unsigned long sop; /* strip operator */ 46 | typedef long sopno; 47 | #define OPRMASK 0xf8000000 48 | #define OPDMASK 0x07ffffff 49 | #define OPSHIFT ((unsigned)27) 50 | #define OP(n) ((n)&OPRMASK) 51 | #define OPND(n) ((n)&OPDMASK) 52 | #define SOP(op, opnd) ((op)|(opnd)) 53 | /* operators meaning operand */ 54 | /* (back, fwd are offsets) */ 55 | #define OEND (1< uch [csetsize] */ 90 | uch mask; /* bit within array */ 91 | uch hash; /* hash code */ 92 | size_t smultis; 93 | char *multis; /* -> char[smulti] ab\0cd\0ef\0\0 */ 94 | } cset; 95 | /* note that CHadd and CHsub are unsafe, and CHIN doesn't yield 0/1 */ 96 | #define CHadd(cs, c) ((cs)->ptr[(uch)(c)] |= (cs)->mask, (cs)->hash += (c)) 97 | #define CHsub(cs, c) ((cs)->ptr[(uch)(c)] &= ~(cs)->mask, (cs)->hash -= (c)) 98 | #define CHIN(cs, c) ((cs)->ptr[(uch)(c)] & (cs)->mask) 99 | #define MCadd(p, cs, cp) mcadd(p, cs, cp) /* regcomp() internal fns */ 100 | 101 | /* stuff for character categories */ 102 | typedef unsigned char cat_t; 103 | 104 | /* 105 | * main compiled-expression structure 106 | */ 107 | struct re_guts { 108 | int magic; 109 | # define MAGIC2 ((('R'^0200)<<8)|'E') 110 | sop *strip; /* malloced area for strip */ 111 | int csetsize; /* number of bits in a cset vector */ 112 | int ncsets; /* number of csets in use */ 113 | cset *sets; /* -> cset [ncsets] */ 114 | uch *setbits; /* -> uch[csetsize][ncsets/CHAR_BIT] */ 115 | int cflags; /* copy of regcomp() cflags argument */ 116 | sopno nstates; /* = number of sops */ 117 | sopno firststate; /* the initial OEND (normally 0) */ 118 | sopno laststate; /* the final OEND */ 119 | int iflags; /* internal flags */ 120 | # define USEBOL 01 /* used ^ */ 121 | # define USEEOL 02 /* used $ */ 122 | # define BAD 04 /* something wrong */ 123 | int nbol; /* number of ^ used */ 124 | int neol; /* number of $ used */ 125 | int ncategories; /* how many character categories */ 126 | cat_t *categories; /* ->catspace[-CHAR_MIN] */ 127 | char *must; /* match must contain this string */ 128 | int mlen; /* length of must */ 129 | size_t nsub; /* copy of re_nsub */ 130 | int backrefs; /* does it use back references? */ 131 | sopno nplus; /* how deep does it nest +s? */ 132 | /* catspace must be last */ 133 | cat_t catspace[1]; /* actually [NC] */ 134 | }; 135 | 136 | /* misc utilities */ 137 | #define OUT (CHAR_MAX+1) /* a non-character value */ 138 | #define ISWORD(c) (isalnum(c) || (c) == '_') 139 | -------------------------------------------------------------------------------- /tsx-1.1/tsx-functions.txt: -------------------------------------------------------------------------------- 1 | TinyScheme Extensions (TSX) 1.1 [September, 2002] 2 | (c) 2002 Manuel Heras-Gilsanz (manuel@heras-gilsanz.com) 3 | 4 | This software is subject to the license terms contained in the 5 | LICENSE file. 6 | 7 | 8 | TSX FUNCTIONS 9 | 10 | TSX incorporates the following functions: 11 | 12 | *Sockets (included if HAVE_SOCKETS is defined in tsx.h) 13 | 14 | (make-client-socket host port) 15 | host: string (IP address or host name) 16 | port: integer number 17 | 18 | Returns a socket which is already connected to the 19 | specified host and port, or #f if the connection could 20 | not be performed. 21 | 22 | (make-server-socket port) 23 | port: integer number 24 | 25 | Returns a socket which is bound to the specified port on 26 | the local machine, and ready to accept connections. If the 27 | socket could not be created (e.g., because the port is 28 | already in use, or it is a privileged port and the user has 29 | no permissions on it), #f is returned. 30 | 31 | (recv! sock buff) 32 | sock: socket obtained with make-client-socket or accept 33 | buff: string 34 | 35 | Waits for received data through the specified socket, and 36 | stores it on the buffer. The return value indicates the 37 | number of received bytes. This call blocks until some data 38 | is received, but does not guarantee that buff gets 39 | completely filled. If an error occurs (e.g., the other 40 | peer disconnects) then #f is returned. 41 | 42 | (recv-new-string sock) 43 | sock: socket obtained with make-client-socket or accept 44 | 45 | Waits for received data through the specified socket, and 46 | returns it in a new string. This call blocks until some 47 | data is received. If an error occurs, then #f is returned. 48 | 49 | (send sock buff) 50 | sock: socket obtained with make-client-socket or accept 51 | buff: string 52 | 53 | Sends the data contained in the string through the socket. 54 | It returns the number of transmitted bytes (could be 55 | different than the size of the string!), or #f if an error 56 | occured (e.g., the other peer disconnected). 57 | 58 | (accept server-sock) 59 | server-sock: socket obtained with make-server-socket 60 | 61 | Waits until a connection is received on the specified 62 | server socket, and returns the connected socket. If an 63 | error occurs (e.g., the network interface shuts down), it 64 | returns #f instead. 65 | 66 | (close-socket sock) 67 | sock: socket obtained with make-server-socket, 68 | make-client-socket or accept 69 | 70 | The socket is closed. No further calls should be performed 71 | on this socket. 72 | 73 | (sock-is-data-ready? sock) 74 | sock: socket obtained with make-server-socket, 75 | make-client-socket or accept 76 | 77 | This function allows non-blocking operation with sockets. 78 | It returns #t if data is available for reception on this 79 | socket, and #f if no data has been received. 80 | 81 | (sock-peek sock) 82 | sock: socket obtained with make-server-socket, 83 | make-client-socket or accept 84 | 85 | This function returns (as a newly created string) the 86 | data received in this socket. The information is not 87 | removed from the input queue. 88 | 89 | *File system (included if HAVE_FILESYSTEM is defined in tsx.h) 90 | 91 | Scheme already defines functions to read and write files. These 92 | functions allow access to the filesystem to check if a certain 93 | file exists, to get its size, etc. 94 | 95 | (file-size filename) 96 | filename: string 97 | 98 | This function returns the size (in bytes) of the 99 | indicated file, or #f if the file does not exists or 100 | is not accessible to the requesting user. 101 | 102 | (file-exists? filename) 103 | filename: string 104 | 105 | This function returns #t if the indicated file exists, and 106 | #f if it does not exists or it is not accessible to the 107 | requesting user. 108 | 109 | (delete-file filename) 110 | filename: string 111 | 112 | Removes the specified file. It returns #t if the operation 113 | succeeds, or #f otherwise (e.g., because the file is 114 | read-only, or because the file does not exist). 115 | 116 | (open-dir-stream path) 117 | path: string 118 | 119 | Opens a "directory stream" on the provided directory path. 120 | This stream will provide all the files within the directory, 121 | using the function read-dir-entry. The stream should be closed 122 | at the end with close-dir-stream. 123 | 124 | (read-dir-entry dirstream) 125 | dirstream: directory stream, obtained with open-dir-stream. 126 | 127 | It returns the name of the following directory entry, or eof 128 | if all the entries were provided. Check the return value with 129 | with eof-object?. 130 | 131 | (close-dir-stream dirstream) 132 | dirstream: directory stream, obtained with open-dir-stream. 133 | 134 | Close directory stream. No further calls to read-dir-entry should 135 | be performed. 136 | 137 | 138 | *Time (available if HAVE_TIME is defined in tsx.h) 139 | 140 | (time) 141 | Returns the current local time, as a list of integer 142 | containing: 143 | (year month day-of-month hour min sec millisec) 144 | The year is expressed as an offsett from 1900. 145 | 146 | (gettimeofday) 147 | Returns a list containing the number of seconds from 148 | the beginning of the day, and microseconds within the 149 | current second. 150 | 151 | (usleep microsec) 152 | microsec: integer 153 | 154 | Suspends execution of the calling thread during the 155 | specified number of microseconds. 156 | 157 | 158 | *Miscellaneous functions (available if HAVE_MISC is defined) 159 | 160 | (getenv varname) 161 | varname: string 162 | 163 | Returns a string with the content of the specified 164 | environment variable, or #f if the variable is not 165 | defined. 166 | 167 | (system command) 168 | command: string 169 | 170 | Executes a command on the /bin/sh shell. Returns #f if 171 | it is unable to run /bin/sh or another error occurs, 172 | or an integer return code which is the value returned 173 | by the command to the shell. 174 | 175 | END 176 | 177 | -------------------------------------------------------------------------------- /minischeme/README: -------------------------------------------------------------------------------- 1 | ===================================================================== 2 | 3 | ---------- Mini-Scheme Interpreter Version 0.85 ---------- 4 | 5 | coded by Atsushi Moriwaki (11/5/1989) 6 | 7 | E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 8 | MIX : riemann 9 | NIFTY : PBB01074 10 | (Note that these addresses are now obsolete, see below) 11 | 12 | ===================================================================== 13 | 14 | Revised by Akira KIDA 15 | 16 | Version 0.85k4 (17 May 1994) 17 | Version 0.85k3 (30 Nov 1989) 18 | Version 0.85k2 (28 Nov 1989) 19 | Version 0.85k1 (14 Nov 1989) 20 | 21 | Mini-Scheme is now maintained by Akira KIDA. 22 | 23 | E-Mail : SDI00379@niftyserve.or.jp 24 | 25 | Most part of this document is written by Akira KIDA. 26 | Send comments/requests/bug reports to Akira KIDA at the above 27 | email address. 28 | 29 | ===================================================================== 30 | 31 | This Mini-Scheme Interpreter is based on "SCHEME Interpreter in 32 | Common Lisp" in Appendix of T.Matsuda & K.Saigo, Programming of LISP, 33 | archive No5 (1987) p6 - p42 (published in Japan). 34 | 35 | 36 | Copyright Notice: 37 | THIS SOFTWARE IS PLACED IN THE PUBLIC DOMAIN BY THE AUTHOR. 38 | 39 | This software is completely free to copy, modify and/or re-distribute. 40 | But I (Atsushi Moriwaki) would appreciate it if you left my name on the 41 | code as the author. 42 | 43 | DISCLAIMER: 44 | THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR 45 | IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED 46 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 47 | PURPOSE. 48 | 49 | 50 | Supported features (or, NOT supported features :-) 51 | 1) Lists, symbols, strings. 52 | However, strings have very limited capability. 53 | For instance, there is *NO* string-ref, string-set!, ... etc. 54 | 2) Numbers are limited to FIXNUM only. 55 | There is *NO* complex, real, rational and even bignum. 56 | 3) Macro feature is supported, though not the one defined in R4RS. 57 | 58 | Known problems: 59 | 1) Poor error recovery from illegal use of syntax and procedure. 60 | 2) Certain procedures do not check its argument type. 61 | 62 | Installation: 63 | 1) Select system declaration and configuration options by editing 64 | source file. 65 | 66 | You may choose one of the following systems by #define'ing 67 | the preprocessor symbol. 68 | 69 | Supported systems are: 70 | Macintosh: 71 | LSC -- LightSpeed C (3.0) for Macintosh 72 | LSC4 -- LightSpeed C (4.0) for Macintosh 73 | They are different in #include header only. 74 | I (kida) think THINK C 5.0, 6.0, 7.0 may be OK 75 | with LSC4 configuration, though not tested. 76 | MPW2 -- Macintosh Programmer's Workshop v2.0x 77 | I don't tested v3.x or later. 78 | DOS: 79 | MSC4 -- Microsoft C v4.0 (use /AL) 80 | MSC v5.1, v6.0, v7.0 are all OK. 81 | TURBO2 -- Bolarnd's Turbo C v2.0 (use -ml) 82 | Turbo C++ 1.0 is OK. 83 | UNIX: 84 | BSD -- UNIX of BSD flavor, ex. SuOS 4.x 85 | SYSV -- UNIX of System-V flavor, ex. Sun/Solaris 2.x 86 | 87 | VAX/VMS: 88 | VAXC -- VAX-C v3.x (this symbol may be defined by the 89 | compiler automatically). 90 | 91 | 2) Configure some preprocessor symbols by editing source files. 92 | 93 | Configurable #define's are: 94 | 95 | #define VERBOSE 96 | -- if defined, GC messages is verbose on default. 97 | 98 | #define AVOID_HACK_LOOP 99 | -- if defined, do _NOT_ use loop construction in the 100 | form 101 | do { ... } while (0) 102 | This form is used in macro expansion, since this is 103 | the best "safety" blocking construct when used in 104 | macro definition. 105 | However, some compiler (including SunPRO CC 2.0.1) 106 | is silly enough to warning this construct, like 107 | "warning: end-of-loop code not reached", etc. 108 | If you dislike such warning, please define this symbol. 109 | NOTE: You may get some "statement not reached" warning 110 | even if you have define this symbol. Please be patient, 111 | or, use more smart compiler. 112 | In short if you use GCC, undefine this and forget it 113 | at all. 114 | 115 | #define USE_SETJMP 116 | -- if defined, use setjmp to global jump on error. 117 | if not defined, avoid to use it. Compiled with 118 | this symbol defined, the interpreter issue fatal 119 | error and return to the operating system immediately 120 | when we run out of free cells. By default, i.e., 121 | compiled with this symbol is not defined, the 122 | interpreter will just return to the top level in 123 | such a case. 124 | May not be used except for compiling as Mac DA. 125 | 126 | #define USE_MACRO 127 | -- if defined, macro features are enabled. 128 | 129 | #define USE_QQUOTE 130 | -- if defined, you can use quasi-quote "`" in macro. 131 | You can use macro even if this symbol is undefined. 132 | 133 | 3) Compile! 134 | 135 | I think there is virtually no problem about how to compile. 136 | Since there is exactly one C source file. :-) 137 | If you are on UNIX boxes with some BSD flavors, instead of 138 | using make command, it's enough to type: 139 | 140 | cc -DBSD -O -o miniscm miniscm.c 141 | 142 | You may have additional warnings like 'function should 143 | return value'. This is due to omitting 'void' keyword 144 | from the source in order to get pre-ANSI compatibility. 145 | 146 | 147 | Usage : miniscm 148 | 149 | Sorry, no command line argnumet is allowed. 150 | 151 | 152 | Special procedures of this system: 153 | 154 | gc : (gc) -- force garbage collection 155 | 156 | gc-verbose : (gc-verbose bool) -- GC verbose on/off 157 | Argument #f turnes off the GC message. 158 | Enything else turn on the GC message. 159 | 160 | quit : (quit) -- quit to the operating system 161 | 162 | put : (put sym prop expr) 163 | -- set the value of a property of a symbol. 164 | get : (get sym prop) 165 | -- get the value of a property of a symbol. 166 | 167 | new-segment : (new-segment n) 168 | -- allocate n new cell segments. 169 | 170 | print-width : (print-width list) 171 | -- returns 'printed' width of list. 172 | 173 | closure? : (closure? obj) 174 | -- test if obj is a closure or not. 175 | 176 | macro? : (macro? obj) 177 | -- test if obj is a macro or not. 178 | note that a macro is also a closure. 179 | 180 | get-closure-code 181 | : (get-closure-code closure-obj) 182 | -- extract S-expr from closure-obj. 183 | 184 | Scheme files: 185 | init.scm -- Automatically loaded at invocation. 186 | Default setting assumes that this file is in the current 187 | working directory. 188 | Change #define InitFile if you don't like it. 189 | 190 | tools.scm -- This is a sample file. Contains very tiny pretty-print 191 | procedure. 192 | After invoking miniscm, type: 193 | (load "tools.scm") 194 | and try 195 | (pp getd) 196 | (pp do) 197 | 198 | Documents?: 199 | 200 | Sorry, there is no other documents. 201 | Do not ask one for me, please see the source instead. :-) 202 | 203 | But if you _absolutely_ need help, please email to me at: 204 | 205 | 206 | Enjoy! 207 | 208 | -- Akira KIDA 209 | Sysop for FPL in NIFTY-Serve in JAPAN. 210 | (FPL stands for 'Forum for Program-Language') 211 | 212 | -------------------------------------------------------------------------------- /minischeme/tools.scm: -------------------------------------------------------------------------------- 1 | ;;;; A Very Tiny Pretty Printer (VtPP) for Mini-Scheme 2 | ;;; 3 | ;;; Date written 28-Nov-1989 by Akira Kida 4 | ;;; Date revised 24-Jan-1990 by Atsushi Moriwaki 5 | ;;; Date revised 17-May-1994 by Akira Kida 6 | ;;; 7 | 8 | ;; Columns of display device. 9 | (define *pp-display-width* 80) 10 | 11 | ;; Margin of display-width 12 | ;; 8 means 80% of *pp-display-width*, i.e., if *pp-display-width* is 13 | ;; set to 80, the result is 64. The prety-print procedure will watch 14 | ;; for the current output column, and if the output seem to exceed 15 | ;; this limit, it tries to insert newlines somewhere in the current 16 | ;; sub-list. However, sometimes this may fail, and output may get even 17 | ;; longer than *pp-display-width*. This is a feature, not a bug. :-) 18 | (define *pp-display-margin* 8) 19 | 20 | ;; Number of elements will possibly be displayed in one line. 21 | ;; pretty-print will never display more then this number of elements 22 | ;; on a single physical line. There is no feature around this. :-) 23 | (define *pp-display-elements* 12) 24 | 25 | 26 | ;;; print n spaces 27 | (define (spaces n) 28 | (if (positive? n) 29 | (begin 30 | (display " ") 31 | (spaces (- n 1))))) 32 | 33 | 34 | ;;; get definition of a procedure or a macro 35 | (define (getd symbol) 36 | (if (not (symbol? symbol)) 37 | (error "getd: expects symbol value")) 38 | (let ((code (eval symbol))) 39 | (cond 40 | ;; since a closure is also a macro, we should check macro first. 41 | ((macro? code) 42 | (let ((def (get-closure-code code))) 43 | (cons 'macro (list symbol def)))) 44 | ((closure? code) 45 | (let ((def (get-closure-code code))) 46 | (cons 47 | 'define 48 | (cons 49 | (cons symbol (car (cdr def))) 50 | (cdr (cdr def)))))) 51 | (else 52 | ;; if symbol is not a macro nor closure, 53 | ;; we shall generate error function call code. 54 | (list 'error "Not a S-Expression procedure:" (list 'quote symbol)))))) 55 | 56 | 57 | ;;; pretty printer main procedure 58 | ;;; 59 | (define (pretty-print a-list) 60 | ; List of procedures which need exceptional handling. 61 | ; Structure or each element in the list is 62 | ; 63 | ; (name . special-indentation) 64 | ; 65 | ; where name is a symbol and 66 | ; special-indentation is an integer. 67 | ; 68 | ; #1 Standard format, non special case. 69 | ; (proc 70 | ; arg1 71 | ; arg2 72 | ; arg3) 73 | ; 74 | ; #2 Format for special-indentation == 0 75 | ; (proc arg1 76 | ; arg2 77 | ; arg3) 78 | ; 79 | ; #3 Format for special-indentation == 1 80 | ; (proc arg1 81 | ; arg2 82 | ; arg3) 83 | ; 84 | ; #4 Format for let style = 2 85 | ; (let ((x .....) 86 | ; (y .....)) 87 | ; <....> 88 | ; <....>) 89 | ; 90 | (define exception 91 | '((lambda . 0) (if . 0) (and . 1) 92 | (or . 1) (let . 2) (case . 0) 93 | (define . 0) (macro . 0) 94 | (map . 0) (apply . 0) 95 | (eq? . 1) (eqv? . 1) (set! . 0) 96 | (let* . 2) (letrec . 2) 97 | (* . 1) (/ . 1) (+ . 1) (- . 1) 98 | (= . 1) (< . 1) (> . 1) (<= . 1) (>= . 1) 99 | (do . 2) 100 | (call-with-input-file . 0) (call-with-output-file . 0))) 101 | ; special quote abbrev. 102 | (define special 103 | '((quote 1 . "'") (quasiquote 1 . "`") 104 | (unquote 2 . ",") (unquote-splicing 2 . ",@"))) 105 | ; calculate appropriate margins 106 | (define pp-margin (/ (* *pp-display-width* *pp-display-margin*) 10)) 107 | ; check whether the number of elements exceeds n or not. 108 | (define (less-than-n-elements? a-list n) 109 | ; count elements in a-list at most (n+1) 110 | (define (up-to-nth a-list n c) 111 | (cond 112 | ((null? a-list) c) 113 | ((pair? a-list) 114 | (set! c (up-to-nth (car a-list) n c)) 115 | (if (< n c) 116 | c 117 | (up-to-nth (cdr a-list) n c))) 118 | (else (+ c 1)))) 119 | (< (up-to-nth a-list n 0) n)) 120 | ; check if the length is fit within n columns or not. 121 | (define (fit-in-n-width? a-list n) 122 | (< (print-width a-list) n)) 123 | ; indent and pretty-print 124 | (define (do-pp a-list col) 125 | (spaces col) 126 | (pp-list a-list col 2)) 127 | ;; main logic. 128 | (define (pp-list a-list col step) 129 | (cond 130 | ((atom? a-list) (write a-list)) ; atom 131 | ((and (assq (car a-list) special) 132 | (pair? (cdr a-list)) 133 | (null? (cddr a-list))) ; check for proper quote etc. 134 | (let ((s (assq (car a-list) special))) 135 | (display (cddr s)) ; display using abbrev. 136 | (pp-list 137 | (cadr a-list) 138 | (+ col (- (print-width (cddr s)) 2)) 139 | (cadr s)))) 140 | ((and (less-than-n-elements? a-list *pp-display-elements*) 141 | (fit-in-n-width? a-list (- pp-margin col))) 142 | (display "(") 143 | (do-pp (car a-list) 0) 144 | (pp-args #f (cdr a-list) 1)) 145 | (else ; long list. 146 | (let* ((sym (car a-list)) 147 | (ex-col (assq sym exception))) 148 | (if (pair? ex-col) ; check for exception., 149 | (case (cdr ex-col) 150 | ((0 1) 151 | (display "(") 152 | (write sym) 153 | (display " ") 154 | (pp-list (cadr a-list) (+ col 2 (print-width sym)) 2) 155 | (pp-args 156 | #t 157 | (cdr (cdr a-list)) 158 | (+ col 2 (if (zero? (cdr ex-col)) 0 (print-width sym))))) 159 | ((2) 160 | (display "(") 161 | (write sym) 162 | (display " ") 163 | (if (symbol? (cadr a-list)) 164 | (begin ; named let 165 | (write (cadr a-list)) 166 | (display " ") 167 | (pp-list 168 | (caddr a-list) 169 | (+ col 3 (print-width sym) (print-width (cadr a-list))) 170 | 1) 171 | (pp-args #t (cdddr a-list) (+ col 2))) 172 | (begin ; usual let 173 | (pp-list (cadr a-list) (+ col 2 (print-width sym)) 1) 174 | (pp-args #t (cddr a-list) (+ col 2))))) 175 | (else 176 | (error "Illegal exception"))) 177 | (begin ; normal case. 178 | (display "(") 179 | (pp-list (car a-list) (+ col 1) 2) 180 | (pp-args #t (cdr a-list) (+ col step)))))))) 181 | ;; display arguments 182 | (define (pp-args nl a-list col) 183 | (cond 184 | ((null? a-list) (display ")")) 185 | ((pair? a-list) 186 | (if nl (newline)) 187 | (do-pp (car a-list) col) 188 | (pp-args nl (cdr a-list) col)) 189 | (else 190 | (display " . ") 191 | (write a-list) 192 | (display ")")))) 193 | ;; 194 | ;; main of pretty-print begins here. 195 | ;; 196 | (do-pp a-list 0) 197 | (newline)) 198 | 199 | 200 | 201 | ;;; pretty print procedure(s)/macro(s). 202 | ;;; (pretty 'a-symbol) ; pretty print a procedure or macro 203 | ;;; (pretty '(sym1 sym2 ...)) ; pretty print procedures and/or macros 204 | (define (pretty symbols) 205 | (if (pair? symbols) 206 | (for-each 207 | (lambda (x) (pretty-print (getd x)) (newline)) 208 | symbols) 209 | (pretty-print (getd symbols)))) 210 | 211 | 212 | 213 | ;;; pretty print user-interface 214 | ;;; 215 | ;;; usage: 216 | ;;; (pp sym1 sym2 ...) ; obtain procedure/macro definitions in sequence 217 | ;;; 218 | ;;; Note: pp never evaluate its argument, so you do not have to specify 219 | ;;; (pp 'proc-name). Use (pp proc-name) instead. 220 | ;;; 221 | (macro pp (lambda (pp-macro) 222 | `(pretty ',(cdr pp-macro)))) 223 | 224 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/scheme.h: -------------------------------------------------------------------------------- 1 | /* SCHEME.H */ 2 | 3 | #ifndef _SCHEME_H 4 | #define _SCHEME_H 5 | 6 | #include 7 | 8 | #ifdef __cplusplus 9 | extern "C" { 10 | #endif 11 | 12 | /* 13 | * Default values for #define'd symbols 14 | */ 15 | #ifndef STANDALONE /* If used as standalone interpreter */ 16 | # define STANDALONE 1 17 | #endif 18 | 19 | # define USE_STRCASECMP 0 20 | # define USE_STRLWR 0 21 | # ifdef _SCHEME_SOURCE 22 | # define SCHEME_EXPORT __declspec(dllexport) 23 | # else 24 | # define SCHEME_EXPORT __declspec(dllimport) 25 | # endif 26 | 27 | #if USE_NO_FEATURES 28 | # define USE_MATH 0 29 | # define USE_CHAR_CLASSIFIERS 0 30 | # define USE_ASCII_NAMES 0 31 | # define USE_STRING_PORTS 0 32 | # define USE_ERROR_HOOK 0 33 | # define USE_TRACING 0 34 | # define USE_COLON_HOOK 0 35 | # define USE_DL 0 36 | # define USE_PLIST 0 37 | #endif 38 | 39 | /* 40 | * Leave it defined if you want continuations, and also for the Sharp Zaurus. 41 | * Undefine it if you only care about faster speed and not strict Scheme compatibility. 42 | */ 43 | #define USE_SCHEME_STACK 44 | 45 | #if USE_DL 46 | # define USE_INTERFACE 1 47 | #endif 48 | 49 | 50 | #ifndef USE_MATH /* If math support is needed */ 51 | # define USE_MATH 1 52 | #endif 53 | 54 | #ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */ 55 | # define USE_CHAR_CLASSIFIERS 1 56 | #endif 57 | 58 | #ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */ 59 | # define USE_ASCII_NAMES 1 60 | #endif 61 | 62 | #ifndef USE_STRING_PORTS /* Enable string ports */ 63 | # define USE_STRING_PORTS 1 64 | #endif 65 | 66 | #ifndef USE_TRACING 67 | # define USE_TRACING 1 68 | #endif 69 | 70 | #ifndef USE_PLIST 71 | # define USE_PLIST 0 72 | #endif 73 | 74 | /* To force system errors through user-defined error handling (see *error-hook*) */ 75 | #ifndef USE_ERROR_HOOK 76 | # define USE_ERROR_HOOK 1 77 | #endif 78 | 79 | #ifndef USE_COLON_HOOK /* Enable qualified qualifier */ 80 | # define USE_COLON_HOOK 1 81 | #endif 82 | 83 | #ifndef USE_STRCASECMP /* stricmp for Unix */ 84 | # define USE_STRCASECMP 0 85 | #endif 86 | 87 | #ifndef USE_STRLWR 88 | # define USE_STRLWR 1 89 | #endif 90 | 91 | #ifndef STDIO_ADDS_CR /* Define if DOS/Windows */ 92 | # define STDIO_ADDS_CR 0 93 | #endif 94 | 95 | #ifndef INLINE 96 | # define INLINE 97 | #endif 98 | 99 | #ifndef USE_INTERFACE 100 | # define USE_INTERFACE 0 101 | #endif 102 | 103 | #ifndef SHOW_ERROR_LINE /* Show error line in file */ 104 | # define SHOW_ERROR_LINE 1 105 | #endif 106 | 107 | typedef struct scheme scheme; 108 | typedef struct cell *pointer; 109 | 110 | typedef void * (*func_alloc)(size_t); 111 | typedef void (*func_dealloc)(void *); 112 | 113 | /* num, for generic arithmetic */ 114 | typedef struct num { 115 | char is_fixnum; 116 | union { 117 | long ivalue; 118 | double rvalue; 119 | } value; 120 | } num; 121 | 122 | SCHEME_EXPORT scheme *scheme_init_new(); 123 | SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free); 124 | SCHEME_EXPORT int scheme_init(scheme *sc); 125 | SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc); 126 | SCHEME_EXPORT void scheme_deinit(scheme *sc); 127 | void scheme_set_input_port_file(scheme *sc, FILE *fin); 128 | void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end); 129 | SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin); 130 | void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); 131 | SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); 132 | SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename); 133 | SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); 134 | SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname); 135 | SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args); 136 | SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj); 137 | void scheme_set_external_data(scheme *sc, void *p); 138 | SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); 139 | 140 | typedef pointer (*foreign_func)(scheme *, pointer); 141 | 142 | pointer _cons(scheme *sc, pointer a, pointer b, int immutable); 143 | pointer mk_integer(scheme *sc, long num); 144 | pointer mk_real(scheme *sc, double num); 145 | pointer mk_symbol(scheme *sc, const char *name); 146 | pointer gensym(scheme *sc); 147 | pointer mk_string(scheme *sc, const char *str); 148 | pointer mk_counted_string(scheme *sc, const char *str, int len); 149 | pointer mk_empty_string(scheme *sc, int len, char fill); 150 | pointer mk_character(scheme *sc, int c); 151 | pointer mk_foreign_func(scheme *sc, foreign_func f); 152 | void putstr(scheme *sc, const char *s); 153 | int list_length(scheme *sc, pointer a); 154 | int eqv(pointer a, pointer b); 155 | 156 | 157 | #if USE_INTERFACE 158 | struct scheme_interface { 159 | void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value); 160 | pointer (*cons)(scheme *sc, pointer a, pointer b); 161 | pointer (*immutable_cons)(scheme *sc, pointer a, pointer b); 162 | pointer (*reserve_cells)(scheme *sc, int n); 163 | pointer (*mk_integer)(scheme *sc, long num); 164 | pointer (*mk_real)(scheme *sc, double num); 165 | pointer (*mk_symbol)(scheme *sc, const char *name); 166 | pointer (*gensym)(scheme *sc); 167 | pointer (*mk_string)(scheme *sc, const char *str); 168 | pointer (*mk_counted_string)(scheme *sc, const char *str, int len); 169 | pointer (*mk_character)(scheme *sc, int c); 170 | pointer (*mk_vector)(scheme *sc, int len); 171 | pointer (*mk_foreign_func)(scheme *sc, foreign_func f); 172 | void (*putstr)(scheme *sc, const char *s); 173 | void (*putcharacter)(scheme *sc, int c); 174 | 175 | int (*is_string)(pointer p); 176 | char *(*string_value)(pointer p); 177 | int (*is_number)(pointer p); 178 | num (*nvalue)(pointer p); 179 | long (*ivalue)(pointer p); 180 | double (*rvalue)(pointer p); 181 | int (*is_integer)(pointer p); 182 | int (*is_real)(pointer p); 183 | int (*is_character)(pointer p); 184 | long (*charvalue)(pointer p); 185 | int (*is_list)(scheme *sc, pointer p); 186 | int (*is_vector)(pointer p); 187 | int (*list_length)(scheme *sc, pointer vec); 188 | long (*vector_length)(pointer vec); 189 | void (*fill_vector)(pointer vec, pointer elem); 190 | pointer (*vector_elem)(pointer vec, int ielem); 191 | pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel); 192 | int (*is_port)(pointer p); 193 | 194 | int (*is_pair)(pointer p); 195 | pointer (*pair_car)(pointer p); 196 | pointer (*pair_cdr)(pointer p); 197 | pointer (*set_car)(pointer p, pointer q); 198 | pointer (*set_cdr)(pointer p, pointer q); 199 | 200 | int (*is_symbol)(pointer p); 201 | char *(*symname)(pointer p); 202 | 203 | int (*is_syntax)(pointer p); 204 | int (*is_proc)(pointer p); 205 | int (*is_foreign)(pointer p); 206 | char *(*syntaxname)(pointer p); 207 | int (*is_closure)(pointer p); 208 | int (*is_macro)(pointer p); 209 | pointer (*closure_code)(pointer p); 210 | pointer (*closure_env)(pointer p); 211 | 212 | int (*is_continuation)(pointer p); 213 | int (*is_promise)(pointer p); 214 | int (*is_environment)(pointer p); 215 | int (*is_immutable)(pointer p); 216 | void (*setimmutable)(pointer p); 217 | void (*load_file)(scheme *sc, FILE *fin); 218 | void (*load_string)(scheme *sc, const char *input); 219 | }; 220 | #endif 221 | 222 | #if !STANDALONE 223 | typedef struct scheme_registerable 224 | { 225 | foreign_func f; 226 | char * name; 227 | } 228 | scheme_registerable; 229 | 230 | void scheme_register_foreign_func_list(scheme * sc, 231 | scheme_registerable * list, 232 | int n); 233 | 234 | #endif /* !STANDALONE */ 235 | 236 | #ifdef __cplusplus 237 | } 238 | #endif 239 | 240 | #endif 241 | 242 | 243 | /* 244 | Local variables: 245 | c-file-style: "k&r" 246 | End: 247 | */ 248 | -------------------------------------------------------------------------------- /tinyscheme-1.40/scheme.h: -------------------------------------------------------------------------------- 1 | /* SCHEME.H */ 2 | 3 | #ifndef _SCHEME_H 4 | #define _SCHEME_H 5 | 6 | #include 7 | 8 | #ifdef __cplusplus 9 | extern "C" { 10 | #endif 11 | 12 | /* 13 | * Default values for #define'd symbols 14 | */ 15 | #ifndef STANDALONE /* If used as standalone interpreter */ 16 | # define STANDALONE 1 17 | #endif 18 | 19 | #ifndef _MSC_VER 20 | # define USE_STRCASECMP 1 21 | # ifndef USE_STRLWR 22 | # define USE_STRLWR 1 23 | # endif 24 | # define SCHEME_EXPORT 25 | #else 26 | # define USE_STRCASECMP 0 27 | # define USE_STRLWR 0 28 | # ifdef _SCHEME_SOURCE 29 | # define SCHEME_EXPORT __declspec(dllexport) 30 | # else 31 | # define SCHEME_EXPORT __declspec(dllimport) 32 | # endif 33 | #endif 34 | 35 | #if USE_NO_FEATURES 36 | # define USE_MATH 0 37 | # define USE_CHAR_CLASSIFIERS 0 38 | # define USE_ASCII_NAMES 0 39 | # define USE_STRING_PORTS 0 40 | # define USE_ERROR_HOOK 0 41 | # define USE_TRACING 0 42 | # define USE_COLON_HOOK 0 43 | # define USE_DL 0 44 | # define USE_PLIST 0 45 | #endif 46 | 47 | /* 48 | * Leave it defined if you want continuations, and also for the Sharp Zaurus. 49 | * Undefine it if you only care about faster speed and not strict Scheme compatibility. 50 | */ 51 | #define USE_SCHEME_STACK 52 | 53 | #if USE_DL 54 | # define USE_INTERFACE 1 55 | #endif 56 | 57 | 58 | #ifndef USE_MATH /* If math support is needed */ 59 | # define USE_MATH 1 60 | #endif 61 | 62 | #ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */ 63 | # define USE_CHAR_CLASSIFIERS 1 64 | #endif 65 | 66 | #ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */ 67 | # define USE_ASCII_NAMES 1 68 | #endif 69 | 70 | #ifndef USE_STRING_PORTS /* Enable string ports */ 71 | # define USE_STRING_PORTS 1 72 | #endif 73 | 74 | #ifndef USE_TRACING 75 | # define USE_TRACING 1 76 | #endif 77 | 78 | #ifndef USE_PLIST 79 | # define USE_PLIST 0 80 | #endif 81 | 82 | /* To force system errors through user-defined error handling (see *error-hook*) */ 83 | #ifndef USE_ERROR_HOOK 84 | # define USE_ERROR_HOOK 1 85 | #endif 86 | 87 | #ifndef USE_COLON_HOOK /* Enable qualified qualifier */ 88 | # define USE_COLON_HOOK 1 89 | #endif 90 | 91 | #ifndef USE_STRCASECMP /* stricmp for Unix */ 92 | # define USE_STRCASECMP 0 93 | #endif 94 | 95 | #ifndef USE_STRLWR 96 | # define USE_STRLWR 1 97 | #endif 98 | 99 | #ifndef STDIO_ADDS_CR /* Define if DOS/Windows */ 100 | # define STDIO_ADDS_CR 0 101 | #endif 102 | 103 | #ifndef INLINE 104 | # define INLINE 105 | #endif 106 | 107 | #ifndef USE_INTERFACE 108 | # define USE_INTERFACE 0 109 | #endif 110 | 111 | #ifndef SHOW_ERROR_LINE /* Show error line in file */ 112 | # define SHOW_ERROR_LINE 1 113 | #endif 114 | 115 | typedef struct scheme scheme; 116 | typedef struct cell *pointer; 117 | 118 | typedef void * (*func_alloc)(size_t); 119 | typedef void (*func_dealloc)(void *); 120 | 121 | /* num, for generic arithmetic */ 122 | typedef struct num { 123 | char is_fixnum; 124 | union { 125 | long ivalue; 126 | double rvalue; 127 | } value; 128 | } num; 129 | 130 | SCHEME_EXPORT scheme *scheme_init_new(); 131 | SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free); 132 | SCHEME_EXPORT int scheme_init(scheme *sc); 133 | SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc); 134 | SCHEME_EXPORT void scheme_deinit(scheme *sc); 135 | void scheme_set_input_port_file(scheme *sc, FILE *fin); 136 | void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end); 137 | SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin); 138 | void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); 139 | SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); 140 | SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename); 141 | SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); 142 | SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname); 143 | SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args); 144 | SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj); 145 | void scheme_set_external_data(scheme *sc, void *p); 146 | SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); 147 | 148 | typedef pointer (*foreign_func)(scheme *, pointer); 149 | 150 | pointer _cons(scheme *sc, pointer a, pointer b, int immutable); 151 | pointer mk_integer(scheme *sc, long num); 152 | pointer mk_real(scheme *sc, double num); 153 | pointer mk_symbol(scheme *sc, const char *name); 154 | pointer gensym(scheme *sc); 155 | pointer mk_string(scheme *sc, const char *str); 156 | pointer mk_counted_string(scheme *sc, const char *str, int len); 157 | pointer mk_empty_string(scheme *sc, int len, char fill); 158 | pointer mk_character(scheme *sc, int c); 159 | pointer mk_foreign_func(scheme *sc, foreign_func f); 160 | void putstr(scheme *sc, const char *s); 161 | int list_length(scheme *sc, pointer a); 162 | int eqv(pointer a, pointer b); 163 | 164 | 165 | #if USE_INTERFACE 166 | struct scheme_interface { 167 | void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value); 168 | pointer (*cons)(scheme *sc, pointer a, pointer b); 169 | pointer (*immutable_cons)(scheme *sc, pointer a, pointer b); 170 | pointer (*reserve_cells)(scheme *sc, int n); 171 | pointer (*mk_integer)(scheme *sc, long num); 172 | pointer (*mk_real)(scheme *sc, double num); 173 | pointer (*mk_symbol)(scheme *sc, const char *name); 174 | pointer (*gensym)(scheme *sc); 175 | pointer (*mk_string)(scheme *sc, const char *str); 176 | pointer (*mk_counted_string)(scheme *sc, const char *str, int len); 177 | pointer (*mk_character)(scheme *sc, int c); 178 | pointer (*mk_vector)(scheme *sc, int len); 179 | pointer (*mk_foreign_func)(scheme *sc, foreign_func f); 180 | void (*putstr)(scheme *sc, const char *s); 181 | void (*putcharacter)(scheme *sc, int c); 182 | 183 | int (*is_string)(pointer p); 184 | char *(*string_value)(pointer p); 185 | int (*is_number)(pointer p); 186 | num (*nvalue)(pointer p); 187 | long (*ivalue)(pointer p); 188 | double (*rvalue)(pointer p); 189 | int (*is_integer)(pointer p); 190 | int (*is_real)(pointer p); 191 | int (*is_character)(pointer p); 192 | long (*charvalue)(pointer p); 193 | int (*is_list)(scheme *sc, pointer p); 194 | int (*is_vector)(pointer p); 195 | int (*list_length)(scheme *sc, pointer vec); 196 | long (*vector_length)(pointer vec); 197 | void (*fill_vector)(pointer vec, pointer elem); 198 | pointer (*vector_elem)(pointer vec, int ielem); 199 | pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel); 200 | int (*is_port)(pointer p); 201 | 202 | int (*is_pair)(pointer p); 203 | pointer (*pair_car)(pointer p); 204 | pointer (*pair_cdr)(pointer p); 205 | pointer (*set_car)(pointer p, pointer q); 206 | pointer (*set_cdr)(pointer p, pointer q); 207 | 208 | int (*is_symbol)(pointer p); 209 | char *(*symname)(pointer p); 210 | 211 | int (*is_syntax)(pointer p); 212 | int (*is_proc)(pointer p); 213 | int (*is_foreign)(pointer p); 214 | char *(*syntaxname)(pointer p); 215 | int (*is_closure)(pointer p); 216 | int (*is_macro)(pointer p); 217 | pointer (*closure_code)(pointer p); 218 | pointer (*closure_env)(pointer p); 219 | 220 | int (*is_continuation)(pointer p); 221 | int (*is_promise)(pointer p); 222 | int (*is_environment)(pointer p); 223 | int (*is_immutable)(pointer p); 224 | void (*setimmutable)(pointer p); 225 | void (*load_file)(scheme *sc, FILE *fin); 226 | void (*load_string)(scheme *sc, const char *input); 227 | }; 228 | #endif 229 | 230 | #if !STANDALONE 231 | typedef struct scheme_registerable 232 | { 233 | foreign_func f; 234 | char * name; 235 | } 236 | scheme_registerable; 237 | 238 | void scheme_register_foreign_func_list(scheme * sc, 239 | scheme_registerable * list, 240 | int n); 241 | 242 | #endif /* !STANDALONE */ 243 | 244 | #ifdef __cplusplus 245 | } 246 | #endif 247 | 248 | #endif 249 | 250 | 251 | /* 252 | Local variables: 253 | c-file-style: "k&r" 254 | End: 255 | */ 256 | -------------------------------------------------------------------------------- /re/debug.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include "utils.h" 4 | #include "regex2.h" 5 | #include "debug.ih" 6 | 7 | /* 8 | - regprint - print a regexp for debugging 9 | == void regprint(regex_t *r, FILE *d); 10 | */ 11 | void 12 | regprint(r, d) 13 | regex_t *r; 14 | FILE *d; 15 | { 16 | register struct re_guts *g = r->re_g; 17 | register int i; 18 | register int c; 19 | register int last; 20 | int nincat[NC]; 21 | 22 | fprintf(d, "%ld states, %d categories", (long)g->nstates, 23 | g->ncategories); 24 | fprintf(d, ", first %ld last %ld", (long)g->firststate, 25 | (long)g->laststate); 26 | if (g->iflags&USEBOL) 27 | fprintf(d, ", USEBOL"); 28 | if (g->iflags&USEEOL) 29 | fprintf(d, ", USEEOL"); 30 | if (g->iflags&BAD) 31 | fprintf(d, ", BAD"); 32 | if (g->nsub > 0) 33 | fprintf(d, ", nsub=%ld", (long)g->nsub); 34 | if (g->must != NULL) 35 | fprintf(d, ", must(%ld) `%*s'", (long)g->mlen, (int)g->mlen, 36 | g->must); 37 | if (g->backrefs) 38 | fprintf(d, ", backrefs"); 39 | if (g->nplus > 0) 40 | fprintf(d, ", nplus %ld", (long)g->nplus); 41 | fprintf(d, "\n"); 42 | s_print(g, d); 43 | for (i = 0; i < g->ncategories; i++) { 44 | nincat[i] = 0; 45 | for (c = CHAR_MIN; c <= CHAR_MAX; c++) 46 | if (g->categories[c] == i) 47 | nincat[i]++; 48 | } 49 | fprintf(d, "cc0#%d", nincat[0]); 50 | for (i = 1; i < g->ncategories; i++) 51 | if (nincat[i] == 1) { 52 | for (c = CHAR_MIN; c <= CHAR_MAX; c++) 53 | if (g->categories[c] == i) 54 | break; 55 | fprintf(d, ", %d=%s", i, regchar(c)); 56 | } 57 | fprintf(d, "\n"); 58 | for (i = 1; i < g->ncategories; i++) 59 | if (nincat[i] != 1) { 60 | fprintf(d, "cc%d\t", i); 61 | last = -1; 62 | for (c = CHAR_MIN; c <= CHAR_MAX+1; c++) /* +1 does flush */ 63 | if (c <= CHAR_MAX && g->categories[c] == i) { 64 | if (last < 0) { 65 | fprintf(d, "%s", regchar(c)); 66 | last = c; 67 | } 68 | } else { 69 | if (last >= 0) { 70 | if (last != c-1) 71 | fprintf(d, "-%s", 72 | regchar(c-1)); 73 | last = -1; 74 | } 75 | } 76 | fprintf(d, "\n"); 77 | } 78 | } 79 | 80 | /* 81 | - s_print - print the strip for debugging 82 | == static void s_print(register struct re_guts *g, FILE *d); 83 | */ 84 | static void 85 | s_print(g, d) 86 | register struct re_guts *g; 87 | FILE *d; 88 | { 89 | register sop *s; 90 | register cset *cs; 91 | register int i; 92 | register int done = 0; 93 | register sop opnd; 94 | register int col = 0; 95 | register int last; 96 | register sopno offset = 2; 97 | # define GAP() { if (offset % 5 == 0) { \ 98 | if (col > 40) { \ 99 | fprintf(d, "\n\t"); \ 100 | col = 0; \ 101 | } else { \ 102 | fprintf(d, " "); \ 103 | col++; \ 104 | } \ 105 | } else \ 106 | col++; \ 107 | offset++; \ 108 | } 109 | 110 | if (OP(g->strip[0]) != OEND) 111 | fprintf(d, "missing initial OEND!\n"); 112 | for (s = &g->strip[1]; !done; s++) { 113 | opnd = OPND(*s); 114 | switch (OP(*s)) { 115 | case OEND: 116 | fprintf(d, "\n"); 117 | done = 1; 118 | break; 119 | case OCHAR: 120 | if (strchr("\\|()^$.[+*?{}!<> ", (char)opnd) != NULL) 121 | fprintf(d, "\\%c", (char)opnd); 122 | else 123 | fprintf(d, "%s", regchar((char)opnd)); 124 | break; 125 | case OBOL: 126 | fprintf(d, "^"); 127 | break; 128 | case OEOL: 129 | fprintf(d, "$"); 130 | break; 131 | case OBOW: 132 | fprintf(d, "\\{"); 133 | break; 134 | case OEOW: 135 | fprintf(d, "\\}"); 136 | break; 137 | case OANY: 138 | fprintf(d, "."); 139 | break; 140 | case OANYOF: 141 | fprintf(d, "[(%ld)", (long)opnd); 142 | cs = &g->sets[opnd]; 143 | last = -1; 144 | for (i = 0; i < g->csetsize+1; i++) /* +1 flushes */ 145 | if (CHIN(cs, i) && i < g->csetsize) { 146 | if (last < 0) { 147 | fprintf(d, "%s", regchar(i)); 148 | last = i; 149 | } 150 | } else { 151 | if (last >= 0) { 152 | if (last != i-1) 153 | fprintf(d, "-%s", 154 | regchar(i-1)); 155 | last = -1; 156 | } 157 | } 158 | fprintf(d, "]"); 159 | break; 160 | case OBACK_: 161 | fprintf(d, "(\\<%ld>", (long)opnd); 162 | break; 163 | case O_BACK: 164 | fprintf(d, "<%ld>\\)", (long)opnd); 165 | break; 166 | case OPLUS_: 167 | fprintf(d, "(+"); 168 | if (OP(*(s+opnd)) != O_PLUS) 169 | fprintf(d, "<%ld>", (long)opnd); 170 | break; 171 | case O_PLUS: 172 | if (OP(*(s-opnd)) != OPLUS_) 173 | fprintf(d, "<%ld>", (long)opnd); 174 | fprintf(d, "+)"); 175 | break; 176 | case OQUEST_: 177 | fprintf(d, "(?"); 178 | if (OP(*(s+opnd)) != O_QUEST) 179 | fprintf(d, "<%ld>", (long)opnd); 180 | break; 181 | case O_QUEST: 182 | if (OP(*(s-opnd)) != OQUEST_) 183 | fprintf(d, "<%ld>", (long)opnd); 184 | fprintf(d, "?)"); 185 | break; 186 | case OLPAREN: 187 | fprintf(d, "((<%ld>", (long)opnd); 188 | break; 189 | case ORPAREN: 190 | fprintf(d, "<%ld>))", (long)opnd); 191 | break; 192 | case OCH_: 193 | fprintf(d, "<"); 194 | if (OP(*(s+opnd)) != OOR2) 195 | fprintf(d, "<%ld>", (long)opnd); 196 | break; 197 | case OOR1: 198 | if (OP(*(s-opnd)) != OOR1 && OP(*(s-opnd)) != OCH_) 199 | fprintf(d, "<%ld>", (long)opnd); 200 | fprintf(d, "|"); 201 | break; 202 | case OOR2: 203 | fprintf(d, "|"); 204 | if (OP(*(s+opnd)) != OOR2 && OP(*(s+opnd)) != O_CH) 205 | fprintf(d, "<%ld>", (long)opnd); 206 | break; 207 | case O_CH: 208 | if (OP(*(s-opnd)) != OOR1) 209 | fprintf(d, "<%ld>", (long)opnd); 210 | fprintf(d, ">"); 211 | break; 212 | default: 213 | fprintf(d, "!%ld(%ld)!", OP(*s), opnd); 214 | break; 215 | } 216 | if (!done) 217 | GAP(); 218 | } 219 | } 220 | 221 | /* 222 | - regchar - make a character printable 223 | == static char *regchar(int ch); 224 | */ 225 | static char * /* -> representation */ 226 | regchar(ch) 227 | int ch; 228 | { 229 | static char buf[10]; 230 | 231 | if (isprint(ch) || ch == ' ') 232 | sprintf(buf, "%c", ch); 233 | else 234 | sprintf(buf, "\\%o", ch); 235 | return(buf); 236 | } 237 | -------------------------------------------------------------------------------- /re/split.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | /* 5 | - split - divide a string into fields, like awk split() 6 | = int split(char *string, char *fields[], int nfields, char *sep); 7 | */ 8 | int /* number of fields, including overflow */ 9 | split(string, fields, nfields, sep) 10 | char *string; 11 | char *fields[]; /* list is not NULL-terminated */ 12 | int nfields; /* number of entries available in fields[] */ 13 | char *sep; /* "" white, "c" single char, "ab" [ab]+ */ 14 | { 15 | register char *p = string; 16 | register char c; /* latest character */ 17 | register char sepc = sep[0]; 18 | register char sepc2; 19 | register int fn; 20 | register char **fp = fields; 21 | register char *sepp; 22 | register int trimtrail; 23 | 24 | /* white space */ 25 | if (sepc == '\0') { 26 | while ((c = *p++) == ' ' || c == '\t') 27 | continue; 28 | p--; 29 | trimtrail = 1; 30 | sep = " \t"; /* note, code below knows this is 2 long */ 31 | sepc = ' '; 32 | } else 33 | trimtrail = 0; 34 | sepc2 = sep[1]; /* now we can safely pick this up */ 35 | 36 | /* catch empties */ 37 | if (*p == '\0') 38 | return(0); 39 | 40 | /* single separator */ 41 | if (sepc2 == '\0') { 42 | fn = nfields; 43 | for (;;) { 44 | *fp++ = p; 45 | fn--; 46 | if (fn == 0) 47 | break; 48 | while ((c = *p++) != sepc) 49 | if (c == '\0') 50 | return(nfields - fn); 51 | *(p-1) = '\0'; 52 | } 53 | /* we have overflowed the fields vector -- just count them */ 54 | fn = nfields; 55 | for (;;) { 56 | while ((c = *p++) != sepc) 57 | if (c == '\0') 58 | return(fn); 59 | fn++; 60 | } 61 | /* not reached */ 62 | } 63 | 64 | /* two separators */ 65 | if (sep[2] == '\0') { 66 | fn = nfields; 67 | for (;;) { 68 | *fp++ = p; 69 | fn--; 70 | while ((c = *p++) != sepc && c != sepc2) 71 | if (c == '\0') { 72 | if (trimtrail && **(fp-1) == '\0') 73 | fn++; 74 | return(nfields - fn); 75 | } 76 | if (fn == 0) 77 | break; 78 | *(p-1) = '\0'; 79 | while ((c = *p++) == sepc || c == sepc2) 80 | continue; 81 | p--; 82 | } 83 | /* we have overflowed the fields vector -- just count them */ 84 | fn = nfields; 85 | while (c != '\0') { 86 | while ((c = *p++) == sepc || c == sepc2) 87 | continue; 88 | p--; 89 | fn++; 90 | while ((c = *p++) != '\0' && c != sepc && c != sepc2) 91 | continue; 92 | } 93 | /* might have to trim trailing white space */ 94 | if (trimtrail) { 95 | p--; 96 | while ((c = *--p) == sepc || c == sepc2) 97 | continue; 98 | p++; 99 | if (*p != '\0') { 100 | if (fn == nfields+1) 101 | *p = '\0'; 102 | fn--; 103 | } 104 | } 105 | return(fn); 106 | } 107 | 108 | /* n separators */ 109 | fn = 0; 110 | for (;;) { 111 | if (fn < nfields) 112 | *fp++ = p; 113 | fn++; 114 | for (;;) { 115 | c = *p++; 116 | if (c == '\0') 117 | return(fn); 118 | sepp = sep; 119 | while ((sepc = *sepp++) != '\0' && sepc != c) 120 | continue; 121 | if (sepc != '\0') /* it was a separator */ 122 | break; 123 | } 124 | if (fn < nfields) 125 | *(p-1) = '\0'; 126 | for (;;) { 127 | c = *p++; 128 | sepp = sep; 129 | while ((sepc = *sepp++) != '\0' && sepc != c) 130 | continue; 131 | if (sepc == '\0') /* it wasn't a separator */ 132 | break; 133 | } 134 | p--; 135 | } 136 | 137 | /* not reached */ 138 | } 139 | 140 | #ifdef TEST_SPLIT 141 | 142 | 143 | /* 144 | * test program 145 | * pgm runs regression 146 | * pgm sep splits stdin lines by sep 147 | * pgm str sep splits str by sep 148 | * pgm str sep n splits str by sep n times 149 | */ 150 | int 151 | main(argc, argv) 152 | int argc; 153 | char *argv[]; 154 | { 155 | char buf[512]; 156 | register int n; 157 | # define MNF 10 158 | char *fields[MNF]; 159 | 160 | if (argc > 4) 161 | for (n = atoi(argv[3]); n > 0; n--) { 162 | (void) strcpy(buf, argv[1]); 163 | } 164 | else if (argc > 3) 165 | for (n = atoi(argv[3]); n > 0; n--) { 166 | (void) strcpy(buf, argv[1]); 167 | (void) split(buf, fields, MNF, argv[2]); 168 | } 169 | else if (argc > 2) 170 | dosplit(argv[1], argv[2]); 171 | else if (argc > 1) 172 | while (fgets(buf, sizeof(buf), stdin) != NULL) { 173 | buf[strlen(buf)-1] = '\0'; /* stomp newline */ 174 | dosplit(buf, argv[1]); 175 | } 176 | else 177 | regress(); 178 | 179 | exit(0); 180 | } 181 | 182 | dosplit(string, seps) 183 | char *string; 184 | char *seps; 185 | { 186 | # define NF 5 187 | char *fields[NF]; 188 | register int nf; 189 | 190 | nf = split(string, fields, NF, seps); 191 | print(nf, NF, fields); 192 | } 193 | 194 | print(nf, nfp, fields) 195 | int nf; 196 | int nfp; 197 | char *fields[]; 198 | { 199 | register int fn; 200 | register int bound; 201 | 202 | bound = (nf > nfp) ? nfp : nf; 203 | printf("%d:\t", nf); 204 | for (fn = 0; fn < bound; fn++) 205 | printf("\"%s\"%s", fields[fn], (fn+1 < nf) ? ", " : "\n"); 206 | } 207 | 208 | #define RNF 5 /* some table entries know this */ 209 | struct { 210 | char *str; 211 | char *seps; 212 | int nf; 213 | char *fi[RNF]; 214 | } tests[] = { 215 | "", " ", 0, { "" }, 216 | " ", " ", 2, { "", "" }, 217 | "x", " ", 1, { "x" }, 218 | "xy", " ", 1, { "xy" }, 219 | "x y", " ", 2, { "x", "y" }, 220 | "abc def g ", " ", 5, { "abc", "def", "", "g", "" }, 221 | " a bcd", " ", 4, { "", "", "a", "bcd" }, 222 | "a b c d e f", " ", 6, { "a", "b", "c", "d", "e f" }, 223 | " a b c d ", " ", 6, { "", "a", "b", "c", "d " }, 224 | 225 | "", " _", 0, { "" }, 226 | " ", " _", 2, { "", "" }, 227 | "x", " _", 1, { "x" }, 228 | "x y", " _", 2, { "x", "y" }, 229 | "ab _ cd", " _", 2, { "ab", "cd" }, 230 | " a_b c ", " _", 5, { "", "a", "b", "c", "" }, 231 | "a b c_d e f", " _", 6, { "a", "b", "c", "d", "e f" }, 232 | " a b c d ", " _", 6, { "", "a", "b", "c", "d " }, 233 | 234 | "", " _~", 0, { "" }, 235 | " ", " _~", 2, { "", "" }, 236 | "x", " _~", 1, { "x" }, 237 | "x y", " _~", 2, { "x", "y" }, 238 | "ab _~ cd", " _~", 2, { "ab", "cd" }, 239 | " a_b c~", " _~", 5, { "", "a", "b", "c", "" }, 240 | "a b_c d~e f", " _~", 6, { "a", "b", "c", "d", "e f" }, 241 | "~a b c d ", " _~", 6, { "", "a", "b", "c", "d " }, 242 | 243 | "", " _~-", 0, { "" }, 244 | " ", " _~-", 2, { "", "" }, 245 | "x", " _~-", 1, { "x" }, 246 | "x y", " _~-", 2, { "x", "y" }, 247 | "ab _~- cd", " _~-", 2, { "ab", "cd" }, 248 | " a_b c~", " _~-", 5, { "", "a", "b", "c", "" }, 249 | "a b_c-d~e f", " _~-", 6, { "a", "b", "c", "d", "e f" }, 250 | "~a-b c d ", " _~-", 6, { "", "a", "b", "c", "d " }, 251 | 252 | "", " ", 0, { "" }, 253 | " ", " ", 2, { "", "" }, 254 | "x", " ", 1, { "x" }, 255 | "xy", " ", 1, { "xy" }, 256 | "x y", " ", 2, { "x", "y" }, 257 | "abc def g ", " ", 4, { "abc", "def", "g", "" }, 258 | " a bcd", " ", 3, { "", "a", "bcd" }, 259 | "a b c d e f", " ", 6, { "a", "b", "c", "d", "e f" }, 260 | " a b c d ", " ", 6, { "", "a", "b", "c", "d " }, 261 | 262 | "", "", 0, { "" }, 263 | " ", "", 0, { "" }, 264 | "x", "", 1, { "x" }, 265 | "xy", "", 1, { "xy" }, 266 | "x y", "", 2, { "x", "y" }, 267 | "abc def g ", "", 3, { "abc", "def", "g" }, 268 | "\t a bcd", "", 2, { "a", "bcd" }, 269 | " a \tb\t c ", "", 3, { "a", "b", "c" }, 270 | "a b c d e ", "", 5, { "a", "b", "c", "d", "e" }, 271 | "a b\tc d e f", "", 6, { "a", "b", "c", "d", "e f" }, 272 | " a b c d e f ", "", 6, { "a", "b", "c", "d", "e f " }, 273 | 274 | NULL, NULL, 0, { NULL }, 275 | }; 276 | 277 | regress() 278 | { 279 | char buf[512]; 280 | register int n; 281 | char *fields[RNF+1]; 282 | register int nf; 283 | register int i; 284 | register int printit; 285 | register char *f; 286 | 287 | for (n = 0; tests[n].str != NULL; n++) { 288 | (void) strcpy(buf, tests[n].str); 289 | fields[RNF] = NULL; 290 | nf = split(buf, fields, RNF, tests[n].seps); 291 | printit = 0; 292 | if (nf != tests[n].nf) { 293 | printf("split `%s' by `%s' gave %d fields, not %d\n", 294 | tests[n].str, tests[n].seps, nf, tests[n].nf); 295 | printit = 1; 296 | } else if (fields[RNF] != NULL) { 297 | printf("split() went beyond array end\n"); 298 | printit = 1; 299 | } else { 300 | for (i = 0; i < nf && i < RNF; i++) { 301 | f = fields[i]; 302 | if (f == NULL) 303 | f = "(NULL)"; 304 | if (strcmp(f, tests[n].fi[i]) != 0) { 305 | printf("split `%s' by `%s', field %d is `%s', not `%s'\n", 306 | tests[n].str, tests[n].seps, 307 | i, fields[i], tests[n].fi[i]); 308 | printit = 1; 309 | } 310 | } 311 | } 312 | if (printit) 313 | print(nf, RNF, fields); 314 | } 315 | } 316 | #endif 317 | -------------------------------------------------------------------------------- /tinyscheme-1.40/hack.txt: -------------------------------------------------------------------------------- 1 | 2 | How to hack TinyScheme 3 | ---------------------- 4 | 5 | TinyScheme is easy to learn and modify. It is structured like a 6 | meta-interpreter, only it is written in C. All data are Scheme 7 | objects, which facilitates both understanding/modifying the 8 | code and reifying the interpreter workings. 9 | 10 | In place of a dry description, we will pace through the addition 11 | of a useful new datatype: garbage-collected memory blocks. 12 | The interface will be: 13 | 14 | (make-block []) makes a new block of the specified size 15 | optionally filling it with a specified byte 16 | (block? ) 17 | (block-length ) 18 | (block-ref ) retrieves byte at location 19 | (block-set! ) modifies byte at location 20 | 21 | In the sequel, lines that begin with '>' denote lines to add to the 22 | code. Lines that begin with '|' are just citations of existing code. 23 | 24 | First of all, we need to assign a typeid to our new type. Typeids 25 | in TinyScheme are small integers declared in an enum, very close to 26 | the top; it begins with T_STRING. Add a new one at the end, say 27 | T_MEMBLOCK. There can be at most 31 types, but you don't have to 28 | worry about that limit yet. 29 | 30 | | ... 31 | | T_PORT, 32 | | T_VECTOR, /* remember to add a comma to the preceding item! */ 33 | | T_MEMBLOCK 34 | } }; 35 | 36 | Then, some helper macros would be useful. Go to where isstring() and 37 | the rest are defined and define: 38 | 39 | > int ismemblock(pointer p) { return (type(p)==T_MEMBLOCK); } 40 | 41 | This actually is a function, because it is meant to be exported by 42 | scheme.h. If no foreign function will ever manipulate a memory block, 43 | you can instead define it as a macro 44 | 45 | > #define ismemblock(p) (type(p)==T_MEMBLOCK) 46 | 47 | Then we make space for the new type in the main data structure: 48 | struct cell. As it happens, the _string part of the union _object 49 | (that is used to hold character strings) has two fields that suit us: 50 | 51 | | struct { 52 | | char *_svalue; 53 | | int _keynum; 54 | | } _string; 55 | 56 | We can use _svalue to hold the actual pointer and _keynum to hold its 57 | length. If we couln't reuse existing fields, we could always add other 58 | alternatives in union _object. 59 | 60 | We then procede to write the function that actually makes a new block. 61 | For conformance reasons, we name it mk_memblock 62 | 63 | > static pointer mk_memblock(scheme *sc, int len, char fill) { 64 | > pointer x; 65 | > char *p=(char*)sc->malloc(len); 66 | > 67 | > if(p==0) { 68 | > return sc->NIL; 69 | > } 70 | > x = get_cell(sc, sc->NIL, sc->NIL); 71 | > 72 | > typeflag(x) = T_MEMBLOCK|T_ATOM; 73 | > strvalue(x)=p; 74 | > keynum(x)=len; 75 | > memset(p,fill,len); 76 | > return (x); 77 | > } 78 | 79 | The memory used by the MEMBLOCK will have to be freed when the cell 80 | is reclaimed during garbage collection. There is a placeholder for 81 | that staff, function finalize_cell(), currently handling strings only. 82 | 83 | | static void finalize_cell(scheme *sc, pointer a) { 84 | | if(isstring(a)) { 85 | | sc->free(strvalue(a)); 86 | | } 87 | > else if(ismemblock(a)) { 88 | > sc->free(strvalue(x)); 89 | > } 90 | | } 91 | 92 | There are no MEMBLOCK literals, so we don't concern ourselfs with 93 | the READER part (yet!). We must cater to the PRINTER, though. We 94 | add one case more in printatom(). 95 | 96 | | } else if (iscontinuation(l)) { 97 | | p = "#"; 98 | > } else if (ismemblock(l)) { 99 | > p = "#"; 100 | | } 101 | 102 | Whenever a MEMBLOCK is displayed, it will look like that. 103 | Now, we must add the interface functions: constructor, predicate, 104 | accessor, modifier. We must in fact create new op-codes for the virtual 105 | machine underlying TinyScheme. There is a huge enum with OP_XXX values. 106 | That's where the op-codes are declared. For reasons of cohesion, we add 107 | the new op-codes right after those for vectors: 108 | 109 | | OP_VECSET, 110 | > OP_MKBLOCK, 111 | > OP_MEMBLOCKP, 112 | > OP_BLOCKLEN, 113 | > OP_BLOCKREF, 114 | > OP_BLOCKSET, 115 | | OP_NOT, 116 | 117 | We add the predicate along the other predicates: 118 | 119 | | OP_VECTORP, 120 | > OP_BLOCKP, 121 | | OP_EQ, 122 | 123 | Op-codes are really just tags for a huge C switch, only this switch 124 | is broke up in a number of different opexe_X functions. The 125 | correspondence is made in table "dispatch_table". There, we assign 126 | the new op-codes to opexe_2, where the equivalent ones for vectors 127 | are situated. We also assign a name for them, and specify the minimum 128 | and maximum arity. INF_ARG as a maximum arity means "unlimited". 129 | 130 | | {opexe_2, "vector-set!", 3, 3}, /* OP_VECSET */ 131 | > {opexe_2, "make-block", 1, 2}, /* OP_MKBLOCK */ 132 | > {opexe_2, "block-length", 1, 1}, /* OP_BLOCKLEN */ 133 | > {opexe_2, "block-ref", 2, 2}, /* OP_BLOCKREF */ 134 | > {opexe_2, "block-set!",3 ,3}, /* OP_BLOCKSET */ 135 | 136 | The predicate goes with the other predicates, in opexe_3. 137 | 138 | | {opexe_3, "vector?", 1, 1}, /* OP_VECTORP, */ 139 | > {opexe_3, "block?", 1, 1}, /* OP_BLOCKP, */ 140 | 141 | All that remains is to write the actual processing in opexe_2, right 142 | after OP_VECSET. 143 | 144 | > case OP_MKBLOCK: { /* make-block */ 145 | > int fill=0; 146 | > int len; 147 | > 148 | > if(!isnumber(car(sc->args))) { 149 | > Error_1(sc,"make-block: not a number:",car(sc->args)); 150 | > } 151 | > len=ivalue(car(sc->args)); 152 | > if(len<=0) { 153 | > Error_1(sc,"make-block: not positive:",car(sc->args)); 154 | > } 155 | > 156 | > if(cdr(sc->args)!=sc->NIL) { 157 | > if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) { 158 | > Error_1(sc,"make-block: not a positive number:",cadr(sc->args)); 159 | > } 160 | > fill=charvalue(cadr(sc->args))%255; 161 | > } 162 | > s_return(sc,mk_memblock(sc,len,(char)fill)); 163 | > } 164 | > 165 | > case OP_BLOCKLEN: /* block-length */ 166 | > if(!ismemblock(car(sc->args))) { 167 | > Error_1(sc,"block-length: not a memory block:",car(sc->args)); 168 | > } 169 | > s_return(sc,mk_integer(sc,keynum(car(sc->args)))); 170 | > 171 | > case OP_BLOCKREF: { /* block-ref */ 172 | > char *str; 173 | > int index; 174 | > 175 | > if(!ismemblock(car(sc->args))) { 176 | > Error_1(sc,"block-ref: not a memory block:",car(sc->args)); 177 | > } 178 | > str=strvalue(car(sc->args)); 179 | > 180 | > if(cdr(sc->args)==sc->NIL) { 181 | > Error_0(sc,"block-ref: needs two arguments"); 182 | > } 183 | > if(!isnumber(cadr(sc->args))) { 184 | > Error_1(sc,"block-ref: not a number:",cadr(sc->args)); 185 | > } 186 | > index=ivalue(cadr(sc->args)); 187 | > 188 | > if(index<0 || index>=keynum(car(sc->args))) { 189 | > Error_1(sc,"block-ref: out of bounds:",cadr(sc->args)); 190 | > } 191 | > 192 | > s_return(sc,mk_integer(sc,str[index])); 193 | > } 194 | > 195 | > case OP_BLOCKSET: { /* block-set! */ 196 | > char *str; 197 | > int index; 198 | > int c; 199 | > 200 | > if(!ismemblock(car(sc->args))) { 201 | > Error_1(sc,"block-set!: not a memory block:",car(sc->args)); 202 | > } 203 | > if(isimmutable(car(sc->args))) { 204 | > Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args)); 205 | > } 206 | > str=strvalue(car(sc->args)); 207 | > 208 | > if(cdr(sc->args)==sc->NIL) { 209 | > Error_0(sc,"block-set!: needs three arguments"); 210 | > } 211 | > if(!isnumber(cadr(sc->args))) { 212 | > Error_1(sc,"block-set!: not a number:",cadr(sc->args)); 213 | > } 214 | > index=ivalue(cadr(sc->args)); 215 | > if(index<0 || index>=keynum(car(sc->args))) { 216 | > Error_1(sc,"block-set!: out of bounds:",cadr(sc->args)); 217 | > } 218 | > 219 | > if(cddr(sc->args)==sc->NIL) { 220 | > Error_0(sc,"block-set!: needs three arguments"); 221 | > } 222 | > if(!isinteger(caddr(sc->args))) { 223 | > Error_1(sc,"block-set!: not an integer:",caddr(sc->args)); 224 | > } 225 | > c=ivalue(caddr(sc->args))%255; 226 | > 227 | > str[index]=(char)c; 228 | > s_return(sc,car(sc->args)); 229 | > } 230 | 231 | Same for the predicate in opexe_3. 232 | 233 | | case OP_VECTORP: /* vector? */ 234 | | s_retbool(isvector(car(sc->args))); 235 | > case OP_BLOCKP: /* block? */ 236 | > s_retbool(ismemblock(car(sc->args))); 237 | -------------------------------------------------------------------------------- /tinyscheme-1.40-mingw/hack.txt: -------------------------------------------------------------------------------- 1 | 2 | How to hack TinyScheme 3 | ---------------------- 4 | 5 | TinyScheme is easy to learn and modify. It is structured like a 6 | meta-interpreter, only it is written in C. All data are Scheme 7 | objects, which facilitates both understanding/modifying the 8 | code and reifying the interpreter workings. 9 | 10 | In place of a dry description, we will pace through the addition 11 | of a useful new datatype: garbage-collected memory blocks. 12 | The interface will be: 13 | 14 | (make-block []) makes a new block of the specified size 15 | optionally filling it with a specified byte 16 | (block? ) 17 | (block-length ) 18 | (block-ref ) retrieves byte at location 19 | (block-set! ) modifies byte at location 20 | 21 | In the sequel, lines that begin with '>' denote lines to add to the 22 | code. Lines that begin with '|' are just citations of existing code. 23 | 24 | First of all, we need to assign a typeid to our new type. Typeids 25 | in TinyScheme are small integers declared in an enum, very close to 26 | the top; it begins with T_STRING. Add a new one at the end, say 27 | T_MEMBLOCK. There can be at most 31 types, but you don't have to 28 | worry about that limit yet. 29 | 30 | | ... 31 | | T_PORT, 32 | | T_VECTOR, /* remember to add a comma to the preceding item! */ 33 | | T_MEMBLOCK 34 | } }; 35 | 36 | Then, some helper macros would be useful. Go to where isstring() and 37 | the rest are defined and define: 38 | 39 | > int ismemblock(pointer p) { return (type(p)==T_MEMBLOCK); } 40 | 41 | This actually is a function, because it is meant to be exported by 42 | scheme.h. If no foreign function will ever manipulate a memory block, 43 | you can instead define it as a macro 44 | 45 | > #define ismemblock(p) (type(p)==T_MEMBLOCK) 46 | 47 | Then we make space for the new type in the main data structure: 48 | struct cell. As it happens, the _string part of the union _object 49 | (that is used to hold character strings) has two fields that suit us: 50 | 51 | | struct { 52 | | char *_svalue; 53 | | int _keynum; 54 | | } _string; 55 | 56 | We can use _svalue to hold the actual pointer and _keynum to hold its 57 | length. If we couln't reuse existing fields, we could always add other 58 | alternatives in union _object. 59 | 60 | We then procede to write the function that actually makes a new block. 61 | For conformance reasons, we name it mk_memblock 62 | 63 | > static pointer mk_memblock(scheme *sc, int len, char fill) { 64 | > pointer x; 65 | > char *p=(char*)sc->malloc(len); 66 | > 67 | > if(p==0) { 68 | > return sc->NIL; 69 | > } 70 | > x = get_cell(sc, sc->NIL, sc->NIL); 71 | > 72 | > typeflag(x) = T_MEMBLOCK|T_ATOM; 73 | > strvalue(x)=p; 74 | > keynum(x)=len; 75 | > memset(p,fill,len); 76 | > return (x); 77 | > } 78 | 79 | The memory used by the MEMBLOCK will have to be freed when the cell 80 | is reclaimed during garbage collection. There is a placeholder for 81 | that staff, function finalize_cell(), currently handling strings only. 82 | 83 | | static void finalize_cell(scheme *sc, pointer a) { 84 | | if(isstring(a)) { 85 | | sc->free(strvalue(a)); 86 | | } 87 | > else if(ismemblock(a)) { 88 | > sc->free(strvalue(x)); 89 | > } 90 | | } 91 | 92 | There are no MEMBLOCK literals, so we don't concern ourselfs with 93 | the READER part (yet!). We must cater to the PRINTER, though. We 94 | add one case more in printatom(). 95 | 96 | | } else if (iscontinuation(l)) { 97 | | p = "#"; 98 | > } else if (ismemblock(l)) { 99 | > p = "#"; 100 | | } 101 | 102 | Whenever a MEMBLOCK is displayed, it will look like that. 103 | Now, we must add the interface functions: constructor, predicate, 104 | accessor, modifier. We must in fact create new op-codes for the virtual 105 | machine underlying TinyScheme. There is a huge enum with OP_XXX values. 106 | That's where the op-codes are declared. For reasons of cohesion, we add 107 | the new op-codes right after those for vectors: 108 | 109 | | OP_VECSET, 110 | > OP_MKBLOCK, 111 | > OP_MEMBLOCKP, 112 | > OP_BLOCKLEN, 113 | > OP_BLOCKREF, 114 | > OP_BLOCKSET, 115 | | OP_NOT, 116 | 117 | We add the predicate along the other predicates: 118 | 119 | | OP_VECTORP, 120 | > OP_BLOCKP, 121 | | OP_EQ, 122 | 123 | Op-codes are really just tags for a huge C switch, only this switch 124 | is broke up in a number of different opexe_X functions. The 125 | correspondence is made in table "dispatch_table". There, we assign 126 | the new op-codes to opexe_2, where the equivalent ones for vectors 127 | are situated. We also assign a name for them, and specify the minimum 128 | and maximum arity. INF_ARG as a maximum arity means "unlimited". 129 | 130 | | {opexe_2, "vector-set!", 3, 3}, /* OP_VECSET */ 131 | > {opexe_2, "make-block", 1, 2}, /* OP_MKBLOCK */ 132 | > {opexe_2, "block-length", 1, 1}, /* OP_BLOCKLEN */ 133 | > {opexe_2, "block-ref", 2, 2}, /* OP_BLOCKREF */ 134 | > {opexe_2, "block-set!",3 ,3}, /* OP_BLOCKSET */ 135 | 136 | The predicate goes with the other predicates, in opexe_3. 137 | 138 | | {opexe_3, "vector?", 1, 1}, /* OP_VECTORP, */ 139 | > {opexe_3, "block?", 1, 1}, /* OP_BLOCKP, */ 140 | 141 | All that remains is to write the actual processing in opexe_2, right 142 | after OP_VECSET. 143 | 144 | > case OP_MKBLOCK: { /* make-block */ 145 | > int fill=0; 146 | > int len; 147 | > 148 | > if(!isnumber(car(sc->args))) { 149 | > Error_1(sc,"make-block: not a number:",car(sc->args)); 150 | > } 151 | > len=ivalue(car(sc->args)); 152 | > if(len<=0) { 153 | > Error_1(sc,"make-block: not positive:",car(sc->args)); 154 | > } 155 | > 156 | > if(cdr(sc->args)!=sc->NIL) { 157 | > if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) { 158 | > Error_1(sc,"make-block: not a positive number:",cadr(sc->args)); 159 | > } 160 | > fill=charvalue(cadr(sc->args))%255; 161 | > } 162 | > s_return(sc,mk_memblock(sc,len,(char)fill)); 163 | > } 164 | > 165 | > case OP_BLOCKLEN: /* block-length */ 166 | > if(!ismemblock(car(sc->args))) { 167 | > Error_1(sc,"block-length: not a memory block:",car(sc->args)); 168 | > } 169 | > s_return(sc,mk_integer(sc,keynum(car(sc->args)))); 170 | > 171 | > case OP_BLOCKREF: { /* block-ref */ 172 | > char *str; 173 | > int index; 174 | > 175 | > if(!ismemblock(car(sc->args))) { 176 | > Error_1(sc,"block-ref: not a memory block:",car(sc->args)); 177 | > } 178 | > str=strvalue(car(sc->args)); 179 | > 180 | > if(cdr(sc->args)==sc->NIL) { 181 | > Error_0(sc,"block-ref: needs two arguments"); 182 | > } 183 | > if(!isnumber(cadr(sc->args))) { 184 | > Error_1(sc,"block-ref: not a number:",cadr(sc->args)); 185 | > } 186 | > index=ivalue(cadr(sc->args)); 187 | > 188 | > if(index<0 || index>=keynum(car(sc->args))) { 189 | > Error_1(sc,"block-ref: out of bounds:",cadr(sc->args)); 190 | > } 191 | > 192 | > s_return(sc,mk_integer(sc,str[index])); 193 | > } 194 | > 195 | > case OP_BLOCKSET: { /* block-set! */ 196 | > char *str; 197 | > int index; 198 | > int c; 199 | > 200 | > if(!ismemblock(car(sc->args))) { 201 | > Error_1(sc,"block-set!: not a memory block:",car(sc->args)); 202 | > } 203 | > if(isimmutable(car(sc->args))) { 204 | > Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args)); 205 | > } 206 | > str=strvalue(car(sc->args)); 207 | > 208 | > if(cdr(sc->args)==sc->NIL) { 209 | > Error_0(sc,"block-set!: needs three arguments"); 210 | > } 211 | > if(!isnumber(cadr(sc->args))) { 212 | > Error_1(sc,"block-set!: not a number:",cadr(sc->args)); 213 | > } 214 | > index=ivalue(cadr(sc->args)); 215 | > if(index<0 || index>=keynum(car(sc->args))) { 216 | > Error_1(sc,"block-set!: out of bounds:",cadr(sc->args)); 217 | > } 218 | > 219 | > if(cddr(sc->args)==sc->NIL) { 220 | > Error_0(sc,"block-set!: needs three arguments"); 221 | > } 222 | > if(!isinteger(caddr(sc->args))) { 223 | > Error_1(sc,"block-set!: not an integer:",caddr(sc->args)); 224 | > } 225 | > c=ivalue(caddr(sc->args))%255; 226 | > 227 | > str[index]=(char)c; 228 | > s_return(sc,car(sc->args)); 229 | > } 230 | 231 | Same for the predicate in opexe_3. 232 | 233 | | case OP_VECTORP: /* vector? */ 234 | | s_retbool(isvector(car(sc->args))); 235 | > case OP_BLOCKP: /* block? */ 236 | > s_retbool(ismemblock(car(sc->args))); 237 | -------------------------------------------------------------------------------- /re/regex.7: -------------------------------------------------------------------------------- 1 | .TH REGEX 7 "7 Feb 1994" 2 | .BY "Henry Spencer" 3 | .SH NAME 4 | regex \- POSIX 1003.2 regular expressions 5 | .SH DESCRIPTION 6 | Regular expressions (``RE''s), 7 | as defined in POSIX 1003.2, come in two forms: 8 | modern REs (roughly those of 9 | .IR egrep ; 10 | 1003.2 calls these ``extended'' REs) 11 | and obsolete REs (roughly those of 12 | .IR ed ; 13 | 1003.2 ``basic'' REs). 14 | Obsolete REs mostly exist for backward compatibility in some old programs; 15 | they will be discussed at the end. 16 | 1003.2 leaves some aspects of RE syntax and semantics open; 17 | `\(dg' marks decisions on these aspects that 18 | may not be fully portable to other 1003.2 implementations. 19 | .PP 20 | A (modern) RE is one\(dg or more non-empty\(dg \fIbranches\fR, 21 | separated by `|'. 22 | It matches anything that matches one of the branches. 23 | .PP 24 | A branch is one\(dg or more \fIpieces\fR, concatenated. 25 | It matches a match for the first, followed by a match for the second, etc. 26 | .PP 27 | A piece is an \fIatom\fR possibly followed 28 | by a single\(dg `*', `+', `?', or \fIbound\fR. 29 | An atom followed by `*' matches a sequence of 0 or more matches of the atom. 30 | An atom followed by `+' matches a sequence of 1 or more matches of the atom. 31 | An atom followed by `?' matches a sequence of 0 or 1 matches of the atom. 32 | .PP 33 | A \fIbound\fR is `{' followed by an unsigned decimal integer, 34 | possibly followed by `,' 35 | possibly followed by another unsigned decimal integer, 36 | always followed by `}'. 37 | The integers must lie between 0 and RE_DUP_MAX (255\(dg) inclusive, 38 | and if there are two of them, the first may not exceed the second. 39 | An atom followed by a bound containing one integer \fIi\fR 40 | and no comma matches 41 | a sequence of exactly \fIi\fR matches of the atom. 42 | An atom followed by a bound 43 | containing one integer \fIi\fR and a comma matches 44 | a sequence of \fIi\fR or more matches of the atom. 45 | An atom followed by a bound 46 | containing two integers \fIi\fR and \fIj\fR matches 47 | a sequence of \fIi\fR through \fIj\fR (inclusive) matches of the atom. 48 | .PP 49 | An atom is a regular expression enclosed in `()' (matching a match for the 50 | regular expression), 51 | an empty set of `()' (matching the null string)\(dg, 52 | a \fIbracket expression\fR (see below), `.' 53 | (matching any single character), `^' (matching the null string at the 54 | beginning of a line), `$' (matching the null string at the 55 | end of a line), a `\e' followed by one of the characters 56 | `^.[$()|*+?{\e' 57 | (matching that character taken as an ordinary character), 58 | a `\e' followed by any other character\(dg 59 | (matching that character taken as an ordinary character, 60 | as if the `\e' had not been present\(dg), 61 | or a single character with no other significance (matching that character). 62 | A `{' followed by a character other than a digit is an ordinary 63 | character, not the beginning of a bound\(dg. 64 | It is illegal to end an RE with `\e'. 65 | .PP 66 | A \fIbracket expression\fR is a list of characters enclosed in `[]'. 67 | It normally matches any single character from the list (but see below). 68 | If the list begins with `^', 69 | it matches any single character 70 | (but see below) \fInot\fR from the rest of the list. 71 | If two characters in the list are separated by `\-', this is shorthand 72 | for the full \fIrange\fR of characters between those two (inclusive) in the 73 | collating sequence, 74 | e.g. `[0-9]' in ASCII matches any decimal digit. 75 | It is illegal\(dg for two ranges to share an 76 | endpoint, e.g. `a-c-e'. 77 | Ranges are very collating-sequence-dependent, 78 | and portable programs should avoid relying on them. 79 | .PP 80 | To include a literal `]' in the list, make it the first character 81 | (following a possible `^'). 82 | To include a literal `\-', make it the first or last character, 83 | or the second endpoint of a range. 84 | To use a literal `\-' as the first endpoint of a range, 85 | enclose it in `[.' and `.]' to make it a collating element (see below). 86 | With the exception of these and some combinations using `[' (see next 87 | paragraphs), all other special characters, including `\e', lose their 88 | special significance within a bracket expression. 89 | .PP 90 | Within a bracket expression, a collating element (a character, 91 | a multi-character sequence that collates as if it were a single character, 92 | or a collating-sequence name for either) 93 | enclosed in `[.' and `.]' stands for the 94 | sequence of characters of that collating element. 95 | The sequence is a single element of the bracket expression's list. 96 | A bracket expression containing a multi-character collating element 97 | can thus match more than one character, 98 | e.g. if the collating sequence includes a `ch' collating element, 99 | then the RE `[[.ch.]]*c' matches the first five characters 100 | of `chchcc'. 101 | .PP 102 | Within a bracket expression, a collating element enclosed in `[=' and 103 | `=]' is an equivalence class, standing for the sequences of characters 104 | of all collating elements equivalent to that one, including itself. 105 | (If there are no other equivalent collating elements, 106 | the treatment is as if the enclosing delimiters were `[.' and `.]'.) 107 | For example, if o and \o'o^' are the members of an equivalence class, 108 | then `[[=o=]]', `[[=\o'o^'=]]', and `[o\o'o^']' are all synonymous. 109 | An equivalence class may not\(dg be an endpoint 110 | of a range. 111 | .PP 112 | Within a bracket expression, the name of a \fIcharacter class\fR enclosed 113 | in `[:' and `:]' stands for the list of all characters belonging to that 114 | class. 115 | Standard character class names are: 116 | .PP 117 | .RS 118 | .nf 119 | .ta 3c 6c 9c 120 | alnum digit punct 121 | alpha graph space 122 | blank lower upper 123 | cntrl print xdigit 124 | .fi 125 | .RE 126 | .PP 127 | These stand for the character classes defined in 128 | .IR ctype (3). 129 | A locale may provide others. 130 | A character class may not be used as an endpoint of a range. 131 | .PP 132 | There are two special cases\(dg of bracket expressions: 133 | the bracket expressions `[[:<:]]' and `[[:>:]]' match the null string at 134 | the beginning and end of a word respectively. 135 | A word is defined as a sequence of 136 | word characters 137 | which is neither preceded nor followed by 138 | word characters. 139 | A word character is an 140 | .I alnum 141 | character (as defined by 142 | .IR ctype (3)) 143 | or an underscore. 144 | This is an extension, 145 | compatible with but not specified by POSIX 1003.2, 146 | and should be used with 147 | caution in software intended to be portable to other systems. 148 | .PP 149 | In the event that an RE could match more than one substring of a given 150 | string, 151 | the RE matches the one starting earliest in the string. 152 | If the RE could match more than one substring starting at that point, 153 | it matches the longest. 154 | Subexpressions also match the longest possible substrings, subject to 155 | the constraint that the whole match be as long as possible, 156 | with subexpressions starting earlier in the RE taking priority over 157 | ones starting later. 158 | Note that higher-level subexpressions thus take priority over 159 | their lower-level component subexpressions. 160 | .PP 161 | Match lengths are measured in characters, not collating elements. 162 | A null string is considered longer than no match at all. 163 | For example, 164 | `bb*' matches the three middle characters of `abbbc', 165 | `(wee|week)(knights|nights)' matches all ten characters of `weeknights', 166 | when `(.*).*' is matched against `abc' the parenthesized subexpression 167 | matches all three characters, and 168 | when `(a*)*' is matched against `bc' both the whole RE and the parenthesized 169 | subexpression match the null string. 170 | .PP 171 | If case-independent matching is specified, 172 | the effect is much as if all case distinctions had vanished from the 173 | alphabet. 174 | When an alphabetic that exists in multiple cases appears as an 175 | ordinary character outside a bracket expression, it is effectively 176 | transformed into a bracket expression containing both cases, 177 | e.g. `x' becomes `[xX]'. 178 | When it appears inside a bracket expression, all case counterparts 179 | of it are added to the bracket expression, so that (e.g.) `[x]' 180 | becomes `[xX]' and `[^x]' becomes `[^xX]'. 181 | .PP 182 | No particular limit is imposed on the length of REs\(dg. 183 | Programs intended to be portable should not employ REs longer 184 | than 256 bytes, 185 | as an implementation can refuse to accept such REs and remain 186 | POSIX-compliant. 187 | .PP 188 | Obsolete (``basic'') regular expressions differ in several respects. 189 | `|', `+', and `?' are ordinary characters and there is no equivalent 190 | for their functionality. 191 | The delimiters for bounds are `\e{' and `\e}', 192 | with `{' and `}' by themselves ordinary characters. 193 | The parentheses for nested subexpressions are `\e(' and `\e)', 194 | with `(' and `)' by themselves ordinary characters. 195 | `^' is an ordinary character except at the beginning of the 196 | RE or\(dg the beginning of a parenthesized subexpression, 197 | `$' is an ordinary character except at the end of the 198 | RE or\(dg the end of a parenthesized subexpression, 199 | and `*' is an ordinary character if it appears at the beginning of the 200 | RE or the beginning of a parenthesized subexpression 201 | (after a possible leading `^'). 202 | Finally, there is one new type of atom, a \fIback reference\fR: 203 | `\e' followed by a non-zero decimal digit \fId\fR 204 | matches the same sequence of characters 205 | matched by the \fId\fRth parenthesized subexpression 206 | (numbering subexpressions by the positions of their opening parentheses, 207 | left to right), 208 | so that (e.g.) `\e([bc]\e)\e1' matches `bb' or `cc' but not `bc'. 209 | .SH SEE ALSO 210 | regex(3) 211 | .PP 212 | POSIX 1003.2, section 2.8 (Regular Expression Notation). 213 | .SH BUGS 214 | Having two kinds of REs is a botch. 215 | .PP 216 | The current 1003.2 spec says that `)' is an ordinary character in 217 | the absence of an unmatched `('; 218 | this was an unintentional result of a wording error, 219 | and change is likely. 220 | Avoid relying on it. 221 | .PP 222 | Back references are a dreadful botch, 223 | posing major problems for efficient implementations. 224 | They are also somewhat vaguely defined 225 | (does 226 | `a\e(\e(b\e)*\e2\e)*d' match `abbbd'?). 227 | Avoid using them. 228 | .PP 229 | 1003.2's specification of case-independent matching is vague. 230 | The ``one case implies all cases'' definition given above 231 | is current consensus among implementors as to the right interpretation. 232 | .PP 233 | The syntax for word boundaries is incredibly ugly. 234 | -------------------------------------------------------------------------------- /oops-0.1.1/oops.scm: -------------------------------------------------------------------------------- 1 | ; A port of Elk's OOPS package 2 | ; 3 | 4 | (define void (string->symbol "")) 5 | 6 | (define (void? x) (eq? x (string->symbol ""))) 7 | 8 | (define (print arg) 9 | (begin (write arg) 10 | (newline) 11 | void)) 12 | 13 | (define (print2 arg1 arg2) 14 | (begin (display arg1) 15 | (write arg2) 16 | (newline) 17 | void)) 18 | 19 | (define (error-extended sym str) 20 | (error (string-append (symbol->string sym) " -- " str))) 21 | 22 | (define (arg->string arg) 23 | (if (list? arg) 24 | (list->string arg) 25 | (symbol->string arg))) 26 | 27 | (define (error-extended-one sym str arg) 28 | (error (string-append (symbol->string sym) " -- " str (arg->string arg)))) 29 | 30 | (define (error-extended-two sym str1 arg1 str2 arg2) 31 | (error (string-append (symbol->string sym) " -- " str1 (arg->string arg1) 32 | str2 (arg->string arg2)))) 33 | 34 | (define class-size 5) 35 | (define instance-size 3) 36 | 37 | ;;; Classes and instances are represented as vectors. The first 38 | ;;; two slots (tag and class-name) are common to classes and instances. 39 | 40 | (define (tag v) (vector-ref v 0)) 41 | (define (set-tag! v t) (vector-set! v 0 t)) 42 | 43 | (define (class-name v) (vector-ref v 1)) 44 | (define (set-class-name! v n) (vector-set! v 1 n)) 45 | 46 | (define (class-instance-vars c) (vector-ref c 2)) 47 | (define (set-class-instance-vars! c v) (vector-set! c 2 v)) 48 | 49 | (define (class-env c) (vector-ref c 3)) 50 | (define (set-class-env! c e) (vector-set! c 3 e)) 51 | 52 | (define (class-super c) (vector-ref c 4)) 53 | (define (set-class-super! c s) (vector-set! c 4 s)) 54 | 55 | (define (instance-env i) (vector-ref i 2)) 56 | (define (set-instance-env! i e) (vector-set! i 2 e)) 57 | 58 | ;;; Methods are bound in the class environment. 59 | 60 | (define (method-known? method class) 61 | (eval `(defined? ',method) (class-env class))) 62 | 63 | (define (lookup-method method class) 64 | (eval method (class-env class))) 65 | 66 | (define (class? c) 67 | (and (vector? c) (= (vector-length c) class-size) (eq? (tag c) 'class))) 68 | 69 | (define (check-class sym c) 70 | (if (not (class? c)) 71 | (error-extended sym "argument is not a class"))) 72 | 73 | (define (instance? i) 74 | (and (vector? i) (= (vector-length i) instance-size) 75 | (eq? (tag i) 'instance))) 76 | 77 | (define (check-instance sym i) 78 | (if (not (instance? i)) 79 | (error-extended sym "argument is not an instance"))) 80 | 81 | ;;; Evaluate `body' within the scope of instance `i'. 82 | 83 | (define-macro (with-instance i . body) 84 | `(eval '(begin ,@body) (instance-env ,i))) 85 | 86 | ;;; Set a variable in an instance. 87 | 88 | (define (instance-set! instance var val) 89 | (eval `(set! ,var ',val) (instance-env instance))) 90 | 91 | ;;; Set a class variable when no instance is available. 92 | 93 | (define (class-set! class var val) 94 | (eval `(set! ,var ',val) (class-env class))) 95 | 96 | ;;; Convert a class variable spec into a binding suitable for a `let'. 97 | 98 | (define (make-binding var) 99 | (if (symbol? var) 100 | (list var '()) ; No initializer given; use () 101 | var)) ; Initializer has been specified; leave alone 102 | 103 | ;;; Check whether the elements of `vars' are either a symbol or 104 | ;;; of the form (symbol initializer). 105 | 106 | (define (check-vars vars) 107 | (if (not (null? vars)) 108 | (if (not (or (symbol? (car vars)) 109 | (and (pair? (car vars)) (= (length (car vars)) 2) 110 | (symbol? (caar vars))))) 111 | (error-extended-one 'define-class "bad variable spec: " (car vars)) 112 | (check-vars (cdr vars))))) 113 | 114 | ;;; Check whether the class var spec `v' is already a member of 115 | ;;; the list `l'. If this is the case, check whether the initializers 116 | ;;; are identical. 117 | 118 | (define (find-matching-var l v) 119 | (cond 120 | ((null? l) #f) 121 | ((eq? (caar l) (car v)) 122 | (if (not (equal? (cdar l) (cdr v))) 123 | (error-extended-two 'define-class "initializer mismatch: " 124 | (car l) " and " v) 125 | #t)) 126 | (else (find-matching-var (cdr l) v)))) 127 | 128 | ;;; Same as above, but don't check initializer. 129 | 130 | (define (find-var l v) 131 | (cond 132 | ((null? l) #f) 133 | ((eq? (caar l) (car v)) #t) 134 | (else (find-var (cdr l) v)))) 135 | 136 | ;;; Create a new list of class var specs by discarding all variables 137 | ;;; from `b' that are already a member of `a' (with identical initializers). 138 | 139 | (define (join-vars a b) 140 | (cond 141 | ((null? b) a) 142 | ((find-matching-var a (car b)) (join-vars a (cdr b))) 143 | (else (join-vars (cons (car b) a) (cdr b))))) 144 | 145 | ;;; The syntax is as follows: 146 | ;;; (define-class class-name . options) 147 | ;;; options are: (super-class class-name) 148 | ;;; (class-vars . var-specs) 149 | ;;; (instance-vars . var-specs) 150 | ;;; each var-spec is either a symbol or (symbol initializer). 151 | 152 | (define-macro (define-class name . args) 153 | (let ((class-vars) (instance-vars (list (make-binding 'self))) 154 | (super) (super-class-env)) 155 | (do ((a args (cdr a))) ((null? a)) 156 | (cond 157 | ((not (pair? (car a))) 158 | (error-extended-one 'define-class "bad argument: " (car a))) 159 | ((eq? (caar a) 'class-vars) 160 | (check-vars (cdar a)) 161 | (set! class-vars (cdar a))) 162 | ((eq? (caar a) 'instance-vars) 163 | (check-vars (cdar a)) 164 | (set! instance-vars (append instance-vars 165 | (map make-binding (cdar a))))) 166 | ((eq? (caar a) 'super-class) 167 | (if (> (length (cdar a)) 1) 168 | (error-extended 'define-class "only one super-class allowed")) 169 | (set! super (cadar a))) 170 | (else 171 | (error-extended-one 'define-class "bad keyword: " (caar a))))) 172 | (if (not (null? super)) 173 | (let ((class (eval super))) 174 | (set! super-class-env (class-env class)) 175 | (set! instance-vars (join-vars (class-instance-vars class) 176 | instance-vars))) 177 | (set! super-class-env (current-environment))) 178 | `(define ,name 179 | (let ((c (make-vector class-size '()))) 180 | (set-tag! c 'class) 181 | (set-class-name! c ',name) 182 | (set-class-instance-vars! c ',instance-vars) 183 | (set-class-env! c (eval `(let* ,(map make-binding ',class-vars) 184 | (current-environment)) 185 | ,super-class-env)) 186 | (set-class-super! c ',super) 187 | c)))) 188 | 189 | (define-macro (define-method class lambda-list . body) 190 | (if (not (pair? lambda-list)) 191 | (error-extended 'define-method "bad lambda list")) 192 | `(begin 193 | (check-class 'define-method ,class) 194 | (let ((env (class-env ,class)) 195 | (method (car ',lambda-list)) 196 | (args (cdr ',lambda-list)) 197 | (forms ',body)) 198 | (eval `(define ,method (lambda ,args ,@forms)) env) 199 | void))) 200 | 201 | ;;; All arguments of the form (instance-var init-value) are used 202 | ;;; to initialize the specified instance variable; then an 203 | ;;; initialize-instance message is sent with all remaining 204 | ;;; arguments. 205 | 206 | (define-macro (make-instance class . args) 207 | `(begin 208 | (check-class 'make-instance ,class) 209 | (let* ((e (current-environment)) 210 | (i (make-vector instance-size #f)) 211 | (class-env (class-env ,class)) 212 | (instance-vars (class-instance-vars ,class))) 213 | (set-tag! i 'instance) 214 | (set-class-name! i ',class) 215 | (set-instance-env! i (eval `(let* ,instance-vars (current-environment)) 216 | class-env)) 217 | (eval `(set! self ',i) (instance-env i)) 218 | (init-instance ',args ,class i e) 219 | i))) 220 | 221 | (define (init-instance args class instance env) 222 | (let ((other-args)) 223 | (do ((a args (cdr a))) ((null? a)) 224 | (if (and (pair? (car a)) (= (length (car a)) 2) 225 | (find-var (class-instance-vars class) (car a))) 226 | (instance-set! instance (caar a) (eval (cadar a) env)) 227 | (set! other-args (cons (eval (car a) env) other-args)))) 228 | (call-init-methods class instance (if (not (null? other-args)) 229 | (reverse other-args))))) 230 | 231 | ;;; Call all initialize-instance methods in super-class to sub-class 232 | ;;; order in the environment of `instance' with arguments `args'. 233 | 234 | (define (call-init-methods class instance args) 235 | (let ((called '())) 236 | (let loop ((class class)) 237 | (if (not (null? (class-super class))) 238 | (loop (eval (class-super class)))) 239 | (if (method-known? 'initialize-instance class) 240 | (let ((method (lookup-method 'initialize-instance class))) 241 | (if (not (memq method called)) 242 | (begin 243 | (apply (set-closure-environment! 244 | method (instance-env instance)) 245 | args) 246 | (set! called (cons method called))))))))) 247 | 248 | (define (send instance msg . args) 249 | (check-instance 'send instance) 250 | (let ((class (eval (class-name instance)))) 251 | (if (not (method-known? msg class)) 252 | (error-extended-one 'send "message not understood: " `(,msg ,@args)) 253 | (apply (set-closure-environment! (lookup-method msg class) 254 | (instance-env instance)) 255 | args)))) 256 | 257 | ;;; If the message is not understood, return #f. Otherwise return 258 | ;;; a list of one element, the result of the method. 259 | 260 | (define (send-if-handles instance msg . args) 261 | (check-instance 'send-if-handles instance) 262 | (let ((class (eval (class-name instance)))) 263 | (if (not (method-known? msg class)) 264 | #f 265 | (list (apply (set-closure-environment! (lookup-method msg class) 266 | (instance-env instance)) 267 | args))))) 268 | 269 | (define (describe-class c) 270 | (check-class 'describe-class c) 271 | (print2 "Class name: " (class-name c)) 272 | (if (not (null? (class-super c))) 273 | (print2 "Superclass: " (class-super c))) 274 | (display "Instancevars: ") 275 | (do ((v (class-instance-vars c) (cdr v)) (space #f #t)) ((null? v)) 276 | (if space 277 | (display " ")) 278 | (print (cons (caar v) (cadar v)))) 279 | (display "Classvars/Methods: ") 280 | (define v (car (environment->list (class-env c)))) 281 | (if (not (null? v)) 282 | (do ((f v (cdr f)) (space #f #t)) ((null? f)) 283 | (if space 284 | (display " ")) 285 | (print (car f))) 286 | (print 'None)) 287 | void) 288 | 289 | (define (describe-instance i) 290 | (check-instance 'describe-instance i) 291 | (print2 "Instance of: " (class-name i)) 292 | (display "Instancevars: ") 293 | (do ((f (car (environment->list (instance-env i))) (cdr f)) 294 | (space #f #t)) ((null? f)) 295 | (if space 296 | (display " ")) 297 | (print (car f))) 298 | void) 299 | --------------------------------------------------------------------------------