level1/88_main_startup.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 ;; index of the next CLI arg to process
   8 ;; set to 0, negative or ARGC to stop further processing
   9 $value "CLI-ARG-NEXT" 1
  10
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12 ;; environment vars
  13
  14 : (dump-env)  ( -- )
  15   envp @ begin dup c@ while dup type-asciiz cr zcount + 1+ repeat drop
  16 ; (hidden)
  17
  18 : get-env  ( addr count -- addr count true // false )
  19   dup +if
  20     envp @
  21     begin dup c@ while
  22       >r 2dup r@ zcount [char] = str-trim-at-char s=ci if
  23         2drop r> zcount [char] = str-skip-after-char true exit
  24       endif
  25       r> zcount + 1+
  26     repeat drop
  27   endif
  28   2drop false
  29 ;
  30
  31
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 : ARGV-STR  ( argnum -- addr count )
  34   dup 0< over argc >= or if
  35     drop pad 0
  36   else
  37     cells argv + @ zcount
  38   endif
  39 ;
  40
  41
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;; filename is in tloader:fnpad
  44 : (cold-try-load-file)  ( -- successflag )
  45     \ endcr ." ::: trying: " tloader:fnpad count type cr
  46   tloader:fnpad-file? ifnot false exit endif
  47   tloader:fnpad count os:o-rdonly 0 os:open dup -if drop false exit endif
  48   tload-verbose >r
  49   tload-verbose-rc to tload-verbose ;; be silent
  50   ['] tloader:tload-fd catch
  51   r> to tload-verbose
  52   throw
  53   true
  54     \ ." loaded!\n"
  55 ; (hidden)
  56
  57 : (COLD-LOAD-RC)  ( -- ??? )
  58   true tloader:build-liblist-name (cold-try-load-file) drop   ;; try list at home dir
  59   false tloader:build-liblist-name (cold-try-load-file) drop  ;; try list at binary dir
  60   ;; check for "--naked"
  61   argc 1 > if
  62     argc 1 do
  63       \ TODO: create special dictionary for cli args, and simply execute them
  64       i argv-str " --naked" s=ci if unloop exit endif
  65       1  ;; argskip
  66       i argv-str " --verbose-libs" s=ci if 1 to tload-verbose-libs endif
  67       i argv-str " --quiet-libs" s=ci if 0 to tload-verbose-libs endif
  68       i argv-str " --verbose-rc" s=ci if 1 to tload-verbose-rc endif
  69       i argv-str " --quiet-rc" s=ci if 0 to tload-verbose-rc endif
  70       i argv-str " --eval" s=ci if drop 2 endif
  71       i argv-str " -e" s=ci if drop 2 endif
  72     +loop
  73   endif
  74   ;; no "--naked", load .rc
  75   tloader:build-rc-name (cold-try-load-file) drop
  76 ; (hidden)
  77
  78
  79 : CLI-ARG-SKIP  ( -- )
  80   cli-arg-next 1+ to cli-arg-next
  81 ;
  82
  83 : (COLD-CLI)  ( -- ??? )
  84   ;; load "urforth.rc" (if present)
  85   (cold-load-rc)
  86   ;; process CLI args
  87   ;; don't use DO ... LOOP here, use CLI-ARG-NEXT
  88   begin
  89     cli-arg-next argc <
  90     cli-arg-next 0> and
  91   while
  92     ;; empty arg?
  93     cli-arg-next argv-str cli-arg-skip
  94     ?dup ifnot
  95       drop
  96     else
  97       ;; ( addr count )
  98       ;; "-..." args?
  99       over c@ [char] - = if
 100         ;; "-e" or "--eval" ?
 101         2dup " -e" s=ci >r
 102         " --eval" s=ci r> or
 103         ;; note that argv is dropped here
 104         if  ;; set TIB and eval
 105           cli-arg-next argv-str cli-arg-skip evaluate
 106         endif
 107         ;; unknown "-..." args are skipped
 108       else  ;; filename arg
 109         tload
 110       endif
 111     endif
 112   repeat
 113 ; (hidden)
 114
 115
 116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117 : (URVERSION->PAD)  ( -- addr count )
 118   base @ >r decimal
 119   " UrForth level " pad c4s:copy-counted
 120   (urforth-level) <#u bl hold #s #> pad c4s:cat-counted
 121   " v" pad c4s:cat-counted
 122   (urforth-version) 24 rshift 0xff and <#u [char] . hold #s #> pad c4s:cat-counted
 123   (urforth-version) 16 rshift 0xff and <#u [char] . hold #s #> pad c4s:cat-counted
 124   (urforth-version) 0x7fff and <#u #s #> pad c4s:cat-counted
 125   (urforth-version) 0x8000 and if " -beta" pad c4s:cat-counted endif
 126   r> base !
 127   pad count
 128 ;
 129
 130 : (.VERSION)  ( -- )
 131   (*
 132   base @ >r decimal
 133   ." UrForth level "
 134   (urforth-level) .
 135   ." v"
 136   (urforth-version) 24 rshift 0xff and 0 .r [char] . emit
 137   (urforth-version) 16 rshift 0xff and 0 .r [char] . emit
 138   (urforth-version) 0x7fff and 0 .r
 139   (urforth-version) 0x8000 and if ." -beta" endif
 140   r> base !
 141   *)
 142   (urversion->pad) type
 143 ;
 144
 145 : (.BANNER)  ( -- )
 146   endcr (.version) cr
 147 ; (hidden)
 148
 149
 150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 151 ;; called to print a banner after processing CLI args
 152 $defer ".BANNER" cfa "(.banner)"
 153
 154 ;; called (once!) to process CLI args
 155 $defer "PROCESS-CLI-ARGS" cfa "(cold-cli)"
 156
 157 ;; main program loop, should never return
 158 $defer "MAIN-LOOP" cfa "quit"  ;; this word should never return
 159
 160
 161 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 162 : COLD  ( ??? )
 163   abort-cleanup
 164   .banner
 165   main-loop
 166   ;; just in case it returns
 167   bye
 168 ; (noreturn)
 169
 170 : (COLD-FIRSTTIME)  ( ??? )
 171   sp0! rp0!
 172   tib-allocate-default
 173   pad-allocate
 174   1 to cli-arg-next
 175   (abort-cleanup-min)
 176   (startup-init)
 177   abort-cleanup
 178   process-cli-args
 179   here (dp-protect)  ;; why not
 180   cold
 181   ;; just in case it returns
 182   bye
 183 ; (hidden) (noreturn)