SYD CHHU & PPPM HP-71 LEX SOURCES FOR JPC VIA MICHAEL MARKOV, 8 MAY 1984 ---------- The KEYCHR$ function puts the HP-71 into a low power consumption state, and then waits for a key to be pressed. A single ASCII character (or optional string) representing the key(s) pressed is returned. For example: Pressing the Q key will return "Q"; Pressing the [g]Q key will return "q"; Pressing the [f]Q key will return CHR$(223); Pressing the [g]+ key will return "?"; Pressing the 'ENDLINE' key will return CHR$(13). When responding to KEYCHR$ from the HP-71 keyboard, the LC (Lowercase) setting is ignored. SYNTAX: KEYCHR$ or KEYCHR$(key count) where key count (n) is an optional numeric expression rounded to an integer in the range 1<=n<=15. KEYCHR$ waits for the number of keys specified by the key count to be pressed. If a parameter is not supplied, KEYCHR$ waits for one key to be pressed. EXAMPLES: K$=KEYCHR$ Wait for one key to be pressed. K$=KEYCHR$(3) Wait for 3 keys to be pressed. 50 DISP "Edit, Add, Del, Quit" 60 M=POS("EADQ",UPRC$(KEYCHR$))+1 ! Used in a program. 70 ON M GOTO 50, .......... 100 IF KEYCHR$(2)=P$ THEN ...... ELSE ...... RELATED KEYWORDS: KEY$, KEYWAIT$. LEX 'KEYCHRLX' * * * Copyright (c) 1987 * Graham Fraser * 25 Octantis Street * Doncaster East, Vic. 3109. * AUSTRALIA * +61 3 842-4586 * * 29 March 1987 Version 3.0 * * KEYCHR$ * Put the HP-71 in light sleep, and wait for a key to be pressed. * Return a single ASCII character (or optional string) * representing the key(s) pressed. * * SYNTAX: * KEYCHR$ or KEYCHR$(key count) * * Key count (n) - 1<=n<=15 * Optional numeric expression rounded to an integer * * Related keywords - KEY$, KEYWAIT$ * * ID #E1 * 225 MSG 0 * No messages POLL 0 * No Poll Handler * * SLEEP EQU #006C2 * Scan keyboard, do LSLEEP if key buffer empty CKSREQ EQU #00721 * Handle service requests (external keyboard) POPBUF EQU #010EE * Pop a key from keyboard buffer into B(A) ARGERR EQU #0BF19 * Report "INVALID ARG" Error RNDAHX EQU #136CB * Pop, test, round and convert real number to HEX ADHEAD EQU #181B7 * Add string header STKCHR EQU #18504 * Add a character to a stack item D1=AVE EQU #18651 * Set D1 to (AVMEME) AVE=D1 EQU #18BB8 * Update AVMEME from D1 D=AVMS EQU #1A460 * Set D(A) to AVMEMS KEYCOD EQU #1FD22 * System keycode map * * ENTRY keychr CHAR #F * Function * KEY 'KEYCHR$' TOKEN #FD * 253 * ENDTXT * * NIBHEX 8 * Numeric parameter NIBHEX 01 * One optional parameter * keychr A=0 A ?C=0 S * If no parameters, then default = 1 GOYES onekey * GOSBVL RNDAHX * Get parameter and check validity GONC argerr * Valid range: 1<=n<=15 C=0 A LC(1) #F * Arbitrary upper limit ?A>C A GOYES argerr A=A-1 A GONC parmOK argerr GOVLNG ARGERR * Report error * parmOK D1=D1+ 16 * Move D1 past parameter on math stack * onekey R2=A * Save key count CD0EX * Save D0 in R3 R3=C CD1EX * Save string start in R1 D1=C R1=C nxtkey GOSBVL AVE=D1 * Update AVMEME * sleep GOSBVL SLEEP * Wait for a key press GONC key GOSBVL CKSREQ * Check for KEYBOARD IS key GOTO sleep * * * key GOSBVL POPBUF * Get keycode NIBHEX C5 * B=B+B A LC(5) KEYCOD * Get ASCII from keycode table C=C+B A CD1EX A=DAT1 B * Read character GOSBVL D=AVMS GOSBVL D1=AVE C=A A GOSBVL STKCHR * Put character on stack A=R2 * Decrement key count A=A-1 A R2=A GONC nxtkey * Wait for more keys * C=R3 * Restore D0 CD0EX ST=0 0 GOVLNG ADHEAD * Add header and exit via EXPR * END ---------- LEX 'FLTYPELX' ID #FD MSG 0 POLL 0 * * Graham Fraser 87/01/31 21:20 * * Syntax: * FLTYPE$(file specifier) * eg. FLTYPE$("FLTYPELX:TAPE") * * RSTK255255 = Error * * Graham Fraser 86/12/15 * ID #52 * HP's ID/Token MSG 0 POLL 0 * ENTRY msg$ CHAR #F * KEY 'MSG$' TOKEN 3 * ENDTXT * * POP1R EQU #0E8FD FLTDH EQU #1B223 R3=D10 EQU #03526 FPOLL EQU #1250A D0=AVS EQU #09B2C TBMSG$ EQU #099AB ERRM$f EQU #09806 HEXDEC EQU #0ECAF A-MULT EQU #1B349 DECHEX EQU #1B2D2 FIXP EQU #02A6E MFERR EQU #09393 * eIVARG EQU #0B * pTRANS EQU #EF * * NIBHEX 811 msg$ GOSBVL POP1R GOSUB msg20 LCHEX 3E517 ?CC W Is year > 200 GOYES CNTOK LCHEX 1900 If not, add 1900 to it (allows A=A+C W 1900-2100 to be advised as 0-200) CNTOK R0=A Year D1=D1+ 16 GOSUB GETSTK R1=C Month D1=D1+ 16 GOSUB GETSTK D=C W Day A=R1 B=A W A=R0 GOSBVL YMDDAY GOSBVL HDFLT C=A W SOLNG4 GOVLNG FNRTN4 NIBHEX 811 DAY GOSUB GETYMD C=D W A=C W GOTO YMDBYE NIBHEX 811 MTH GOSUB GETYMD A=B W GOTO YMDBYE NIBHEX 811 YEAR GOSUB GETYMD YMDBYE GOSBVL FLOAT C=A W GOTO SOLNG4 GETYMD GOSBVL POP1R GOSBVL FLTDH C=0 W C=A A GOSBVL DAYYMD RTN GETSTK GOSBVL POP1R GOSBVL FLTDH GOSBVL HEXDEC RTN END ---------- LEX 'CPRTLX71' * * * LEX file containing command "CPYRT" which will cause a Copyright * message to be displayed. This command also checks that the * date in the HP71B is after 1/4/87. (If not, the program will * PAUSE to allow the user to do a SETDATE.) * * WARNING - This command overwrites the CHARSET buffer * * SYNTAX - A=CPYRT(Y,N$) * where Y is the year of copyright less 1980 (i.e. 1986=6) * N$ is the owner of the copyright * A is always returned as 0 (because I haven't mastered * commands yet, only functions) * * * (C) 1987 AMP Society / Ian Harvey * * History: * * Date Programmer Modification *-------- ---------- ------------------------------------------- * 03/87 IH Wrote *01/05/87 IH Documented * * * * Before assembly, change LEX ID to whatever is appropriate ID #F4 MSG 0 POLL 0 AVS2DS EQU #09708 BLDDSP EQU #01898 D0=AVS EQU #09B2C D0ASCI EQU #09833 FLTDH EQU #1B223 FNRTN1 EQU #0F216 FUNCD0 EQU #2F8BB FUNCD1 EQU #2F8C0 I/OALL EQU #1197D MEMERR EQU #0944D MOVEU3 EQU #1B177 NoCont EQU 14 POP1R EQU #0E8FD REVPOP EQU #0BD31 YMDHMS EQU #130DB bCHARS EQU #BFB ENTRY CPYRT CHAR #F KEY 'CPYRT' * The token number below should also be changed TOKEN 14 ENDTXT NIBHEX 4812 CPYRT C=C-1 S C=C-1 S GOC CPYRT1 GOSBVL REVPOP P= 0 CD1EX R2=C C=C+A A D1=C GOSBVL POP1R LCHEX #FF0A0D DAT1=C 6 GOTO CPYRT3 CPYRT1 GOSUB CPYRT2 * If you want a default owner, change the "AMP Society" below to * whatever you want. Just use as many NIBASCs as you need. (Each * NIBASC can have up to 8 characters.) I recommend no more than * 13 characters in owner name. NIBASC 'AMP ' NIBASC 'Society' NIBHEX D0A0FF CPYRT2 C=RSTK R2=C GOSBVL POP1R CPYRT3 R3=A GOSUB SD0D1 C=0 W LC(2) 24 B=C A LC(3) bCHARS SETHEX GOSBVL I/OALL GOC CPYRT4 GOVLNG MEMERR CPYRT4 GOSUB CPYRT5 NIBHEX C12294555514 NIBHEX 22C100000000 CPYRT5 C=RSTK D0=C C=0 A LC(2) 24 GOSBVL MOVEU3 GOSBVL D0=AVS GOSUB CPYRT6 NIBHEX 0818FF CPYRT6 C=RSTK GOSUB MOVECH A=R3 GOSBVL FLTDH P= 0 LC(5) 1980 A=A+C A B=A A LC(2) #F4 GOSBVL D0ASCI GOSUB CPYRT7 NIBHEX 0202FF CPYRT7 C=RSTK GOSUB MOVECH C=R2 GOSUB MOVECH B=0 W P= 0 GOSBVL AVS2DS GOSBVL BLDDSP * The following code is checking that the date is after 1/4/87 GOSBVL YMDHMS A=C W P= 0 LCHEX 870401000000 A=A-C W GONC DATEOK GOSUB CPYRT8 NIBASC 'Pls set ' NIBASC 'todays ' NIBASC 'date' NIBHEX D0A0FF CPYRT8 C=RSTK GOSBVL D0=AVS GOSUB MOVECH B=0 W P= 0 GOSBVL AVS2DS GOSBVL BLDDSP ST=1 NoCont DATEOK GOSUB RD0D1 D1=D1- 16 C=0 W GOVLNG FNRTN1 MOVECH D1=C P= 0 LC(2) 02 B=0 W SETHEX B=B-1 W GOSBVL D0ASCI RTN RD0D1 D0=(5) FUNCD0 C=DAT0 A CD0EX D1=(5) FUNCD1 C=DAT1 A CD1EX RTN SD0D1 CD0EX D0=(5) FUNCD0 DAT0=C A CD0EX CD1EX D1=(5) FUNCD1 DAT1=C A CD1EX RTN END ---------- Greetings Four HP71 source code files accompany this message - BUFSTO71 MISCLEX71 HORNER71 TFLAG71 Note that NO approval for resource allocation has been made with HP, and so, ID's and Tokens should be considered arbitrary (my choice of ID #EC was made for mathemystical[!] reasons). The code for RECALL$, I am sure, could be much improved by the use of the MOVED3 entry point, but I do not yet have the competence and confidence to do this. Cheers and happy programing, Jack Elhay (PPPM) ---------- HISTORICAL BACKGROUND TO BUFSTO71: It seemed to me that it would be a good idea to be able to store information without losing it in a DESTROY ALL or having it in a text file. An adaptation of ENDUPLEX without the execution of statements seemed to be the way. There are potentially many uses of the STORE command. Examples are: (1) STORE LIST$(3,":PORT(0)"),4 followed by MODIFY XXXX,RECALL$(4) should get around the HORRIBLE bug of LIST$, without disturbing the alternate character set. (2) Include as part of your STARTUP a RECALL$(8), say, to give yourself a message at turn-on. (3) Add a STORE command to a subroutine to trace a string variable or STR$( a numeric variable) without messing around with the parameter list, etc. LEX 'BUFSTO10' * CREATE 10 BUFFERS FOR INFO STORAGE ID #EC MSG 0 POLL polhnd * POLL HANDLER TO PRESERVE BUFFERS IF IN USE ENTRY recal CHAR #F * A FUNCTION ENTRY store CHAR #D * A STATEMENT GENERALLY USABLE ( KBD,PRGM ETC.) KEY 'RECALL$' * SYNTAX: RECALL$[(n)] WITH 0<=n<=9, DEFAULT 0 TOKEN 14 KEY 'STORE' * SYNTAX: STORE string,n WITH n AS ABOVE TOKEN 15 RNDAHX EQU #136CB * POP NUMBER, ROUND CONVERT TO HEX IN A(A) STRGCK EQU #036BA * STRING CHECK FOR PARSE ROUTINE FIXDC EQU #05493 * FIX DECOMPILE COMCK+ EQU #032AE * COMMA CHECK FOR PARSE FIXP EQU #02A6E * FIX PARSE SYNTXe EQU #02E2B * SYNTAX ERROR EXIT ARGERR EQU #0BF19 * INVALID ARGUMENT ERROR EXIT MEMERR EQU #0944D * INSUFFICIENT MEMORY EXIT MOVEU3 EQU #1B177 * SHIFT STUFF IN MEMORY I/OALL EQU #1197D * ALLOCATE NEW BUFFER OR ADJUST EXISTING BUFFER I/ODAL EQU #11A41 * DE-ALLOCATE BUFFER ( WHEN NOT NEEDED!) STROVF EQU #1411A * STRING OVERFLOW ERROR EXIT REVPOP EQU #0BD31 * POP 1 STRING AND REVERSE ON STACK D=AVMS EQU #1A460 * STORE AVAIL.MEM.START IN D EXPEXC EQU #0F186 * EVALUATE EXPRESSION: PUTS RESULT ON STACK XXHEAD EQU #1A44E * POP 1 STRING AND STRIP OFF HEADER I/ORES EQU #118FF * SET HIGH BIT ON BUFFER ID TO SAVE IT I/OFND EQU #118BA * BUFFER FIND ROUTINE STKCHR EQU #18504 * STACK CHARACTERS - BUILDS UP STRING ON STACK ADHEAD EQU #181B7 * ADD HEADER TO STRING NXTSTM EQU #08A48 * TERMINATE STATEMENTS bSTORE EQU #F39 * 1st BUFFER'S ID. ADD n TO THIS pCONFG EQU #FB * CONFIG POLL:TIME TO SAVE OR DELETE BUFFERS ENDTXT polhnd LC(2) pCONFG * LOAD POLL ID ?B=C B * IS THIS THE ONE? GOYES savebuf * YES! SAVE THE BUFFERS GONC rtncc * NO RETURN WITH CARRY CLEAR savebuf P= 0 * SET TO LOAD 1st BUFFER'S ID LC(3) bSTORE * LOAD IT P= 9 * NOW USE P AS A LOOP COUNTER SETHEX * HEX ARITHMETIC loop GOSBVL I/ORES * SET HIGH BIT OF ID C=C+1 A * INCREMENT ID FOR NEXT BUFFER P=P-1 * DECREMENT POINTER/COUNTER GONC loop * LOOP IF P>=0 (CARRY CLEAR) rtncc A=0 A * ON EXIT, CARRY IS SET- MUST CLEAR A=A+1 A * BY INCREMENTING A BEFORE RTNSXM * STANDARD EXIT FROM POLL HANDLER strgckp GOSBVL STRGCK * START OF PARSE ROUTINE ( COURTESY OF JPC) GOSBVL COMCK+ GOC fixp GOVLNG SYNTXe fixp GOVLNG FIXP fixd GOVLNG FIXDC REL(5) fixd REL(5) strgckp store GOSBVL EXPEXC * EVALUATES THE STRING, PUTS HEADER ON STACK D0=D0+ 2 * SHIFT PAST tCOMMA TOKEN GOSBVL EXPEXC * EVALUATES NUMERIC PARAMETER, PUTS IT ON STACK GOSUB pop * POP THE NUMERIC OFF THE STACK LC(3) bSTORE * LOAD 1st BUFFER'S ID C=C+A A * ADD n TO GET DESIRED BUFFER'S ID R2=C * SAVE ID IN R2 C=0 W GOSBVL XXHEAD LCHEX #0D * STRING TERMINATOR P= 1 ST=0 0 CD1EX C=-C A C+P+1 C=-C A ?CC A * HERE WE CHECK FOR A NULL STRING GOYES char10 C=R2 * NULL FOUND: PUT ID INTO C GOSBVL I/ODAL * DE-ALLOCATE THIS BUFFER GOTO nxtstm * EXIT charer GOVLNG MEMERR char10 B=A A * NOT A NULL STRING C=0 A LC(3) #FFF * LIMIT ON BUFFER'S CAPACITY ?A<=C A GOYES char40 * OK GOVLNG STROVF * TOO MUCH! char40 R1=A C=R2 * RELOAD ID INTO C GOSBVL I/OALL * EXPAND BUFFER IF PRESENT, CREATE IT OTHERWISE GONC charer A=R0 D0=A C=R1 GOSBVL MOVEU3 * PLACES THE STRING IN THE BUFFER nxtstm GOVLNG NXTSTM * EXIT pop GOSBVL RNDAHX GONC argerr * ERROR ON NEGATIVE ARGUMENT C=0 W LCHEX 9 ?A>C X GOYES argerr * ERROR IF ARG>9 D1=D1+ 16 * SHIFT PAST n, TO READ STRING FOR STORE, AND RTN * TO MAKE ROOM FOR STRING HEADER IN RECALL$(n) argerr GOVLNG ARGERR NIBHEX 801 * A FUNCTION WITH ONE OPTIONAL NUMERIC PARAMETER recal A=0 W * CLEAR A ?C=0 S * IS THERE NO PARAMETER? GOYES recal0 * THEN SKIP POP ROUTINE GOSUB pop * OTHERWISE POP n TO ADD TO F39 recal0 C=0 S * CLEAR SIGN NIBBLE OF C LC(3) bSTORE * LOAD #F39 C=C+A A * ADD POPPED n AD1EX * HERE BEGINS THE RECALL FROM THE CHOSEN BUFFER R1=A * AGAIN THIS CODE IS ESSENTIALLY THAT OF ENDUPLEX GOSBVL I/OFND * AFTER pop, ID IS IN C AS REQUIRED BY I/OFND CD1EX CD0EX B=C A GOSBVL D=AVMS A=R1 D1=A GONC LBL2 LBL1 A=DAT0 B LCHEX #0D ?A=C B * IS THIS THE END OF THE STRING? GOYES LBL2 C=A B GOSBVL STKCHR * PILE ANOTHER BYTE ON D0=D0+ 2 GONC LBL1 * B.E.T. LBL2 C=B A D0=C GOVLNG ADHEAD * EXITS THROUGH EXPR END Well, there it is. After months of frustration, with the constant help and suggestions from David Cameron, BUFSTORE works! String information can now be STOREd in buffers 'numbered' 0 to 9 without being lost in a DESTROY ALL. If numbers need to be STOREd, they have to be converted to strings using STR$. They can later be recovered using VAL. - Jack Elhay --------- This file contains four keywords,EL,ELSTR,ISTR$ and MDIM. The way the ENDLINE statement of the 71B works has always irritated me. It forces the number of characters recognised according to its own rules. Now EL and ELSTR allow me to control the string of three characters and how many characters are recognised independently. As the code has been written, ELSTR [] has the default string specified by n1=13 and n2=n3=10 (this could be altered, of course). Only a string of length 3 is permitted when the statement's parameter is included. EL is a function which fixes the Endline string at 0,2 or 3 characters, given the numeric parameter values 0,1 or 2. With the default string, this means Endline suppressed for 0, one carriage return and one line feed for 1 and one CR and 2 LF's for 2; thus 2 gives double spacing on the THINKJET, 1 gives single spacing while 0 can be used prior to employing raster graphics. The function returns the previous value of the parameter. A program could thus save the endline length ( A=EL(2) ) while setting double space, then, at the end, restore the original length ( A=EL(A) ). ISTR$ sets STD display mode, executes the STR$ function, then restores the original display mode in force on entry. Integers are converted 'clean', with no decimal points or trailing zeros - e.g. X(3,4), not X(3.00,4.00). MDIM will be of value to users who do not have a MATH ROM, while providing information on string arrays. It replaces both LBND and UBND. It is a function of two parameters. The first can be a string array, a matrix or a vector. The second is numeric and defines the information sought. For a value of 0, it returns the lower bound of the array, i.e. what option base was in force when the array was created. For a value of 1, the output is the upper bound on the number of rows. When the value is 2, the number of columns is returned for a matrix, 0 is returned for vectors, and the maximum length of the string is output for string arrays. Items on the MATH STACK are of two kinds. There are binary coded decimal(BCD) numbers and there are representatives of other things. For simple strings, these are headers. For arrays, we have an eight byte dope vector which contains the information extracted by MDIM. (see also IDS I). - Jack Elhay LEX 'MISCLEX1' * MISCELLANEOUS KEYWORDS ID #EC MSG 0 POLL 0 STRGCK EQU #036BA * VALID STRING? CHECK EOLCK EQU #02A7E * END OF LINE CHECK RESPTR EQU #03172 * RESET POINTERS AFTER PARSE DROPDC EQU #05470 * FLEXIBLE DECOMPILE ROUTINE POP1S EQU #0BD38 * POP 1 STRING EXPEXC EQU #0F186 * EVALUATE EXPRESSION, SET D1 TO MATH STACK EOLSTR EQU #2F95B * ADDRESS OF ENDLINE STRING NXTSTM EQU #08A48 * EXIT FROM STATEMENTS RNDAHX EQU #136CB * POP, ROUND, TEST NUMBER, CONVERT TO HEX IN A(A) RDATTY EQU #17CC6 * DATA TYPE ERROR EXIT ARGERR EQU #0BF19 * INVALID ARGUMENT ERROR EXIT EOLLEN EQU #2F95A * ADDRESS OF ENDLINE STRING LENGTH NIBBLE FNRTN1 EQU #0F216 * FUNCTION RETURN A-MULT EQU #1B349 * MULTIPLY TWO HEX NUMBERS HDFLT EQU #1B31B * FLOAT A HEX NUMBER EXPR EQU #0F23C * FUNCTION RETURN STR$SB EQU #18149 * INTERNAL VERSION OF STR$ DSPFLG EQU #2F6DC * ADDRESS OF DISPLAY FORMAT NIBBLE MEMBER EQU #1B098 * TEST A BYTE ENTRY ENTER CHAR #D * STATEMENT CAN BE USED ANYWHERE ENTRY LABEL1 CHAR #F * FUNCTION ENTRY LABEL CHAR #F * FUNCTION ENTRY entry CHAR #F * FUNCTION KEY 'ELSTR' * SYNTAX: ELSTR [] TOKEN 8 KEY 'EL' * SYNTAX: EL(n), 0<=n<=2 TOKEN 9 KEY 'ISTR$' * SYNTAX: AS FOR STR$ TOKEN 10 KEY 'MDIM' * SYNTAX: MDIM(X,n) OR MDIM(X$,n), 0<=n<=2 TOKEN 11 * WHERE X IS MATRIX OR VECTOR, X$ IS STR. ARRAY ENDTXT ELSTRp GOSBVL EOLCK * PARSE ELSTR : IS THERE A PARAMETER? GOC resptr * NO GOSBVL RESPTR * YES, RESET POINTERS GOSBVL STRGCK * CHECK THAT WE HAVE A VALID STRING resptr GOVLNG RESPTR ELSTRd GOVLNG DROPDC * DECOMPILE REL(5) ELSTRd REL(5) ELSTRp ENTER A=DAT0 B * IS THERE A PARAMETER? THIS PART IS TAKEN FROM LCHEX F0 * IDS 3 CODE FOR ENDLINE WHERE THE PARAMETER ?A1,6=>2 A=A-1 A ASRB * THIS DIVIDES BY 2 LABEL2 R2=A * SAVE OLD VALUE IN R2 GOSBVL RNDAHX GONC Argerr * NO NEGATIVES PLEASE P= 0 LC(1) #2 ?A>C P * ARGUMENT NOT >2, PLEASE GOYES Argerr LC(1) #5 C=C-A A * CONVERT ARG. TO No OF NIBBLES GOSBVL A-MULT DAT0=A 1 * WRITE RESULT TO EOLLEN C=R3 CD0EX * RESTORE D0 A=R2 * PREPARE OLD VALUE FOR OUTPUT GOSBVL HDFLT ACEX W GOVLNG FNRTN1 * SEND OUT OLD VALUE Argerr GOVLNG ARGERR NIBHEX 811 * THIS IS ISTR$ LABEL CD0EX * SAVE D0 R3=C * IN R3 D0=(5) DSPFLG * ADDRESS OF NIBBLE TO SAVE AND CHANGE C=0 W C=DAT0 S * PICK UP NIBBLE IN C(S) R4=C * SAVE IN R4 C=0 W P= 0 LC(1) #8 * THIS VALUE WILL SET STD DISPLAY DAT0=C 1 * WRITE IT TO DSPFLG A=0 W GOSBVL STR$SB * CONVERT! C=R4 * RECOVER ORIGINAL NIBBLE DAT0=C S * RESTORE IT C=0 W C=R3 * RECOVER D0 CD0EX * RESTORE D0 GOVLNG EXPR * FUNCTION EXIT WHEN ITEM IS ALREADY ON STACK NIBHEX 8E22 * TWO PARS.:1st STR OR NUMERIC ARRAY, 2nd NUMERIC entry GOSBVL RNDAHX GONC argerr D1=D1+ 16 * SHIFT D1 PAST NUMERIC R1=A * SAVE NUMERIC IN R1 A=DAT1 B * COPY DATA TYPE BYTE TO A(B) P= 0 LCHEX #1A1B1C1D1E * DATA TYPE BYTES FOR VECTORS P= 9 GOSBVL MEMBER * IS OUR BYTE ONE OF THESE? GONC start1 * IF SO, BRANCH LCHEX #2A2B2C2D2E1F * DATA TYPE BYTES FOR MATRICES+ F1 FOR STR.ARRAYS P= 11 GOSBVL MEMBER * IS IT ONE OF THESE? GONC start2 * YES, BRANCH GOVLNG RDATTY * NO, DATA TYPE ERROR start1 ST=1 4 * SET ST4 FOR VECTORS GOTO start argerr GOVLNG ARGERR start2 ST=0 4 * CLEAR ST4 OTHERWISE start A=R1 * RESTORE A TO GET OUR NUMERIC PAR BACK C=0 W ?A=C A * WAS IT 0? GOYES base * LOWER BOUND WAS WANTED C=C+1 A ?A=C A * WAS IT 1? GOYES dim1 * No OF ROWS WAS WANTED C=C+1 A ?A>C A * ARG >2? GOYES argerr * INVALID ARGUMENT, OTHERWISE DIM2 WAS WANTED dim2 ?ST=1 4 * DO WE HAVE A VECTOR? GOYES vector GOSUB saveD1 * SELF EXPLANATORY D1=D1+ 3 * NIBS 3-6 HOLD DIM2 (OR MAXLEN) A=DAT1 4 * COPY TO A GOTO out * OUTPUT base GOSUB saveD1 D1=D1+ 2 * NIB 2 HOLDS LOWER BOUND A=DAT1 1 * COPY TO A out C=R0 * OUTPUT ROUTINE CD1EX out1 GOSBVL HDFLT * D1 WAS OK FROM vector D1=D1- 16 * SHIFT D1 BACK FOR OUTPUT ACEX W GOVLNG FNRTN1 * SEND RESULT OUT saveD1 CD1EX * ROUTINE TO SAVE D1 R0=C * IN R0 CD1EX RTN dim1 GOSUB saveD1 D1=D1+ 7 * NIBS 7-10 HOLD DIM1 (No OF ROWS) A=DAT1 4 * COPY TO A GOTO out vector A=0 W GOTO out1 * OUTPUT 0 FOR DIM2 OF VECTOR END ---------- LEX 'TFLAGS' * TOGGLE SYSTEM FLAGS ID #EC * RESTRICTED TO FLAGS -1 TO -59 MSG 0 * TO SAFEGUARD AGAINST MEMORY RESET POLL 0 ENTRY IN CHAR #F * A FUNCTION - RETURNS PREVIOUS VALUE OF FLAG KEY 'TFLAG' * SYNTAX TFLAG(-n), 1<=n<=59 TOKEN 12 POP1R EQU #0E8FD * POP 1 REAL FLTDH EQU #1B223 * FLOATING POINT TO HEX NUMBER CONVERSION HDFLT EQU #1B31B * THE REVERSE OF FLTDH SFLAGT EQU #13608 * SYSTEM FLAG TOGGLE ROUTINE (USED BY LC,USER ETC) FNRTN1 EQU #0F216 ARGERR EQU #0BF19 ENDTXT NIBHEX 811 * ONE OBLIGATORY NUMERIC PARAMETER IN GOSBVL POP1R * POP 1 REAL NUMBER A=0 S * CLEAR THE SIGN NIBBLE GOSBVL FLTDH * REAL IN A(W) TO HEX INTEGER IN A(A) C=0 W LC(2) #3C * #3C=60 DECIMAL ?C<=A B * PREVENT TOGGLE OF FLAGS -60 TO -64 GOYES ERROR C=0 A LC(3) #100 * FLAG NUMBER IS HEX COMPLEMENT OF #100 C=C-A X GOSBVL SFLAGT * TOGGLE ! ERRORS OUT ON USER FLAGS A=0 W * START SET-UP FOR OUTPUT GONC OUT * CARRY STATUS=PREVIOUS FLAG STATUS A=A+1 A * INCREMENT FOR ALTERNATE CASE OUT GOSBVL HDFLT * HEX INT. => REAL IN A(W) C=A W * COPY TO C(W) FOR OUTPUT GOVLNG FNRTN1 * BACK TO THE USER WITH PREVIOUS FLAG VALUE ERROR GOVLNG ARGERR END * WHEW! This keyword arose more as the result of the learning process, than from any real need. In retrospect I can see that it could be improved - e.g. the hex complement could have been achieved with: C=A B A=-A-1 B, and so on. To toggle an accessible flag : DEF KEY'%','N=VAL(DISP$)@N=FLAG(N,NOTFLAG(N))': ---------- LEX 'HORNER' * HORNER'S SCHEME FOR THE EVALUATION OF ID #EC * POLYNOMIALS UP TO DEGREE 13. MSG 0 POLL 0 ENTRY hORNER CHAR #F KEY 'INTERP' * FOR SYNTAX SEE BELOW TOKEN 13 FUNCD1 EQU #2F8C0 * A SAFE PLACE TO STORE D1 POP1R EQU #0E8FD * POP 1 REAL, ERROR ON COMPLEX SPLITA EQU #0C6BF * SPLIT A INTO A 15-FORM IN (A,B) MP2-15 EQU #0C43A * MULTIPLY TWO 15-FORMS AD2-15 EQU #0C363 * ADD TWO 15-FORMS uRES12 EQU #0C994 * 15-FORM IN (A,B) TO 12-FORM IN C(W) FNRTN1 EQU #0F216 * FNCTION EXIT ENDTXT NIBHEX 888888888888888 * ALL NUMERIC PARAMETERS NIBHEX 3F * AT LEAST 3, AT MOST 15 OF THEM! hORNER R0=C * SAVE C IN R0 - C(S) HOLDS NUMBER OF PARAMETERS CD1EX * ACTUALLY PASSED, THEN SAVE D1 D1=(5) FUNCD1 * IN FUNCD1. DAT1=C A CD1EX CD0EX R2=C * SAVE D0 IN R2 CD0EX C=R0 C=C-1 S * DECREMENT C(S) BY 3 BECAUSE DEGREE IS 3 LESS C=C-1 S * THAN NUMBER OF PARAMETERS C=C-1 S R3=C * SAVE DEGREE IN R3 GOSBVL POP1R * GET THE ARGUMENT OF THE POLYNOMIAL GOSBVL SPLITA R0=A * SAVE IN R0 AND R1 A=B W * REGISTER B WON'T TALK TO SCRATCH REGISTERS R1=A D1=D1+ 16 * SHIFT ALONG STACK FOR NEXT PARAMETER GOSBVL POP1R * COLLECT IT (THIS ONE IS THE LEADING GOSBVL SPLITA * COEFFICIENT) loop C=R1 * RECOVER D=C W * THE POLYNOMIAL C=R0 * ARGUMENT. GOSBVL MP2-15 * MULTIPLY C=B W * COPY (A,B) INTO (C,D) D=C W C=A W D1=D1+ 16 * MOVE D1 TO PICK UP NEXT COEFFICIENT GOSBVL POP1R GOSBVL SPLITA GOSBVL AD2-15 * ADD CR3EX * R3 CONTAINS THE COUNTER C=C-1 S * WHICH IS NOW DECREMENTED CR3EX * AND REPLACED GONC loop * CARRY SET IF NO MORE COEFFICIENTS GOSBVL uRES12 * RESULT IS PUT INTO C(W) FOR FNRTN1 D1=(5) FUNCD1 * RESTORE D1 FOR OUTPUT A=DAT1 A * PUT IT IN A(A) D1=A A=R2 GOSBVL FNRTN1 * EXIT END SYNTAX: INTERP(a0,a1[,a2[,a3[,a4[,a5[,a6[,a7.....[,a13]]]...],x), where the subscripted a's are the coefficients and x is the polynomial argument. In standard polynomial notation, we want to evaluate: f(x)=a0+a1x+a2x^2+a3x^3+....+a13x^13 . This is a very poor method numerically as it leads to severe rounding errors through exponentiation. Horner's scheme, however, is not subject to that since no exponentiation is done: f(x)=a0+x(a1+x(a2+x(a3+x(....(a12+a13x))...). * JACK ELHAY ---------- End of File