## dynamic member lookup fallback routines { -- 0 } "#.?" deffd { keys dump "undefined member in .: " dump dump "" die } "#." defmd { keys dump "undefined member in .|: " dump dump "" die } "#.|" defmd { keys dump "undefined member in =: " dump dump "" die } "#.=" defmd ## regex support # ideas taken from http://swtch.com/~rsc/regexp/regexp3.html < 0 ==:MATCH 1 ==:TERM 2 ==:JUMP 3 ==:SPLIT 4 ==:SAVE 5 ==:FIRST 6 ==:LAST { ==b ==a [ [ SPLIT 1 a len 2 add ] a _ len dearray [ JUMP b len 1 add ] b _ len dearray ] } /alternative deffd |cat /sequence deffd { ==?a [ # TODO measure separate + implementation performance impact [ JUMP a len 1 add ] a _ len dearray [ SPLIT a len neg 1 ] ] } /star deffd { ==?p [ [ TERM p ] ] } /terminal deffd { -- 1 }" terminal ==:TERMANY { { eq }_ terminal } =*:TERMCHAR { ==?i ==?a [ [ SAVE i 2 mul ] a _ len dearray [ SAVE i 2 mul 1 add ] ] } /capture deffd { [ ] } /empty deffd { ==?str str len 0 eq { 1 neg } { 0 str * } ? * } /head deffd { 1 -01 str .postfix } /tail deffd { 0 -01 * -101 head eq } "^" deffd { deffd }' /install deffd [ "(" ")" "[" "]" "-" "|" "^" "*" "+" "." "$" "\\" "?" ] { ==?c { _ head 0 c * eq } "^" c cat install } each { 0 -01 * }" /threadGetPC deffd { 1 -01 * }" /threadGetCaptures deffd { #==thread ==newpc [ -021 threadGetCaptures ] }" /cloneThread deffd { #==thread ==newpc 0 -1201 =[] }" /updateThread deffd { #==thread ==newpc [ -0201 threadGetCaptures _ len dearray ] ] }" /fullCloneThread deffd |add /origadd deffd str .|bitTest /bitTest deffd str .|bitSet /bitSet deffd str .|zero /zero deffd # TODO think about implementation efficiency { ==maxSize < 0 ==size [ maxSize { 0 }" rep ] =*get maxSize 1 sub 8 udiv 1 add 8 mul str .alloc _ zero ==pcUsed { # ==thread _ threadGetPC pcUsed bitTest { -- }" { _ size |get =[] threadGetPC pcUsed bitSet size 1 origadd =size }" ? * }' /add deffst { size 1 sub _ =size get }' /pop deffst { 0 =size pcUsed zero }' /clear deffst > } /threadList deffd { 0 ==?currentCapture { # "(parse) re: " -101 cat dump seq ==?a ^| { tail parse ==?b a b alternative =a } rep a } /parse deffst { # "(seq) re: " -101 cat dump empty _ ==?a ==?l { # "(seq loop) re: " -101 cat dump _ head 1 neg eq -01 ^| -01 ^) -01 -0321 or or not } { [ { ^* } { l star =l tail } { ^+ } { l l star sequence =l tail } { ^? } { l empty alternative =l tail } { 1 } { a l sequence =a atom =l } ] conds } loop a l sequence } /seq deffst { # "(atom) re: " -101 cat dump empty ==?a [ { ^( } { currentCapture ==thisCapture currentCapture 1 add =currentCapture tail parse thisCapture capture =a ^) not { ") expected" die } rep tail } { ^[ } { tail ^^ { tail chars =*nset { nset not }' ==?set ^] not { "] expected" die } rep tail }' { chars ==?set ^] not { "] expected" die } rep tail }' ? * set terminal =a } { ^. } { TERMANY =a tail } { ^^ } { [ [ FIRST ] ] =a tail } { ^$ } { [ [ LAST ] ] =a tail } { ^\ } { tail [ { ^d } { { _ 0 "0" * ge -01 0 "9" * le and }" terminal =a tail } { ^n } { { 0 "\n" * eq }" terminal =a tail } [ "." "[" "?" "*" "+" "$" "^" "\\" ] { ==c { _ head 0 c * eq } { { 0 c * eq } terminal =a tail } } each { 1 } { "invalid character '" "' after \\ in regex" -120 cat cat die } ] conds } { 1 } { _ head TERMCHAR =a tail } ] conds # "(atom end) re: " -101 cat dump a } /atom deffst { # "(chars) re: " -101 cat dump ^] { tail chars2 =*s { _ s -01 0 "]" * eq or }' ==?set }' { chars2 ==?set }' ? * set } /chars deffst { # "(chars2) re: " -101 cat dump ^- { tail chars2 =*s { _ s -01 0 "-" * eq or }' ==?set }' { charsR ==?set }' ? * set } /chars2 deffst { # "(charsR) re: " -101 cat dump charsN ==?set { ^] not } { set =*s1 charsN =*s2 { _ s1 -01 s2 or }' =set } loop set } /charsR deffst { # "(charsN) re: " -101 cat dump _ head ==?start ^\ { tail [ { ^\ } { 0 "\\" * =start } { ^n } { 0 "\n" * =start } { 1 } { "invalid character '" "' after \\ in regex" -120 cat cat die } ] conds } rep tail ^- { tail _ head ==?end ^\ { tail [ { ^\ } { 0 "\\" * =end } { ^n } { 0 "\n" * =end } { 1 } { "invalid character '" "' after \\ in regex" -120 cat cat die } ] conds } rep tail { _ start ge -01 end le and }' ==?set }' { { start eq }' ==?set }' ? * set } /charsN deffst { [ 0 # pc [ currentCapture { 0 0 } rep ] # captures ] } /newThread deff # TODO: reconsider clist/ilist and also reconsider optimisation potential { ==prog ==string 0 ==position string len ==maxPosition 0 ==matched < > ==matchedThread prog len _ threadList ==clist _ threadList ==nlist threadList ==ilist newThread _ ==thread clist .add 0 ==pc { } =*code ilist .|add =*iPush ilist .|pop =*iPop [ { # MATCH 1 =matched thread =matchedThread clist .clear }" { # TERM position maxPosition lt { position string * 1 code * { pc 1 add thread updateThread nlist .add }" rep }" rep }" { # JUMP pc 1 code add thread cloneThread iPush }" { # SPLIT pc 2 code add thread cloneThread iPush pc 1 code add thread cloneThread iPush }" { # SAVE pc 1 add thread fullCloneThread position 1 code -2102 threadGetCaptures =[] iPush }" { # FIRST position 0 eq { pc 1 add thread cloneThread iPush }" rep }" { # LAST position maxPosition eq { pc 1 add thread cloneThread iPush }" rep }" ] =*codeSemantics 0 ==i { position maxPosition le }" { 0 =i { i clist .size lt }" { i clist .get _ =thread threadGetPC _ =pc prog * =code 0 code codeSemantics * i 1 add =i { ilist .size }" { iPop _ =thread threadGetPC _ =pc prog * =code 0 code codeSemantics * }" loop }" loop # "Next input character ========" dump clist nlist =clist =nlist nlist .clear ilist .clear position 1 add =position }" loop matched { currentCapture ==i { i } { i 1 sub =i i 2 mul matchedThread threadGetCaptures * i 2 mul 1 add matchedThread threadGetCaptures * string str .infix } loop } rep matched } /execute deffst parse ==prog -- prog 0 -01 * 0 -01 * FIRST eq { [ 1 prog len range { prog * } each ] =prog } { [ [ SPLIT 3 1 ] [ TERM { -- 1 }" ] [ JUMP 2 neg ] prog _ len dearray ] =prog } ? * [ prog _ len dearray [ MATCH ] ] =prog { prog execute } } > -- /enregex deffd { quoted { _ sys .typed .type 1 eq { enregex } { |enregex "*" | } ? * } { enregex * } ? * } /regex defq { scope keys }' /globals deffd < # sys extensions # TODO: handle EINTR correctly 0 _ ==:RDONLY 1 _ ==:WRONLY 2 _ ==:RDWR bor bor ==:RWMASK 64 ==:OCREAT 512 ==:OTRUNC 1024 ==:OAPPEND 1 ==:PROTREAD 2 ==:PROTWRITE 4 ==:PROTEXEC 2 ==:MAPPRIVATE 32 ==:MAPANONYMOUS 0 ==:READ 1 ==:WRITE 2 ==:OPEN 3 ==:CLOSE 9 ==:MMAP 11 ==:MUNMAP 60 ==:EXIT { ==code code 0 0 0 0 0 EXIT sys .asm .syscall "exit failed" die } /exit sys .deff { < ==?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 { flags OCREAT bor =flags } /creating deff { flags OAPPEND bor =flags } /appending deff { flags OTRUNC bor =flags } /truncating 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 { =*f "" ==buffer { buffer 4096 read -010 cat =buffer "" eq not } { buffer "\n" str .split ==lines 0 lines len 1 sub range { lines * f } each lines len 1 sub lines * =buffer } loop buffer "" eq not { buffer "\n" str .split |f each } rep } /eachLine deff > > -- } /makefile deff { RDWR 511 makefile } /fdToFile sys .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 { object dump "unknown type in typeStack" die } ==unknown { object dump "invalid type in typeStack" die } ==invalid { [ object 0 1 neg ] } ==literal object sys .typed .type [ literal # integer literal # string unknown unknown 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 { [ { object "#dom" .? } { object "#dom" . ==d object "#in" . ==in in len 1 neq { "multi-input scope (with #dom) in typeStack" die } rep [ 0 in * 0 d len 1 sub ] object "#out" . ==out out len 1 neq { "multi-output scope (with #dom) in typeStack" die } rep 0 out * typeStackInternal } { object "#*" .? } { object "#in" . ==in in len 1 neq { "multi-input scope in typeStack" die } rep [ 0 in * 0 1 neg ] object "#out" . ==out out len 1 neq { "multi-output scope in typeStack" die } rep 0 out * typeStackInternal } { 1 } literal ] conds } # scope invalid # name table 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 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 } # General integers co-iterate only if equal { 0 earlierType * 0 laterType * 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 } # If none defines a range, take the first { 1 } { earlierType 1 } ] conds } /commonIterationType deff { ==arr arr sys .typed .type 7 eq { 0 arr len range } { arr "#iclone" . } ? * } /cloneForLoop deff { ==arr ==i arr sys .typed .type 7 eq { i } { i arr "#itrans" . } ? * } /transformLoopIndex deff { ==arr arr sys .typed .type 7 eq { 0 } { arr "#istart" . } ? * } /getLoopStart deff { ==arr arr sys .typed .type 7 eq { arr len eq } { arr "#iend" . } ? * } /isLoopEnd deff { ==arr arr sys .typed .type 7 eq { 1 add } { arr "#istep" . } ? * } /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 f sys .typed .type 7 eq { f { * }_ [ 0 ] [ 0 ] '' =f } rep f sys .typed .inputs ==inputs f sys .typed .outputs ==outputs outputs len 1 gt { "multi-output function in auto-loop" die } rep [ ] ==concreteArgs [ ] ==viewPortOffset # Phase 1 0 inputs len 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 1 add range { ==viewPortSize [ 0 viewPortSize 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 range { ==i i concreteArgs * typeStack ==remaining [ 0 i viewPortOffset * 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 # "attempting to call function (w.o. abstraction)" dump 0 ==typeMismatch 0 ==mismatchIndex 0 concreteArgs len range reverse { ==i i concreteArgs * sys .typed .type # _ dump i inputs * sys .typed .type # _ dump neq typeMismatch not and { 1 =typeMismatch i =mismatchIndex } rep } each typeMismatch { mismatchIndex concreteArgs * ==arg arg sys .typed .type 9 eq { # this is a scope "" ==handlingMember globals { _ ==g | sys .asm .rawAddress f sys .asm .rawAddress eq { mismatchIndex 9 gt { "cannot create member-fallback for argument index " dump mismatchIndex dump "" die } rep arg concreteArgs len 1 sub mismatchIndex sub [ "#" "#-01 " "#-021 " "#-0321 " "#-04321 " "#-054321 " "#-0654321 " "#-07654312 " "#-087654321 " "#-0987654321 " ] * g cat _ ==candidate .? { candidate =handlingMember } rep } rep } each "" handlingMember eq { "a handling member could not be found at argument index " dump mismatchIndex dump "" die } rep 0 concreteArgs len range { ==i i mismatchIndex neq { i concreteArgs * } rep } each arg handlingMember . } { "invalid input type at argument index " dump typeMismatch 1 sub dump "" die } ? * } { concreteArgs # _ dump _ len dearray f * } ? * } { [ ] ==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 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 range reverse { ==j j toBeAbstractedTypes * len not not { 0 j toBeAbstractedTypes * * type commonIterationType # -> { =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 } ? * [ stageCalls2 ] stageCalls 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 { loopIndex concreteArgs * ==loopedOver outputs len { loopedOver cloneForLoop } { [ ] } ? * ==results loopedOver getLoopStart ==i { i loopedOver isLoopEnd not } { [ concreteArgs _ len dearray ] ==concreteArgsCopy stage { ==j # TODO: think about a single function returning multiple values i loopedOver transformLoopIndex j concreteArgs * * j concreteArgsCopy =[] } each concreteArgsCopy stageCalls argTypes loops unravel outputs len { i loopedOver transformLoopIndex results =[] } rep # 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 outputs len { results } rep # push @$data, [\@results, ['array', '[]', [['range', 0, $#results]], [undef]]]; # FIXME the undef can be determined } { { ==v [ concreteArgs _ len dearray ] ==concreteArgsCopy stage { ==i v i concreteArgs * * i concreteArgsCopy =[] } each concreteArgsCopy 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 > -- > -- { _ ==f _ sys .typed .inputs ==inputs sys .typed .outputs ==outputs inputs len 2 lt { f } { { "t from curry should never execute" die } [ inputs len 1 sub inputs * ] outputs '' ==t 0 inputs len 2 sub range reverse { ==i t [ i inputs * ] [ t ] '' =t } each 1 inputs len range reverse { ==i f < =*g { { g }_ } > -- [ i inputs * ] [ t ] '' =f 0 t sys .typed .outputs * =t } each f } ? * } /curry deffd { | curry } "||" deffd { ==o { "unknown type in **" die } ==:unknown { "invalid type in **" die } ==:invalid o sys .typed .type [ { o } # integer { o } # string { o } # float unknown invalid # extension area { o * ** } # function invalid # function code { o * ** } # array invalid # function type { o "#*" .? { o * ** } { o } ? * } # scope invalid # name table unknown unknown unknown unknown unknown ] * * } "**" deffd # global extensions < "0123456789" ==:base10digits "0123456789ABCDEF" ==:base16digits [ 0 11 range { sys .asm .intToFloat } each ] =*:FLOAT { _ 0 lt { neg "-" } { "" } ? * -01 [ -01 16 { _ 16 umod base16digits * -01 16 udiv } rep -- ] reverse str .fromArray cat } /base16encode64 deffd { ==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 { o ==f 0 ==e "+" ==s 0 ==i f 0 FLOAT lt { 0 FLOAT f sub =f "-" =s } rep { f 1 FLOAT lt i 500 lt and } { f 10 FLOAT mul =f e 1 sub =e i 1 add =i } loop { f 10 FLOAT ge i 500 lt and } { f 10 FLOAT div =f e 1 add =e i 1 add =i } loop i 500 eq { s f 1 FLOAT lt "0.0e0" "inf" ? cat sys .err .writeall } { { 0 ==d 1 10 range { ==i f i FLOAT gt { i =d } rep } each f d sub =f f 10 FLOAT mul =f d base10digits * } /extractDigit deffst [ 0 s * extractDigit 0 "." * 10 |extractDigit rep 0 "e" * e 0 lt { 0 e sub =e 0 "-" * } rep e 0 eq { 0 "0" * } rep [ { e } { e 10 mod base10digits * e 10 div =e } loop ] reverse _ len dearray ] str .fromArray sys .err .writeall } ? * } # float unknown invalid # extension area { "" cat sys .err .writeall } { "" cat sys .err .writeall } { "[\n" sys .err .writeall o { indent 1 add dumpIndented } each "" indent { " " cat } rep "]" cat sys .err .writeall } # array invalid # function type { "" cat sys .err .writeall } invalid # name table invalid # stack { "" cat sys .err .writeall } unknown unknown unknown ] * * "\n" sys .err .writeall } /dumpIndented deffd # dump top stack element to sys .err { 0 dumpIndented } > -- /dump deffd # TODO: why do we save section information, exactly? { ==filename # ==f (left on the stack a while and executed from sys .asm .programStart) sys .asm .patchProgramStart ==frozenAllocationCount # hex decoding { ==strNumber strNumber len 2 neq { "not a valid hex-string" die } rep 1 0 { strNumber * 48 sub [ 0 1 2 3 4 5 6 7 8 9 0 0 0 0 0 0 0 10 11 12 13 14 15 ] * } -20*10* 16 mul add } "%" defq { 8 { _ 256 umod -01 256 udiv } rep -- } /uint64 deffd { _ 0 lt { 4294967296 add } rep 4294967295 band 4 { _ 256 umod -01 256 udiv } rep -- } /uint32 deffd { _ 0 lt { 65536 add } rep 65535 band 2 { _ 256 umod -01 256 udiv } rep -- } /uint16 deffd { _ 0 lt { 256 add } rep 255 band } /uint8 deffd { ==align ==value align value align umod sub align umod } /alignUpto deff sys .file ==out filename out _ .creating _ .writeonly .open [ < ".null" ==?name 0 ==?nameOffset { =nameOffset } /setNameOffset deff 0 ==?dataOffset { =dataOffset } /setDataOffset deff 0 ==?type # reserved first section 0 ==?flags # none 0 ==?addr # not loaded 0 ==?link # no associated section 0 ==?entsize # no entries [ ] ==?data 0 ==?dataSize > < ".strtab" ==?name 0 ==?nameOffset { =nameOffset } /setNameOffset deff 0 ==?dataOffset { =dataOffset } /setDataOffset deff 3 ==?type # string table 0 ==?flags # none 0 ==?addr # not loaded 0 ==?link # no associated section 0 ==?entsize # no entries [ ] ==?data # to be filled later 0 ==?dataSize # to be filled later { _ =data len =dataSize } /setData deff > _ ==?stringTable ] ==metaSections [ 0 frozenAllocationCount range { ==i < ".-=#=-" ==?name 0 ==?nameOffset { =nameOffset } /setNameOffset deff 0 ==?dataOffset { =dataOffset } /setDataOffset deff 1 ==?type # program data 7 ==?flags # writable, allocated, executable i sys .asm .globalAllocBase ==?addr # address where this section will be loaded 0 ==?link # no associated section 0 ==?entsize # no entries i sys .asm .globalAllocBase ==?dataBase i sys .asm .globalAllocSize ==?dataSize > } each ] ==allocSections 4096 ==:PAGESIZE < 1 ==?nameOffset [ %00 # initial zero byte of string table ### section names [ metaSections allocSections ] { { ==?s s .name ==?n 0 n len range { n * } each %00 nameOffset s .setNameOffset nameOffset n len add 1 add =nameOffset } each } each ] stringTable .setData > -- < # %40 ==? section header size, %38 == program header size metaSections len allocSections len add %40 mul allocSections len %38 mul add %40 add ==?dataOffset metaSections { ==s dataOffset s .setDataOffset dataOffset s .dataSize add =dataOffset } each dataOffset _ 4096 alignUpto add =dataOffset allocSections { ==s dataOffset s .setDataOffset dataOffset s .dataSize add _ PAGESIZE alignUpto add =dataOffset } each > -- [ ### elf header # unsigned char e_ident[16]; /* ELF identification */ %7F 0 1 2 "ELF" -30*20*10* # elf identifier %02 # elfclass64 %01 # elf version %01 # little endian encoding %00 %00 # Sys-V ABI %00 %00 %00 %00 %00 %00 %00 # padding # Elf64_Half e_type; /* Object file type */ %02 %00 # executable file # Elf64_Half e_machine; /* Machine type */ %3E %00 # whatever, /bin/ls has this # Elf64_Word e_version; /* Object file version */ %01 %00 %00 %00 # always 1 # Elf64_Addr e_entry; /* Entry point address */ sys .asm .|programStart sys .asm .rawCodeAddress uint64 # Elf64_Off e_phoff; /* Program header offset */ metaSections len allocSections len add %40 mul %40 add uint64 # Elf64_Off e_shoff; /* Section header offset */ %40 uint64 # Elf64_Word e_flags; /* Processor-specific flags */ %00 %00 %00 %00 # taken from from /bin/ls # Elf64_Half e_ehsize; /* ELF header size */ %40 %00 # Elf64_Half e_phentsize; /* Size of program header entry */ %38 %00 # Elf64_Half e_phnum; /* Number of program header entries */ allocSections len uint16 # Elf64_Half e_shentsize; /* Size of section header entry */ %40 %00 # Elf64_Half e_shnum; /* Number of section header entries */ metaSections len allocSections len add uint16 # Elf64_Half e_shstrndx; /* Section name string table index */ %01 %00 # section header name table index in section headers table [ metaSections allocSections ] { { ==s ### section header # Elf64_Word sh_name; /* Section name */ s .nameOffset uint32 # Elf64_Word sh_type; /* Section type */ s .type uint32 # Elf64_Xword sh_flags; /* Section attributes */ s .flags uint64 # Elf64_Addr sh_addr; /* Virtual address in memory */ s .addr uint64 # Elf64_Off sh_offset; /* Offset in file */ s .dataOffset uint64 # Elf64_Xword sh_size; /* Size of section */ s .dataSize uint64 # Elf64_Word sh_link; /* Link to other section */ s .link uint32 # Elf64_Word sh_info; /* Miscellaneous information */ 0 uint32 # Elf64_Xword sh_addralign; /* Address alignment boundary */ 1 uint64 # Elf64_Xword sh_entsize; /* Size of entries, if section has table */ 0 uint64 } each } each allocSections { ==s ### program header # Elf64_Word p_type; /* Type of segment */ %01 %00 %00 %00 # loadable segment # Elf64_Word p_flags; /* Segment attributes */ %07 %00 %00 %00 # read | write | execute # Elf64_Off p_offset; /* Offset in file */ s .dataOffset uint64 # Elf64_Addr p_vaddr; /* Virtual address in memory */ s .dataBase uint64 # Elf64_Addr p_paddr; /* Reserved */ %00 %00 %00 %00 %00 %00 %00 %00 # Elf64_Xword p_filesz; /* Size of segment in file */ s .dataSize uint64 # Elf64_Xword p_memsz; /* Size of segment in memory */ s .dataSize uint64 # Elf64_Xword p_align; /* Alignment of segment */ %01 %00 %00 %00 %00 %00 %00 %00 # alignment } each ] ==fileHeaders 0 ==fileOffset [ fileHeaders metaSections { .data } each ] { ==data fileOffset data len add =fileOffset data str .fromArray out .writeall } each 1 ==:WRITE allocSections { ==section section .dataOffset fileOffset sub str .alloc out .writeall section .dataOffset section .dataSize add =fileOffset out .fd section .dataBase section .dataSize 0 0 0 WRITE sys .asm .syscall -- section .dataSize neq { "write failed" die } rep } each out .close ==f sys .asm .patchProgramStart frozenAllocationCount neq { "freezing allocated new memory chunks, retrying..." dump f filename sys .freeze } rep } /freeze sys .deff # no long-term stack use here as the executed program uses it as well { scope 0 "0" * ==:zero { 0 ==result { zero sub result 10 mul add =result } each result } /base10decode deffd [ 0 11 range { sys .asm .intToFloat } each ] =*:FLOAT { ==currentScope ==input { .value currentScope sys .executeIdentifier =currentScope } /TOKID defvd { .value base10decode } /TOKINT defvd { .value "^(\\d+)(\\.(\\d*))?([eE](-)?(\\d+))?$" regex not { "Not in fact a float" die } rep ==m1 -- ==m2 -- ==eS ==e 0 FLOAT ==m1f m1 { zero sub m1f 10 FLOAT mul add =m1f } each 0 FLOAT ==m2f [ m2 { } each ] reverse { zero sub m2f add 10 FLOAT div =m2f } each m1f m2f add ==result 0 ==ei e { zero sub ei 10 mul add =ei } each eS "" eq { ei { result 10 FLOAT mul =result } rep } { ei { result 10 FLOAT div =result } rep } ? * result } /TOKFLOAT defvd { .value } /TOKSTR defvd { TOKFLOAT TOKINT TOKSTR TOKID elymas .tokenize { _ .handle } each } input .eachLine } * }" /includeFile deffd { # ==?filename sys .file _ _ .|open -01 |includeFile -01 .|close ; ; -120 * # can use neither stack nor scope for storage here }" /include deffd # vim: syn=elymas