"Loading Small CREATE and support" $PRINT CRLF
;
; HP-IPL/OS 0.58B CREATE - small version
; by Terry Newton, modified 12/1/02 3/10/03 9/6/04
; modified 12/13/07 - fixed IHASH typo and recomputed hash tables
; modified 2/13/08 - patched $ML2CODE to avoid crash w/ bad ASC line,
;  altered messages to make up for added code
;
; CREATE - Defines Machine Language
; Usage: CREATE DEFNAME
; Sorta HPASM-compatible, 6-char labels
; If redirecting input flow-control must be used, there
; may be sizable delays while compiling (searching for
; already defined labels) and at the end (going back over
; and fixing locations that weren't defined yet). Should
; work fine from PTR, BACI or MS but probably won't work
; directly from the 2400 baud non-buffered TTY console
; unless an app is written to detect the prompt and not
; send the line until the prompt appears. Example use..
;
; ? CREATE TEST
; 022345:  LDA VALUE
; 022346:  JSB ZSPSH,I
; 022347:  JMP END
; 022350: VALUE OCT 777
; 022351: END
; ?
;
; 9/17/02 added /K (/KEEP) option to keep previous symbols
; 10/8/02 removed /L option
;
OCTAL DEFINE CREATE
DEC END ;dummy, will wrap around everything else
;
VARIABLE SYMBOLS  ;number of symbols
VARIABLE FIXUPS   ;number of fixups
VARIABLE MLERROR  ;set to 1 if error
VARIABLE MLCODE   ;binary code for instruction
VARIABLE SYMADR   ;starting address of symbols
VARIABLE FIXADR   ;starting address of fixups
VARIABLE IMATCH   ;zero if no match yet
VARIABLE IOMATCH  ;if one, it's an IO instruction
;
;handy comparisons...
;DEFINE A>B
;SWAP SUB IF<0 #1 ELSE #0 ENDIF END
;DEFINE A<B
;SUB IF<0 #1 ELSE #0 ENDIF END
"Loading A=B" $PRINT CRLF
DEFINE A=B
SUB IFZ #1 ELSE #0 ENDIF END
;DEFINE A<=B
;SWAP SUB IF<0 #0 ELSE #1 ENDIF END
"Loading A>=B" $PRINT CRLF
DEFINE A>=B
SUB IF<0 #0 ELSE #1 ENDIF END
;DEFINE A<>B
;SUB IFZ #0 ELSE #1 ENDIF END
;
"Loading PUTSYMBOL" $PRINT CRLF
DEFINE PUTSYMBOL
; saves symbol to SYMADR + SYMBOLS * 4
; increments SYMBOLS
; data format SY MB OL address (up to 6 char label)
; Usage: "SYMBOL" address PUTSYMBOL
; removes string
SYMADR GET SYMBOLS GET 4 MUL ADD ;calculate offset
DUP $ADR GET PUT  ;write 1st 2 letters
INC DUP $ADR INC GET PUT ;write next 2 letters
INC DUP $ADR 2 ADD GET PUT ;write last 2 letters
INC SWAP PUT    ;write address
SYMBOLS DUP GET INC PUT ;increment symbols
$DROP
END
;
"Loading FINDSYMBOL" $PRINT CRLF
DEFINE FINDSYMBOL
; searches for saved symbol and pushes address
; usage: "SYMBOL" GETSYMBOL
; pushes 0 if not found, else pushes 1 and item
; string must be at least 6 chars, not removed
#0  ;start no match
#0 SYMBOLS GET DEC +DO  ;loop thru all
 DUP IFZ  ;if no match yet 
  SYMBOLS GET DEC INDEX SUB ;adjusted index to go backwards
  4 MUL SYMADR GET ADD ;point to entry
  DUP GET $ADR GET A=B IFNZ ;if 1st 2 chars match
   INC DUP GET $ADR INC GET A=B IFNZ ; and next 2
    INC DUP GET $ADR 2 ADD GET A=B IFNZ ; and next 2
     INC GET S>Z ;it's a match, change ptr into val on Z
     DROP #1 #0 ;change to a match, dummy ptr to drop
    ENDIF
   ENDIF
  ENDIF
  DROP  ;drop the pointer
 ENDIF
+LOOP
DUP IFNZ Z>S SWAP ENDIF ;get saved val if match
END
;
"Loading PUTFIX" $PRINT CRLF
DEFINE PUTFIX
; saves fixpoint to FIXADR + FIXUPS * 4
; increments FIXUPS
; "SYMBOL" address PUTFIX
; string must be at least 6 chars, removed
FIXADR GET FIXUPS GET 4 MUL ADD ;calculate offset
DUP $ADR GET PUT  ;write 1st 2 letters
INC DUP $ADR INC GET PUT ;write next 2 letters
INC DUP $ADR 2 ADD GET PUT ;write last 2 letters
INC SWAP PUT $DROP ;write value and drop string
FIXUPS DUP GET INC PUT  ; increment fixups
END
;
"Loading GETFIX" $PRINT CRLF
DEFINE GETFIX
; gets fixup address and symbol
; usage: n GETFIX
; pushes address and string symbol to X
4 MUL FIXADR GET ADD  ;point to entry
DUP GET S>X      ;write name to string
INC DUP GET S>X
INC DUP GET S>X
6 S>X 4 S>X      ;length 6 wordlen=4 (inc. len)
INC GET  ;leave value on stack
END
;
"Loading CONVERT_TO_ADDRESS" $PRINT CRLF
DEFINE CONVERT_TO_ADDRESS
; if string starts with *, evaluate +/- relative to
; @DIPTR and change string to actual address
#0 $GET 52 SUB IFZ
 "     " $CAT #1 7 $SLICE $TRIM
 #0 $GET 53 SUB IFZ $HEAD DROP ENDIF
 $VAL @DIPTR GET ADD $DROP $STR
ENDIF
END
;
"Loading IHASH" $PRINT CRLF
DEFINE IHASH
; converts 3 char string of A-Z into unique 16 bit number
; on stack, does not remove string
0 $GET 101 SUB 1 $GET 101 SUB 32 MUL ADD
2 $GET 101 SUB 1244 MUL ADD END
;
"Loading 2D1" $PRINT CRLF
DEFINE 2D1
DROP DROP #1 END
;
"Loading MATCHSIMPLE" $PRINT CRLF
DEFINE MATCHSIMPLE
; instruction on X stack (remains)
; if successful set IMATCH and put base
; instruction bits in MLCODE.
#0  ;imatch value
#0  ;mlcode value
IHASH  ;convert string to a hash
CASE
= 024425 2D1 #0     ;NOP
= 004476 2D1 10000  ;AND
= 002201 2D1 14000  ;JSB
= 027147 2D1 20000  ;XOR
= 024335 2D1 24000  ;JMP
= 027130 2D1 30000  ;IOR
= 041740 2D1 34000  ;ISZ
= 000116 2D1 40000  ;ADA
= 001362 2D1 44000  ;ADB
= 000610 2D1 50000  ;CPA
= 002054 2D1 54000  ;CPB
= 000131 2D1 60000  ;LDA
= 001375 2D1 64000  ;LDB
= 001000 2D1 70000  ;STA
= 002244 2D1 74000  ;STB
ENDCASE
MLCODE SWAP PUT
IFNZ IMATCH #1 PUT ENDIF
END
;
"Loading MATCHIO" $PRINT CRLF
DEFINE MATCHIO
; match IO instructions, string not removed
; if successful, IMATCH set to 1, IOMATCH set to 1
; and MLCODE contains instruction bits (minus select
; code and ,C flag if specified - that is handled by
; the label/literal processing afterwards)
#0 #0  ;temp IMATCH and MLCODE data
IHASH ;hash the string
CASE
= 031521 2D1 102000  ;HLT
= 007464 2D1 102100  ;STF
= 007124 2D1 103100  ;CLF
= 002734 2D1 102200  ;SFC
= 030034 2D1 102300  ;SFS
= 000334 2D1 102400  ;MIA
= 001600 2D1 106400  ;MIB
= 000333 2D1 102500  ;LIA
= 001577 2D1 106500  ;LIB
= 000774 2D1 102600  ;OTA
= 002240 2D1 106600  ;OTB
= 003510 2D1 102700  ;STC
= 003150 2D1 106700  ;CLC
= 023370 2D1 102101  ;STO
= 023030 2D1 103101  ;CLO
= 030406 2D1 102301  ;SOS
= 003306 2D1 102201  ;SOC
ENDCASE
MLCODE SWAP PUT  ;update MLCODE and matches...
IFNZ IMATCH #1 PUT IOMATCH #1 PUT ENDIF
END
;
"Declaring ISLOT ITYPE" $PRINT CRLF
VARIABLE ISLOT
VARIABLE ITYPE
;
"Loading TEST_ASG" $PRINT CRLF
DEFINE TEST_ASG
; pushes 1 if in ASG group (3 or 4) else pushes 0
#0
ITYPE GET 3 SUB IFZ DROP #1 ENDIF
ITYPE GET 4 SUB IFZ DROP #1 ENDIF
END
;
"Loading S_A S_B S_ASG S_1 S_2 S_3 S_4" $PRINT CRLF
DEFINE S_A
; if ITYPE=0 then set to 6
ITYPE GET IFZ ITYPE 6 PUT ENDIF
END
DEFINE S_B
; if ITYPE=0 then set to 7
ITYPE GET IFZ ITYPE 7 PUT ENDIF
END
DEFINE S_ASG
; if ITYPE=0 then set to 5
ITYPE GET IFZ ITYPE 5 PUT ENDIF
END
DEFINE S_1
ITYPE #1 PUT END
DEFINE S_2
ITYPE 2 PUT END
DEFINE S_3
ITYPE 3 PUT END
DEFINE S_4
ITYPE 4 PUT END
;
"Loading DROP_B" $PRINT CRLF
DEFINE DROP_B
$LEN DEC $GET 102 SUB ;9/2/02
IFZ $TAIL DROP ENDIF END  ;ignore B in constants
;
"Loading ICOMPOUND" $PRINT CRLF
DEFINE ICOMPOUND
; input.. string containing compound fragment (removes)
;  ISLOT should be 0 for first slot, 1 for 2nd
;  ITYPE (start at 0) is the instruction type...
;   0=undefined 1=SRGA 2=SRGB 3=ASGA 4=ASGB 5=ASG 6=A 7=B
;  if non-0 ITYPE determines encoding using the rules...
;   0 can change to any, 5 can change to 3 or 4, 6 can
;   change to 1 or 3, 7 can change to 2 or 4.
; output.. 
;  ITYPE updated, new bits OR'd into MLCODE
;  if successful IMATCH set to 1
;not much errorchecking.... gigo
;9/6/04 removed INC_ISLOT word and all refs, was confused
#0 #0 ;imatch, partial
IHASH ;hash the input string
CASE
= 005660 2D1 TEST_ASG IFNZ 2100 ELSE 40 ENDIF       ;CLE
= 000460 2D1 TEST_ASG IFNZ 2010 ELSE 10 ENDIF S_A   ;SLA
= 001724 2D1 TEST_ASG IFNZ 6010 ELSE 4010 ENDIF S_B ;SLB
= 030246 2D1 ISLOT GET IFZ 1000 ELSE 20 ENDIF S_1   ;ALS
= 030247 2D1 ISLOT GET IFZ 5000 ELSE 4020 ENDIF S_2 ;BLS
= 030502 2D1 ISLOT GET IFZ 1100 ELSE 21 ENDIF S_1   ;ARS
= 030503 2D1 ISLOT GET IFZ 5100 ELSE 4021 ENDIF S_2 ;BRS
= 016435 2D1 ISLOT GET IFZ 1200 ELSE 22 ENDIF S_1   ;RAL
= 016467 2D1 ISLOT GET IFZ 5200 ELSE 4022 ENDIF S_2 ;RBL
= 026365 2D1 ISLOT GET IFZ 1300 ELSE 23 ENDIF S_1   ;RAR
= 026417 2D1 ISLOT GET IFZ 5300 ELSE 4023 ENDIF S_2 ;RBR
= 027002 2D1 ISLOT GET IFZ 1400 ELSE 24 ENDIF S_1   ;ALR
= 027003 2D1 ISLOT GET IFZ 5400 ELSE 4024 ENDIF S_2 ;BLR
= 000676 2D1 ISLOT GET IFZ 1500 ELSE 25 ENDIF S_1   ;ERA
= 002142 2D1 ISLOT GET IFZ 5500 ELSE 4025 ENDIF S_2 ;ERB
= 000442 2D1 ISLOT GET IFZ 1600 ELSE 26 ENDIF S_1   ;ELA
= 001706 2D1 ISLOT GET IFZ 5600 ELSE 4026 ENDIF S_2 ;ELB
= 007122 2D1 ISLOT GET IFZ 1700 ELSE 27 ENDIF S_1   ;ALF
= 007123 2D1 ISLOT GET IFZ 5700 ELSE 4027 ENDIF S_2 ;BLF
= 000440 2D1 2400 S_3   ;CLA
= 001704 2D1 6400 S_4   ;CLB
= 000472 2D1 3000 S_3   ;CMA
= 001736 2D1 7000 S_4   ;CMB
= 000066 2D1 3400 S_3   ;CCA
= 001332 2D1 7400 S_4   ;CCB
= 005712 2D1 2200 S_ASG ;CME
= 005306 2D1 2300 S_ASG ;CCE
= 041176 2D1 2040 S_ASG ;SEZ
= 000746 2D1 2020 S_3   ;SSA
= 002212 2D1 6020 S_4   ;SSB
= 000532 2D1 2004 S_3   ;INA
= 001776 2D1 6004 S_4   ;INB
= 001234 2D1 2002 S_3   ;SZA
= 002500 2D1 6002 S_4   ;SZB
= 030555 2D1 2001 S_ASG ;RSS
ENDCASE
$DROP ;drop string being tested
MLCODE GET OR MLCODE SWAP PUT  ; OR in instruction bits
IFNZ IMATCH #1 PUT ENDIF    ;update IMATCH
END
;
"Loading PARSE_FRAGMENT" $PRINT CRLF
DEFINE PARSE_FRAGMENT
; input.. str pointer on stack, string on X
; output.. another string on X containing 3 chars at and
;  after pointer, pointer = pointer + 4, and pushes
;  1 if no more (does Not push fragment), or 0 if valid
$LEN OVER  ;push length and pointer
3 ADD SUB  ;drop those and push len - (ptr+3)
IF<0 #1 ELSE ;if <0 no more left otherwise
 DUP $GET 40 SUB IFZ #1 ;if space, no more left
 ELSE
  DUP DUP 2 ADD $SLICE ;create fragment string
  4 ADD #0  ;update pointer, not done yet
 ENDIF
ENDIF
END
;
"Loading MATCHCOMPOUND" $PRINT CRLF
DEFINE MATCHCOMPOUND
; try to match compound instructions
; if successful set IMATCH and return code in MLCODE
; string not removed, processed until space or end of line
ISLOT #0 PUT ITYPE #0 PUT
#0 ;pointer into instruction line, starts at byte 0
; pass 1 - determine type to prevent ambiguity
DO
 PARSE_FRAGMENT DUP IFZ ;if successful
  ICOMPOUND  ;update ITYPE, MLCODE ignored for now
 ENDIF
 ISLOT #1 PUT ;9/6/04 if not 1st instruction must go in 2nd slot
UNTIL ;no more instructions
DROP ;the instruction line pointer
IMATCH GET IFZ MLERROR #1 PUT ENDIF ;error if no matches
; pass 2 - actually encode the compound instruction
MLERROR GET IFZ  ;if no errors
 ITYPE IFZ ITYPE 3 PUT ENDIF ;use ASGA if generic
 ITYPE GET 5 SUB IFZ ITYPE 3 PUT ENDIF ;use ASGA if ASG
 ITYPE GET 6 SUB IFZ ITYPE 1 PUT ENDIF ;use SRGA if A
 ITYPE GET 7 SUB IFZ ITYPE 2 PUT ENDIF ;use SRGB if B
 #0  ; pointer to instruction line
 MLCODE #0 PUT ; op code.. OR in all compound bits
 ISLOT #0 PUT  ; start at slot 0 again
 DO  ;loop through string
  PARSE_FRAGMENT DUP IFZ ICOMPOUND ENDIF
  ISLOT #1 PUT ;9/6/04 use 2nd slot if not 1st instruction
 UNTIL ;no more to decode
 DROP ; drop instruction line pointer 
ENDIF
END
;
"Loading $ML2CODE" $PRINT CRLF
DEFINE $ML2CODE
; processes string with one line of ML and returns
; equivalent ML code in MLCODE. If line contains
; a label, calls PUTSYMBOL to store its address.
; If line references a label, calls PUTFIX with
; referenced label and current address.
; If error occurs, MLERROR set to 1.
; MLERROR is set to 2 if a EQU encountered, no code.
; Input string left on the stack, not removed.
; @DIPTR holds current address, if anything
; writes more than 1 word, calls ADDCODE directly
; to add extra words, leaving last word in MLCODE
;
; if label detected (1st char not space) then save it
; position pointer after label if one exists
#0 $GET DUP 40 SUB IFNZ
 $LEN "" SWAP $APPEND #1 DO
  DUP X>>Y $GET Y>>X DUP 40 SUB IFNZ
   $APPEND INC OVER OVER SUB IFNZ #0 ELSE #1 ENDIF
  ELSE DROP #1 ENDIF ;geez tricky stuff!
 UNTIL SWAP DROP
 "     " $CAT @DIPTR GET PUTSYMBOL
ELSE DROP #1 ENDIF
; skip to start of instruction
DO
 DUP $GET 40 SUB IFZ
  INC DUP $LEN SUB IFNZ #0 ELSE #1 ENDIF
 ELSE #1 ENDIF
UNTIL
DUP $LEN SUB IFZ
 MLERROR #1 PUT  ;error - nothing on line
 DROP  ;going down...
ELSE
 ; trim down string so it starts at instruction
 #1 SWAP +DO $HEAD DROP +LOOP
 "      " $CAT  ;append spaces to avoid errors
 ; check for EQU/DEF/OCT/DEC/ASC
 #0 2 $SLICE "EQU" $EQUAL $DROP IFNZ
  4 11 $SLICE $TRIM CONVERT_TO_ADDRESS DROP_B $VAL
  ;now have to change the previously recorded symbol
  ;to value on the stack..
  SYMBOLS DUP DUP GET DEC PUT GET ;dec symbols, get value
  4 MUL SYMADR GET ADD ;calculate offset into symbol table
  "      " ;string to hold symbol
  DUP GET $ADR SWAP PUT  ;get 1st 2 chars
  INC DUP GET $ADR INC SWAP PUT ;get 2nd 2 chars
  INC DUP GET $ADR 2 ADD SWAP PUT ;get last 2 chars
  INC GET  ;get address
  ;label should be on X, address on stack and the
  ;fixup point effectively removed by decrementing fixups
  ;EQU value still on stack under fix address
  @DIPTR GET SUB IFNZ ;error if address <> current ptr
   $DROP DROP MLERROR #1 PUT
  ELSE
   PUTSYMBOL  ;write EQU value to symbol table instead
   MLERROR 2 PUT  ;set error to 2 to indicate no code
  ENDIF
 ELSE
  #0 2 $SLICE "DEF" $EQUAL $DROP IFNZ
   MLCODE 4 11 $SLICE $TRIM
   CONVERT_TO_ADDRESS $DUP DROP_B $VAL
   DUP IFNZ $DROP ;evaluates to non-zero address
   ELSE "      " $CAT ;append spaces for putfix
    @DIPTR GET PUTFIX  ;add fixup point, data=0
   ENDIF 
   PUT
  ELSE
   #0 2 $SLICE "OCT" $EQUAL $DROP IFNZ
    MLCODE 4 11 $SLICE $TRIM DROP_B $VAL PUT
   ELSE
    #0 2 $SLICE "DEC" $EQUAL $DROP IFNZ
     MLCODE 4 11 $SLICE $TRIM DECIMAL $VAL OCTAL PUT
    ELSE
     #0 2 $SLICE "ASC" $EQUAL $DROP IFNZ
      4 5 $SLICE 1 $GET 54 SUB IFZ $TAIL DROP ENDIF
      DECIMAL $VAL OCTAL  ;# words to compile on stack
      DUP DEC IF<0 DROP #1 MLERROR #1 PUT ENDIF
      ;get string after comma...
      6 DUP $GET 54 SUB IFZ INC ENDIF ;position after comma
      $LEN DEC "" +DO X>>Y INDEX $GET Y>>X $APPEND +LOOP
      DUP #1 SUB IFZ ;if only one word
       MLCODE $ADR GET PUT  ;return binary
       DROP  ;drop #words to compile
      ELSE
       $ADR OVER DEC DEC #0 SWAP +DO
        DUP INDEX ADD GET ADDCODE 
       +LOOP ADD DEC GET MLCODE SWAP PUT
      ENDIF
      $DROP ;drop string after ,
     ELSE
      IMATCH #0 PUT  ;clear match flag
      IOMATCH #0 PUT ;clear IO-match flag
      #0 3 $SLICE $TRIM  ;1st 4 chars, trim
      MATCHSIMPLE  ;try simple matches
      IMATCH GET IFZ MATCHIO ENDIF ;if no match try IO
;not used in small version
;     IMATCH GET IFZ MATCHEXT ENDIF ;if no match try extended
      $DROP  ;drop instruction field
      IMATCH GET IFZ  ;if no match...
       MATCHCOMPOUND
      ELSE  ;match requiring label processing
; process labels.. find separating space
       3 DO
        DUP $GET 40 SUB IFNZ
         INC DUP $LEN SUB IFZ #1 ELSE #0 ENDIF
        ELSE #1 ENDIF
       UNTIL
;pointer on stack, skip to non-space (or end of line)
;max 5 characters separating parm
       5 S>Y     ;9/2/02
       DO
        DUP $GET 40 SUB IFZ
         INC DUP $LEN SUB IFZ #1 ELSE #0 ENDIF
         Y>S DEC DUP S>Y IFZ DROP #1 ENDIF  ;9/2/02
        ELSE #1 ENDIF
       UNTIL
       Y>S DROP  ;9/2/02
;create string up to space, comma or end of line
       "" DO
        DUP X>>Y $LEN DEC Y>>X SWAP SUB IF<0 #1 ELSE
         DUP X>>Y $GET Y>>X  ;damn this is ugly
         DUP 40 SUB IFZ #1 ELSE
          DUP 54 SUB IFZ #1 ELSE
           DUP $APPEND ;append the character
           SWAP INC SWAP #0  ;inc ptr and keep going
          ENDIF
         ENDIF
         SWAP DROP  ;the char
        ENDIF
       UNTIL
;ptr still on stack, will need in a bit..
       $LEN IFZ $DROP ;if empty string, no label
       ELSE           ;otherwise process...
        6 $LEN SUB IF<0   ;if > 6 chars
         MLERROR #1 PUT   ;error-label too long
         $DROP  ;drop the label string
        ELSE
         CONVERT_TO_ADDRESS  ;translate *+1 type parms
; check to see if it is a constant.. only octal supported
         $DUP ;dup string for testing
         DROP_B ;ignore trailing B
         ;prepend enough zeros to equal 6 chars
         DO
          $LEN 6 SUB IF<0
           "0" $SWAP $CAT #0
          ELSE #1 ENDIF
         UNTIL
         $DUP $VAL DUP $STR $EQUAL $DROP IFNZ
; if a number then OR MLCODE with value AND 1777
          $DROP ; don't need string, got value
          DUP 1777 AND MLCODE GET OR MLCODE SWAP PUT
; this will work with the 6 bit select code instructions
; too, just don't select a channel larger than 6 bits!
; if value > 1777 then set C bit in MLCODE
          1777 SWAP SUB IF<0
           MLCODE DUP GET 2000 OR PUT
          ENDIF
         ELSE
          DROP ; it ain't a number
          "     " $CAT ;pad in case < 6 chars
          @DIPTR GET PUTFIX ;add the fixup point (drops $)
         ENDIF
; check to see if ,C or ,I etc specified
         DUP $GET 54 SUB IFZ  ;if comma
          INC DUP $GET 111 SUB IFZ  ;if ,I
           MLCODE DUP GET 100000 OR PUT ;set bit 15
          ELSE
           DUP $GET 103 SUB IFZ ;if ,C
            MLCODE DUP GET
            IOMATCH GET IFNZ 1000 ;if IO set bit 9
            ELSE 2000 ENDIF ;if memadr set bit 10
            OR PUT
           ELSE
            DUP $GET 132 SUB IFZ ;if ,Z
             MLCODE DUP GET 175777 AND PUT ;clear bit 10
            ENDIF
           ENDIF
          ENDIF
         ENDIF
        ENDIF  ;>6 chars check
       ENDIF ;empty label check
       DROP ;drop the ptr
      ENDIF ;simple match test
;     
; anything else that might need checking for?
;      
      IMATCH GET IFZ  ;if no match
       MLERROR #1 PUT ;error assembling
      ENDIF
     ENDIF ;=ASC
    ENDIF ;=DEC
   ENDIF ;=OCT
  ENDIF ;=DEF
 ENDIF ;=EQU
ENDIF ;=END
END
;
; utility to assist in adding new opcodes
;OCTAL DEFINE INUM
;DO CRLF "1) HASH" $PRINT CRLF "2) BIN TO OCT" $PRINT CRLF
;"3) QUIT >" $PRINT CHRIN CRLF
;CASE = 000061 "STRING: " $PRINT $IN IHASH
;20 40 $CREATE $PRINT PNUM $DROP #0
;= 000062 "BINARY: " $PRINT $IN BINARY $VAL OCTAL
;20 40 $CREATE $PRINT PNUM #0
;DEFAULT #1 ENDCASE UNTIL END
;
"Loading MAIN" $PRINT CRLF
DEFINE MAIN
TOKEN IFNZ "Name?" $PRINT
ELSE
 OCTAL    ;default radix = octal
 @TL GET S>Z @TB1 GET S>Z @TB2 GET S>Z ;save def specs
 @TB1 #0 PUT ;zero previous token results
 TOKEN DROP  ;check for parm, drop flag
 @TB1 GET 27513 SUB ;push 0 if 1st 2 chars /K, otherwise non-0
 IFNZ  ;if no /K option..
  ;make sure at least 2 blocks are available, if not restart hpiplos
  @END GET 3777 SUB @BLK GET SUB
  IF<0 "Blocks?" $PRINT 2 RUN ENDIF
  ;compute SYMADR
  SYMADR @BLK GET PUT  ;put symbols in block 0
  FIXADR @BLK GET 2000 ADD PUT ;fixups in block 1
  SYMBOLS #0 PUT ;start out with no labels
  "ZNXT  " 321 PUTSYMBOL   ;indirect NEXT vector
  "ZSPSH " 323 PUTSYMBOL   ;indirect S push
  "ZSPOP " 324 PUTSYMBOL   ;indirect S pop
  "ZRPSH " 325 PUTSYMBOL   ;indirect R push
  "ZRPOP " 326 PUTSYMBOL   ;indirect R pop
  "ZXPSH " 327 PUTSYMBOL   ;indirect X push
  "ZXPOP " 330 PUTSYMBOL   ;indirect X pop
  "ZYPSH " 331 PUTSYMBOL   ;indirect Y push
  "ZYPOP " 332 PUTSYMBOL   ;indirect Y pop
  "ZZPSH " 333 PUTSYMBOL   ;indirect Z push
  "ZZPOP " 334 PUTSYMBOL   ;indirect Z pop
  "ZCOUT " 337 PUTSYMBOL   ;indirect char-out vector
  "ZCHIN " 341 PUTSYMBOL   ;indirect char-in vector
  "ZCRLF " 340 PUTSYMBOL   ;indirect crlf-out vector
  "ZPTWD " 342 PUTSYMBOL   ;indirect word-out vector
  "ZPBFL " 343 PUTSYMBOL   ;indirect string-out vector
  "ZIN   " 346 PUTSYMBOL   ;indirect standard-in vector
  "ZOUT  " 347 PUTSYMBOL   ;indirect standard-out vector
  "ZMINP " 350 PUTSYMBOL   ;indirect MS in vector
  "ZMOUT " 351 PUTSYMBOL   ;indirect MS out vector
  "ISAVE " 475 PUTSYMBOL   ;indirect state-save/-irq vector
  "IREST " 476 PUTSYMBOL   ;indirect state-restore/+irq vector
  "TMRLO " 473 PUTSYMBOL   ;location of timer low (tbg)
  "TMRHI " 474 PUTSYMBOL   ;location of timer high (tbg)
  "TMP1  " 311 PUTSYMBOL   ;temp locations
  "TMP2  " 312 PUTSYMBOL
  "TMP3  " 313 PUTSYMBOL
  "TMP4  " 314 PUTSYMBOL
  "SP    " 301 PUTSYMBOL   ;S stack pointer
  "RP    " 302 PUTSYMBOL   ;R stack pointer
  "XP    " 303 PUTSYMBOL   ;etc
  "YP    " 304 PUTSYMBOL
  "ZP    " 305 PUTSYMBOL
  "BM2A  " 463 PUTSYMBOL   ;address of sign-on string
  "ASENA " 465 PUTSYMBOL   ;auto-start enable if <>0
  "TXTWP " 466 PUTSYMBOL   ;text-was-printed flag
  "PSUBA " 470 PUTSYMBOL   ;patch sub address
  "CHINS " 471 PUTSYMBOL   ;actual chrin sub address
  "CHOUS " 472 PUTSYMBOL   ;actual chrout sub address
  "CON1  " 433 PUTSYMBOL   ;contains -1
  "IENAV " 462 PUTSYMBOL   ;address of int.enable sub
  "ABFLG " 260 PUTSYMBOL   ;8/26/04 alternate boot flag
  "ABVEC " 261 PUTSYMBOL   ;alt boot vector 8/28/04
  "WDENA " 262 PUTSYMBOL   ;watchdog enable
  "WDTMR " 263 PUTSYMBOL   ;watchdog timer
  "WDTOV " 264 PUTSYMBOL   ;watchdog timeout value
 ELSE ;idiot-check if /KEEP and not initialised...
  SYMADR GET IFZ
   "/K error" $PRINT
   2 RUN ;restart hpiplos (quick cleanup..)
  ENDIF
 ENDIF
 FIXUPS #0 PUT  ; clear fixups table
 MLERROR #0 PUT ; reset error flag
 @TB2 Z>S PUT @TB1 Z>S PUT @TL Z>S PUT ;restore def specs
 ADDHEADER      ; add a header for the definition
 @DIPTR GET INC ADDCODE ; add DEF *+1 header
 DO  ; process all source lines....
  #0 ; by default loop when gets to UNTIL
  @DIPTR GET PNUM ": " $PRINT ;display prompt   
  $IN ;get input line, drop any leading LF..
  #0 $GET 12 SUB IFZ $HEAD DROP ENDIF
  $LEN 3 A>=B IFNZ ;if len >= 3 then...
   #0 $GET 52 SUB IFNZ ;if the line isn't a comment
    #0 2 $SLICE "END" $EQUAL $DROP
    IFNZ   ;if 0-2 equal "END"
     ;add line to symbol table...
     @DIPTR GET "END   " PUTSYMBOL
     DROP #1          ;stop looping
    ELSE
     $ML2CODE  ;convert the line to binary
     MLERROR GET 2 SUB IFZ ;if an EQU line then
      MLERROR #0 PUT  ;reset error flag back to zero
     ELSE
      MLERROR GET IFZ ;if no error then
       MLCODE GET ADDCODE  ;write binary to definition
      ELSE
       CRLF "Parse error..." $PRINT
       CRLF $DUP $PRINT CRLF ;print the errant line
       DROP #1     ;stop looping
      ENDIF
     ENDIF
    ENDIF
   ENDIF
  ENDIF
  $DROP   ;drop the input string
 UNTIL ; END entered
 MLERROR GET IFNZ  ;if error
  CONSOLE       ;cancel redirection
  Z>S DROP Z>S DROP  ;remove fixlinks info
 ELSE
  124321 ADDCODE ;add JMP ZNXT,I (hard-coded)
;go thru FIXUPS and adjust lower 6 bits
;if this takes too long will present a problem if
;feeding input into the standard (unbuffered) console,
;use with BACI/PTR or other input with flow-control
  FIXUPS GET IFNZ  ;if there are fixups to do
   "Fixing..." $PRINT CRLF
   #0 FIXUPS GET DEC +DO ;loop thru all
    INDEX GETFIX ; push label and address to fix
    FINDSYMBOL  ;search for it    
    IFZ  ;if not found...
     $PRINT " not found" $PRINT CRLF
     MLERROR #1 PUT
    ELSE
     ;real address on the stack
     ;address to fix under that
     OVER 176000 AND OVER 176000 AND SUB
     OVER 2000 SUB IF<0 DROP #0 ENDIF ;pass for page 0
     IFNZ
      "Page error: " $PRINT $PRINT "  " $PRINT
      SWAP PNUM "--> " $PRINT PNUM CRLF
      MLERROR #1 PUT
     ELSE
      ;if data at address under is not 0,
      ; write low 10 bits of top to address under,
      ; preserving top 5 bits, bit 10 = Z/C
      ;else write number to address under
      OVER GET IFNZ  ;if target <> 0
       DUP 1777 SWAP SUB IF<0  ;if address > 1777
        1777 AND 2000 OR    ;set bit 10, clear 11-15
       ELSE
        1777 AND   ;clear bits 10-15
       ENDIF
       OVER GET
       ; 174000 AND  removed 9/2/02 to fix IO labels
       OR ;combine w/ instruction
      ENDIF
      PUT   ;write data
      $DROP
     ENDIF
    ENDIF
   +LOOP
  ENDIF
  MLERROR GET IFZ FIXLINKS  ;finalize definition
  ELSE Z>S DROP Z>S DROP CONSOLE ;cancel redirect if error
  ENDIF
 ENDIF
ENDIF
END
;
; fold MAIN and everything else into the CREATE definition...
"Folding into CREATE" $PRINT CRLF
"MAIN" $DEFADR DUP DEC GET ;push MAIN word address & link value
"CREATE" $DEFADR DEC SWAP PUT ;wrap CREATE around all subs
"CREATE" $DEFADR INC SWAP PUT ;replace dummy with MAIN call
; end of CREATE source
;
"Done" $PRINT CONSOLE