.segment "CODE" ; ---------------------------------------------------------------------------- ; "STR$" FUNCTION ; ---------------------------------------------------------------------------- STR: jsr CHKNUM ldy #$00 jsr FOUT1 pla pla LD353: lda #<(STACK2-1) ldy #>(STACK2-1) .if STACK2 > $0100 bne STRLIT .else beq STRLIT .endif ; ---------------------------------------------------------------------------- ; GET SPACE AND MAKE DESCRIPTOR FOR STRING WHOSE ; ADDRESS IS IN FAC+3,4 AND WHOSE LENGTH IS IN A-REG ; ---------------------------------------------------------------------------- STRINI: ldx FAC_LAST-1 ldy FAC_LAST stx DSCPTR sty DSCPTR+1 ; ---------------------------------------------------------------------------- ; GET SPACE AND MAKE DESCRIPTOR FOR STRING WHOSE ; ADDRESS IS IN Y,X AND WHOSE LENGTH IS IN A-REG ; ---------------------------------------------------------------------------- STRSPA: jsr GETSPA stx FAC+1 sty FAC+2 sta FAC rts ; ---------------------------------------------------------------------------- ; BUILD A DESCRIPTOR FOR STRING STARTING AT Y,A ; AND TERMINATED BY $00 OR QUOTATION MARK ; RETURN WITH DESCRIPTOR IN A TEMPORARY ; AND ADDRESS OF DESCRIPTOR IN FAC+3,4 ; ---------------------------------------------------------------------------- STRLIT: ldx #$22 stx CHARAC stx ENDCHR ; ---------------------------------------------------------------------------- ; BUILD A DESCRIPTOR FOR STRING STARTING AT Y,A ; AND TERMINATED BY $00, (CHARAC), OR (ENDCHR) ; ; RETURN WITH DESCRIPTOR IN A TEMPORARY ; AND ADDRESS OF DESCRIPTOR IN FAC+3,4 ; ---------------------------------------------------------------------------- STRLT2: sta STRNG1 sty STRNG1+1 sta FAC+1 sty FAC+2 ldy #$FF L3298: iny lda (STRNG1),y beq L32A9 cmp CHARAC beq L32A5 cmp ENDCHR bne L3298 L32A5: cmp #$22 beq L32AA L32A9: clc L32AA: sty FAC tya adc STRNG1 sta STRNG2 ldx STRNG1+1 bcc L32B6 inx L32B6: stx STRNG2+1 lda STRNG1+1 .ifdef CONFIG_NO_INPUTBUFFER_ZP beq LD399 cmp #>INPUTBUFFER .elseif .def(AIM65) beq LD399 cmp #$01 .endif bne PUTNEW LD399: tya jsr STRINI ldx STRNG1 ldy STRNG1+1 jsr MOVSTR ; ---------------------------------------------------------------------------- ; STORE DESCRIPTOR IN TEMPORARY DESCRIPTOR STACK ; ; THE DESCRIPTOR IS NOW IN FAC, FAC+1, FAC+2 ; PUT ADDRESS OF TEMP DESCRIPTOR IN FAC+3,4 ; ---------------------------------------------------------------------------- PUTNEW: ldx TEMPPT cpx #TEMPST+9 bne PUTEMP ldx #ERR_FRMCPX JERR: jmp ERROR PUTEMP: lda FAC sta 0,x lda FAC+1 sta 1,x lda FAC+2 sta 2,x ldy #$00 stx FAC_LAST-1 sty FAC_LAST .ifdef CONFIG_2 sty FACEXTENSION .endif dey sty VALTYP stx LASTPT inx inx inx stx TEMPPT rts ; ---------------------------------------------------------------------------- ; MAKE SPACE FOR STRING AT BOTTOM OF STRING SPACE ; (A)=# BYTES SPACE TO MAKE ; ; RETURN WITH (A) SAME, ; AND Y,X = ADDRESS OF SPACE ALLOCATED ; ---------------------------------------------------------------------------- GETSPA: lsr DATAFLG L32F1: pha eor #$FF sec adc FRETOP ldy FRETOP+1 bcs L32FC dey L32FC: cpy STREND+1 bcc L3311 bne L3306 cmp STREND bcc L3311 L3306: sta FRETOP sty FRETOP+1 sta FRESPC sty FRESPC+1 tax pla rts L3311: ldx #ERR_MEMFULL lda DATAFLG bmi JERR jsr GARBAG lda #$80 sta DATAFLG pla bne L32F1 ; ---------------------------------------------------------------------------- ; SHOVE ALL REFERENCED STRINGS AS HIGH AS POSSIBLE ; IN MEMORY (AGAINST HIMEM), FREEING UP SPACE ; BELOW STRING AREA DOWN TO STREND. ; ---------------------------------------------------------------------------- GARBAG: .ifdef CONST_MEMSIZ ldx #CONST_MEMSIZ .else ldx MEMSIZ lda MEMSIZ+1 .endif FINDHIGHESTSTRING: stx FRETOP sta FRETOP+1 ldy #$00 sty FNCNAM+1 .ifdef CONFIG_2 sty FNCNAM ; GC bugfix! .endif lda STREND ldx STREND+1 sta LOWTR stx LOWTR+1 lda #TEMPST ldx #$00 sta INDEX stx INDEX+1 L333D: cmp TEMPPT beq L3346 jsr CHECK_VARIABLE beq L333D L3346: lda #BYTES_PER_VARIABLE sta DSCLEN lda VARTAB ldx VARTAB+1 sta INDEX stx INDEX+1 L3352: cpx ARYTAB+1 bne L335A cmp ARYTAB beq L335F L335A: jsr CHECK_SIMPLE_VARIABLE beq L3352 L335F: sta HIGHDS stx HIGHDS+1 lda #$03 ; OSI GC bugfix -> $04 ??? sta DSCLEN L3367: lda HIGHDS ldx HIGHDS+1 L336B: cpx STREND+1 bne L3376 cmp STREND bne L3376 jmp MOVE_HIGHEST_STRING_TO_TOP L3376: sta INDEX stx INDEX+1 .ifdef CONFIG_SMALL ldy #$01 .else ldy #$00 lda (INDEX),y tax iny .endif lda (INDEX),y php iny lda (INDEX),y adc HIGHDS sta HIGHDS iny lda (INDEX),y adc HIGHDS+1 sta HIGHDS+1 plp bpl L3367 .ifndef CONFIG_SMALL txa bmi L3367 .endif iny lda (INDEX),y .ifdef CONFIG_CBM1_PATCHES jsr LE7F3 ; XXX patch, call into screen editor .else .ifdef CONFIG_11 ldy #$00 ; GC bugfix .endif asl a adc #$05 .endif adc INDEX sta INDEX bcc L33A7 inc INDEX+1 L33A7: ldx INDEX+1 L33A9: cpx HIGHDS+1 bne L33B1 cmp HIGHDS beq L336B L33B1: jsr CHECK_VARIABLE beq L33A9 ; ---------------------------------------------------------------------------- ; PROCESS A SIMPLE VARIABLE ; ---------------------------------------------------------------------------- CHECK_SIMPLE_VARIABLE: .ifndef CONFIG_SMALL lda (INDEX),y bmi CHECK_BUMP .endif iny lda (INDEX),y bpl CHECK_BUMP iny ; ---------------------------------------------------------------------------- ; IF STRING IS NOT EMPTY, CHECK IF IT IS HIGHEST ; ---------------------------------------------------------------------------- CHECK_VARIABLE: lda (INDEX),y beq CHECK_BUMP iny lda (INDEX),y tax iny lda (INDEX),y cmp FRETOP+1 bcc L33D5 bne CHECK_BUMP cpx FRETOP bcs CHECK_BUMP L33D5: cmp LOWTR+1 bcc CHECK_BUMP bne L33DF cpx LOWTR bcc CHECK_BUMP L33DF: stx LOWTR sta LOWTR+1 lda INDEX ldx INDEX+1 sta FNCNAM stx FNCNAM+1 lda DSCLEN sta Z52 ; ---------------------------------------------------------------------------- ; ADD (DSCLEN) TO PNTR IN INDEX ; RETURN WITH Y=0, PNTR ALSO IN X,A ; ---------------------------------------------------------------------------- CHECK_BUMP: lda DSCLEN clc adc INDEX sta INDEX bcc L33FA inc INDEX+1 L33FA: ldx INDEX+1 ldy #$00 rts ; ---------------------------------------------------------------------------- ; FOUND HIGHEST NON-EMPTY STRING, SO MOVE IT ; TO TOP AND GO BACK FOR ANOTHER ; ---------------------------------------------------------------------------- MOVE_HIGHEST_STRING_TO_TOP: .ifdef CONFIG_2 lda FNCNAM+1 ; GC bugfix ora FNCNAM .else ldx FNCNAM+1 .endif beq L33FA lda Z52 .ifndef CONFIG_10A sbc #$03 .else and #$04 .endif lsr a tay sta Z52 lda (FNCNAM),y adc LOWTR sta HIGHTR lda LOWTR+1 adc #$00 sta HIGHTR+1 lda FRETOP ldx FRETOP+1 sta HIGHDS stx HIGHDS+1 jsr BLTU2 ldy Z52 iny lda HIGHDS sta (FNCNAM),y tax inc HIGHDS+1 lda HIGHDS+1 iny sta (FNCNAM),y jmp FINDHIGHESTSTRING ; ---------------------------------------------------------------------------- ; CONCATENATE TWO STRINGS ; ---------------------------------------------------------------------------- CAT: lda FAC_LAST pha lda FAC_LAST-1 pha jsr FRM_ELEMENT jsr CHKSTR pla sta STRNG1 pla sta STRNG1+1 ldy #$00 lda (STRNG1),y clc adc (FAC_LAST-1),y bcc L3454 ldx #ERR_STRLONG jmp ERROR L3454: jsr STRINI jsr MOVINS lda DSCPTR ldy DSCPTR+1 jsr FRETMP jsr MOVSTR1 lda STRNG1 ldy STRNG1+1 jsr FRETMP jsr PUTNEW jmp FRMEVL2 ; ---------------------------------------------------------------------------- ; GET STRING DESCRIPTOR POINTED AT BY (STRNG1) ; AND MOVE DESCRIBED STRING TO (FRESPC) ; ---------------------------------------------------------------------------- MOVINS: ldy #$00 lda (STRNG1),y pha iny lda (STRNG1),y tax iny lda (STRNG1),y tay pla ; ---------------------------------------------------------------------------- ; MOVE STRING AT (Y,X) WITH LENGTH (A) ; TO DESTINATION WHOSE ADDRESS IS IN FRESPC,FRESPC+1 ; ---------------------------------------------------------------------------- MOVSTR: stx INDEX sty INDEX+1 MOVSTR1: tay beq L3490 pha L3487: dey lda (INDEX),y sta (FRESPC),y tya bne L3487 pla L3490: clc adc FRESPC sta FRESPC bcc L3499 inc FRESPC+1 L3499: rts ; ---------------------------------------------------------------------------- ; IF (FAC) IS A TEMPORARY STRING, RELEASE DESCRIPTOR ; ---------------------------------------------------------------------------- FRESTR: jsr CHKSTR ; ---------------------------------------------------------------------------- ; IF STRING DESCRIPTOR POINTED TO BY FAC+3,4 IS ; A TEMPORARY STRING, RELEASE IT. ; ---------------------------------------------------------------------------- FREFAC: lda FAC_LAST-1 ldy FAC_LAST ; ---------------------------------------------------------------------------- ; IF STRING DESCRIPTOR WHOSE ADDRESS IS IN Y,A IS ; A TEMPORARY STRING, RELEASE IT. ; ---------------------------------------------------------------------------- FRETMP: sta INDEX sty INDEX+1 jsr FRETMS php ldy #$00 lda (INDEX),y pha iny lda (INDEX),y tax iny lda (INDEX),y tay pla plp bne L34CD cpy FRETOP+1 bne L34CD cpx FRETOP bne L34CD pha clc adc FRETOP sta FRETOP bcc L34CC inc FRETOP+1 L34CC: pla L34CD: stx INDEX sty INDEX+1 rts ; ---------------------------------------------------------------------------- ; RELEASE TEMPORARY DESCRIPTOR IF Y,A = LASTPT ; ---------------------------------------------------------------------------- FRETMS: .ifdef KBD cpy #$00 .else cpy LASTPT+1 .endif bne L34E2 cmp LASTPT bne L34E2 sta TEMPPT sbc #$03 sta LASTPT ldy #$00 L34E2: rts ; ---------------------------------------------------------------------------- ; "CHR$" FUNCTION ; ---------------------------------------------------------------------------- CHRSTR: jsr CONINT txa pha lda #$01 jsr STRSPA pla ldy #$00 sta (FAC+1),y pla pla jmp PUTNEW ; ---------------------------------------------------------------------------- ; "LEFT$" FUNCTION ; ---------------------------------------------------------------------------- LEFTSTR: jsr SUBSTRING_SETUP cmp (DSCPTR),y tya SUBSTRING1: bcc L3503 lda (DSCPTR),y tax tya L3503: pha SUBSTRING2: txa SUBSTRING3: pha jsr STRSPA lda DSCPTR ldy DSCPTR+1 jsr FRETMP pla tay pla clc adc INDEX sta INDEX bcc L351C inc INDEX+1 L351C: tya jsr MOVSTR1 jmp PUTNEW ; ---------------------------------------------------------------------------- ; "RIGHT$" FUNCTION ; ---------------------------------------------------------------------------- RIGHTSTR: jsr SUBSTRING_SETUP clc sbc (DSCPTR),y eor #$FF jmp SUBSTRING1 ; ---------------------------------------------------------------------------- ; "MID$" FUNCTION ; ---------------------------------------------------------------------------- MIDSTR: lda #$FF sta FAC_LAST jsr CHRGOT cmp #$29 beq L353F jsr CHKCOM jsr GETBYT L353F: jsr SUBSTRING_SETUP .ifdef CONFIG_2 beq GOIQ .endif dex txa pha clc ldx #$00 sbc (DSCPTR),y bcs SUBSTRING2 eor #$FF cmp FAC_LAST bcc SUBSTRING3 lda FAC_LAST bcs SUBSTRING3 ; ---------------------------------------------------------------------------- ; COMMON SETUP ROUTINE FOR LEFT$, RIGHT$, MID$: ; REQUIRE ")"; POP RETURN ADRS, GET DESCRIPTOR ; ADDRESS, GET 1ST PARAMETER OF COMMAND ; ---------------------------------------------------------------------------- SUBSTRING_SETUP: jsr CHKCLS pla .ifndef CONFIG_11 sta JMPADRS+1 pla sta JMPADRS+2 .else tay pla sta Z52 .endif pla pla pla tax pla sta DSCPTR pla sta DSCPTR+1 .ifdef CONFIG_11 lda Z52 pha tya pha .endif ldy #$00 txa .ifndef CONFIG_2 beq GOIQ .endif .ifndef CONFIG_11 inc JMPADRS+1 jmp (JMPADRS+1) .else rts .endif ; ---------------------------------------------------------------------------- ; "LEN" FUNCTION ; ---------------------------------------------------------------------------- LEN: jsr GETSTR SNGFLT1: jmp SNGFLT ; ---------------------------------------------------------------------------- ; IF LAST RESULT IS A TEMPORARY STRING, FREE IT ; MAKE VALTYP NUMERIC, RETURN LENGTH IN Y-REG ; ---------------------------------------------------------------------------- GETSTR: jsr FRESTR ldx #$00 stx VALTYP tay rts ; ---------------------------------------------------------------------------- ; "ASC" FUNCTION ; ---------------------------------------------------------------------------- ASC: jsr GETSTR beq GOIQ ldy #$00 lda (INDEX),y tay .ifndef CONFIG_11A jmp SNGFLT1 .else jmp SNGFLT .endif ; ---------------------------------------------------------------------------- GOIQ: jmp IQERR ; ---------------------------------------------------------------------------- ; SCAN TO NEXT CHARACTER AND CONVERT EXPRESSION ; TO SINGLE BYTE IN X-REG ; ---------------------------------------------------------------------------- GTBYTC: jsr CHRGET ; ---------------------------------------------------------------------------- ; EVALUATE EXPRESSION AT TXTPTR, AND ; CONVERT IT TO SINGLE BYTE IN X-REG ; ---------------------------------------------------------------------------- GETBYT: jsr FRMNUM ; ---------------------------------------------------------------------------- ; CONVERT (FAC) TO SINGLE BYTE INTEGER IN X-REG ; ---------------------------------------------------------------------------- CONINT: jsr MKINT ldx FAC_LAST-1 bne GOIQ ldx FAC_LAST jmp CHRGOT ; ---------------------------------------------------------------------------- ; "VAL" FUNCTION ; ---------------------------------------------------------------------------- VAL: jsr GETSTR bne L35AC jmp ZERO_FAC L35AC: ldx TXTPTR ldy TXTPTR+1 stx STRNG2 sty STRNG2+1 ldx INDEX stx TXTPTR clc adc INDEX sta DEST ldx INDEX+1 stx TXTPTR+1 bcc L35C4 inx L35C4: stx DEST+1 ldy #$00 lda (DEST),y pha lda #$00 sta (DEST),y jsr CHRGOT jsr FIN pla ldy #$00 sta (DEST),y ; ---------------------------------------------------------------------------- ; COPY STRNG2 INTO TXTPTR ; ---------------------------------------------------------------------------- POINT: ldx STRNG2 ldy STRNG2+1 stx TXTPTR sty TXTPTR+1 rts