"Loading CREATE and support" $PRINT CRLF
;
; HP-IPL/OS 0.58B CREATE - normal version
; by Terry Newton, modified 12/1/02 3/10/03 9/6/04
; 9/29/07 - added PRESET to IPL (no change to CREATE)
; 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
; 9/21/02 added /L (/LARGE) option to provide more symbol space
; 11/19/02 removed context markers, alternate hiding technique
;
;----------
OCTAL DEFINE CREATE
XOR END ;XOR will be replaced by MAIN
;
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
;
"Loading MATCHEXT" $PRINT CRLF
DEFINE MATCHEXT
;new extended/dms instructions 9/2/02
;(n) indicates how many words in instruction
;code extra words as oct's or def's
#0 #0  ;temp IMATCH and MLCODE data
IHASH ;hash the string
CASE
= 034107 2D1 100400  ;DIV (2)
= 004415 2D1 104200  ;DLD (2)
= 032003 2D1 104400  ;DST (2)
= 040362 2D1 100200  ;MPY (2)
= 017340 2D1 100020  ;ASL
= 027270 2D1 101020  ;ASR
= 017353 2D1 100040  ;LSL
= 027303 2D1 101040  ;LSR
= 017327 2D1 100100  ;RRL
= 027257 2D1 101100  ;RRR
= 036412 2D1 105746  ;ADX (2)
= 037656 2D1 105756  ;ADY (2)
= 036276 2D1 101741  ;CAX
= 037542 2D1 101751  ;CAY
= 036330 2D1 105741  ;CBX
= 037574 2D1 105751  ;CBY
= 001130 2D1 101744  ;CXA
= 002374 2D1 105744  ;CXB
= 001162 2D1 101754  ;CYA
= 002426 2D1 105754  ;CYB
= 037223 2D1 105761  ;DSX
= 040467 2D1 105771  ;DSY
= 037230 2D1 105760  ;ISX
= 040474 2D1 105770  ;ISY
= 036307 2D1 101742  ;LAX (2)
= 037553 2D1 101752  ;LAY (2)
= 036341 2D1 105742  ;LBX (2)
= 037605 2D1 105752  ;LBY (2)
= 036425 2D1 105745  ;LDX (2)
= 037671 2D1 105755  ;LDY (2)
= 036316 2D1 101740  ;SAX (2)
= 037562 2D1 101750  ;SAY (2)
= 036350 2D1 105740  ;SBX (2)
= 037614 2D1 105750  ;SBY (2)
= 037274 2D1 105743  ;STX (2)
= 040540 2D1 105753  ;STY (2)
= 036323 2D1 101747  ;XAX
= 037567 2D1 101757  ;XAY
= 036355 2D1 105747  ;XBX
= 037621 2D1 105757  ;XBY
= 040207 2D1 105762  ;JLY (2)
= 040357 2D1 105772  ;JPY (2)
= 031110 2D1 105766  ;CBT (3)
= 031121 2D1 105763  ;LBT
= 031122 2D1 105765  ;MBT (3)
= 031130 2D1 105764  ;SBT
= 001470 2D1 105767  ;SFB
= 027644 2D1 105774  ;CBS (3)
= 027664 2D1 105773  ;SBS (3)
= 027665 2D1 105775  ;TBS (3)
= 035522 2D1 105776  ;CMW (3)
= 036106 2D1 105777  ;MVW (3)
;float instructions...
= 003761 2D1 105000  ;FAD (2)
= 033707 2D1 105060  ;FDV (2)
= 036621 2D1 105100  ;FIX
= 031517 2D1 105120  ;FLT
= 024331 2D1 105040  ;FMP (2)
= 002175 2D1 105020  ;FSB (2)
;DMS instructions...
= 024211 2D1 105732  ;DJP (2)
= 030165 2D1 105733  ;DJS (2)
= 030513 2D1 105715  ;JRS (3)
= 000215 2D1 101727  ;LFA
= 001461 2D1 105727  ;LFB
= 006532 2D1 105703  ;MBF
= 012506 2D1 105702  ;MBI
= 035076 2D1 105704  ;MBW
= 007574 2D1 105706  ;MWF
= 013550 2D1 105705  ;MWI
= 036140 2D1 105707  ;MWW
= 000017 2D1 101712  ;PAA
= 001263 2D1 105712  ;PAB
= 000051 2D1 101713  ;PBA
= 001315 2D1 105713  ;PBB
= 000745 2D1 101730  ;RSA
= 002211 2D1 105730  ;RSB
= 001063 2D1 101731  ;RVA
= 002327 2D1 105731  ;RVB
= 024230 2D1 105734  ;SJP (2)
= 030204 2D1 105735  ;SJS (2)
= 020626 2D1 105714  ;SSM (2)
= 001202 2D1 101710  ;SYA
= 002446 2D1 105710  ;SYB
= 024232 2D1 105736  ;UJP (2)
= 030206 2D1 105737  ;UJS (2)
= 000750 2D1 101711  ;USA
= 002214 2D1 105711  ;USB
= 000113 2D1 101726  ;XCA (2)
= 001357 2D1 105726  ;XCB (2)
= 000465 2D1 101724  ;XLA (2)
= 001731 2D1 105724  ;XLB (2)
= 000517 2D1 101722  ;XMA
= 001763 2D1 105722  ;XMB
= 020377 2D1 105720  ;XMM
= 030327 2D1 105721  ;XMS
= 000753 2D1 101725  ;XSA (2)
= 002217 2D1 105725  ;XSB (2)
ENDCASE
MLCODE SWAP PUT
IFNZ IMATCH #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
      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+
  @TB1 GET 27514 SUB ;push 0 if 1st 2 chars /L (/LARGE)
  ;if /L specified then set fixadr to 1/2 allocated...
  IFZ FIXADR @END GET INC @BLK GET SUB 2 DIV PUT
  ;otherwise set fixadr to block 1+
  ELSE FIXADR @BLK GET 2000 ADD PUT ENDIF
  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
;
"Loading PRESET" $PRINT CRLF
;
; PRESET - a general solution to the deferred interrupt problem when
; loading binary code. When run, PRESET disables interrupts, clears
; the overflow flags, and does CLC slot, STF slot for channels 6-57.
; Pretty much what the Preset button does on a HP21MX-E machine, but
; this does not clear the parity error flag... if that happens use
; the actual switch (and fix the machine).
OCTAL CREATE PRESET
GIENA  EQU 461             location of HP-IPL/OS' global int. flag
       CLF 0               disable interrupts
       CLA
       STA GIENA           store 0 in global int. enable for HP-IPL/OS
       LDA STASL           get starting slot
       STA CSLOT           store in current slot
PLOOP  LDA CSLOT           get current slot
       CPA STOSL           compare to stop slot
       JMP PDONE           done, jump from loop
       LDA CLCIN           get clc instruction
       AND K1777
       IOR CSLOT           or with slot#
       STA CLCIN           update clc instruction
       LDA STFIN           get stf instruction
       AND K1777
       IOR CSLOT
       STA STFIN           update stf instruction
CLCIN  CLC 0               clear control
STFIN  STF 0               set flag
       ISZ CSLOT           increment slot
       JMP PLOOP           loop to do next slot
PDONE  CLO                 clear overflow flag
       JMP END             done
CSLOT  OCT 0               current slot
STASL  OCT 6               starting slot
STOSL  OCT 60              end slot + 1
K1777  OCT 177700          all bits set except 0-5
END
;
"Done" $PRINT CONSOLE