ASMB,A,L,B * HEWLETT PACKARD INTERPRETIVE PROGRAMMING LANGUAGE / OPERATING SYSTEM * HP-IPL/OS 8K V1.6 STAND ALONE CODE * (C)2002-2010 ROBERT SHANNON / TERRY NEWTON LAST MOD 6/9/10 * ORG 2 JMP *+1,I DEF BOOT HLT 4 HLT 5 * default interrupt table... (no actions) NOP * 6 NOP * 7 NOP * 10 NOP * 11 NOP * 12 NOP * 13 NOP * 14 NOP * 15 NOP * 16 NOP * 17 NOP * 20 NOP * 21 NOP * 22 NOP * 23 NOP * 24 NOP * 25 * * 100-177 available for IPL variables * 200-257 free in the kernel but reserved for options * * GLOBAL VARIABLES IN PAGE ZERO * * new for 0.58... 8/28/04 ORG 000260B ABFLG OCT 0 * alt boot flag, to determine if timeout occured ABVEC DEF ABOOT * alternate bootup path, sets ABFLG to 1 WDENA OCT 0 * watchdog enabled if not 0 (if TBG code present) WDTMR OCT 0 * watchdog timer ("next" clears) WDTOV OCT 62 * default 5 seconds before reset STEP OCT 1 * step value for +LOOP * * watchdog is operative only when TBG word !100MS is active * no WD functionality in kernal except to clear it. * * new kernal vars... 1/4/04 ORG 000266B DFCIN DEF CHRIN * default input vector, ZCIN/ZIN set to this DFCOT DEF CHROT * default output vector, ZCOUT/ZOUT set to this * * TBG BACI etc self-patching drivers store slot numbers in 270-277 * Values set by IPL's as they are loaded, and saved by SYSALL etc * ORG 000300B * * do not alter location of variables once usage begins! * many ipl programs refer to the absolute location. * IOP OCT 000500 * IO BUFFER POINTER (500-617) SP OCT 000620 * SYSTEM STACK POINTER (620-777) RP OCT 001000 * RETURN STACK POINTER (1000-1177) XP OCT 001200 * X STACK POINTER (1200-1377) YP OCT 001400 * Y STACK POINTER (1400-1577) ZP OCT 001600 * Z STACK POINTER (1600-1777) IR OCT 000000 * INSTRUCTION REGISTER CA OCT 000000 * CODE ADDRESS REGISTER WA OCT 000000 * WORD ADDRESS REGISTER TMP1 OCT 000000 * TEMP REGISTER 1 TMP2 OCT 000000 * TEMP REGISTER 2 TMP3 OCT 000000 * TEMP REGISTER 3 TMP4 OCT 000000 * TEMP REGISTER 4 TL OCT 000000 * TOKEN LENGHT REGISTER TB1 OCT 000000 * TOKEN BUFFER 1 TB2 OCT 000000 * TOKEN BUFFER 2 DISRA DEF DUMMY * location of dummy sub (was status) * * CROSS PAGE LINKAGE ADDRESSES IN PAGE ZERO * ZNXT DEF NEXT * LINK TO NEXT ZRUN DEF RUN * LINK TO RUN ZSPSH DEF SPUSH * LINK TO SPUSH ZSPOP DEF SPOP * LINK TO SPOP ZRPSH DEF RPUSH * LINK TO RPUSH ZRPOP DEF RPOP * LINK TO RPOP ZXPSH DEF XPUSH * push to X stack ZXPOP DEF XPOP * pop from X stack ZYPSH DEF YPUSH * push to Y stack ZYPOP DEF YPOP * pop from Y stack ZZPSH DEF ZPUSH * push to Z stack ZZPOP DEF ZPOP * pop from Z stack ZW2A DEF W2ASC * word to ascii ZA2W DEF ASC2W * ascii to word ZCOUT DEF CHROT * char output (console out vector) ZCRLF DEF CRLF * print crlf (will go thru ZCOUT) ZCHIN DEF CHRIN * char input (console in vector) ZPTWD DEF PTWD * print word (will go thru ZCOUT) ZPBFL DEF PBFL * print string (will go thru ZCOUT) ZPTRI DEF PTRIN * get char from papertape reader ZPTPO DEF PTPOT * send char to papertape punch ZIN DEF CHRIN * redirectable input linkage ZOUT DEF CHROT * redirectable output linkage ZMINP DEF PTRIN * redirectable mass storage input ZMOUT DEF PTPOT * redirectable mass storage output DBGVE OCT 0 * for debugger if present * BEGOD DEF CONSA * BEGINNING OF DICTIONARY STRPT OCT 0 * gp string pointer * TTYCH OCT 11 * TTY channel PTPCH OCT 13 * PTP channel PTRCH OCT 12 * PTR channel * * ASCII<->NUMBER CONVERSION VARIABLES * ANBYA OCT 0 * POINT TO ASCII DIGITS (START AT END, 1'S) ANVAL OCT 0 * ASC2W OUTPUT VALUE W2FLG OCT 0 * FOR W2ASC, BIT 0 SUPPRESS LEADING 0'S * BIT 1 CONVERT >32768 AS MINUS W2AIN OCT 0 * MACHINE NUMBER TO CONVERT WITH W2ASC W2OUT OCT 0,0,0,0,0,0,0,0 * W2ASC OUTPUT BUFFER, UP TO 16 DIGITS OCT 0,0,0,0,0,0,0,0 W2OUA DEF W2OUT * BEGINNING OF OUTPUT BUFFER ANMUA DEF ANMUT * BEGINNING OF MULTIPLIER TABLE ANRVA DEF ANRAD * BEGINNING OF RADIX VARIABLES W2LEN OCT 0 * W2ASC LEAVES NUMBER LENGTH HERE * THESE MUST CHANGE TO CHANGE CONVERSION RADIX... ANRAD DEC 8 * CONVERSION RADIX (2=BIN, 8=OCT, 10=DEC) CHOF2 OCT 177770 * 65536-RADIX ANMUE DEF ANMUT+5 * ADDRESS OF 1 MULTIPLIER ANMUT OCT 100000 * MULTIPLY TABLE FOR W2ASC OCT 10000 OCT 1000 * OCTAL TABLE OCT 100 OCT 10 OCT 1 OCT 0,0,0,0,0,0,0,0,0,0 * UP TO 16 ENTRIES IF BASE 2 * * CONSTANTS, VARIABLES, AND POINTERS * CON1 OCT 177777 * -1(10) OCT 0 * not used but reserved CON4 OCT 000614 * END OF IO BUFFER CON5 OCT 000500 * START OF IO BUFFER STOP OCT 000620 * START OF SYSTEM STACK SLIM OCT 000777 * LIMIT OF SYSTEM STACK RTOP OCT 001000 * START OF RETURN STACK RLIM OCT 001177 * LIMIT OF RETURN STACK XTOP OCT 001200 * START OF X STACK XLIM OCT 001377 * LIMIT OF X STACK YTOP OCT 001400 * START OF Y STACK YLIM OCT 001577 * LIMIT OF Y STACK ZTOP OCT 001600 * START OF Z STACK ZLIM OCT 001677 * LIMIT OF Z STACK DTOP DEF DIC00 * beginning of dictionary DUSER DEF DICND * beginning of user definitions DLIM OCT 014000 * end of dictionary, start of free blocks ENDOM OCT 017777 * end of HPIPLOS memory CBIIR DEF OI0 * Cold-boot IR/WA value WBIIR DEF OI7 * Warm-boot IR/WA value WBVEC DEF WBOOT * Address of warm-boot DEFPR OCT 037440 * "? " PROMPT GIENA OCT 0 * Global Interrupt Enable 0 = no ints IENAV DEF IENAS * Interrupt Enable Vector BM2A DEF BM2 * location of boot message PRMPT OCT 037440 * current prompt ASENA OCT 1 * if this word = 0 autostart does not occur TXTWP OCT 1 * text-was printed flag, avoids double-spacing DIPTR DEF DICND+1 * Dictionary Pointer (+1 6/3/10) PSUBA DEF PIOCS * address of patch subroutine CHINS DEF CHRIN * (non-changing) location of CHRIN sub CHOUS DEF CHROT * (non-changing) location of CHROT sub TMRLO OCT 0 * real-time counter TMRHI OCT 0 ISAVE DEF ISAVS * state save/restore subroutines IREST DEF IRESS * last word before keyboard buffer... OCT 40 * a single space for the cio code ************ main code starts here *********************************** ORG 002000B * CODE STARTS AT 1K BOUNDRY BOOT JMP CBOOT * COLD START ENTRY POINT * v0.54 moved this up front to make MTVIEW much faster * MTGEN modified to write 2000-eod first then all the other stuff BM1 OCT 000013 * 11 WORDS LONG (including crlf) BM2 OCT 6412 * Start with CRLF ASC 10,HP-IPL/OS 8K V1.6 DUMMY NOP * a dummy ISR... JMP DUMMY,I * constants... CON2 OCT 000177 * LOW SEVEN BIT MASK EOL OCT 006412 * CR, LF SPCHR OCT 020040 * ASCII SPACE, SPACE SPBSP OCT 020010 * ASCII SPACE, BACKSPACE CNST2 OCT 2 * a 2 CMD1 OCT 120000 * TTY OUTPUT COMMAND CMD2 OCT 160000 * TTY INPUT COMMAND CMD3 OCT 110000 * PUNCH OUTPUT COMMAND * state save subroutines for use by ISR's.. * save disables ints until restore called - only one level ISAVS NOP CLF 0 STA SAVEA STB SAVEB CLA STA SAVEE STA SAVEO SEZ ISZ SAVEE SOC ISZ SAVEO JMP ISAVS,I IRESS NOP CLE LDA SAVEE SZA CME CLO LDA SAVEO SZA STO LDA SAVEA LDB SAVEB STF 0 JMP IRESS,I SAVEA OCT 0 SAVEB OCT 0 SAVEE OCT 0 SAVEO OCT 0 * * Interrupt Enable Subroutine * IENAS NOP STA IENSV * save A LDA GIENA * get global interrupt flag SZA * skip if zero STF 0 * if non-zero enable interrupts LDA IENSV * restore A JMP IENAS,I * return from sub IENSV OCT 0 * place to save A reg * * Paper-tape I/O routines * PTPOT NOP * punch character LDB CMD3 PTPP1 OTB 13B AND C377 PTPP2 OTA 13B PTPP3 STC 13B,C PTPP4 SFS 13B JMP *-1 PTPP5 CLC 13B * 9/2/07 added CLC and new punch patch CLB * 8/23/04 STB WDTMR * clear watchdog after any punch JMP PTPOT,I C377 OCT 377 * upper byte clear * PTRIN NOP * read character CLB * 8/23/04 STB WDTMR * clear watchdog before PT read RDRP1 STC 12B,C RDRP2 SFS 12B JMP *-1 RDRP3 LIA 12B RDRP4 CLC 12B * 12/4/07 removed ,C from LIA, added CLC AND C377 JMP PTRIN,I * * Patch I/O channels * PIOCH NOP LDA TTYPL * get TTY patch list LDB TTYCH * get TTY channel JSB PIOCS * patch it LDA PTPPL * get punch patch list LDB PTPCH * get punch channel JSB PIOCS * patch it LDA PTRPL * get reader patch list LDB PTRCH * get reader channel JSB PIOCS * patch it JMP PIOCH,I * patch sub... address of patch list in A, channel in B PIOCS NOP STA TMP1 * list pointer STB TMP2 * save channel PIOCL LDB TMP1,I * get patch address SZB,RSS * skip if not zero JMP PIOCS,I * if end of list exit sub LDA 1,I * get instruction at patch address AND C1777 * clear low 6 bits IOR TMP2 * or with new channel STA 1,I * put modified instruction back ISZ TMP1 * increment list pointer JMP PIOCL * loop to patch next address * Patch-point lists.... PTPPL DEF *+1 DEF PTPP1 DEF PTPP2 DEF PTPP3 DEF PTPP4 DEF PTPP5 * 9/2/07 OCT 0 PTRPL DEF *+1 DEF RDRP1 DEF RDRP2 DEF RDRP3 DEF RDRP4 * 12/4/07 OCT 0 TTYPL DEF *+1 DEF TTYP1 DEF TTYP2 DEF TTYP3 DEF TTYP4 DEF TTYP5 DEF TTYP6 DEF TTYP7 DEF TTYP8 DEF TTYP9 * 12/4/07 DEF TTYPA * 12/4/07 OCT 0 C1777 OCT 177700 * lower 6 bits clear * * CONSOLE I/O ROUTINES * CHROT NOP * LINKAGE STA TXTWP * set text-was-printed flag LDB CMD1 * GET TTY OUTPUT COMMAND TTYP1 OTB 11B * SET OUTPUT MODE AND CON2 * AND WITH 7 BIT MASK TTYP2 OTA 11B * SEND CHAR TO INTERFACE TTYP3 STC 11B,C * SEND CHAR TO CONSOLE TTYP4 SFS 11B * INTERFACE DONE? JMP *-1 * NO, WAIT TILL DONE TTYP9 CLC 11B * 12/4/07 CLB * 8/23/04 STB WDTMR * clear watchdog after any print JMP CHROT,I * RETURN FROM CHROT * CHRIN NOP * LINKAGE LDB CMD2 * GET TTY INPUT COMMAND TTYP5 OTB 11B * SET INPUT MODE TTYP6 STC 11B,C * START TTY INTERFACE TTYP7 SFS 11B * GOT CHAR FROM CONSOLE? JMP *-1 * NO, KEEP CHECKING TTYP8 LIA 11B * GET CHAR FROM INTERFACE TTYPA CLC 11B * 12/4/07 AND CON2 * AND WITH 7 BIT MASK CLB * 8/28/04 STB WDTMR * clear watchdog after any char input JMP CHRIN,I * RETURN FROM CHRIN * PTWD NOP * LINKAGE STA PTWDT * SAVE WORD FOR IN A BIT ALF,ALF * SWAP BYTES AND C377 * Zero high byte JSB ZCOUT,I * SEND FIRST CHAR IN WORD LDA PTWDT * GET ORIGINAL WORD AND C377 * Zero high byte JSB ZCOUT,I * SEND SECOND CHAR IN WORD JMP PTWD,I * RETURN FROM PTWD PTWDT OCT 0 * TEMP WORD SAVE * PBFL NOP * LINKAGE CMA,INA * 2'S COMPLEMENT A REG STA TMP2 * SAVE STRING COUNT STB TMP3 * SAVE STRING POINTER PBFL1 LDA TMP3,I * GET WORD FROM STRING JSB PTWD * PRINT WORD ISZ TMP3 * BUMP ADDRESS POINTER ISZ TMP2 * BUMP COUNT, DONE? JMP PBFL1 * NO, GET NEXT WORD JMP PBFL,I * RETURN FROM PBFL * CRLF NOP * LINKAGE LDA EOL * GET CR, LF WORD JSB PTWD * SEND WORD TO CONSOLE JMP CRLF,I * RETURN FROM CRLF * SPACE NOP * LINKAGE LDA SPCHR * GET SPACE CHAR JSB ZCOUT,I * SEND IT TO THE CONSOLE JMP SPACE,I * RETURN FROM SPACE * NLINE NOP * LINKAGE LDA PRMPT * GET COMMAND LINE PROMPT JSB PTWD * SEND IT TO THE CONSOLE JMP NLINE,I * RETURN FROM NLINE * * Reset redirection to console, set MS redirection to papertape * CNSOL NOP LDA ZCHIN * get address of console in sub STA ZIN * save to input vector LDA ZCOUT * get address of console out sub STA ZOUT * save to output vector LDA ZPTRI * get address of PTRIN STA ZMINP * save to MS input vector LDA ZPTPO * get address of PTPOT STA ZMOUT * save to MS output vector JMP CNSOL,I * * Reset just console redirection without affecting MS * 10/6/07 for v1.2, called by <>CON * RJCON NOP LDA ZCHIN * get address of console in sub STA ZIN * save to input vector LDA ZCOUT * get address of console out sub STA ZOUT * save to output vector JMP RJCON,I * * STACK SUBROUTINES * * PUSH PUSH A REG ONTO STACK AT (B REG) * A = DATA, B = CURRENT STACK POINTER * PUSH NOP * LINKAGE STA 000001B,I * STORE A TO CURRENT STACK INB * INCREMENT STACK POINTER JMP PUSH,I * RETURN * * POP POP STACK AT (B REG) INTO A REG * A = DATA, B = CURRENT STACK POINTER * POP NOP * LINKAGE ADB CON1 * DECREMENT CURRENT STACK POINTER LDA 000001B,I * LOAD A FROM CURRENT STACK JMP POP,I * RETURN * * SPUSH PUSH A REG ONTO SYSTEM STACK * A = DATA, B = NOT PRESERVED * SPUSH NOP * LINKAGE LDB SP * GET SYSTEM STACK POINTER CPB SLIM * SYSTEM STACK FULL? JMP SOVER * YES, DO SYSTEM STACK PUSH JSB PUSH * NO, CALL PUSH SUBROUTINE STB SP * SAVE SYSTEM STACK POINTER JMP SPUSH,I * RETURN * * RPUSH PUSH A REG ONTO RETURN STACK * A = DATA, B = NOT PRESERVED * RPUSH NOP * LINKAGE LDB RP * GET RETURN STACK POINTER CPB RLIM * RETURN STACK FULL? JMP ROVER * YES, CRASH AND BURN JSB PUSH * NO, CALL PUSH SUBROUTINE STB RP * SAVE RETURN STACK POINTER JMP RPUSH,I * RETURN * * XPUSH PUSH A REG ONTO EXTRA STACK * A = DATA, B = NOT PRESERVED * XPUSH NOP * LINKAGE LDB XP * GET EXTRA STACK POINTER CPB XLIM * EXTRA STACK FULL? JMP XOVER * YES, CRASH AND BURN JSB PUSH * NO, CALL PUSH SUBROUTINE STB XP * SAVE EXTRA STACK POINTER JMP XPUSH,I * RETURN * * YPUSH PUSH A REG ONTO Y STACK * A = DATA, B = NOT PRESERVED * YPUSH NOP * LINKAGE LDB YP * GET Y STACK POINTER CPB YLIM * Y STACK FULL? JMP YOVER * YES, CRASH AND BURN JSB PUSH * NO, CALL PUSH SUBROUTINE STB YP * SAVE Y STACK POINTER JMP YPUSH,I * RETURN * * ZPUSH PUSH A REG ONTO Z STACK * A = DATA, B = NOT PRESERVED * ZPUSH NOP * LINKAGE LDB ZP * GET Z STACK POINTER CPB ZLIM * Z STACK FULL? JMP ZOVER * YES, CRASH AND BURN JSB PUSH * NO, CALL PUSH SUBROUTINE STB ZP * SAVE Z STACK POINTER JMP ZPUSH,I * RETURN * * SPOP POP SYSTEM STACK TO A REG * A = DATA, B = NOT PRESERVED * SPOP NOP * LINKAGE LDB SP * GET SYSTEM STACK POINTER CPB STOP * SYSTEM STACK EMPTY? JMP SUNDR * YES, CRASH AND BURN JSB POP * NO, CALL POP SUBROUTINE STB SP * SAVE SYSTEM STACK POINTER JMP SPOP,I * RETURN * * RPOP POP RETURN STACK INTO A REG * A = DATA, B = NOT PRESERVED * RPOP NOP * LINKAGE LDB RP * GET RETURN STACK POINTER CPB RTOP * RETURN STACK EMPTY? JMP RUNDR * YES, CRASH AND BURN JSB POP * NO, CALL POP SUBROUTINE STB RP * SAVE SYSTEM STACK POINTER *fixed typo was SPOP JMP RPOP,I * RETURN * * XPOP POP EXTRA STACK INTO A REG * A = DATA, B = NOT PRESERVED * XPOP NOP * LINKAGE LDB XP * GET EXTRA STACK POINTER CPB XTOP * EXTRA STACK EMPTY? JMP XUNDR * YES, CRASH AND BURN JSB POP * NO, CALL POP SUBROUTINE STB XP * SAVE SYSTEM STACK POINTER JMP XPOP,I * RETURN * * YPOP POP Y STACK INTO A REG * A = DATA, B = NOT PRESERVED * YPOP NOP * LINKAGE LDB YP * GET Y STACK POINTER CPB YTOP * Y STACK EMPTY? JMP YUNDR * YES, CRASH AND BURN JSB POP * NO, CALL POP SUBROUTINE STB YP * SAVE Y STACK POINTER JMP YPOP,I * RETURN * * ZPOP POP Z STACK INTO A REG * A = DATA, B = NOT PRESERVED * ZPOP NOP * LINKAGE LDB ZP * GET Z STACK POINTER CPB ZTOP * Z STACK EMPTY? JMP ZUNDR * YES, CRASH AND BURN JSB POP * NO, CALL POP SUBROUTINE STB ZP * SAVE Z STACK POINTER JMP ZPOP,I * RETURN * * STACK ERROR HANDLERS * SOVER LDA SWRDC JMP OVERM ROVER LDA RWRDC JMP OVERM XOVER LDA XWRDC JMP OVERM YOVER LDA YWRDC JMP OVERM ZOVER LDA ZWRDC JMP OVERM SUNDR LDA SWRDC JMP UNDRM RUNDR LDA RWRDC JMP UNDRM XUNDR LDA XWRDC JMP UNDRM YUNDR LDA YWRDC JMP UNDRM ZUNDR LDA ZWRDC JMP UNDRM SWRDC OCT 51440 * "S " RWRDC OCT 51040 * "R " XWRDC OCT 54040 * "X " YWRDC OCT 54440 * "Y " ZWRDC OCT 55040 * "Z " STKEL OCT 3 STKEC DEF *+1 ASC 3,STACK 1/29/08 OVERL OCT 4 OVERC DEF *+1 ASC 4,OVERFLOW UNDRL OCT 5 UNDRC DEF *+1 ASC 5,UNDERFLOW 1/29/08 OVERM STA TMP4 JSB CRLF LDA TMP4 JSB PTWD JSB STKEM LDA OVERL LDB OVERC JSB PBFL JMP WBOOT UNDRM STA TMP4 JSB CRLF LDA TMP4 JSB PTWD JSB STKEM LDA UNDRL LDB UNDRC JSB PBFL JMP WBOOT STKEM NOP LDA STKEL LDB STKEC JSB PBFL JMP STKEM,I * * RSTAK RESETS ALL STACK POINTERS * A = NOT PRESERVED * RSTAK NOP * LINKAGE LDA STOP * GET TOP OF SYSTEM STACK STA SP * LOAD SYSTEM STACK POINTER LDA RTOP * GET TOP OF RETURN STACK STA RP * LOAD RETURN STACK POINTER LDA XTOP * GET TOP OF EXTRA STACK STA XP * LOAD EXTRA STACK POINTER LDA YTOP * GET TOP OF Y STACK STA YP * LOAD Y STACK POINTER LDA ZTOP * GET TOP OF Z STACK STA ZP * LOAD Z STACK POINTER JMP RSTAK,I * RETURN * * ASCII NUMBER CONVERSION SUBROUTINES * ASC2W - ASCII TO WORD... * INPUT: ANBYA POINTS TO LAST CHAR OF NUMBER (1'S DIGIT) * CONVERSION RADIX IN ANRAD, 2'S COMP IN CHOF2 * ANMUE POINTS TO LAST ENTRY (1) OF MULT TABLE * ANMUA POINTS TO FIRST ENTRY OF MULT TABLE * OUTPUT: A=0 IF NOT A NUMBER, OTHERWISE VALUE IN ANVAL * ASC2W NOP CLA STA ANVAL * start out value = 0 LDA ANMUE * get address of last mult.table entry (1) STA ANMPT * save in multiplier pointer ASC2L LDA ANBYA,I * get ascii character CPA ASCMI * is it a "-" sign? JMP ASCCO * yes, 2's complement value and exit with number CPA TCON1 * is it a space? JMP ASCEX * yes, exit routine with number LDB ANMPT * check for overflow.. get mult.table pointer INB * increment it? CPB ANMUA * equal to start of table (meaning below table) JMP NOTNM * yes - not a valid number ADA CHOFS * convert digit to numeric SSA * is it below 0? JMP NOTNM * yes, not a number STA TMPDG * save number ADA CHOF2 * subtract radix SSA * is below 0? JMP ISDIG * yes, it's a digit NOTNM CLA JMP ASC2W,I * return 0 for failure ISDIG LDA TMPDG * get digit ISDIL SZA,RSS * process if not 0 JMP ASC2N * otherwise multiply and move to next digit LDA ANMPT,I * get current multiplier ADA ANVAL * add value to it STA ANVAL * store it LDA TMPDG * get digit ADA CON1 * subtract one STA TMPDG * save it JMP ISDIL * loop until digit = 0 ASC2N LDA ANMPT * get mult table pointer ADA CON1 * decrement it STA ANMPT * save it back LDA ANBYA * NEXT DIGIT - get input pointer ADA CON1 * subtract 1 STA ANBYA * save it JMP ASC2L * jump to main conversion loop ASCCO LDA ANVAL * get value CMA,INA * two's compliment STA ANVAL * save it ASCEX CLA,INA * EXIT - set A to 1 for success JMP ASC2W,I * outahere CHOFS OCT 177720 * 65536-48 TMPDG OCT 0 * temp digit ASCMI OCT 55 * minus sign ANMPT OCT 0 * current multiplier table pointer * * W2ASC - WORD TO ASCII... * INPUT: NUMBER TO CONVERT IN W2AIN * W2OUA POINTS TO START OF OUT BUFFER (DEFAULT W2OUT) * CONVERSION RADIX IN ANRAD, 2'S COMP IN CHOF2 * PROPER MULTIPLY TABLE (BIG TO 1) AT [ANMUA] TO [ANMUE] * W2FLG BIT 0 = IF SET SUPPRESS LEADING ZEROS * BIT 1 = IF SET CONVERT 32768-65535 AS MINUS * (NOTE: W2FLG IGNORED IF ANRAD=2) * OUTPUT: ASCII NUMBER AT W2OUT (OR WHEREVER W2OUA POINTS) * NUMBER OF CHARS IN W2LEN (FROM 5 TO 16 DIGITS) * W2ASC NOP LDA W2OUA * get address of output buffer STA W2PTR * init output pointer LDA ANMUA * get address of multiply table STA ANMPT * init mult-table pointer CLA STA W2LEN * start length at 0 STA W2LZC * default=output leading zeros LDA W2AIN * get input word to convert STA W2NUM * save in remainder LDB ANRAD * get radix CPB W2CO2 * compare to 2 JMP W2ACV * equal, start conversion (ignore W2FLG) LDB W2FLG * get conversion preferences flag SLB * skip if bit 0 = 0 else STB W2LZC * save non-zero in leading zero control RBR * rotate bit 1 to bit 0 to check minus flag OCT 6011 * SLB,RSS - skip next if bit 0 is 1 JMP W2ACV * minus flag not set, start conversion SSA,RSS * skip if bit 15 = 1 (number still in A) JMP W2ACV * no, start conversion process LDA ASCMI * get a minus sign JSB W2AOC * output character to buffer LDA W2NUM * get number CMA,INA * 2's complement it STA W2NUM * save it * strategy is start at highest multiplier and loop to 1 * for each digit try to subtract multiplier from number, * if negative then next digit, otherwise save remainder in number * and increment digit counter. Repeat until negative to get that digit * then write digit to buffer (ascii converted). * for octal looks like, starting with the value 83 decimal.. * table calculations output digit * 32768 83 - 32768 < 0 0 * 4096 83 - 4096 < 0 0 * 512 83 - 512 < 0 0 * 64 83 - 64 = 19 19 - 64 < 0 1 * 8 19 - 8 = 11 11 - 8 = 3 3 - 8 < 0 2 * 1 3 - 1 = 2 2 - 1 = 1 1 - 1 = 0 0 - 1 < 0 3 * looks pretty simple looking at it that way... W2ACV CLA STA W2TMD * clear temp digit LDA W2NUM * get remainder W2AC2 LDB ANMPT,I * get multiplier value CMB,INB * two's complement it ADA 1 * add into A SSA * skip if sign bit = 0 JMP W2OUD * done, output digit ISZ W2TMD * increment temp digit STA W2NUM * new remainder JMP W2AC2 * keep subtracting until < 0 W2OUD LDA W2TMD * get digit result CLB SZA * skip if digit=zero STB W2LZC * if not zero clear leading zero control ADA CHOF1 * add ascii offset (48 dec) JSB W2AOC * write character to buffer LDA ANMPT * get current multiplier pointer CPA ANMUE * compare to address of last entry JMP W2AEX * if equal then we're done ISZ ANMPT * increment multpointer JMP W2ACV * do next digit W2AEX LDA W2LEN * get output length this is needed to handle SZA * skip if 0 the zero case with leading JMP W2ASC,I * good output, exit zeros suppressed, or any LDA CHOF1 * load a "0" in A other reason length CLB * clear leading STB W2LZC * zero control (or else!) JSB W2AOC * output it to buffer might be 0 JMP W2ASC,I * exit subroutine * private vars... W2NUM OCT 0 * current remainder W2PTR OCT 0 * private pointer to output buffer W2CO2 DEC 2 * just a 2 W2LZC OCT 0 * leading zero control.. if <>0 suppress 0 W2TMD OCT 0 * temp digit CHOF1 DEC 48 * offset to add to get ascii * ascii output-to-buffer subroutine, char in A * if W2LZC is not zero, doesn't output if char is "0" W2AOC NOP LDB W2LZC * get leading zero flag (caller must control!) SZB,RSS * skip if not zero JMP W2AO1 * continue if not CPA CHOF1 * compare to "0" character (48 dec) JMP W2AOC,I * yes, return without doing anything W2AO1 LDB W2PTR * get buffer pointer STA 1,I * store character INB * increment and STB W2PTR * save pointer ISZ W2LEN * increment length NOP * should not be necessary but just in case JMP W2AOC,I * return from sub * * ABOOT CLA,INA * 8/26/04 set ABFLG to 1 for alternate boot JMP CBOO1 CBOOT CLA * or set ABFLG to 0 for normal boot CBOO1 STA ABFLG * save bootup flag CLA * 8/29/04 STA WDENA * disable WD after any boot CLC 0 * 1/30/08 - reset all I/O control bits JSB PIOCH * patch IO channels LDA DFCIN * get default console in STA ZCHIN * store in console in vector LDA DFCOT * get default console out STA ZCOUT * store in console out vector LDA CBIIR * get cold-boot initial IR/WA value RSS * skip next instruction WBOOT LDA WBIIR * get warm-boot IR/WA value (skip autostarts) STA IR * PRELOAD INSTRUCTION REG STA WA * PRELOAD WORD ADDRESS REG CLA,INA * SET A TO 1 STA TXTWP * set text-was-printed flag STA STEP * 6/9/10 - set default +LOOP step value LDA DEFPR * get ascii for default prompt (norm "? ") STA PRMPT * store in prompt location JSB CNSOL * reset redirection to console/papertape JSB RSTAK * RESET ALL STACKS JMP NEXT * START OUTER INTERPRETER * * * INNER INTERPRETER CODE BEGINS * * * ENSEC ENTER A SECONDARY INSTRUCTION * ENSEC LDA IR * GET INSTRUCTION REGISTER JSB RPUSH * PUSH IT ONTO THE RETURN STACK LDA WA * GET WORD ADDRESS REGISTER STA IR * STORE INTO INSTRUCTION REGISTER JMP NEXT * JUMP TO NEXT * * RTSEC RETURN FROM A SECONDARY * RTSEC DEF RTSEC+1 * CODE ADDRESS POINTER FOR RESEC JSB RPOP * POP RETURN STACK STA IR * INTO INSTRUCTION REGISTER * * NEXT FETCH NEXT WORD ADDRESS FROM (IR) * NEXT LDB IR * MOVE IR TO B REG LDA 000001B,I * MOVE M(IR) TO A REG STA WA * M(IR) TO WORD ADDRESS REG INB * INCREMENT IR VALUE STB IR * SAVE NEXT INSTRUCTION ADDRESS CLA * 8/28/04 clear watchdog timer STA WDTMR * every time "next" runs * * RUN START NEXT INSTRUCTION * RUN LDB WA * MOVE WA REGISTER TO B REG LDA 000001B,I * MOVE M(WA) TO A REG STA CA * SAVE CODE ADDRESS VALUE (?) INB * POINT TO NEXT WORD ADDRESS STB WA * SAVE WORD ADDRESS VALUE JMP 000000B,I * JUMP TO CODE ADDRESS * * * OUTER INTERPRETER CODE BEGINS * * OI0 DEF AUTO * Auto-run definitions beginning with ! DEF SIGNO * Perform sign-on * OI7 DEF CONIN * GET COMMAND LINE FROM USER OI10 DEF MAKSA * make safe, init BEGOD to after IR words OI11 DEF TOKEN * EXTRACT NEXT TOKEN IN LINE OI12 DEF TEST * CHECK FOR END OF LINE? OI13 DEF OI7 * YES, GET NEXT COMMAND LINE OI14 DEF SDIC * NO, SEARCH DICTIONARY FOR TOKEN OI15 DEF TEST * TOKEN FOUND? OI16 DEF OI23 * YES, GO EXECUTE THE TOKEN OI20 DEF DSERR * DICTIONARY SEARCH ERROR OI21 DEF GOTO * INNER INTERPRETER JUMP OI22 DEF OI7 * TO RESTART OUTER INTERPRETER OI23 DEF EXEC * EXECUTE TOKEN ON STACK OI24 DEF GOTO * INNER INTERPRETER JUMP OI25 DEF OI10 * TO GET NEXT TOKEN FROM LINE * * * OUTER INTERPRETER FUNCTIONS * SIGNO DEF *+1 LDA BM1 * BOOT MESSAGE LENGHT LDB BM2A * BOOT MESSAGE ADDRESS JSB PBFL JMP NEXT * * Execute... so that inner guts aren't dependent on * addresses within the dictionary (faster by 2 cycles too) * EXEC DEF *+1 * CODE ADDRESS POINTER JSB SPOP * CALL SPOP SUBROUTINE STA WA * STORE IN WA REGISTER JMP RUN * JUMP TO RUN * * MAKSA * sets beginning of dictionary (BEGOD) to * * after flow control words MAKSA DEF *+1 LDA MAKS9 * get safe beginning STA BEGOD * make that the beginning JMP NEXT MAKS9 DEF CONSA * label that is safe * * * TEST POPS A VALUE FROM THE SYSTEM STACK AND * JUMPS TO THE LOCATION IN NEXT WORD ADDRESS * IF THE VALUE IS NOT EQUAL TO ZERO, IF ZERO * TEST SKIPS THE NEXT WORD ADDRESS * TEST DEF *+1 * PRIMITIVE, WA=WA+1 JSB SPOP * POP VALUE FROM SYSTEM STACK SZA * SKIP NEXT IF ZERO JMP TST1 * JUMP IF NOT ZERO LDA IR * GET INNER INTERPRETER IR INA * INCREMENT TO BYPASS JUMP ADDRESS STA IR * SAVE NEW IR VALUE JMP NEXT * END OF TEST TST1 LDA IR,I * GET JUMP TARGET ADDRESS STA IR * LOAD TARGET ADDRESS INTO IR JMP NEXT * AND RUN CODE FROM THERE * * * GOTO UNCONDITIONAL INNER INTERPRETER JUMP * LOADS IR+1 INTO IR, THEN EXITS TO NEXT * GOTO DEF *+1 * PRIMITIVE, WA=WA+1 LDA IR,I * GET TARGET ADDRESS STA IR * LOAD TARGET ADDRESS INTO IR JMP NEXT * AND RUN CODE FROM THERE * * * CONIN GETS A COMMAND LINE FROM THE USER WITH LINE * EDITING FUNCTIONS, EXITS ON RETURN KEY ONLY * EXITS WITH EDITIED COMMAND LINE IN BUFFER * WITH [SPACE] CR AT END OF LINE * CONIN DEF *+1 * PRIMITIVE, WA=WA+1 CIN0 JSB RSTBF * RESET IO BUFFER POINTER LDA ZIN * get input vector CPA ZCHIN * = console character input sub? JMP *+2 * yes, print prompt JMP CIN * no, keep quiet * to avoid double-spacing prompts but also avoid misplaced * output text, only print initial crlf if text was printed LDA TXTWP * get text-was-printed flag SZA * skip crlf if clear JSB CRLF * GOTO NEXT LINE ON CONSOLE JSB NLINE * SEND COMMAND PROMPT * CIN JSB ZIN,I * GET CHAR FROM CONSOLE or device CPA TCON6 * linefeed? JMP CIN * yes - don't need that,ignore SZA,RSS * is it 0? JMP CIN * yes - zeros have no biz here CPA TCON2 * IS CHAR BACKSPACE? (8) JMP BSP * YES, PROCESS BACKSPACE CPA TCON5 * is it a 127-backspace JMP BSP * yes, process backspace CPA TCON3 * NO, IS CHAR ESCAPE? JMP CIN0 * YES, PROCESS ESCAPE CPA TCON4 * NO, IS CHAR RETURN? JMP RET * YES, PROCESS RETURN LDB IOP * NO, GET IOP VALUE STA 000001B,I * STORE CHAR BUFFER CPB CON4 * END OF IO BUFFER? JMP EBUFF * YES, DO END OF BUFFER INB * NO, INCREMENT IOP STB IOP * SAVE NEW IOP VALUE JMP CIN * GET NEXT CHAR FROM CONSOLE * BSP LDB IOP * GET IOP VALUE * added these 2 to keep from underflowing buffer... CPB CON5 * at beginning of buffer? JMP CINB * yes - throw away character (modified) ADB CON1 * DECREMENT VALUE STB IOP * SAVE NEW IOP VALUE * new code to auto-detect the backspace mode... LDB 0 * B = A, the backspace detected LDA TCON2 * get backspace(8) CPB TCON5 * was it a 127 backspace? JSB ZCOUT,I * yes, send the backspace(8) LDA SPBSP * GET SPACE, BACKSPACE WORD JSB PTWD * SEND IT TO THE CONSOLE JMP CIN * GET NEXT CHAR FROM CONSOLE CINB CPA TCON5 * here if at beg.of line.. a 127 backspace? JMP CIN * yes - loop for more JSB SPACE * no - print space to avoid erasing prompt JMP CIN * loop for more BSPTM OCT 0 * save inputted backspace char * RET LDB IOP * GET IOP VALUE INB * increment STA 000001B,I * SAVE RETURN IN BUFFER (+1) ADB CON1 * decrement buffer pointer LDA TCON1 * get space STA 1,I * save in buffer before return * the above code adds a space after everything so that * token will work correctly LDA ZIN * get input vector CPA ZCHIN * = console character input sub? JSB CRLF * yes, send return to console * avoid double-spacing prompts... CLA * clear STA TXTWP * text-was-written flag JSB RSTBF * RESET IO POINTER JMP NEXT * EXIT CONSOLE INPUT FUNCTION * EBUFF LDA TCON2 * get backspace JSB ZCOUT,I * at end of buffer only CR allowed LDA SPBSP * get space,backspace JSB PTWD * erase undesirable character JMP CIN * GET NEW LAST CHAR * TCON1 OCT 000040 * ASCII SPACE CHAR TCON2 OCT 000010 * ASCII BACKSPACE CHAR TCON3 OCT 000033 * ASCII ESCAPE CHAR TCON4 OCT 000015 * ASCII RETURN CHAR * for some reason backspace returns 127 decimal under SIMH.. TCON5 OCT 000177 * to redirect from dos files... TCON6 OCT 12 * Ascii line feed * * RSTBF NOP * LINKAGE LDA CON5 * GET START OF IO BUFFER STA IOP * SAVE IN IO POINTER JMP RSTBF,I * RETURN * TOKEN DEF *+1 * PRIMATIVE, WA=WA+1 *added... default TB2 to spaces LDA SPCHR STA TB2 LDB IOP * GET IO POINTER VALUE TOKN2 LDA 000001B,I * READ IO BUFFER WORD CPA TCON1 * IS IT SPACE? JMP NTOKN * YES, FIND NEXT TOKEN * CPA TCON4 * NO, IS IT RETURN? JMP ETOK2 * YES, END OF TOKEN 2 ALF,ALF * MOVE TO TOP BYTE STA TB1 * SAVE IN TOKEN BUFFER 1 INB * INCREMENT VALUE STB IOP * SAVE NEW IOP VALUE CLA,INA * A REG = 1 STA TL * TOKEN LENGHT = 1 * GOT FIRST CHAR OF TOKEN LDA 000001B,I * READ BUFFER WORD CPA TCON1 * IS IT SPACE? JMP ETOK1 * YES, END OF TOKEN 1 CPA TCON4 * NO, IS IT RETURN? JMP ETOK2 * YES, END OF TOKEN 2 IOR TB1 * OR IN LAST CHAR OF TOKEN STA TB1 * SAVE FINAL TB1 VALUE INB * INCREMENT IOP VALUE STB IOP * SAVE NEW IOP VALUE JSB INCTL * INCREMENT TOKEN LENGHT * GOT SECOND CHAR OF TOKEN LDA 000001B,I * READ BUFFER WORD CPA TCON1 * IS IT SPACE? JMP ETOK1 * YES, END OF TOKEN 1 CPA TCON4 * NO, IS IT RETURN? JMP ETOK2 * YES, END OF TOKEN 2 ALF,ALF * MOVE TO HIGH BYTE STA TB2 * SAVE IN TB2 INB * INCREMENT IOP VALUE STB IOP * SAVE NEW IOP VALUE JSB INCTL * INCREMENT TOKEN LENGHT * GOT THIRD CHAR OF TOKEN LDA 000001B,I * READ BUFFER WORD CPA TCON1 * IS IT SPACE? JMP ETOK1 * YES, END OF TOKEN 1 CPA TCON4 * NO, IS IT RETURN? JMP ETOK2 * YES, END OF TOKEN 2 IOR TB2 * OR IN LAST CHAR OF TOKEN STA TB2 * SAVE FINAL TB2 VALUE INB * INCREMENT IOP VALUE STB IOP * SAVE NEW IOP VALUE JSB INCTL * INCREMENT TOKEN LENGHT * GOT FOURTH CHAR OF TOKEN, NEW FIND TOKEN LENGHT TOKLN LDA 000001B,I * READ BUFFER WORD CPA TCON1 * IS IT SPACE? JMP ETOK1 * YES, END OF TOKEN 1 CPA TCON4 * NO, IS IT RETURN? JMP ETOK2 * YES, END OF TOKEN 2 INB * NO, INCREMENT IOP VALUE STB IOP * SAVE NEW IOP VALUE JSB INCTL * INCREMENT TOKEN LENGHT JMP TOKLN * CHECK NEXT CHAR IN BUFFER * INCTL NOP * LINKAGE LDA TL * GET TOKEN LENGHT VALUE INA * INCREMENT TOKEN LENGHT STA TL * SAVE NEW TOKEN LENGHT JMP INCTL,I * RETURN * NTOKN INB * INCREMENT IOP VALUE STB IOP * SAVE NEW IOP VALUE JMP TOKN2 * GET NEXT BUFFER WORD * ETOK1 CLA *push false to sstack jump to next ETOK3 JSB SPUSH * if token length is 1 or 3 then pad with space LDA TL CPA NUM1 * is it one? JMP PADB1 * yes, pad tb1 CPA NUM3 * is it three? JMP PADB2 * yes, pad tb2 JMP NEXT ETOK2 CLA,INA *push true to sstack jump to next JMP ETOK3 PADB1 LDA TB1 * pad buffers IOR TCON1 STA TB1 JMP NEXT PADB2 LDA TB2 IOR TCON1 STA TB2 JMP NEXT NUM1 OCT 1 NUM3 OCT 3 * * dictionary search error * DSERR DEF *+1 JSB CNSOL * reset console in case from device LDA TB1 JSB PTWD * print 1st 2 token chars LDA TB2 JSB PTWD * print 2 more token chars * doesn't print the remaining dots (X, ? whatever), that * would take more code and I'm already bumping up against * the dictionary in the small memory version... * perhaps will come back later. This is functional. LDA DSERL * LOAD MESSAGE LEN LDB DSERA * LOAD MESSAGE ADDRESS JSB PBFL * PRINT SEARCH ERROR MESSAGE JMP NEXT DSEM4 OCT 177774 * -4 DSERL OCT 5 DSERA DEF *+1 ASC 5, NOT FOUND 1/29/08 * * SEARCH DICTIONARY * SDIC DEF *+1 * match TL,TB1,TB2 at word entrance * This searches top to end and flags last matching entry * Entire dictionary is searched every time * End to beginning search not practical - no back chains! * * Check for quote to indicate string push... CLA STA SDSFF * clear quote flip-flop LDA TB1 AND UBMSK * get only upper byte CPA UBQUO * compare to quote char*256 JMP SDSTR * yes, jump to string handling code * commenting... by putting here guarantees won't be detected * in the middle of a string. A bit tricky though, since SDIC * must return an address containing the address of something * to execute. So implemented like a handler.. at console it * does nothing, under DEFINE detection of comment handler is * ignored. The SDCMT code will insert CR right after the * space following the detected comment string, thus * terminating the line. CPA UBCMT * compare to comment char(;)*256 JMP SDCMT * yes, jump to comment handler * Search the dictionary for match... SDIC0 CLA STA SDADR * clear match address LDB BEGOD * get address of first word definition SDICL STB SDPTR * LOOP - save curr address in pointer LDA 1,I * get word length (address in B reg) SZA,RSS * is it 0? JMP SDEND * YES - end of search CPA TL * compare to target length JMP SDIC1 * equal - keep going JMP SDCHN * not equal, check next word SDIC1 INB * increment pointer LDA 1,I * get 1st two chars of word name CPA TB1 * compare JMP SDIC2 JMP SDCHN SDIC2 INB LDA 1,I * compare CPA TB2 JMP SDMAT * We have a match! * no match - skip to next word definition SDCHN LDA SDPTR * get last pointer INA * skip length INA * skip 1st 2 chars INA * skip last 2 chars LDB 0,I * B points to next word JMP SDICL * keep searching * match - retrieve address of code SDMAT INB * skip INB * link STB SDADR * save match JMP SDCHN * keep searching in case more matches SDEND LDA SDADR * load match or 0 if not found SZA,RSS * skip if not zero JSB SDTST * test for constant (A=literal handler if so) JSB SPUSH * push success flag to stack SZA * skip if not found (A=0) JSB SPUSH * push results JMP NEXT * continue with next address in thread SDADR OCT 0 * address match here SDPTR OCT 0 * pointer to definition SDTST NOP * SUB test for literal... * return 0 in A if not a number, otherwise return literal handler LDA IOP * get buffer pointer ADA CON1 * subtract 1 to point to possible 1's digit STA ANBYA * save in asc2w's pointer JSB ASC2W * try to convert SZA,RSS * skip if A<>0 (success) JMP SDTST,I * otherwise return not a number LDA LITRH * address of address of literal-push code JMP SDTST,I * for string detection... UBMSK OCT 177400 * upper 8 bits=1, lower 8 bits=0 UBQUO OCT 021000 * quote in upper byte (1st char) LBQUO OCT 42 * quote in lower byte * for comment detection... UBCMT OCT 35400 * ";" in upper byte, 0 in lower SDCMT LDA TCON4 * get return character STA IOP,I * store in buffer to terminate line LDA CMNTH * get address of address of handler code JSB SPUSH * push to stack JSB SPUSH * push non-0 to indicate success JMP NEXT * out of here CMNTH DEF *+1 * address to match comment handler CMNTA DEF *+1 * address of comment handler code JMP NEXT * this is an empty handler * * process strings... * when "string" is entered at the console, parse string and if * no errors push console string handler address twice otherwise * push 0 to indicate failure. String handler will do the pushing. * Strings are stored on the X stack, new format for 0.25... * "HE" <- in memory in proper order, high then low * "LL" * "O" 0 <- unused low byte padded with 0 (doesn't matter) * 5 <- char count * 4 <- word count * Upon entry here, IOP will be pointing to the space after * the last char, IOP-1 will be a quote if a valid string * without spaces. To handle (real) spaces in strings, If IOP * is a quote then fine.. push handler.. otherwise advance IOP * to next space and check for quote again. If end of input buffer * reached and no quote yet then exit w/ not found. * On exit of SDIC, STRPT points to the character after the * first quotation mark. Will be the end-quote if empty string, * if not empty the 1st character of the string to process. SDSTR LDB IOP ADB CON1 * B=iop-1 LDA 1,I * get that character CPA LBQUO * is it a quote? JMP SDST1 * yes, process string SDSDP LDB IOP * get IOP SDSQL INB * increment STB IOP * save in IOP in case this is the one LDA 1,I * get char CPA TCON4 * is it RETURN? JMP SDSFA * yes, fail CPA TCON1 * is it a space? JMP SDSTR * check for that quote again CPB CON4 * pointer=top of buffer? JMP SDSFA * yes, fail (in case called w/ bad data) JMP SDSQL * increment and keep searching SDSFA CLA * clear A JSB SPUSH * push failure JMP NEXT * return to whatever SDST1 LDA SDSFF CMA STA SDSFF SZA,RSS JMP SDST2 CLA,INA * A=1 CPA TL * was it a length of one? JMP SDSDP * isolated quote, don't process yet SDST2 ADB CON1 * process string, dec B LDA 1,I * get buffer byte CPA LBQUO * quote? JMP SDST3 * yes, terminate JMP SDST2 * no, loop until first quote found SDST3 INB * bump to point to 1st character STB STRPT * save to string pointer LDA SHAND * get address of address of handler JSB SPUSH * push to stack JSB SPUSH * twice JMP NEXT * string handler will execute SDSFF OCT 0 * flip-flop for handling single quotes * * String Handler... at console * SHAWC OCT 0 * string handler word count SHACC OCT 0 * string handler char count SHTMP OCT 0 * temp for combining SHAND DEF *+1 * address of address SHANA DEF *+1 * address of code CLB STB SHAWC * clear words STB SHACC * clear count * On entry STRPT points to 1st character, or end quote if empty * Handler pushes each character (high then low), when done pushes * character count and word count SHAN1 LDB STRPT * get string pointer LDA 1,I * get character from buffer CPA LBQUO * quote character? JMP SHAN5 * yes, done - finish by pushing counts LDB SHACC * get character count SLB * skip if count is even JMP SHAN3 * if odd char jump ALF,ALF * even - put char in high byte, low byte = 0 JSB ZXPSH,I * push to X stack ISZ SHAWC * increment word count SHAN2 ISZ SHACC * increment character count ISZ STRPT * increment string pointer JMP SHAN1 * do next character SHAN3 STA SHTMP * save in temp JSB ZXPOP,I * pop previous incomplete pair IOR SHTMP * OR with new value JSB ZXPSH,I * push back to stack JMP SHAN2 * increment char count, string ptr and loop SHAN5 LDA SHACC * get # characters pushed JSB ZXPSH,I * push to X stack LDA SHAWC * get # words pushed INA * increment to account for char length JSB ZXPSH,I * push to X stack JMP NEXT * done, do the next thing * * String Push from within a thread... * PSTRP DEF *+1 LDB IR * get adr of next thread item STB STRPT * save in string pointer LDA 1,I * get data at IR, length in words STA SHAWC * save to push last ISZ IR * bump IR over length PSTRL STA SHACC * save length SZA,RSS * skip if not zero JMP PSTRE * end of string ISZ STRPT * bump pointer to next item LDA STRPT,I * get item JSB XPUSH * push to X stack ISZ IR * skip one more data item LDA SHACC * get length ADA CON1 * decrement JMP PSTRL * keep looping till done PSTRE LDA SHAWC * get length JSB XPUSH * push to X stack JMP NEXT * keep processing thread * * Literal Handler... at console * LITRH DEF *+1 * address of address LITRA DEF *+1 * address of code LDA ANVAL * get number JSB SPUSH * push on stack JMP NEXT * * Literal Push from within a thread... * PLPSH DEF *+1 LDB IR LDA 1,I * get data at IR INB * skip data STB IR * save new IR JSB SPUSH * push data JMP NEXT * * Auto-run definitions beginning with ! AUTO DEF ENSEC * no obvious way to run a definition from machine code * so this has to be hi-level (but can call ML) DEF AINIT * init pointer AUTO1 DEF AGNXT * pushes address of next ! word, and 1 if valid * pushes just 0 if at end of dictionary DEF TEST * jump to following addr if stack is non-zero DEF AEXEC * jump to execute code if valid address returned DEF RTSEC * we're done.. return to outer interpreter ADPTR OCT 0 * pointer ADPST DEF DIC00 AINIT DEF *+1 LDA ADPST * get start of dictionary STA ADPTR * store in pointer JMP NEXT * return AGNXT DEF *+1 LIA 1 * get switch register CMA,SZA,RSS * complement, skip if not zero JMP AGNX0 * if SR is all 1's, skip autostart LDA ASENA * get enable flag SZA,RSS * skip if A<>0 JMP AGNX0 * if enable = 0 skip autostart AGNXL LDA ADPTR,I * get next definition length SZA * skip next instruction if zero JMP AGNX1 * if not zero goto agnx1 AGNX0 JSB SPUSH * push that zero JMP NEXT * return with a zero on stack AGNX1 ISZ ADPTR * increment dictionary pointer LDA ADPTR,I * get first two chars of name STA TMP1 * save in temp1 ISZ ADPTR ISZ ADPTR * move pointer to link LDB ADPTR,I * get value in B ISZ ADPTR * move pointer to start of def LDA ADPTR * get value STA TMP2 * save in TMP2 STB ADPTR * update pointer to next def LDA TMP1 * get first two chars of name AND AGNC1 * clear low byte CPA AGNC2 * compare to ! JMP AGNX2 * found one.. get ready to run JMP AGNXL * nope, keep searching AGNX2 LDA TMP2 * get address of definition to run JSB SPUSH * push to stack CLA,INA * a = 1 JSB SPUSH * push 1 to indicate success JMP NEXT * return with addr and 1 on stack AGNC1 OCT 177400 * mask to clear low byte AGNC2 OCT 020400 * ! in high byte AEXEC DEF EXEC * interpret address on stack DEF GOTO * jump to.. DEF AUTO1 * auto1 to execute more ! definitions * * end of core threaded interpreter code * * headerless word for PUTing into the dictionary... 6/2/10 DPUT DEF *+1 JSB ZSPOP,I pop put data STA PDATA save it JSB ZSPOP,I pop put address STA PADR save it LDA DLIM get block start address LDB PADR get put address CMB INB 2's complement ADA 1 A = block adr - put adr SSA skip if not negative JMP UERR if > block adr jump to error SZA,RSS skip if not zero JMP UERR if = block adr jump to error LDA PDATA get put data STA PADR,I store in put address JMP ZNXT,I exit word PDATA OCT 0 storage for put data PADR OCT 0 storage for put address UERR LDB EMA error print - get str adr in B LDA EMC get word length in A JSB ZPBFL,I call the string print code JMP WBVEC,I warm-boot EMC OCT 4 word length of message EMA DEF *+1 address of message ASC 4,DICT OVF * subroutine to validate string addresses, called by DEFINE DEVDT NOP STA DEVD1 save A CMA INA make negative ADA DLIM A = start of blocks - address (should be positive) SSA skip if not negative JMP UERR if > block adr jump to error SZA,RSS skip if not zero JMP UERR if = block adr jump to error LDA DEVD1 restore pointer JMP DEVDT,I return from subroutine DEVD1 OCT 0 storage for A register * headerless save last load point word SVLLP DEF ENSEC DEF PLPSH (LITERAL PUSH) DEF LSTLP address of last-load-point var DEF PEOD EOD DEF PPUT write EOD to LSTLP DEF RTSEC * *--------------------------------------------------------------- * * HEWLETT PACKARD INTERPRETIVE PROGRAMMING LANGUAGE / OPERATING SYSTEM * LANGUAGE DICTIONARY CODE * ORG 004000B * DIC00 EQU * * * OCT 000002 * LENGHT IN CHARS ASC 2,DO * "DO " DEF PDOZ * POINTER TO NEXT ENTRY PDO DEF *+1 * CODE ADDRESS POINTER LDA IR * GET CURRENT IR VALUE (points to next addr) JSB ZRPSH,I * PUSH TO RETURN ADDRESS STACK JMP ZNXT,I * END OF DO PDOZ EQU * * * DEC 3 ASC 2,+DO * "+DO" - starts a loop DEF PPDOZ * usage: [index] [limit] +DO PPDO DEF *+1 LDA IR JSB ZRPSH,I * push IR to return stack JSB ZSPOP,I * pop limit JSB ZRPSH,I * push to r.stack JSB ZSPOP,I * pop index JSB ZRPSH,I * push to r.stack JMP ZNXT,I PPDOZ EQU * * * DEC 5 ASC 2,INDE * "INDEX" - pushes iteration# to s.stack DEF PINDZ PINDX DEF *+1 JSB ZRPOP,I JSB ZRPSH,I JSB ZSPSH,I JMP ZNXT,I PINDZ EQU * * * DEC 5 ASC 2,+LOO * "+LOOP" - like basic's next DEF PPLOZ * modified 8/22/04 PPLOO DEF *+1 JSB ZRPOP,I * index STA TMP1 JSB ZRPOP,I * limit STA TMP2 JSB ZRPOP,I * loop address STA TMP3 LDA TMP1 CPA TMP2 * if index = limit JMP PPLTL * (mod 8/04) then terminate loop LDA TMP3 STA IR * IR back to loop position JSB ZRPSH,I * push loop adr to rstack LDA TMP2 JSB ZRPSH,I * push limit to rstack LDA TMP1 * get index value ADA STEP * (mod 8/04) index = index + step JSB ZRPSH,I * push to rstack JMP ZNXT,I * go back to right after +DO PPLTL CLA,INA * (8/04) set A to 1 STA STEP * reset step to 1 JMP ZNXT,I * back to hpiplos PPLOZ EQU * * * OCT 5 ASC 2,>STE * ">STEP" - pops stack and sets step value DEF P2STZ * for +LOOP, not usable from console 8/22/04 P2STE DEF *+1 JSB ZSPOP,I * pop stack STA STEP * store step value JMP ZNXT,I * back to hpiplos P2STZ EQU * * * OCT 4 ASC 2,IFNZ * "IFNZ" - if not zero - pops 1 value DEF PINZZ * falls through if not zero otherwise PIFNZ DEF *+1 * advances past corresponding endif (nestable) JSB ZSPOP,I * pop system stack SZA * skip if zero JMP ZNXT,I * execute following tokens in thread if not * search for corresponding endif or else.. crash if none exist PIFCO CLB,INB * start IF level to 1 in B PIFCL LDA IR,I * get next token to execute CPA PIFN3 * is it a IFNZ? INB * yes - increment if level CPA PIFN4 * is it a IFZ? INB * yes - increment if level CPA PIFN5 * is it a IF<0? INB * yes - increment if level CPA PIFN6 * is it an endif? ADB CON1 * yes - decrement if level CPB PIFN8 * level 1? RSS * skip if yes JMP PIFC2 * bypass if not level 1 CPA PIFN7 * is it an else? ADB CON1 * yes - decrement if level PIFC2 ISZ IR * increment IR SZB * skip if B=0 JMP PIFCL * keep searching for matching endif JMP ZNXT,I * found, go there PIFN2 OCT 11 * return char PIFN3 DEF PIFNZ * word address of "IFNZ" PIFN4 DEF PIFZ * word address of "IFZ" PIFN5 DEF PIFLZ * word address of "IF<0" PIFN6 DEF PENDI * word address of "ENDIF" PIFN7 DEF PELSE * word address of "ELSE" PIFN8 OCT 1 * just a one PINZZ EQU * * * OCT 3 ASC 2,IFZ * "IFZ" - if zero, like above but backwards DEF PIFZZ PIFZ DEF *+1 JSB ZSPOP,I * pop system stack SZA,RSS * skip if not zero JMP ZNXT,I * execute following tokens in thread if not JMP PIFCO * jump to IF common code above PIFZZ EQU * * * OCT 4 ASC 2,IF<0 * "IF<0" - if less than zero DEF PILZZ PIFLZ DEF *+1 JSB ZSPOP,I * pop system stack SSA * skip if sign bit = 0 JMP ZNXT,I * execute instructions after IF<0 if <0 JMP PIFCO * jump to IF common code to find else or endif PILZZ EQU * * * OCT 5 ASC 2,ENDI * "ENDIF" terminates an IFZ IFNZ or IF<0 block DEF PENIZ PENDI DEF *+1 JMP ZNXT,I * does nothing, just something to search for PENIZ EQU * * * OCT 4 ASC 2,ELSE * "ELSE" - when executed skips to the DEF PELSZ * corresponding ENDIF PELSE DEF *+1 JMP PIFCO * perform like IF was not true, skip block PELSZ EQU * * * OCT 5 ASC 2,UNTI * "UNTIL" - pops sys stack and if zero DEF PUNTZ * performs a normal LOOP else cleans up PUNTI DEF *+1 * the return stack and continues JSB ZSPOP,I * pop sys stack SZA,RSS * skip if not zero JMP PLOOE * if zero jump to loop code DILPC JSB ZRPOP,I * pop no longer needed return adr JMP ZNXT,I * remnents of LOOP PLOOE JSB ZRPOP,I * POP RETURN ADDRESS STACK JSB ZRPSH,I * push it back STA IR * SAVE NEW IR JMP ZNXT,I * END OF LOOP PUNTZ EQU * * * OCT 5 ASC 2,WHIL * "WHILE" - pops sys stack and loops if DEF PWHIZ * not zero, else cleans up and continues PWHIL DEF *+1 JSB ZSPOP,I * pop sys stack SZA * skip if 0 JMP PLOOE * if not zero jump to loop code JMP DILPC * if 0 then continue PWHIZ EQU * * * * HPASM definitions that implement a CASE structure * * Targets can be literal numbers or standard * variables and constants: * V0 GET CASE > V1 "V0 > V1" $PRINT ENDCASE * * CASE - main entry logic * = < > <= >= <> - conditional markers * DEFAULT - marker for if no condition is true * ENDCASE - terminates the CASE structure * In case of multiple true conditions, the first is * acted upon and the rest ignored. Example... * $IN $VAL * CASE * = 1 "You entered 1" $PRINT * = 2 "You entered 2" $PRINT * DEFAULT "You didn't enter 1 or 2" $PRINT * ENDCASE * * "CASE" - pops stack and uses to search for matching * condition markers, each 3 words long, a marker plus a * literal to test against. Each is tested in order until * the condition matches then execution proceeds after the * literal. If no match then execution proceeds after * DEFAULT or ENDCASE, whichever is encountered first. * * Created 6-23-02 * Modified 11-13-02 to allow nesting * DEC 4 ASC 2,CASE DEF PCASZ PCASE DEF *+1 JSB ZSPOP,I * get case parameter STA VTEST * save in variable CLA STA CASLV * save in case level * main search loop PCASL JSB PCANX * get next token in A, inc IR CPA ACASE * is it another case? JMP ICALV * yes, inc case level CPA AECAS * is it endcase? JMP DCALV * yes, exit if level=0 else dec case level LDB CASLV * get case level in B SZB * skip if B=0 JMP PCASL * ignore content if not case level 0 CPA ADFLT * is it default? JMP ZNXT,I * yes, done processing CPA AEQ * is it "="? JMP QEQ * check for equality CPA ALT * is it "<"? JMP QLT * check for less-than CPA AGT * is it ">"? JMP QGT * check for greater-than CPA ALTE * "<="? JMP QLTE * chk 4 lt or eq CPA AGTE * ">="? JMP QGTE * chk 4 gt or eq CPA ANEQ * "<>"? JMP QNEQ * chk 4 not eq JMP PCASL * loop for more * if another CASE encountered... ICALV ISZ CASLV * increment case level JMP PCASL * loop * if ENDCASE encountered... DCALV LDA CASLV * get case level SZA,RSS * skip if level > 0 JMP ZNXT,I * exit command if case level = 0 ADA CON1 * subtract 1 STA CASLV * save back to case level JMP PCASL * loop * QEQ JSB PCAGP * get next parm LDA VTEST * get first parm CPA VTES1 * compare to 2nd parm JMP ZNXT,I * if equal exit JMP PCASL * otherwise keep searching * QNEQ JSB PCAGP * get next parm LDA VTEST * get first parm CPA VTES1 * compare to 2nd parm JMP PCASL * if equal keep searching JMP ZNXT,I * if not equal exit * QLT JSB PCAGP * get next parm LDA VTEST * get first parm LDB VTES1 * get 2nd QLTC JSB SUBAB * sub sub SSA * skip if positive (not true) JMP ZNXT,I * if negative exit JMP PCASL * otherwise keep searching * QGT JSB PCAGP LDA VTES1 * same as QLT but reversed LDB VTEST JMP QLTC * QLTE JSB PCAGP LDA VTES1 LDB VTEST QLTEC JSB SUBAB SSA JMP PCASL JMP ZNXT,I * QGTE JSB PCAGP LDA VTEST LDB VTES1 JMP QLTEC * SUBAB NOP CMB,INB * 2's comp 2nd parm ADA 1 * to subtract from first JMP SUBAB,I * get next token in A and inc IR * if token=literal or str push then move IR * to after the constant and repeat PCANX NOP PCAX1 LDA IR,I * get token ISZ IR * increment IR CPA ALPSH * is it a literal push JMP PCAX2 * yes, inc IR and try again CPA ASTRP * is it a string push? JMP PCAX3 * yes, skip string and try again JMP PCANX,I * exit with token in A PCAX2 ISZ IR * increment IR JMP PCAX1 * load next token PCAX3 LDA IR,I * get #words in string ADA IR * add to IR INA * plus 1 STA IR * save it JMP PCAX1 * load next token * get parm and store in VTES1 PCAGP NOP LDB IR,I * get token CPB ALPSH * is it literal push JMP PCAG1 * yes, process * process vars and constants ADB CON1 * subtract 1 from B (token adr) LDA 1,I * get link data at loc B ADA CON1 * subtract one from A (end adr) LDB 0,I * get variable or constant at loc A JMP PCAG2 * inc, save and exit PCAG1 ISZ IR * increment IR to point to constant LDB IR,I * get constant PCAG2 ISZ IR * increment IR again to -> to next token STB VTES1 * save constant JMP PCAGP,I * exit PCAC3 OCT 3 * CASLV OCT 0 * case level - act only if = 0 ACASE DEF PCASE * address of CASE AEQ DEF PEQ * address of = ALT DEF PLT * address of < AGT DEF PGT * address of > ALTE DEF PLTE * address of <= AGTE DEF PGTE * address of >= ANEQ DEF PNEQ * address of <> ADFLT DEF PDFLT * address of DEFAULT AECAS DEF PECAS * address of ENDCASE ALPSH DEF PLPSH * address of literal push ASTRP DEF PSTRP * address of string push VTEST EQU TMP1 * stored stack, what to test VTES1 EQU TMP2 * parm to test against * PCASZ EQU * * * Comparisons.. run time behavior is to skip to after * (corresponding) ENDCASE and resume execution. * DEC 1 ASC 2,= * "=" DEF PEQZ PEQ DEF *+1 PEQE CLA * zero STA CASLV * case level PEQL JSB PCANX * get next token CPA ACASE * is it "CASE"? JMP PEICL * yes, increment case level (cl) CPA AECAS * is it "ENDCASE"? JMP PEDCL * yes, exit if cl=0 else dec cl JMP PEQL * no keep looping PEICL ISZ CASLV * for CASE.. increment cl JMP PEQL * keep looping PEDCL LDA CASLV * for ENDCASE.. get cl SZA,RSS * skip if cl>0 JMP ZNXT,I * exit if cl=0 ADA CON1 * subtract 1 STA CASLV * save back to cl JMP PEQL * keep looping PEQZ EQU * * DEC 1 ASC 2,< * "<" DEF PLTZ PLT DEF *+1 JMP PEQE PLTZ EQU * * DEC 1 ASC 2,> * ">" DEF PGTZ PGT DEF *+1 JMP PEQE PGTZ EQU * * DEC 2 ASC 2,<= * "<=" DEF PLTEZ PLTE DEF *+1 JMP PEQE PLTEZ EQU * * DEC 2 ASC 2,>= * ">=" DEF PGTEZ PGTE DEF *+1 JMP PEQE PGTEZ EQU * * DEC 2 ASC 2,<> * "<>" DEF PNEQZ PNEQ DEF *+1 JMP PEQE PNEQZ EQU * * * "DEFAULT" - labels lines to run if no condition is true * run-time behavior same as comparisons * DEC 7 ASC 2,DEFA DEF PDFTZ PDFLT DEF *+1 JMP PEQE PDFTZ EQU * * * "ENDCASE" - terminates a CASE structure * no run-time behavior * DEC 7 ASC 2,ENDC DEF PECSZ PECAS DEF *+1 JMP ZNXT,I PECSZ EQU * * * everything below here safe from console... * CONSA EQU * * at console BEGOD set to this * * EXECUTE POPS A WORD ADDRESS OFF THE SYSTEM STACK * AND EXECUTES CODE AT THAT WORD ADDRESS * OCT 000007 * LENGHT IN CHARS ASC 2,EXEC * "EXECUTE" DEF EXECZ * POINTER TO NEXT ENTRY PEXEC DEF EXEC+1 EXECZ EQU * * * OCT 000005 * LENGHT IN CHARS ASC 2,WBOO * "WBOOT" DEF WBOOZ * POINTER TO NEXT ENTRY PWBOO DEF WBOOT * run warm-boot code WBOOZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,AND * "AND" DEF PANDZ * POINTER TO NEXT ENTRY PAND DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG STA TMP1 * TO TEMP 1 JSB ZSPOP,I * STACK2 TO A REG AND TMP1 * A = STACK1 AND STACK2 JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF AND PANDZ EQU * * * OCT 000002 * LENGHT IN CHARS ASC 2,OR * "OR" DEF PORZ * POINTER TO NEXT ENTRY POR DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG STA TMP1 * TO TEMP 1 JSB ZSPOP,I * STACK2 TO A REG IOR TMP1 * A = STACK1 OR STACK2 JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF OR PORZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,XOR * "XOR" DEF PXORZ * POINTER TO NEXT ENTRY PXOR DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG STA TMP1 * TO TEMP 1 JSB ZSPOP,I * STACK2 TO A REG XOR TMP1 * A = STACK1 XOR STACK2 JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF XOR PXORZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,ADD * "ADD" DEF PADDZ * POINTER TO NEXT ENTRY PADD DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG STA TMP1 * TO TEMP 1 JSB ZSPOP,I * STACK2 TO A REG ADA TMP1 * A = STACK1 + STACK2 JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF ADD PADDZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,SUB * "SUB" DEF PSUBZ * POINTER TO NEXT ENTRY PSUB DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG STA TMP1 * TO TEMP 1 JSB ZSPOP,I * STACK2 TO A REG STA TMP2 * to temp 2 CLO * clear overflow CLE * and extend bits LDA TMP1 * get first popped, last pushed CMA,INA * 2'S COMPLEMENT A REG ADA TMP2 * A = STACK2 - STACK1 JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF SUB PSUBZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,INC * "INC" DEF PINCZ * POINTER TO NEXT ENTRY PINC DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG INA * INCREMENT VALUE JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF INC PINCZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,DEC * "DEC" DEF PDECZ * POINTER TO NEXT ENTRY PDEC DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG ADA CON1 * ADD -1 TO DECREMENT JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF DEC PDECZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,NOT * "NOT" DEF PNOTZ * POINTER TO NEXT ENTRY PNOT DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG CMA * COMPLEMENT VALUE JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF NOT PNOTZ EQU * * * OCT 000004 * LENGHT IN CHARS ASC 2,2CPL * "2CPL" DEF P2CLZ * POINTER TO NEXT ENTRY P2CPL DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG CMA,INA * 2'S COMPLEMENT VALUE JSB ZSPSH,I * SAVE RESULT TO STACK JMP ZNXT,I * END OF 2CPL P2CLZ EQU * * * OCT 000003 * LENGTH IN CHARS ASC 2,DUP * "DUP" DEF PDUPZ * POINTER TO NEXT ENTRY PDUP DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG JSB ZSPSH,I * RESTORE VALUE TO STACK JSB ZSPSH,I * DUPLICATE VALUE JMP ZNXT,I * END OF DUP PDUPZ EQU * * * OCT 000004 * LENGHT IN CHARS ASC 2,DROP * "DROP" DEF PDROZ * POINTER TO NEXT ENTERY PDROP DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG JMP ZNXT,I * END OF DROP PDROZ EQU * * * OCT 000004 * LENGHT IN CHARS ASC 2,OVER * "OVER" DEF POVEZ * POINTER TO NEXT ENTRY POVER DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG STA TMP1 * STACK1 TO TMP1 JSB ZSPOP,I * STACK2 TO A REG STA TMP2 * STACK2 TO TMP2 JSB ZSPSH,I * RESTORE STACK2 TO STACK LDA TMP1 * GET STACK1 VALUE JSB ZSPSH,I * RESTORE STACK1 TO STACK LDA TMP2 * GET STACK2 VALUE AGAIN JSB ZSPSH,I * PUT STACK2 VALUE ON STACK JMP ZNXT,I * END OF OVER POVEZ EQU * * * OCT 000003 * LENGHT ON CHARS ASC 2,ROT * "ROT" DEF PROTZ * POINTER TO NEXT ENTRY PROT DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG STA TMP1 * STACK1 TO TMP1 JSB ZSPOP,I * STACK2 TO A REG STA TMP2 * STACK2 TO TMP2 JSB ZSPOP,I * STACK3 TO A REG STA TMP3 * STACK3 TO TMP3 LDA TMP2 * GET STACK2 VALUE JSB ZSPSH,I * RESTORE TO STACK LDA TMP3 * GET STACK3 VALUE JSB ZSPSH,I * RESTORE TO STACK LDA TMP1 * GET STACK1 VALUE JSB ZSPSH,I * RESTORE TO STACK JMP ZNXT,I * END OF ROT PROTZ EQU * * * OCT 000004 * LENGHT IN CHARS ASC 2,SWAP * "SWAP" DEF PSWAZ * POINTER TO NEXT ENTRY PSWAP DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * STACK1 TO A REG STA TMP1 * STACK1 TO TMP1 JSB ZSPOP,I * STACK2 TO A REG STA TMP2 * STACK2 TO TMP2 LDA TMP1 * GET STACK1 VALUE JSB ZSPSH,I * RESTORE TO STACK LDA TMP2 * GET STACK2 VALUE JSB ZSPSH,I * RESTORE TO STACK JMP ZNXT,I * END OF SWAP PSWAZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,GET * "GET " DEF PGETZ * POINTER TO NEXT ENTRY PGET DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * GET ADDRESS FROM STACK STA TMP1 * SAVE ADDRESS IN TMP1 LDA TMP1,I * GET CONTENTS OF ADDRESS JSB ZSPSH,I * SAVE DATA TO STACK JMP ZNXT,I * END OF GET PGETZ EQU * * * OCT 000003 * LENGHT IN CHARS ASC 2,PUT * "PUT " DEF PPUTZ * POINTER TO NEXT ENTRY PPUT DEF *+1 * CODE ADDRESS POINTER JSB ZSPOP,I * GET DATA FROM STACK STA TMP1 * SAVE DATA IN TMP1 JSB ZSPOP,I * GET DESTINATION ADDRESS STA TMP2 * SAVE TARGET ADDRESS LDA TMP1 * GET DATA AGAIN STA TMP2,I * WRITE IT TO TARGET ADDRESS JMP ZNXT,I * END OF PUT PPUTZ EQU * * * DEC 4 ASC 2,PNUM * "PNUM" - print number at top of sstack DEF PPNUZ * next entry PPNUM DEF ENSEC * enter secondary DEF PSSTR * $STR - convert number into string DEF PPSTR * $PRINT - print the string DEF PLPSH * literal push OCT 40 * 40 a space DEF PPCHR * PCHR print space DEF RTSEC * return from secondary PPNUZ EQU * * * DEC 4 ASC 2,CRLF * "CRLF" - print a crlf to device DEF PCRLZ PCRLF DEF ENSEC DEF PLPSH OCT 6412 DEF PPWRD DEF RTSEC PCRLZ EQU * * * DEC 7 ASC 2,DECI * "DECIMAL" - set radix to 10 DEF PDCMZ PDECI DEF *+1 LDA PDEPR * get conversion preferences STA W2FLG * tell W2ASC LDA PDETP * get table pointer PDECO STA TMP1 * save in tmp1 LDB ANRVA * get address of radix variables in B PDECL LDA TMP1,I * get new value SZA,RSS * skip if word<>0 JMP ZNXT,I * done - exit STA 1,I * store in radix variables INB * increment destination pointer ISZ TMP1 * increment source pointer (never 0) JMP PDECL * loop until done PDEWY JMP PDEWY * disaster trap PDEPR OCT 3 * W2FLG preferences, 3=lzs,show - PDETP DEF PDETB * table/variables for base 10 PDETB DEC 10 * radix 10 OCT 177766 * 2's comp of radix DEF ANMUT+4 * location of 1's multiplier DEC 10000 * multiply table DEC 1000 DEC 100 DEC 10 DEC 1 OCT 0 * end of table PDCMZ EQU * * * DEC 5 ASC 2,OCTA * "OCTAL" - set radix to 8 DEF POCTZ POCTA DEF *+1 CLA STA W2FLG * disable lzs and show minus flags LDA POCTP STA TMP1 JMP PDECO * cheating, jumping to code in decimal POCTP DEF POCTB * variables for base 8 POCTB DEC 8 * radix = 8 OCT 177770 * 2's compliment DEF ANMUT+5 * 6 multiplier values OCT 100000 OCT 10000 OCT 1000 OCT 100 OCT 10 OCT 1 OCT 0 * end of table POCTZ EQU * * * DEC 6 ASC 2,BINA * "BINARY" - set radix to 2 DEF PBINZ PBINA DEF *+1 CLA STA W2FLG * disable lzs and show minus flags LDB ANRVA * get location of radix vars in B LDA PBIC2 * get 2 STA 1,I * store 2 in radix INB * increment destination pointer CMA,INA * 2's complement it STA 1,I * store 65536-2 in comp. radix INB * inc ptr LDA PBIOD * get position of x1 mult STA 1,I * store it INB * inc ptr LDA PBIMS * get starting value 32768 PBILP STA 1,I * store it INB * inc ptr CLE * clear extend bit ERA * rotate E+A right (/2) SZA * skip if 0 JMP PBILP * if not 0 keep looping JMP ZNXT,I * exit PBIC2 OCT 2 * a 2 constant PBIOD DEF ANMUT+15 * 16 mult-table entries PBIMS DEC 32768 * starting value for table PBINZ EQU * * * "RADIX" - pushes current radix * OCT 5 ASC 2,RADI DEF PRADZ PRADX DEF *+1 LDA ANRAD JSB ZSPSH,I JMP ZNXT,I PRADZ EQU * * * DEC 4 ASC 2,SP>S * "SP>S" - pushes stack pointer DEF PSP2Z PSP2S DEF *+1 LDA SP JSB ZSPSH,I JMP ZNXT,I PSP2Z EQU * * * DEC 4 ASC 2,SB>S * "SB>S" - pushes stack base DEF PSB2Z PSB2S DEF *+1 LDA STOP * get start of system stack JSB ZSPSH,I * push to system stack JMP ZNXT,I PSB2Z EQU * * * DEC 4 ASC 2,XP>S * "XP>S" - pushes X stack pointer DEF PXP2Z PXP2S DEF *+1 LDA XP JSB ZSPSH,I JMP ZNXT,I PXP2Z EQU * * * DEC 4 ASC 2,XB>S * "XB>S" - pushes X stack base DEF PXB2Z PXB2S DEF *+1 LDA XTOP JSB ZSPSH,I JMP ZNXT,I PXB2Z EQU * * * DEF 4 ASC 2,YP>S * "YP>S" - pushes Y stack pointer DEF PYP2Z PYP2S DEF *+1 LDA YP JSB ZSPSH,I JMP ZNXT,I PYP2Z EQU * * * DEC 4 ASC 2,YB>S * "YB>S" - pushes Y stack base DEF PYB2Z PYB2S DEF *+1 LDA YTOP JSB ZSPSH,I JMP ZNXT,I PYB2Z EQU * * * DEC 4 ASC 2,ZP>S * "ZP>S" - pushes Z stack pointer DEF PZP2Z PZP2S DEF *+1 LDA ZP JSB ZSPSH,I JMP ZNXT,I PZP2Z EQU * * * DEC 4 ASC 2,ZB>S * "ZB>S" - pushes Z stack base DEF PZB2Z PZB2S DEF *+1 LDA ZTOP JSB ZSPSH,I JMP ZNXT,I PZB2Z EQU * * * DEC 3 ASC 2,END * "END" - end a definition DEF PENDZ PENDD DEF *+1 JMP ZNXT,I * do nothing, here just to match PENDZ EQU * * * "EOD" - calculates and pushes end of dictionary * *@USR GET ;get start of user dictionary *DO ;loop until end found... * DUP GET ;dup pointer and get memdata * DUP IFNZ ;if memdata<>0... * DROP 3 ADD ;drop memdata, add 3 to pointer * GET #1 ;get new pointer at link, keep looping * ENDIF *WHILE ;pop and loop while not-zero *END * This was ok but had major side effects if you manually forget * words before the @USR point. This was to speed up searches but * can make more reliable and faster too if machine coded... * OCT 3 ASC 2,EOD 1/29/08 DEF PEODZ PEOD DEF *+1 LDA DTOP get start of dictionary PEODL LDB 0,I get data at location A SZB,RSS skip next if B not 0 JMP PEODP done, push A ADA PEOD3 point A to link LDB 0,I get data at location A LDA 1 put back in A JMP PEODL loop until end is found PEODP JSB ZSPSH,I push end of dictionary JMP ZNXT,I back to hpiplos PEOD3 OCT 3 constant, link offset PEODZ EQU * * * "DEFINE" - compile definition * Compiles input and adds to dictionary, terminate * definition with END to return to the console. * 0.35 - requires EOD definition * 0.42 - fixed double not-found bug * 0.44 - error if no parm specified * 1.6 6/2/10 - modified to use alternate DPUT code to avoid overflow * DEC 6 ASC 2,DEFI DEF DEFIZ * determine name of definition to define... DEF ENSEC * enter secondary DEF TOKEN * get next token for name DEF TEST * test return value DEF DE090 * branch to rtsec if no name * fix so flow control can compile... DEF PLPSH * push DEF BEGOD * address of BEGOD DEF PLPSH * push DEF DIC00 * true start of dictionary DEF DPUT * write to BEGOD * determine end of dictionary... DEF PEOD * push end-of-dictionary (new) DEF PDUP * duplicate to go back and enable * end of definitions (and copy) found and at top of stack * next compile the definition to a real thread... * To do this and make use of TOKEN, SDIC etc we'll run our * own outer interpreter, but instead of executing, add the * addresses (and literals) as entered until END is entered. * Sounds reasonable.. one artifact is because there is * no way to (easily) get to TOKEN's previous end-of-line * flag no choice but start a new line, therefore DEFINE * followed by name of definition should be entered by itself * to start the compile. Terminate definition by entering END. * * TL,TB1,TB2 contains name info to define.. * come back and fix TL later (so SDIC will work!) but * still have to put the value somewhere (using TOKEN changes) DEF PATL * push address of TL DEF PGET * get data of TL (rep adr) DEF PSWAP * swap with code pointer to save DEF PINC * increment code pointer DEF PDUP * push pointer DEF PATB1 * push address of TB1 DEF PGET * replace with data at TB1 DEF DPUT * write it DEF PINC * increment code pointer DEF PDUP * push current pointer DEF PATB2 * push address of TB2 DEF PGET * replace with data at TB2 DEF DPUT * write it DEF PINC * increment code pointer * code pointer now pointing to link position.. don't * know yet so need to save this point.. DEF PDUP DEF PINC * point to where first "instruction" will go * start thread off with a enter-secondary code DEF PDUP * push code pointer DEF PAESC * push address of enter-secondary DEF DPUT * write it DEF PINC * increment code pointer * now there is the original entry point, saved TL value, * address of link and current code pointer on the stack * the initial len and link are still 0 but the name and * initial ensec code are written to code memory * * change to "> " cursor... DEF DEFCU * use headerless ML DE020 DEF CONIN * get new command line DE030 DEF TOKEN * parse it DEF TEST * check for end of line DEF DE020 * if at end get new line DEF PDUP * duplicate code pointer * so that put at DE120 will have an "eatable" address * there are some disadvantages to stack-computing.. * will be easier when there are variables... DEF SDIC * search dictionary DEF TEST * match found? DEF DE100 * yes - compile it DEF DSERR * print "TOKEN NOT FOUND" * updated 1/4/04 - use warm boot to exit, 5 drops removed DEF NORCU * restore normal cursor (headerless ML) DEF PWBOO * warm boot the system to exit DE090 DEF RTSEC * return from secondary DE100 DEF PDUP * duplicate sdic results * the address returned by SDIC and a copy is on system stack, * can copy to code as-is with a few exceptions... * if =LITRA then substitute PLPSH followed by value at ANVAL * if =PEND then compile a RTSEC and exit define * if =SHANA then get string and compile to use PSTRP * if =CMTHA then ignore token DEF PLPSH * push DEF LITRA * literal handler code address DEF PSUB * subtract DEF TEST * check for 0 DEF DE110 * goto DE110 if not 0 DEF GOTO * goto DEF DE200 * threadling to handle literals DE110 DEF PDUP * dup sdic results DEF PLPSH * push DEF PENDD * end token address DEF PSUB * subtract DEF TEST * check for 0 DEF DE120 * goto DE120 if not 0 DEF GOTO * goto DEF DE300 * threadling to handle END * modified to compile strings... DE120 DEF PDUP * push sdic results DEF PLPSH * push DEF SHANA * string handler address DEF PSUB * subract the two DEF TEST * check for zero DEF DE125 * goto DE125 if not 0 DEF GOTO DEF DE400 * goto string compiler * modified to ignore comments... DE125 DEF PDUP DEF PLPSH DEF CMNTA * comment "handler" address DEF PSUB DEF TEST DEF DE130 * goto DE130 if not a comment DEF PDROP * drop the comment token DEF PDROP * drop temp address to write to DEF GOTO DEF DE030 * next token, pointer unchanged * compile token as is DE130 DEF DPUT * write the data from sdic DEF PINC * bump the pointer DEF GOTO * goto DEF DE030 * next token * handle literals... DE200 DEF PDROP * discard literal handler token * already have a duplicate code pointer DEF PALIP * push push code DEF DPUT * write the push code DEF PINC * increment code pointer DEF PDUP * push code pointer DEF PLPSH * push DEF ANVAL * address of literal value DEF PGET * get actual value DEF DPUT * write it DEF PINC * increment code pointer DEF GOTO * goto DEF DE030 * next token * handle end of definition... DE300 DEF PDROP * discard end token * duplicate code pointer on stack DEF PARTS * push return-from-secondary code DEF DPUT * write the code DEF PINC * increment code pointer DEF PDUP * push duplicate DEF PCS0 * push 0 to terminate chain DEF DPUT * write 0 to new end-of-dictionary * 6/3/10 - update DIPTR so it points to end+1 DEF PADPT * push DIPTR address DEF POVER * push pointer DEF PINC * bump it DEF PPUT * save updated DIPTR * now need to write the current code pointer value * to the link address saved earlier, since that address * is one down on the stack... DEF DPUT * write code pointer to link address * stack should now contain saved original start followed * by the saved TL value.. easy enough... DEF DPUT * write it DEF NORCU * restore normal cursor DEF RTSEC * end sub * * compile strings... DE400 DEF PDROP * pop sdic results to nothing DEF SHANA * execute the console string handler * leaves string+len on X stack, now to compile... DEF PASTP * push address of threaded string handler DEF DPUT * write the push code (eat dup c.p.) DEF PINC * increment code pointer DEF DE500 * don't care to do with a thread.. DEF GOTO * goto DEF DE030 * next token DE500 DEF *+1 * switching to machine code... * pop length from X and write to tos, inc tos, * if len<>0 pop len words from X and write to code pointed to by tos * leave tos pointing to next code item * tricky - have to reverse order!!! * trickier yet - have to keep from overwriting block memory JSB ZXPOP,I * pop X stack - should be len STA DE590 * save it JSB ZSPOP,I * pop code pointer JSB DEVDA,I * validate 6/2/10 LDB DE590 * get len STB 0,I * store in definition INA * inc code pointer in A JSB ZSPSH,I * push back to stack LDB DE590 * get length SZB,RSS * skip if not 0 JMP ZNXT,I * empty string, done (ret to de400/goto) STA DE591 * save code pointer (start of str field) JSB ZSPOP,I * pop stack ADA DE590 * add length JSB ZSPSH,I * push back ADA CON1 * subtract 1 DE510 JSB DEVDA,I * validate 6/2/10 STA DE590 * save in working pointer JSB ZXPOP,I * pop double char STA DE590,I * store in str field starting at end LDA DE590 * get pointer CPA DE591 * equal to start of str field? JMP ZNXT,I * yes - everything done ADA CON1 * subtract 1 JMP DE510 * keep looping DE590 OCT 0 * length/pointer DE591 OCT 0 * start of str field DEVDA DEF DEVDT * 6/2/10 address of validate sub * These are used by DEFINE to change cursor DEFCU DEF *+1 LDA PRMPT * get existing prompt STA NORCW * save it LDA DEFCW * get prompt for define mode DEFC1 STA PRMPT * save in prompt location JMP ZNXT,I NORCU DEF *+1 LDA NORCW * get normal prompt JMP DEFC1 * save a word DEFCW OCT 37040 * "> " for define NORCW OCT 37440 * (normally) "? " for normal DEFIZ EQU * * * * DEC 4 ASC 2,DMPS * "DMPS" - dump stack (4/3/02) DEF DMPSZ * DEF ENSEC * begin sub DEF PSB2S * from stack base DEF PSP2S * to current stack pointer DEF PDEC * minus 1 to compensate for prev DEF PSUB * subtract, leave result on stack DEF PIFNZ * if not zero... DEF PSB2S * repeat initial pushes.. stack base DEF PSP2S * current stack pointer DEF PDEC * minus 1 for 1st push DEF PDEC * and again because sp->1st unused pos. DEF PPDO * do DEF PINDX * push current do index to stack DEF PGET * change to memory location contents DEF PCRLF * print newline DEF PPNUM * pop and print number DEF PPLOO * loop DEF PCRLF * another newline so last val stands out DEF PENDI * end if DEF RTSEC * end sub DMPSZ EQU * * * OCT 4 ASC 2,S>SR * "S>SR" - pop stack and write to switches DEF PSSRZ PS2SR DEF *+1 JSB ZSPOP,I * pop stack OTA 01 * write to SR JMP ZNXT,I PSSRZ EQU * * * OCT 4 ASC 2,SR>S * "SR>S" - read switches and push to stack DEF PSRSZ PSR2S DEF *+1 LIA 01 * read switches JSB ZSPSH,I * push to stack JMP ZNXT,I PSRSZ EQU * * * OCT 4 ASC 2,PCHR * "PCHR" - pop stack and print char DEF PPCHZ * redirectable by changing ZOUT PPCHR DEF *+1 JSB ZSPOP,I * pop stack to A JSB ZOUT,I * print character in A to device JMP ZNXT,I PPCHZ EQU * * * OCT 4 ASC 2,PWRD * "PWRD" - pop stack and print 2 chars DEF PPWRZ * redirectable by changing ZOUT PPWRD DEF *+1 JSB ZSPOP,I * get word JSB ZSPSH,I * put back to get again AND PPWR2 * zero low byte ALF,ALF * swap bytes JSB ZOUT,I * output 1st char JSB ZSPOP,I * get word again AND PPWR1 * zero high byte JSB ZOUT,I * output 2nd char JMP ZNXT,I PPWR1 OCT 377 PPWR2 OCT 177400 PPWRZ EQU * * * "CHRIN" - gets one character from device and pushes * OCT 5 ASC 2,CHRI DEF PCHIZ PCHRI DEF *+1 JSB ZIN,I * get character from device JSB ZSPSH,I * push it JMP ZNXT,I PCHIZ EQU * * * OCT 3 ASC 2,S>X * "S>X" - pop S and push to X DEF PS2XZ PSTOX DEF *+1 JSB ZSPOP,I JSB ZXPSH,I JMP ZNXT,I PS2XZ EQU * * * OCT 3 ASC 2,X>S * "X>S" - pop X and push to S DEF PX2SZ PXTOS DEF *+1 JSB ZXPOP,I JSB ZSPSH,I JMP ZNXT,I PX2SZ EQU * * * OCT 3 ASC 2,S>Y * "S>Y" - pop S and push to Y DEF PS2YZ PSTOY DEF *+1 JSB ZSPOP,I JSB ZYPSH,I JMP ZNXT,I PS2YZ EQU * * * OCT 3 ASC 2,Y>S * "Y>S" - pop Y and push to S DEF PY2SZ PYTOS DEF *+1 JSB ZYPOP,I JSB ZSPSH,I JMP ZNXT,I PY2SZ EQU * * * OCT 3 ASC 2,S>Z * "S>Z" - pop S and push to Z DEF PS2ZZ PSTOZ DEF *+1 JSB ZSPOP,I JSB ZZPSH,I JMP ZNXT,I PS2ZZ EQU * * * OCT 3 ASC 2,Z>S * "Z>S" - pop Z and push to S DEF PZ2SZ PZTOS DEF *+1 JSB ZZPOP,I JSB ZSPSH,I JMP ZNXT,I PZ2SZ EQU * * * "MUL" - pop two values from stack, multiply and push results * OCT 3 ASC 2,MUL 1/29/08 DEF PMULZ PMULT DEF *+1 JSB ZSPOP,I * pop and store operands STA TMP1 JSB ZSPOP,I STA TMP2 CLA STA MLTAC * clear accumulator INA STA MLTMS * init mask to 1 MLT10 LDA TMP2 * loop - get 2nd operand AND MLTMS * and with mask SZA,RSS * skip if not zero JMP MLT20 * bit is zero - no sum LDA TMP1 * get operand 1 ADA MLTAC * accumulate STA MLTAC * store MLT20 LDA TMP1 * get operand 1 CLE,ELA * shift left STA TMP1 * save shifted operand 1 LDA MLTMS * get mask CLE,ELA * shift left STA MLTMS * save shifted mask SEZ,RSS * skip if E set JMP MLT10 * do it until done LDA MLTAC * get results JSB ZSPSH,I * push JMP ZNXT,I * exit def MLTMS EQU TMP3 * rotating bit mask MLTAC EQU TMP4 * accumulate results PMULZ EQU * * * "ASL" - arithmetic shift left (multiply by 2) * OCT 3 ASC 2,ASL 1/29/08 DEF PASLZ PASL DEF *+1 JSB ZSPOP,I CLE,ELA JSB ZSPSH,I JMP ZNXT,I PASLZ EQU * * * "ASR" - arithmetic shift right (divide by 2) * OCT 3 ASC 2,ASR 1/29/08 DEF PASRZ PASR DEF *+1 JSB ZSPOP,I CLE,ERA JSB ZSPSH,I JMP ZNXT,I PASRZ EQU * * * "ROL" - rotate left * OCT 3 ASC 2,ROL 1/29/08 DEF PROLZ PROL DEF *+1 JSB ZSPOP,I RAL JSB ZSPSH,I JMP ZNXT,I PROLZ EQU * * * "ROR" - rotate right * OCT 3 ASC 2,ROR 1/29/08 DEF PRORZ PROR DEF *+1 JSB ZSPOP,I RAR JSB ZSPSH,I JMP ZNXT,I PRORZ EQU * * * "DIV" - pop 2, divide 2nd by 1st and push results * OCT 3 ASC 2,DIV 1/29/08 DEF PDIVZ PDIV DEF *+1 JSB ZSPOP,I * pop stack STA DIVDR * store in divisor JSB ZSPOP,I * pop stack STA DIVDD * store in dividend LDA DIVNL * get number of iterations STA DIVCT * store in count CLA STA DIVAR * clear "a" register DIVUP LDA DIVDD * get dividend CLE,ELA * arithmetic shift left STA DIVDD * save dividend LDA DIVAR * get register ELA * shift E into it STA DIVAR * save it LDA DIVDR * get divisor CMA,INA * 2's complement ADA DIVAR * A=DIVAR-DIVDR SSA JMP DIVDN * jump if sign set LDA DIVDR * get divisor CMA,INA * 2's complement ADA DIVAR * A="a" register - divisor STA DIVAR * save back in "a" register DIVDN LDA DIVQU * get quotient ELA * shift left feeding in E STA DIVQU * save it LDA DIVCT * get count ADA CON1 * subtract 1 STA DIVCT * save count SZA * skip if A=0 JMP DIVUP * otherwise keep looping LDA DIVQU * get quotient JSB ZSPSH,I * push to stack JMP ZNXT,I * exit DIVNL DEC 16 * #iterations DIVCT OCT 0 * a counter DIVAR EQU TMP1 * "a" register DIVDR EQU TMP2 * divisor - divide by this DIVDD EQU TMP3 * dividend - what's being divided DIVQU EQU TMP4 * quotient deposited here PDIVZ EQU * * * OCT 3 ASC 2,RUN * "RUN" - pop stack and execute ML there DEF PRUNZ PRUN DEF ENSEC DEF PLPSH * push DEF PRUN9 * address of private var DEF PSWAP * swap with address on stack DEF PPUT * store address in private var DEF PLPSH * push DEF PRUN9 * address of private var DEF EXEC * execute it DEF RTSEC PRUN9 OCT 0 * storage for address to execute PRUNZ EQU * * * OCT 4 ASC 2,X>>Y * "X>>Y" - pop string from X and push to Y DEF PX2YZ PXTOY DEF *+1 JSB ZXPOP,I * pop length of string from X stack STA TMP1 * TMP1 = string length X2Y10 STA TMP2 * TMP2 = remaining length SZA,RSS * skip if remaining length <> 0 JMP X2Y20 * done storing to Z, now reverse to Y JSB ZXPOP,I * pop from X JSB ZZPSH,I * push to Z LDA TMP2 * get remaining count ADA CON1 * subtract 1 JMP X2Y10 * save remaining and loop X2Y20 LDA TMP1 * get original length X2Y30 STA TMP2 * store in remaining SZA,RSS * skip if remaining <> 0 JMP X2Y40 * done reversing, save length JSB ZZPOP,I * pop from Z JSB ZYPSH,I * push to Y LDA TMP2 * get remaining ADA CON1 * subtract 1 JMP X2Y30 * save remaining and loop X2Y40 LDA TMP1 * get string length JSB ZYPSH,I * push to Y JMP ZNXT,I * all done PX2YZ EQU * * * OCT 4 ASC 2,X>>Z * "X>>Z" - pop string from X and push to Z DEF PX2ZZ PXTOZ DEF *+1 JSB ZXPOP,I * pop length of string from X stack STA TMP1 * TMP1 = string length X2Z10 STA TMP2 * TMP2 = remaining length SZA,RSS * skip if remaining length <> 0 JMP X2Z20 * done storing to Y, now reverse to Z JSB ZXPOP,I * pop from X JSB ZYPSH,I * push to Y LDA TMP2 * get remaining count ADA CON1 * subtract 1 JMP X2Z10 * save remaining and loop X2Z20 LDA TMP1 * get original length X2Z30 STA TMP2 * store in remaining SZA,RSS * skip if remaining <> 0 JMP X2Z40 * done reversing, save length JSB ZYPOP,I * pop from Y JSB ZZPSH,I * push to Z LDA TMP2 * get remaining ADA CON1 * subtract 1 JMP X2Z30 * save remaining and loop X2Z40 LDA TMP1 * get string length JSB ZZPSH,I * push to Z JMP ZNXT,I * all done PX2ZZ EQU * * * OCT 4 ASC 2,Y>>X * "Y>>X" - pop string from Y and push to X DEF PY2XZ PYTOX DEF *+1 JSB ZYPOP,I * pop length of string from Y stack STA TMP1 * TMP1 = string length Y2X10 STA TMP2 * TMP2 = remaining length SZA,RSS * skip if remaining length <> 0 JMP Y2X20 * done storing to Z, now reverse to X JSB ZYPOP,I * pop from Y JSB ZZPSH,I * push to Z LDA TMP2 * get remaining count ADA CON1 * subtract 1 JMP Y2X10 * save remaining and loop Y2X20 LDA TMP1 * get original length Y2X30 STA TMP2 * store in remaining SZA,RSS * skip if remaining <> 0 JMP Y2X40 * done reversing, save length JSB ZZPOP,I * pop from Z JSB ZXPSH,I * push to X LDA TMP2 * get remaining ADA CON1 * subtract 1 JMP Y2X30 * save remaining and loop Y2X40 LDA TMP1 * get string length JSB ZXPSH,I * push to X JMP ZNXT,I * all done PY2XZ EQU * * * OCT 4 ASC 2,Z>>X * "Z>>X" - pop string from Z and push to X DEF PZ2XZ PZTOX DEF *+1 JSB ZZPOP,I * pop length of string from Z stack STA TMP1 * TMP1 = string length Z2X10 STA TMP2 * TMP2 = remaining length SZA,RSS * skip if remaining length <> 0 JMP Z2X20 * done storing to Y, now reverse to X JSB ZZPOP,I * pop from Z JSB ZYPSH,I * push to Y LDA TMP2 * get remaining count ADA CON1 * subtract 1 JMP Z2X10 * save remaining and loop Z2X20 LDA TMP1 * get original length Z2X30 STA TMP2 * store in remaining SZA,RSS * skip if remaining <> 0 JMP Z2X40 * done reversing, save length JSB ZYPOP,I * pop from Y JSB ZXPSH,I * push to X LDA TMP2 * get remaining ADA CON1 * subtract 1 JMP Z2X30 * save remaining and loop Z2X40 LDA TMP1 * get string length JSB ZXPSH,I * push to X JMP ZNXT,I * all done PZ2XZ EQU * * * "$PRINT" - print string from X stack to output device * topmost item on X = number of 16bit words followed * by that many words. Next down on the stack is the * number of characters in the string. The word count * is used to calculate the starting address, then specified * number of characters are sent to the console * OCT 6 ASC 2,$PRI DEF PSOUZ PPSTR DEF *+1 JSB ZXPOP,I * pop #words in package SZA,RSS * skip if not 0 JMP ZNXT,I * bad data, exit ADA CON1 * decrement to compensate for char count STA PPSWC * save word count JSB ZXPOP,I * pop #chars in string SZA,RSS * skip if not 0 JMP ZNXT,I * empty string, exit STA PPSCC * save character count LDA PPSWC * get word count CMA,INA * 2's complement it LDB XP * get X stack pointer in B ADA 1 * A = SP - #double-chars STA PPSMP * save in memory pointer CLA STA PPSCP * clear character pointer PPST1 LDB PPSMP * get mem pointer LDA 1,I * get double char AND PPST3 * isolate high byte ALF,ALF * put in low byte JSB ZOUT,I * print character to device ISZ PPSCP * increment char pointer LDA PPSCP * get char pointer CPA PPSCC * = # chars? JMP PPST2 * yes, then clean up stack and exit LDB PPSMP * get mem pointer LDA 1,I * get double char AND PPST4 * isolate low char JSB ZOUT,I * print character to device ISZ PPSCP * increment char pointer LDA PPSCP * get char pointer CPA PPSCC * = # chars? JMP PPST2 * yes, then clean up stack and exit ISZ PPSMP * increment mem pointer JMP PPST1 * loop PPST2 LDA PPSWC * get word count SZA,RSS * skip if not zero JMP ZNXT,I * if zero then done, exit ADA CON1 * decrement word count STA PPSWC * and save JSB ZXPOP,I * pop one word from X stack to nothing JMP PPST2 * loop until all string words popped PPSCP OCT 0 * char pointer PPSMP OCT 0 * memory pointer PPSWC OCT 0 * #words PPSCC OCT 0 * #chars PPST3 OCT 177400 * top 8 1's PPST4 OCT 377 * bottom 8 1's PSOUZ EQU * * * "$SWAP" - swap string items on X * OCT 5 ASC 2,$SWA DEF PSSWZ PSSWP DEF ENSEC DEF PXTOY * X>>Y DEF PXTOZ * X>>Z DEF PYTOX * Y>>X DEF PZTOX * Z>>X DEF RTSEC PSSWZ EQU * * * "$CPY" - copy string on X to Y (uses Z) * OCT 4 ASC 2,$CPY DEF PSCPZ PSCPY DEF *+1 JSB ZXPOP,I * pop length STA TMP1 * save in temp SCP10 STA TMP2 * save in remaining SZA,RSS * skip if not 0 JMP SCP20 * otherwise jump to next part JSB ZXPOP,I * pop string JSB ZZPSH,I * push to Z LDA TMP2 * get remaining ADA CON1 * subtract 1 JMP SCP10 * save remaining and get more SCP20 LDA TMP1 * get length SCP30 STA TMP2 * save in remaining SZA,RSS * skip if not 0 JMP SCP40 * otherwise jump to finalize JSB ZZPOP,I * pop from Z JSB ZXPSH,I * write to X JSB ZYPSH,I * write to Y LDA TMP2 * get count ADA CON1 * one less JMP SCP30 * keep looping till copied SCP40 LDA TMP1 * get length JSB ZXPSH,I * push to X JSB ZYPSH,I * push to Y JMP ZNXT,I * all done PSCPZ EQU * * * "$DUP" - duplicate string on X stack * must be space on Y and Z to hold copies * OCT 4 ASC 2,$DUP DEF PSDUZ PSDUP DEF ENSEC * enter secondary DEF PSCPY * copy to Y DEF PYTOX * transfer to X DEF RTSEC * not much to this one thanks to $CPY PSDUZ EQU * * * "$DROP" - removes one string from X * OCT 5 ASC 2,$DRO DEF PSDRZ PSDRP DEF *+1 JSB ZXPOP,I * pop length SDRP1 STA TMP1 * save SZA,RSS * skip if not 0 JMP ZNXT,I * done JSB ZXPOP,I * remove from X LDA TMP1 * get remaining ADA CON1 * sub 1 JMP SDRP1 * loop PSDRZ EQU * * * "$LEN" - push character length of string on X to system stack * OCT 4 ASC 2,$LEN DEF PSLEZ PSLEN DEF ENSEC * enter secondary DEF PXTOS * X>S pop word count on X to S DEF PXTOS * X>S pop char count on X to S DEF PDUP * DUP duplicate S DEF PSTOY * S>Y save on Y DEF PSTOX * S>X put back char count DEF PSTOX * S>X put back word count DEF PYTOS * Y>S put result on sys stack DEF RTSEC * return from secondary PSLEZ EQU * * * "$ADR" - returns address of 1st word of string on X * string not affected, address left on system stack. * No bounds checking! don't use on non string data! * If used on 0-length string, points to char-count (0) * OCT 4 ASC 2,$ADR DEF PSADZ PSADR DEF ENSEC * enter secondary DEF PXTOS * X>S pop word count on X, push to S DEF PXP2S * XP>S push XP to S (=adr of word count now) DEF PSWAP * SWAP swap pointer and word count DEF PDUP * DUP duplicate word count DEF PSTOX * S>X put word count back on X DEF PSUB * SUB subtract count from end, adr on stack DEF RTSEC * return from secondary PSADZ EQU * * * "$XTEST" - checks address on stack (preserves) does * nothing if ok, else prints error and restarts hpiplos * OCT 6 ASC 2,$XTE DEF PXTSZ PXTST DEF *+1 JSB ZSPOP,I * pop system stack JSB ZSPSH,I * put back STA TMP4 * save in MLATS's input reg JSB MLATS * call address-test subroutine JMP ZNXT,I * if it got here everything's cool * Address Test Subroutine (other ML calls this for their testing) * entry - TMP4 contains address to test to see if within X bounds * exit - does nothing if OK, else halts with string error MLATS NOP LDA XTOP * get X stack base CMA,INA * make -XB to subtract ADA TMP4 * get startadr - XB (should be >=0) SSA * skip to continue tests if bit15 clear JMP MLATE * jump to error if start adr < XP LDA TMP4 * get startadr CMA,INA * make negative to subtract ADA XLIM * get XLIM - startadr SSA,RSS * skip to error if start adr > XLIM JMP MLATS,I * return from subroutine * anything can jump here and halt/restart with string error MLATE LDA MLAT8 * load error message word len LDB MLAT9 * load error message address JSB ZPBFL,I * print message JMP WBVEC,I * warm-boot the system MLAT8 OCT 6 MLAT9 DEF *+1 ASC 6,STRING ERROR PXTSZ EQU * * * "$PUT" - put bytes into a string by element number * Usage: element# byte $PUT (element# starts at 0) * Exampe: OCTAL "HEY" 1 40 $PUT $PRINT prints "H Y" * Note - string must be large enough to handle! * Minimal safety checks, tests for valid string but * does not check to see if specified char is off the end * OCT 4 ASC 2,$PUT DEF PSPUZ PSPUT DEF ENSEC * enter secondary DEF PSWAP * SWAP swap element# and byte DEF PSADR * $ADR push string address to stack DEF PXTST * $XTEST test address - halt if invalid DEF PSWAP * SWAP swap starting address and element# * stack is now byte startadr element# (sp) DEF PDUP * DUP duplicate and DEF PSTOY * S>Y stash element# for later DEF PASR * ASR shift right to /2 to get word offset DEF PADD * ADD add to offset DEF PSWAP * SWAP swap to put byte on top * stack is now wordadr byte (sp) with element# on Y stack * if element# is even, then put byte in high byte else put in low byte DEF PYTOS * Y>S get back original element# DEF PCS1 * #1 bit 0 set DEF PAND * AND element# and 1 DEF PIFZ * IFZ if even then DEF PSPUH * put in high byte of wordadr DEF PELSE * ELSE DEF PSPUL * put in low byte of wordadr DEF PENDI * ENDIF DEF RTSEC * return from secondary PSPUH DEF *+1 * switch to machine code * on entry stack=wordadr byte * store byte in wordadr and remove items from stack JSB ZSPOP,I * pop stack to get byte ALF,ALF * put in high byte STA TMP4 * save in temp JSB ZSPOP,I * pop stack to get wordadr LDB 0 * put in B LDA 1,I * get existing data at wordadr AND PSPU1 * zero high, keep low IOR TMP4 * OR with new data STA 1,I * put back JMP ZNXT,I * back to thread PSPUL DEF *+1 JSB ZSPOP,I * pop stack to get byte STA TMP4 * put in temp JSB ZSPOP,I * pop stack to get wordadr LDB 0 * put in B LDA 1,I * get existing data at wordadr AND PSPU2 * zero low, keep high IOR TMP4 * OR with new data STA 1,I * put back JMP ZNXT,I * back to thread PSPU1 OCT 377 * keep low byte, zero high PSPU2 OCT 177400 * keep high byte, zero low PSPUZ EQU * * * "$GET" - get specified byte from string on X * Usage: element# $GET - pushes byte at element# to stack * String is not affected. No sanity checks. * OCT 4 ASC 2,$GET DEF PSGEZ PSGET DEF ENSEC * enter secondary DEF PSADR * get string starting address DEF PSWAP * SWAP swap starting address and element# DEF PDUP * DUP duplicate and DEF PSTOY * S>Y stash element# for later DEF PASR * ASR shift right to /2 to get word offset DEF PADD * ADD add to offset to get word address DEF PYTOS * Y>S get back original element# DEF PCS1 * #1 bit 0 set DEF PAND * AND element# and 1 DEF PIFZ * IFZ if even then DEF PSGEH * get and push high byte of wordadr DEF PELSE * ELSE DEF PSGEL * get and push low byte of wordadr DEF PENDI * ENDIF DEF RTSEC * return from secondary PSGEH DEF *+1 * machine code to push high byte JSB ZSPOP,I * pop word address LDB 0 * put in B LDA 1,I * get data AND PSPU2 * keep high, zero low ALF,ALF * swap bytes JSB ZSPSH,I * push to stack JMP ZNXT,I * back to thread PSGEL DEF *+1 JSB ZSPOP,I * pop word address LDB 0 * put in B LDA 1,I * get data AND PSPU1 * keep low, zero high JSB ZSPSH,I * push to stack JMP ZNXT,I * back to thread PSGEZ EQU * * * $CREATE - creates a string of repeating bytes * Usage: 10 0 $CREATE makes a string on X containing 10 0's * OCT 7 ASC 2,$CRE DEF PSCRZ PSCRE DEF ENSEC DEF PSCRD * machine code to make highbyte=lowbyte DEF PSTOZ * S>Z save byte to repeat DEF PDUP * DUP char count DEF PSTOY * S>Y save original count on Y DEF PINC * INC increment and DEF PASR * ASR /2 for #words DEF PDUP * DUP for if test DEF PIFNZ * IFNZ if not a zero-len string DEF PDUP * DUP duplicate #words DEF PCS1 * #1 push a 1 DEF PSWAP * SWAP for +DO order DEF PPDO * +DO do from 1 to #words DEF PZTOS * Z>S DEF PDUP * DUP DEF PSTOZ * S>Z DEF PSTOX * S>X push byte to repeat to X DEF PPLOO * +LOOP DEF PENDI * ENDIF DEF PZTOS * Z>S DEF PDROP * DROP discard repeating bytes DEF PYTOS * Y>S get string length DEF PSTOX * S>X push to X DEF PINC * INC increment word count DEF PSTOX * S>X push to X to finish string DEF RTSEC PSCRD DEF *+1 JSB ZSPOP,I * pop from stack STA TMP4 * save in temp ALF,ALF * swap bytes IOR TMP4 * OR with temp JSB ZSPSH,I * push back to stack JMP ZNXT,I PSCRZ EQU * * * "$STR" - pop number on stack and convert to string on X * OCT 4 ASC 2,$STR DEF PSSTZ PSSTR DEF *+1 JSB ZSPOP,I * pop system stack to A STA W2AIN * store in Word2AsciiIN location JSB ZW2A,I * call Word-to-Ascii subroutine LDA W2OUA * W2ASC's output buffer location STA TMP4 * save to TMP4 for pointer CLA * clear count STA TMP3 * save count in TMP3 PSSTL LDB TMP3 * loop - get count CPB W2LEN * done? B=len? JMP PSST4 * yes - jump to finish LDB TMP4 * get pointer LDA 1,I * get digit from W2ASC buffer LDB TMP3 * get count SLB * skip if count is even JMP PSST2 * jump if count is odd ALF,ALF * shift char to high byte JSB ZXPSH,I * push to X stack JMP PSST3 * continue to next PSST2 STA TMP2 * odd - save char in TMP2 JSB ZXPOP,I * pop high-char on X IOR TMP2 * OR with low-char JSB ZXPSH,I * push back to X PSST3 ISZ TMP3 * next - increment count ISZ TMP4 * increment buffer pointer JMP PSSTL * jump to loop for more PSST4 LDA W2LEN * get char length JSB ZXPSH,I * push to X INA * add 1 to length * CLE,ERA * shift right to /2 OCT 65 * make sure gets coded right INA * add 1 JSB ZXPSH,I * push word length to X stack JMP ZNXT,I * back to threads PSSTZ EQU * * * "$HEAD" - pops 1st char from string on X and pushes to stack * Slows down the longer the string because it must "barrel roll" * the bytes thru the entire string, use $GET on larger strings. * If string-length = 0 then string error * OCT 5 ASC 2,$HEA DEF PSHEZ PSHEA DEF *+1 JSB ZXPOP,I * pop word length STA TMP1 * save word length in tmp1 CMA,INA * 2's complement length ADA XP * to subtract length from XP STA TMP4 * save results in tmp4 for startadr JSB MLATS * call ML Address TeSt subroutine JSB ZXPOP,I * pop char length SZA,RSS * must not be zero - would be empty string JMP MLATE * halt with string error if char len = 0 STA TMP2 * save in temp2 for char length LDA TMP4,I * get word at start address ALF,ALF * put high byte (1st char) in low AND PSHE7 * keep low, zero high JSB ZSPSH,I * push character to system stack * have results now, and X stack is minus char and word length's * loop wordlen-1 times... (a)=adr (start at startadr) * (a)low-->(a)high * (a+1)high-->(a)low * increment a LDA TMP1 * get word length PSHEL ADA CON1 * subtract 1 from A STA TMP3 * put A in countdown SZA,RSS * keep going if countdown not=0 JMP PSHE2 * jump to adjust string len and exit LDA TMP4,I * get (a) ALF,ALF * swap bytes AND PSHE6 * zero low byte STA TMP4,I * save results in (a) LDB TMP4 * get a INB * increment for a+1 LDA 1,I * get (a+1) AND PSHE6 * zero low byte ALF,ALF * swap high to low IOR TMP4,I * OR with (a) STA TMP4,I * save results to (a) ISZ TMP4 * increment pointer LDA TMP3 * get countdown JMP PSHEL * loop to dec and do some more * all rolled down, decrement char count, if even pop * extra word and decrement word length, push new char,word count PSHE2 LDA TMP2 ADA CON1 STA TMP2 * decrement char count SLA * skip to pop/adjust if even JMP PSHE3 * continue if odd JSB ZXPOP,I * pop extra word to nothing LDA TMP1 * get word count ADA CON1 STA TMP1 * decrement word count PSHE3 LDA TMP2 * get char length JSB ZXPSH,I * push char length to X LDA TMP1 * get word count JSB ZXPSH,I * push word count to X to complete JMP ZNXT,I PSHE6 OCT 177400 PSHE7 OCT 377 PSHEZ EQU * * * "$APPEND" - pops stack and appends to string on X * OCT 7 ASC 2,$APP DEF PSAPZ PSAPP DEF *+1 JSB ZXPOP,I * pop word len from X STA TMP1 * save in tmp1 JSB ZXPOP,I * pop char len from X STA TMP2 * save in tmp2 JSB ZSPOP,I * pop char to append from stack AND PSHE7 * zero high byte STA TMP3 * save in tmp3 LDB TMP2 * get char len * SLB,RSS * skip if odd OCT 6011 * =SLB,RSS so HPASM will assemble JMP PSAPE * jump if even JSB ZXPOP,I * if odd... pop partial word AND PSHE6 * zero low byte IOR TMP3 * or with char to append JSB ZXPSH,I * push back to stack JMP PSAIC * jump to increment char PSAPE ALF,ALF * swap bytes JSB ZXPSH,I * push to X ISZ TMP1 * if even increment word len PSAIC ISZ TMP2 * for both increment char len LDA TMP2 * get char len JSB ZXPSH,I * push to X LDA TMP1 * get word len JSB ZXPSH,I * push to X JMP ZNXT,I * done PSAPZ EQU * * * "$TAIL" - pops last char from string on X and push to stack * OCT 5 ASC 2,$TAI DEF PSTAZ PSTAI DEF *+1 JSB ZXPOP,I * pop word len from X STA TMP1 * save word len JSB ZXPOP,I * pop char len from X SZA,RSS * must not be zero - would be empty string JMP MLATE * halt with string error if char len = 0 STA TMP2 * save char len SLA * skip if even JMP PSTAO * jump if odd JSB ZXPOP,I * pop double-char from X STA TMP3 * save AND PSHE6 * zero low byte JSB ZXPSH,I * put partial back on X LDA TMP3 * get back double-char AND PSHE7 * zero high byte JSB ZSPSH,I * push to sys stack JMP PSTDC * jump to decrement char count PSTAO JSB ZXPOP,I * odd - pop partial from X ALF,ALF * swap bytes AND PSHE7 * zero high byte JSB ZSPSH,I * push to sys stack LDA TMP1 * get word count ADA CON1 * decrement STA TMP1 * put back PSTDC LDA TMP2 * get char count ADA CON1 * decrement JSB ZXPSH,I * push to X stack LDA TMP1 * get word count JSB ZXPSH,I * push to X stack to complete string JMP ZNXT,I * done PSTAZ EQU * * * "$IN" - input string from console/device, up to but not including return. * HPIPLOS version - should probably be machine coded but this was easy... * OCT 3 ASC 2,$IN 1/29/08 DEF PSINZ PSIN DEF ENSEC * OCTAL DEFINE STRIN DEF PSTRP * "" push string OCT 1 * word len=1 OCT 0 * char len=0 (empty string) DEF PDO * DO DEF PCHRI * CHRIN DEF PDUP * DUP DEF PLPSH * push literal OCT 15 * 15 a cr DEF PSUB * SUB check for equality DEF PIFNZ * IFNZ if not a return DEF PDUP * DUP DEF PLPSH * literal push OCT 10 * 10 a backspace DEF PSUB * SUB DEF PIFZ * IFZ if a backspace then DEF PLPSH * literal push OCT 40 * 40 a space DEF PPCHR * PCHR print space to erase DEF PSLEN * $LEN get string length DEF PIFNZ * IFNZ if length <> 0 then DEF PLPSH * literal push OCT 10 * 10 a backspace DEF PPCHR * PCHR return to prev. position DEF PSTAI * $TAIL erase character from string DEF PDROP * DROP don't need DEF PENDI * ENDIF DEF PELSE * ELSE not a regular backspace DEF PDUP * DUP DEF PLPSH * literal push OCT 177 * 177 TTY backup char DEF PSUB * SUB DEF PIFZ * IFZ if a TTY backup then DEF PSLEN * $LEN get string length DEF PIFNZ * IFNZ if length <> 0 then DEF PLPSH * literal push OCT 4040 * 4040 backspace,space DEF PPWRD * PWRD backup and erase DEF PLPSH * literal push OCT 10 * 10 a backspace DEF PPCHR * PCHR restore cursor DEF PSTAI * $TAIL erase character from string DEF PDROP * DROP don't need DEF PENDI * ENDIF (if len<>0) DEF PELSE * ELSE must be a char to add to string DEF PDUP * DUP duplicate and DEF PSAPP * $APPEND append to the string DEF PENDI * ENDIF (a tty backup) DEF PENDI * ENDIF (a regular backspace) DEF PDROP * DROP clean off stack DEF PCS0 * #0 push 0 to keep going DEF PELSE * ELSE (it's a return) DEF PDROP * DROP DEF PCS1 * #1 push 1 to terminate DEF PENDI * ENDIF (a return) DEF PUNTI * UNTIL loop until return * under TTY sim does not advance to the next line without crlf * may be removed... depends on what it does on real hardware DEF PCRLF * CRLF print crlf DEF RTSEC * END PSINZ EQU * * * $CAT - combines two strings on X * not very efficient but compact... tried in ML but gave up. * OCT 4 ASC 2,$CAT DEF PSCAZ PSCAT DEF ENSEC DEF PSLEN * $LEN get length of top string DEF PDUP * DUP duplicate for if test DEF PIFNZ * IFNZ if not empty string then DEF PCS1 * #1 push a 1 DEF PSWAP * SWAP swap to get 1, len on stack DEF PPDO * +DO loop from 1 to length DEF PSHEA * $HEAD remove char from top string to stack DEF PXTOY * X>>Y move top string to Y to reveal previous DEF PSAPP * $APPEND append char to previous string DEF PYTOX * Y>>X move top string back DEF PPLOO * +LOOP loop for each char in top string DEF PELSE * ELSE else if empty string DEF PDROP * DROP removed unused length DEF PENDI * ENDIF DEF PSDRP * $DROP drop the now-empty top string DEF RTSEC * END PSCAZ EQU * * * "$VAL" - pops string on X and pushes value to stack * if not a number returns 0 * OCT 4 ASC 2,$VAL DEF PSVAZ PSVAL DEF ENSEC DEF PLPSH * literal push OCT 40 * 40 a space for proper conversion DEF PCS1 * #1 push 1 to start count at DEF PSTOY * S>Y keep count on Y to know how much to clean DEF PDO * DO do... DEF PSHEA * $HEAD remove 1st char from string and push DEF PYTOS * Y>S get count DEF PINC * INC add one DEF PSTOY * S>Y put back DEF PSLEN * $LEN get reduced string length DEF PWHIL * WHILE loop while length <> 0 DEF PSP2S * SP>S push value of stack pointer DEF PDEC * DEC minus 1 to point to 1's digit DEF PDO * DO do... DEF PDUP * DUP duplicate for get DEF PGET * GET get data there DEF PLPSH * literal push OCT 40 * 40 a space DEF PSUB * SUB subtract to test DEF PIFZ * IFZ if data = space then DEF PDEC * DEC subtract 1 from 1's pointer DEF PDUP * DUP duplicate non-zero for while DEF PELSE * ELSE else if data <> space DEF PCS0 * #0 push a zero to terminate while DEF PENDI * ENDIF DEF PWHIL * WHILE loop until non-space found DEF PATOW * execute ascii to word machine-code DEF PSTOZ * S>Z save results on Z for now DEF PCS1 * #1 push a 1 to start +do DEF PYTOS * Y>S get count for "to" parm DEF PPDO * +DO loop count times DEF PDROP * DROP drop temp chars from stack DEF PPLOO * +LOOP until stack is like it was DEF PZTOS * Z>S pop results and push to stack DEF PSDRP * $DROP drop the now-empty original string DEF RTSEC * convert ascii to word (headerless) * Entry: stack points to one's digit, rest of digits before that * with a space before digits * Exit: val at top of stack (0 if not a number) PATOW DEF *+1 JSB ZSPOP,I * pop stack STA ANBYA * store in ASC2W's input pointer JSB ZA2W,I * call ascii-word sub SZA * skip if A=0 (not a number) JMP PATO2 * jump to process number PATO1 JSB ZSPSH,I * push 0 JMP ZNXT,I * exit back to thread PATO2 LDA ANVAL * process number - get value JMP PATO1 * push to stack and exit * end of $VAL PSVAZ EQU * * * "<>CON" - reset input and output redirection to console * 10/6/07 - mod to Reset Just CONsole (call new RJCON sub) * Prev. version reset MS too, defeating the purpose of having * a separate word to Not do that, and interfering with making * interactive IPL load files which use <>CON TEMP CO DEF PCNSZ PCNSL DEF *+1 JSB PCNSA,I JMP ZNXT,I PCNSA DEF RJCON PCNSZ EQU * * * ">PTP" - redirect printed output to papertape punch * OCT 4 ASC 2,>PTP DEF POPTZ POPTP DEF *+1 LDA ZPTPO * get punch vector STA ZOUT * put in output vector JMP ZNXT,I POPTZ EQU * * * "CON, * >PTP and CON MSPAPER * * The INBLOCK, OUTBLOCK definitions reset their respective byte pointers * so the last four definitions are for convenience. Were easy. * Once set, LOAD/SAVE and anything else using MS operators will * go to/from memory blocks. Note.. it's legal to write over 1K * boundries so long as allocated space is not exceeded. So can * be used to write a big ABS file then split into blocks to * write to disk or magtape. If you exceed the contents of ENDOM * an address error will display and the system restarted. Note.. * restarting sets the general vectors, but does NOT set MS vectors, * that would be inconvenient. The system works with bytes and does * its own high/low packing and unpacking. The pointers are the * byte# - where it is in memory is DLIM + block#*2000oct + byte#/2 * * "MSPAPER" - sets mass-storage vectors to paper-tape code * OCT 7 ASC 2,MSPA DEF PMPAZ PMPAP DEF *+1 * machine-coded definition LDA ZPTRI * get address of PTRIN STA ZMINP * save to MS input vector LDA ZPTPO * get address of PTPOT STA ZMOUT * save to MS output vector JMP ZNXT,I * done PMPAZ EQU * * * "MSBOUT" - pops stack and sends byte thru mass-storage vector * OCT 6 ASC 2,MSBO DEF PMSOZ PMSOU DEF *+1 JSB ZSPOP,I JSB ZMOUT,I JMP ZNXT,I PMSOZ EQU * * * "MSBIN" - reads byte from mass storage and pushes to stack * OCT 5 ASC 2,MSBIN DEF PMSIZ PMSIN DEF *+1 JSB ZMINP,I JSB ZSPSH,I JMP ZNXT,I PMSIZ EQU * * * "MSWOUT" - pops stack and writes two bytes to mass storage * writes high byte first followed by low byte * OCT 6 ASC 2,MSWO DEF PSWMZ PSWMS DEF *+1 JSB ZSPOP,I * pop stack STA PSWMT * save to temp ALF,ALF * swap bytes AND PSWMM * zero high byte JSB ZMOUT,I * send high byte to MS (now in low) LDA PSWMT * get word from temp AND PSWMM * zero high byte JSB ZMOUT,I * send low byte to MS JMP ZNXT,I PSWMM OCT 377 * mask to clear high byte PSWMT OCT 0 * safe temp storage PSWMZ EQU * * * "MSWIN" - reads two bytes from mass storage and pushes to stack * 1st byte read placed in high byte, 2nd byte in low byte * OCT 5 ASC 2,MSWI DEF PMSWZ PMSWS DEF *+1 JSB ZMINP,I * get byte from MS ALF,ALF * swap bytes STA TMP1 * save to temp JSB ZMINP,I * get byte from MS IOR TMP1 * or with temp JSB ZSPSH,I * push to stack JMP ZNXT,I PMSWZ EQU * * * "MS$OUT" - output string to mass storage device or buffer * OCT 6 ASC 2,MS$O DEF PMOSZ PMSSO DEF ENSEC DEF PSLEN * $LEN DEF PDUP * DUP DEF PIFNZ * IFNZ don't send empty string DEF PCS0 * #0 push a 0 DEF PSWAP * SWAP swap with length DEF PDEC * DEC decrement length DEF PPDO * +DO loop from 0 to len-1 DEF PINDX * INDEX DEF PSGET * $GET DEF PMSOU * MSBOUT send each char via MSBOUT DEF PPLOO * +LOOP DEF PELSE * ELSE else an empty string.. DEF PDROP * DROP don't need length DEF PENDI * ENDIF DEF PSDRP * $DROP drop original string DEF RTSEC PMOSZ EQU * * * "MS$IN" - input string from mass storage device or buffer * skips character after CR, assumed to be a LF * OCT 5 ASC 2,MS$I DEF PMISZ PMSSI DEF ENSEC * a thread... DEF PSTRP * push string OCT 1 * "" start with empty string OCT 0 DEF PDO * DO loop until done DEF PMSIN * MSBIN get one byte DEF PDUP * DUP DEF PLPSH * literal push OCT 15 * 15 cr DEF PSUB * SUB DEF PIFZ * IFZ if cr then DEF PDROP * DROP drop the original char DEF PCS1 * #1 push 1 terminate until DEF PELSE * ELSE else not a cr DEF PSAPP * $APPEND append to string DEF PCS0 * #0 push 0 to keep looping DEF PENDI * ENDIF DEF PUNTI * UNTIL keep looping till true DEF PMSIN * MSBIN skip line-feed character DEF PDROP * DROP drop the extra character DEF RTSEC * END PMISZ EQU * * * "MSCRLF" - send CRLF to mass-storage output * OCT 6 ASC 2,MSCR DEF PMSCZ PMSCR DEF ENSEC DEF PLPSH OCT 6412 * 6412 DEF PSWMS * MSWOUT DEF RTSEC * END PMSCZ EQU * * * ">MS" - redirect PCHR, PWRD, PNUM and $PRINT output to mass-storage * OCT 3 ASC 2,>MS 1/29/08 DEF PO2MZ PO2MS DEF *+1 LDA ZMOUT STA ZOUT JMP ZNXT,I PO2MZ EQU * * * "CON MSPAPER, for terminating IPL loads * OCT 7 ASC 2,CONS DEF ACONZ ACONS DEF ENSEC DEF PCNSL <>CON DEF PMPAP MSPAPER DEF RTSEC ACONZ EQU * *---------------------------------------------------------- * * "#0" - pushes zero to stack * OCT 2 ASC 2,#0 1/29/08 DEF PCS0Z PCS0 DEF *+1 CLA JSB ZSPSH,I JMP ZNXT,I PCS0Z EQU * * * "#1" - pushes one to stack * OCT 2 ASC 2,#1 1/29/08 DEF PCS1Z PCS1 DEF *+1 CLA,INA JSB ZSPSH,I JMP ZNXT,I PCS1Z EQU * * * "@TL" - pushes address of Token Length variable * OCT 3 ASC 2,@TL 1/29/08 DEF PATLZ PATL DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF TL PATLZ EQU * * * "@TB1" - pushes address of Token Buffer 1 * OCT 4 ASC 2,@TB1 DEF PAT1Z PATB1 DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF TB1 PAT1Z EQU * * * "@TB2" - pushes address of Token Buffer 2 * OCT 4 ASC 2,@TB2 DEF PAT2Z PATB2 DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF TB2 PAT2Z EQU * * * "@ANVAL" - pushes ANVAL address * OCT 6 ASC 2,@ANV DEF PAANZ PAANV DEF *+1 NOP LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF ANVAL PAANZ EQU * * * "@LLP" - pushes LSTLP address 6/5/10 * page boundary is around here so coded as IPL * OCT 4 ASC 2,@LLP DEF PALPZ PALPC DEF ENSEC DEF PLPSH literal push DEF LSTLP address of LSTLP DEF RTSEC LSTLP OCT 0 storage for last load point PALPZ EQU * * * "@ENSEC" - pushes ENSEC address * OCT 6 ASC 2,@ENS DEF PAESZ PAESC DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF ENSEC PAESZ EQU * * * "@CLH" - pushes LITRA (console literal push handler) address * OCT 4 ASC 2,@CLH DEF PACLZ PACLH DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF LITRA PACLZ EQU * * * "@LITERAL" - pushes PLPSH (literal push handler) address * DEC 8 ASC 2,@LIT DEF PALIZ PALIP DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF PLPSH PALIZ EQU * * * "@STRING" - pushes PSTRP (string push) address * DEC 7 ASC 2,@STR DEF PASPZ PASTP DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF PSTRP PASPZ EQU * * * "@RTSEC" - pushes RTSEC address * OCT 6 ASC 2,@RTS DEF PARSZ PARTS DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF RTSEC PARSZ EQU * * * @DIC - pushes address containing start of dictionary * OCT 4 ASC 2,@DIC DEF PADIZ PADIC DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF DTOP PADIZ EQU * * * @USR - pushes address containing start of user dictionary * OCT 4 ASC 2,@USR DEF PAUSZ PAUSR DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF DUSER PAUSZ EQU * * * @BLK - pushes address containing start of block memory * OCT 4 ASC 2,@BLK DEF PABLZ PABLK DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF DLIM PABLZ EQU * * * @END - pushes address containing end of memory * OCT 4 ASC 2,@END DEF PAENZ PAEND DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF ENDOM PAENZ EQU * * * @DIPTR - pushes address containing Dictionary Pointer * OCT 6 ASC 2,@DIP DEF PADPZ PADPT DEF *+1 LDA *+3 JSB ZSPSH,I JMP ZNXT,I DEF DIPTR PADPZ EQU * * * "RND" - returns random number on system stack * OCT 3 ASC 2,RND 1/29/08 DEF PRNDZ PRND DEF *+1 LDA PRNDA RAL XOR PRNDB STA PRNDA JSB ZSPSH,I LDA PRNDB ADA PRNDC XOR PRNDA STA PRNDB JMP ZNXT,I PRNDA OCT 035562 PRNDB OCT 124517 PRNDC OCT 037521 PRNDZ EQU * * * "TOKEN" - executes TOKEN function - returns next word * from input buffer in @TL, @TB1 and @TB2 * OCT 5 ASC 2,TOKE DEF PTOKZ PTOKN DEF TOKEN+1 PTOKZ EQU * * * "SDIC" - executes SDIC function - searches for definition * named in @TL,@TB1,@TB2 and if found pushes address and non-zero * (really address again), if not found pushes 0 * OCT 4 ASC 2,SDIC DEF PSDIZ PSDIC DEF SDIC+1 PSDIZ EQU * * * * "+IRQ" enable IRQ processing * OCT 4 ASC 2,+IRQ DEF BIRQZ BIRQ DEF *+1 STF 0 * enable interrupts CLA,INA STA GIENA * store 1 in global int. enable JMP ZNXT,I BIRQZ EQU * * * "-IRQ" disable IRQ processing * OCT 4 ASC 2,-IRQ DEF DIRQZ DIRQ DEF *+1 CLF 0 * disable interrupts CLA STA GIENA * store 0 in global int. enable JMP ZNXT,I DIRQZ EQU * * * "+AUTO" enable autostart * OCT 5 ASC 2,+AUT DEF EAUTZ EAUTO DEF *+1 CLA,INA * a = 1 STA AOAEL,I * store in autostart enable location JMP ZNXT,I AOAEL DEF ASENA * address of autostart enable flag EAUTZ EQU * * * "-AUTO" disable autostart * OCT 5 ASC 2,-AUT DEF DAUTZ DAUTO DEF *+1 CLA * a = 0 STA AOAEL,I * store in autostart enable location JMP ZNXT,I DAUTZ EQU * * * "ADDCODE" - generated by MKHPASM * modified 6/2/10 to validate, no longer replaceable, just removeable * OCT 000007 ASC 2,ADDC DEF MA7CZ MA7CD DEF ENSEC DEF PADPT * @DIPxx DEF PGET * GET DEF PSWAP * SWAP DEF DPUT * alternate DPUT code DEF PADPT * @DIPxx DEF PDUP * DUP DEF PGET * GET DEF PINC * INC DEF PPUT * PUT DEF RTSEC * END MA7CZ EQU * * * ========= Block-oriented MS definitions * * "INBLOCK" - sets mass-storage input vector to spec'd block * 0 INBLOCK causes MSBIN and MSWIN to input from mem block 0 * Sets byte pointer to 0, each byte read increments pointer. * Use GETIP to push the byte position of the next read. * Use n SETIP to set the byte position for the next read. * Contents of DLIM determines where block 0 begins. * Note - n must be between 0 and 15 (or will be reduced) * Max 16K words of blocks. * OCT 7 ASC 2,INBL DEF PIBLZ PIBLK DEF *+1 CLA STA PIBLP * clear byte pointer JSB PBLGS * get start and validate STA PIBLA * save block start address LDA PIBLV * get new MS input vector STA ZMINP * redirect all MS input to read block JMP ZNXT,I * return to hpiplos PIBLP OCT 0 * byte pointer PIBLA OCT 0 * desired block start address PIBLM OCT 36000 * start address mask PIBLB OCT 377 * to keep just low byte PIBLV DEF PIBLS * location of new subroutine PIBLS NOP * new MS input byte-handler subroutine LDA PIBLP * get byte pointer CLE,ERA * /2 and put even/odd in E SEZ * skip if even JMP PIBLO * jump if odd ADA PIBLA * add in start address JSB PBLKE * error-check LDB 0 * put in B for index LDA 1,I * get data at desired address ALF,ALF * put high in low byte JMP PIBLE * finish up PIBLO ADA PIBLA * for odd bytes.. add in start JSB PBLKE * error-check LDB 0 * put in B for index LDA 1,I * get data, desired already in low PIBLE AND PIBLB * trim off high byte, leaving desired in low ISZ PIBLP * increment byte pointer JMP PIBLS,I * return to caller * error-checking sub - make sure A is <= ENDOM PBLKE NOP LDB 0 * put A in B for processing CMB,INB * make -address ADB ENDOM * B = ENDOM - address SSB,RSS * skip if bit 15=1 JMP PBLKE,I * if ok, return to caller LDA PBERW * get word length of message LDB PBERA * get address of message JSB ZPBFL,I * print the error message JMP WBVEC,I * warmboot HPIPLOS PBERW DEC 8 PBERA DEF *+1 ASC 8,MEMORY OVERFLOW 1/29/08 * subroutine - pop stack, calc start and validate PBLGS NOP JSB ZSPOP,I * pop stack ALF,ALF * rotate left 8 places ELA,ELA * rotate left 2 places AND PIBLM * mask off unused bits - now n * 1024 ADA DLIM * add in start of block space JSB PBLKE * error-check sub - halt if no memory JMP PBLGS,I * must be ok PIBLZ EQU * * * "OUTBLOCK" - sets mass-storage output vector to spec'd block * 1 OUTBLOCK causes MSBOUT and MSWOUT to go to block 1 * Sets byte pointer to 0, each byte read increments pointer. * Use GETOP to push byte position of next write * Use n SETOP to set position of next write * Contents of DLIM determines where block 0 begins. * Note - n must be between 0 and 15 (or will be reduced) * Max 16K words of blocks. * (borrows subs/constants from IBLK definition) * DEC 8 ASC 2,OUTB DEF POBLZ POBLK DEF *+1 CLA STA POBLP * clear byte pointer JSB PBLGS * pop stack, calc start and validate STA POBLA * save for start address LDA POBLV * get new MS output vector STA ZMOUT * redirect all MS output to write to block JMP ZNXT,I * return to hpiplos POBLP OCT 0 * byte pointer POBLA OCT 0 * start address of desired block POBLB OCT 177400 * to zero low byte POBL1 OCT 0 * private temps... got into trouble POBL2 OCT 0 * using the TMPx vars - it's a handler! POBLV DEF POBLS * out handler address POBLS NOP * out handler subroutine... AND PIBLB * zero high byte in case of abuse STA POBL1 * save byte to write LDA POBLP * get byte pointer CLE,ERA * /2 and put even/odd in E SEZ * skip if even JMP POBLO * jump if odd ADA POBLA * add in start address JSB PBLKE * error-check LDB 0 * put in B for index LDA 1,I * get data at desired address AND PIBLB * zero high byte STA POBL2 * save LDA POBL1 * get byte to write ALF,ALF * put in high byte IOR POBL2 * or mem data with byte JMP POBLE * finish up POBLO ADA POBLA * if odd.. add in start JSB PBLKE * error-check LDB 0 * put in B LDA 1,I * get memdata AND POBLB * zero low byte IOR POBL1 * or with byte to write POBLE STA 1,I * finish.. store new mem data ISZ POBLP * increment byte pointer JMP POBLS,I * done POBLZ EQU * * * "GETIP" - pushes value of block input byte pointer * OCT 5 ASC 2,GETI DEF PGEIZ PGETI DEF *+1 LDA PIBLP * get value of input pointer JSB ZSPSH,I * push to stack JMP ZNXT,I PGEIZ EQU * * * "SETIP" - pops stack and sets input byte pointer * OCT 5 ASC 2,SETI DEF PSEIZ PSETI DEF *+1 JSB ZSPOP,I * pop stack STA PIBLP * store in input byte pointer JMP ZNXT,I PSEIZ EQU * * * "GETOP" - pushes value of block output byte pointer * OCT 5 ASC 2,GETO DEF PGOPZ PGETO DEF *+1 LDA POBLP * get value of output pointer JSB ZSPSH,I * push to stack JMP ZNXT,I PGOPZ EQU * * * "SETOP" - pops stack and sets output byte pointer * OCT 5 ASC 2,SETO DEF PSEOZ PSETO DEF *+1 JSB ZSPOP,I * pop stack STA POBLP * store in output byte pointer JMP ZNXT,I PSEOZ EQU * * * ======= definitions written in hpiplos... * * "$DEFADR" - generated by MKHPASM * OCT 000007 ASC 2,$DEF DEF MS7FZ MS7FD DEF ENSEC DEF PATL * @TL DEF PSLEN * $LEN DEF PPUT * PUT DEF PSTRP * (STRING PUSH) OCT 000003 * 000003 OCT 020040 * " " OCT 020000 * 020000 OCT 000003 * 000003 DEF PSCAT * $CAT DEF PATB1 * @TB1 DEF PSADR * $ADR DEF PDUP * DUP DEF PSTOY * S>Y DEF PGET * GET DEF PPUT * PUT DEF PATB2 * @TB2 DEF PYTOS * Y>S DEF PINC * INC DEF PGET * GET DEF PPUT * PUT DEF PSDRP * $DROx DEF PSDIC * SDIC DEF PDUP * DUP DEF PIFNZ * IFNZ DEF PDROP * DROP DEF PENDI * ENDIx DEF RTSEC * END MS7FZ EQU * * * "HEADER$" - generated by MKHPASM (edited 12/12/07) * OCT 000007 ASC 2,HEAD DEF MH7DZ MH7DE DEF ENSEC DEF PCS0 * #0 DEF POVER * OVER DEF PADIC * @DIC DEF PGET * GET DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PDROP * DROP DEF PCS1 * #1 DEF PENDI * ENDIx DEF POVER * OVER DEF PABLK * @BLK DEF PGET * GET DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PELSE * ELSE DEF PDROP * DROP DEF PCS1 * #1 DEF PENDI * ENDIx DEF POVER * OVER DEF PLPSH * (LITERAL PUSH) OCT 000004 * 000004 DEF PSUB * SUB DEF PGET * GET DEF PLPSH * (LITERAL PUSH) OCT 000024 * 000024 DEF PSWAP * SWAP DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PDROP * DROP DEF PCS1 * #1 DEF PENDI * ENDIx DEF POVER * OVER DEF PDUP * DUP DEF PCS1 * #1 DEF PSUB * SUB DEF PGET * GET DEF PDUP * DUP DEF PIFLZ * IF<0 DEF PDROP * DROP DEF PDROP * DROP DEF PDROP * DROP DEF PCS1 * #1 DEF PELSE * ELSE DEF PDUP * DUP DEF PSTOY * S>Y DEF PDEC * DEC DEF PSWAP * SWAP DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PDROP * DROP DEF PCS1 * #1 DEF PENDI * ENDIx DEF PABLK * @BLK DEF PGET * GET DEF PYTOS * Y>S DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PDROP * DROP DEF PCS1 * #1 DEF PENDI * ENDIx DEF PENDI * ENDIx DEF PIFNZ * IFNZ DEF PSTRP * (STRING PUSH) OCT 000002 * 000002 OCT 055400 * "[" OCT 000001 * 000001 DEF PSSTR * $STR DEF PSCAT * $CAT DEF PSTRP * (STRING PUSH) OCT 000002 * 000002 OCT 056440 * "] " OCT 000002 * 000002 DEF PSCAT * $CAT DEF PELSE * ELSE DEF PDUP * DUP DEF PLPSH * (LITERAL PUSH) OCT 000003 * 000003 DEF PSUB * SUB DEF PDUP * DUP DEF PGET * GET DEF PSTOX * S>X DEF PINC * INC DEF PGET * GET DEF PSTOX * S>X DEF PLPSH * (LITERAL PUSH) OCT 000004 * 000004 DEF PSTOX * S>X DEF PLPSH * (LITERAL PUSH) OCT 000003 * 000003 DEF PSTOX * S>X DEF PLPSH * (LITERAL PUSH) OCT 000004 * 000004 DEF PSUB * SUB DEF PGET * GET DEF PLPSH * (LITERAL PUSH) OCT 000004 * 000004 DEF PSWAP * SWAP DEF PSUB * SUB DEF PDUP * DUP DEF PIFLZ * IF<0 DEF P2CPL * 2CPL DEF PCS1 * #1 DEF PSWAP * SWAP DEF PPDO * +DO DEF PSTRP * (STRING PUSH) OCT 000002 * 000002 OCT 074000 * "x" OCT 000001 * 000001 DEF PSCAT * $CAT DEF PPLOO * +LOOx DEF PELSE * ELSE DEF PDUP * DUP DEF PIFNZ * IFNZ DEF PCS1 * #1 DEF PSWAP * SWAP DEF PPDO * +DO DEF PSTAI * $TAIx DEF PDROP * DROP DEF PPLOO * +LOOx DEF PELSE * ELSE DEF PDROP * DROP DEF PENDI * ENDIx DEF PENDI * ENDIx DEF PSTRP * (STRING PUSH) OCT 000002 * 000002 OCT 020000 * 020000 OCT 000001 * 000001 DEF PSCAT * $CAT DEF PENDI * ENDIx DEF RTSEC * END MH7DZ EQU * * * "WORDS" - generated by MKHPASM * OCT 000005 ASC 2,WORD DEF MW5DZ MW5DO DEF ENSEC DEF PCS0 * #0 DEF PSTOZ * S>Z DEF PADIC * @DIC DEF PGET * GET DEF PDO * DO DEF PDUP * DUP DEF PGET * GET DEF PIFZ * IFZ DEF PCS1 * #1 DEF PELSE * ELSE DEF PDUP * DUP DEF PLPSH * (LITERAL PUSH) OCT 000004 * 000004 DEF PADD * ADD DEF MH7DE * HEADxxx (faked) DEF PZTOS * Z>S DEF PSLEN * $LEN DEF PADD * ADD DEF PDUP * DUP DEF PSTOZ * S>Z DEF PLPSH * (LITERAL PUSH) OCT 000114 * 000114 DEF PSWAP * SWAP DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PZTOS * Z>S DEF PDROP * DROP DEF PSLEN * $LEN DEF PSTOZ * S>Z DEF PCRLF * CRLF DEF PENDI * ENDIx DEF PPSTR * $PRIxx DEF PLPSH * (LITERAL PUSH) OCT 000003 * 000003 DEF PADD * ADD DEF PGET * GET DEF PCS0 * #0 DEF PENDI * ENDIx DEF PUNTI * UNTIx DEF PCRLF * CRLF DEF PSTRP * (STRING PUSH) OCT 000003 * 000003 OCT 042517 * "EO" OCT 042075 * "D=" OCT 000004 * 000004 DEF PPSTR * $PRIxx DEF PDUP * DUP DEF PPNUM * PNUM DEF PSTRP * (STRING PUSH) OCT 000004 * 000004 OCT 043122 * "FR" OCT 042505 * "EE" OCT 036400 * "=" OCT 000005 * 000005 DEF PPSTR * $PRIxx DEF PABLK * @BLK DEF PGET * GET DEF PDEC * DEC DEF PSWAP * SWAP DEF PSUB * SUB DEF PPNUM * PNUM DEF PZTOS * Z>S DEF PDROP * DROP DEF RTSEC * END MW5DZ EQU * * * "ADDHEADER" - generated by MKHPASM * OCT 000011 ASC 2,ADDH DEF MA9HZ MA9HD DEF ENSEC DEF PATL * @TL DEF PGET * GET DEF PSTOZ * S>Z DEF PADPT * @DIPxx DEF PEOD * EOD DEF PDUP * DUP DEF PSTOZ * S>Z DEF PINC * INC DEF PPUT * PUT DEF PATB1 * @TB1 DEF PGET * GET DEF MA7CD * ADDCxxx (faked) DEF PATB2 * @TB2 DEF PGET * GET DEF MA7CD * ADDCxxx (faked) DEF PCS0 * #0 DEF MA7CD * ADDCxxx (faked) DEF RTSEC * END MA9HZ EQU * * * "ADDHEADER$" - generated by MKHPASM * OCT 000012 ASC 2,ADDH DEF MAAHZ MAAHD DEF ENSEC DEF PATL * @TL DEF PSLEN * $LEN DEF PPUT * PUT DEF PSTRP * (STRING PUSH) OCT 000003 * 000003 OCT 020040 * " " OCT 020040 * " " OCT 000004 * 000004 DEF PSCAT * $CAT DEF PATB1 * @TB1 DEF PSADR * $ADR DEF PGET * GET DEF PPUT * PUT DEF PATB2 * @TB2 DEF PSADR * $ADR DEF PINC * INC DEF PGET * GET DEF PPUT * PUT DEF PSDRP * $DROx DEF MA9HD * ADDHxxxxx (faked) DEF RTSEC * END MAAHZ EQU * * * "FIXLINKS" - generated by MKHPASM (edited afterwards 6/2/10) * OCT 000010 ASC 2,FIXL DEF MF8LZ MF8LI DEF ENSEC DEF PCS0 * #0 DEF MA7CD * ADDCxxx (faked) DEF PZTOS * Z>S DEF PDUP * DUP DEF PZTOS * Z>S DEF PPUT * PUT DEF PLPSH * (LITERAL PUSH) OCT 000003 * 000003 DEF PADD * ADD DEF PADPT * @DIPxx DEF PGET * GET DEF PDEC * DEC DEF PPUT * PUT DEF RTSEC * END MF8LZ EQU * * * "ADDMLVAR" - generated by MKHPASM * OCT 000010 ASC 2,ADDM DEF MA8MZ MA8MD DEF ENSEC DEF PADPT * @DIPxx DEF PGET * GET DEF PINC * INC DEF MA7CD * ADDCxxx (faked) DEF PADPT * @DIPxx DEF PGET * GET DEF PLPSH * (LITERAL PUSH) OCT 000003 * 000003 DEF PADD * ADD DEF PLPSH * (LITERAL PUSH) OCT 001777 * 001777 DEF PAND * AND DEF PDUP * DUP DEF PLPSH * (LITERAL PUSH) OCT 000003 * 000003 DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PLPSH * (LITERAL PUSH) OCT 000003 * 000003 DEF POVER * OVER DEF PSUB * SUB DEF PCS1 * #1 DEF PSWAP * SWAP DEF PPDO * +DO DEF PCS0 * #0 DEF MA7CD * ADDCxxx (faked) DEF PPLOO * +LOOx DEF PDROP * DROP DEF PLPSH * (LITERAL PUSH) OCT 000003 * 000003 DEF PENDI * ENDIx DEF PLPSH * (LITERAL PUSH) OCT 062000 * DEF POR * OR DEF MA7CD * ADDCxxx (faked) DEF PLPSH * (LITERAL PUSH) OCT 114323 * 114323 DEF MA7CD * ADDCxxx (faked) DEF PLPSH * (LITERAL PUSH) OCT 124321 * 124321 DEF MA7CD * ADDCxxx (faked) DEF RTSEC * END MA8MZ EQU * * * "VARIABLE" - generated by MKHPASM (manually edited 6/2/10) * OCT 000010 ASC 2,VARI DEF MV8IZ MV8IA DEF ENSEC DEF PTOKN * TOKEx DEF PIFZ * IFZ DEF MA9HD * ADDHxxxxx (faked) DEF PCS1 * #1 DEF PTOKN * TOKEx DEF PIFZ * IFZ DEF PAANV * @ANVxx DEF PCS0 * #0 DEF PPUT * PUT DEF PSDIC * SDIC DEF PIFNZ * IFNZ DEF PDROP * DROP DEF PENDI * ENDIx DEF PDROP * DROP DEF PAANV * @ANVxx DEF PGET * GET DEF PENDI * ENDIx DEF PDUP * DUP DEF PCS1 * #1 DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PDROP * DROP DEF PCS1 * #1 DEF PENDI * ENDIx DEF MA8MD * ADDMxxxx (faked) DEF PADPT * @DIPxx DEF PGET * GET DEF PINC * INC DEF MA7CD * ADDCxxx (faked) DEF PCS1 * #1 DEF PSWAP * SWAP DEF PPDO * +DO DEF PCS0 * #0 DEF MA7CD * ADDCxxx (faked) DEF PPLOO * +LOOx DEF MF8LI * FIXLxxxx (faked) DEF PENDI * ENDIx DEF RTSEC * END MV8IZ EQU * * * "CONSTANT" - generated by MKHPASM (manually edited 6/2/10) * OCT 000010 ASC 2,CONS DEF MC8SZ MC8SO DEF ENSEC DEF PTOKN * TOKEx DEF PIFZ * IFZ DEF MA9HD * ADDHxxxxx (faked) DEF PCS0 * #0 DEF PTOKN * TOKEx DEF PIFNZ * IFNZ DEF PDROP * DROP DEF PCS1 * #1 DEF PELSE * ELSE DEF PSDIC * SDIC DEF PIFZ * IFZ DEF PDROP * DROP DEF PCS1 * #1 DEF PELSE * ELSE DEF PDUP * DUP DEF PACLH * @CLH DEF PSUB * SUB DEF PIFZ * IFZ DEF PDROP * DROP DEF PELSE * ELSE DEF PAANV * @ANVxx DEF PSWAP * SWAP DEF PPUT * PUT DEF PENDI * ENDIx DEF PENDI * ENDIx DEF PENDI * ENDIx DEF PIFNZ * IFNZ DEF PSTRP * (STRING PUSH) OCT 000006 * 000006 OCT 041101 * "BA" OCT 042040 * "D " OCT 053101 * "VA" OCT 046125 * "LU" OCT 042400 * "E" OCT 000011 * 000011 DEF PPSTR * $PRIxx DEF PZTOS * Z>S DEF PDROP * DROP DEF PZTOS * Z>S DEF PDROP * DROP DEF PELSE * ELSE DEF MA8MD * ADDMxxxx (faked) DEF PAANV * @ANVxx DEF PGET * GET DEF MA7CD * ADDCxxx (faked) DEF MF8LI * FIXLxxxx (faked) DEF PENDI * ENDIx DEF PENDI * ENDIx DEF RTSEC * END MC8SZ EQU * * * "ALLOCATE" - generated by MKHPASM * OCT 000010 ASC 2,ALLO DEF MA8OZ MA8OL DEF ENSEC DEF PLPSH * (LITERAL PUSH) OCT 002000 * 002000 DEF PMULT * MUL DEF PAEND * @END DEF PGET * GET DEF PINC * INC DEF PLPSH * (LITERAL PUSH) OCT 176000 * 176000 DEF PAND * AND DEF PSWAP * SWAP DEF PSUB * SUB DEF PDUP * DUP DEF PEOD * EOD DEF PINC * INC DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PSTRP * (STRING PUSH) OCT 000013 * 000013 OCT 047117 * "NO" OCT 052040 * "T " OCT 042516 * "EN" OCT 047525 * "OU" OCT 043510 * "GH" OCT 020106 * " F" OCT 051105 * "RE" OCT 042440 * "E " OCT 046505 * "ME" OCT 046400 * "M" OCT 000023 * 000023 DEF PPSTR * $PRIxx DEF PDROP * DROP DEF PELSE * ELSE DEF PABLK * @BLK DEF PSWAP * SWAP DEF PPUT * PUT DEF PENDI * ENDIx DEF RTSEC * END MA8OZ EQU * * * "ZEROxxxxx" - generated by MKHPASM 8/22/04 * OCT 000011 ASC 2,ZERO DEF MZ9OZ MZ9OE DEF ENSEC DEF POBLK * OUTBxxxx DEF PCS0 * #0 DEF PLPSH * (LITERAL PUSH) OCT 001777 * 001777 DEF PPDO * +DO DEF PCS0 * #0 DEF PSWMS * MSWOxx DEF PPLOO * +LOOx DEF PENDI * ENDIx DEF RTSEC * END MZ9OZ EQU * * * "BPUT" - generated by MKHPASM * OCT 000004 ASC 2,BPUT DEF MB4TZ MB4TP DEF ENSEC DEF PLPSH * (LITERAL PUSH) OCT 002000 * 002000 DEF PMULT * MUL DEF PABLK * @BLK DEF PGET * GET DEF PADD * ADD DEF PADD * ADD DEF PDUP * DUP DEF PAEND * @END DEF PGET * GET DEF PSWAP * SWAP DEF PSUB * SUB DEF PIFLZ * IF<0 DEF PSTRP * (STRING PUSH) OCT 000004 * 000004 OCT 042522 * "ER" OCT 051117 * "RO" OCT 051000 * "R " OCT 000005 * 000005 DEF PPSTR * $PRIxx DEF PDROP * DROP DEF PDROP * DROP DEF PELSE * ELSE DEF PSWAP * SWAP DEF PPUT * PUT DEF PENDI * ENDIx DEF RTSEC * END MB4TZ EQU * * * "BGET" - generated by MKHPASM * OCT 000004 ASC 2,BGET DEF MBGEZ MB4TG DEF ENSEC DEF PLPSH * (LITERAL PUSH) OCT 002000 * 002000 DEF PMULT * MUL DEF PABLK * @BLK DEF PGET * GET DEF PADD * ADD DEF PADD * ADD DEF PGET * GET DEF RTSEC * END MBGEZ EQU * * * DICND OCT 0 * new defs will add here * * end of source * END