; More definitions for HP-IPL/OS. Contents... ; $EQUAL $SLICE $TRIM ABSOUT PTZERO MARKCON SETCON GLOBAL ; DUMP PDEF EXPLAIN FORGET ERASE FETCH STASH HIDEDUPS ; RENAME DELETE UNDELETE WHEREIS LOAD ; mod 1/4/04 for 0.57 8/23/04 for 0.58 (configurator) ; 12/8/07 bugfixes to FETCH DUMP UNDELETE, tweaks to PDEF STASH DELETE ; 6/5/10 for 1.6 - ERASE erases from last load point ( " $PRINT #1 ;default selection DO CHRIN 60 SUB ;get char, convert to number CASE = 1 #1 ;terminate if 1 = 2 DROP 2 #1 ;select 2 and terminate if 2 = 3 DROP 3 #1 ;select 3 and terminate if 3 = 4 DROP 4 #1 ;select 4 and terminate if 4 DEFAULT ;not 1 2 3 or 4 print bs and keep looping 10 PCHR #0 ENDCASE UNTIL CRLF CASE ;463 contains address of sign-on message = 2 @END 37777 PUT @BLK 34000 PUT 463 GET 6 ADD DUP 30466 PUT INC 45440 PUT "Configured to 16K" $PRINT = 3 @END 33777 PUT @BLK 30000 PUT 463 GET 6 ADD DUP 30466 PUT INC 45440 PUT "Configured to 16K w/himem" $PRINT = 4 @END 67777 PUT @BLK 60000 PUT 463 GET 6 ADD DUP 31462 PUT INC 45440 PUT "Configured to 32K w/himem" $PRINT ENDCASE CRLF END <>CON TEMP >Y $LEN Y>>X SUB IFZ ;if lengths are equal.. #1 ;start out equal #0 $LEN DEC +DO ;loop thru each char DUP IFNZ ;only check if necessary! INDEX $GET ;get byte from string X>>Y INDEX $GET Y>>X ;get byte from string before that SUB IFNZ DROP #0 ENDIF ;compare, if not equal reset ENDIF +LOOP ELSE ;if lengths are not equal #0 ;strings not equal ENDIF $DROP ; drop top string END ;-------------------------------------------------- "Loading $SLICE" $PRINT CRLF DEFINE $SLICE ; usage: start end $SLICE - pushes substring ; leaves original string on X (indexes start at 0) "" +DO X>>Y INDEX $GET Y>>X $APPEND +LOOP END ;-------------------------------------------------- "Loading $TRIM" $PRINT CRLF DEFINE $TRIM ; remove extra spaces from string DO ;trailing spaces $LEN DEC $GET 40 SUB IFZ $TAIL DROP #0 ELSE #1 ENDIF UNTIL DO ;leading spaces #0 $GET 40 SUB IFZ $HEAD DROP #0 ELSE #1 ENDIF UNTIL END ;-------------------------------------------------- "Loading ABSOUT" $PRINT CRLF ; ; fromAdr toAdr ABSOUT - outputs ABS binary to MS out ; ex: 100 17777 ABSOUT to encode memory from 100 to 17777. ; NOTE! Does not add final 0's so multiple ranges can be ; written to one file, use PTZERO to end the file. ; OCTAL DEFINE ABSOUT #0 S>Z ;record counter on Z DUP S>Y ;copy end address to Y to check for last block #0 S>X ;checksum on X +DO ;for index = start address to end address Z>S DUP S>Z ;copy record counter to stack IFZ ;if zero then start of new block... Y>S DUP S>Y ;get end address INDEX ;get current address X>S DROP ;discard prev checksum DUP S>X ;copy address to checksum SUB INC ;sub/inc to get # words left DUP ;save to use in a bit 33 SUB ;subtract 33 oct to see if incomplete IF<0 ;if incomplete block leave #left on stack ELSE ;else DROP ; don't need #words left 33 ; instead do 33 octal words ENDIF Z>S DROP DUP S>Z ;copy record count to Z MSBOUT ;output record count to mass storage #0 MSBOUT ;write 0 pad byte INDEX MSWOUT ;write two byte starting address ENDIF INDEX GET ;get data at current address DUP MSWOUT ;write to mass storage X>S ADD DUP S>X ;add data to checksum and duplicate Z>S DEC DUP S>Z ;decrement record counter IFZ ;if last word... MSWOUT ; write checksum ELSE DROP ;else discard it ENDIF +LOOP X>S DROP ;discard checksum Y>S DROP ;discard last address Z>S DROP ;discard record counter END ;--------------------------------------------- "Loading PTZERO" $PRINT CRLF ; ; PTZERO - writes 20 zero bytes to MS output ; OCTAL DEFINE PTZERO #1 24 +DO #0 MSBOUT +LOOP END ;--------------------------------------------- "Loading MARKCON" $PRINT CRLF OCTAL DEFINE MARKCON ; ; Defines a context marker, usage: MARKCON context# ; Anything afterwards (until GLOBAL marker) is visible ; only when SETCON context# is used. Use SETCON 0 ; to hide all contexts, any non-existing # will do. ; Note - only one context can be visible at a time! ; Name of context marker = "~" ; @ANVAL #0 PUT TOKEN IFNZ "Specify context" $PRINT ELSE SDIC IFZ "Invalid context" $PRINT ELSE DROP ;don't need address any more @ANVAL GET IFZ "Can't be 0" $PRINT ELSE "~" ADDHEADER$ @ENSEC ADDCODE @RTSEC ADDCODE @ANVAL GET ADDCODE FIXLINKS ENDIF ENDIF ENDIF END ; "Loading SETCON" $PRINT CRLF OCTAL DEFINE SETCON ; ; searches through all markers produced by MARKCON ; and sets all links to the global marker following it, ; except for the matching one which is set to drop thru. ; EOD point treated as global marker in case omitted ; @ANVAL #0 PUT TOKEN IFNZ "Specify context" $PRINT ELSE SDIC IFZ "Invalid context" $PRINT ELSE DROP @USR GET ;start at user portion of dictionary DO ;loop until done.. DUP GET ;get length at pointer address IFZ ;if length=0 then #1 ; end of dictionary, terminate ELSE DUP INC GET 77040 SUB ;77040="~ " IFZ ;if it's a context marker DUP 6 ADD GET @ANVAL GET SUB IFZ ;if target context DUP 3 ADD DUP 4 ADD PUT ;set to normal end ELSE ;find global mark.. (or eod) DUP ;start at current location DO ;until found or end 3 ADD GET ;point to next def DUP GET IFZ #1 ELSE DUP GET 2 SUB IFNZ ;if not len 2 #0 ;keep looking ELSE DUP INC GET 77176 SUB IFNZ ;if not "~~" #0 ;keep looking ELSE #1 ;found! ENDIF ENDIF ENDIF UNTIL ; matching global or end at top of stack ; current pointer under that, so set context marker ; link to point to global link OVER ;push current pointer 3 ADD ;point to link OVER ;push location of global/end PUT ;write to link location DROP ;discard global/end pointer ENDIF ;target context ENDIF ;context marker 3 ADD GET #0 ;keep searching ENDIF ;eod UNTIL DROP ;drop the pointer ENDIF ;valid parm test ENDIF ;existing parm test END ; "Loading GLOBAL" $PRINT CRLF OCTAL DEFINE GLOBAL ; ; Defines a marker used by SETCON to define the ; end of context definitions ; Name of global marker = "~~" ; "~~" ADDHEADER$ @ENSEC ADDCODE @RTSEC ADDCODE FIXLINKS END ;-------------------------------------------------- "LOADING DUMP" $PRINT CRLF ; ;fromAdr toAdr DUMP - dumps memory in octal/ascii ; OCTAL DEFINE DUMP OCTAL ;dump in octal format INC ;tired of listing as a bug! include the toAdr location S>Y S>X DO X>S DUP S>X CRLF $STR $HEAD DROP $PRINT ":" $PRINT ; to all fit! #0 7 +DO X>S DUP S>X INDEX ADD GET PNUM +LOOP #0 7 +DO X>S DUP S>X INDEX ADD GET ;again for text #0 #1 +DO ;do high and low characters INDEX IFZ DUP 177400 AND 400 DIV ;1st time thru ;isolate high byte, put in low byte, leave ;double-char on stack for next pass ELSE 377 AND ENDIF ;second time thru isolate low #0 OVER 40 SUB IF<0 DROP #1 ENDIF ;reject < 32 OVER 177 SWAP SUB IF<0 DROP #1 ENDIF ;reject > 127 IFZ PCHR ELSE "." $PRINT DROP ENDIF +LOOP +LOOP Y>S DUP S>Y X>S 10 ADD DUP S>X SUB DUP IF<0 DROP #0 ENDIF WHILE Y>S X>S DROP DROP CRLF END ;-------------------------------------------------- "LOADING PDEF" $PRINT CRLF ; ; WordAdr PDEF - lists definition at WordAdr ; OCTAL DEFINE PDEF OCTAL ;output numbers in octal DUP HEADER$ ;get header string DUP GET @ENSEC SUB IFNZ ; if (address) <> ENSEC.. "Can't list " $PRINT $PRINT ;complain ELSE ;otherwise list it, address still on stack.. #0 $GET 133 SUB ;check to see if headerless ("[") IFZ ;if headerless... @BLK GET S>Y ;forced end if end of dictionary ELSE ;if not headerless... DUP DEC GET S>Y ;put link address on Y to check ENDIF "OCTAL DEFINE " $PRINT $PRINT ;print DEFINE line " ;ENSEC=" $PRINT DUP PNUM CRLF ;and commented address #0 S>Z ;init line length on Z ;main loop.... DO INC DUP Y>S DUP S>Y SUB IF<0 ;if adr < link.. DUP GET ;get data at next address ;check for literal numbers and strings.. @STRING SUB IFZ ;if string... INC DUP GET DUP S>Z ;get word length, dup to Z #1 SWAP +DO INC DUP GET S>X +LOOP ;build string Z>S S>X ;complete string with word count ;code to print CRLF if req and update line len 74 $LEN 3 ADD Z>S ADD DUP S>Y SUB IF<0 CRLF $LEN 3 ADD S>Z Y>S DROP ELSE Y>S S>Z ENDIF 42 PCHR $PRINT 21040 PWRD ;print '"string" ' #0 ;keep going ELSE DUP GET @LITERAL SUB IFZ ; if number... ;code to print CRLF if req and update line len 74 7 Z>S ADD DUP S>Y SUB IF<0 CRLF 7 S>Z Y>S DROP ELSE Y>S S>Z ENDIF INC DUP GET PNUM #0 ; print # and keep going ELSE DUP GET @RTSEC SUB IFZ ; if RTSEC (END) "END" $PRINT CRLF #1 ;print END and stop ELSE DUP GET ; get address to decode... HEADER$ ; get header name of address ; string to print on X, line length on Z 74 $LEN Z>S ADD DUP S>Y ; max len, new length on stack and dup'd to Y SUB ;max - new IF<0 ;if 60-len < 0... CRLF $LEN S>Z Y>S DROP ;new Z, drop old len ELSE Y>S S>Z ;else Z=new line length ENDIF $PRINT ;print string #0 ;keep going ENDIF ; RTSEC ENDIF ; number ENDIF ; string ELSE ; if = or past next link.. "END" $PRINT CRLF #1 ;print END and stop ENDIF ; next link test UNTIL ; loop until finished Z>S DROP ; drop the line length counter Y>S DROP ; drop the link address ENDIF ; ENSEC test DROP ; drop the pointer address END ;end of definition ;-------------------------------------------------- "LOADING EXPLAIN" $PRINT CRLF OCTAL DEFINE EXPLAIN ; ; EXPLAIN DefName - lists definition ; TOKEN IFNZ ;if no next token "Need name" $PRINT ELSE ;otherwise SDIC ; search dictionary IFZ ; if not found "Not found" $PRINT ELSE PDEF ; try to list the definition ENDIF ENDIF END ;-------------------------------------------------- "Loading FORGET" $PRINT CRLF OCTAL DEFINE FORGET ;this replaces the existing FORGET command ;Now supports both original syntax and modified TOKEN IFNZ ; if no parm, forget the last thing... @USR GET GET IFZ "Nothing to forget" $PRINT ELSE @USR GET ;get pointer DO DUP 3 ADD GET GET ;get link then contents IFZ ;if link points to end (0) #1 ;stop ELSE 3 ADD GET #0 ;walk the chain and keep going ENDIF UNTIL DUP 4 ADD HEADER$ "Forget " $PRINT $PRINT "? " $PRINT CHRIN "Y" $HEAD $DROP SUB CRLF IFNZ DROP ELSE #0 PUT "Done" $PRINT ENDIF ENDIF ELSE SDIC IFZ @TB1 GET PWRD @TB2 GET PWRD " not found" $PRINT ELSE DUP @USR GET SUB IF<0 "Not allowed" $PRINT DROP ELSE "Forget " $PRINT DUP HEADER$ $PRINT "and everything after it? " $PRINT CHRIN "Y" $HEAD $DROP SUB CRLF IFNZ DROP ELSE 4 SUB #0 PUT "Done" $PRINT ENDIF ENDIF ENDIF ENDIF END ;-------------------------------------------------- "Loading ERASE" $PRINT CRLF ; ; "ERASE" - prompts to erase from last load point ; 6/3/10 requires v1.6 kernel with @LLP variable ; OCTAL DEFINE ERASE @LLP GET DUP IFZ DROP ELSE @TL OVER GET PUT ;get length @TB1 OVER INC GET PUT ;get 1st 2 chars of name @TB2 SWAP INC INC GET PUT ;get next 2 chars of name SDIC IFNZ "Erase from " $PRINT HEADER$ $PRINT "(Y/N)? " $PRINT CHRIN 131 SUB IFZ @LLP GET #0 PUT CRLF "Done" $PRINT ENDIF ENDIF ENDIF END ;-------------------------------------------------- "Loading FETCH" $PRINT CRLF ; ; "FETCH" - pop stack and load hpiplos source code ; from that memory block. Code should end with CONSOLE. ; OCTAL DEFINE FETCH DUP 20 SWAP SUB IF<0 "Error" $PRINT DROP ELSE INBLOCK MS ;make prints go to spec'd mem block PDEF CRLF ;print definition and extra crlf "CONSOLE" $PRINT CRLF ;terminate the source CONSOLE ; and our redirection too MS_RESTORE ENDIF DROP ENDIF END ;-------------------------------------------------- "Loading HIDEDUPS" $PRINT CRLF ; ; HIDEDUPS name - hides all occurrences of name ; except for last by making dup names = " " ; OCTAL DEFINE HIDEDUPS TOKEN IFNZ "HIDEDUPS WordName" $PRINT ELSE SDIC IFZ "Not found" $PRINT ELSE ;name specs in @TL,@TB1,@TB2 ;ensec adr on stack "Hide dup " $PRINT DUP HEADER$ $PRINT "words? " $PRINT CHRIN "Y" $HEAD $DROP SUB IFZ 5 SUB ;where to stop minus 1 @DIC GET ; push start of dictionary DO ;look for matches... OVER OVER ;push stop adr, current pointer SUB ;replace with stop - current IF<0 #1 ELSE ;if past stop adr, stop, else.. DUP GET @TL GET SUB IFZ ;if length the same DUP INC GET @TB1 GET SUB IFZ ; and 1st two DUP INC INC GET @TB2 GET SUB IFZ ; and last two ;it's a dup, get rid of it... (by making name=" ") DUP #1 PUT ;length = 1 DUP INC 20040 PUT DUP INC INC 20040 PUT ;name = spaces CRLF "Done" $PRINT ENDIF ENDIF ENDIF 3 ADD GET ;point to next entry #0 ;keep looking ENDIF UNTIL DROP ;drop dict pointer ENDIF DROP ;drop stop addr ENDIF ENDIF END ; ;-------------------------------------------------- "Loading RENAME" $PRINT CRLF ; ; RENAME wordname newname - renames definition ; OCTAL DEFINE RENAME TOKEN IFNZ "RENAME WordName NewName" $PRINT ELSE SDIC IFZ "Not found " $PRINT TOKEN DROP ELSE TOKEN IFNZ "Need NewName" $PRINT DROP ELSE 4 SUB DUP @TL GET PUT INC DUP @TB1 GET PUT INC @TB2 GET PUT ENDIF ENDIF ENDIF END ;-------------------------------------------------- "Loading DELETE" $PRINT CRLF ; ; DELETE name - "deletes" a definition by naming to " " ; OCTAL DEFINE DELETE TOKEN IFNZ "DELETE WordName" $PRINT ELSE SDIC IFZ "Not found" $PRINT ELSE "Delete " $PRINT DUP HEADER$ $PRINT "? " $PRINT CHRIN "Y" $HEAD $DROP SUB IFNZ DROP ELSE 4 SUB DUP #1 PUT INC DUP 20040 PUT INC 20040 PUT CRLF "Done" $PRINT ENDIF ENDIF ENDIF END ;-------------------------------------------------- "Loading UNDELETE" $PRINT CRLF ; ; UNDELETE - finds deleted words and prompts to undelete, ; when confirmed prompts for name to make accessable again ; OCTAL DEFINE UNDELETE @DIC GET ;push start of dictionary DO DUP GET IFNZ ;if not end of dict DUP GET #1 SUB IFZ ;if len=1 DUP INC GET 20040 SUB IFZ ;if spaces "Found..." $PRINT CRLF DUP 4 ADD OVER 3 ADD GET DUMP ;display "word" CRLF "UnDelete?" $PRINT CHRIN CRLF 131 SUB IFZ ;if yes... "Name: " $PRINT $IN $LEN IFZ "What?" $PRINT ELSE DUP $LEN PUT ;set length DUP INC $ADR GET PUT ;set first 2 chars DUP INC INC $ADR INC GET PUT ;set next 2 chars ENDIF $DROP ;input string #1 ;terminate loop after undeleting or no name ELSE #0 ;keep looping if Y wasn't pressed ENDIF ELSE #0 ;keep looping if not spaces ENDIF ELSE #0 ;keep looping if not len 1 ENDIF ELSE #1 ;terminate if eod ENDIF SWAP 3 ADD GET SWAP ;update pointer on stack UNTIL DROP END ;-------------------------------------------------- "Loading WHEREIS" $PRINT CRLF ; ; WHEREIS DefName - displays Word Address and memory ; occupied by a dictionary word (definition) ; OCTAL DEFINE WHEREIS TOKEN IFNZ "What?" $PRINT ELSE SDIC IFZ "Not found" $PRINT ELSE DUP DUP "Word address = " $PRINT PNUM CRLF "Occupies " $PRINT 000004 SUB PNUM "to " $PRINT DEC GET DEC PNUM ENDIF ENDIF END ;---------------------------------------------------- "Loading LOAD" $PRINT CRLF ; ; LOAD - like 4000 "(loading from sub " $PRINT DUP PNUM 4051 PWRD CRLF ENDCASE DROP