Working on alignment in DOTQ and ERROR

diff --git a/FIG68K.S b/FIG68K.S
index f1b7791..3829d05 100644 (file)
--- a/FIG68K.S
+++ b/FIG68K.S
@@ -1267,35 +1267,54 @@ QODD    DC.L    *+NATWID
        MOVE.L  D0,-(PSP)       ; Save the test result as the flag.\r
        BRA.W   NEXT\r
 *\r
-* Not in fig,\r
-* for CPUs that don't like odd addresses.\r
-* Floor top of stack even.\r
-* ( n --- even )\r
+* Not in fig --\r
+* Calculate the bump adjustment necessary for odd or even alignment.\r
+* Odd for odd alignment, even for even.\r
+* ( n alignment --- n bump )\r
        EVEN\r
        DC.B    0\r
        DC.B    $86\r
-       DC.B    'FLOOR' ; 'FLOOR2'\r
-       DC.B    '2'|$80\r
-       DC.L    QODD-5-NATWID\r
-FLOOR2 DC.L    *+NATWID\r
-       AND.W   #$FFFE,NATWID/2(PSP)\r
+       DC.B    'ALIGN' ; 'ALIGN-BUMP'\r
+       DC.B    '+'|$80\r
+       DC.L    ALLOT-6-NATWID\r
+ALGNB  DC.L    *+NATWID\r
+       MOVE.L  (PSP),D0\r
+       AND.L   #1,D0   ; Even or odd alignment?\r
+       MOVE.L  NATWID(PSP),D1\r
+       AND.W   #1,D1   ; Even address or odd?\r
+       EOR.W   D0,D1   ; odd on even or even on odd is 1, else 0\r
+       MOVE.L  D1,(PSP)\r
        BRA.W   NEXT\r
 *\r
-* Not in fig,\r
-* for CPUs that don't like odd addresses.\r
-* Make top of stack even by adjusting it up.\r
-* ( n --- even )\r
-       EVEN\r
-       DC.B    0\r
-       DC.B    $88\r
-       DC.B    'CIELING'       ; 'CIELING2'\r
-       DC.B    '2'|$80\r
-       DC.L    FLOOR2-7-NATWID\r
-CIEL2  DC.L    *+NATWID\r
-       BCLR    #0,NATWID-1(PSP)\r
-       BEQ.S   CIEL2X\r
-       ADDQ.L  #2,(PSP)\r
-CIEL2X BRA.W   NEXT\r
+** Not in fig,\r
+** for CPUs that don't like odd addresses.\r
+** Floor top of stack even.\r
+** ( n --- even )\r
+*      EVEN\r
+*      DC.B    0\r
+*      DC.B    $86\r
+*      DC.B    'FLOOR' ; 'FLOOR2'\r
+*      DC.B    '2'|$80\r
+*      DC.L    QODD-5-NATWID\r
+* FLOOR2       DC.L    *+NATWID\r
+*      AND.W   #$FFFE,NATWID/2(PSP)\r
+*      BRA.W   NEXT\r
+**\r
+** Not in fig,\r
+** for CPUs that don't like odd addresses.\r
+** Make top of stack even by adjusting it up.\r
+** ( n --- even )\r
+*      EVEN\r
+*      DC.B    0\r
+*      DC.B    $88\r
+*      DC.B    'CIELING'       ; 'CIELING2'\r
+*      DC.B    '2'|$80\r
+*      DC.L    FLOOR2-7-NATWID\r
+* CIEL2        DC.L    *+NATWID\r
+*      BCLR    #0,NATWID-1(PSP)\r
+*      BEQ.S   CIEL2X\r
+*      ADDQ.L  #2,(PSP)\r
+* CIEL2X       BRA.W   NEXT\r
 *\r
 * ######>> screen 26 <<\r
 * ======>>  23  <<\r
@@ -1950,6 +1969,18 @@ NATP     DC.L    *+NATWID
        MOVE.L  D0,(PSP)\r
        BRA.W   NEXT\r
 *\r
+* Useful constant, not in model, needed for abstraction:\r
+* ( --- NATWID/2 )\r
+* Half the byte width of objects on stack.\r
+       EVEN\r
+       DC.B    0\r
+       DC.B    $8A\r
+       DC.B    'HALFNATWI'     ; 'HALFNATWID'\r
+       DC.B    'D'|$80\r
+       DC.L    NATP-5-NATWID\r
+HNATWC DC.L    DOCON\r
+HNATWCV        DC.L    NATWID/2\r
+*\r
        PAGE\r
 *\r
 * ======>>  56  <<\r
@@ -1960,7 +1991,7 @@ NATP      DC.L    *+NATWID
        DC.B    $82\r
        DC.B    'B'     ; 'BL'\r
        DC.B    'L'|$80\r
-       DC.L    NATP-5-NATWID\r
+       DC.L    HNATWC-11-NATWID\r
 BL     DC.L    DOCON   ; ascii blank\r
        DC.L    $20\r
 *\r
@@ -2417,6 +2448,17 @@ HERE     DC.L    DOCOL,DICTPT,AT
 ALLOT  DC.L    DOCOL,DICTPT,PSTORE\r
        DC.L    SEMIS\r
 *\r
+* ( n --- )\r
+* Bump the DICTPT if necessary to odd or even alignment, according to n.\r
+* Odd n for odd alignment, even n for even.\r
+       EVEN\r
+       DC.B    $85\r
+       DC.B    'ALIG'  ; 'ALIGN-HERE'\r
+       DC.B    'N'|$80\r
+       DC.L    ALLOT-6-NATWID\r
+ALIGNH DC.L    DOCOL,ALGNB,ALLOT\r
+       DC.L    SEMIS\r
+*\r
 * ======>>  87  <<\r
 * ( n --- )\r
 * Store word n at DP++,\r
@@ -2424,7 +2466,7 @@ ALLOT     DC.L    DOCOL,DICTPT,PSTORE
        EVEN\r
        DC.B    $81     ; , (COMMA)\r
        DC.B    ','|$80\r
-       DC.L    ALLOT-6-NATWID\r
+       DC.L    ALIGNH-6-NATWID\r
 COMMA  DC.L    DOCOL,HERE,STORE,NATWC,ALLOT    ; race condition\r
        DC.L    SEMIS\r
 * COMMA        DC.L    DOCOL,HERE,STORE,TWO,ALLOT      ;  The model hard-coded TWO\r
@@ -2443,19 +2485,32 @@ COMMA   DC.L    DOCOL,HERE,STORE,NATWC,ALLOT    ; race condition
 CCOMM  DC.L    DOCOL,HERE,CSTORE,ONE,ALLOT     ; race condition\r
        DC.L    SEMIS\r
 *\r
+* Not in model, but needed for 32-bit.\r
+* ( h --- )\r
+* Store half cell h at DP+.\r
+* Should ERROR check stack/heap.\r
+       EVEN\r
+       DC.B    0\r
+       DC.B    $82\r
+       DC.B    'H'     ; 'H,'\r
+       DC.B    ','|$80\r
+       DC.L    CCOMM-3-NATWID\r
+HCOMM  DC.L    DOCOL,HERE,HSTORE,HNATWC,ALLOT  ; race condition\r
+       DC.L    SEMIS\r
+*\r
 * ======>>  89  <<\r
 * ( n1 n2 --- n1-n2 )\r
 * Subtract top two words.\r
        EVEN\r
        DC.B    $81     ; -\r
        DC.B    '-'|$80\r
-       DC.L    CCOMM-3-NATWID\r
+       DC.L    HCOMM-3-NATWID\r
 SUB    DC.L    *+NATWID\r
        MOVE.L  (PSP)+,D0       ; Subtraction is not commutative.\r
        SUB.L   D0,(PSP)        ; left side operand is the deeper one on the stack.\r
        BRA.W   NEXT\r
 * SUB  DC.L    DOCOL,MINUS,PLUS\r
-*      DC.L    SEMIS   ; Costs lots of bytes and lots of cycles compared to native code.\r
+*      DC.L    SEMIS   ; Costs extra bytes and lots of cycles compared to native code.\r
 *\r
 * ( d1 d2 --- d1-d2 )\r
 * Subtract top two integers.\r
@@ -2769,11 +2824,12 @@ SCSP    DC.L    DOCOL,SPAT,CSP,STORE
        DC.B    'R'|$80\r
        DC.L    SCSP-5-NATWID\r
 * QERR DC.L    *+NATWID\r
-*      LDD     NATWID,U\r
-*      BNE     QERROR\r
-*      LEAU    2*NATWID,U\r
-*      LBRA    NEXT\r
-** this doesn't work anyway: QERROR    LBRA    ERROR\r
+*      TST.L   NATWID(PSP)\r
+*      BNE.S   QERROR\r
+*      LEA     NATWID(PSP),PSP\r
+*      BRA.W   NEXT\r
+** this doesn't work anyway: \r
+* QERROR       BRA.W   ERROR\r
 QERR   DC.L    DOCOL,SWAP,ZBRAN\r
        DC.L    QERR2-*-NATWID\r
        DC.L    ERROR,BRAN\r
@@ -3155,8 +3211,11 @@ DTRAL4   DC.L    XLOOP
        DC.L    DTRAIL-10-NATWID\r
 * PDOTQ        DC.L    DOCOL,R,TWOP,COUNT,DUP,ONEP\r
 * PDOTQ        DC.L    DOCOL,R,NATP,COUNT,DUP,ONEP\r
-PDOTQ  DC.L    DOCOL,R,COUNT,DUP,ONEP  ; A5/IP is post-inc.\r
-       DC.L    FROMR,PLUS,TOR,TYPE\r
+PDOTQ  DC.L    DOCOL,R         ; A5/IP is post-inc.\r
+       DC.L    COUNT,DUP,ONEP  ; There's a count byte, too.\r
+       DC.L    ALGNB,PLUS      ; Align it.\r
+       DC.L    FROMR,PLUS,TOR  ; IP ready to continue after the string.\r
+       DC.L    TYPE\r
        DC.L    SEMIS\r
 *\r
 * ======>>  125  <<\r
@@ -3177,7 +3236,7 @@ DOTQ      DC.L    DOCOL
        DC.L    STATE,AT,ZBRAN\r
        DC.L    DOTQ1-*-NATWID\r
        DC.L    COMPIL,PDOTQ,WORD\r
-       DC.L    HERE,CAT,ONEP,ALLOT,BRAN\r
+       DC.L    HERE,CAT,ONEP,ALGNB,PLUS,ALLOT,BRAN\r
        DC.L    DOTQ2-*-NATWID\r
 DOTQ1  DC.L    WORD,HERE,COUNT,TYPE\r
 DOTQ2  DC.L    SEMIS\r
@@ -3371,6 +3430,7 @@ HOLD      DC.L    DOCOL,LIT
 * ( --- adr )\r
 * Give the address of the output PAD buffer. \r
 * PAD points to the end of a 68 byte buffer for numeric conversion.\r
+* 68 bytes is enough to convert a 64-bit integer to binary.\r
        EVEN\r
        DC.B    $83\r
        DC.B    'PA'    ; 'PAD'\r
@@ -3483,6 +3543,66 @@ DFIND    DC.L    DOCOL,BL,WORD,HERE,CONTXT,AT,AT
 DFIND2 DC.L    SEMIS\r
 *\r
        PAGE\r
+* ######>> screen 50 <<\r
+* ======>>  142  <<\r
+* ( anything --- nothing )        ( anything *** nothing )\r
+* An indirection for ABORT, for ERROR,\r
+* which may be modified carefully.\r
+       EVEN\r
+       DC.B    $87\r
+       DC.B    '(ABORT'        ; '(ABORT)'\r
+       DC.B    ')'|$80\r
+       DC.L    DFIND-6-NATWID\r
+PABORT DC.L    DOCOL,ABORT\r
+       DC.L    SEMIS\r
+*\r
+* ======>>  143  <<\r
+* ERROR        ( anything line --- IN BLK )    ( anything *** nothing )\r
+* ( anything --- nothing )\r
+* ( anything *** nothing ) WARNING < 0\r
+* Prints out the last symbol scanned and MESSAGE number line.  If\r
+* WARNING is less than zero, ABORTs through (ABORT), otherwise,\r
+* clears the parameter stack, pushes the INput cursor and\r
+* interpretaion BLK, and QUITs.\r
+       EVEN\r
+       DC.B    $85\r
+       DC.B    'ERRO'  ; 'ERROR'\r
+       DC.B    'R'|$80-NATWID\r
+       DC.L    PABORT-8-NATWID\r
+* This really should not be high level, according to best practices.\r
+* But fixing that cascades through MESSAGE,\r
+* requiring re-architecting the disk block system.\r
+* First, we need to get this transliteration running.\r
+ERROR  DC.L    DOCOL,WARN,AT,ZLESS\r
+       DC.L    ZBRAN\r
+       DC.L    ERROR2-*-NATWID\r
+* note: WARNING is\r
+* -1 to abort,\r
+* 0 to print error #\r
+* and 1 to print error message from disc\r
+       DC.L    PABORT\r
+ERROR2 DC.L    HERE,COUNT,TYPE,PDOTQ\r
+       DC.B    4,7     ; ( bell )\r
+       DC.B    " ? "\r
+       DC.B    0       ; hand-align\r
+       DC.L    MESS,SPSTOR,IN,AT,BLK,AT,QUIT\r
+       DC.L    SEMIS\r
+*\r
+* ======>>  144  <<\r
+* ( n adr --- )\r
+* Mask byte at adr with n.\r
+* Not in FIG, don't need it for 8 bit characters after all.\r
+*      EVEN\r
+*      DC.B    $85\r
+*      DC.B    'CMAS'  ; 'CMASK'\r
+*      DC.B    $CB     ; 'K'\r
+*      DC.L    ERROR-8\r
+* CMASK        DC.L    *+NATWID\r
+*      MOVE.L  (PSP)+,A0       ; adr\r
+*      MOVE.L  (PSP)+,D0       ; prepare for mask\r
+*      AND.B   D0,(A0)\r
+*      BRA.W   NEXT\r
+*\r
 \r
 *\r
 * ######>> screen 63 <<\r
@@ -3694,56 +3814,6 @@ TRON     FDB     *+NATWID
 \r
 ******* Continue from the LOOP variables ********\r
 \r
-* ######>> screen 50 <<\r
-* ======>>  142  <<\r
-* ( anything --- nothing )        ( anything *** nothing )\r
-* An indirection for ABORT, for ERROR,\r
-* which may be modified carefully.\r
-       FCB     $87\r
-       FCC     '(ABORT'        ; '(ABORT)'\r
-       FCB     $A9\r
-       FDB     DFIND-8\r
-PABORT FDB     DOCOL,ABORT\r
-       FDB     SEMIS\r
-*\r
-* ======>>  143  <<\r
-       FCB     $85\r
-       FCC     'ERRO'  ; 'ERROR'\r
-       FCB     $D2\r
-       FDB     PABORT-10\r
-* This really should not be high level, according to best practices.\r
-* But fixing that cascades through MESSAGE,\r
-* requiring re-architecting the disk block system.\r
-* First, we need to get this transliteration running.\r
-ERROR  FDB     DOCOL,WARN,AT,ZLESS\r
-       FDB     ZBRAN\r
-       FDB     ERROR2-*-NATWID\r
-* note: WARNING is\r
-* -1 to abort,\r
-* 0 to print error #\r
-* and 1 to print error message from disc\r
-       FDB     PABORT\r
-ERROR2 FDB     HERE,COUNT,TYPE,PDOTQ\r
-       FCB     4,7     ( bell )\r
-       FCC     " ? "\r
-       FDB     MESS,SPSTOR,IN,AT,BLK,AT,QUIT\r
-       FDB     SEMIS\r
-*\r
-* ======>>  144  <<\r
-* ( n adr --- )\r
-* Mask byte at adr with n.\r
-* Not in FIG, don't need it for 8 bit characters after all.\r
-*      FCB     $85\r
-*      FCC     'CMAS'  ; 'CMASK'\r
-*      FCB     $CB     ; 'K'\r
-*      FDB     ERROR-8\r
-* CMASK        FDB     *+NATWID\r
-*      LDX     ,U++    ; adr\r
-*      LDD     ,U++    ; mask\r
-*      ANDB    ,X\r
-*      STB     ,X\r
-*      LBRA    NEXT\r
-*\r
 * ( adr --- adr )\r
 * Mask high bit of tail of name in PAD buffer.\r
 * Not in FIG, need it for 8 bit characters.\r

diff --git a/notes.text b/notes.text
index b6db753..44abc01 100644 (file)
--- a/notes.text
+++ b/notes.text
@@ -49,3 +49,15 @@
 * That shouldn't be PCR in LATEST, it should be XCURR-UORIG,X .
 
 * Need to go back and check all allocating words for integer alignment issues.
+
+* No description for ERROR for some reason.
+
+* Need to figure out whether TYPE or PDOTQ will handle odd lenght strings.
+
+* PDOTQ and DOTQ have alignment adjuctment stuff.
+
+* PAD needs comment on buffer width
+
+* ERROR gets alignment adjustment.
+
+