1. - - 15


39

( 31.03.86 DIGIT CONVERT NUMBER ) : DIGIT ( C,N1->N2,TF/FF) 0 ROT ROT 0 DO I ALPHA OVER = IF 2DROP I -1 0 LEAVE THEN LOOP DROP ; : CONVERT ( WD1,A1->WD2,A2) BEGIN 1+ DUP >R C@ BASE @ DIGIT WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ DPL @ 1+ IF DPL 1+! THEN R> REPEAT R> ; : NUMBER ( T->WD ) 0 0 ROT DUP >R COUNT OVER + OVER C@ C" - = DUP >R SWAP >R IF ELSE 1- THEN -1 BEGIN DPL ! CONVERT DUP R@ < WHILE DUP C@ C" . <> IF RDROP RDROP R> BADWORD THEN 0 REPEAT DROP RDROP R> IF DNEGATE THEN RDROP ;

40

( 31.03.86 EXPECT QUERY INTERPRET - X ) : EXPECT ( A,+N-> ) DUP >R (EXPECT) DUP SPAN ! TYPE R> SPAN @ - IF SPACE THEN ; : QUERY ( ->) TIB 80 EXPECT >IN 0! BLK 0! SPAN @ #TIB ! ; : INTERPRET ( ->) BEGIN -FIND ?DUP IF 1+ IF EXECUTE ELSE STATE @ IF , ELSE EXECUTE THEN THEN ELSE NUMBER DPL @ 1+ IF [COMPILE] 2LITERAL ELSE DROP [COMPILE] LITERAL THEN THEN ?STACK AGAIN ; : - ( ->) BEGIN QUERY INTERPRET AGAIN ; CODE X ( ->) -X ( "X") EXIT# B, END-CODE IMMEDIATE

41

( 31.03.86 -TRAILING ' ['] [COMPILE] LOAD THRU ;S --> ) CODE -TRAILING ( A,N1->A,N2) 14 LHRW12 BAL, RW1 RMASK NR, RW1 RFORTH AR, 0 RW1 LR, RW1 RW2 AR, BEGIN, RW1 0 CR, 1 =F BNH, RW1 0 BCTR, 0 (, RW1 64 CLI, ?NE UNTIL, 0 0 BCTR, 1 =H RW1 0 SR, PUTRW1 B, END-CODE : ' ( ->CFA) -FIND 0= IF BADWORD THEN ; : ['] ( -> ) ?COMP ' [COMPILE] LITERAL ; IMMEDIATE : [COMPILE] ( ->) -FIND IF , EXIT THEN BADWORD ; IMMEDIATE : LOAD ( N-> N ) >IN @ >R BLK @ >R BLK ! >IN 0! INTERPRET R> BLK ! R> >IN ! ; : THRU ( N1,N2-> N1 N2 ) 1+ SWAP DO I LOAD LOOP ; : ;S ( ->) ?LOADING RDROP ; IMMEDIATE : --> ( ->) ?LOADING >IN 0! BLK 1+! ; IMMEDIATE

42

( 09.09.86 DUMP SNAPSTK S. R. ) : DUMP ( A,U-> U ) DUP IF BASE @ >R HEX OVER + SWAP DO CR I <# C" * HOLD 0 15 DO DUP I + C@ HOLD -1 +LOOP C" * HOLD 0 15 DO BL HOLD DUP I + C@ 0 # # 2DROP -1 +LOOP BL HOLD BL HOLD 0 # # # # #> TYPE 16 +LOOP R> BASE ! ELSE 2DROP THEN ; : SNAPSTK RDROP CR ". ." , " 2DUP SWAP - 2/ DUP . 0 SWAP , IF ." ( )" CR 2- DO I @ . -2 +LOOP ELSE 2DROP THEN ; : S. ( ->) SP@ S0 @ " " SNAPSTK ; : R. ( ->) RP@ 2+ R0 @ " " SNAPSTK ;