various minor improvements

TODO.FACTOR.txt

@@ -10,10 +10,11 @@
 - clone-sbuf
 - contains ==> contains?
 - telnetd: send errors on socket
-- partition, sort
 - inspector: sort
 - index of str
 - accept: return socket, instead of printing msg
+- crash: [ primitives, ] with-image .
+- enforce bottom-up in native bootstrap
 
 + interactive:
 

library/cross-compiler.factor

@@ -45,6 +45,7 @@ DEFER: setenv
 DEFER: save-image
 DEFER: handle?
 DEFER: room
+DEFER: os-env
 
 IN: strings
 DEFER: str=
@@ -160,6 +161,7 @@ IN: cross-compiler
         flush-fd
         shutdown-fd
         room
+        os-env
     ] [
         swap succ tuck primitive,
     ] each drop ;

library/debugger.factor

@@ -42,17 +42,17 @@ USE: unparser
 
 : parse-dump ( error -- )
     <%
-    "parse-name" get [ "<interactive>" ] unless* % ":" %
+    "error-parse-name" get [ "<interactive>" ] unless* % ":" %
-    "line-number" get [ 1 ] unless* unparse % ": " %
+    "error-line-number" get [ 1 ] unless* unparse % ": " %
     %> write
     error.
     
-    "line" get print
+    "error-line" get print
     
-    <% "pos" get " " fill % "^" % %> print ;
+    <% "error-pos" get " " fill % "^" % %> print ;
 
 : in-parser? ( -- ? )
-    "line" get "pos" get and ;
+    "error-line" get "error-pos" get and ;
 
 : error-handler-hook
     #! The game overrides this.

library/errors.factor

@@ -40,9 +40,17 @@ USE: vectors
 : c> ( catch -- ) catchstack* vector-pop ;
 
 : save-error ( error -- )
-    #! Save the stacks for post-mortem inspection after an
+    #! Save the stacks and parser state for post-mortem
-    #! error.
+    #! inspection after an error.
+    "pos" get
+    "line" get
+    "line-number" get
+    "parse-name" get
     global [
+        "error-parse-name" set
+        "error-line-number" set
+        "error-line" set
+        "error-pos" set
         "error" set
         datastack >pop> "error-datastack" set
         callstack >pop> >pop> "error-callstack" set

library/init.factor

@@ -43,6 +43,47 @@ USE: 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 ;
+
+: run-user-init ( -- )
+    #! Run user init file if it exists
+    "user-init" get [
+        <% "~" get % "/" get % ".factor-" % "rc" % %>
+        ?run-file
+    ] when ;
+
+: cli-param ( param -- )
+    #! Handle a command-line argument starting with '-' by
+    #! setting that variable to t, or if the argument is
+    #! prefixed with 'no-', setting the variable to f.
+    dup "no-" str-head? dup [
+        f put drop
+    ] [
+        drop t put
+    ] ifte ;
+
+: cli-arg ( argument -- argument )
+    #! Handle a command-line argument. If the argument was
+    #! consumed, returns f. Otherwise returns the argument.
+    dup [
+        dup "-" str-head? dup [
+            cli-param drop f
+        ] [
+            drop
+        ] ifte
+    ] when ;
+
+: parse-switches ( args -- args )
+    [ cli-arg ] inject ;
+
+: run-files ( args -- )
+    [ [ run-file ] when* ] each ;
+
+: parse-command-line ( args -- )
+    #! Parse command line arguments.
+    parse-switches run-files ;
+
 : init-search-path ( -- )
     ! For files
     "user" "file-in" set
@@ -84,12 +125,17 @@ USE: strings
     #! between runs.
     <namespace> "scratchpad" "vocabularies" get set* ;
 
+: init-toplevel ( -- )
+    [ "top-level-continuation" set ] callcc0 ;
+
 : init-interpreter ( -- )
     #! If we're run stand-alone, start the interpreter on stdio.
     "interactive" get [
-        [ "top-level-continuation" set ] callcc0
+        init-toplevel
 
-        interpreter-loop
+        [
-    ] [
+            interpreter-loop
-        f "top-level-continuation" set
+        ] [
-    ] ifte ;
+            default-error-handler suspend
+        ] catch
+    ] when ;

library/inspect-vocabularies.factor

@@ -92,3 +92,9 @@ USE: words
 : use. ( -- )
     #! Print the vocabulary search path for interactive parsers.
     "use" get . ;
+
+: vocabs. ( -- )
+    vocabs . ;
+
+: words. ( vocab -- )
+    words . ;

library/interpreter.factor

@@ -43,9 +43,10 @@ USE: unparser
 USE: vectors
 
 : print-banner ( -- )
-    "Factor " version cat2 print
+    <% "This is " % java? [ "JVM " % ] when
+    native? [ "native " % ] when "Factor " % version % %> print
     "Copyright (C) 2003, 2004 Slava Pestov" print
-    "Enter ``exit'' to exit." print ;
+    "Type ``exit'' to exit, ``help'' for help." print ;
 
 : init-history ( -- )
     "history" get [ 64 <vector> "history" set ] unless ;
@@ -96,3 +97,31 @@ USE: vectors
     init-history
     [ "quit-flag" get not ] [ interpret ] while
     "quit-flag" off ;
+
+: help ( -- )
+    "SESSION:" print
+    native? [
+        "\"foo.image\" save-image   -- save heap to a file" print
+        "room.                    -- show memory usage" print
+    ] when
+    "garbage-collection       -- force a GC" print
+    "exit                     -- exit interpreter" print
+    terpri
+    "WORDS:" print
+    "vocabs.                  -- list vocabularies" print 
+    "\"math\" words.            -- list the math vocabulary" print
+    "\"neg\" see                -- show word definition" print
+    "\"str\" apropos.           -- list all words containing str" print
+    "\"car\" usages.            -- list all words invoking car" print
+    terpri
+    "STACKS:" print
+    ".s .r .n .c              -- show contents of the 4 stacks" print
+    "clear                    -- clear datastack" print
+    terpri
+    "OBJECTS:" print
+    "global describe          -- list global variables." print
+    "\"foo\" get .              -- print a variable value." print
+    ".                        -- print top of stack." print
+    terpri
+    "HTTP SERVER:             USE: httpd 8888 httpd" print
+    "TELNET SERVER:           USE: telnetd 9999 telnetd" print ;

library/platform/jvm/combinators.factor

@@ -30,6 +30,8 @@ USE: kernel
 USE: lists
 USE: stack
 
+! These are DEPRECATED!
+
 : expand ( list -- list )
     #! Evaluates a quotation on a new stack, and pushes the
     #! reversed stack onto the original stack.
@@ -40,9 +42,12 @@ USE: stack
         call
     unstack ; interpret-only
 
+IN: lists
+DEFER: each
+
 : map ( [ items ] [ code ] -- [ mapping ] )
     #! Applies the code to each item, returns a list that
     #! contains the result of each application.
     #!
     #! This combinator will not compile.
-    2list restack each unstack ; inline interpret-only
+    unit cons restack each unstack ; inline interpret-only

library/platform/jvm/init.factor

@@ -39,37 +39,6 @@ USE: stdio
 USE: streams
 USE: strings
 
-: cli-param ( param -- )
-    #! Handle a command-line argument starting with '-' by
-    #! setting that variable to t, or if the argument is
-    #! prefixed with 'no-', setting the variable to f.
-    dup "no-" str-head? dup [
-        f put drop
-    ] [
-        drop t put
-    ] ifte ;
-
-: cli-arg ( argument -- argument )
-    #! Handle a command-line argument. If the argument was
-    #! consumed, returns f. Otherwise returns the argument.
-    dup [
-        dup "-" str-head? dup [
-            cli-param drop f
-        ] [
-            drop
-        ] ifte
-    ] when ;
-
-: parse-switches ( args -- args )
-    [ cli-arg ] inject ;
-
-: run-files ( args -- )
-    [ [ run-file ] when* ] each ;
-
-: parse-command-line ( args -- )
-    #! Parse command line arguments.
-    "args" get parse-switches run-files ;
-
 : stdin ( -- stdin )
     "java.lang.System" "in"  jvar-static-get
     <ireader> <breader> ;
@@ -86,18 +55,6 @@ USE: strings
     "user.home" system-property "~" set
     "file.separator" system-property "/" set ;
 
-: run-user-init ( -- )
-    #! Run user init file if it exists
-    "~" get "/" get ".factor-rc" cat3 "init-path" set
-
-    "user-init" get [
-        "init-path" get dup exists? [
-            interactive-run-file
-        ] [
-            drop
-        ] ifte
-    ] when ;
-
 : boot ( -- )
     #! The boot word is run by the intepreter when starting from
     #! an object database.
@@ -111,7 +68,7 @@ USE: strings
     init-environment
     init-search-path
     init-scratchpad
-    parse-command-line
+    "args" get parse-command-line
     run-user-init
 
     "compile" get [

library/platform/jvm/parser.factor

@@ -57,7 +57,7 @@ USE: streams
     #! global [ "in" get  ] bind
     f t <custom-parser> parse* ;
 
-: interactive-run-file ( path -- )
+: (run-file) ( path -- )
     dup <freader> interactive-parse-stream call ;
 
 : parse ( string -- list )

library/platform/native/boot.factor

@@ -80,7 +80,6 @@ primitives,
     "/library/math/math-combinators.factor"
     "/library/math/namespace-math.factor"
     "/library/platform/native/arithmetic.factor"
-    "/library/platform/native/cross-compiler.factor"
     "/library/platform/native/errors.factor"
     "/library/platform/native/io-internals.factor"
     "/library/platform/native/stream.factor"
@@ -96,6 +95,7 @@ primitives,
     "/library/platform/native/vectors.factor"
     "/library/platform/native/vocabularies.factor"
     "/library/platform/native/unparser.factor"
+    "/library/platform/native/cross-compiler.factor"
     "/library/platform/native/init.factor"
 ] [
     cross-compile-resource

library/platform/native/errors.factor

@@ -82,5 +82,5 @@ DEFER: default-error-handler
 : init-errors ( -- )
     64 <vector> set-catchstack*
     [ 1 exit* ] >c ( last resort )
-    [ default-error-handler suspend ] >c
+    [ default-error-handler 1 exit* ] >c
     [ throw ] 5 setenv ( kernel calls on error ) ;

library/platform/native/init.factor

@@ -55,20 +55,26 @@ USE: unparser
 : boot ( -- )
     init-gc
     init-namespaces
-    init-stdio
-    "stdio" get <ansi-stream> "stdio" set
-    init-errors
-    init-search-path
-    init-scratchpad
-    init-styles
-    init-vocab-styles
 
     ! Some flags are *on* by default, unless user specifies
     ! -no-<flag> CLI switch
     t "user-init" set
     t "interactive" set
 
+    init-stdio
+    "stdio" get <ansi-stream> "stdio" set
+
+    "HOME" os-env [ "." ] unless* "~" set
+    "/" "/" set
     10 "base" set
+    init-errors
+    init-search-path
+    init-scratchpad
+    init-styles
+    init-vocab-styles
+
+    run-user-init
+
     print-banner
     room.
     init-interpreter ;

library/platform/native/parse-stream.factor

@@ -57,23 +57,28 @@ USE: strings
         "parse-stream" get fclose rethrow
     ] catch ;
 
-: init-parser ( name -- seed )
+: file-vocabs ( -- )
-    "parse-name" set
     "file-in" get "in" set
     "file-use" get "use" set
-    f ;
+     ;
 
 : parse-stream ( name stream -- code )
-    <namespace> [
+    #! Uses the current namespace for temporary variables.
-        >r init-parser r> [ (parse) ] read-lines nreverse
+    >r "parse-name" set f r> [ (parse) ] read-lines nreverse ;
-    ] bind ;
 
 : parse-file ( file -- code )
     dup <filecr> parse-stream ;
 
-: run-file ( file -- )
+: (run-file) ( file -- )
+    #! Run a file. The file is read with the same IN:/USE: as
+    #! the current interactive interpreter.
     parse-file call ;
 
+: run-file ( file -- )
+    #! Run a file. The file is read with the default IN:/USE:
+    #! for files.
+    <namespace> [ file-vocabs parse-file ] bind call ;
+
 : resource-path ( -- path )
     "resource-path" get [ "." ] unless* ;
 

library/platform/native/stream.factor

@@ -28,7 +28,9 @@
 IN: streams
 USE: combinators
 USE: io-internals
+USE: errors
 USE: kernel
+USE: logic
 USE: stack
 USE: strings
 USE: namespaces
@@ -103,3 +105,7 @@ USE: namespaces
 
 : init-stdio ( -- )
     stdin stdout <fd-stream> "stdio" set ;
+
+: exists? ( file -- ? )
+    #! This is terrible.
+    [ <filebr> fclose t ] [ nip not ] catch ;

native/primitives.c

@@ -89,7 +89,8 @@ XT primitives[] = {
 	primitive_write_fd_8,                   /* 85 */
 	primitive_flush_fd,                     /* 86 */
 	primitive_shutdown_fd,                  /* 87 */
-	primitive_room                          /* 88 */
+	primitive_room,                         /* 88 */
+	primitive_os_env                        /* 89 */
 };
 
 CELL primitive_to_xt(CELL primitive)

native/primitives.h

@@ -1,5 +1,5 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 89
+#define PRIMITIVE_COUNT 90
 
 CELL primitive_to_xt(CELL primitive);
 

native/run.c

@@ -126,3 +126,13 @@ void primitive_exit(void)
 {
 	exit(to_fixnum(env.dt));
 }
+
+void primitive_os_env(void)
+{
+	char* name = to_c_string(untag_string(env.dt));
+	char* value = getenv(name);
+	if(value == NULL)
+		env.dt = F;
+	else
+		env.dt = tag_object(from_c_string(getenv(name)));
+}

native/run.h

@@ -82,3 +82,4 @@ void primitive_ifte(void);
 void primitive_getenv(void);
 void primitive_setenv(void);
 void primitive_exit(void);
+void primitive_os_env(void);