; Internal definitions for HP-IPL/OS ; mod for 0.55 12/1/02, mod for 0.58 8/22/04 ; mod for 1.4 12/12/07, mod for 1.6 6/5/10 ; ; These are definitions written in HP-IPL/OS but converted to ; HPASM and included in the 8K build... ; ; $DEFADR returns WA of "DefName", used by several IPL files ; HEADER$ used by WORDS, EXPLAIN etc ; WORDS ; ADDHEADER ---. ; ADDHEADER$ \ ; FIXLINKS Variable/Constant ; ADDMLVAR / ; VARIABLE / ; CONSTANT --' ; ALLOCATE --. ; ZEROBLOCK \ Blocks ; BPUT / ; BGET --' ; ; Note - this IPL file assumes that $DEFADR already exists, ; as in starting with the stock 8K base version. ; ; ADDCODE has been moved to just before blocks so it can be coded ; to protect dictionary, removed if variable support is removed. ; "Loading configurator" $PRINT CRLF OCTAL DEFINE TEMP "Press the appropriate key..." $PRINT CRLF "1) Stock 8K config with 2 blocks" $PRINT CRLF "2) Remove blocks and block support" $PRINT CRLF "3) Remove blocks and constants/variables" $PRINT CRLF "> " $PRINT <>CON CHRIN Y GET PUT ;put 1st 2 chars in TB1 @TB2 Y>S INC GET PUT ;put next 2 chars in TB2 $DROP SDIC DUP IFNZ DROP ENDIF ;uniform output END ;-------------------------------------------------- "Loading HEADER$" $PRINT CRLF OCTAL DEFINE HEADER$ ; takes address on stack and pushes string containing ; name of definition, or [address] if headerless ; New version - does not output extra spaces if ; definition is < 4 characters. #0 ;start out ok OVER @DIC GET SUB IF<0 DROP #1 ENDIF ;if < start of dict, error OVER @BLK GET SUB IF<0 ELSE DROP #1 ENDIF ;if >= end of dict, error OVER 4 SUB GET 24 SWAP SUB ; get # chars and test IF<0 DROP #1 ENDIF ; headerless if > 20 chars OVER DUP #1 SUB GET ;get link DUP IF<0 DROP DROP DROP #1 ELSE ;12/12/07 DUP S>Y DEC SWAP SUB ;dup to Y and test IF<0 DROP #1 ENDIF ; headerless if link < current adr @BLK GET Y>S SUB ; test for end of dict 12/12/07 IF<0 DROP #1 ENDIF ; headerless if link > end of dict ENDIF ;12/12/07 ;removed link follow 12/12/07 IFNZ ;if no header... "[" $STR $CAT "] " $CAT ; string = [address] ELSE ;otherwise.... DUP 3 SUB DUP GET S>X ;start with 4 char string INC GET S>X 4 S>X 3 S>X ;with 1st 4 letters 4 SUB GET 4 SWAP SUB DUP IF<0 ; if more than 4 chars 2CPL #1 SWAP +DO "x" $CAT +LOOP ; add the needed # of x's ELSE ; modified.... return true len + 1 DUP IFNZ ;if less than 4 characters #1 SWAP +DO $TAIL DROP +LOOP ;remove some ELSE DROP ;get rid of intermediate ENDIF ; end mods - above was just DROP ENDIF " " $CAT ;add trailing space ENDIF ;header check END ;-------------------------------------------------- "Loading WORDS" $PRINT CRLF OCTAL DEFINE WORDS #0 S>Z ;init line-length count on Z @DIC GET ; push pointer to stack DO DUP GET IFZ ;if at end of dictionary #1 ;terminate do loop ELSE DUP 4 ADD HEADER$ ;get word name string Z>S $LEN ADD DUP S>Z ;add length to count 114 SWAP SUB IF<0 ;if count > 76 Z>S DROP $LEN S>Z ;count = name length CRLF ;next line ENDIF $PRINT ;print word name 3 ADD GET ;update pointer #0 ;keep looping ENDIF UNTIL CRLF "EOD=" $PRINT DUP PNUM ;print ptr value "FREE=" $PRINT @BLK GET DEC SWAP SUB PNUM ; print free space left in dictionary Z>S DROP ;drop length counter END ; ; ***** Constant and Variable support ***** ; ; 100 set by configurator, if 3 selected (no vars) ; then halt right here... ; DEFINE TEMP 100 GET 3 SUB IFZ CONSOLE "Done" $PRINT ENDIF "TEMP" $DEFADR 4 SUB 0 PUT ;self-deleting definition @USR EOD PUT ;put @USR back to EOD to make "unforgettable" END TEMP ; ;----------------------------------------- "Loading ADDHEADER" $PRINT CRLF ; ; "ADDHEADER$" and "ADDHEADER" ; ADDHEADER$ adds header specified by string on X by ; poking stats in TL/TB1/TB2 and calling ADDHEADER. ; For goofing around at console. ; ADDHEADER (the real one) adds header specified by ; TL/TB1/TB2 as set by TOKEN or ADDHEADER$, sets ; @DIPTR to where ENSEC or *+1 will go. Pushes length ; and length address to Z stack for FIXLINKS to use. ; Length in header left set to zero to avoid corrupting ; dictionary if the rest of the steps are not performed. ; Do not use ADDHEADER from console. ; (defining defs with console cmds might be too scary..) ; OCTAL DEFINE ADDHEADER @TL GET S>Z ;save length to Z @DIPTR ;push address of dict. pointer EOD ;calculate and push End Of Dictionary DUP S>Z ;save initial address to Z INC ;plus one (skip length for now) PUT ;set @DIPTR to position of 1st 2 chars @TB1 GET ;push those chars ADDCODE ;add to dictionary @TB2 GET ;push 2nd 2 chars ADDCODE ;add to dictionary #0 ADDCODE ;add zero link for now END ; "Loading ADDHEADER$" $PRINT CRLF ; OCTAL DEFINE ADDHEADER$ @TL $LEN PUT " " $CAT @TB1 $ADR GET PUT @TB2 $ADR INC GET PUT $DROP ADDHEADER END ; "Loading FIXLINKS" $PRINT CRLF ; ; "FIXLINKS" - pops address and length from Z and writes ; length to initial address, and value of @DIPTR to the ; link address (initial+3) to make the new definition visible. 6/2/10 ; OCTAL DEFINE FIXLINKS #0 ADDCODE Z>S DUP Z>S PUT 3 ADD @DIPTR GET DEC PUT ;leave @DIPTR = EOD + 1 so spurious addcodes ; will not corrupt the dictionary. You should never ever ; count on @DIPTR being valid unless you set it yourself ; or run ADDHEADER first to set it. END ; "Loading ADDMLVAR" $PRINT CRLF ; ; "ADDMLVAR" - adds machine code that pushes exit ; location to stack and exits via NEXT indirect. ; Contains hard coded locations! see below. OCTAL DEFINE ADDMLVAR @DIPTR GET INC ADDCODE ; *+1 @DIPTR GET 3 ADD 1777 AND ;calc adr field DUP 3 SUB IF<0 ;if page boundary violation 3 OVER SUB #1 SWAP +DO #0 ADDCODE +LOOP ; output enough nops to pad DROP 3 ; make offset=3, LDA at ofs 0 ENDIF 62000 OR ADDCODE ; LDA *+3 ; note!!! alter below if z.p. locations change!! 114323 ADDCODE ; JSB 323,I (ZSPSH) 124321 ADDCODE ; JMP 321,I (ZNXT) END ;-------------------------------------------------- "Loading VARIABLE" $PRINT CRLF ; variable define - console only! put outside definitions. ; compiles a definition which pushes the address of ; a location within the definition for variable/array ; storage. Syntax: VARIABLE NAME [SIZE][crlf] ; If size not specified, a single location is used. 6/2/10 OCTAL DEFINE VARIABLE TOKEN ;get desired name of variable definition IFZ ;if name specification found... ADDHEADER ;add header for new definition #1 ;start with size=1 TOKEN ;see if number specified.. IFZ ;if another token present... @ANVAL #0 PUT ;clear ANVAL z.p. variable SDIC ;let SDIC do its thing IFNZ ;if SDIC returned match.. DROP ;drop the console literal push address ENDIF DROP @ANVAL GET ;replace size w/ number at ANVAL ENDIF DUP #1 SUB ;test the number to allocate IF<0 ;if <1 then DROP #1 ;use var length of 1 (support comments!) ENDIF ADDMLVAR ;add machine code to push var and exit @DIPTR GET INC ADDCODE ; *+1 #1 SWAP +DO #0 ADDCODE +LOOP FIXLINKS ; finalize the definition ENDIF ;first token valid END ;-------------------------------------------------- "Loading CONSTANT" $PRINT CRLF ; constant define - console only ; usage: CONSTANT NAME value 6/2/10 OCTAL DEFINE CONSTANT TOKEN ;get next token, name of constant IFZ ;if token.. ADDHEADER ; add header for definition #0 ;temp error flag TOKEN ;get next token, the value of constant IFNZ DROP #1 ELSE ;error if no token, otherwise... SDIC ;sdic, let it convert.. IFZ DROP #1 ELSE ;if not processed, error, otherwise... DUP ;duplicate token address returned by sdic @CLH ;push address of LITRA - console literal handler SUB ;subtract to test IFZ ;if it's a real console handler DROP ;drop the token, value in @ANVAL ELSE ;if some other recognized token was specified @ANVAL SWAP PUT ;put token in @ANVAL - lets you define ;constants equal to the entry point of a definition! ENDIF ENDIF ENDIF IFNZ ;if errorflag <>0 then... "BAD VALUE" $PRINT ;complain Z>S DROP Z>S DROP ;clean up ELSE ;else valid syntax.. constant in @ANVAL ADDMLVAR ;add var push/exit machine code @ANVAL GET ADDCODE ;add actual constant FIXLINKS ;finish up definition ENDIF ENDIF END ; ; ***** Block support ***** ; ; 100 set by configurator, if 2 selected (no blocks) ; then halt right here... ; DEFINE TEMP 100 GET 2 SUB IFZ CONSOLE "Done" $PRINT ENDIF "TEMP" $DEFADR 4 SUB 0 PUT ;self-deleting definition @USR EOD PUT ;put @USR back to EOD to make "unforgettable" END TEMP ; ;-------------------------------------------------- "Loading ALLOCATE" $PRINT CRLF OCTAL DEFINE ALLOCATE ; @END should be set to max hpiplos location ; n ALLOCATE allocates n blocks down from there ; and sets @BLK to start of block 0 002000 MUL @END GET INC 176000 AND SWAP SUB DUP EOD INC SUB IF<0 "NOT ENOUGH FREE MEM" $PRINT DROP ELSE @BLK SWAP PUT ENDIF END ;-------------------------------------------------- "Loading ZEROBLOCK" $PRINT CRLF ; ; "ZEROBLOCK" - pop stack and write 1Kword zeros to ; the specified memory block ; OCTAL DEFINE ZEROBLOCK ; outblock errorchecks already OUTBLOCK #0 1777 +DO #0 MSWOUT +LOOP ENDIF END ;-------------------------------------------------- "Loading BPUT" $PRINT CRLF DEFINE BPUT ;NUM DIM BLOCK BPUT ;WRITES NUM TO ARRAY (DIM,BLOCK) 2000 MUL @BLK GET ADD ;SET COURSE OFFSET ADD ;SET FINE OFFSET DUP @END GET SWAP SUB IF<0 ;if address > last block address "ERROR" $PRINT DROP DROP ;don't do it ELSE SWAP PUT ;DO IT ENDIF END ;-------------------------------------------------- "Loading BGET" $PRINT CRLF DEFINE BGET ;DIM BLOCK BGET ;PUSHES (DIM,BLOCK) TO STACK 2000 MUL @BLK GET ADD ADD ;SET OFFSET GET ;DO IT (no crash-harm if invalid parms) END ;-------------------------------------------------- ; @USR EOD PUT ;put @USR back to EOD to make "unforgettable" @LLP EOD PUT ;set @LLP to EOD for default erase point "Done" $PRINT CONSOLE