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 tools.errors
   7 vocabs.loader ;
   8 IN: command-line
   9
  10 SYMBOL: user-init-errors
  11 SYMBOL: +user-init-error+
  12
  13 T{ error-type
  14     { type +user-init-error+ }
  15     { word ":user-init-errors" }
  16     { plural "rc file errors" }
  17     { icon "vocab:ui/tools/error-list/icons/user-init-error.tiff" }
  18     { quot [ user-init-errors get-global values ] }
  19     { forget-quot [ user-init-errors get-global delete-at ] }
  20 } define-error-type
  21
  22 : :user-init-errors ( -- )
  23     user-init-errors get-global values errors. ;
  24
  25 TUPLE: user-init-error error file line# asset ;
  26
  27 : <user-init-error> ( error -- error' )
  28     [ ] [ error-file ] [ error-line ] tri
  29     f user-init-error boa ; inline
  30 M: user-init-error error-file file>> ;
  31 M: user-init-error error-line line#>> ;
  32 M: user-init-error error-type drop +user-init-error+ ;
  33
  34 SYMBOL: script
  35 SYMBOL: command-line
  36
  37 : (command-line) ( -- args )
  38     OBJ-ARGS special-object sift [ alien>native-string ] map ;
  39
  40 : rc-path ( name -- path )
  41     home prepend-path ;
  42
  43 : try-user-init ( file -- )
  44     "user-init" get swap '[
  45         _ [ ?run-file ] [
  46             <user-init-error>
  47             swap user-init-errors get set-at
  48             notify-error-observers
  49         ] recover
  50     ] when ;
  51
  52 : run-bootstrap-init ( -- )
  53     ".factor-boot-rc" rc-path try-user-init ;
  54
  55 : run-user-init ( -- )
  56     ".factor-rc" rc-path try-user-init ;
  57
  58 : load-vocab-roots ( -- )
  59     "user-init" get [
  60         ".factor-roots" rc-path dup exists? [
  61             utf8 file-lines harvest [ add-vocab-root ] each
  62         ] [ drop ] if
  63     ] when ;
  64
  65 : var-param ( name value -- ) swap set-global ;
  66
  67 : bool-param ( name -- ) "no-" ?head not var-param ;
  68
  69 : param ( param -- )
  70     "=" split1 [ var-param ] [ bool-param ] if* ;
  71
  72 : run-script ( file -- )
  73     t parser-quiet? [
  74         [ run-file ]
  75         [ source-file main>> [ execute( -- ) ] when* ] bi
  76     ] with-variable ;
  77
  78 : parse-command-line ( args -- )
  79     [ command-line off script off ] [
  80         unclip "-" ?head
  81         [ param parse-command-line ]
  82         [ script set command-line set ] if
  83     ] if-empty ;
  84
  85 SYMBOL: main-vocab-hook
  86
  87 : main-vocab ( -- vocab )
  88     embedded? [
  89         "alien.remote-control"
  90     ] [
  91         main-vocab-hook get [ call( -- vocab ) ] [ "listener" ] if*
  92     ] if ;
  93
  94 : default-cli-args ( -- )
  95     [
  96         "e" off
  97         "user-init" on
  98         main-vocab "run" set
  99     ] with-global ;
 100
 101 [
 102     H{ } user-init-errors set-global
 103     default-cli-args
 104 ] "command-line" add-startup-hook
 105
 106 { "debugger" "command-line" } "command-line.debugger" require-when