From 25196416c7b3933107b7c753531130f6d3047bb8 Mon Sep 17 00:00:00 2001 From: ESL Date: Mon, 6 Mar 2023 23:52:38 -0500 Subject: [PATCH] a few extra i/o instructions & procedures --- i.c | 53 +++++++++++++++++++++++++++++++---- i.h | 9 +++++- s.c | 79 +++++++++++++++++++++++++++++++++++++++++++++++++++- src/s.scm | 83 +++++++++++++++++++++++++++++++++++++++++++++---------- 4 files changed, 202 insertions(+), 22 deletions(-) diff --git a/i.c b/i.c index 4efd9d6..31e9ecb 100644 --- a/i.c +++ b/i.c @@ -2118,11 +2118,6 @@ define_instruction(boolp) { gonexti(); } -define_instruction(eofp) { - ac = obj_from_bool(iseof(ac)); - gonexti(); -} - define_instruction(funp) { ac = obj_from_bool(isvmclo(ac)); gonexti(); @@ -2153,6 +2148,20 @@ define_instruction(sep) { gonexti(); } +define_instruction(ipop) { + cxtype_iport_t *vt; ckr(ac); + vt = iportvt(ac); assert(vt); + ac = obj_from_bool(vt != (cxtype_iport_t *)IPORT_CLOSED_NTAG); + gonexti(); +} + +define_instruction(opop) { + cxtype_oport_t *vt; ckw(ac); + vt = oportvt(ac); assert(vt); + ac = obj_from_bool(vt != (cxtype_oport_t *)OPORT_CLOSED_NTAG); + gonexti(); +} + define_instruction(otip) { FILE *fp = fopen(stringchars(ac), "r"); if (fp == NULL) fail("can't open input file"); @@ -2208,6 +2217,40 @@ define_instruction(gos) { gonexti(); } + +define_instruction(rdc) { + int c; ckr(ac); + c = iportgetc(ac); + if (unlikely(c == EOF)) ac = mkeof(); + else ac = obj_from_char(c); + gonexti(); +} + +define_instruction(rdac) { + int c; ckr(ac); + c = iportpeekc(ac); + if (unlikely(c == EOF)) ac = mkeof(); + else ac = obj_from_char(c); + gonexti(); +} + +define_instruction(rdcr) { + ckr(ac); + ac = obj_from_bool(1); /* no portable way to detect hanging? */ + gonexti(); +} + +define_instruction(eofp) { + ac = obj_from_bool(iseof(ac)); + gonexti(); +} + +define_instruction(eof) { + ac = mkeof(); + gonexti(); +} + + define_instruction(wrc) { obj x = ac, y = spop(); ckc(x); ckw(y); oportputc(char_from_obj(x), y); diff --git a/i.h b/i.h index d93b497..157d5b9 100644 --- a/i.h +++ b/i.h @@ -416,13 +416,14 @@ declare_instruction(scmp, "O2", 0, "%scmp", 2, INLINED) declare_instruction(sicmp, "O3", 0, "%sicmp", 2, INLINED) declare_instruction(symp, "Y0", 0, "%symp", 1, INLINED) declare_instruction(boolp, "Y1", 0, "%boolp", 1, INLINED) -declare_instruction(eofp, "Y9", 0, "%eofp", 1, INLINED) declare_instruction(funp, "K0", 0, "%funp", 1, INLINED) declare_instruction(ipp, "P00", 0, "%ipp", 1, INLINED) declare_instruction(opp, "P01", 0, "%opp", 1, INLINED) declare_instruction(sip, "P10", 0, "%sip", 0, INLINED) declare_instruction(sop, "P11", 0, "%sop", 0, INLINED) declare_instruction(sep, "P12", 0, "%sep", 0, INLINED) +declare_instruction(ipop, "P20", 0, "%ipop", 1, INLINED) +declare_instruction(opop, "P21", 0, "%opop", 1, INLINED) declare_instruction(otip, "P40", 0, "%otip", 1, INLINED) declare_instruction(otop, "P41", 0, "%otop", 1, INLINED) declare_instruction(ois, "P50", 0, "%ois", 1, INLINED) @@ -430,6 +431,12 @@ declare_instruction(oos, "P51", 0, "%oos", 0, INLINED) declare_instruction(cip, "P60", 0, "%cip", 1, INLINED) declare_instruction(cop, "P61", 0, "%cop", 1, INLINED) declare_instruction(gos, "P9", 0, "%gos", 1, INLINED) +declare_instruction(rdc, "R0", 0, "%rdc", 1, INLINED) +declare_instruction(rdac, "R1", 0, "%rdac", 1, INLINED) +declare_instruction(rdcr, "R2", 0, "%rdcr", 1, INLINED) +declare_instruction(eofp, "R8", 0, "%eofp", 1, INLINED) +declare_instrshadow(eofp, "Y9", 0, NULL, 0, INLINED) +declare_instruction(eof, "R9", 0, "%eof", 0, INLINED) declare_instruction(wrc, "W0", 0, "%wrc", 2, INLINED) declare_instruction(wrs, "W1", 0, "%wrs", 2, INLINED) declare_instruction(wrcd, "W4", 0, "%wrcd", 2, INLINED) diff --git a/s.c b/s.c index ed760c4..a6718a9 100644 --- a/s.c +++ b/s.c @@ -1663,6 +1663,22 @@ char *s_code[] = { 0, "&0{%1.0P01]1}@!(y22:%25residual-output-port?)", + "input-port-open?", + "l5:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y5:%25ipop;y1:x;;;l2:py1:_;y" + "12:syntax-rules;;py26:%25residual-input-port-open?;y12:syntax-rules;;;" + "l2:y1:_;y26:%25residual-input-port-open?;;", + + 0, + "&0{%1.0P20]1}@!(y26:%25residual-input-port-open?)", + + "output-port-open?", + "l5:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y5:%25opop;y1:x;;;l2:py1:_;y" + "12:syntax-rules;;py27:%25residual-output-port-open?;y12:syntax-rules;;" + ";l2:y1:_;y27:%25residual-output-port-open?;;", + + 0, + "&0{%1.0P21]1}@!(y27:%25residual-output-port-open?)", + "current-input-port", "l5:y12:syntax-rules;n;l2:l1:y1:_;;l1:y4:%25sip;;;l2:py1:_;y12:syntax-r" "ules;;py28:%25residual-current-input-port;y12:syntax-rules;;;l2:y1:_;y" @@ -1743,13 +1759,61 @@ char *s_code[] = { 0, "&0{%1.0P9]1}@!(y27:%25residual-get-output-string)", + 0, + "&0{%1.0P00,.0?{.0]2}.1P01]2}@!(y5:port?)", + + 0, + "&0{%1.0P00?{.0P60}.0P01?{.0P61]1}]1}@!(y10:close-port)", + + 0, + "&0{%2.0,&1{%!0${:0,@(y10:close-port)[01}.0,@(y5:%25sdmv),@(y5:%25appl)" + "[12},.1,.3,&2{%0:1,:0[01},@(y5:%25cwmv)[22}@!(y14:call-with-port)", + + 0, + "&0{%2.1,.1P40,@(y14:call-with-port)[22}@!(y20:call-with-input-file)", + + 0, + "&0{%2.1,.1P41,@(y14:call-with-port)[22}@!(y21:call-with-output-file)", + + "read-char", + "l6:y12:syntax-rules;n;l2:l1:y1:_;;l2:y4:%25rdc;l1:y4:%25sip;;;;l2:l2:y" + "1:_;y1:p;;l2:y4:%25rdc;y1:p;;;l2:py1:_;y4:args;;py19:%25residual-read-" + "char;y4:args;;;l2:y1:_;y19:%25residual-read-char;;", + + "peek-char", + "l6:y12:syntax-rules;n;l2:l1:y1:_;;l2:y5:%25rdac;l1:y4:%25sip;;;;l2:l2:" + "y1:_;y1:p;;l2:y5:%25rdac;y1:p;;;l2:py1:_;y4:args;;py19:%25residual-pee" + "k-char;y4:args;;;l2:y1:_;y19:%25residual-peek-char;;", + + "char-ready?", + "l5:y12:syntax-rules;n;l2:l1:y1:_;;l2:y5:%25rdcr;l1:y4:%25sip;;;;l2:l2:" + "y1:_;y1:p;;l2:y5:%25rdcr;y1:p;;;l2:y1:_;y21:%25residual-char-ready?;;", + + 0, + "&0{%1P51,t,,#0.3,.3,.2,&3{%1:2R0,.0R8,.0?{.0}{'(c%0a),.2C=}_1?{.0R8?{." + "1}{f}?{.0]2}:1P9,:1P61.0]3}'(c%0d),.1C=?{f,:0^[21}:1,.1W0f,:0^[21}.!0." + "0^_1[21}@!(y10:%25read-line)", + + "read-line", + "l5:y12:syntax-rules;n;l2:l1:y1:_;;l2:y10:%25read-line;l1:y4:%25sip;;;;" + "l2:l2:y1:_;y1:p;;l2:y10:%25read-line;y1:p;;;l2:y1:_;y19:%25residual-re" + "ad-line;;", + "eof-object?", "l5:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y5:%25eofp;y1:x;;;l2:py1:_;y" "12:syntax-rules;;py21:%25residual-eof-object?;y12:syntax-rules;;;l2:y1" ":_;y21:%25residual-eof-object?;;", 0, - "&0{%1.0Y9]1}@!(y21:%25residual-eof-object?)", + "&0{%1.0R8]1}@!(y21:%25residual-eof-object?)", + + "eof-object", + "l5:y12:syntax-rules;n;l2:l1:y1:_;;l1:y4:%25eof;;;l2:py1:_;y12:syntax-r" + "ules;;py20:%25residual-eof-object;y12:syntax-rules;;;l2:y1:_;y20:%25re" + "sidual-eof-object;;", + + 0, + "&0{%0R9]0}@!(y20:%25residual-eof-object)", "write-char", "l6:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l3:y4:%25wrc;y1:x;l1:y4:%25sop;" @@ -1904,6 +1968,19 @@ char *s_code[] = { 0, "&0{%!1.0u?{'(i10),.2E9]2}.0a,.2E9]2}@!(y24:%25residual-string->number)", + 0, + "&0{%!0.0u?{P10R0]1}.0aR0]1}@!(y19:%25residual-read-char)", + + 0, + "&0{%!0.0u?{P10R1]1}.0aR1]1}@!(y19:%25residual-peek-char)", + + 0, + "&0{%!0.0u?{P10R2]1}.0aR2]1}@!(y21:%25residual-char-ready?)", + + 0, + "&0{%!0.0u?{P10,@(y10:%25read-line)[11}.0a,@(y10:%25read-line)[11}@!(y1" + "9:%25residual-read-line)", + 0, "&0{%!1.0u?{P11,.2W0]2}.0a,.2W0]2}@!(y20:%25residual-write-char)", diff --git a/src/s.scm b/src/s.scm index e9f1387..c888050 100644 --- a/src/s.scm +++ b/src/s.scm @@ -664,6 +664,10 @@ (define-inline (output-port? x) %residual-output-port? (%opp x)) +(define-inline (input-port-open? x) %residual-input-port-open? (%ipop x)) + +(define-inline (output-port-open? x) %residual-output-port-open? (%opop x)) + (define-inline (current-input-port) %residual-current-input-port (%sip)) (define-inline (current-output-port) %residual-current-output-port (%sop)) @@ -684,17 +688,26 @@ (define-inline (get-output-string x) %residual-get-output-string (%gos x)) -;call-with-port -;call-with-input-file -;call-with-output-file -;port? -;input-port-open? -;output-port-open? -;with-input-from-file -;with-output-to-file +(define (port? x) (or (input-port? x) (output-port? x))) + +(define (close-port p) + (if (input-port? p) (close-input-port p)) + (if (output-port? p) (close-output-port p))) + +(define (call-with-port port proc) + (call-with-values (lambda () (proc port)) + (lambda vals (close-port port) (apply values vals)))) + +(define (call-with-input-file fname proc) + (call-with-port (open-input-file fname) proc)) + +(define (call-with-output-file fname proc) + (call-with-port (open-output-file fname) proc)) + +;with-input-from-file -- requires parameterize +;with-output-to-file -- requires parameterize ;open-binary-input-file ;open-binary-output-file -;close-port ;open-input-bytevector ;open-output-bytevector ;get-output-bytevector @@ -704,11 +717,46 @@ ; Input ;--------------------------------------------------------------------------------------------- +(define-syntax read-char + (syntax-rules () + [(_) (%rdc (%sip))] + [(_ p) (%rdc p)] + [(_ . args) (%residual-read-char . args)] + [_ %residual-read-char])) + +(define-syntax peek-char + (syntax-rules () + [(_) (%rdac (%sip))] + [(_ p) (%rdac p)] + [(_ . args) (%residual-peek-char . args)] + [_ %residual-peek-char])) + +(define-syntax char-ready? + (syntax-rules () + [(_) (%rdcr (%sip))] + [(_ p) (%rdcr p)] + [_ %residual-char-ready?])) + +(define (%read-line p) + (let ([op (%oos)]) + (let loop ([read-nothing? #t]) + (let ([c (%rdc p)]) + (cond [(or (%eofp c) (char=? c #\newline)) + (if (and (%eofp c) read-nothing?) c + (let ([s (%gos op)]) (%cop op) s))] + [(char=? c #\return) (loop #f)] + [else (%wrc c op) (loop #f)]))))) + +(define-syntax read-line + (syntax-rules () + [(_) (%read-line (%sip))] + [(_ p) (%read-line p)] + [_ %residual-read-line])) + +(define-inline (eof-object? x) %residual-eof-object? (%eofp x)) +(define-inline (eof-object) %residual-eof-object (%eof)) + ;read -;read-char -;peek-char -;read-line -;char-ready? ;read-string ;read-u8 ;peek-u8 @@ -716,8 +764,6 @@ ;read-bytevector ;read-bytevector! -(define-inline (eof-object? x) %residual-eof-object? (%eofp x)) -;eof-object ;--------------------------------------------------------------------------------------------- @@ -773,6 +819,8 @@ [(_ . args) (%residual-write-simple . args)] [_ %residual-write-simple])) +;flush-output-port + ;--------------------------------------------------------------------------------------------- ; System interface @@ -939,6 +987,11 @@ (define %residual-number->string (unary-binary-adaptor number->string)) (define %residual-string->number (unary-binary-adaptor string->number)) +(define %residual-read-char (nullary-unary-adaptor read-char)) +(define %residual-peek-char (nullary-unary-adaptor peek-char)) +(define %residual-char-ready? (nullary-unary-adaptor char-ready?)) +(define %residual-read-line (nullary-unary-adaptor read-line)) + (define %residual-write-char (unary-binary-adaptor write-char)) (define %residual-write-string (unary-binary-adaptor write-string)) (define %residual-newline (nullary-unary-adaptor newline))