From 8dc87ec18f9b2f7ff8daec3b56fc4542ab28054b Mon Sep 17 00:00:00 2001 From: ESL Date: Sun, 26 Mar 2023 14:52:30 -0400 Subject: [PATCH] (read) added! --- i.c | 8 ++ i.h | 1 + s.c | 127 ++++++++++++++++++++ src/s.scm | 339 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 473 insertions(+), 2 deletions(-) diff --git a/i.c b/i.c index 8bdf231..082ed9d 100644 --- a/i.c +++ b/i.c @@ -1143,6 +1143,14 @@ define_instruction(ssub) { gonexti(); } +define_instruction(spos) { + obj x = ac, y = spop(); char *s, *p; + ckc(x); cks(y); + s = stringchars(y), p = strchr(s, char_from_obj(x)); + ac = p ? fixnum_obj(p-s) : bool_obj(0); + gonexti(); +} + define_instruction(bvecp) { ac = bool_obj(isbytevector(ac)); diff --git a/i.h b/i.h index 19ba4a0..f6dfeae 100644 --- a/i.h +++ b/i.h @@ -403,6 +403,7 @@ declare_instruction(sget, "S4", 0, "string-ref", '2', declare_instruction(sput, "S5", 0, "string-set!", '3', AUTOGL) declare_instruction(scat, "S6", 0, "string-cat", '2', AUTOGL) declare_instruction(ssub, "S7", 0, "substring", '3', AUTOGL) +declare_instruction(spos, "S8", 0, "string-position", '2', AUTOGL) declare_instruction(seq, "S=", 0, "string=?", 'c', AUTOGL) declare_instruction(slt, "S<", 0, "string", 0, "string>?", 'c', AUTOGL) diff --git a/s.c b/s.c index 68994e9..34371b5 100644 --- a/s.c +++ b/s.c @@ -539,5 +539,132 @@ char *s_code[] = { "&0{%2.1,.1,@(y14:read-substring)[22}%x,&0{%1P10,.1,@(y14:read-substrin" "g)[12}%x,&2{|10|21%%}@!(y11:read-string)", + "P", "%read", + "%2,,,,,,,,,,,,,,,,,,,,,,#0#1#2#3#4#5#6#7#8#9#(i10)#(i11)#(i12)#(i13)#(" + "i14)#(i15)#(i16)#(i17)#(i18)#(i19)#(i20)#(i21)n.!0&0{%1.0,&1{%0:0z]0}]" + "1}.!1&0{%1.0K0]1}.!2.3,&1{%1.0K0?{${.2[00},:0^[11}.0]1}.!3.4,.4,&2{%1." + "0p?{.0aK0?{${.2a,:0^[01},.1sa}{${.2a,:1^[01}}.0dK0?{${.2d,:0^[01},.1sd" + "]1}.0d,:1^[11}.0V0?{'0,,#0.2,:0,:1,.3,&4{%1:3V3,.1I?^_~0123456789+-.@),.1S8]1}.!(i11)&" + "0{%1.0X8,'(i48),.1!}{f},.0?{.0]3}'(i65),.2" + "!}{f},.0?{.0]4}'(i97),.3!]4}f]4}.!(i12)&0{%1.0C1,.0?{.0" + "]2}'(c)),.2C=,.0?{.0]3}'(c(),.3C=,.0?{.0]4}'(c]),.4C=,.0?{.0]5}'(c[),." + "5C=,.0?{.0]6}'(c%22),.6C=,.0?{.0]7}'(c;),.7C=]7}.!(i13).(i15),.(i11),&" + "2{%1${.2,:1^[01},.0R8?{.1,'(y5:port:),'(s22:unexpected end of file),@(" + "y10:read-error)[23}${.2,:0^[01}?{.1,'(y5:port:),.2d,'(s17:unexpected t" + "oken:),@(y10:read-error)[24}.0]2}.!(i14).8,.(i12),.(i20),.(i24),.(i19)" + ",.(i12),.(i22),.(i24),.(i27),.(i22),.(i12),.(i25),.(i13),.(i13),.(i37)" + ",&(i15){%1.0R0,.0R8?{.0]2}.0C1?{.1,:(i10)^[21}'(c(),.1C=?{t,:9^,.3,.3," + ":8^[24}'(c)),.1C=?{:9^]2}'(c[),.1C=?{t,:(i14)^,.3,.3,:8^[24}'(c]),.1C=" + "?{:(i14)^]2}'(c'),.1C=?{${.3,:3^[01},'(y5:quote),l2]2}'(c`),.1C=?{${.3" + ",:3^[01},'(y10:quasiquote),l2]2}${.2,:(i13)^[01}?{.1,.1,:(i11)^[22}'(c" + ";),.1C=?{${.3R0,,#0.5,.1,&2{%1.0R8,.0?{.0]2}'(c%0a),.2C=,.0?{.0]3}:1R0" + ",:0^[31}.!0.0^_1[01}.1,:(i10)^[21}'(c,),.1C=?{.1R1,.0R8?{.2,'(y5:port:" + "),'(s19:end of file after ,),@(y10:read-error)[33}'(c@),.1C=?{.2R0${.4" + ",:3^[01},'(y16:unquote-splicing),l2]3}${.4,:3^[01},'(y7:unquote),l2]3}" + "'(c%22),.1C=?{n,,#0.3,:(i12),.2,&3{%1:2R0,.0R8?{:2,'(y5:port:),'(s27:e" + "nd of file within a string),@(y10:read-error)[23}'(c%5c),.1C=?{${'(y6:" + "string),:2,:1^[02},.0?{.2,.1c}{.2},:0^[31}'(c%22),.1C=?{.1A9X3]2}.1,.1" + "c,:0^[21}.!0.0^_1[21}'(c|),.1C=?{n,,#0.3,:(i12),.2,&3{%1:2R0,.0R8?{:2," + "'(y5:port:),'(s29:end of file within a |symbol|),@(y10:read-error)[23}" + "'(c%5c),.1C=?{${'(y6:symbol),:2,:1^[02},.0?{.2,.1c}{.2},:0^[31}'(c|),." + "1C=?{.1A9X3X5]2}.1,.1c,:0^[21}.!0.0^_1[21}'(c#),.1C=?{.1R1,.0R8?{.2,'(" + "y5:port:),'(s19:end of file after #),@(y10:read-error)[33}'(ct),.1Ci=," + ".0?{.0}{'(cf),.2Ci=}_1?{${.4,:3^[01},.0,'(l2:y1:t;y4:true;),.1A1?{t]5}" + "'(l2:y1:f;y5:false;),.1A1?{f]5}.4,'(y5:port:),.3,'(s23:unexpected name" + " after #),@(y10:read-error)[54}'(cb),.1Ci=,.0?{.0}{'(co),.2Ci=,.0?{.0}" + "{'(cd),.3Ci=,.0?{.0}{'(cx),.4Ci=,.0?{.0}{'(ci),.5Ci=,.0?{.0}{'(ce),.6C" + "i=}_1}_1}_1}_1}_1?{.2,'(c#),:(i11)^[32}'(c&),.1C=?{.2R0${.4,:3^[01}b]3" + "}'(c;),.1C=?{.2R0${.4,:3^[01}.2,:(i10)^[31}'(c|),.1C=?{.2R0${,#0.5,.1," + "&2{%0:1R0,.0R8?{:1,'(y5:port:),'(s25:end of file in #| comment),@(y10:" + "read-error)[13}'(c|),.1C=?{:1R1,.0R8?{:1,'(y5:port:),'(s25:end of file" + " in #| comment),@(y10:read-error)[23}'(c#),.1C=?{:1R0]2}:0^[20}'(c#),." + "1C=?{:1R1,.0R8?{:1,'(y5:port:),'(s25:end of file in #| comment),@(y10:" + "read-error)[23}'(c|),.1C=?{:1R0${:0^[00}:0^[20}:0^[20}:0^[10}.!0.0^_1[" + "00}.2,:(i10)^[31}'(c(),.1C=?{.2R0${f,:9^,.6,.5,:8^[04}X1]3}'(cu),.1C=?" + "{.2R0'(c8),.3R0q?{'(c(),.3R0q}{f}?{${.4,:7^[01}E1]3}.2,'(y5:port:),'(s" + "25:invalid bytevector syntax),@(y10:read-error)[33}'(c%5c),.1C=?{.2R0." + "2R1,.0R8?{.3,'(y5:port:),'(s20:end of file after #%5c),@(y10:read-erro" + "r)[43}.0,'(cx)C=?{.3R0${.5R1,:5^[01}?{.0]4}f,.4,:6^[42}.0C4?{${.5,:3^[" + "01},'1,.1X4S3=?{.1]5}.0,'(y4:null),.1v?{'0X9]6}'(y5:space),.1v?{'(c )]" + "6}'(y5:alarm),.1v?{'(c%07)]6}'(y9:backspace),.1v?{'(c%08)]6}'(y6:delet" + "e),.1v?{'(i127)X9]6}'(y6:escape),.1v?{'(i27)X9]6}'(y3:tab),.1v?{'(c%09" + ")]6}'(l2:y7:newline;y8:linefeed;),.1A1?{'(c%0a)]6}'(y4:vtab),.1v?{'(c%" + "0b)]6}'(y4:page),.1v?{'(c%0c)]6}'(y6:return),.1v?{'(c%0d)]6}.5,'(y5:po" + "rt:),.3,'(s15:unknown #%5c name),@(y10:read-error)[64}.3R0.0]4}.0C5?{:" + "0?{${.4,'(y5:port:),'(s44:#N=/#N# notation is not allowed in this mode" + "),@(y10:read-error)[03}}n,,#0.4,.1,:4,:3,:2,:1,&6{%1:5R0,.0R8?{:5,'(y5" + ":port:),'(s32:end of file within a #N notation),@(y10:read-error)[23}." + "0C5?{.1,.1c,:4^[21}'(c#),.1C=?{.1A9X3,'(i10),.1E9,.0I0?{:0^,.1A3}{f},." + "0?{.0d]5}'(s22:unknown #n# reference:),'(y5:port:),.4,@(y10:read-error" + ")[53}'(c=),.1C=?{.1A9X3,'(i10),.1E9,.0I0~?{${'(s22:invalid #n= referen" + "ce:),'(y5:port:),.5,@(y10:read-error)[03}}{:0^,.1A3?{${'(s18:duplicate" + " #n= tag:),'(y5:port:),.4,@(y10:read-error)[03}}{f}}fb,:0^,${.3,:1^[01" + "},.3cc:!0${:5,:2^[01},${.2,:3^[01}?{'(s31:#n= has another label as tar" + "get),'(y5:port:),.5,@(y10:read-error)[63}.0,.2sz.0]6}:5,'(y5:port:),'(" + "s34:invalid terminator for #N notation),@(y10:read-error)[23}.!0.0^_1[" + "31}.2,'(y5:port:),.2,'(s16:unknown # syntax),@(y10:read-error)[34}.1,'" + "(y5:port:),.2,'(s22:illegal character read),@(y10:read-error)[24}.!(i1" + "5).(i15),.(i11),.(i16),.(i12),&4{%4${.3,:3^[01},:0^,.1q?{.2,'(y5:port:" + "),'(s42:missing car -- ( immediately followed by .),@(y10:read-error)[" + "53}.0,,#0.0,.5,:3,:2,.(i10),:1,.(i11),:0,&8{%1.0R8?{:6,'(y5:port:),'(s" + "41:eof inside list -- unbalanced parentheses),@(y10:read-error)[13}:1," + ".1q?{n]1}:0^,.1q?{:3?{${:6,:2^[01},${:6,:5^[01},:1,.1q?{.1]3}:6,'(y5:p" + "ort:),.2,'(s31:randomness after form after dot),@(y10:read-error)[34}:" + "6,'(y5:port:),'(s13:dot in #(...)),@(y10:read-error)[13}${.2,:4^[01}?{" + ":6,'(y5:port:),.2d,'(s20:error inside list --),@(y10:read-error)[14}${" + "${:6,:5^[01},:7^[01},.1c]1}.!0.0^_1[51}.!(i16).(i15),.8,.(i12),&3{%1${" + ".2,:2^[01},,#0.0,.3,:2,:0,:1,&5{%1.0R8?{:3,'(y5:port:),'(s21:eof insid" + "e bytevector),@(y10:read-error)[13}:0^,.1q?{n]1}${.2,:1^[01}?{:3,'(y5:" + "port:),.2d,'(s26:error inside bytevector --),@(y10:read-error)[14}.0I0" + "~,.0?{.0}{'0,.2I<,.0?{.0}{'(i255),.3I>}_1}_1?{:3,'(y5:port:),.2,'(s33:" + "invalid byte inside bytevector --),@(y10:read-error)[14}${${:3,:2^[01}" + ",:4^[01},.1c]1}.!0.0^_1[11}.!(i17).(i19),&1{%2.0R0,.0R8?{${.3,'(y5:por" + "t:),.6,'(s20:end of file within a),@(y10:read-error)[04}}'(c%5c),.1C=," + ".0?{.0}{'(c%22),.2C=,.0?{.0}{'(c|),.3C=}_1}_1?{.0]3}'(ca),.1C=?{'(c%07" + ")]3}'(cb),.1C=?{'(c%08)]3}'(ct),.1C=?{'(c%09)]3}'(cn),.1C=?{'(c%0a)]3}" + "'(cv),.1C=?{'(c%0b)]3}'(cf),.1C=?{'(c%0c)]3}'(cr),.1C=?{'(c%0d)]3}'(cx" + "),.1C=?{t,.2,:0^[32}'(y6:string),.3q?{.0C1}{f}?{.1R1,'(c%0a),.2C=,,#0." + "0,.5,&2{%2.1R8,.0?{.0}{.2C1~}_1?{.0?{f]2}:0,'(y5:port:),'(s32:no newli" + "ne in line ending escape),@(y10:read-error)[23}.0?{'(c%0a),.2C=}{f}?{f" + "]2}:0R0:0R1,.1,.0?{.0}{'(c%0a),.4C=}_1,:1^[22}.!0.0^_1[32}.1,'(y5:port" + ":),.2,'(y1::),.6,'(s22:invalid char escape in),@(y10:read-error)[36}.!" + "(i18).(i13),.(i13),&2{%2,#0.1,&1{%1.0u?{:0,'(y5:port:),'(s31:%5cx esca" + "pe sequence is too short),@(y10:read-error)[13}'(i16),.1A9X3X7X9]1}.!0" + "'0,n,.3R1,,#0.0,.6,:0,.7,.(i10),:1,&6{%3.0R8?{:1?{:4,'(y5:port:),'(s27" + ":end of file within a string),@(y10:read-error)[33}.1,:2^[31}:1?{'(c;)" + ",.1C=}{f}?{:4R0.1,:2^[31}:1~?{${.2,:0^[01}}{f}?{.1,:2^[31}${.2,:3^[01}" + "~?{:4,'(y5:port:),.2,'(s37:unexpected char in %5cx escape sequence),@(" + "y10:read-error)[34}'2,.3>?{:4,'(y5:port:),'(s30:%5cx escape sequence i" + "s too long),@(y10:read-error)[33}:4R0'1,.3+,.2,.2c,:4R1,:5^[33}.!0.0^_" + "1[33}.!(i19)&0{%4.0,.0?{.0}{.2C5}_1?{f]4}'(s2:+i),.4Si=,.0?{.0}{'(s2:-" + "i),.5Si=}_1?{f]4}'(s6:+nan.0),.4Si=,.0?{.0}{'(s6:-nan.0),.5Si=}_1?{f]4" + "}'(s6:+inf.0),.4Si=,.0?{.0}{'(s6:-inf.0),.5Si=}_1?{f]4}'(c+),.2C=,.0?{" + ".0}{'(c-),.3C=}_1?{.2du?{t]4}'(c.),.3daC=?{.2ddp?{.2ddaC5~]4}f]4}.2daC" + "5~]4}'(c.),.2C=?{.2dp?{.2daC5~]4}f]4}f]4}.!(i20).(i13),.(i21),.(i11),." + "(i14),&4{%2'(c#),.1C=,.1,l1,.3R1,,#0.5,.1,:0,:1,:2,:3,&6{%3.0R8,.0?{.0" + "}{${.3,:0^[01}}_1?{.1A9,.0a,.1X3,.5,.0?{.0}{.2C5,.0?{.0}{'(c+),.4C=,.0" + "?{.0}{'(c-),.5C=,.0?{.0}{'(c.),.6C=}_1}_1}_1}_1?{'(s1:.),.1S=?{:2^]6}$" + "{.2,.5,.5,.(i10),:1^[04}?{.0X5]6}'(i10),.1E9,.0?{.0]7}:5,'(y5:port:),." + "3,'(s54:unsupported number syntax (implementation restriction)),@(y10:" + "read-error)[74}.0X5]6}'(c#),.1C=?{:5R0t,.2,.2c,:5R1,:4^[33}${.2,:3^[01" + "}?{:5R0.2,.2,.2c,:5R1,:4^[33}:5,'(y5:port:),.2,'(s29:unexpected number" + "/symbol char),@(y10:read-error)[34}.!0.0^_1[23}.!(i21)${.(i24),.(i18)^" + "[01},${.2,.(i14)^[01}~?{.1^u?{.0](i25)}.0,.7^[(i25)1}.(i23),'(y5:port:" + "),.2d,'(s17:unexpected token:),@(y10:read-error)[(i25)4", + + "C", 0, + "&0{%1f,.1,@(y5:%25read)[12}%x,&0{%0f,P10,@(y5:%25read)[02}%x,&2{|00|11" + "%%}@!(y4:read)", + + "C", 0, + "&0{%1t,.1,@(y5:%25read)[12}%x,&0{%0t,P10,@(y5:%25read)[02}%x,&2{|00|11" + "%%}@!(y11:read-simple)", + 0, 0, 0 }; diff --git a/src/s.scm b/src/s.scm index cfec1af..90e96ea 100644 --- a/src/s.scm +++ b/src/s.scm @@ -612,6 +612,7 @@ ; (%string->list1 s) + ; (string-cat s1 s2) + ; (substring s from to) +; (string-position s c) + ; (string-cmp s1 s2) + ; (string=? s1 s2 s ...) ; (string=? i end) (fx- i start) @@ -1154,6 +1153,342 @@ ;read-bytevector ;read-bytevector! +(define (%read port simple?) + (define-syntax r-error + (syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)])) ; see read-error below + + (define shared '()) + (define (make-shared-ref loc) (lambda () (unbox loc))) + (define (shared-ref? form) (procedure? form)) + (define (patch-ref! form) (if (procedure? form) (patch-ref! (form)) form)) + (define (patch-shared! form) + (cond [(pair? form) + (if (procedure? (car form)) + (set-car! form (patch-ref! (car form))) + (patch-shared! (car form))) + (if (procedure? (cdr form)) + (set-cdr! form (patch-ref! (cdr form))) + (patch-shared! (cdr form)))] + [(vector? form) + (let loop ([i 0]) + (when (fx?^_~0123456789+-.@")) + + (define (char-hex-digit? c) + (let ([scalar-value (char->integer c)]) + (or (and (>= scalar-value 48) (<= scalar-value 57)) + (and (>= scalar-value 65) (<= scalar-value 70)) + (and (>= scalar-value 97) (<= scalar-value 102))))) + + (define (char-delimiter? c) + (or (char-whitespace? c) + (char=? c #\)) (char=? c #\() + (char=? c #\]) (char=? c #\[) + (char=? c #\") (char=? c #\;))) + + (define (sub-read-carefully p) + (let ([form (sub-read p)]) + (cond [(eof-object? form) + (r-error p "unexpected end of file")] + [(reader-token? form) + (r-error p "unexpected token:" (cdr form))] + [else form]))) + + (define (sub-read p) + (let ([c (read-char p)]) + (cond [(eof-object? c) c] + [(char-whitespace? c) (sub-read p)] + [(char=? c #\() (sub-read-list c p close-paren #t)] + [(char=? c #\)) close-paren] + [(char=? c #\[) (sub-read-list c p close-bracket #t)] + [(char=? c #\]) close-bracket] + [(char=? c #\') (list 'quote (sub-read-carefully p))] + [(char=? c #\`) (list 'quasiquote (sub-read-carefully p))] + [(char-symbolic? c) (sub-read-number-or-symbol c p)] + [(char=? c #\;) + (let loop ([c (read-char p)]) + (or (eof-object? c) (char=? c #\newline) + (loop (read-char p)))) + (sub-read p)] + [(char=? c #\,) + (let ([next (peek-char p)]) + (cond [(eof-object? next) + (r-error p "end of file after ,")] + [(char=? next #\@) + (read-char p) + (list 'unquote-splicing (sub-read-carefully p))] + [else (list 'unquote (sub-read-carefully p))]))] + [(char=? c #\") + (let loop ([l '()]) + (let ([c (read-char p)]) + (cond [(eof-object? c) + (r-error p "end of file within a string")] + [(char=? c #\\) + (let ([e (sub-read-strsym-char-escape p 'string)]) + (loop (if e (cons e l) l)))] + [(char=? c #\") (list->string (reverse! l))] + [else (loop (cons c l))])))] + [(char=? c #\|) + (let loop ([l '()]) + (let ([c (read-char p)]) + (cond [(eof-object? c) + (r-error p "end of file within a |symbol|")] + [(char=? c #\\) + (let ([e (sub-read-strsym-char-escape p 'symbol)]) + (loop (if e (cons e l) l)))] + [(char=? c #\|) (string->symbol (list->string (reverse! l)))] + [else (loop (cons c l))])))] + [(char=? c #\#) + (let ([c (peek-char p)]) + (cond [(eof-object? c) (r-error p "end of file after #")] + [(or (char-ci=? c #\t) (char-ci=? c #\f)) + (let ([name (sub-read-carefully p)]) + (case name [(t true) #t] [(f false) #f] + [else (r-error p "unexpected name after #" name)]))] + [(or (char-ci=? c #\b) (char-ci=? c #\o) + (char-ci=? c #\d) (char-ci=? c #\x) + (char-ci=? c #\i) (char-ci=? c #\e)) + (sub-read-number-or-symbol #\# p)] + [(char=? c #\&) + (read-char p) + (box (sub-read-carefully p))] + [(char=? c #\;) + (read-char p) + (sub-read-carefully p) + (sub-read p)] + [(char=? c #\|) + (read-char p) + (let recur () ;starts right after opening #| + (let ([next (read-char p)]) + (cond + [(eof-object? next) + (r-error p "end of file in #| comment")] + [(char=? next #\|) + (let ([next (peek-char p)]) + (cond + [(eof-object? next) + (r-error p "end of file in #| comment")] + [(char=? next #\#) (read-char p)] + [else (recur)]))] + [(char=? next #\#) + (let ([next (peek-char p)]) + (cond + [(eof-object? next) + (r-error p "end of file in #| comment")] + [(char=? next #\|) (read-char p) (recur) (recur)] + [else (recur)]))] + [else (recur)]))) + (sub-read p)] + [(char=? c #\() ;) + (read-char p) + (list->vector (sub-read-list c p close-paren #f))] + [(char=? c #\u) + (read-char p) + (if (and (eq? (read-char p) #\8) (eq? (read-char p) #\()) + (list->bytevector (sub-read-byte-list p)) + (r-error p "invalid bytevector syntax"))] + [(char=? c #\\) + (read-char p) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) + (r-error p "end of file after #\\")] + [(char=? #\x c) + (read-char p) + (if (char-delimiter? (peek-char p)) + c + (sub-read-x-char-escape p #f))] + [(char-alphabetic? c) + (let ([name (sub-read-carefully p)]) + (if (= (string-length (symbol->string name)) 1) + c + (case name + [(null) (integer->char #x00)] + [(space) #\space] + [(alarm) #\alarm] + [(backspace) #\backspace] + [(delete) (integer->char #x7F)] ; todo: support by SFC + [(escape) (integer->char #x1B)] + [(tab) #\tab] + [(newline linefeed) #\newline] + [(vtab) #\vtab] + [(page) #\page] + [(return) #\return] + [else (r-error p "unknown #\\ name" name)])))] + [else (read-char p) c]))] + [(char-numeric? c) + (when simple? (r-error p "#N=/#N# notation is not allowed in this mode")) + (let loop ([l '()]) + (let ([c (read-char p)]) + (cond [(eof-object? c) + (r-error p "end of file within a #N notation")] + [(char-numeric? c) + (loop (cons c l))] + [(char=? c #\#) + (let* ([s (list->string (reverse! l))] [n (string->number s)]) + (cond [(and (fixnum? n) (assq n shared)) => cdr] + [else (r-error "unknown #n# reference:" s)]))] + [(char=? c #\=) + (let* ([s (list->string (reverse! l))] [n (string->number s)]) + (cond [(not (fixnum? n)) (r-error "invalid #n= reference:" s)] + [(assq n shared) (r-error "duplicate #n= tag:" n)]) + (let ([loc (box #f)]) + (set! shared (cons (cons n (make-shared-ref loc)) shared)) + (let ([form (sub-read-carefully p)]) + (cond [(shared-ref? form) (r-error "#n= has another label as target" s)] + [else (set-box! loc form) form]))))] + [else (r-error p "invalid terminator for #N notation")])))] + [else (r-error p "unknown # syntax" c)]))] + [else (r-error p "illegal character read" c)]))) + + (define (sub-read-list c p close-token dot?) + (let ([form (sub-read p)]) + (if (eq? form dot) + (r-error p "missing car -- ( immediately followed by .") ;) + (let recur ([form form]) + (cond [(eof-object? form) + (r-error p "eof inside list -- unbalanced parentheses")] + [(eq? form close-token) '()] + [(eq? form dot) + (if dot? + (let* ([last-form (sub-read-carefully p)] + [another-form (sub-read p)]) + (if (eq? another-form close-token) + last-form + (r-error p "randomness after form after dot" another-form))) + (r-error p "dot in #(...)"))] + [(reader-token? form) + (r-error p "error inside list --" (cdr form))] + [else (cons form (recur (sub-read p)))]))))) + + (define (sub-read-byte-list p) + (let recur ([form (sub-read p)]) + (cond [(eof-object? form) + (r-error p "eof inside bytevector")] + [(eq? form close-paren) '()] + [(reader-token? form) + (r-error p "error inside bytevector --" (cdr form))] + [(or (not (fixnum? form)) (fx? form 255)) + (r-error p "invalid byte inside bytevector --" form)] + [else (cons form (recur (sub-read p)))]))) + + (define (sub-read-strsym-char-escape p what) + (let ([c (read-char p)]) + (if (eof-object? c) + (r-error p "end of file within a" what)) + (cond [(or (char=? c #\\) (char=? c #\") (char=? c #\|)) c] + [(char=? c #\a) #\alarm] + [(char=? c #\b) #\backspace] + [(char=? c #\t) #\tab] + [(char=? c #\n) #\newline] + [(char=? c #\v) #\vtab] + [(char=? c #\f) #\page] + [(char=? c #\r) #\return] + [(char=? c #\x) (sub-read-x-char-escape p #t)] + [(and (eq? what 'string) (char-whitespace? c)) + (let loop ([gotnl (char=? c #\newline)] [nc (peek-char p)]) + (cond [(or (eof-object? nc) (not (char-whitespace? nc))) + (if gotnl #f (r-error p "no newline in line ending escape"))] + [(and gotnl (char=? nc #\newline)) #f] + [else (read-char p) (loop (or gotnl (char=? nc #\newline)) (peek-char p))]))] + [else (r-error p "invalid char escape in" what ': c)]))) + + (define (sub-read-x-char-escape p in-string?) + (define (rev-digits->char l) + (if (null? l) + (r-error p "\\x escape sequence is too short") + (integer->char (string->fixnum (list->string (reverse! l)) 16)))) + (let loop ([c (peek-char p)] [l '()] [cc 0]) + (cond [(eof-object? c) + (if in-string? + (r-error p "end of file within a string") + (rev-digits->char l))] + [(and in-string? (char=? c #\;)) + (read-char p) + (rev-digits->char l)] + [(and (not in-string?) (char-delimiter? c)) + (rev-digits->char l)] + [(not (char-hex-digit? c)) + (r-error p "unexpected char in \\x escape sequence" c)] + [(> cc 2) + (r-error p "\\x escape sequence is too long")] + [else + (read-char p) + (loop (peek-char p) (cons c l) (+ cc 1))]))) + + (define (suspect-number-or-symbol-peculiar? hash? c l s) + (cond [(or hash? (char-numeric? c)) #f] + [(or (string-ci=? s "+i") (string-ci=? s "-i")) #f] + [(or (string-ci=? s "+nan.0") (string-ci=? s "-nan.0")) #f] + [(or (string-ci=? s "+inf.0") (string-ci=? s "-inf.0")) #f] + [(or (char=? c #\+) (char=? c #\-)) + (cond [(null? (cdr l)) #t] + [(char=? (cadr l) #\.) (and (pair? (cddr l)) (not (char-numeric? (caddr l))))] + [else (not (char-numeric? (cadr l)))])] + [else (and (char=? c #\.) (pair? (cdr l)) (not (char-numeric? (cadr l))))])) + + (define (sub-read-number-or-symbol c p) + (let loop ([c (peek-char p)] [l (list c)] [hash? (char=? c #\#)]) + (cond [(or (eof-object? c) (char-delimiter? c)) + (let* ([l (reverse! l)] [c (car l)] [s (list->string l)]) + (if (or hash? (char-numeric? c) + (char=? c #\+) (char=? c #\-) (char=? c #\.)) + (cond [(string=? s ".") dot] + [(suspect-number-or-symbol-peculiar? hash? c l s) (string->symbol s)] + [(string->number s)] + [else (r-error p "unsupported number syntax (implementation restriction)" s)]) + (string->symbol s)))] + [(char=? c #\#) + (read-char p) + (loop (peek-char p) (cons c l) #t)] + [(char-symbolic? c) + (read-char p) + (loop (peek-char p) (cons c l) hash?)] + [else (r-error p "unexpected number/symbol char" c)]))) + + ; body of %read + (let ([form (sub-read port)]) + (if (not (reader-token? form)) + (if (null? shared) form (patch-shared form)) + (r-error port "unexpected token:" (cdr form))))) + +(define read + (case-lambda + [() (%read (current-input-port) #f)] + [(p) (%read p #f)])) + +(define read-simple + (case-lambda + [() (%read (current-input-port) #t)] + [(p) (%read p #t)])) + ;--------------------------------------------------------------------------------------------- ; Output