\ Experiment with a new code generator. \ Based on 4p-3.1-Luxor -ANS 256 constant /stack defer| _se _lit | : op, over , dup , ?dup and: 1- recurse ; : index, bounds do i , 2#c +loop ; /stack cells dup buffer simstack create tos ^stack @ cell- ! ; : sim2, here begin world @ over u< while 3#c - dup @ 2 pick = over cell+ @ 4 pick = and over 2#c + @ 5 pick = and if sim-push 2drop drop ;then repeat drop here sim-push , , , ; : >sim2 1 sim-ndrop sim2, ; : sim, 0 -rot sim2, ; : >sim 1 sim-ndrop sim, ; : sim-lit ['] _lit sim, ; : >lit 1 sim-ndrop sim-lit ; : (simply) sim-tos @ ['] _lit = dup and: sim-tos cell+ @ swap ; : (combine) sim-snd @ ['] _lit = sim-tos @ ['] _lit = and dup and: sim-snd cell+ @ sim-tos cell+ @ rot 1 sim-ndrop ; : simply` (simply)` if` step >lit` ;then` ; : combine` (combine)` if` step >lit` ;then` ; : unidir sim-tos @ ['] _lit = or: sim-snd @ ['] _lit of 1 sim-roll ;then ['] _se = if 1 sim-roll then ; : sim-lit? sim-tos @ ['] _lit = dup and: sim-tos cell+ @ swap ; : nozero` sim-lit?` if` 0=` if` 1` sim-ndrop` ;then` then` ; : plus-like` combine` adopt [']` then> >r unidir sim-tos @ ['] _lit = sim-snd @ r = and if sim-snd 2#c + @ @ ['] _lit = if sim-snd 2#c + @ cell+ @ sim-tos cell+ @ r execute sim-snd cell+ @ 2 sim-ndrop sim-push sim-lit then then rdrop ; : 1-bit? begin dup while dup 1 and if 1 = ;then shr repeat ; : uptobit 0 begin over 1 and 0= while swap shr swap 1+ repeat nip ; context sim `sim set-current \ "primitives" : dup 0 sim-pick ; : over 1 sim-pick ; : swap 1 sim-roll ; : rot 2 sim-roll ; : drop 1 sim-ndrop ; : tuck sim swap sim over ; : -rot sim rot sim rot ; : nip sim swap sim drop ; : 2dup sim over sim over ; : 2drop 2 sim-ndrop ; : 2rot 5 sim-roll 5 sim-roll ; : negate simply negate sim-tos @ ['] negate = if sim-tos cell+ @ sim>tos ;then sim-tos ['] negate >sim ; : 0= simply 0= sim-tos ['] 0= >sim ; : @ here begin world @ over u< while 3#c - dup @ ['] ! = if dup 2#c + @ sim-tos = if cell+ @ sim>tos ;then then repeat drop sim-tos ['] @ >sim ; : ! sim-snd @ ['] @ = if sim-tos sim-snd cell+ @ = if sim 2drop ;then then sim-two ['] ! >sim2 sim drop ; : + plus-like + nozero sim-two ['] + >sim2 ; : and plus-like and sim-lit? if -1 of sim drop ;then 0 = if sim nip ;then then sim-two ['] and >sim2 ; : or plus-like or sim-lit? if -1 of sim nip ;then 0 = if sim drop ;then then sim-two ['] or >sim2 ; : xor plus-like xor nozero sim-two ['] xor >sim2 ; : lshift combine lshift nozero sim-two ['] lshift >sim2 ; : rshift combine rshift nozero sim-two ['] rshift >sim2 ; : * combine * unidir sim-lit? if 1 of sim drop ;then dup 1-bit? if sim drop uptobit sim-lit sim lshift ;then -1 of sim drop sim negate ;then 0 = if sim nip ;then then sim-two ['] * >sim2 ; : / combine / sim-lit? if -1 of sim drop sim negate ;then 1 = if sim drop ;then then sim-two ['] / >sim2 ; : u/ combine u/ sim-lit? if 1 = if sim drop ;then then sim-two ['] u/ >sim2 ; : mod combine mod sim-lit? if -1 of sim 2drop 0 sim-lit ;then 1 = if sim 2drop 0 sim-lit ;then then sim-two ['] mod >sim2 ; : umod combine umod sim-lit? if dup 1-bit? if sim drop 1- sim-lit sim and ;then 1 = if sim 2drop 0 sim-lit ;then then sim-two ['] umod >sim2 ; : false 0 sim-lit ; : true -1 sim-lit ; : cell+ 1#c sim-lit sim + ; : cells 1#c sim-lit sim * ; : 1+ 1 sim-lit sim + ; : 1- -1 sim-lit sim + ; : 2* 1 sim-lit sim lshift ; : invert -1 sim-lit sim xor ; : d>s sim drop ; : - sim negate sim + ; : +! {~ sim dup @ rot + swap ! ~} ; : /mod {~ sim 2dup mod -rot / ~} ; : u/mod {~ sim 2dup umod -rot u/ ~} ; : 2! {~ sim tuck ! cell+ ! ~} ; : 2@ {~ sim dup cell+ @ swap @ ~} ; : /string {~ sim tuck - -rot + swap ~} ; : bounds {~ sim over + swap ~} ; definitions : first-change simstack begin dup name type space cell+ @ . ; : .sim ^stack @ first-change ?do i @ .sim-name 1#c +loop ; : >ord 0; here begin universe @ over u< while 2#c - 2dup @ = if 1 swap cell+ +! drop ;then repeat drop dup @ ['] _lit of , 1 , ;then ['] _se = if , 1 , ;then dup cell+ @ >ord dup 2#c + @ >ord , 1 , ; : !>ord here begin universe @ over u< while 2#c - over 2#c + @ over @ 2#c + @ = if 2drop ;then repeat drop >ord ; : sim-schedule here dup universe ! begin world @ over u< while 3#c - dup @ ['] ! = if dup !>ord then repeat drop ^stack @ first-change ?do i @ >ord 1#c +loop ; : .ord here universe @ ?do i @ .sim-name ': emit i cell+ @ . space 2#c +loop ; \ \ --- Now follows the C-output. \ include newgen-c4p \ Mögliches Register-Layout: \ EBX = Stack Pointer \ 0 EAX 1 EDX 2 ECX 3 ESI 4 EDI 5 EBP 6 constant #regs 128 constant #spills 2 constant #protected-regs \ niemals "hin-spillen" create regs #regs cells alloz create spills #spills cells alloz : reg` cells` regs` +` ; \ \ --- Some test cases. \ variable (simnu) context simnu : ((simnu))` (simnu) @ execute sim-lit` ; :: Numbers cfind dup ['] word? <> and: (simnu) ! ['] ((simnu)) ; simnu >cfind : sim"` '" parse then> 2dup type cr here >r sim-reset `simnu >enter `sim ~~ eval ;enter sim-schedule .c-ord \ ." // " .ord cr r> here - allot ; sim" 1 over 4 + ! +" cr sim" over 123 7 + tuck 5 130 ! ! @" cr sim" swap" cr sim" 12 +" cr sim" 12 * 7 / swap" cr sim" @ 2 + -2 +" cr sim" @ 3 + -2 + swap" cr sim" dup 1 *" cr sim" dup 0 *" cr sim" dup -1 *" cr sim" dup -1 * negate" cr sim" dup 0 and" cr sim" dup 123 and 7 and" cr sim" dup 12 or 128 or" cr sim" dup 12 xor 128 xor" cr sim" dup 1 xor 1 xor" cr sim" 123 + swap 234 + rot 345 + -rot" cr sim" dup 1 + * 2 /" cr sim" 16 mod" cr sim" 16 umod" cr sim" 16 *" cr sim" 2 /string" cr sim" 123 u/mod" cr sim" 123 @ ! 4 123 +! 123 @ ! 4 123 +!" cr