--- old/CHANGELOG Fri Aug 12 13:47:51 2005 +++ CHANGELOG Sat Aug 13 20:44:19 2005 @@ -38,3 +38,13 @@ exit-loop now takes optional arguments whose progn is the loop's return value. Added unique-word function to word.c and switch macro to preload.lisp. Cleaned up Makefile. +Words which are eqv? are now always eq? as well. + +2005-08-13: 1.5: Declared tryit() static. +read_object() now checks that the given stream is readable. +Fixed substring()'s behavior when length<=0 or offset<0. +Substring now accepts #f for length to go to the end of the string. +Changed the return value of macro-define to be the macro's name. +Changed dprint to allow for multiple arguments. +Removed many uses of real_eqv as eqv? words are now eq?. +Implemented eqv? in preload.lisp and removed it from the .h and .c's. --- old/Makefile Fri Aug 12 13:41:21 2005 +++ Makefile Fri Aug 12 13:49:53 2005 @@ -3,7 +3,7 @@ CFLAGS=-O2 -Wall -Werror SRCS=builtin.c cons.c func.c integer.c main.c nil.c quote.c rawfunc.c reader.c scope.c stream.c string.c throw.c util.c word.c BUILDDIR=obj/ -VERSION=1.4 +VERSION=1.5 -include .local.Makefile $(BUILDDIR)mikelisp : $(SRCS:%.c=$(BUILDDIR)%.o) lisp.h --- old/lisp.h Fri Aug 12 13:30:56 2005 +++ lisp.h Sat Aug 13 20:41:37 2005 @@ -1,4 +1,4 @@ -/* lisp.h by Michael Thorpe 2005-08-12 */ +/* lisp.h by Michael Thorpe 2005-08-13 */ #ifndef OBJ_H #define OBJ_H @@ -17,7 +17,6 @@ void (*dropobj)(obj *); /* Called when object is to be discarded */ obj *(*evaluate)(scope *,obj *); obj *(*applyfunc)(scope *,obj *,obj *); - int (*eqv)(obj *,obj *); }; union rawfuncptr { @@ -185,7 +184,6 @@ void drop_object(obj *o); obj *evaluate(scope *scope,obj *o); obj *newobj(objtype *type); -int real_eqv(obj *o1,obj *o2); int register_objtype(objtype *type); #ifdef DEBUG void show_remaining_objects(); --- old/builtin.c Wed Aug 10 14:43:47 2005 +++ builtin.c Sat Aug 13 20:41:51 2005 @@ -1,4 +1,4 @@ -/* builtin.c by Michael Thorpe 2005-08-10 */ +/* builtin.c by Michael Thorpe 2005-08-13 */ #include #include @@ -145,15 +145,6 @@ return(incref((a==b)?&trueobj:&nilobj)); } -static obj *eqv(obj *a,obj *b) { - int i; - - i=real_eqv(a,b); - decref(a); - decref(b); - return(incref(i?&trueobj:&nilobj)); -} - static obj *ifelse(scope *s,obj *cond,obj *iftrue,obj *iffalse) { decref(cond); if(cond==&nilobj) { @@ -224,7 +215,7 @@ decref(p); continue; } - if(!real_eqv(exception,nextloop)) + if(exception != nextloop) break; decref(exception); exception=incref(&nilobj); @@ -233,7 +224,7 @@ } decref(o); decscoperef(s); - if(real_eqv(exception,exitloop)) { + if(exception==exitloop) { decref(exception); exception=incref(&nilobj); p=exceptionvalue; @@ -441,7 +432,6 @@ || store_builtin_ns2("bit-or",bitor) || store_builtin_ns2("bit-xor",bitxor) || store_builtin_ns2("eq?",eq) - || store_builtin_ns2("eqv?",eqv) || store_builtin_s3("#ifelse",ifelse) || store_builtin_ns1("isascii",isasciip) || store_builtin_ns1("isdigit",isdigitp) --- old/cons.c Fri Aug 12 10:01:37 2005 +++ cons.c Sat Aug 13 20:42:00 2005 @@ -1,4 +1,4 @@ -/* cons.c by Michael Thorpe 2005-08-12 */ +/* cons.c by Michael Thorpe 2005-08-13 */ #include #include @@ -170,10 +170,6 @@ return(c); } -static int cons_eqv(obj *o1,obj *o2) { - return(real_eqv(o1->value.c.a,o2->value.c.a) && real_eqv(o1->value.c.d,o2->value.c.d)); -} - int cons_init() { if(store_builtin_ns1("car",car) || store_builtin_ns1("cdr",cdr) @@ -186,7 +182,6 @@ name: "cons", tostring: cons_tostring, dropobj: decref_cons, - evaluate: cons_evaluate, - eqv: cons_eqv + evaluate: cons_evaluate }; --- old/func.c Fri Aug 12 09:55:51 2005 +++ func.c Sat Aug 13 20:42:09 2005 @@ -1,4 +1,4 @@ -/* func.c by Michael Thorpe 2005-08-12 */ +/* func.c by Michael Thorpe 2005-08-13 */ #include #include "lisp.h" @@ -97,10 +97,6 @@ return(prog); } -static int func_eqv(obj *o1,obj *o2) { - return(real_eqv(o1->value.func.args,o2->value.func.args) && real_eqv(o1->value.func.prog,o2->value.func.prog)); -} - int func_init() { if(store_builtin_ns1("args-of-func",args_of_func) || store_builtin_ns1("prog-of-func",prog_of_func)) @@ -112,6 +108,5 @@ name: "func", tostring: func_tostring, dropobj: drop_func, - applyfunc: applyfunc, - eqv: func_eqv + applyfunc: applyfunc }; --- old/integer.c Fri Aug 12 11:21:57 2005 +++ integer.c Sat Aug 13 20:42:49 2005 @@ -1,4 +1,4 @@ -/* integer.c by Michael Thorpe 2005-08-12 */ +/* integer.c by Michael Thorpe 2005-08-13 */ #include #include "lisp.h" @@ -16,14 +16,9 @@ return(out); } -static int integer_eqv(obj *o1,obj *o2) { - return(o1->value.i==o2->value.i); -} - objtype integer_objtype={ name: "integer", - tostring: integer_tostring, - eqv: integer_eqv + tostring: integer_tostring }; obj trueobj={&integer_objtype,{refcount:1},{i:1}}; --- old/main.c Fri Aug 12 13:31:10 2005 +++ main.c Sat Aug 13 19:55:06 2005 @@ -1,9 +1,9 @@ -/* main.c by Michael Thorpe 2005-08-12 */ +/* main.c by Michael Thorpe 2005-08-13 */ #include #include "lisp.h" -int tryit() { +static int tryit() { obj *s,*o; FILE *f; @@ -25,7 +25,7 @@ return(1); while(1) { o=read_object(incref(s)); - if(!o && real_eqv(exception,eoferror)) { + if(!o && exception==eoferror) { decref(exception); decref(exceptionvalue); exception=incref(&nilobj); --- old/quote.c Fri Aug 12 10:00:36 2005 +++ quote.c Sat Aug 13 20:42:22 2005 @@ -1,4 +1,4 @@ -/* quote.c by Michael Thorpe 2005-08-12 */ +/* quote.c by Michael Thorpe 2005-08-13 */ #include #include "lisp.h" @@ -45,10 +45,6 @@ return(q); } -static int quote_eqv(obj *o1,obj *o2) { - return(real_eqv(o1->value.o,o2->value.o)); -} - int quote_init() { if(store_builtin_ns1("quote",quoteobj)) return(1); @@ -59,7 +55,6 @@ name: "quote", tostring: quote_tostring, dropobj: drop_quote, - evaluate: quote_evaluate, - eqv: quote_eqv + evaluate: quote_evaluate }; --- old/reader.c Wed Aug 10 14:57:57 2005 +++ reader.c Sat Aug 13 19:57:16 2005 @@ -1,4 +1,4 @@ -/* reader.c by Michael Thorpe 2005-08-10 */ +/* reader.c by Michael Thorpe 2005-08-13 */ #include #include @@ -11,7 +11,7 @@ o=read_object(incref(stream)); if(!o) { - if(real_eqv(exception,eoferror)) + if(exception==eoferror) return(throw(incref(reader_error),stream)); decref(stream); return(0); @@ -25,21 +25,21 @@ tmp1=read_object(incref(stream)); if(!tmp1) { - if(real_eqv(exception,eoferror)) + if(exception==eoferror) return(throw(incref(reader_error),stream)); decref(stream); return(0); } - if(!real_eqv(tmp1,close_paren)) { + if(tmp1 != close_paren) { tmp2=read_object(incref(stream)); if(!tmp2) { decref(tmp1); - if(real_eqv(exception,eoferror)) + if(exception==eoferror) return(throw(incref(reader_error),stream)); decref(stream); return(0); } - if(real_eqv(tmp2,close_paren)) { + if(tmp2==close_paren) { decref(stream); decref(tmp2); return(tmp1); @@ -61,16 +61,16 @@ CDR(cur)=incref(&nilobj); decref(start); } - if(real_eqv(exception,eoferror)) + if(exception==eoferror) return(throw(incref(reader_error),stream)); decref(stream); return(0); } - if(real_eqv(tmp,close_paren)) { + if(tmp==close_paren) { decref(tmp); break; } - if(real_eqv(tmp,dot_word)) { + if(tmp==dot_word) { decref(tmp); if(!cur) return(throw(incref(reader_error),stream)); @@ -171,6 +171,8 @@ if(stream->type != &stream_objtype) return(throwtypeerror(stream)); + if(!stream->value.stream.readable) + return(throwaccesserror(stream)); while(1) { c=real_speekc(stream); if(c==-1) { --- old/scope.c Wed Aug 10 14:58:55 2005 +++ scope.c Sat Aug 13 19:57:11 2005 @@ -1,4 +1,4 @@ -/* scope.c by Michael Thorpe 2005-08-10 */ +/* scope.c by Michael Thorpe 2005-08-13 */ #include #include @@ -29,7 +29,7 @@ scope=globalscope; while(scope) { for(e=scope->firstentry;e;e=e->next) - if(real_eqv(e->name,name)) + if(e->name==name) return(e); scope=scope->parent; } --- old/string.c Fri Aug 12 09:56:28 2005 +++ string.c Sat Aug 13 20:42:58 2005 @@ -1,4 +1,4 @@ -/* string.c by Michael Thorpe 2005-08-12 */ +/* string.c by Michael Thorpe 2005-08-13 */ #include #include @@ -144,44 +144,50 @@ static obj *substring(obj *str,obj *offobj,obj *lenobj) { obj *substr; - unsigned long off,len; + signed long off,len; + int no_truncate=0; - if(str->type != &string_objtype) { + if(&string_objtype != str->type) { decref(offobj); decref(lenobj); return(throwtypeerror(str)); } - if(offobj->type != &integer_objtype) { + if(&integer_objtype==offobj->type) { + off=offobj->value.i; + } else { decref(str); decref(lenobj); return(throwtypeerror(offobj)); } - if(lenobj->type != &integer_objtype) { + if(&nilobj==lenobj) { + no_truncate=1; + len=0; + } else if(&integer_objtype==lenobj->type) { + len=lenobj->value.i; + } else { decref(str); decref(offobj); return(throwtypeerror(lenobj)); } - off=offobj->value.i; - len=lenobj->value.i; if(off<0) off+=str->value.s.len; - if(len<=0) - len=str->value.s.len-off-len; if(off<0 || off>str->value.s.len) { decref(lenobj); decref(str); return(throwrangecheck(offobj)); } decref(offobj); + if(no_truncate || len<0) + len+=str->value.s.len-off; if(len<0) { decref(str); return(throwrangecheck(lenobj)); } - decref(lenobj); if(off+len<0 || off+len>str->value.s.len) { decref(str); - return(throwrangecheck(incref(&nilobj))); + return(throwrangecheck(lenobj)); } + decref(lenobj); substr=real_new_string(str->value.s.data+off,len); decref(str); return(substr); @@ -220,14 +226,6 @@ return(r); } -static int string_eqv(obj *o1,obj *o2) { - if(o1->value.s.len != o2->value.s.len) - return(0); - if(!memcmp(o1->value.s.data,o2->value.s.data,o1->value.s.len)) - return(1); - return(0); -} - int string_init() { if(store_builtin_ns2("get-char",get_char) || store_builtin_ns1("new-string",new_string) @@ -243,7 +241,6 @@ objtype string_objtype={ name: "string", tostring: string_tostring, - dropobj: drop_string, - eqv: string_eqv + dropobj: drop_string }; --- old/throw.c Wed Aug 10 15:05:30 2005 +++ throw.c Sat Aug 13 19:58:15 2005 @@ -1,4 +1,4 @@ -/* throw.c by Michael Thorpe 2005-08-10 */ +/* throw.c by Michael Thorpe 2005-08-13 */ #include "lisp.h" @@ -15,7 +15,7 @@ obj *e,*o,*tmp; o=evaluate(incscoperef(s),func); - if(!o && (type->type==&nil_objtype || real_eqv(type,exception))) { + if(!o && (type==exception || type==&nilobj)) { decref(type); s=newscope(s); if(!s) { --- old/util.c Fri Aug 12 09:52:34 2005 +++ util.c Sat Aug 13 20:42:32 2005 @@ -1,4 +1,4 @@ -/* util.c by Michael Thorpe 2005-08-12 */ +/* util.c by Michael Thorpe 2005-08-13 */ #include #include @@ -99,16 +99,6 @@ firstobj=o; #endif return(o); -} - -int real_eqv(obj *o1,obj *o2) { - if(o1==o2) - return(1); - if(o1->type != o2->type) - return(0); - if(!o1->type->eqv) - return(0); - return((o1->type->eqv)(o1,o2)); } int register_objtype(objtype *type) { --- old/preload.lisp Fri Aug 12 13:33:32 2005 +++ preload.lisp Sat Aug 13 20:40:44 2005 @@ -1,4 +1,4 @@ -; preload.lisp by Michael Thorpe 2005-08-12 +; preload.lisp by Michael Thorpe 2005-08-13 (#define '#f (= 1 2)) (#define '#t (= 1 1)) @@ -9,7 +9,7 @@ (#define 'get (#lambda '(hash item) '(#ifelse hash - '(#ifelse (eqv? (car (car hash)) item) + '(#ifelse (eq? (car (car hash)) item) '(cdr (car hash)) '(get (cdr hash) item)) '#f))) @@ -35,7 +35,9 @@ 'o))) (#define '#macro-define (#lambda '(macro func) - '(#define 'macroexpansions (cons (cons macro func) macroexpansions)))) + '(#prog2of2 + (#define 'macroexpansions (cons (cons macro func) macroexpansions)) + 'macro))) (#macro-define 'define (#lambda '(name . value) @@ -95,14 +97,6 @@ ;;; From this point on we're operating on our own repl (minus the printing) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (write-newline file) - (write-char file 10)) -(define (write-object file obj) - (write-string file (->string obj))) -(define (dprint o) - (write-object #standard-out o) - (write-newline #standard-out)) - (macro-define (+ . aaa) (ifelse (pair? (cdr aaa)) (ifelse (pair? (cdr (cdr aaa))) @@ -171,6 +165,19 @@ (define (append oldlist newtail) (reverse (reverse/append oldlist newtail))) +(define (write-newline file) + (write-char file 10)) +(define (write-object file obj) + (write-string file (->string obj))) +(define (dprint . o) + (while o + (write-object #standard-out (car o)) + (define-local o (cdr o)) + (if o + (write-char #standard-out 32))) + (write-newline #standard-out) + #f) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Now we reimplement the reader and read-object ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -196,6 +203,12 @@ (define (define-character-macro char macro) (define character-macros (cons (cons char macro) character-macros))) +(define (get-using-= hash item) + (while hash + (if (= (car (car hash)) item) + (exit-loop (cdr (car hash)))) + (define hash (cdr hash)))) + (define (expand-string oldstring) (define-local newstring (new-string (+ 512 (string-length oldstring)))) (define-local i 0) @@ -336,7 +349,7 @@ (exit-loop)) (unless (isascii c) (exit-loop)) - (if (get character-macros c) + (if (get-using-= character-macros c) (exit-loop)) (define-local c (read-char stream))) (define buffer (substring buffer 0 i)) @@ -350,7 +363,7 @@ (define-local c (read-char stream))) (unless (isascii c) (throw 'reader-error stream)) - (define macro (get character-macros c)) + (define macro (get-using-= character-macros c)) (ifelse macro (macro stream) (read-token stream c))) @@ -384,7 +397,7 @@ ; (define (switch-handle var cases) (ifelse cases - (ifelse (eqv? 'else (caar cases)) + (ifelse (eq? 'else (caar cases)) (cons 'progn (cdar cases)) (ifelse (caar cases) `(ifelse (eqv? ,var ,(caaar cases)) @@ -400,6 +413,44 @@ `(progn (define-local ,var ,key) ,(switch-handle var cases))) + +(define (string-equivalent a b) + (define-local c (string-length a)) + (ifelse (= c (string-length b)) + (loop + (if (= c 0) + (exit-loop #t)) + (define-local c (- c 1)) + (if (<> (get-char a c) (get-char b c)) + (exit-loop #f))) + #f)) +; This short-circuit macro is necessary to prevent switch/eqv? from getting +; into an endless mutual recursion loop: +(macro-define (eqv? a b) + (ifelse + (or + (and (eq? 'quote (object-type a)) (eq? 'word (object-type (evaluate a)))) + (and (eq? 'quote (object-type b)) (eq? 'word (object-type (evaluate b))))) + (list 'eq? a b) + dont-macro-expand)) +(define (eqv? a b) + (ifelse (eq? a b) + #t + (ifelse (eq? (object-type a) (object-type b)) + (switch (object-type a) + (('integer) + (= a b)) + (('cons) + (and + (eqv? (car a) (car b)) + (eqv? (cdr a) (cdr b)))) + (('quote) + (eqv? (evaluate a) (evaluate b))) + (('string) + (string-equivalent a b)) + (else + #f)) + #f))) (define (cars arg) ; ((1 2) (3 4)) => (1 3) (define-local stack '())