basis/command-line/command-line.factor

   1 ! Copyright (C) 2003, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.strings assocs continuations
   4 io.encodings.utf8 io.files kernel kernel.private namespaces
   5 parser sequences source-files.errors splitting system
   6 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: script
  22 SYMBOL: command-line
  23
  24 : (command-line) ( -- args )
  25     OBJ-ARGS special-object sift [ alien>native-string ] map ;
  26
  27 : delete-user-init-errors ( file -- )
  28     user-init-errors get delete-at* nip
  29     [ notify-error-observers ] when ;
  30
  31 : try-user-init ( file -- )
  32     [ delete-user-init-errors ] keep
  33     "user-init" get swap '[
  34         _ [ ?run-file ] [
  35             <user-init-error>
  36             swap user-init-errors get set-at
  37             notify-error-observers
  38         ] recover
  39     ] when ;
  40
  41 : run-bootstrap-init ( -- )
  42     "~/.factor-boot-rc" try-user-init ;
  43
  44 : run-user-init ( -- )
  45     "~/.factor-rc" try-user-init ;
  46
  47 : load-vocab-roots ( -- )
  48     "user-init" get [
  49         "~/.factor-roots" [
  50             utf8 file-lines harvest [ add-vocab-root ] each
  51         ] when-file-exists
  52         "roots" get [
  53             os windows? ";" ":" ?
  54             split [ add-vocab-root ] each
  55         ] when*
  56     ] when ;
  57
  58 : var-param ( name value -- ) swap set-global ;
  59
  60 : bool-param ( name -- ) "no-" ?head not var-param ;
  61
  62 : param ( param -- )
  63     "=" split1 [ var-param ] [ bool-param ] if* ;
  64
  65 : (parse-command-line) ( args -- )
  66     [
  67         unclip "-" ?head [
  68             [ CHAR: - = ] trim-head
  69             [ param ] [ "run=" head? ] bi
  70             [ command-line set ]
  71             [ (parse-command-line) ] if
  72         ] [
  73             script set command-line set
  74         ] if
  75     ] unless-empty ;
  76
  77 : parse-command-line ( args -- )
  78     command-line off
  79     script off
  80     rest (parse-command-line) ;
  81
  82 SYMBOL: main-vocab-hook
  83
  84 : main-vocab ( -- vocab )
  85     embedded? [
  86         "alien.remote-control"
  87     ] [
  88         main-vocab-hook get [ call( -- vocab ) ] [ "listener" ] if*
  89     ] if ;
  90
  91 : default-cli-args ( -- )
  92     [
  93         "e" off
  94         "user-init" on
  95         main-vocab "run" set
  96     ] with-global ;
  97
  98 STARTUP-HOOK: [
  99     H{ } user-init-errors set-global
 100     default-cli-args
 101 ]
 102
 103 { "debugger" "command-line" } "command-line.debugger" require-when