basis/command-line/command-line.factor

   1 ! Copyright (C) 2003, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.strings assocs continuations fry init
   4 io.encodings.utf8 io.files io.pathnames kernel kernel.private
   5 namespaces parser parser.notes sequences source-files
   6 source-files.errors splitting system vocabs.loader ;
   7 IN: command-line
   8
   9 SYMBOL: user-init-errors
  10 SYMBOL: +user-init-error+
  11
  12 TUPLE: user-init-error error path line# asset ;
  13
  14 : <user-init-error> ( error -- error' )
  15     [ ] [ error-file ] [ error-line ] tri
  16     f user-init-error boa ; inline
  17 M: user-init-error error-file path>> ;
  18 M: user-init-error error-line line#>> ;
  19 M: user-init-error error-type drop +user-init-error+ ;
  20
  21 SYMBOL: executable
  22 SYMBOL: script
  23 SYMBOL: command-line
  24
  25 : (command-line) ( -- args )
  26     OBJ-ARGS special-object sift [ alien>native-string ] map ;
  27
  28 : rc-path ( name -- path )
  29     home prepend-path ;
  30
  31 : try-user-init ( file -- )
  32     "user-init" get swap '[
  33         _ [ ?run-file ] [
  34             <user-init-error>
  35             swap user-init-errors get set-at
  36             notify-error-observers
  37         ] recover
  38     ] when ;
  39
  40 : run-bootstrap-init ( -- )
  41     ".factor-boot-rc" rc-path try-user-init ;
  42
  43 : run-user-init ( -- )
  44     ".factor-rc" rc-path try-user-init ;
  45
  46 : load-vocab-roots ( -- )
  47     "user-init" get [
  48         ".factor-roots" rc-path dup exists? [
  49             utf8 file-lines harvest [ add-vocab-root ] each
  50         ] [ drop ] if
  51         "roots" get [
  52             os windows? ";" ":" ?
  53             split [ add-vocab-root ] each
  54         ] when*
  55     ] when ;
  56
  57 : var-param ( name value -- ) swap set-global ;
  58
  59 : bool-param ( name -- ) "no-" ?head not var-param ;
  60
  61 : param ( param -- )
  62     "=" split1 [ var-param ] [ bool-param ] if* ;
  63
  64 : run-script ( file -- )
  65     t parser-quiet? [
  66         [ run-file ]
  67         [ path>source-file main>> [ execute( -- ) ] when* ] bi
  68     ] with-variable ;
  69
  70 : (parse-command-line) ( args -- )
  71     [
  72         unclip "-" ?head [
  73             [ param ] [ "run=" head? ] bi
  74             [ command-line set ]
  75             [ (parse-command-line) ] if
  76         ] [
  77             script set command-line set
  78         ] if
  79     ] unless-empty ;
  80
  81 : parse-command-line ( args -- )
  82     command-line off
  83     script off
  84     unclip executable set
  85     (parse-command-line) ;
  86
  87 SYMBOL: main-vocab-hook
  88
  89 : main-vocab ( -- vocab )
  90     embedded? [
  91         "alien.remote-control"
  92     ] [
  93         main-vocab-hook get [ call( -- vocab ) ] [ "listener" ] if*
  94     ] if ;
  95
  96 : default-cli-args ( -- )
  97     [
  98         "e" off
  99         "user-init" on
 100         main-vocab "run" set
 101     ] with-global ;
 102
 103 [
 104     H{ } user-init-errors set-global
 105     default-cli-args
 106 ] "command-line" add-startup-hook
 107
 108 { "debugger" "command-line" } "command-line.debugger" require-when