CREATE : ] CREATE ] (;) [ ' (:) SET-DOES
CREATE ; ' [ COMPILE, ] (LITERAL) (;) COMPILE, (LITERAL) (:) SET-DOES (;) [ ' (:) SET-DOES IMMEDIATE

: \ 10 PARSE 2DROP ; IMMEDIATE
: ( 41 PARSE 2DROP ; IMMEDIATE
\ woo, comments are now defined!

: NOOP ;
: LITERAL (LITERAL) [ ' (LITERAL) , ] COMPILE, COMPILE, ; IMMEDIATE
: ['] ' [ ' LITERAL COMPILE, ] ; IMMEDIATE
: CONSTANT CREATE ['] (CONSTANT) SET-DOES , ;
: VARIABLE CREATE ['] (VARIABLE) SET-DOES 1 CELLS ALLOT ;
: NIP SWAP DROP ;
: TUCK SWAP OVER ;
: EXIT RDROP ;
: / /MOD NIP ;
: 2* 1 LSHIFT ;
: 2/ 1 RSHIFT ;
: 0< 0 < ;

: CELL+ ( addr -- addr ) 8 + ;
: 1+! ( addr -- ) DUP @ 1+ SWAP ! ;
: 1-! ( addr -- ) DUP @ 1- SWAP ! ;

: CATCH ( i*x xt -- j*x 0 | i*x n )
  \ Save depth (not including XT), flags, and source.
  DEPTH 1- >R FLAGS >R SOURCE >R >R >R
  \ Save previous catch handler.
  PROCESS-TABLE $30 + @ >R
  \ Save previous rstack depth.
  PROCESS-TABLE $38 + @ >R

  \ Install a new handler, whose address is the second part of this word.
  (LITERAL) [ HERE 0 , ] PROCESS-TABLE $30 + !
  \ Save the rdepth.
  RDEPTH PROCESS-TABLE $38 + !

  \ Run the XT and push zero.
  EXECUTE 0

  \ Throw away saved source, flags, and depth.
  R> DROP R> DROP R> DROP R> DROP R> DROP
  \ Restore previous rstack depth.
  R> PROCESS-TABLE $38 + !
  \ Restore previous catch handler.
  R> PROCESS-TABLE $30 + !
  \ Return if we got here normally.
  (;)

  \ The handler for exceptions.
  [ HERE SWAP ! ] PROCESS-TABLE $38 + @ SET-RDEPTH
  \ Restore old state, except depth.
  R> PROCESS-TABLE $38 + !
  R> PROCESS-TABLE $30 + !
  R> R> R> SET-SOURCE R> SET-FLAGS R>
  \ Save the throw code, then restore the depth and throw code.
  SWAP >R SET-DEPTH R> ;

\ TODO(remexre): These should probably have some mechanism for arbitrary-length
\ stacks.
\ An sstack (software stack) has the memory layout:
\ +--------+----------+--------+
\ | Length | Capacity | Items ...
\ +--------+----------+--------+
: SSTACK CREATE 0 , DUP , CELLS ALLOT ;
: SSTACK/LEN ( sstack -- val ) @ ;
: SSTACK/CAP ( sstack -- val ) CELL+ @ ;
: SSTACK/CHECK/NONFULL ( sstack -- ) DUP SSTACK/LEN SWAP SSTACK/CAP = -256 AND THROW ;
: SSTACK/CHECK/NONEMPTY ( sstack -- ) @ NOT -257 AND THROW ;
: SSTACK/UNSAFE/DROP ( sstack -- ) 1-! ;
: SSTACK/UNSAFE/UNDROP ( sstack -- ) 1+! ;
: SSTACK/UNSAFE/TOP-ADDR ( sstack -- addr ) DUP SSTACK/LEN 1+ CELLS + ;
: SSTACK/UNSAFE/PEEK ( sstack -- val ) SSTACK/UNSAFE/TOP-ADDR @ ;
: SSTACK/UNSAFE/SET-TOP ( val sstack -- ) SSTACK/UNSAFE/TOP-ADDR ! ;
: SSTACK/DROP ( sstack -- val ) DUP SSTACK/CHECK/NONEMPTY SSTACK/UNSAFE/DROP ;
: SSTACK/PEEK ( sstack -- val ) DUP SSTACK/CHECK/NONEMPTY SSTACK/UNSAFE/PEEK ;
: SSTACK/POP ( sstack -- val ) DUP SSTACK/PEEK SWAP SSTACK/UNSAFE/DROP ;
: SSTACK/PUSH ( val sstack -- ) DUP SSTACK/CHECK/NONFULL DUP SSTACK/UNSAFE/UNDROP SSTACK/UNSAFE/SET-TOP ;
: SSTACK/1+ ( stack -- ) DUP SSTACK/POP 1+ SWAP SSTACK/PUSH ;
: SSTACK/1- ( stack -- ) DUP SSTACK/POP 1- SWAP SSTACK/PUSH ;

32 SSTACK IF-STACK
: IF ['] (BRANCH0) COMPILE, HERE IF-STACK SSTACK/PUSH 0 COMPILE, ; IMMEDIATE
: ELSE ['] (BRANCH) COMPILE, HERE 0 COMPILE, HERE IF-STACK SSTACK/POP ! IF-STACK SSTACK/PUSH ; IMMEDIATE
: THEN HERE IF-STACK SSTACK/POP ! ; IMMEDIATE

: POSTPONE PARSE-AND-FIND DUP HEADER>XT SWAP HEADER>IMMEDIATE?
  IF COMPILE,
  ELSE [ ' LITERAL COMPILE, ] ['] COMPILE, COMPILE,
  THEN ; IMMEDIATE

32 SSTACK BEGIN-STACK
: BEGIN HERE BEGIN-STACK SSTACK/PUSH ; IMMEDIATE
: AGAIN POSTPONE (BRANCH) BEGIN-STACK SSTACK/POP COMPILE, ; IMMEDIATE
: UNTIL POSTPONE (BRANCH0) BEGIN-STACK SSTACK/POP COMPILE, ; IMMEDIATE
: WHILE
  POSTPONE (BRANCH0) HERE 0 COMPILE,
  BEGIN-STACK SSTACK/POP SWAP BEGIN-STACK SSTACK/PUSH BEGIN-STACK SSTACK/PUSH ; IMMEDIATE
: REPEAT POSTPONE AGAIN HERE BEGIN-STACK SSTACK/POP ! ; IMMEDIATE

64 SSTACK CASE-STACK
: CASE 0 CASE-STACK SSTACK/PUSH ; IMMEDIATE
: OF
  POSTPONE OVER POSTPONE = POSTPONE (BRANCH0)
  HERE CASE-STACK SSTACK/PUSH 0 COMPILE,
  POSTPONE DROP ; IMMEDIATE
: ENDOF
  POSTPONE (BRANCH)
  CASE-STACK SSTACK/POP
  HERE CASE-STACK SSTACK/PUSH 0 COMPILE,
  HERE SWAP ! ; IMMEDIATE
: ENDCASE
  POSTPONE DROP
  BEGIN CASE-STACK SSTACK/POP DUP WHILE HERE SWAP ! REPEAT
  DROP ; IMMEDIATE

\ Notes: At runtime, loop-sys looks like ( R: -- leave limit index )
\ TODO(remexre): Rework this to not be as dynamic (i.e., leave shouldn't be
\ part of loop-sys).
32 SSTACK DO-STACK
: DO
  POSTPONE (LITERAL) HERE 0 COMPILE, DO-STACK SSTACK/PUSH
  POSTPONE >R POSTPONE 2>R HERE DO-STACK SSTACK/PUSH ; IMMEDIATE
: ?DO
  POSTPONE (LITERAL) HERE 0 COMPILE, DO-STACK SSTACK/PUSH
  POSTPONE >R POSTPONE 2DUP POSTPONE =
  POSTPONE IF POSTPONE 2DROP POSTPONE EXIT POSTPONE THEN
  POSTPONE 2>R HERE DO-STACK SSTACK/PUSH ; IMMEDIATE
: UNLOOP R> RDROP RDROP RDROP >R ;
: +LOOP
  POSTPONE 2R> POSTPONE ROT POSTPONE + POSTPONE 2DUP POSTPONE 2>R POSTPONE =
  POSTPONE (BRANCH0) DO-STACK SSTACK/POP COMPILE, POSTPONE UNLOOP HERE DO-STACK SSTACK/POP !
  ; IMMEDIATE
: LOOP POSTPONE (LITERAL) 1 COMPILE, POSTPONE +LOOP ; IMMEDIATE
: I 2R> OVER -ROT 2>R ;
: LEAVE RDROP RDROP RDROP ;

: TO ' CELL+ CELL+ FLAGS 1 AND IF ! ELSE POSTPONE LITERAL POSTPONE ! THEN ; IMMEDIATE
: VALUE CREATE ['] (VALUE) SET-DOES , ;

: 3DROP ( a b c -- ) 2DROP DROP ;
: 3DUP ( a b c -- a b c a b c ) 2DUP 5 PICK -ROT ;
: STR= ( addr1 len1 addr2 len2 -- flag )
  ROT OVER <> IF 3DROP FALSE EXIT THEN
  0 ?DO 2DUP I + C@ SWAP I + C@ <> IF 2DROP FALSE UNLOOP EXIT THEN LOOP 2DROP TRUE ;

: S"
  34 PARSE
  FLAGS 1 AND NOT
  IF SWAP POSTPONE LITERAL POSTPONE LITERAL THEN
  ; IMMEDIATE
: ." POSTPONE S" FLAGS 1 AND NOT IF POSTPONE TYPE ELSE TYPE THEN ; IMMEDIATE
: .( 41 PARSE TYPE CR ; IMMEDIATE

32 CONSTANT BL
: SPACE BL EMIT ;
: SPACES 0 ?DO SPACE LOOP ;
: QUOTE 34 EMIT ;
: .N FLAGS 2 AND IF .HEX ELSE .DECIMAL THEN ;
: . .N SPACE ;
: DECIMAL FLAGS 2 INVERT AND SET-FLAGS ;
: HEX FLAGS 2 OR SET-FLAGS ;

: NYBBLE>HEXCH 15 AND S" 0123456789abcdef" DROP + C@ ;
: C.HEX DUP 4 RSHIFT NYBBLE>HEXCH EMIT NYBBLE>HEXCH EMIT ;
: H.HEX DUP 8 RSHIFT C.HEX C.HEX ;
: W.HEX DUP 16 RSHIFT H.HEX H.HEX ;
: D.HEX DUP 32 RSHIFT W.HEX W.HEX ;

: BTYPE ( addr len -- ) OVER + SWAP ?DO I C@ C.HEX LOOP ;

: .S ." <" DEPTH .DECIMAL ." > " 1 DEPTH ?DO I 1- PICK . -1 +LOOP CR ;
: (DEBUG) ." : " HEX .S BP TODO ;
: DEBUG" POSTPONE ." POSTPONE (DEBUG) ; IMMEDIATE
: DEBUG DEBUG" DEBUG" ;

: COUNT DUP C@ SWAP 1+ SWAP ;
: CTYPE COUNT TYPE ;
: CSTR>STR ( addr -- addr len ) 0 BEGIN 2DUP + C@ WHILE 1+ REPEAT ;
: >BODY 16 + ;
: LATEST PROCESS-TABLE @ ;
: POW2 ( u -- u ) 1 SWAP LSHIFT ;
: ALIGN-DOWN-TO-POW2 ( u b -- u ) POW2 1- INVERT AND ;
: ALIGN-UP-TO-POW2 ( u b -- u ) POW2 1- DUP ROT + SWAP INVERT AND ;
: ALIGNED ( u -- u ) 3 ALIGN-UP-TO-POW2 ;
: WALIGNED ( u -- u ) 2 ALIGN-UP-TO-POW2 ;
: PRINT-WORD-NAME ( word-addr -- ) DUP 10 + SWAP 9 + C@ TYPE SPACE ;
: WORDS ( -- ) LATEST BEGIN DUP WHILE DUP PRINT-WORD-NAME @ REPEAT ;

: (DOES>) R@ CELL+ SET-DOES ;
: DOES> POSTPONE (DOES>) POSTPONE EXIT
  \ Ideally, this inline asm wouldn't be needed... It's the same as in
  \ SET-DOES, though, so I guess I'm fine with it?
  $d63f012058000049 , \ ldr x9, [pc, 8]; blr x9
  ['] (DOES) , ; IMMEDIATE

: (DEFER-ABORT) -259 THROW ;
: DEFER CREATE ['] (DEFER-ABORT) , DOES> @ EXECUTE ;
: DEFER! >BODY ! ;
: IS FLAGS 1 AND IF ' DEFER! ELSE POSTPONE ['] POSTPONE DEFER! THEN ; IMMEDIATE

: ARRAY CREATE DUP , CELLS ALLOT
  DOES> 2DUP @ < NOT IF -260 THROW THEN SWAP CELLS + CELL+ ;

\ A simple bitmap structure, used in the buddy allocator.
\ This has the memory layout:
\ +---------+---------+
\ |  Length | Bitmap ...
\ | (Bytes) |  Data  ...
\ +---------+---------+
: NONAME-BITMAP ( bit-count -- ) ALIGNED 3 RSHIFT DUP , ALLOT ;
: BITMAP ( bit-count -- ) CREATE NONAME-BITMAP ;
: BITMAP/IDX ( idx -- byte-idx bit-idx ) DUP 3 RSHIFT SWAP 7 AND ;
: BITMAP/CHECK ( idx bitmap -- ) SWAP BITMAP/IDX DROP SWAP @ < NOT -261 AND THROW ;
: BITMAP/GET ( idx bitmap -- flag ) 2DUP BITMAP/CHECK
  CELL+ SWAP BITMAP/IDX -ROT + C@ SWAP POW2 AND 0<> ;
: BITMAP/SET ( idx flag bitmap -- ) 3DUP NIP BITMAP/CHECK
  CELL+ ROT BITMAP/IDX
  -ROT + 2DUP C@ SWAP POW2 INVERT AND
  ROT POW2 4 PICK 0<> AND OR SWAP C! DROP ;
: BITMAP/FLIP ( idx bitmap -- ) 2DUP BITMAP/GET NOT SWAP BITMAP/SET ;