root/trunk/orca/boot.r

REBOL [
    Purpose: {ORCA boot-strap script.}
]


natives: [
    ;native: native [spec [block!]]
    sizeof: native []

    comment: native [value]

    set: native [
        word  ; [any-word! none!]
        value ; [any-type!]
        ;/any
    ]

    unset: native [
        word [word! block!]
    ]

    value?: native [val]
    any-word?: native [val]

    get: native [
        word ; [any-word! none!]
        ;/any
    ]

    do: native [
      "Evaluates a block or any other value."
      value
      /args arg
      ;/next
    ]

    make: native [
        "Construct new value"
        type
        spec
    ]

    bind: native [
        words [block! word!]        ;[block! any-word!]
        known-word [word! object!]  ;[any-word! object! port!]
        /copy
    ]

    in: native [
        object [object!] ; port!
        word [word!]     ; any-word!
    ]

    use: native [
        words [block! word!]
        body [block!]
    ]

    copy: native [
        value [series! bitset! matrix!]     ; [series! port!]
        /part
        range [integer! series!]    ; [number! port! pair!]
        /deep
    ]

    change: native [
        series [series!]    ; port!
        value               ; [any-type!]
        /part
        range [integer! series!]    ; [number! port!]
        /only
    ]

    find: native [
        series [series!]    ; port! bitset!
        value   ; [any-type!]
        /match
        /last
        /skip size [integer!]
        ;/part
        ;range   ; [number! series! port!]
        ;/case
    ]

    reduce: native [
        value
    ]

    compose: native [
        value
        /deep
        /only
    ]

    form: native [
        value
    ]

    mold: native [
        value
        /only
        ;/all
        ;/flat
    ]

    not: native [ value ]

    print: native [ value ]
    prin: native [ value ]

    clear: native [
        series [series! none!]    ;port! bitset!
    ]

    skip: native [
        series [series!]    ;port!
        offset [number! logic!]  ; pair!
    ]

    at: native [
        series [series!]    ; port!
        index [number! logic!]  ; pair!
    ]

    pick: native [
        series [series! tuple! matrix!]    ; time! object! port! ...
        index [number! logic!]  ; pair!
    ]

    poke: native [
        value
        index [number! logic!]  ; pair!
        data
    ]

    select: native [
        series [series!] ; port!
        value
        ;/part
        ;range [number! series!]  ; port!
        ;/only
        ;/case
        ;/skip
        ;size [integer!]
    ]

    first:  native [ value ]
    second: native [ value ]
    third:  native [ value ]

    last: native [ value [series! tuple!] ]  ;port!

    reverse: native [
        value [series! tuple! pair!]
        /part
        range [integer! series!]
    ]

    parse: native [
        input [series!]
        rules [block! string! none!]
        /all
        /case
    ]

    type?: native [value /word]
    length?: native [value [series! tuple!]]  ; port! bitset! struct!
    any-string?: native [value]
    any-block?: native [value]

    ;series?: native [ value ]
    ;integer?: native [ value ]
    ;tag?: native [ value ]

    binary?:
    bitset?:
    block?:
    char?:
    datatype?:
    decimal?:
    error?:
    file?:
    function?:
    getword?:
    hash?:
    integer?:
    issue?:
    list?:
    litpath?:
    litword?:
    logic?:
    native?:
    none?:
    number?:
    object?:
    op?:
    pair?:
    paren?:
    path?:
    refinement?:
    series?:
    setpath?:
    setword?:
    string?:
    tag?:
    time?:
    tuple?:
    unset?:
    word?: native [value]

    to: native [
        type
        value
    ]

    disarm: native [ error [error!] ]
    try:   native [ block [block!] ]
    catch: native [
        block [block!]
        /name word [word!]  ;[word! block!]
    ]
    throw: native [ value /name word [word!] ]

    does: native [ value ]

    func: native [
        ;[catch]
        spec [block!]
        body [block!]
    ]

    if: native [
        condition
        then-block [block!]
        ;/else
        ;else-block [block!]
    ]

    unless: native [
        condition
        then-block [block!]
    ]

    either: native [
        condition
        then-block [block!]
        else-block [block!]
    ]

    any: native [
        block [block!]
    ]

    all: native [
        block [block!]
    ]

    loop: native [
        count [integer!]
        block [block!]
    ]

    repeat: native [
        'word [word!]
        value [integer! series!]
        block [block!]
    ]

    foreach: native [
        'word [word! block!]    ; get-word!
        data [series!]
        body [block!]
    ]

    remove-each: native [
        'word [word! block!] 
        data [series!] 
        body [block!]
    ] 
    
    while: native [
        cond [block!]
        body [block!]
    ]

    until: native [
        cond [block!]
    ]

    break: native [
        /return
        value   ;[any-type!]
    ]

    return: native [
        value   ;[any-type!]
    ]

    exit: native []

    back: native [
        series [series!]    ; [series! port!]
    ]

    next: native [
        series [series!]    ; [series! port!]
    ]

    head: native [
        series [series!]    ; [series! port!]
    ]

    tail: native [
        series [series!]    ; [series! port!]
    ]

    index?: native [
        series [series!]    ; [series! port!]
    ]

    head?: native [
        series [series!]    ; port!
    ]

    tail?: native [
        series [series!]    ; [series! port! bitset!]
    ]

    insert: native [
        series [series!]    ;[series! port! bitset!]
        value  ;[any-type!]
        /part
        range  [integer! series!] ;[number! series! port! pair!]
        /only
        ;/dup
        ;count [integer!] ;[number! pair!]
    ]

    remove: native [
        series [series! none!]    ; [series! port! bitset! none!]
        /part
        range [integer! series! pair!] ; [number! series! port! pair!]
    ]

    lowercase: native [
        string [string! file!]  ; any-string!
        /part range [integer!]  ; any-string!
    ]

    uppercase: native [
        string [string! file!]  ; any-string!
        /part range [integer!]  ; any-string!
    ]

    load: native [
        source [file! string!]  ; url! any-block! binary!
    ]


    open:  native [ what ]
    close: native [ port [port!] ]

    read: native [
        source [file! port!]  ; block! object! url!
        /binary
        /lines
        /skip length [number!]
        /part size [number!]
        ; many more...
    ]

    write: native [
        dest [file! port! object! block!] ; url!
        value
        /binary
        /append
        ;/lines
        ; many more...
    ]

    rename: native [
        old [file!]             ; url!
        new [file! string!]     ; url!
    ]

    delete: native [
        what [file!]    ; url!
    ]

    exists?: native [
        target [file!]  ; url!
    ]

    size?: native [
        target [file!]  ; url!
    ]

    dir?: native [
        target [file!]  ; url!
    ]

    modified?: native [
        target [file!]  ; url!
    ]

    getenv: native [name [string!]]

    change-dir: native [value]
    what-dir: native []
    make-dir: native [path [file!]]     ; url!

    clean-path: native [path [file!]]   ; url!

    recycle: native [/off /on]

    halt: native []
    quit: native [/return code]

    protect: native [
        value [word! block!]
    ]

    now: native [
        ;/year
        ;/month
        ;/day
        /time
        ;/zone
        ;/date
        ;/weekday
        ;/precise
    ]

    trim: native [
        string [string! series!]  ; [series! port!]
        /auto
        /head
        /tail
        ;/all
        ;/lines
        ;/with
        ;pattern [char! string!]
    ]

    ;to-hex: native [
    ;    value [integer!]
    ;]   
    ;sizeof: native []
    ;memory: native []
    dump: native [val]

    same?: native [v1 v2]
    equal?: native [v1 v2]
    strict-equal?: native [v1 v2]
    greater-or-equal?: native [v1 v2]
    greater?: native [v1 v2]
    lesser-or-equal?: native [v1 v2]
    lesser?: native [v1 v2]

    odd?: native [number [number! char!]]  ; date! time!
    even?: native [number [number! char!]]  ; date! time!
    abs: native [number [number! pair!]] ; date! time!
    complement: native [value [logic! integer! bitset!]] ;number! char! tuple!
    negate: native [number [number! pair! bitset! vec3!]] ; time!

    sine: native [value [number!] /radians]
    cosine: native [value [number!] /radians]
    arcsine: native [value [number!] /radians]
    arccosine: native [value [number!] /radians]
    tangent: native [value [number!] /radians]
    arctangent: native [value [number!] /radians]
    square-root: native [value [number!]]

    random: native [value /seed /only]
    power: native [x [number!] y [number!]]
    remainder: native [
        x [number!]   ; pair! char! time! tuple!
        y [number!]   ; pair! char! time! tuple!
    ]


    ; config compress

    compress: native [data [string! binary!]] ; any-string!
    decompress: native [data [binary!]]


    ; config glmath

    dot:   native [a [vec3!] b [vec3!]]
    cross: native [a [vec3!] b [vec3!]]
    normalize: native [vec [vec3!]]
]


boot: [
    context: func [blk [block!]] [make object! blk]

    probe: func [ value ][ print mold :value :value ]

    source: func ['word] [
        prin rejoin [word ": "]
        either function? get word [
            print mold get word
        ][
            either native? get word
                [print mold get word]
                [print "is not a function"]
        ]
    ]

    function: func [
        spec [block!]
        vars [block!]
        body [block!]
    ][
        func head insert insert tail copy spec /local vars body
    ]

    true: yes: on:  make logic! 1
    false: no: off: make logic! 0

    newline: #"^/"

    empty?: :tail?
    q: :quit

    orca: true

    system: context [
        version: 0.0.23
        os: none
        error: context [
          msg: type: id: near: none
        ]
        error-types: [ 'syntax 'script 'math 'access 'internal ]
        words: none
        script-proto: context [
            args:
            path:
            parent:
            header: none
        ]
        script: none

        ;console: context [
        ;  history: []
        ;  prompt: {>> }
        ;]
    ]

    protect 'system
    protect 'datatypes

    to-binary: func [value][to binary! :value]
    to-bitset: func [value][to bitset! :value]
    to-block: func [value][to block! :value]
    to-char: func [value][to char! :value]
    ;to-date: func [value][to date! :value]
    to-decimal: func [value][to decimal! :value]
    to-file: func [value][to file! :value]
    to-get-word: func [value][to get-word! :value]
    ;to-hash: func [value][to hash! :value]
    to-integer: func [value][to integer! :value]
    to-issue: func [value][to issue! :value]
    ;to-list: func [value][to list! :value]
    to-lit-path: func [value][to lit-path! :value]
    to-lit-word: func [value][to lit-word! :value]
    to-logic: func [value][to logic! :value]
    ;to-pair: func [value][to pair! :value]
    to-paren: func [value][to paren! :value]
    to-path: func [value][to path! :value]
    to-refinement: func [value][to refinement! :value]
    to-set-path: func [value][to set-path! :value]
    to-set-word: func [value][to set-word! :value]
    to-string: func [value][to string! :value]
    to-tag: func [value][to tag! :value]
    to-time: func [value][to time! :value]
    to-tuple: func [value][to tuple! :value]
    ;to-url: func [value][to url! :value]
    to-word: func [value][to word! :value]

    charset: func [str [string! block!]] [make bitset! str]

    append: func [
        series [series!]    ; [series! port!]
        value
        /only
    ][
        head either only
            [insert/only tail series :value]
            [insert tail series :value]
    ]

    rejoin: func [
        block [block!]
    ][
        if empty? block: reduce block [return block]
        append either series? first block
            [copy first block]
            [form first block]
        next block
    ]

    replace: func [
        series [series!]
        pattern
        with
        /all
        /local orig len
    ][
      orig: series
      if (any-string? series) and any [not any-string? :pattern tag? :pattern][
          pattern: form :pattern
      ]
      len: either any [any-string? series any-block? :pattern]
          [length? :pattern]
          [1]
      while [series: find series :pattern][
          series: change/part series :with len
          if not all [break]
      ]
      orig
    ]

    forall: func [
        [throw]
        'word [word!]
        body [block!]
    ][
        while [not tail? get word] [
          do body
          set word next get word
        ]
    ]

    switch: func [
        [throw]
        value
        options [block!]
        /default else
    ][
        either value: select options value
            [do value]
            [either default [do else][none]]
    ]

    forever: func [
        [throw]
        body [block!]
    ][
        while [1] body
    ]

    forskip: func [
        [throw]
        'iter [word!]
        mod   [integer!]
        body  [block!]
    ][
        while [not tail? get iter] [
            do body
            set iter skip get iter mod
        ]
    ]

    join: func [a b] [
        a: either series? a [copy a][form a]
        head insert tail a reduce :b
    ]

    reform: func [value] [
        form reduce value
    ]

    repend: func [
        series [series!]  ; port!
        value
        /only
    ][
        head either only
            [insert/only tail series reduce :value]
            [insert tail series reduce :value]
    ]

    save: func [
        file [file!]
        data
    ][
        write file mold/only data
    ]

    dirize: func [path [file! string!] /local end]
    [
        end: last path
        either all [
            end <> #"/"
            end <> #"\"
        ][ append path #"/" ][ path ]
    ]

    time-block: func [blk /local a b] [a: now/time do blk b: now/time b - a]
]


do %config.r
if find config 'rebol [append boot load %rebol_compat.r]

if find config 'os_call [
    append natives [
        call: native [
            command [string! block!]
            ;/input
            ;in [string! file! none!]    ; [any-string! port! file! url! none!]
            /output
            out [string! file! none!]    ; [string! port! file! url! none!]
            /wait
            ;/console
            ;/shell
            ;/info
        ]
    ]
]

;eof