path: root/compiler/standardClient.ey

< # sys extensions
  # TODO: handle EINTR correctly

  0 _ ==RDONLY
  1 _ ==WRONLY
  2 _ ==RDWR
      bor bor ==RWMASK

  1 ==PROTREAD
  2 ==PROTWRITE
  4 ==PROTEXEC

  2 ==MAPPRIVATE
  32 ==MAPANONYMOUS
  
  0 ==READ
  1 ==WRITE
  2 ==OPEN
  3 ==CLOSE

  9 ==MMAP
  11 ==MUNMAP

  { < ==mode ==flags ==fd <
      { flags RWMASK bnot band RDONLY bor =flags } /readonly deff
      { flags RWMASK bnot band WRONLY bor =flags } /writeonly deff
      { flags RWMASK bnot band RDWR bor =flags } /readwrite deff
      { ==path
        fd 0 ge { "file already open" die } rep 
        path "\0" cat flags mode 0 0 0 OPEN sys .asm .syscall -- _ =fd
        0 lt { "cannot open " path cat die } rep
      } /open deff
      {
        fd 0 0 0 0 0 CLOSE sys .asm .syscall --
        0 lt { "bad things happened to your close call" die } rep
      } /close deff
      { ==count
        fd 0 lt { "file not open" die } rep 
        count str .alloc ==buf
        fd buf count 0 0 0 READ sys .asm .syscall -- _
        0 lt { "read failed" die } rep
        buf str .inplacePrefix
      } /read deff
      { ==buf
        fd 0 lt { "file not open" die } rep 
        fd buf _ len 0 0 0 WRITE sys .asm .syscall -- _
        0 lt { "write failed" die } rep
      } /write deff
      { ==buf
        fd 0 lt { "file not open" die } rep 
        { buf len } { 
          fd buf _ len 0 0 0 WRITE sys .asm .syscall -- _
          0 lt { "write failed" die } rep
          buf str .postfix =buf
        } loop
      } /writeall deff
  > > -- } /makefile deff

  { # 0777 = 511
    1 neg RDONLY 511 makefile
  } /file sys .deff

  0 RDONLY 0 makefile /in sys .defv
  1 WRONLY 0 makefile /out sys .defv
  2 WRONLY 0 makefile /err sys .defv

  < # sys .asm extensions
    { ==reqAddr ==reqSize
      <
        reqAddr
        reqSize
        PROTEXEC PROTREAD PROTWRITE bor bor
        MAPPRIVATE MAPANONYMOUS bor
        1 neg
        0
        MMAP sys .asm .syscall -- _
        0 lt { "mmap failed" die } rep

        ==base
        reqSize ==size

        {
          base size 0 0 0 0 MUNMAP sys .asm .syscall --
          0 lt { "munmap failed" die } rep
        } =*free
      >
    } /allocAt sys .asm .deff

    {
      0 sys .asm .allocAt
    } /alloc sys .asm .deff
  > --

  < # sys .typed extensions

    # Returns an array which lists the sequence of curried arguments
    # i.e. if f: A -> B -> C -> D -> E the result will be [ A B C D ]
    { ==object
      { "unknown type in typeStack" die } ==unknown
      { "invalid type in typeStack" die } ==invalid
      { [ object 0 1 neg ] } ==literal

      object sys .typed .type [
        literal # integer
        literal # string
        literal # scope
        invalid # name table
        invalid # extension area
        { object sys .typed .inputs ==in
          in len 1 neq { "multi-input function in typeStack" die } rep
          [ 0 in * 0 1 neg ]
          object sys .typed .outputs ==out
          out len 1 neq { "multi-output function in typeStack" die } rep
          0 out * typeStackInternal
        } # function
        invalid # function code
        { [ 1 0 object len 1 sub ] 0 object * typeStackInternal } # array
        invalid # function type
        unknown
        unknown
        unknown
        unknown
        unknown
        unknown
        unknown
      ] * *
    } /typeStackInternal deff

    { [ -01 typeStackInternal ] } /typeStack deff

    { -- 0 } /isVariableType deff

    { ==t
      t len 3 neq { "complex execution type non-triple" die } rep

      { "unknown type in typeStack" die } ==unknown
      { "invalid type in typeStack" die } ==invalid

      2 t * 1 t * ge
    } /isIterableType deff

    { =*a =*b
      [
        0 a sys .typed .type 0 b sys .typed .type neq
        { 0 }

        0 a sys .typed .type 0 neq
        { "type equality only implemented for ints" die }

        0 b sys .typed .type 0 neq
        { "type equality only implemented for ints" die }

        0 a 0 b neq { 0 }
        1 { 1 }
      ] conds
    } /typeEqual deff

    { ==earlierType ==laterType
      [
        earlierType laterType typeEqual
        { earlierType 1 }

        # TODO: maybe handle structs here one day (or move the whole affair into
        # a real compilation stage
        0 earlierType * sys .typed .type 0 neq
        { 0 }

        # Who came first determines iteration range
        2 earlierType * 1 neg neq
        { earlierType 1 }

        # But if only the later one defines a range, take that one
        2 laterType * 1 neg neq
        { laterType 1 }

        # General integers go-iterate iff they binary and results in non-zero
        0 earlierType * 0 laterType * band 0 neq
        { earlierType 1 }

        1
        { 0 }
      ] conds
    } /commonIterationType deff

    { ==arr
      0
    } /getLoopStart deff

    { ==arr
      arr len eq
    } /isLoopEnd deff

    { ==arr
      1 add
    } /doLoopStep deff

    # Executing a function f: A->B->C (i.e. B A f) on concrete arguments b a.
    # Phase 1
    #   Foreach argument:
    #     Find the function input type from top of concrete argument type stack,
    #       increase viewport from top of concrete type stack
    #         match type from bottom to top, if type cannot be found, create constant function
    #         final match is that which creates minimal number of constant function layers
    # Phase 2
    #   Foreach argument type:
    #     Identify the type stack above the match from phase 1.
    #     Run from right (stacktop) argument to left (stacklow) argument:
    #       Take topmost type, check whether it can be found in other stacks (from top)
    #         Eliminate all matching types via function or loop creation
    { _ ==f sys .typed .inputs ==inputs
      [ ] ==concreteArgs
      [ ] ==viewPortOffset

      # Phase 1
      0 inputs len 1 sub range reverse {
        # print "Analyzing arg: %d"
        inputs * typeStack ==formalTypeStack
        _ ==c typeStack ==concreteTypeStack
        # "Type-Stack: %d" Dumper($concreteTypeStack) die

        0 ==bestViewPortSize
        concreteTypeStack len 1 add ==bestViewPortMatch

        # "Formal Type Stack: @$formalTypeStack\n" print
        # "       Type Stack: @$concreteTypeStack\n" print

        1 neg concreteTypeStack * isVariableType {
          1 concreteTypeStack len range { ==viewPortSize
            [ 0 viewPortSize 1 sub range { concreteTypeStack * } each ] ==typeViewPort # explicit each here
            # "@$formalTypeStack vs. @$concreteTypeStack\n" print

            formalTypeStack concreteTypeStack typeMismatchCount ==viewPortMatch # FIXME this line seems fishy
            viewPortMatch bestViewPortMatch lt {
              viewPortSize =bestViewPortSize
              viewPortMatch =bestViewPortMatch
            } rep
          } each
        } {
          concreteTypeStack len =bestViewPortSize
          0 =bestViewPortMatch
        } ? *

        # convert concrete argument to exactly matching function
        # ... which calls the concrete argument using its relevant args
        bestViewPortMatch {
          # if argument is concrete, but we need are construction a function overall, then concrete
          # argument needs to be converted to a constant function in whatever domain is necessary
          "concrete argument constant functionification needs to be implemented, mismatch: $bestViewPortMatch" die
          { "magic goes here FIXME" die } =c
        } {
          # zero mismatches, can directly use concrete argument
          [ concreteTypeStack len formalTypeStack len sub ] viewPortOffset cat =viewPortOffset
        } ? *

        [ c ] concreteArgs cat =concreteArgs
      } each

      # "Viewport Offsets: @viewPortOffset\n" print

      # Phase 2,
      [
        0 viewPortOffset len 1 sub range { ==i
          i concreteArgs * typeStack ==remaining
          [ 0 i viewPortOffset * 1 sub range { remaining * } each ] # explicit each here
        } each
      ] ==toBeAbstractedTypes

      "toBeAbstractedTypes: " dump
      toBeAbstractedTypes dump

      [ toBeAbstractedTypes { len } each ] any not {
        # no types need to be abstracted, function can be called
        concreteArgs _ dump _ len dearray f
        "attempting to call function (w.o. abstraction)" dump
        0 concreteArgs len 1 sub range { ==i
          i concreteArgs * sys .typed .type _ dump
          i inputs       * sys .typed .type _ dump
          neq { "invalid input type at argument index " dump i dump "" die } rep
        } each
        *
      } {
        [ ] ==argTypes # the type stack of the new function
        [ ] ==stageCalls # which functions to call in each stage
        [ ] ==loops # undef for lambda abstraction, loop bound source for loops

        0 toBeAbstractedTypes len 1 sub range reverse { ==i
          { i toBeAbstractedTypes * len } {
            # TODO: create a decent shift
            [ i toBeAbstractedTypes * reverse _ len dearray ==type ] reverse i toBeAbstractedTypes =[]
              [ i ] ==stageCalls2
              1 neg ==iterationSource
              type isIterableType { i =iterationSource } rep

              0 i 1 sub range reverse { ==j
                j toBeAbstractedTypes * len not not {
                  0 j toBeAbstractedTypes * * type commonIterationType # -> <type> <any exists>
                  { =type
                    iterationSource 0 lt type isIterableType and { j =iterationSource } rep
                    # TODO: create a decent shift
                    [ j toBeAbstractedTypes * reverse _ len dearray -- ] reverse j toBeAbstractedTypes =[]
                    [ j ] stageCalls2 cat =stageCalls2
                  } rep
                } rep
              } each

              iterationSource 0 ge {
                [ 1 neg ] argTypes cat =argTypes
                [ iterationSource ] loops cat =loops
              } {
                [ type ] argTypes cat =argTypes
                [ 1 neg ] loops cat =loops
              } ? *
            stageCalls [ stageCalls2 ] cat =stageCalls
          } loop
        } each

        "concreteArgs: " dump
        concreteArgs dump
        "stageCalls: " dump
        stageCalls dump
        "argTypes: " dump
        argTypes dump
        "loops: " dump
        loops dump
        
        { ==loops ==argTypes ==stageCalls ==concreteArgs
          stageCalls len not {
            concreteArgs _ len dearray f
            *
          } {
            [ stageCalls _ len dearray ==stage ] =stageCalls
            [ argTypes _ len dearray ==argType ] =argTypes
            [ loops _ len dearray ==loopIndex ] =loops
            loopIndex 0 ge {
              [ ] ==results
              loopIndex concreteArgs * ==loopedOver
              loopedOver getLoopStart ==i
              { i loopedOver isLoopEnd not } {
                [ concreteArgs _ len dearray ] ==concreteArgsCopy
                stage { ==j
                  # TODO: think about a single function returning multiple values
                  i j concreteArgs * * j concreteArgsCopy =[]
                } each

                [ concreteArgsCopy stageCalls argTypes loops unravel ]
                results -01 cat =results
                results dump
                # TODO: think about a single function returning multiple values
                # should be solved by producing two arrays side by side

                i loopedOver doLoopStep =i
              } loop

              results
              # push @$data, [\@results, ['array', '[]', [['range', 0, $#results]], [undef]]];
              # FIXME the undef can be determined
            } {
              { ==v
                stage { ==i
                  v i concreteArgs * * i concreteArgs =[]
                } each

                concreteArgs stageCalls argTypes loops unravel
              } # leave this on the stack
              # push @$data, [$abstraction, ['func', 'autoabstraction of ' . $f->[1]->[1], [grep { $_ } @argTypeCopy], undef]];
              # FIXME the undef can be determined
            } ? *
          } ? *
        } =*unravel

        concreteArgs stageCalls argTypes loops unravel

        "execution complete" dump
      } ? *
    } /execute sys .typed .deff
  > --
> --

# global extensions
<
  [ /0 /1 /2 /3 /4 /5 /6 /7 /8 /9 /A /B /C /D /E /F ] ==base16singleDigits
  [ base16singleDigits { ==first base16singleDigits { first -01 cat } each } each ] ==base16digits

  {
    [ -01 8 { _ 256 mod base16digits * -01 256 div } rep -- ]
    reverse |cat fold
  } /base16encode64 deff

  { ==indent _ ==o
    { "unknown type in dump" die } ==unknown
    { "invalid type in dump" die } ==invalid
        
    "" indent { "  " cat } rep sys .err .writeall
    sys .typed .type [
      { o base16encode64 sys .err .writeall } # integer
      { "\"" o "\"" cat cat sys .err .writeall } # string
      { "<scope>" } # scope
      invalid # name table
      invalid # extension area
      { "<function>" } # function
      invalid # function code
      {
        "[\n" sys .err .writeall
        o { indent 1 add dumpIndented } each
        "" indent { "  " cat } rep "]" cat sys .err .writeall
      } # array
      invalid # function type
      unknown
      unknown
      unknown
      unknown
      unknown
      unknown
      unknown
    ] * *
    "\n" sys .err .writeall
  } /dumpIndented deff

  # dump top stack element to sys .err
  { 0 dumpIndented }
> -- /dump deff

# regex support
# ideas taken from http://swtch.com/~rsc/regexp/regexp3.html
{
  0 ==MATCH 1 ==TERM 2 ==JUMP 3 ==SPLIT 4 ==SAVE

  { ==b ==a [
    [ SPLIT 1 a len 1 add ]
    a _ len dearray
    [ JUMP b len ]
    b _ len dearray
  ] } /alternative deff

  |cat /sequence deff

  { ==a [
    a _ len dearray
    [ SPLIT a len neg 1 ]
  ] } /star deff

  { ==p [
    [ TERM p ]
  ] } /terminal deff

  { ==i ==a [
    [ SAVE i 2 mul ]
    a _ len dearray
    [ SAVE i 2 mul 1 add ]
  ] } /capture deff

  { [ ] } /empty deff

  { ==str
    str len 0 eq {
      1 neg
    } {
      0 str *
    } ? *
  } /head deff

  { 1 -01 str .postfix } /tail deff

  { deff }' /install deff
  [ "(" ")" "[" "]" "-" "|" "^" "*" "." ] { ==c
    { _ head 0 c * eq } "^" c cat install
  } each

  { # ==re
    # "(parse) re: " re cat dump

    seq ==a
    ^| {
      tail parse ==b
      a b alternative =a
    } rep
    a
  } /parse deff

  { # ==re
    # "(seq) re: " re cat dump

    empty _ ==a
            ==l

    {
      # "(seq loop) re: " re cat dump
      _ head 1 neg eq -01
      ^| -01
      ^) -01
      -0321 or or not
    } {
      ^* {
        l star =l
        tail
      } {
        a l sequence =a
        atom =l
      } ? *
    } loop
    a l sequence
  } /seq deff

  { ==e ==t =*i
    { i t e ? * }
  } /ifthenelse deff

  0 ==currentCapture
  
  { # ==re
    # "(atom) re: " re cat dump
    empty ==a

    { ^( } {
      tail parse currentCapture capture =a
      currentCapture 1 add =currentCapture
      ^) not { ") expected" die } rep
      tail
    } { ^[ } {
      tail
      ^^ {
        tail chars ==nset
        { nset not } ==set
        ^] not { "] expected" die } rep
        tail
      } {
        tail chars ==set
        ^] not { "] expected" die } rep
        tail
      } ? *
      set terminal =a
    } { ^. } {
      { -- 1 } terminal =a
      tail
    } {
      _ head { eq }_ terminal =a
      tail
    } ifthenelse ifthenelse ifthenelse *

    a
    # "(atom end) re: " re cat dump
  } /atom deff

  { # ==re
    # "(chars) re: " re cat dump

    ^] {
      tail chars2 ==set
      set { 0 "]" * eq } or =set "TODO" die
    } {
      chars2 ==set
    } ? *
    set
  } /chars deff

  { # ==re
    # "(chars2) re: " re cat dump

    ^- {
      tail chars2 ==set
      set { 0 "-" * eq } or =set "TODO" die
    } {
      charsR ==set
    } ? *
    set
  } /chars2 deff

  { # ==re
    # "(charsR) re: " re cat dump

    charsN ==set
    { ^] not } {
      charsN set or =set "TODO" die
    } loop
    set
  } /charsR deff

  { # ==re
    # "(charsN) re: " re cat dump

    _ head ==start
    tail
    ^- {
      tail
      _ head ==end
      tail
      { "TODO" die } ==set
    } {
      { start eq } ==set
    } ? *
    set
  } /charsN deff

  { <
    0 ==pc
    [ 10 { 0 0 } rep ] ==captures
  > } /newThread deff

  |add /origadd deff

  # TODO think about implementation efficiency
  { < ==maxSize
    0 ==size
    [ maxSize { 0 } rep ] =*get
    [ maxSize { 1 } rep ] =*pcFree

    { ==thread
      thread .pc pcFree {
        thread size |get =[]
        0 thread .pc |pcFree =[]
        size 1 origadd =size
      } rep
    } /add deff

    {
      0 =size
      [ maxSize { 1 } rep ] =pcFree
    } /clear deff
  > } /threadList deff

  { ==thread ==newpc <
    newpc ==pc
    [ thread .captures 20 dearray ] ==captures
  > } /cloneThread deff

  { ==prog ==string
    0 ==position
    string len ==maxPosition
    0 ==done
    0 ==matched

    prog len _ threadList ==clist
               threadList ==nlist

    newThread _ ==thread clist .add

    { position maxPosition le done not and } {
      0 ==i
      { i clist .size lt done not and } {
        i clist .get _ =thread
                       .pc _ ==pc
                             prog * =*code
        0 code [
          { # MATCH
            1 =matched
            clist .clear
          } { # TERM
            position maxPosition lt {
              position string * 1 code * { pc 1 add thread cloneThread nlist .add } rep
            } rep
          } { # JUMP
            pc 1 code add thread cloneThread clist .add
          } { # SPLIT
            pc 1 code add thread cloneThread clist .add
            pc 2 code add thread cloneThread clist .add
          } { # SAVE
            position 1 code thread .captures =[]
            pc 1 add thread cloneThread clist .add
          }
        ] * *
        i 1 add =i
      } loop

      clist nlist =clist =nlist
      nlist .clear
      position 1 add =position
    } loop

    matched {
      currentCapture ==i
      { i } { i 1 sub =i
        string
        i 2 mul       thread .captures * _ ==start -01 str .postfix
        i 2 mul 1 add thread .captures * start sub -01 str .inplacePrefix
      } loop
    } rep
    matched
  } /execute deff

  parse ==prog --
  [
    [ SPLIT 3 1 ]
    [ TERM { -- 1 } ]
    [ JUMP 2 neg ]
    prog _ len dearray
    [ MATCH ]
  ] =prog
  { prog execute }
} /enregex deff

{ enregex * } /regex deff

# vim: syn=elymas