root/trunk/thune/mkboot.t

#!./thune

{
context! [
  logic! 1 make :true
  logic! 0 make :false

  opcode!  0 'nop     make :nop
  opcode!  3 'drop    make :drop
  opcode!  4 'dup     make :dup
  opcode!  5 'dup2    make :dup2
  opcode!  6 'over    make :over
  opcode!  7 'swap    make :swap
  opcode!  8 'nip     make :nip
  opcode!  9 'tuck    make :tuck
  opcode! 10 'rot     make :rot
  opcode! 11 'rot.r   make :rot.r
  opcode! 12 'do      make :do
  opcode! 13 'proc    make :proc
  opcode! 14 'iter    make :iter
  opcode! 15 'each    make :each
  opcode! 16 'recurse make :recurse
  opcode! 17 'return  make :return
  opcode! 18 'throw   make :throw
  opcode! 19 'try     make :try
  opcode! 20 'ift     make :ift
  opcode! 21 'if-some make :if-some
  opcode! 22 'iff     make :iff
  opcode! 23 'or-else make :or-else
  opcode! 24 'if      make :if
  opcode! 25 'halt    make :halt
  opcode! 26 'quit    make :quit
  opcode! 27 'inc     make :inc
  opcode! 28 'dec     make :dec
  opcode! 29 '++      make :++
  opcode! 30 '--      make :--
  opcode! 31 'verify  make :verify
  opcode! 32 'forever make :forever
  opcode! 33 'loop    make :loop

  int!/decimal! :number!
  word!/set-word!/get-word!/lit-word! :any-word!
  binary!/string!/block!/paren! :series!
] make :kernel-ops
}
:boot-script

{
logic! 1 make dup :yes :on
logic! 0 make dup :no :off
char!  9 make :tab
char! 10 make :eol
3.14159265358979323846 :pi
tail?: :empty?
[quit] proc :q
[block!  swap make] proc :to-block
[string! to] proc :to-string
[context! swap make] proc :context

[
  read
  dup \"#!\" match ift (eol find)
  to-block kernel-ops infuse
] proc :load    ;(filename -- block)

[open swap string! to write close] proc :save    ;(value filename -- )

[select if-some do] proc :case

['break throw] proc :break

[
  [dup do iff break over do] forever
  drop drop
]
'loop proc :while  ;(block cond -- )

[body  n number!  limit number!] [
  n
  [[dup limit lt? iff break  dup body do  inc]
   [dup limit gt? iff break  dup body do  dec]]
  over limit lt? pick
  forever drop
] 'loop func :loop.to

[ser words block! body block!]
[
  ser [words set body do] words length? iter
]
'loop func :each.set    ;(ser words body -- )

[ser comb] [
  ser [dup first comb do 1 poke drop] iter
] 'loop func :map       ;(ser comb -- )

[[do if-some return] each false] proc :any    ; (blk -- logic)

[[do dup iff return drop] each true] proc :all    ; (blk -- logic)

[ser old new | len] [
  old length? :len
  ser old find if-some (new len change :ser recurse)
  ser
] func :replace.all     ;(ser old new -- ser)


[reduce to-text console.out] proc :prin  ;(val -- )
[reduce [first to-text console.out] iter] proc :prin.pack  ;(val -- )
[reduce to-text console.out eol console.out] proc :print   ;(val -- )

[error! swap make throw] proc :error
[swap context bind proc] proc :proc.env      ;(env body -- proc)
[rot  context bind func] proc :func.env      ;(env sig body -- func)
[
  [some none] copy swap 2 poke
  parse
  dup tail? iff (
    \"parse.some failed at -^^/\" copy
      swap string! as 80 copy.part
      append
    error
  ) drop
]
proc :parse.some  ;(data rules -- )

[
  0,0,5 :version
  none :os
  [] :devices
]
context :script-env

[swap copy swap append head] proc :join   ; (base addition -- new)

[val block!]
[
  val dup empty? ift return
  reduce
  dup first
    dup series! is-type? [copy] [to-text] either :val
  next [
    first val swap append drop
  ] iter
  val
] func :rejoin  ; (block -- string)

[ser pat rep]
[
  ser [dup first pat if/eq (rep 1 poke) drop] iter
  ser
]
func :replace   ; (ser pat rep -- ser)

[bind [dup second swap first set] iter/2] proc :set-key-values ; (blk ctx -- )

[now swap do now swap sub] proc :time-blk

[
  dup [
    \".\"   [drop \"./\"  none]
    \"..\"  [drop \"../\"  none]
    [
      dup last '/' eq? ift (none return)
      dup '/' find.last dup iff (swap return)
      ; fullpath file
      next
      dup2 slice
      rot.r nip
    ]
  ] case
] proc :split-path    ; (fullpath -- path file)

[
  dup last dup '/' if/eq (drop return)
    '\\' if/eq return
  '/' append head
] proc :dirize    ; (path -- path)

[0 swap add] proc :to-dec
[rot minimum maximum] proc :limit   ; (n min max -- n)

[blk | ctx num word]
[
  [] context :ctx
  blk [num word][
    opcode! num word make word ctx set
  ] each.set
  ctx
] func :make-opcodes    ; (block -- ctx)
}
:env-script

/*
  [devices select next copy] proc :make-port  ; (name -- port)

  [name spec] [
    devices name append spec context append drop
  ] func :add-port-device

  'file [none :fd none :filename] add-port-device

  quit: :q                  ; Can't get opcode!
  none!  0 make :none
  logic! 1 make [true yes on] set
  logic! 0 make [false no off] set
*/


[
    dup first eol eq? ift next
    [
        :tok to eol tok: skip
            (tok tail? iff ({  "} prin tok prin {\n"} print))
    ]
    parse.some
]
proc :print-c   ; (string -- )


{/* Generated by mkboot.t */

static char _bootScript[] =} print
    boot-script print-c
{;

static char _envScript[] =} print
    env-script print-c
';' print


;eof