handle I/O on closed ports gracefully

TODO.FACTOR.txt

@@ -1,5 +1,6 @@
-- quot>interp needs to go
 - nodes: lazily create history, class/literal map hashes
+- delete no longer infers
+- write tests for callcc and catch inference
 
 + ui:
 

library/bootstrap/boot-stage2.factor

@@ -8,7 +8,7 @@ sequences sequences-internals words ;
 : pull-in ( ? list -- )
     swap [
         [
-            dup print run-resource
+            dup print [ dup run-resource ] try drop
         ] each
     ] [
         drop

library/cli.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2003, 2004 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: command-line
-USING: io kernel kernel-internals lists namespaces parser
+USING: errors io kernel kernel-internals lists namespaces parser
 sequences strings ;
 
 ! This file is run as the last stage of boot.factor; it relies
 ! on all other words already being defined.
 
 : ?run-file ( file -- )
-    dup exists? [ run-file ] [ drop ] ifte ;
+    dup exists? [ [ dup run-file ] try drop ] [ drop ] ifte ;
 
 : run-user-init ( -- )
     #! Run user init file if it exists

library/collections/sequences-epilogue.factor

@@ -109,14 +109,6 @@ M: object peek ( sequence -- element )
     #! Get value at end of sequence and remove it.
     dup peek swap pop* ;
 
-: adjoin ( elt seq -- )
-    2dup member? [ 2drop ] [ push ] ifte ;
-
-: prune ( seq -- seq )
-    [
-        dup length <vector> swap [ over adjoin ] each
-    ] keep like ; flushable
-
 : join ( seq glue -- seq )
     #! The new sequence is of the same type as glue.
     swap dup empty? [

library/continuations.factor

@@ -3,30 +3,39 @@
 IN: kernel
 USING: arrays errors lists namespaces sequences words vectors ;
 
-TUPLE: interp data call name catch ;
+TUPLE: continuation data c call name catch ;
+
+: c-stack ( -- c-stack )
+    #! In the interpreter, this is a no-op. The compiler has an
+    #! an intrinsic for this word.
+    f ;
+
+: set-c-stack ( c-stack -- )
+    [ "not supported" throw ] when ;
 
 : continuation ( -- interp )
     #! The continuation is reified from after the *caller* of
     #! this word returns.
-    datastack callstack dup pop* dup pop*
-    namestack catchstack <interp> ;
+    datastack c-stack callstack dup pop* dup pop*
+    namestack catchstack <continuation> ; inline
 
-: >interp< ( interp -- data call name catch )
-    [ interp-data ] keep
-    [ interp-call ] keep
-    [ interp-name ] keep
-    interp-catch ;
+: >continuation< ( continuation -- data c call name catch )
+    [ continuation-data ] keep
+    [ continuation-c ] keep
+    [ continuation-call ] keep
+    [ continuation-name ] keep
+    continuation-catch ; inline
 
 : continue ( continuation -- )
     #! Restore a continuation.
-    >interp<
-    set-catchstack set-namestack set-callstack set-datastack ;
+    >continuation< set-catchstack set-namestack set-callstack
+    >r set-datastack r> set-c-stack ;
 
 : continue-with ( object continuation -- object )
     #! Restore a continuation, and place the object in the
     #! restored data stack.
-    >interp< set-catchstack set-namestack
-    >r swap >r set-datastack r> r> set-callstack ;
+    >continuation< set-catchstack set-namestack set-callstack
+    >r swap >r set-datastack r> r> set-c-stack ;
 
 : (callcc) ( terminator balance  -- | quot: continuation -- )
     #! Direct calls to this word will not compile correctly;
@@ -36,9 +45,8 @@ TUPLE: interp data call name catch ;
     #! The balance branch is never called, but it is there to
     #! give the callcc form a stack effect.
     >r >r
-    continuation dup interp-call dup pop* pop*
-    t r> r> ifte ;
-    inline
+    continuation dup continuation-call dup pop* pop*
+    t r> r> ifte ; inline
 
 : callcc0 ( quot -- | quot: continuation -- )
     #! Call a quotation with the current continuation, which may

library/errors.factor

@@ -5,7 +5,7 @@ DEFER: callcc1
 DEFER: continue-with
 
 IN: errors
-USING: kernel-internals lists ;
+USING: kernel-internals lists sequences ;
 
 ! This is a very lightweight exception handling system.
 
@@ -20,13 +20,13 @@ TUPLE: no-method object generic ;
 : c> ( catch -- ) catchstack uncons set-catchstack ;
 
 : (catch) ( try -- exception/f )
-    [ >c call f c> drop f ] callcc1 nip ;
+    [ >c call f c> drop f ] callcc1 nip ; inline
 
 : catch ( try catch -- )
     #! Call the try quotation. If an error occurs restore the
     #! datastack, push the error, and call the catch block.
     #! If no error occurs, push f and call the catch block.
-    >r (catch) r> call ;
+    >r (catch) r> call ; inline
 
 : rethrow ( error -- )
     #! Use rethrow when passing an error on from a catch block.

library/generic/generic.factor

@@ -39,14 +39,15 @@ SYMBOL: builtins
     #! Outputs a sequence of classes whose union is this class.
     [ (flatten) ] make-hash ;
 
-DEFER: types
-
 : (types) ( class -- )
     #! Only valid for a flattened class.
-    dup superclass [ types % ] [ "type" word-prop , ] ?ifte ;
+    flatten [
+        car dup superclass
+        [ (types) ] [ "type" word-prop dup set ] ?ifte
+    ] hash-each ;
 
 : types ( class -- types )
-    [ flatten hash-keys [ (types) ] each ] { } make prune ;
+    [ (types) ] make-hash hash-keys ;
 
 DEFER: class<
 

library/httpd/cont-responder.factor

@@ -139,7 +139,7 @@ DEFER: show
   ] show-final ;
 
 : >callable ( quot|interp|f -- interp )
-  dup interp? [
+  dup continuation? [
     [ continue-with ] cons
   ] when ;
 

library/inference/known-words.factor

@@ -510,3 +510,17 @@ prettyprint ;
 
 \ array>vector [ [ array ] [ vector ] ] "infer-effect" set-word-prop
 \ array>vector t "flushable" set-word-prop
+
+\ datastack [ [ ] [ vector ] ] "infer-effect" set-word-prop
+\ set-datastack [ [ vector ] [ ] ] "infer-effect" set-word-prop
+
+\ callstack [ [ ] [ vector ] ] "infer-effect" set-word-prop
+\ set-callstack [ [ vector ] [ ] ] "infer-effect" set-word-prop
+
+\ c-stack [
+    "c-stack cannot be compiled (yet)" throw
+] "infer" set-word-prop
+
+\ set-c-stack [
+    "set-c-stack cannot be compiled (yet)" throw
+] "infer" set-word-prop

library/sdl/sdl-keyboard.factor

@@ -13,22 +13,17 @@ sequences ;
 : SDL_EnableKeyRepeat ( delay interval -- )
     "int" "sdl" "SDL_EnableKeyRepeat" [ "int" "int" ] alien-invoke ;
 
-: modifiers, ( mod -- )
-    modifiers get [
-        uncons pick bitand 0 = [ drop ] [ , ] ifte
-    ] each
-    drop ;
+: modifier ( mod -- str )
+    [ modifiers [ uncons rot bitand 0 > ?, ] each-with ] [ ] make ;
 
-: keysym, ( sym -- )
+: keysym ( sym -- str )
     #! Return the original keysym number if its unknown.
-    [ keysyms get hash dup ] keep ? , ;
+    [ keysyms hash dup ] keep ? ;
 
 : keyboard-event>binding ( event -- binding )
     #! Turn a key event into a binding, which is a list where
     #! all elements but the last one are modifier names looked
     #! up the modifiers alist, and the last element is a keysym
     #! look up in the keysyms hash.
-    [
-        dup keyboard-event-mod modifiers,
-        keyboard-event-sym keysym,
-    ] [ ] make prune ;
+    dup keyboard-event-mod modifier
+    swap keyboard-event-sym keysym add ;

library/sdl/sdl-keysym.factor

@@ -5,29 +5,18 @@ IN: sdl USING: namespaces ;
 ! Here we smash left/right control/shift/alt for convinience.
 ! Later, something better needs to be done.
 
-SYMBOL: modifiers
+: modifiers
+    {
+        [[ "SHIFT" HEX: 0003 ]]
+        [[ "CTRL"  HEX: 00c0 ]]
+        [[ "ALT"   HEX: 0300 ]]
+        [[ "META"  HEX: 0c00 ]]
+    } ;
 
-[
-    [[ "SHIFT" HEX: 0001 ]]
-    [[ "SHIFT" HEX: 0002 ]]
-    [[ "CTRL"  HEX: 0040 ]]
-    [[ "CTRL"  HEX: 0080 ]]
-    [[ "ALT"   HEX: 0100 ]]
-    [[ "ALT"   HEX: 0200 ]]
-    [[ "META"  HEX: 0400 ]]
-    [[ "META"  HEX: 0800 ]]
-! We ignore these two modifiers since they're mighty useless
-!    [[ "NUM"   HEX: 1000 ]]
-!    [[ "CAPS"  HEX: 2000 ]]
-    [[ "MODE"  HEX: 4000 ]]
-] modifiers set
-
-SYMBOL: keysyms
-
-{{
+: keysyms
+    {{
         ! The keyboard syms have been cleverly chosen to map to ASCII
         [[ 0  "UNKNOWN"    ]]
-!    [[ 0  "FIRST"      ]]
         [[ 8  "BACKSPACE"  ]]
         [[ 9  "TAB"        ]]
         [[ 12 "CLEAR"      ]]
@@ -268,4 +257,4 @@ SYMBOL: keysyms
         [[ 321 "EURO" ]]           ! Some european keyboards
         [[ 322 "UNDO" ]]           ! Atari keyboard has Undo
         ! Add any other keys here
-}} keysyms set
+    }} ;

library/test/collections/sequences.factor

@@ -64,8 +64,6 @@ unit-test
 [ @{ @{ 1 4 }@ @{ 2 5 }@ @{ 3 6 }@ }@ ]
 [ @{ @{ 1 2 3 }@ @{ 4 5 6 }@ }@ flip ] unit-test
 
-[ [ "a" 43 [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test
-
 [ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
 [ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test
 [ t ] [ [ ] all-equal? ] unit-test

library/test/continuations.factor

@@ -31,14 +31,6 @@ USE: test
 : multishot-test ( -- stack )
     [
         dup "cc" set 5 swap continue-with
-    ] callcc1 "cc" get interp-data ;
+    ] callcc1 "cc" get continuation-data ;
 
 [ 5 { } ] [ multishot-test ] unit-test
-
-[ ] [
-    [
-        global [ "x" set ] bind
-        [ global [ "x" get ] bind continue ] quot>interp
-        continue
-    ] callcc0 global [ "x" off ] bind
-] unit-test

library/test/inference.factor

@@ -223,7 +223,6 @@ DEFER: agent
 [ @{ 1 1 }@ ] [ [ reverse ] infer ] unit-test
 [ @{ 2 1 }@ ] [ [ member? ] infer ] unit-test
 [ @{ 2 1 }@ ] [ [ remove ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ prune ] infer ] unit-test
 
 : bad-code "1234" car ;
 

library/tools/interpreter.factor

@@ -45,15 +45,17 @@ SYMBOL: meta-executing
     meta-cf get [ meta-cf [ uncons ] change ] [ up next ] ifte ;
 
 : meta-interp ( -- interp )
-    meta-d get meta-r get meta-n get meta-c get <interp> ;
+    meta-d get f meta-r get meta-n get meta-c get
+    <continuation> ;
 
 : set-meta-interp ( interp -- )
-    >interp< meta-c set meta-n set meta-r set meta-d set ;
+    >continuation<
+    meta-c set meta-n set meta-r set drop meta-d set ;
 
 : host-word ( word -- )
     [
         \ call push-r  continuation [
-            continuation over interp-data push continue
+            continuation over continuation-data push continue
         ] cons cons push-r  meta-interp continue
     ] call  set-meta-interp  pop-d 2drop ;
 

library/ui/hand.factor

@@ -25,7 +25,7 @@ C: hand ( world -- hand )
     dup hand-gadget over set-hand-clicked
     dup screen-loc over set-hand-click-loc
     dup hand-gadget over relative over set-hand-click-rel
-    hand-buttons adjoin ;
+    hand-buttons push ;
 
 : button\ ( n hand -- )
     hand-buttons delete ;

library/unix/io.factor

@@ -2,8 +2,8 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: io-internals
 USING: alien arrays compiler-backend errors generic hashtables
-io kernel kernel-internals lists math parser sequences
-strings threads unix-internals vectors ;
+io kernel kernel-internals lists math parser sequences strings
+threads unix-internals vectors words ;
 
 ! We want namespaces::bind to shadow the bind system call from
 ! unix-internals
@@ -49,7 +49,19 @@ SYMBOL: write-tasks
 : init-handle ( fd -- ) F_SETFL O_NONBLOCK fcntl io-error ;
 
 ! Common delegate of native stream readers and writers
-TUPLE: port handle buffer error timeout cutoff output? sbuf eof? ;
+SYMBOL: input
+SYMBOL: output
+SYMBOL: closed
+
+TUPLE: port handle error timeout cutoff type sbuf eof? ;
+
+: check-port ( port expected -- )
+    >r port-type r> 2dup eq? [
+        [
+            "Cannot perform " % word-name %
+            " on " % word-name % " port" %
+        ] "" make throw
+    ] unless 2drop ;
 
 : make-buffer ( n -- buffer/f )
     dup 0 > [ <buffer> ] [ drop f ] ifte ;
@@ -150,7 +162,7 @@ GENERIC: task-container ( task -- vector )
 ! Readers
 
 : <reader> ( fd -- stream )
-    buffered-port <line-reader> ;
+    buffered-port input over set-port-type <line-reader> ;
 
 : open-read ( path -- fd )
     O_RDONLY file-mode open dup io-error ;
@@ -212,10 +224,12 @@ M: read-task task-container drop read-tasks get ;
     ] unless 2drop ;
 
 M: port stream-read ( count stream -- string )
+    dup input check-port
     [ wait-to-read ] keep dup port-eof?
     [ drop f ] [ port-sbuf >string ] ifte ;
 
 M: port stream-read1 ( stream -- char/f )
+    dup input check-port
     1 over wait-to-read dup port-eof?
     [ drop f ] [ port-sbuf first ] ifte ;
 
@@ -226,7 +240,7 @@ M: port stream-read1 ( stream -- char/f )
     dup io-error ;
 
 : <writer> ( fd -- writer )
-    buffered-port t over set-port-output? ;
+    buffered-port output over set-port-type ;
 
 : write-step ( port -- )
     dup >port< dup buffer@ swap buffer-length write dup 0 >= [
@@ -272,25 +286,30 @@ M: write-task task-container drop write-tasks get ;
     ] ifte* ;
 
 M: port stream-flush ( stream -- )
-    dup port-output? [
-        [ swap <write-task> add-write-io-task stop ] callcc0
-    ] when drop ;
+    dup output check-port
+    [ swap <write-task> add-write-io-task stop ] callcc0 drop ;
 
-M: port stream-finish ( stream -- ) drop ;
+M: port stream-finish ( stream -- ) output check-port ;
 
 : wait-to-write ( len port -- )
     tuck can-write? [ dup stream-flush ] unless pending-error ;
 
 M: port stream-write1 ( char writer -- )
+    dup output check-port
     1 over wait-to-write ch>buffer ;
 
 M: port stream-format ( string style writer -- )
+    dup output check-port
     nip over length over wait-to-write >buffer ;
 
 M: port stream-close ( stream -- )
-    dup stream-flush
+    dup port-type closed eq? [
+        dup port-type output eq? [ dup stream-flush ] when
         dup port-handle close
-    delegate [ buffer-free ] when* ;
+        dup delegate [ buffer-free ] when*
+        f over set-delegate
+        closed over set-port-type
+    ] unless drop ;
 
 ! Make a duplex stream for reading/writing a pair of fds
 

library/unix/sockets.factor

@@ -67,7 +67,8 @@ TUPLE: server client ;
 
 C: server ( port -- server )
     #! Starts listening for TCP connections on localhost:port.
-    [ >r server-socket 0 <port> r> set-delegate ] keep ;
+    [ >r server-socket 0 <port> r> set-delegate ] keep
+    server over set-port-type ;
 
 IN: io-internals
 USE: unix-internals

library/words.factor

@@ -24,9 +24,11 @@ M: word set-word-xt ( xt w -- ) 7 set-integer-slot ;
     #! Outputs a list of words that this word directly calls.
     [
         dup word-def [
-            dup word? [ 2dup eq? [ dup , ] unless ] when 2drop
+            dup word?
+            [ 2dup eq? [ dup dup set ] unless ] when
+            2drop
         ] tree-each-with
-    ] { } make prune ;
+    ] make-hash hash-keys ;
 
 ! The cross-referencer keeps track of word dependencies, so that
 ! words can be recompiled when redefined.