forth.scr

# 55 forth/ # 63 forth/ ~ thru















`# 7 `forth/ `# 47 `forth/ `~ `thru















# 52 forth/ # 54 forth/ ~ thru















# 56 forth/ ~ load |
# 48 forth/ # 49 forth/ ~ thru |
# 52 forth/ ~ load |
# 50 forth/ # 51 forth/ ~ thru |

# 196 block # 60 block # 0 cfill
# 196 block here!
# 0 ' patch >link !
# 1 `forth/ ~ load |

' [macro] ' _macro patch
' [micro] ' _micro patch
' evaluator >body # 1 task !
' `forth/ prune


# 56 forth/ ~ load |
# 48 forth/ # 49 forth/ ~ thru |
# 52 forth/ ~ load |
# 50 forth/ # 51 forth/ ~ thru |

# 132 block # 60 block # 0 cfill
# 132 block here!
# 0 ' patch >link !
# 1 `forth/ ~ load |

' [macro] ' _macro patch
' [micro] ' _micro patch
' evaluator >body # 1 task !
' `forth/ prune


# 55 forth/ # 56 forth/ ~ thru |

# 194 block # 30 block # 0 cfill
# 194 block here!
# 2 forth/ ~ load |

# 0 block # 1 block # 0 cfill
# 0 block here!
' ?trap >body \ call  ' main >body \ jump
empty






# 55 forth/ # 56 forth/ ~ thru  |

# 2 block # 30 block # 0 cfill
# 2 block here!
# 2 forth/ ~ load |

# 0 block # 1 block # 0 cfill
# 0 block here!
' ?trap >body \ call  ' main >body \ jump
empty






`macro: push `( n ; - ; n)  `$ 10 `c, `;
`macro: pop `( ; n - n ;)  `$ 11 `c, `;
`macro: i@ `( ; n - n ; n)  `$ 50 `c, `;
`macro: i! `( n1 ; n2 - ; n1)  `$ 51 `c, `;

`macro: drop `( n -)  `$ 1C `c, `;
`macro: dup `( n - n n)  `$ 1D `c, `;
`macro: over `( n1 n2 - n1 n2 n1)  `$ 1E `c, `;
`macro: swap `( n1 n2 - n2 n1)  `$ 1F `c, `;
`macro: nip `( n1 n2 - n2)  `$ 5C `c, `;
`macro: tuck `( n1 n2 - n2 n1 n2)  `$ 5D `c, `;
`macro: rot `( n1 n2 n3 - n2 n3 n1)  `$ 5E `c, `;
`macro: -rot `( n1 n2 n3 - n3 n1 n2)  `$ 5F `c, `;



`macro: 2dup `( n1 n2 - n1 n2 n1 n2)  `\ over `\ over `;
`macro: 2drop `( n1 n2 -)  `\ drop `\ drop `;














`macro: lit `( n -) `( - n)  `$ 07 `c, `, `;
`macro: clit `( cn -) `( - cn)  `$ 27 `c, `c, `;














`macro: + `( n1 n2 - n3)  `$ 18 `c, `;
`macro: - `( n1 n2 - n3)  `$ 19 `c, `;
`macro: * `( n1 n2 - n3)  `$ 1A `c, `;
`macro: /mod `( n1 n2 - n3 n4)  `$ 1B `c, `;
`macro: u* `( u1 u2 - u3)  `$ 5A `c, `;
`macro: u/mod `( u1 u2 - u3 u4)  `$ 5B `c, `;
`macro: negate `( n1 - n2)  `$ 54 `c, `;
`macro: abs `( n1 - n2)  `$ 55 `c, `;
`macro: min `( n1 n2 - n3)  `$ 56 `c, `;
`macro: max `( n1 n2 - n3)  `$ 57 `c, `;

`macro: / `( n1 n2 - n3)  `\ /mod `\ nip `;
`macro: mod `( n1 n2 - n3)  `\ /mod `\ drop `;
`macro: u/ `( u1 u2 - u3)  `\ u/mod `\ nip `;
`macro: umod `( u1 u2 - u3)  `\ u/mod `\ drop `;

`macro: 1+ `( n1 - n2)  `# 1 `\ clit `\ + `;
`macro: 1- `( n1 - n2)  `# 1 `\ clit `\ - `;














`macro: lshift `( n1 n2 - n3)  `$ 12 `c, `;
`macro: rshift `( n1 n2 - n3)  `$ 58 `c, `;
`macro: ashift `( n1 n2 - n3)  `$ 13 `c, `;

`macro: 2* `( n1 - n2)  `# 1 `\ clit `\ lshift `;
`macro: 2/ `( n1 - n2)  `# 1 `\ clit `\ ashift `;

`macro: not `( n1 - n2)  `$ 14 `c, `;
`macro: and `( n1 n2 - n3)  `$ 15 `c, `;
`macro: or `( n1 n2 - n3)  `$ 16 `c, `;
`macro: xor `( n1 n2 - n3)  `$ 17 `c, `;





`macro: = `( n1 n2 - ?)  `$ 52 `c, `;
`macro: < `( n1 n2 - ?)  `$ 53 `c, `;
`macro: u< `( u1 u2 - ?)  `$ 59 `c, `;

`macro: <> `( n1 n2 - ?)  `\ = `\ not `;
`macro: > `( n1 n2 - ?)  `\ swap `\ < `;
`macro: >= `( n1 n2 - ?)  `\ < `\ not `;
`macro: <= `( n1 n2 - ?)  `\ > `\ not `;
`macro: u> `( u1 u2 - ?)  `\ swap `\ u< `;
`macro: u>= `( u1 u2 - ?)  `\ u< `\ not `;
`macro: u<= `( u1 u2 - ?)  `\ u> `\ not `;





`macro: 0= `( n - ?)  `# 0 `\ clit `\ = `;
`macro: 0<> `( n - ?)  `# 0 `\ clit `\ <> `;
`macro: 0< `( n - ?)  `# 0 `\ clit `\ < `;
`macro: 0> `( n - ?)  `# 0 `\ clit `\ > `;
`macro: 0>= `( n - ?)  `# 0 `\ clit `\ >= `;
`macro: 0<= `( n - ?)  `# 0 `\ clit `\ <= `;










`macro: r! `( r -) `( a -)  `$ 48 `c, `c, `;
`macro: r@ `( r -) `( - a)  `$ 49 `c, `c, `;

`macro: @r `( r -) `( - n)  `$ 0A `c, `c, `;
`macro: !r `( r -) `( n -)  `$ 0B `c, `c, `;
`macro: @r+ `( r -) `( - n)  `$ 0C `c, `c, `;
`macro: !r+ `( r -) `( n -)  `$ 0D `c, `c, `;
`macro: -@r `( r -) `( - n)  `$ 0E `c, `c, `;
`macro: -!r `( r -) `( n -)  `$ 0F `c, `c, `;







`macro: cr! `( r -) `( a -)  `$ 28 `c, `c, `;
`macro: cr@ `( r -) `( - a)  `$ 29 `c, `c, `;

`macro: c@r `( r -) `( - cn)  `$ 2A `c, `c, `;
`macro: c!r `( r -) `( cn -)  `$ 2B `c, `c, `;
`macro: c@r+ `( r -) `( - cn)  `$ 2C `c, `c, `;
`macro: c!r+ `( r -) `( cn -)  `$ 2D `c, `c, `;
`macro: -c@r `( r -) `( - cn)  `$ 2E `c, `c, `;
`macro: -c!r `( r -) `( cn -)  `$ 2F `c, `c, `;







`macro: @ `( a - n)  `$ 4 `\ r!  `$ 4 `\ @r `;
`macro: ! `( n a -)  `$ 4 `\ r!  `$ 4 `\ !r `;
`macro: c@ `( a - cn)  `$ 4 `\ r!  `$ 4 `\ c@r `;
`macro: c! `( cn a -)  `$ 4 `\ r!  `$ 4 `\ c!r `;












`macro: wait `( t p - n)  `$ 80 `c, `;
`macro: clip `( a # p - n)  `$ 81 `c, `;
`macro: recv `( p - a # n)  `$ 82 `c, `;
`macro: send `( a # l - n)  `$ 83 `c, `;

`macro: now `( - t)  `$ 84 `c, `;

`macro: reset `( - *)  `$ 85 `c, `;
`macro: depth `( - u1 u2)  `$ 86 `c, `;







`macro: exit `( ; a - ;)  `$ 00 `c, `;
`macro: ex `( ; a1 - ; a2)  `$ 01 `c, `;
`macro: jump `( a -) `( *)  `$ 02 `c, `, `;
`macro: call `( a -) `( *)  `$ 03 `c, `, `;

`: abort `( - *)  reset `;










`macro: begin `( - a) `( -)  `here `;
`macro: again `( a -) `( -)  `\ jump `;

`macro: for `( - a) `( n -)  `\ 1- `\ push `\ begin `;
`macro: next `( a -) `( ; n - ; n | ;)  `$ 06 `c, `, `;

`macro: if `( - a) `( ? -)  `$ 04 `c, `here `$ 0 `, `;
`macro: -if `( - a) `( ? -)  `$ 05 `c, `here `$ 0 `, `;
`macro: then `( a -) `( -)  `here swap ! `;
`macro: else `( a1 - a2) `( -)
  `$ 02 `c, `here `$ 0 `,  swap `\ then `;

`macro: while `( a1 - a2 a1) `( ? -)  `\ if swap `;
`macro: -while `( a1 - a2 a1) `( ? -)  `\ -if swap `;
`macro: repeat `( a1 a2 -) `( -)  `\ again `\ then `;

`macro: here! `( a -)  `$ 2 `\ r! `;
`macro: here@ `( - a)  `$ 2 `\ r@ `;
`macro: here `( - a)  `\ here@ `;

`macro: , `( n -)  `$ 2 `\ !r+ `;
`macro: c, `( cn -)  `$ 2 `\ c!r+ `;

`macro: allot `( # -)  `$ 2 `\ r@ `\ +  `$ 2 `\ r! `;

`: naligned `( u1 u2 - u3)  1-  dup not  -rot +  and `;
`: aligned `( u1 - u2)  `# 4 naligned `;
`: align `( -)  here@ aligned here! `;




`macro: t! `( a -)  `$ 1 `\ r! `;
`macro: t@ `( - a)  `$ 1 `\ r@ `;

`macro: @t `( a - n)  `$ 0 `\ r!  `$ 0 `\ @r `;
`macro: !t `( n a -)  `$ 0 `\ r!  `$ 0 `\ !r `;











`macro: here' `( - a)  `# 0 `\ clit `;
`macro: last `( - a)  `# 4 `\ clit `;
`macro: text `( - a)  `# 8 `\ clit `;
`macro: text# `( - a)  `# 12 `\ clit `;












`macro: cells `( u1 - u2)  `# 2 `\ clit `\ lshift `;
`macro: cells+ `( u1 u2 - u3)  `\ cells `\ + `;
`macro: cells- `( u1 u2 - u3)  `\ cells `\ - `;

`macro: block `( u1 - u2)  `# 10 `\ clit `\ lshift `;











`macro: eval-buff `( - a)  `# 129 block `\ lit `;
`macro: send-buff `( - a)  `# 131 block `\ lit `;














`: <? `( -)  send-buff `[ `$ 6 `] r! `;
`: ?> `( - a #)  send-buff  `[ `$ 6 `] r@ over - `;
`: ?c, `( cn -)  `[ `$ 6 `] c!r+ `;

`: emit `( c - ~)
  <? `# 0 ?c,  ?c, ?>
  begin 2dup `# 0 send 0< while repeat
  2drop `;

`: cr `( - ~)  `$ A emit `;
`: space `( - ~)  `$ 20 emit `;

`: type `( a # - ~)
  dup 0<= if 2drop exit then
  swap `[ `$ 4 `] r!  for `[ `$ 4 `] c@r+ emit next `;

`macro: base! `( u -)  `$ 8 `\ r! `;
`macro: base@ `( - u)  `$ 8 `\ r@ `;














`: digit `( u - c)  dup `# 9 >  `# 7 and +  `# 48 + `;

`: <?# `( -)  send-buff `[ `$ 6 `] r! `;
`: #?> `( - a #)  drop  `[ `$ 6 `] r@  send-buff over - `;
`: hold `( c -)  `[ `$ 6 `] -c!r `;
`: ?# `( u1 - u2)  base@ u/mod  swap digit hold `;
`: ?#s `( u - 0)  begin ?#  dup 0= -while repeat `;
`: sign `( n -)  0< if `$ 2D hold then `;








`: (.) `( n u - ~)
  base!  dup abs  <?# `$ 20 hold  ?#s  swap sign #?> type `;
`: . `( n - ~)  `# 10 (.) `;
`: .x `( n - ~)  `# 16 (.) `;
`: .b `( n - ~)  `# 2 (.) `;
`: .o `( n - ~)  `# 8 (.) `;

`: (u.) `( u1 u2 - ~)
  base!  <?# `$ 20 hold  ?#s #?> type `;
`: u. `( u - ~)  `# 10 (u.) `;
`: u.x `( u - ~)  `# 16 (u.) `;
`: u.b `( u - ~)  `# 2 (u.) `;
`: u.o `( u - ~)  `# 8 (u.) `;



`: trim `( a1 #1 - a2 #2)
  dup 0<= if exit then
  swap `[ `$ 4 `] r!  for
    `[ `$ 4 `] c@r+ `# 33 < -if
      `[ `$ 4 `] r@ 1-  pop 1+
      exit
    then
  next
  `[ `$ 4 `] r@ 1-  `# 0 `;







`: scan `( a1 #1 c - a2 #2)
  `[ `$ 6 `] cr!  dup 0<= if exit then
  over `[ `$ 4 `] r!  dup for
    `[ `$ 4 `] c@r+  `[ `$ 6 `] cr@ = if
      pop 1+ -
      exit
    then
  next `;

`: parse `( c ~ - a #)
  text @t text# @t
  rot scan  2dup + 1+  dup text @t -
  text# @t swap -
  text# !t text !t `;


`: s, `( a # -)
  dup `c,  swap `[ `$ 4 `] r!  dup 0<= if drop exit then
  for `[ `$ 4 `] c@r+ `c, next `;
`: s@ `( a1 - a2 #)
  `[ `$ 4 `] r!  `[ `$ 4 `] c@r+  `[ `$ 4 `] r@  swap `;











`: slit `( ; a1 - a2 # ; a3)
  i@ `[ `$ 4 `] r!
  `[ `$ 4 `] c@r+  `[ `$ 4 `] r@  swap
  2dup + i! `;

`macro: " `( ~ -) `( - a #)
  `# 34 parse  dup 0< if drop `# 0 then  `\ slit  s, `;

`macro: ." `( ~ -) `( - ~)  `\ " `\ type `;

`macro: abort" `( ~ -) `( - ~ *)
  `\ ." `\ cr `\ abort `;




`: (word) `( ~ - a #)
  text @t text# @t  trim  text# !t text !t
  `$ 20 parse `;
`: word `( ~ - a # | ~ *)
  (word)  dup 0<= if 2drop  abort"  ?" then `;











`: -digit `( c - n)
  `# 48 -  dup `# 9 > if `# 7 -  dup `# 10 <  or then `;

`: number `( a # - a # n | ~ *)
  dup 0<= if 2drop abort"  ?" then
  2dup  swap `[ `$ 6 `] r!
  `[ `$ 6 `] c@r `# 45 =  push
  `[ `$ 6 `] r@ i@ -  `[ `$ 6 `] r!
  i@ +  `# 0  swap for
    base@ *  `[ `$ 6 `] c@r+ -digit
    dup base@ u>= if
      2drop  pop drop  type abort"  ?"
    then  +
  next
  pop if negate then `;

`: (#) `( u ~ - | ~ *) `( - n)
  base!  word number `\ lit  2drop `;
`macro: # `( ~ - | ~ *) `( - n)  `# 10 (#) `;
`macro: $ `( ~ - | ~ *) `( - n)  `# 16 (#) `;
`macro: % `( ~ - | ~ *) `( - n)  `# 2 (#) `;
`macro: & `( ~ - | ~ *) `( - n)  `# 8 (#) `;

`macro: char `( ~ - | ~ *) `( - c)
  text# @t 0<= if abort"  ?" then
  text @t c@ `\ clit
  text @t 1+ text !t
  text# @t 1- text# !t `;

`macro: ( `( ~ -) `( -)  `# 41 parse 2drop `;


`: same `( a1 #1 a2 #2 - ?)
  push  `[ `$ 4 `] r!  swap `[ `$ 6 `] r!
  i@ =  dup -if pop drop exit then
  pop for
    `[ `$ 4 `] c@r+ `[ `$ 6 `] c@r+ =  and
    dup i@ and i!
  next `;









`macro: >data `( h - a)  `# 2 cells `\ clit `\ - `;
`macro: >code `( h - a)  `# 1 cells `\ clit `\ - `;
`macro: >link `( h - a)  `;
`macro: >name `( h - a)  `# 1 cells `\ clit `\ + `;

`macro: >body `( h - a)  `\ >data `\ @ `;










`: find `( a # - a # h | a # 0)
  last @t push
  begin i@ 0= -while
    2dup  i@ >name s@  same if pop exit then
    i@ >link @ i!
  repeat pop `;










`: compile `( ~ - * | ~ *)
  begin (word)  dup 0> while
    find  dup if
      nip nip  dup >code @ push ex
    else
      drop  type abort"  ?"
    then
  repeat 2drop `;








`macro: [ `( -)
  here@ here' !t  eval-buff here! `;
`macro: ] `( - *) `( *)
  `\ exit  here' @t here!  eval-buff push `;
`macro: | `( - *) `( *)  `\ ] `\ [ `;

`: evaluate `( a # ~ - * | ~ *)
  text @t push  text# @t push
  text# !t text !t  `\ [ compile `\ ]
  pop text# !t  pop text !t `;






`: evaluator `( a # ~ - ~ *)
  dup # 1 = if 2drop exit then
  `# 128 block t!  here' @t here!
  text# !t text !t  `\ [ compile `\ ]
  here@ here' !t
  ."  ok" cr `;










`: header `( a # -)
  `here last @t `, last !t  s,  `here here' !t `;
`: define `( h ~ - | ~ *)
  `here push `# 0 `,  >body `,
  word header
  `here pop ! `;

`: [macro] `( h - *) `( *)  >body push `;
`macro: macro: `( ~ - | ~ *) `( *)
  `\ ]  `' [macro] define `;
`: [micro] `( h -) `( *)  >body `\ call `;
`macro: : `( ~ - | ~ *) `( *)
  `\ ]  `' [micro] define `;
`macro: ; `( ; a - ;)  `\ exit  `\ [ `;


`: (') `( ~ - h | ~ *)
  word find  dup if
    nip nip
  else
    drop  type abort"  ?"
  then `;

`macro: ' `( ~ - | ~ *) `( - h)  (') `\ lit `;

`macro: \ `( ~ - | ~ *) `( *)
  `\ '  `\ dup `\ >code `\ @ `\ push `\ ex `;

`macro: ~ `( ~ - | ~ *) `( *)  (')  >body `\ jump `;



`: load `( u - *)
  block `# 1024 evaluate `;
`: thru `( u1 u2 - *)
  over - 1+ for
    dup load 1+
  next drop `;










`: bye `( -)
  <? `# 1 ?c, ?>
  begin 2dup `# 0 send 0< while repeat
  2drop `;












`: words `( - ~)
  last @t push
  begin i@ 0= -while
    i@ >name s@ type  space
    i@ >link @ i!
  repeat cr  pop drop `;










: patch ( h1 h2 -)
  last @t push
  begin i@ 0= -while
    dup >code @  i@ >code @ = if
      over >body  i@ >code !
    then
    i@ >link @ i!
  repeat 2drop  pop drop ;

macro: _macro ( -) ( -)  ;
: _micro ( -)  ;





: prune ( h -)
  last @t push
  begin i@ 0= -while
    dup  i@ >link @ = if
      # 0 i@ >link !
      drop  pop drop exit
    then
    i@ >link @ i!
  repeat drop  pop drop ;







macro: `( ( ~ -) ( -)  \ ( ;

macro: `macro: ( ~ - | ~ *) ( *)  \ macro: ;
macro: `: ( ~ - | ~ *) ( *)  \ : ;
macro: `; ( ; a - ;)  \ ; ;

macro: `[ ( -)  \ [ ;
macro: `] ( - *) ( *)  \ ] ;
macro: `| ( - *) ( *)  \ | ;
macro: `~ ( ~ - | ~ *) ( *)  \ ~ ;

macro: `' ( ~ - | ~ *) ( - h)  \ ' ;
macro: `\ ( ~ - | ~ *) ( *)  \ \ ;



macro: `# ( ~ - | ~ *) ( - n)  \ # ;
macro: `$ ( ~ - | ~ *) ( - n)  \ $ ;

macro: `here ( - a)  \ here ;
macro: `, ( n -)  \ , ;
macro: `c, ( cn -)  \ c, ;

: `load ( u - *)  load ;
: `thru ( u1 u2 - *)  thru ;

: `forth/ ( u1 - u2)  forth/ ;





macro: tasks ( - a)  # 1 block \ lit ;
: task ( n - a)  1+ cells  tasks + ;














: wait' ( -)  # -1 # 0 wait drop ;
: clip' ( a # -)
  begin 2dup # 0 clip 0< while repeat
  2drop ;
: recv' ( - a #)
  begin # 0 recv 0< while 2drop  wait' repeat ;
: mark ( a # - n)
  over # 1 cells- @  dup # -1 = if drop  over @ then ;

: ?trap ( a n - | ~ *)
  dup # 2 < if 2drop exit then
  ." ERROR " . u.x cr
  reset ;



: main ( - *)
  begin
    # 32 block dup clip'  recv'
    mark task @  dup if
      push ex
    else
      drop  2drop
    then
  again ;







last @t here@

macro: empty ( -)
  lit \ lit \ here!
  lit \ lit \ last \ !t ;











: cfill ( a # cn -)
  -rot  swap [ $ 4 ] r!  for
    dup [ $ 4 ] c!r+
  next drop ;

: cmove ( a1 # a2 -)
  [ $ 6 ] r!  swap [ $ 4 ] r!  for
    [ $ 4 ] c@r+  [ $ 6 ] c!r+
  next ;







: execute ( h - *)  >body push ;















macro: alias ( h ~ - | ~ *) ( *)
  \ ]  dup >data @ ,  >code @ ,  word header  \ [ ;














: internal ( - h)  last @t ;
: external ( - h)  here aligned # 2 cells+ ;
: module ( h1 h2 -)  >link ! ;













: rest ( ; a - a ;)  pop ;
: create ( ~ - | ~ *) ( - a)  ' [micro] define \ rest ;
: use ( a -)  last @t >body 1+ ! ;
: does ( ; a - ;) ( ; a - *)  pop use ;

: >rest ( h - a)  >body 1+ # 1 cells+ ;










macro: variable ( ~ - | ~ *) ( - a)
  \ ]  create # 0 ,  \ [ ;

macro: constant ( n ~ - | ~ *) ( - n)
  \ ]  create ,  \ [  does pop @ ;











macro: defer ( ~ - | ~ *) ( *)
  \ ]  create ' abort >body ,  \ [  does pop @ push ;
: defer! ( a h -)  >rest ! ;
: defer@ ( h - a)  >rest @ ;
macro: is ( ~ - | ~ *) ( h -)  \ >body  \ ' \ defer! ;











: z.h ( cu - ~)
  # 16 base!  <?# $ 20 hold  ?# ?# #?> type ;

: dump ( a # - ~)
  swap [ $ A ] r!  for
    [ $ A ] c@r+ z.h
  next cr ;

: more ( - a)  [ $ A ] r@ ;