Commit 2d7edfee authored by Kevin Cozens's avatar Kevin Cozens Committed by Kevin Cozens

Removed.

2007-10-28  Kevin Cozens  <kcozens@cvs.gnome.org>

	* tinyscheme.patch: Removed.

svn path=/trunk/; revision=372
parent 586829b7
2007-10-28 Kevin Cozens <kcozens@cvs.gnome.org>
* tinyscheme.patch: Removed.
2007-10-28 Kevin Cozens <kcozens@cvs.gnome.org>
* ftx/.cvsignore
......
--- tinyscheme-1.35/dynload.c 2004-06-07 02:56:50.000000000 -0400
+++ tinyscheme/dynload.c 2004-07-18 12:25:00.000000000 -0400
@@ -21,8 +21,6 @@
#else
typedef void *HMODULE;
typedef void (*FARPROC)();
-#define SUN_DL
-#include <dlfcn.h>
#endif
#ifdef _WIN32
--- tinyscheme-1.35/init.scm 2004-06-07 02:56:50.000000000 -0400
+++ tinyscheme/init.scm 2004-07-11 12:12:29.000000000 -0400
@@ -64,16 +64,25 @@
(foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst)))
(define (succ x) (+ x 1))
(define (pred x) (- x 1))
-(define (gcd a b)
- (let ((aa (abs a))
- (bb (abs b)))
- (if (= bb 0)
- aa
- (gcd bb (remainder aa bb)))))
-(define (lcm a b)
- (if (or (= a 0) (= b 0))
- 0
- (abs (* (quotient a (gcd a b)) b))))
+(define gcd
+ (lambda a
+ (if (null? a)
+ 0
+ (let ((aa (abs (car a)))
+ (bb (abs (cadr a))))
+ (if (= bb 0)
+ aa
+ (gcd bb (remainder aa bb)))))))
+(define lcm
+ (lambda a
+ (if (null? a)
+ 1
+ (let ((aa (abs (car a)))
+ (bb (abs (cadr a))))
+ (if (or (= aa 0) (= bb 0))
+ 0
+ (abs (* (quotient aa (gcd aa bb)) bb)))))))
+
(define call/cc call-with-current-continuation)
@@ -118,9 +127,9 @@
(if (pred n)
(atom->string n)
(error "xxx->string: not a xxx" n)))
-
-(define (number->string n) (anyatom->string n number?))
+
+(define (number->string n) (anyatom->string n number?))
(define (char-cmp? cmp a b)
(cmp (char->integer a) (char->integer b)))
@@ -181,8 +190,8 @@
(cons cars cdrs)
(let ((car1 (caar lists))
(cdr1 (cdar lists)))
- (unzip1-with-cdr-iterative
- (cdr lists)
+ (unzip1-with-cdr-iterative
+ (cdr lists)
(append cars (list car1))
(append cdrs (list cdr1))))))
@@ -466,7 +475,7 @@
(and (input-port? p) (output-port? p)))
(define (close-port p)
- (cond
+ (cond
((input-output-port? p) (close-input-port (close-output-port p)))
((input-port? p) (close-input-port p))
((output-port? p) (close-output-port p))
@@ -539,7 +548,7 @@
(* (quotient *seed* q) r)))
(if (< *seed* 0) (set! *seed* (+ *seed* m)))
*seed*))
-;; SRFI-0
+;; SRFI-0
;; COND-EXPAND
;; Implemented as a macro
(define *features* '(srfi-0))
--- tinyscheme-1.35/scheme.c 2004-06-22 02:13:39.000000000 -0400
+++ tinyscheme/scheme.c 2004-08-07 12:31:06.000000000 -0400
@@ -27,9 +27,14 @@
#include <float.h>
#include <ctype.h>
+#include <glib.h>
+#include <libintl.h>
+
#if USE_STRCASECMP
#include <strings.h>
#define stricmp strcasecmp
+#else
+#define stricmp strcmp
#endif
/* Used for documentation purposes, to signal functions in 'interface' */
@@ -49,6 +54,7 @@
#define TOK_SHARP 10
#define TOK_SHARP_CONST 11
#define TOK_VEC 12
+#define TOK_TQUOTE 13
# define BACKQUOTE '`'
@@ -63,6 +69,7 @@
#ifndef macintosh
# include <malloc.h>
#else
+# if USE_STRCASECMP
static int stricmp(const char *s1, const char *s2)
{
unsigned char c1, c2;
@@ -77,6 +84,7 @@
} while (c1 != 0);
return 0;
}
+# endif
#endif /* macintosh */
#if USE_STRLWR
@@ -88,6 +96,8 @@
}
return p;
}
+#else
+#define strlwr(s) s
#endif
#ifndef prompt
@@ -102,6 +112,8 @@
# define FIRST_CELLSEGS 3
#endif
+void (*ts_output_routine) (FILE *, char *, int);
+
enum scheme_types {
T_STRING=1,
T_NUMBER=2,
@@ -161,6 +173,7 @@
#define strvalue(p) ((p)->_object._string._svalue)
#define strlength(p) ((p)->_object._string._length)
+INTERFACE static int is_list(scheme *sc, pointer p);
INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
INTERFACE static void fill_vector(pointer vec, pointer obj);
INTERFACE static pointer vector_elem(pointer vec, int ielem);
@@ -174,6 +187,7 @@
}
INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
+INTERFACE INLINE int string_length(pointer p) { return strlength(p); }
INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
INLINE num nvalue(pointer p) { return ((p)->_object._number); }
INTERFACE long ivalue(pointer p) { return (is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
@@ -439,7 +453,7 @@
}
} else if (res < 0) {
if (e1 > 0) {
- res += labs(e2);
+ res += labs(e2);
}
}
ret.value.ivalue=res;
@@ -867,11 +881,11 @@
return sc->strbuff;
}
if(str!=0) {
- strcpy(q, str);
+ memcpy(q, str, len_str);
} else {
memset(q, fill, len_str);
- q[len_str]=0;
}
+ q[len_str]=0;
return (q);
}
@@ -1390,41 +1404,44 @@
}
}
-INTERFACE void putstr(scheme *sc, const char *s) {
+static void putchars(scheme *sc, const char *chars, int len) {
+ int l;
+ char *s;
port *pt=sc->outport->_object._port;
- if(pt->kind&port_file) {
- fputs(s,pt->rep.stdio.file);
- } else {
- for(;*s;s++) {
- if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
- *pt->rep.string.curr++=*s;
+
+ /* Output characters to console mode (if enabled) */
+ (*ts_output_routine) (pt->rep.stdio.file, (char *)chars, len);
+
+ if (sc->print_error) {
+ l = strlen(sc->linebuff);
+ s = &sc->linebuff[l];
+ while (len-- > 0)
+ {
+ *s++ = *chars++;
+ if (++l > LINESIZE-1)
+ break;
}
- }
+ return;
}
-}
-static void putchars(scheme *sc, const char *s, int len) {
- port *pt=sc->outport->_object._port;
if(pt->kind&port_file) {
- fwrite(s,1,len,pt->rep.stdio.file);
+ fwrite(chars,1,len,pt->rep.stdio.file);
+ fflush(pt->rep.stdio.file);
} else {
for(;len;len--) {
if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
- *pt->rep.string.curr++=*s++;
+ *pt->rep.string.curr++=*chars++;
}
}
}
}
INTERFACE void putcharacter(scheme *sc, int c) {
- port *pt=sc->outport->_object._port;
- if(pt->kind&port_file) {
- fputc(c,pt->rep.stdio.file);
- } else {
- if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
- *pt->rep.string.curr++=c;
- }
- }
+ putchars(sc, (char *)&c, 1);
+}
+
+INTERFACE void putstr(scheme *sc, const char *s) {
+ putchars(sc, s, strlen(s));
}
/* read characters up to delimiter, but cater to character constants */
@@ -1432,7 +1449,7 @@
char *p = sc->strbuff;
while (!is_one_of(delim, (*p++ = inchar(sc))));
- if(p==sc->strbuff+2 && p[-2]=='\\') {
+ if(p==sc->strbuff+2 && p[-2]=='\\') { /* ?? ~~~~~ */
*p=0;
} else {
backchar(sc,p[-1]);
@@ -1498,21 +1515,18 @@
break;
case st_x1:
case st_x2:
+ if (!isxdigit(c))
+ return sc->F;
c=toupper(c);
- if(c>='0' && c<='F') {
- if(c<='9') {
+ if(c<='9')
c1=(c1<<4)+c-'0';
- } else {
+ else
c1=(c1<<4)+c-'A'+10;
- }
- if(state==st_x1) {
+ if(state==st_x1)
state=st_x2;
- } else {
+ else {
*p++=c1;
state=st_ok;
- }
- } else {
- return sc->F;
}
break;
}
@@ -1564,6 +1578,11 @@
return (TOK_COMMENT);
case '"':
return (TOK_DQUOTE);
+ case '_':
+ if ((c=inchar(sc)) == '"')
+ return (TOK_TQUOTE);
+ backchar(sc,c);
+ return (TOK_ATOM);
case BACKQUOTE:
return (TOK_BQUOTE);
case ',':
@@ -2027,7 +2046,7 @@
sc->op = (int)OP_ERR0;
return sc->T;
}
-#define Error_1(sc,s, a) return _Error_1(sc,s,a)
+#define Error_1(sc,s,a) return _Error_1(sc,s,a)
#define Error_0(sc,s) return _Error_1(sc,s,0)
/* Too small to turn into function */
@@ -2224,7 +2243,7 @@
if(sc->tracing) {
putstr(sc,"\nGives: ");
}
- if(file_interactive(sc)) {
+ if(file_interactive(sc) || sc->print_output) {
sc->print_flag = 1;
sc->args = sc->value;
s_goto(sc,OP_P0LIST);
@@ -3144,16 +3163,63 @@
return sc->T;
}
+static int is_list(scheme *sc, pointer a) {
+ pointer slow, fast;
+
+ slow = fast = a;
+ while (1)
+ {
+ if (fast == sc->NIL)
+ return 1;
+ if (!is_pair(fast))
+ return 0;
+ fast = cdr(fast);
+ if (fast == sc->NIL)
+ return 1;
+ if (!is_pair(fast))
+ return 0;
+ fast = cdr(fast);
+
+ slow = cdr(slow);
+ if (fast == slow)
+ {
+ /* the fast pointer has looped back around and caught up
+ with the slow pointer, hence the structure is circular,
+ not of finite length, and therefore not a list */
+ return 0;
+ }
+ }
+}
+
static int list_length(scheme *sc, pointer a) {
- int v=0;
- pointer x;
- for (x = a, v = 0; is_pair(x); x = cdr(x)) {
- ++v;
- }
- if(x==sc->NIL) {
- return v;
- }
- return -1;
+ int i=0;
+ pointer slow, fast;
+
+ slow = fast = a;
+ while (1)
+ {
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return i;
+ fast = cdr(fast);
+ ++i;
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return i;
+ ++i;
+ fast = cdr(fast);
+
+ slow = cdr(slow);
+ if (fast == slow)
+ {
+ /* the fast pointer has looped back around and caught up
+ with the slow pointer, hence the structure is circular,
+ not of finite length, and therefore not a list */
+ return -1;
+ }
+ }
}
static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
@@ -3233,23 +3299,8 @@
|| is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
case OP_PAIRP: /* pair? */
s_retbool(is_pair(car(sc->args)));
- case OP_LISTP: { /* list? */
- pointer slow, fast;
- slow = fast = car(sc->args);
- while (1) {
- if (!is_pair(fast)) s_retbool(fast == sc->NIL);
- fast = cdr(fast);
- if (!is_pair(fast)) s_retbool(fast == sc->NIL);
- fast = cdr(fast);
- slow = cdr(slow);
- if (fast == slow) {
- /* the fast pointer has looped back around and caught up
- with the slow pointer, hence the structure is circular,
- not of finite length, and therefore not a list */
- s_retbool(0);
- }
- }
- }
+ case OP_LISTP: /* list? */
+ s_retbool(is_list(sc, car(sc->args)));
case OP_ENVP: /* environment? */
s_retbool(is_environment(car(sc->args)));
case OP_VECTORP: /* vector? */
@@ -3319,6 +3370,9 @@
sc->args=cons(sc,mk_string(sc," -- "),sc->args);
setimmutable(car(sc->args));
}
+ if (sc->print_error == 0) /* Reset buffer if not already */
+ sc->linebuff[0] = '\0'; /* in error message output mode*/
+ sc->print_error = 1;
putstr(sc, "Error: ");
putstr(sc, strvalue(car(sc->args)));
sc->args = cdr(sc->args);
@@ -3333,6 +3387,7 @@
s_goto(sc,OP_P0LIST);
} else {
putstr(sc, "\n");
+ sc->print_error = 0;
if(sc->interactive_repl) {
s_goto(sc,OP_T0LVL);
} else {
@@ -3601,7 +3656,15 @@
case TOK_ATOM:
s_return(sc,mk_atom(sc, readstr_upto(sc, "();\t\n\r ")));
case TOK_DQUOTE:
- x=readstrexp(sc);
+ case TOK_TQUOTE:
+ if (sc->tok == TOK_DQUOTE)
+ x=readstrexp(sc);
+ else {
+ char *s;
+ s = readstr_upto(sc, "\"");
+ (void)inchar(sc); /* Swallow the terminating " char */
+ x=mk_string(sc, gettext(s));
+ }
if(x==sc->F) {
Error_0(sc,"Error reading string");
}
@@ -3646,7 +3709,7 @@
sc->tok = token(sc);
s_goto(sc,OP_RDSEXPR);
} else {
- s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
+ s_save(sc,OP_RDLIST, sc->args, sc->NIL);
s_goto(sc,OP_RDSEXPR);
}
}
@@ -4060,10 +4123,12 @@
mk_character,
mk_vector,
mk_foreign_func,
+ mk_closure,
putstr,
putcharacter,
is_string,
+ string_length,
string_value,
is_number,
nvalue,
@@ -4073,12 +4138,15 @@
is_real,
is_character,
charvalue,
+ is_list,
is_vector,
+ list_length,
ivalue,
fill_vector,
vector_elem,
set_vector_elem,
is_port,
+
is_pair,
pair_car,
pair_cdr,
@@ -4163,6 +4231,7 @@
sc->loadport=sc->NIL;
sc->nesting=0;
sc->interactive_repl=0;
+ sc->print_output=0;
if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
sc->no_memory=1;
@@ -4423,9 +4492,9 @@
fprintf(stderr,"Could not open file %s\n",file_name);
} else {
if(isfile) {
- scheme_load_file(&sc,fin);
+ scheme_load_file(&sc,fin);
} else {
- scheme_load_string(&sc,file_name);
+ scheme_load_string(&sc,file_name);
}
if(!isfile || fin!=stdin) {
if(sc.retcode!=0) {
--- tinyscheme-1.35/scheme.h 2004-06-07 02:56:51.000000000 -0400
+++ tinyscheme/scheme.h 2004-06-25 23:11:04.000000000 -0400
@@ -13,8 +13,6 @@
#endif
#ifndef _MSC_VER
-# define USE_STRCASECMP 1
-# define USE_STRLWR 1
# define SCHEME_EXPORT
#else
# define USE_STRCASECMP 0
@@ -161,10 +159,12 @@
pointer (*mk_character)(scheme *sc, int c);
pointer (*mk_vector)(scheme *sc, int len);
pointer (*mk_foreign_func)(scheme *sc, foreign_func f);
+ pointer (*mk_closure)(scheme *sc, pointer c, pointer e);
void (*putstr)(scheme *sc, const char *s);
void (*putcharacter)(scheme *sc, int c);
int (*is_string)(pointer p);
+ int (*string_length)(pointer p);
char *(*string_value)(pointer p);
int (*is_number)(pointer p);
num (*nvalue)(pointer p);
@@ -174,7 +174,9 @@
int (*is_real)(pointer p);
int (*is_character)(pointer p);
long (*charvalue)(pointer p);
+ int (*is_list)(scheme *sc, pointer p);
int (*is_vector)(pointer p);
+ int (*list_length)(scheme *sc, pointer a);
long (*vector_length)(pointer vec);
void (*fill_vector)(pointer vec, pointer elem);
pointer (*vector_elem)(pointer vec, int ielem);
@@ -204,6 +206,7 @@
int (*is_environment)(pointer p);
int (*is_immutable)(pointer p);
void (*setimmutable)(pointer p);
+
void (*load_file)(scheme *sc, FILE *fin);
void (*load_string)(scheme *sc, const char *input);
};
--- tinyscheme-1.35/scheme-private.h 2004-06-07 02:56:51.000000000 -0400
+++ tinyscheme/scheme-private.h 2004-06-28 19:19:41.000000000 -0400
@@ -71,6 +71,8 @@
pointer dump; /* stack register for next evaluation */
int interactive_repl; /* are we in an interactive REPL? */
+int print_output; /* set to 1 to print results and error messages */
+int print_error; /* set to 1 while printing error messages */
struct cell _sink;
pointer sink; /* when mem. alloc. fails */
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment