X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme.4th;h=669665a2e80c7a0667a4ad3ec86a8f91774ac24d;hb=0dadd5f58d2c204c7f621ccd3c42f75a3fd790a8;hp=52fcbcce2fb1917cc9cb6425590fcabea028cf24;hpb=aa76b536aa3e1a90b31a64fd9147b2b16153ec8b;p=scheme.forth.jl.git diff --git a/src/scheme.4th b/src/scheme.4th index 52fcbcc..669665a 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -36,7 +36,7 @@ make-type pair-type make-type symbol-type make-type primitive-proc-type make-type compound-proc-type -make-type fileport-type +make-type port-type : istype? ( obj type -- obj bool ) over = ; @@ -175,37 +175,6 @@ variable nextfree \ }}} -\ ---- Port I/O ---- {{{ - -: fileport>fid ( fileport -- fid ) - drop ; - -: fid>fileport ( fid -- fileport ) - fileport-type ; - -: open-input-file ( addr n -- fileport ) - r/o open-file drop fid>fileport -; - -: close-port ( fileport -- ) - fileport>fid close-file drop -; - -objvar console-i/o-port -0 fileport-type console-i/o-port obj! - -objvar current-input-port -console-i/o-port obj@ current-input-port obj! - -: read-port ( fileport -- obj ) - current-input-port obj! - read ; - -: read-console ( -- obj ) - console-i/o-port obj@ read-port ; - -\ }}} - \ ---- Pre-defined symbols ---- {{{ objvar symbol-table @@ -305,12 +274,128 @@ create-symbol if if-symbol create-symbol lambda lambda-symbol create-symbol λ λ-symbol create-symbol begin begin-symbol +create-symbol eof eof-symbol \ Symbol to be bound to welcome message procedure by library create-symbol welcome welcome-symbol \ }}} +\ ---- Port I/O ---- {{{ + +( Ports are pairs with the fid in the car and the peek buffer in the cdr. ) + +: fileport>fid ( fileport -- fid ) + drop pair-type car drop ; + +: get-last-peek ( fileport -- char/nil ) + drop pair-type cdr ; + +: set-last-peek ( char/nil fileport -- ) + drop pair-type set-cdr! +; + +: fid>fileport ( fid -- fileport ) + fixnum-type nil cons drop port-type ; + +: open-input-file ( addr n -- fileport ) + r/o open-file drop fid>fileport +; + +: close-port ( fileport -- ) + fileport>fid close-file drop +; + +objvar console-i/o-port +0 fixnum-type nil cons drop port-type console-i/o-port obj! + +objvar current-input-port +console-i/o-port obj@ current-input-port obj! + +: read-char ( port -- char ) + 2dup get-last-peek nil? if + 2drop + 2dup console-i/o-port obj@ objeq? if + 2drop + key character-type + else + fileport>fid pad 1 rot read-file 0= if + eof-symbol + else + pad @ character-type + then + then + else + nil 2rot set-cdr! + then +; + +: peek-char ( port -- char ) + 2dup get-last-peek nil? if + 2drop 2dup read-char + 2dup 2rot set-last-peek + else + 2swap 2drop + then +; + +variable read-line-buffer-span +variable read-line-buffer-offset + +( Hack to save original read-line while we transition to new one. ) +: orig-read-line immediate + ['] read-line , ; + +: read-line ( port -- string ) + + 2dup get-last-peek + nil? if + 2drop + 0 read-line-buffer-offset ! + else + 2over nil 2swap set-last-peek + 2dup drop '\n' = if + 2drop nil nil cons exit + else + drop pad ! + 1 read-line-buffer-offset ! + then + then + + 2dup console-i/o-port obj@ objeq? if + 2drop + pad read-line-buffer-offset @ + 200 expect cr + span @ read-line-buffer-offset @ + read-line-buffer-span ! + else + pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line + drop swap read-line-buffer-offset @ + read-line-buffer-span ! + then + + nil + + begin + read-line-buffer-span @ 0> + while + pad read-line-buffer-span @ 1- + @ character-type 2swap cons + -1 read-line-buffer-span +! + repeat + + nil? if + nil cons drop string-type + else + drop string-type + then +; + +: read-port ( fileport -- obj ) + current-input-port obj! + read ; + +: read-console ( -- obj ) + console-i/o-port obj@ read-port ; + +\ }}} + \ ---- Environments ---- {{{ : enclosing-env ( env -- env ) @@ -648,7 +733,7 @@ parse-idx-stack parse-idx-sp ! parse-str 160 expect cr span @ parse-str-span ! else - parse-str 160 current-input-port obj@ fileport>fid read-line + parse-str 160 current-input-port obj@ fileport>fid orig-read-line drop swap parse-str-span ! parse-str-span @ 0= and if append-eof then @@ -1780,6 +1865,7 @@ hide env primitive-proc-type istype? if printprim exit then compound-proc-type istype? if printcomp exit then none-type istype? if printnone exit then + port-type istype? if printport exit then recoverable-exception throw" Tried to print object with unknown type." ; is print @@ -1808,6 +1894,7 @@ variable gc-stack-depth string-type istype? if true exit then symbol-type istype? if true exit then compound-proc-type istype? if true exit then + port-type istype? if true exit then false ; @@ -1868,12 +1955,13 @@ variable gc-stack-depth ; :noname - \ ." GC! " + ." GC! " gc-unmark symbol-table obj@ gc-mark-obj macro-table obj@ gc-mark-obj + console-i/o-port obj@ gc-mark-obj global-env obj@ gc-mark-obj depth gc-stack-depth @ do @@ -1892,24 +1980,6 @@ variable gc-stack-depth \ ---- Loading files ---- {{{ -: charlist>cstr ( charlist addr -- n ) - - dup 2swap ( origaddr addr charlist ) - - begin - nil? false = - while - 2dup cdr 2swap car - drop ( origaddr addr charlist char ) - -rot 2swap ( origaddr charlist addr char ) - over ! - 1+ -rot ( origaddr nextaddr charlist ) - repeat - - 2drop ( origaddr finaladdr ) - swap - -; - : load ( addr n -- finalResult ) open-input-file