diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 19347e5a3e..da7819cfb4 100644 --- a/TODO.FACTOR.txt +++ b/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: diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index c617de8f90..3bec81374c 100644 --- a/library/cross-compiler.factor +++ b/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 ; diff --git a/library/debugger.factor b/library/debugger.factor index d54e09631b..045a582054 100644 --- a/library/debugger.factor +++ b/library/debugger.factor @@ -42,17 +42,17 @@ USE: unparser : parse-dump ( error -- ) <% - "parse-name" get [ "" ] unless* % ":" % - "line-number" get [ 1 ] unless* unparse % ": " % + "error-parse-name" get [ "" ] unless* % ":" % + "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. diff --git a/library/errors.factor b/library/errors.factor index bb4f09b242..835877f88a 100644 --- a/library/errors.factor +++ b/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 - #! error. + #! Save the stacks and parser state for post-mortem + #! 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 diff --git a/library/init.factor b/library/init.factor index 0d70404f00..7e844d0384 100644 --- a/library/init.factor +++ b/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. "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 - ] [ - f "top-level-continuation" set - ] ifte ; + [ + interpreter-loop + ] [ + default-error-handler suspend + ] catch + ] when ; diff --git a/library/inspect-vocabularies.factor b/library/inspect-vocabularies.factor index e7d7349dd9..d204d60487 100644 --- a/library/inspect-vocabularies.factor +++ b/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 . ; diff --git a/library/interpreter.factor b/library/interpreter.factor index 1fb5c2dee4..7b5db97a8a 100644 --- a/library/interpreter.factor +++ b/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 "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 ; diff --git a/library/platform/jvm/combinators.factor b/library/platform/jvm/combinators.factor index de2b617ed0..8bdd24694e 100644 --- a/library/platform/jvm/combinators.factor +++ b/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 diff --git a/library/platform/jvm/init.factor b/library/platform/jvm/init.factor index bf12631b4b..10a1b23ab2 100644 --- a/library/platform/jvm/init.factor +++ b/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 ; @@ -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 [ diff --git a/library/platform/jvm/parser.factor b/library/platform/jvm/parser.factor index a87cc71d27..9b311b7fa5 100644 --- a/library/platform/jvm/parser.factor +++ b/library/platform/jvm/parser.factor @@ -57,7 +57,7 @@ USE: streams #! global [ "in" get ] bind f t parse* ; -: interactive-run-file ( path -- ) +: (run-file) ( path -- ) dup interactive-parse-stream call ; : parse ( string -- list ) diff --git a/library/platform/native/boot.factor b/library/platform/native/boot.factor index 61b899f27d..79b5e8877f 100644 --- a/library/platform/native/boot.factor +++ b/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 diff --git a/library/platform/native/errors.factor b/library/platform/native/errors.factor index cf59f9fa31..344cfdf963 100644 --- a/library/platform/native/errors.factor +++ b/library/platform/native/errors.factor @@ -82,5 +82,5 @@ DEFER: default-error-handler : init-errors ( -- ) 64 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 ) ; diff --git a/library/platform/native/init.factor b/library/platform/native/init.factor index cc63066229..4b0f673b93 100644 --- a/library/platform/native/init.factor +++ b/library/platform/native/init.factor @@ -55,20 +55,26 @@ USE: unparser : boot ( -- ) init-gc init-namespaces - init-stdio - "stdio" get "stdio" set - init-errors - init-search-path - init-scratchpad - init-styles - init-vocab-styles ! Some flags are *on* by default, unless user specifies ! -no- CLI switch t "user-init" set t "interactive" set + init-stdio + "stdio" get "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 ; diff --git a/library/platform/native/parse-stream.factor b/library/platform/native/parse-stream.factor index efd0f964a6..d927189ba7 100644 --- a/library/platform/native/parse-stream.factor +++ b/library/platform/native/parse-stream.factor @@ -57,23 +57,28 @@ USE: strings "parse-stream" get fclose rethrow ] catch ; -: init-parser ( name -- seed ) - "parse-name" set +: file-vocabs ( -- ) "file-in" get "in" set "file-use" get "use" set - f ; + ; : parse-stream ( name stream -- code ) - [ - >r init-parser r> [ (parse) ] read-lines nreverse - ] bind ; + #! Uses the current namespace for temporary variables. + >r "parse-name" set f r> [ (parse) ] read-lines nreverse ; : parse-file ( file -- code ) dup 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. + [ file-vocabs parse-file ] bind call ; + : resource-path ( -- path ) "resource-path" get [ "." ] unless* ; diff --git a/library/platform/native/stream.factor b/library/platform/native/stream.factor index f9353d8a36..3e904b7f2b 100644 --- a/library/platform/native/stream.factor +++ b/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 "stdio" set ; + +: exists? ( file -- ? ) + #! This is terrible. + [ fclose t ] [ nip not ] catch ; diff --git a/native/primitives.c b/native/primitives.c index 175532fde3..b366fac3a5 100644 --- a/native/primitives.c +++ b/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) diff --git a/native/primitives.h b/native/primitives.h index 42d1f01859..3d76ad2d0e 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,5 +1,5 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 89 +#define PRIMITIVE_COUNT 90 CELL primitive_to_xt(CELL primitive); diff --git a/native/run.c b/native/run.c index 716d63ff48..6e20009ca1 100644 --- a/native/run.c +++ b/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))); +} diff --git a/native/run.h b/native/run.h index 6459f513bb..65c408779e 100644 --- a/native/run.h +++ b/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);