LnSOS BOOT 1.1 SOS.KERNEL SOS KRNLI/O ERRORFILE 'SOS.KERNEL' NOT FOUND%INVALID KERNEL FILE: xةw,@  ȱlmi8#)!) 1 2 5 3\ 4 6 7 8 9 10 VV::AO^9Y |*MAPIT.TEXT A4,MY.DISP.TEXT A .OLDCALC.1.TEXT7lA ,PKYMACS.TEXT A -READ.ME.FIRST%SEG.T jŸ/ *MENU.MAKER A ,)DUMP.TEXTx A ,-FONT.201.TEXT A6 )FONT.TEXT A6 )LOAD.TEXT A* -LOCK.201.TEXT A*&)LOCK.TEXT A*&III.SRC.03C.Bu' -CALC.SCT.TEXTA %* )CALC.TEXT'LA (!-CALLMACS.TEXT>A l-CRPT.202.TEXTMA +% )CRPT.TEXT\A , -DUMP.201.TEXTk >dLԡm#i㰼m#iЕOLԡȱfg hi !dLԡ憦  Ljmkm l y`2 Lԡ8(Je稽)ʈ@L  BPL sct_SG1 LDA FR1+1 ;BRANCH IF < 2 CMP #02 BLT sct_RR10 movenum N4,FR2 ;FR1 = 4-FR1, LDA FR1+2 ;SGN = -SGN ORA #080 STA FR1+2 JSR SYSDADD LDA FR1+2 BMI sct_RR8 JSR SYSDROL JMP sct_RR7 sct_RR8 LDA FR1+2 ;RESTORE SIGN AND #07F STA FR1+2 ; ; REDUCE RANGE FROM [0,4] TO [0,1] ; sct_RR9 LDA FR1 ;QUIT IF < .5 sct_RR5 JSR SYSDROL ;REMOVE INTEGER JMP sct_RR4 sct_RR6 LDX #15. ;NORMALIZE sct_RR6A LDA FR1+2,X BNE sct_RR7 DBPL X,sct_RR6A STA FR1 STA FR1+1 BMI sct_RTS sct_RR7 BPL sct_RR6 ;MAINTAIN PRECISION CMP #080 ;WHILE REMOVING MULTIPLES BNE sct_RR5 ;OF 2*PI LDA FR1+1 CMP #03 BLT sct_RR6 BLT sct_RR3 BNE sct_RR2 INX CPX #3. BNE sct_RR1 sct_RR2 FERR #1 sct_RTS RTS sct_RR3 movenum IHPI,FR2 ;FR1=FR1*2/PI JSR SYSDMUL sct_RR4 LDA FR1 ;USE EXTENDED RESULT TO ascii "SYSDSIN" (.endc  SYSDSIN LDA FR1+2 ;REMOVE AND SAVE SIGN AND #080 STA sct_SGN LDA FR1+2 ORA #080 STA FR1+2 LDX #0 ;CHECK SIZE sct_RR1 LDA FR1,X CMP MAX,X (.ascii "SYSDCOS" (.endc ( SYSDCOS ; CHANGE ARGUMENT: COS(X) = SIN(X+PI/2) 'movenum HALFPI,FR2 JSR SYSDADD 8; 8; REMOVE MULTIPLES OF 2*PI, MAPPING THE 8; UNIT CIRCLE FROM [0,2*PI] TO [0,4] 8; (.if test (. * ;* 1) ALGORITHM DEVELOPED FROM * ;* CODY, PP 125-149. TABLE * ;* 3346 FROM HART. * ;* * ;**************************************** ;* (.if test * ;* FR1 - ARGUMENT * ;* * ;* OUTPUTS: * ;* FR1 - RESULT * ;* * ;* NOTES: SIN(X) * ;* * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 * ;* BY HAYDEN BOOK COMPANY, INC. * ;* * ;* INPUTS: ; ; could save a few bytes by replacing the refs to N2 and N4 by N1's with ; appropriate incs of the dest reg+1 ; ;**************************************** ;* * ;* SYSDCOS - COS(X) * ;* SYSDSIN - LDA sct_SGN EOR #080 STA sct_SGN sct_RR10 LDA FR1 ;QUIT IF < .5 BPL sct_SG1 LDA FR1+1 ;BRANCH IF < 1 BEQ sct_SG1 movenum N2,FR2 ;FR1=2-FR1 LDA FR1+2 ORA #080 STA FR1+2 JSR SYSDADD ; ; DONE IF FR1 < EPS (SMALL ANGLE ; APPROXIMATION ; sct_SG1 LDA FR1 ;CHECK SIZE CMP EPS BLT sct_SG2 BNE sct_PE1 LDA FR1+ !"#$%&'()*+,-./0123456789:;<1 2 3 4 5 6 SOUT ]9IC ! !`CO^508B,062,0C5 '.byte 07F,0FD,023,035,0E3,03B,0AD,057,00C,078,043 '.byte 080,000,0A5,05D,0E7,031,02D,0F2,095,0F3,043 '.byte 080,001,049,00F,0DA,0A2,021,068,0C2,034,0C4 p_p09 .word p09-2000  .byte 07F,0E2,0B7,0D6,0A2,01F,046,0D5,09B,007,007 '.byte 07F,0E8,074,07A,019,0BE,047,0CC,088,0FC,059 '.byte 07F,0EE,0F1,083,0A7,0EE,014,04E,0C4,0AE,0BC '.byte 07F,0F4,028,03C,01A,043,0F5,0EF,0DD,064,0D2 '.byte 07F,0F9,099,069,066,073,015,0EA,N2 .byte 080,002,000,000,000,000,000,000,000,000,000 N4 .byte 080,003,000,000,000,000,000,000,000,000,000 EPS .byte 07F,0BC P09 .byte 07F,0D4,0BF,05A,04E,07E,0A8,0C1,029,0FA,0EF '.byte 07F,0DB,055,05D,060,031,011,073,06C,05E,0DB ' numlen,00  ; ; DATA AREAS ; MAX .byte 080,022,0C9 const_PI .byte 080,002,049,00F,0DA,0A2,021,068,0BF,0E5,0C2  HALFPI .byte 080,001,049,00F,0DA,0A2,021,068,0BF,0E5,0C2 IHPI .byte 080,000,022,0F9,083,06E,04E,044,015,029,0FC FR1,X STA TFR2,X LDA TFR1,X STA FR1,X DBPL X,DT1 JSR SYSDSIN movenum TFR2,FR2 JMP SYSDDIV  sct_SGN .byte 00 sct_N .block numlen,00  TFR1 .block numlen,00 TFR2 .block FR2 - RESULT * ;* * ;**************************************** ;* (.if test (.ascii "SYSDTAN" (.endc  SYSDTAN movenum FR1,TFR1 JSR SYSDCOS LDX #10. DT1 LDA ;* BY HAYDEN BOOK COMPANY, INC. * ;* * ;* INPUTS: * ;* FR1 - ARGUMENT * ;* * ;* OUTPUTS: * ;* *********************** ;* * ;* SYSDTAN - TAN (X) * ;* * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 * ;FR1 = N^2 LA R6,P09 ;FR1 = P(N^2)*N LM R8,#9 JSR SYSDPOL movenum sct_N,FR2 JSR SYSDMUL ; ; SET SIGN ; sct_SS1 LDA sct_SGN EOR FR1+2 STA FR1+2 RTS ;*****************1 CMP EPS+1 BGE sct_PE1 sct_SG2 movenum HALFPI,FR2 ;MAP TO RADIANS JSR SYSDMUL JMP sct_SS1 ; ; POLYNOMIAL EXPANSION ; sct_PE1 movenum FR1,FR2 ;N = FR1 +movenum FR1,sct_N JSR SYSDMUL M1H .equ 091 ;MATH REGISTERS M2L .equ 092 M2H .equ 093 M3L .equ 094 M3H .equ 095 SIGN .equ 096 ERR_number .equ 097 ;FLOATING POINT ERROR # AD1 .equ 098 ;FP AND DP OPERAND RAD .equ 09A ; LOAD REGISTERS R7 .equ 087 R8 .equ 088 R9 .equ 089 R10 .equ 08A R11 .equ 08B R12 .equ 08C R13 .equ 08D R14 .equ 08E R15 .equ 08F xb_r6 .equ 1687 xb_r10 .equ 168b   M1L .equ 090 ;TWO BYTE INTEGER mmon  entry jsr my_init 0jsr do_it 0jsr wrap_up 0rts  ; COMMON DATA R0 .equ 080 ;GENERAL PURPOSE R1 .equ 081 ;REGISTERS R2 .equ 082 R3 .equ 083 R4 .equ 084 R5 .equ 085 R6 .equ 086;e  undo_cmd .equ 002 ;cntl-u  start (jmp entry (.ascii "K" (.word start-1 (.word end-start (.ascii "QuikCalc"  (.INCLUDE CALC.MAC (.include pkymacs (.include callmacs (.include zpco numlen .equ 0b ;double precision = 11 bytes/number rest_mem .equ 012 ;cntl-r clr_entry .equ 003 ;cntl-c pi .equ 022 ;quote ; e .equ 065 s, etc. ; 2.02 remove put_char and add back cursor to error char beep ; 2.01 initial version with full impl. ; 2.00 initial testing version ; ;------------------------------------------------------------------ test .equ 0 ered cntl chars out on first char typed ; 2.05 added my_display to SYSDOUT to handle non-E numbers ; 2.04 fixed re-show of first char typed ; 2.03 added Clr, ce and cr=add handlers, fixed chained ops handler ; and unified display of resultantilog) ; clear out supermacros on entry and restore at exit ; added logic to get_num to check for double E.- chars ; also allows leading - sign ; ; 2.06 set getnum to default to prev result for no num entry ; and filt; added simple error trap to display * (beep) and zero result ; added undo (cntl-U) command ; changed clears to cntl-Z = zero and cntl-C = clear ; added dummy pi and e constants ; added EXP function with cntl-L (for changed entry command to (K)alc ; added memory register with save/restore (cntl-S,R) ; no longer clearing screen on entry ; loading result on eXit into = macro unless too big ; no loading of = macro if Quit used changed string store locs from x'30 to x'20 bytes ; change undo to backup ; remove e const, change e to exp fn ; added Help line display ; added deg and %pct functions ; 2.07 added SIN COS TAN functions ; orage in macro correctly ; fix to handle incorrect re-display for 0>x>.01 ; and .01 display as .01. ; ; 2.10 fixes for - neg nums and macro loading for E1 numbers ; ; 2.09 fixes for 2.08 ; 2.08 fixes for 2.07 ; 0.PROC CALC,0 ;------------------------------------------------------------------ ; ; calc 2.12 9/05/86 ; ; 2.12 want fix for macro 1.23 from 1.234 ; want fix for Zero command after 123 -> 023 ; 2.11 fix to handle "0" value st FR1 .equ 09C ;FLOATING POINT FR2 .equ 0B0 ; MATH REGISTERS RETAD .equ 0BC ;RETURN ADDRESS CHRAD .equ 0BE ;CHARACTER ADDRESS do_it gnum_1 jsr get_num ;num--> fr1, op--> save_op  gnum_1a moveb #00,op_pend_flag (jsr fr1_2_result (moveb save_op,curr_op (moveb save_op_num,curr_op_num ( (tax ;check for binary op (lda bin_op_tbl,x (cmp #02 (bne gnum_2a gnum_2 (jsr get_num ;se(lda #1f (jsr put_char ;clear to end of line (rts   put_string (ldy string_index (sta string,y (iny (sty string_index (rts handle_op2 ;set op pending flag for second op which @;is a binary op (lrts   beep_n_back  lda #07 ;beep (jsr put_char (lda #08 ;backup (jsr put_char (lda #20 (jsr put_char (lda #08 (jsr put_char (rts  clear_display (CALL m_msg0,p_gn_msg string+1 (jsr SYSDPIN ;convert string to FR1 number ( (rts fr1_2_result (ldx #numlen-1 $005 lda result,x (sta save_undo,x (lda fr1,x (sta result,x (dex (bpl $005 (rts  result_2_fr1 (movenum result,fr1 ( get_one  is_an_op ;is an op (stx save_op_num (sta save_op (lda string_index (beq $090 ;leave old string there if no new nmbr (lda #0ff (jsr put_string $090 ldy adj_p_string (lda adj_p_ jsr put_string ;add char to string (jmp get_one  chk_for_op ;char is not ok for number (ldx max_ops $010 cmp op_table,x (beq is_an_op (dex (bpl $010 (jsr beep_n_back (jmp (beq char_is_ok (jmp beep_n_back alpha_cnt .byte 01 alpha_tbl .ascii "E." alpha_f_tbl e_cnt .byte 0ff dp_cnt .byte 0ff char_is_ok ;char is ok for number (bne chk_num (jmp get_num ( chk_num jsr SYSNMID ;checks for 0-9 (bcs char_is_ok ( chk_alpha (ldx alpha_cnt $005 cmp alpha_tbl,x (beq $010 (dex (bpl $005 (bmi chk_for_op $010 inc alpha_f_tbl,x  #020 (bcs $010 ;don't display cntl chars 2.10 (lda #020 ;show a dummy space instead 2.10 $010 jsr put_char (pla $090 rts ( ( get_one jsr get_char (cmp #clr_entry ;cntl-c is clear-entry... (rts  $030 cmp #undo_cmd ;cntl-u (bne $040 (movenum save_undo,fr1 (rts $040 jsr clear_n_showit ;2.10 (jmp chk_num clear_n_showit (pha (jsr clear_display pla (pha (cmp p the "-" 2.10 (jmp char_is_ok ;does put_string & jmp to get_one 2.10 ( $010 cmp #pi (bne $020 (movenum const_pi,fr1 (rts $020 cmp #rest_mem ;cntl-r (bne $030 (movenum mem_reg,fr1 SYSDOUT (jsr result_2_fr1 (CALL m_msg,p_string get_first (jsr get_char chk_first ;check for constants e pi(") or restore or undo command (cmp #"-" (bne $010 ;leading minus sign ok (jsr clear_n_showit ;puts uperator number in table ( (ldx #00 (stx string_index (stx save_op (stx save_op_num (dex (stx dp_cnt ;initialize these to ff so one inc -> 0 (stx e_cnt ( (CALL m_msg0,p_gn_msg  (jsr result_2_fr1 (jsr (bpl gnum_1 ;---------------------------------------------------- get_num ;accept char input for proper number 0;terminated by an operator 0;result is fr1 << number 0; save_op << operator char ( ; save_op_num << ocond number for binary ops (moveb save_op,next_op (jsr handle_op2 (movenum fr1,fr2 ;set up two operands for binop (jsr result_2_fr1 gnum_2a jsr do_the_op (jsr fr1_2_result (bit op_pend_flag (bmi gnum_1a dx save_op_num (lda bin_op_tbl,x (cmp #02 (bne $090 (moveb #80,op_pend_flag (moveb next_op,save_op $090 rts (  do_the_op (lda curr_op_num (asl a (tay (lda opfn_tbl+1,y (pha (lda opfn_tbl,y (pha (rts (  get_char CALL m_get_char 0and #7f 0rts put_char CALL m_put_char 0rts do_exit jsr set_macro ;save number string in + macro H;unless "E" format  do_quit pla 0pla do_null do_eq rts 0.byte 01,02   opfn_tbl .word do_null-1 0.word SYSDADD-1 0.word SYSDSUB-1 0.word SYSDMUL-1 0.word SYSDDIV-1 0.word SYSDPWR-1 0.word do_eq-1 0.word do_quit-1 0.word do_exit-1 0.word do_zero-1 0.word SYSDADD-1 ;SIN COS TAN 0.ascii "d%" ;DEG PCT 0 binop_tbl .byte 01 0.byte 02,02,02,02,02,01 0.byte 01 0.byte 01 0.byte 01 0.byte 02 0.byte 01,01 0.byte 01 0.byte 01 0.byte 01,01,01 ;cntl-Z is Zero 0.byte 00d ;cr does add 0.ascii "Ll" ;LOG, LN 0.byte 013 ;cntl-S is memStore 0.ascii "e" ;e is antilog (EXP) 0.ascii "sct" .word get_num_msg max_ops .byte 13 op_table .byte 00 ;null op does eq 0.ascii "+-*/^=" 0.byte 011 ;cntl-Q is QUIT 0.byte 018 ;cntl-X is eXit 0.byte 01a sv_xb_r6 .byte 00 sv_xb_r10 .byte 00 sv_1a80 .block 40,0 ;x'80-BF  save_op .byte 00 save_op_num .byte 00 string_index .byte 00 get_num_msg .ascii "CALC >> " 0.byte 0ff  p_gn_msg0 0inc zp_key_data+1 0 $005 lda string,x ;2.10 0sta @zp_key_data,y 0dey 0dex 0bpl $005 0dec zp_key_data+1 $090 rts 0 0 ; ; LOCAL DATA AREAS ; macro_len .byte 00 value 0 0and #7f 0tax 0 ;1D is offset into macro table of the = key @;we will bump ptr up one page then use @;the 0D * 10 (macro entry len) = D0 as a @;ptr to the base of the = entry 0clc 0lda #0d0 0adc macro_len 0tay 0 0bcs $090 0 lda actual_len 0cmp #011 0bcc $002 0lda #010 0 $002 sta macro_len ora #080 0ldy #1d ;offset to = key macro 0sta @zp_on_flags,y ;set the flag 0bne $020 0lda #01 0sta actual_len 0bne $002 0 $020 lda save_the_exp+1 ;don't load macro if the 0and #7f ;result is > e15 or < e-15 0bne $090 0lda save_the_exp 0cmp #1(rts save_123 .byte 00,00,00 rest_123_macs  ldy #02 $005 lda save_123,y (sta @zp_on_1_flag,y (dey (bpl $005 (rts  set_macro 0lda fr1 ;2.11 check for "0" 0ora fr1+1 80,y (sta 1a80,y (dey (bpl $005 ( (moveb sv_xb_r6,xb_r6 (moveb sv_xb_r10,xb_r10 (rts  save_123_macs (ldx #00 (ldy #02 $005 lda @zp_on_1_flag,y (sta save_123,y (txa (sta @zp_on_1_flag,y (dey (bpl $005 005 lda 1a80,y (sta sv_1a80,y (dey (bpl $005 ( (lda 0ffef (sta xb_r6 (sta xb_r10 (jsr save_123_macs  (CALL m_msg,p_help_msg (rts  wrap_up (jsr rest_123_macs (ldy #3f $005 lda sv_1ado_pct_fn jsr SYSDMUL 0movenum N100,fr2 0jmp SYSDDIV  ;---------------------- init and wrap stuff ------------------------  my_init (moveb #00,err_number  moveb xb_r6,sv_xb_r6 (moveb xb_r10,sv_xb_r10  (ldy #3f $ do_zero lda #00 0sta result 0sta result+1 0sta sout_exp 0sta sout_exp+1 0pla 0pla 0jmp do_it 0 do_memstore movenum fr1,mem_reg 0rts do_deg_fn movenum k_pi_div_180,fr2 0jmp SYSDMUL ;cr=add 0.word SYSDLOG-1 0.word SYSDLNX-1  .word do_memstore-1 0.word SYSDEXP-1 0.word SYSDSIN-1 0.word SYSDCOS-1 0.word SYSDTAN-1  .word do_deg_fn-1 0.word do_pct_fn-1 0 0 pol_fx .block numlen,00 Z .equ * FX .block numlen,00 W .equ * FX2 .block numlen,00 Q .block numlen,00 MANT .block numlen,00  EXP .block 0f,00 ;check length TR1 .block 10,00 ;check le(jsr chk_adj (bcs $090 (jsr do_adj (ldx #0ff $005 inx (lda my_string,x (sta string,x (cmp #0ff (bne $005 (pla (pla $090 rts  chk_adj sec ;return cset=no adj, cclr=do adj (lda my_extring (moveb #0ff,string+1 (lda #07 (jsr put_char (lda #00 (sta result (sta result+1 (sta err_number (rts $002 ' movew sout_exp,my_exp ;*** DA save for later display chk (movew sout_exp,save_the_exp y_string (.if test (.ascii "adj display" (.endc  adj_display (moveb char,actual_len ;2.10 ( ;2.12 dec actual_len ( (lda err_number ;do error check here (beq $002 (moveb #"*",s.block numlen,00  exp_sgn_flag .byte 00 ;contains sout_exp+1  my_exp .word 0000 save_the_exp .word 0000 my_len .byte 00 actual_len .byte 00  my_string .block 20,0ff p_my_string .word mcurr_op .byte 00 curr_op_num .byte 00 next_op .byte 00  op_pend_flag .byte 00 (.if test (.ascii "-------undo---------" (.endc ( save_undo .block numlen,00 mem_reg .block numlen,00  result D0,0BC,0BB,0F7,0F9,0B3,0F5 .byte 080,008,06C,029,018,0DD,06D,093,089,009,06D .byte 080,00A,089,042,0CA,0A5,0A1,0D0,09F,0AD,046 .byte 080,009,032,01B,012,0FA,0AC,077,028,024,052 p_sysp3 .word sysp3-2000 q4-2000  sysP2 .byte 080,006,072,074,006,0FC,0F4,005,018,098,019 .byte 080,00F,06C,09B,03D,054,014,0E1,0AD,008,052 .byte 080,015,07D,0F0,0D8,04A,0C3,0A3,05F,0AF,08A p_sysp2 .word sysp2-2000  sysP3 .byte 080,005,0C4,067,000,000 .byte 080,006,08E,01A,0E1,092,032,09C,060,03A,0DE .byte 080,008,041,0C1,083,09F,007,0F5,07E,002,0AB .byte 080,009,0A6,0F1,0F8,07A,013,0E4,07B,0DA,0E9 .byte 080,008,032,01B,012,0FA,0AC,077,028,024,05E p_q4 .word .byte 080,00B,05A,0A7,010,08B,038,07B,077,06F,021 .byte 080,013,020,003,0B1,082,09B,07B,0E8,05C,0C8 .byte 080,017,037,02D,0F8,014,0E7,009,083,07E,006 p_q3 .word q3-2000  Q4 .byte 080,001,000,000,000,000,000,000,000,0,000,000,000,000,000,000 NI2 .byte 080,000,000,000,000,000,000,000,000,000,000  ; N1 .byte 080,001,000,000,000,000,000,000,000,000,000 N1 Q3 .byte 080,001,000,000,000,000,000,000,000,000,000 01,035,004,0F3,033,0F9,0DE,064,084,059 ILN2 .byte 080,001,038,0AA,03B,029,05C,017,0F0,0BB,0BF LN2 .byte 080,000,031,072,017,0F7,0D1,0CF,079,0AB,0CA MN .byte 080,010,000,000,000,000,000,000,000,000,000 N10 .byte 080,004,020,000,000 07f,0fb,00e,0fa,035,012,094,0e9,0c7,009,067 N100 .byte 080,007,048,000,000,000,000,000,000,000,000  ILN10 .byte 07F,0FF,05E,05B,0D8,0A9,037,028,071,095,035 LN10 .byte 080,002,013,05D,08D,0DD,0AA,0A8,0AC,016,0EA SQR2 .byte 080,0STRING .block 20,0ff ;OUTPUT STRING p_STRING .word string adj_p_string .word string-2000 ; ; INTERNAL CONSTANTS ; ; const_e .byte 080,002,02d,0f8,054,058,0a2,0bb,04a,09a,0af k_pi_div_180 .byte ngth  LY .byte 000 DP .byte 000 ESIGN .byte 000 MSIGN .byte 000 CHAR .byte 00 ;DISP IN STRING LCNT .byte 00 ;LOOP COUNTER p+1 ;check for exp > 15 or exp < -15 (and #7f (bne $090 (lda my_exp (beq $090 ;no adj for exp=0 (cmp #10 ;cc if exp<16 $090 rts (  do_adj moveb #10,my_len (lda #00 (tax ;index to old string (tay ;index to my new string ( (lda string ;check for leading minus sign (cmp #"-" (bne $090 (inx (iny (sta my_string ( $090 bit exp_sgn_flag (bmi adj_neg ( adj_p=?@ABCDEFGHIJK1 2 3 4 5 6 dO^ѭì .ascii "^B)ack ^S)tore ^R)ecall c)os s)in t)an %)pct +-/*^" .byte 0d,01f,0ff  p_help_msg .word help_msg 0.include CALC.SCT 0.INCLUDE CALC.1 0.INCLUDE CALC.2 0 end 0.END  #20 (bne $005 (sta string,x ;bump space right to flag next 0 $005 rts help_msg  .byte 01a,000,013,01f,0d  .ascii "^Z)ero ^C)lear ^X)exit ^Q)uit l)nx L)og e)xp d)eg adds" .byte 0d,01f my_string,y ( ;2.12 dey (sty actual_len rts_xx rts build_string sta my_string,y 0iny 0dec my_len 0rts 0 get_nxt_num (lda string,x (inx (cmp #"." (beq get_nxt_num (cmp 05 dec my_exp (beq $010  jsr build_string (bne $005 $010 jsr get_nxt_num (cmp #20 (beq adj_out ;2.11, was beq rts_xx (jsr build_string (bne $010 adj_out (lda #0ff (sta $008 jsr build_string jsr get_nxt_num (cmp #20 (bne $008 (jmp adj_out adj_neg ;convert 1.23456 E-3 0;to .00123456 0; 0;also 1 E-2 0;to .01 (lda #"." (jsr build_string (lda #"0" $0os ;convert 1.23456 E3 0;to 1234.56 0; 0;also 1.2 E4 0;to 12000. $005 jsr get_nxt_num (cmp #20 (bne $007 (lda #"0" $007 jsr build_string (dec my_exp (bpl $005 (lda #"." ;------------------------------------------------------------ ; ; version 2.05 mod 03/03/86 ; ;------------------------------------------------------------ ;call numbers next ; ; console functions ;  n_cons_stat .equ 01 n_cons_cntl efnum (moveb #n_sos_close,call_number (moveb %1,p1 (.endm   (.macro m_sos_newline ;CALL refnum,is_newline,nl_char (moveb #n_sos_newline,call_number (moveb %1,p1 (moveb %2,p2 (moveb %3,p3 (.endm ( ( ; ; file funite,call_number (moveb %1,p1 (movew %2,p2 (movew %3,pky_rw_buff (.endm ( ( (.macro m_sos_destroy ;CALL null (pathname loaded prev) (moveb #n_sos_destroy,call_number (.endm ( ( (.macro m_sos_close ; call m_CLOSE,r(.endm  (.macro m_sos_read ;CALL refnum,req_cnt,p_buff (moveb #n_sos_read,call_number (moveb %1,p1 (movew %2,p2 (movew %3,pky_rw_buff (.endm ( ( (.macro m_sos_write ;CALL refnum,cnt,p_buff (moveb #n_sos_wrhe m_get_fname macro ;  (.macro m_sos_create ; call m_CREATE,filetype (moveb #n_sos_create,call_number (moveb #%1,p1 (.endm ( (.macro m_sos_open ; call m_OPEN (moveb #n_sos_open,call_number ; returns refnum -> p1 ; call m_PUT1,put_fref (sta p2 (moveb #n_put1,call_number (moveb %1,p1 (.endm (.macro m_put_char (sta p1 (moveb #n_put_char,call_number (.endm ( ( ( ; ; sos function macros ; ; all pathnames must have been obtained by t ( (.macro m_get1 ; call m_GET1 (moveb #n_get1,call_number ; returns char -> A (.endm ( (.macro m_get_char ;CALL null (moveb #n_get_char,call_number ;returns (a)=char (.endm ( (.macro m_put1 (.macro m_dflt_line ; call m_dflt_line,p_line (moveb #n_dflt_line,call_number (movew %1,p1 (.endm ( (.macro m_get_l_char ; call m_GET_LCHAR (moveb #n_get_lchar,call_number ; returns char -> A (.endm ovew %2,p2 (.endm ( (.macro m_restore_scr ; call m_RESTORE-SCR (moveb #n_restore_scr,call_number (.endm ( (.macro m_get_line ;CALL null (moveb #n_get_line,call_number ;returns p1/p2=p_lread_buff (.endm ro m_cons_cntl ;CALL {p1=cntl_code,p2/p3=p_cntl_list} (moveb #n_cons_cntl,call_number (moveb %1,p1 (movew %2,p2 (.endm ( (.macro m_cons_stat ;CALL {p1=stat_code,p2/p3=p_stat_list} (moveb #n_cons_stat,call_number (moveb %1,p1 (mequ 24 n_xmisc_2 .equ 25 n_xmisc_3 .equ 26 n_xmisc_4 .equ 27 ( (.macro CALL ; CALL xfn_name xfn_parms... (%1 %2,%3,%4,%5,%6 (jsr call_handler (.endm ; ; console function macros ;  .macn_build_pname .equ 1c n_copy_pname .equ 1d n_dflt_device .equ 1e n_xfile_4 .equ 1f ; ; misc functions ; n_msg0 .equ 20 n_msg .equ 21 n_cntl8 .equ 22 n_get_atcurs .equ 23 n_get_numeric . .equ 14 n_sos_close .equ 15 n_sos_newline .equ 16 n_xsos_1 .equ 17 ; ; file functions ; n_get_fname .equ 18 n_bin_load .equ 19 n_bin_save .equ 1a  n_file_error .equ 1b b n_xcons_2 .equ 0c n_xcons_3 .equ 0d n_xcons_4 .equ 0e n_xcons_5 .equ 0f ; ; sos functions ;  n_sos_create .equ 10 n_sos_open .equ 11 n_sos_read .equ 12 n_sos_write .equ 13 n_sos_destroy .equ 02  n_restore_scr .equ 03 n_getline .equ 04 n_dflt_line .equ 05 n_get_lchar .equ 06 n_get1 .equ 07 n_get_char .equ 08 n_put1 .equ 09 n_put_char .equ 0a n_xcons_1 .equ 0ction macros ;  (.macro m_get_fname ;CALL null (moveb #n_get_fname,call_number (.endm ;returns p_pname in p1/p2 (  .macro m_bin_load ;CALL count,p_buff (moveb #n_bin_load,call_number (movew %1,p1 ;returns p1=act count (movew %2,p3 (.endm ( (.macro m_bin_save ;CALL count,p_buff (moveb #n_bin_save,call_number (movew %1,p1 (movew %2,p3 (.endm  (.macro ( .proc pkycrpt,0  ;---------------------------------------------------------------- ; POWER KEYS /// module CRPT ; ; file encryptor module ; ; version 2.02 09/11/86 ; ; 2.02 fixes for get/put name stuff ; 2LNOPQRSTUVWXYZ 1 FORMAT COPY 2 3 4 0 X Y O^Rn val so use p3 (moveb %3,p3  .endm ( ( (.macro m_get_numeric (moveb #n_get_numeric,call_number (moveb %1,p1 (.endm  (moveb #n_cntl8,call_number (.endm ( ( (.macro m_get_atcurs ;CALL max_chars,80=restor curs,80=curr scr (moveb #n_get_atcurs,call_number (moveb %1,p1 ;returns pointer to string in p1 (moveb %2,p2 ;nb 2 filled by retur0 ; call p_msg_start (moveb #n_msg0,call_number (movew %1,p1 (.endm ( (.macro m_msg ;CALL p_msg_start (moveb #n_msg,call_number (movew %1,p1 (.endm ( ( (.macro m_cntl8 ;CALL null ( (.macro m_copy_pname ;CALL p_my_pname (moveb #n_copy_pname,call_number (movew %1,p1 (.endm ( (.macro m_dflt_device ;no call parms (moveb #n_dflt_device,call_number (.endm ; ; misc function macros ;  (.macro m_msg m_file_error ; call m_FILE_ERROR (sta p1 (moveb #n_file_error,call_number (.endm  (.macro m_build_pname ;CALL p_my_pname (moveb #n_build_pname,call_number (movew %1,p1 ;returns p1/p2=p_pname (.endm ( .01 added delete option for original file ; ;--------------------------------------------------------------- ; ;*************************************** ; header follows ;***************************************  start (jmp entry (.ascii "E" ; (.word start-1 (.word end-start (.ascii "QwkCrypt"  test .equ 0  .include pkymacs 0.include callmacs 0.include zpcommon  eof_err .equ 04C  a_open_flag .byte 000 b_open_(jmp copy_out get_info_a (.BYTE 000 (.byte 0c4 (.word get_info_plist (rts get_info_plist (.byte 03 get_p .word 0000 (.word gtin_opt_lst (.byte 0f  gtin_opt_lst .block 0f,00 set_info_b (.BYTE 000 (.byte 0c3 (.w test_err (JMP RWLOOP $090 rts 0 (.if test (.ascii "test err" (.endc  test_err (bne $010 (rts  $010 cmp #eof_err (bne $020 (rts $020 CALL m_file_error ; err number in (A) (pla (pla (pla (pla $010 CALL m_sos_read,refnum_a,hex0200,p_rw_buff (lda call_return (jsr test_err (cmp #eof_err (beq $090 ( (jsr crypt_it ( (movew p1,wr_count (CALL m_sos_write,refnum_b,wr_count,p_rw_buff (lda call_return (jsr (CALL m_getline ( (ldx #00 $005 CALL m_get_lchar (cmp #0d (beq $090 (sta hold_key,x (inx (cpx #08 (bne $005 $090 rts ( ( ( (.if test (.ascii "rw loop" (.endc   rwloop movew p_rw_buff,pky_rw_buff  CALL m_sos_destroy ;pre-erase b (CALL m_sos_create,#00 ;create b (CALL m_sos_open ;open b (moveb p1,refnum_b (moveb call_return,b_open_flag (jsr test_err (rts do_key CALL m_msg,p_key_msg moveb call_return,a_open_flag (jsr test_err (rts ( ( ( (.if test (.ascii "---- do b ----" (.endc   do_b (CALL m_msg,p_msg_bname (CALL m_get_fname ;get b name get_fname ;get a name (movew p1,get_p (movew p1,set_p (jsr put_a_name ;2.01 save a-name info for later del (jsr getinfo_a ;get a info (CALL m_sos_open ;open a (moveb p1,refnum_a ( ;close b $030 lda a_open_flag (bne $090 (CALL m_sos_close,refnum_a ;close a jsr chk_del ;2.01 $090 rts  (.if test (.ascii "---- do a ----" (.endc  do_a (CALL m_msg,p_msg_aname (CALL m_(dex (bpl $005 (rts (  do_copy (jsr do_a (jsr do_b (jsr do_key (jsr rw_loop ;read-write loop (jsr setinfo_b copy_out  lda b_open_flag (bne $030  CALL m_sos_close,refnum_b cii "entry" (.endc entry  jsr init (jsr do_copy (rts  init ldx #00 (stx refnum_a (stx refnum_b (dex (stx a_open_flag (stx b_open_flag  ldx #07 (lda #20 $005 sta hold_key,x .block 100,0 ;save 512 for later rw_buff2 .block 100,0  p_rw_buff .WORD rw_buff-2000 hex0200 .WORD 0200 hold_key .block 08,00 p_namebuff .word 0000 save_a_name .block 81,0 (.if test (.asascii "CRPT> Enter Keyword (1-8 chars) : " 0.byte 0ff  p_key_msg .word key_msg del_msg .byte 1a,00,16,1d 0.ascii "CRPT> Do you wish to DELETE original file (Y/N) ?" 0.byte 0ff p_del_msg .word del_msg  rw_buff  p_msg_aname .WORD msg_aname msg_bname .BYTE 1a,00,14,1d ;row 20 0.ascii "CRPT> File to xlate TO : " 0.BYTE 0ff  p_msg_bname .WORD msg_bname key_msg .byte 1a,00,15,1d ;row 21 0.flag .byte 000 wr_count .word 0000 refnum_a .byte 00 refnum_b .byte 00 msg_aname .BYTE 1a,00,13,1d ;row 19 0.ascii "CRPT> File to xlate FROM : " 0.BYTE 0ff ord set_info_plist (rts set_info_plist (.byte 03 set_p .word 0000 (.word gtin_opt_lst (.byte 0f (.IF TEST (.ASCII "crypt it" (.endc  cryptit crypt_1  ldx #00 ;key index (ldy #00 ;buffer index $005 lda rw_buff,y (eor hold_key,x (sta rw_buff,y (inx (cpx #08 (bne $010 (ldx #00 $010 iny (bne $005 ( crypt_it2  ldx #00 ;key index (ldy #00 ; (.word start-1 (.word end-start (.ascii "QwkCrypt"  test .equ 0  .include pkymacs 0.include callmacs 0.include zpcommon  eof_err .equ 04C  a_open_flag .byte 000 b_open_.01 added delete option for original file ; ;--------------------------------------------------------------- ; ;*************************************** ; header follows ;***************************************  start (jmp entry (.ascii "E" ( .proc pkycrpt,0  ;---------------------------------------------------------------- ; POWER KEYS /// module CRPT ; ; file encryptor module ; ; version 2.02 09/11/86 ; ; 2.02 fixes for get/put name stuff ; 2[]^_`abcdefghi 1 FORMAT COPY 2 3 4 0 X Y O^Rɬput_a_name lda p2 0sec 0sbc #20 0sta p2 0movew p1,p_namebuff 0 0ldy #00 0lda @p1,y 0tay $005 lda @p1,y 0sta save_a_name,y 0dey 0bpl $005 0rts ( (.list  end (.end  0and #05f 0cmp #"Y" 0bne $090 0jsr get_a_name 0CALL m_sos_destroy $090 rts  get_a_name movew p_namebuff,p1 0ldy save_a_name $005 lda save_a_name,y 0sta @p1,y 0dey 0bpl $005 0rts ;buffer index $005 lda rw_buff2,y (eor hold_key,x (sta rw_buff2,y (inx (cpx #08 (bne $010 (ldx #00 $010 iny (bne $005 (rts ( ( chk_del CALL m_msg,p_del_msg 0CALL m_get_char flag .byte 000 wr_count .word 0000 refnum_a .byte 00 refnum_b .byte 00 msg_aname .BYTE 1a,00,13,1d ;row 19 0.ascii "CRPT> File to xlate FROM : " 0.BYTE 0ff  p_msg_aname .WORD msg_aname msg_bname .BYTE 1a,00,14,1d ;row 20 0.ascii "CRPT> File to xlate TO : " 0.BYTE 0ff  p_msg_bname .WORD msg_bname key_msg .byte 1a,00,15,1d ;row 21 0. ;buffer index $005 lda rw_buff,y (eor hold_key,x (sta rw_buff,y (inx (cpx #08 (bne $010 (ldx #00 $010 iny (bne $005 ( crypt_it2  ldx #00 ;key index (ldy #00 ord set_info_plist (rts set_info_plist (.byte 03 set_p .word 0000 (.word gtin_opt_lst (.byte 0f (.IF TEST (.ASCII "crypt it" (.endc  cryptit crypt_1  ldx #00 ;key index (ldy #00 (jmp copy_out get_info_a (.BYTE 000 (.byte 0c4 (.word get_info_plist (rts get_info_plist (.byte 03 get_p .word 0000 (.word gtin_opt_lst (.byte 0f  gtin_opt_lst .block 0f,00 set_info_b (.BYTE 000 (.byte 0c3 (.w test_err (JMP RWLOOP $090 rts 0 (.if test (.ascii "test err" (.endc  test_err (bne $010 (rts  $010 cmp #eof_err (bne $020 (rts $020 CALL m_file_error ; err number in (A) (pla (pla (pla (pla $010 CALL m_sos_read,refnum_a,hex0200,p_rw_buff (lda call_return (jsr test_err (cmp #eof_err (beq $090 ( (jsr crypt_it ( (movew p1,wr_count (CALL m_sos_write,refnum_b,wr_count,p_rw_buff (lda call_return (jsr (CALL m_getline ( (ldx #00 $005 CALL m_get_lchar (cmp #0d (beq $090 (sta hold_key,x (inx (cpx #08 (bne $005 $090 rts ( ( ( (.if test (.ascii "rw loop" (.endc   rwloop movew p_rw_buff,pky_rw_buff  CALL m_sos_destroy ;pre-erase b (CALL m_sos_create,#00 ;create b (CALL m_sos_open ;open b (moveb p1,refnum_b (moveb call_return,b_open_flag (jsr test_err (rts do_key CALL m_msg,p_key_msg moveb call_return,a_open_flag (jsr test_err (rts ( ( ( (.if test (.ascii "---- do b ----" (.endc   do_b (CALL m_msg,p_msg_bname (CALL m_get_fname ;get b name get_fname ;get a name (movew p1,get_p (movew p1,set_p (jsr put_a_name ;2.01 save a-name info for later del (jsr getinfo_a ;get a info (CALL m_sos_open ;open a (moveb p1,refnum_a ( ;close b $030 lda a_open_flag (bne $090 (CALL m_sos_close,refnum_a ;close a jsr chk_del ;2.01 $090 rts  (.if test (.ascii "---- do a ----" (.endc  do_a (CALL m_msg,p_msg_aname (CALL m_(dex (bpl $005 (rts (  do_copy (jsr do_a (jsr do_b (jsr do_key (jsr rw_loop ;read-write loop (jsr setinfo_b copy_out  lda b_open_flag (bne $030  CALL m_sos_close,refnum_b cii "entry" (.endc entry  jsr init (jsr do_copy (rts  init ldx #00 (stx refnum_a (stx refnum_b (dex (stx a_open_flag (stx b_open_flag  ldx #07 (lda #20 $005 sta hold_key,x .block 100,0 ;save 512 for later rw_buff2 .block 100,0  p_rw_buff .WORD rw_buff-2000 hex0200 .WORD 0200 hold_key .block 08,00 p_namebuff .word 0000 save_a_name .block 81,0 (.if test (.asascii "CRPT> Enter Keyword (1-8 chars) : " 0.byte 0ff  p_key_msg .word key_msg del_msg .byte 1a,00,16,1d 0.ascii "CRPT> Do you wish to DELETE original file (Y/N) ?" 0.byte 0ff p_del_msg .word del_msg  rw_buff ;buffer index $005 lda rw_buff2,y (eor hold_key,x (sta rw_buff2,y (inx (cpx #08 (bne $010 (ldx #00 $010 iny (bne $005 (rts ( ( chk_del CALL m_msg,p_del_msg 0CALL m_get_char 0and #05f 0cmp #"Y" 0bne $090 0jsr get_a_name 0CALL m_sos_destroy $090 rts  get_a_name movew p_namebuff,p1 0ldy save_a_name $005 lda save_a_name,y 0sta @p1,y 0dey 0bpl $005 0rts 0.block 48,20 0.byte 0ff  p_ot_buff .word ot_buff off .block 3,0 hexbyte .byte 0 ascii1 .byte 0 ascii2 .byte 0 dot_index .byte 0 inbuff_index .byte 0 otbuff_index .byte 0 dline_count .byte 00  " 0.byte 0ff p_gname_msg .word gname_msg  refnum .byte 00 line_number .byte 00 k64 .word 0040 in_buff .block 50,20 pi_in_buff .word in_buff-2000 ot_buff .ascii "000000: " mp entry .ascii "H" ;command key for module .word start-1 .word end-start .ascii "HexDumpr" ;module name gname_msg .ascii "DUMP> Enter name of file to dump :utility, hex display of any file ; ; 2.01 changed to display 16 lines of text (=256 bytes) ; ;----------------------------------------------------------------- (.include zpcommon (.include pkymacs (.include callmacs start j .proc pkymod,0 ;----------------------------------------------------------------- ; ; Module Name : HexDumpr Cmd Key: (H)iew file ; ; Date : 09/12/86 Version : 2.01 Name Code : DUMP ; ; Description : More type jlmnopqrstuv1 O^Fɬput_a_name lda p2 0sec 0sbc #20 0sta p2 0movew p1,p_namebuff 0 0ldy #00 0lda @p1,y 0tay $005 lda @p1,y 0sta save_a_name,y 0dey 0bpl $005 0rts ( (.list  end (.end  eof_error .equ 04C echo_list .byte 00 p_echo_list .word echo_list  echo_off lda #000 0beq echo_x echo_on lda #0c0 echo_x sta echo_list 0CALL m_cons_cntl,#0b,p_echo_list 0rts  entry (lda #00 (sta off (sta off+1 (sta off+2 ( (lda #15 (jsr put_char (lda #0f (jsr put_char ;enable scroll ( (CALL m_msg0,p_gname_msg (CALL m_get_fname (CALL m_sos_open (bne file_error 1 O^Fɬp #20 (bcc x3 (bcs x4 x3 lda #"."' x4 ldy dot_index (sta ot_buff,y (iny (sty dot_index (rts (   end .end (rts ( ( nascii cmp #0a (bcc nas1 ;branch if high nibble < 10 (clc (adc #7 ;else add 7 so that after adding 30 @; it will be 'A-F' nas1 adc #30 (rts ( ( ( dodots lda hexbyte (bmi x3 (cm(tax ;SAVE ORIG VALUE ( (and #0f0 ;convert high nibble (lsr a (lsr a (lsr a (lsr a (jsr nascii (sta ascii1 ( 8;convert low nibble (txa (and #0f (jsr nascii (sta ascii2 ( (pla (tax nbuff_index (tya (and #0f ;will pop out at index=10,20,30,etc (bne maploop ( (rts  toascii ;xlate byte in hexbyte to two byte ascii 8;equivalent in ascii1,ascii2 (txa (pha   lda hexbyte y (sta hexbyte (jsr dodots (jsr toascii  (lda ascii1 (ldy otbuff_index (sta ot_buff,y (iny (lda ascii2 (sta ot_buff,y (iny (iny (sty otbuff_index ( (ldy inbuff_index (iny ( x2 sty i(adc #00 (sta off+1 (lda off (adc #00 (sta off (rts ( do_1 jsr show_addr (moveb #3a,dot_index ;posn 51 in display is dots (moveb #08,otbuff_index ( maploop ldy inbuff_index (lda in_buff,da off,y (sta hexbyte (jsr toascii (lda ascii1 (sta ot_buff,x (inx (lda ascii2 (sta ot_buff,x (inx (iny (cpy #03 (bne $010 inc_addr (clc (lda off+2 (adc #10 (sta off+2 (lda off+1 rts  show_4 moveb #04,dline_count ;counts 4 lines (moveb #00,inbuff_index ;index in in_buff $010 jsr do_1 (CALL m_msg,p_ot_buff (dec dline_count (bne $010 (rts show_addr (ldy #00 (ldx #00 ( $010 l #1c (jsr put_char (rts (  file_error cmp #eof_error 0beq $080 0CALL m_file_error 0jmp done 0 $080 jsr get_char 0jmp done get_char CALL m_get_char 0rts  put_char CALL m_put_char 0(dec line_number (bne $010 ( (jsr get_char (cmp #1b (bne $005 done CALL m_sos_close,refnum (jsr echo_on (lda #15 (jsr put_char ;disable scroll (lda #07 (jsr put_char (lda (moveb p1,refnum (jsr echo_off ( (lda #1c ;clear home (jsr put_char ( $005 moveb #04,line_number $010 CALL m_sos_read,refnum,k64,pi_in_buff  bne file_error (  jsr show_4  wyz{|}~rts  show_4 moveb #04,dline_count ;counts 4 lines (moveb #00,inbuff_index ;index in in_buff $010 jsr do_1 (CALL m_msg,p_ot_buff (dec dline_count (bne $010 (rts show_addr (ldy #00 (ldx #00 ( $010 l #1c (jsr put_char (rts (  file_error cmp #eof_error 0beq $080 0CALL m_file_error 0jmp done 0 $080 jsr get_char 0jmp done get_char CALL m_get_char 0rts  put_char CALL m_put_char 0(dec line_number (bne $010 ( (jsr get_char (cmp #1b (bne $005 done CALL m_sos_close,refnum (jsr echo_on (lda #15 (jsr put_char ;disable scroll (lda #07 (jsr put_char (lda (moveb p1,refnum (jsr echo_off ( (lda #1c ;clear home (jsr put_char ( $005 moveb #04,line_number $010 CALL m_sos_read,refnum,k64,pi_in_buff  bne file_error (  jsr show_4  (lda #00 (sta off (sta off+1 (sta off+2 ( (lda #15 (jsr put_char (lda #0f (jsr put_char ;enable scroll ( (CALL m_msg0,p_gname_msg (CALL m_get_fname (CALL m_sos_open (bne file_error eof_error .equ 04C echo_list .byte 00 p_echo_list .word echo_list  echo_off lda #000 0beq echo_x echo_on lda #0c0 echo_x sta echo_list 0CALL m_cons_cntl,#0b,p_echo_list 0rts  entry0.block 48,20 0.byte 0ff  p_ot_buff .word ot_buff off .block 3,0 hexbyte .byte 0 ascii1 .byte 0 ascii2 .byte 0 dot_index .byte 0 inbuff_index .byte 0 otbuff_index .byte 0 dline_count .byte 00  " 0.byte 0ff p_gname_msg .word gname_msg  refnum .byte 00 line_number .byte 00 k64 .word 0040 in_buff .block 50,20 pi_in_buff .word in_buff-2000 ot_buff .ascii "000000: " mp entry .ascii "H" ;command key for module .word start-1 .word end-start .ascii "HexDumpr" ;module name gname_msg .ascii "DUMP> Enter name of file to dump :utility, hex display of any file ; ; 2.01 changed to display 16 lines of text (=256 bytes) ; ;----------------------------------------------------------------- (.include zpcommon (.include pkymacs (.include callmacs start j .proc pkymod,0 ;----------------------------------------------------------------- ; ; Module Name : HexDumpr Cmd Key: (H)iew file ; ; Date : 09/12/86 Version : 2.01 Name Code : DUMP ; ; Description : More type da off,y (sta hexbyte (jsr toascii (lda ascii1 (sta ot_buff,x (inx (lda ascii2 (sta ot_buff,x (inx (iny (cpy #03 (bne $010 inc_addr (clc (lda off+2 (adc #10 (sta off+2 (lda off+1 (adc #00 (sta off+1 (lda off (adc #00 (sta off (rts ( do_1 jsr show_addr (moveb #3a,dot_index ;posn 51 in display is dots (moveb #08,otbuff_index ( maploop ldy inbuff_index (lda in_buff, .proc pkymod,0 ;----------------------------------------------------------------- ; ; Module Name : FontLoad Cmd Key: (Y) ; ; Date : 11/11/86 Version : 2.01 Name Code : FONT ; ; Description : dynamically load aO^F<p #20 (bcc x3 (bcs x4 x3 lda #"."' x4 ldy dot_index (sta ot_buff,y (iny (sty dot_index (rts (   end .end (rts ( ( nascii cmp #0a (bcc nas1 ;branch if high nibble < 10 (clc (adc #7 ;else add 7 so that after adding 30 @; it will be 'A-F' nas1 adc #30 (rts ( ( ( dodots lda hexbyte (bmi x3 (cm(tax ;SAVE ORIG VALUE ( (and #0f0 ;convert high nibble (lsr a (lsr a (lsr a (lsr a (jsr nascii (sta ascii1 ( 8;convert low nibble (txa (and #0f (jsr nascii (sta ascii2 ( (pla (tax nbuff_index (tya (and #0f ;will pop out at index=10,20,30,etc (bne maploop ( (rts  toascii ;xlate byte in hexbyte to two byte ascii 8;equivalent in ascii1,ascii2 (txa (pha   lda hexbyte y (sta hexbyte (jsr dodots (jsr toascii  (lda ascii1 (ldy otbuff_index (sta ot_buff,y (iny (lda ascii2 (sta ot_buff,y (iny (iny (sty otbuff_index ( (ldy inbuff_index (iny ( x2 sty i new font ; ; 2.01 fix to add error check to file open ; was doing the fontload cntl call even after err ; ;----------------------------------------------------------------- (.include zpcommon (.include pkymacs (.include callmacs start jmp entry .ascii "Y" ;command key for module .word start-1 .word end-start .ascii "FontLoad" ;module name entry (CALL m_msg0,p_gname_msg (Cllmacs start jmp entry .ascii "Y" ;command key for module .word start-1 .word end-start .ascii "FontLoad" ;module name entry (CALL m_msg0,p_gname_msg (C new font ; ; 2.01 fix to add error check to file open ; was doing the fontload cntl call even after err ; ;----------------------------------------------------------------- (.include zpcommon (.include pkymacs (.include ca .proc pkymod,0 ;----------------------------------------------------------------- ; ; Module Name : FontLoad Cmd Key: (Y) ; ; Date : 11/11/86 Version : 2.01 Name Code : FONT ; ; Description : dynamically load aO^F< p_gname_msg .word gname_msg  one_k .word 0400 font_buff .block 100,0 0.block 100,0 0.block 100,0 0.block 100,0 p_font_buff .word font_buff adj_p_font_bu .word font_buff-2000   end .end ALL m_bin_load,one_k,adj_p_font_buff (lda call_return (bne error  CALL m_cons_cntl,#10,p_font_buff (rts error CALL m_file_error (rts   gname_msg .ascii "FONT> Enter Name of FontFile to Load : " 0.byte 0ff ALL m_bin_load,one_k,adj_p_font_buff (lda call_return (bne error  CALL m_cons_cntl,#10,p_font_buff (rts error CALL m_file_error (rts   gname_msg .ascii "FONT> Enter Name of FontFile to Load : " 0.byte 0ff  p_gname_msg .word gname_msg  one_k .word 0400 font_buff .block 100,0 0.block 100,0 0.block 100,0 0.block 100,0 p_font_buff .word font_buff adj_p_font_bu .word font_buff-2000   end .end .word start-1 .word end-start .ascii "ModuLoad" ;module name  ;------------------------------------------------------------------ ;------------ data here ;----------------------- rel_ptr .equ 0 ; ;----------------------------------------------------------------- (.include zpcommon (.include pkymacs (.include callmacs start jmp entry .ascii "M" ;command key for module to simple build_pname ; 2.03 fixes to relocator logic, added close and fix to cmd pointer ; 2.04 added open error handler,load error handler ; also handlers for FILE IO errors # D1 and D2 for ; no Bucket found and Bucket too Small situations; Description : load a specified module into bucket ; ; 2.00 initial ; 2.01 changed /DYNAMIC to DYNAMIC ; changed pointers to adj values ; changed p1 handling in copy_pname call ; 2.02 removed prefix code and switched from copy_pname (buggy) ; .proc pkymod,0 0 test .equ 0  ;----------------------------------------------------------------- ; ; Module Name : ModuLoad Cmd Key: (M)odule loader ; ; Date : 09/11/86 Version : 2.04 Name Code : LOAD ; 1 2 0 uO^Fd8 rel_data .equ 0da  no_buk_emsg .equ 0D1 ;2.04 too_big_emsg .equ 0D2 ;2.04  hex1f8 .word 01f8 eight .word 0008 two .word 0002 three .word 0003 fourteen .word 000e count .word 0000 ref_num .byte 00 reloc_cnt .word 0000 dum_buff .block 6,0 codelen .word 0000 p_dum_buff .word dum_buff-2000 p_load_point .word load_point-2000 (.if test (.ascii "get_cmd_address" (.endc  get_cmd_address (movew 0C1,tst_addr+1 ;find the "M" starting with (C1/C2)-x'AA (sec (lda tst_addr+1 (sbc #0ab (sta tst_addr+1 (lda tst_addr+2 (sbc #00 (sta tst_add ;2.01 (adc #20 (sta @rel_data,y ( (decw reloc_cnt (bne $010 ( (sbcw rel_ptr,three,rel_ptr ( $090 rts ( (.if test (.ascii "set_cmd" (.endc ( set_cmd lda new_cmd (jsr put_cmd (rts  da rel_ptr+1 (sbc @rel_ptr,y (sta rel_data+1 ( ( ;update the data here (clc ;hi-byte only needed (ldy #01 (lda @rel_data,y (adc p_load_point+1 (clc ;start with ptr at end ( (addw p_load_point,codelen,rel_ptr (sbcw rel_ptr,fourteen,rel_ptr (movewia rel_ptr,reloc_cnt $010 sbcw rel_ptr,two,rel_ptr (ldy #00 (sec (lda rel_ptr (sbc @rel_ptr,y (sta rel_data (iny (l(rts ;2.04  do_error CALL m_file_error ;2.04 0rts ;2.04  ;---------- (.if test (.ascii "reloc_mod" (.endc  reloc_mod ( (;addw load_point,codelen,rel_ptr da #too_big_emsg ;2.04 (jsr do_error (pla (pla (jmp close_up ( load_error ;2.04 (jsr do_error ;2.04 (pla (pla (pla (pla ;2.04 (bcs too_big ;2.04 ( (movew hex1f8,count (jsr load_em (movew code_len,count ( (;jmp load_em ( load_em (CALL m_sos_read,refnum,count,p_load_point (bne load_error (rts  too_big l ;2.04 0rts ;2.04  ;---------- (.if test (.ascii "load_mod" (.endc  load_mod (movew eight,count (CALL m_sos_read,refnum,count,p_dum_buff (lda code_len+1 ;2.04 (cmp page_size (CALL m_sos_open ;then open it (bne open_error ;2.04 (moveb p1,refnum (rts open_error jsr do_error ;2.04 0pla ;2.04 0pla p_gname_msg (CALL m_getline ( (ldy #00 $005 CALL m_get_lchar (cmp #0d (beq $010 (sta mod_lit,y (iny (inc dyna_lit (bne $005 ( $010 CALL m_build_pname,pi_dyna_lit ;copy the filename into buffer le (; restore prefix ( $005 jsr get_modname ( jsr load_mod (jsr reloc_mod (jsr set_cmd close_up (CALL m_sos_close,refnum (rts ;---------- (.if test (.ascii "get_modname" (.endc  get_modname (CALL m_msg0,ss  moveb #0ff,first_flag ( (; save prefix (; append /DYNAMIC to default prefix (; set prefix to that new one (; query for module file name to load (; open/read/load it into load point with error checking (; relocate it (; adjust cmd tabpi_dynalit .word dyna_lit-2000 gname_msg .ascii "LOAD> Enter Name of Module File to Load : " 0.byte 0ff  p_gname_msg .word gname_msg  entry (moveb #08,dyna_lit ( (bit first_flag (bmi $005 ( (jsr get_cmd_addre  first_flag .byte 00  K_size .byte 00 page_size .byte 00 ;2.04  dummy_cmd .byte 00   dyna_lit .byte 08 ( .ascii "DYNAMIC/" mod_lit .block 10,20 r+2 ( (ldx #10 $005 jsr get_cmd (cmp #"M" (beq got_M (dex (bpl $005 not_M bmi M_error got_M jsr get_cmd (tay (and #0f0 (cmp #30 (bne M_error (tya (and #0f (sta K_size (asl a ;2.04 (asl a ;2.04 (sta page_size ;2.04 (movew tst_addr+1,cmd_address (rts  M_error lda #no_buk_emsg ;2.04 (jsr do_error ;command key for module .word start-1 .word end-start .ascii "LockOut " ;module name ( match_flag .byte 00 ;2.01  entry $005 CALL m_msg0,p_gpass_msg (CALL m_getlinep keyboard until password typed ; ;----------------------------------------------------------------- (.include zpcommon (.include pkymacs (.include callmacs start jmp entry .ascii "L" .proc pkymod,0 ;----------------------------------------------------------------- ; ; Module Name : LockOut Cmd Key: (L)ock keyboard ; ; Date : 08/04/86 Version : 2.00 Name Code : LOCK ; ; Description : lock uO^F_point .equ * new_cmd .equ *+3  end .end   cmd_address .equ *+1 put_cmd sta dummy_cmd ;modified to point to command ( rts ;--------------------------------------- ; no code after here ;---------------------------------------  .align 100 ( load ;2.04 (pla ;2.04 (pla ;2.04 (rts ( get_cmd  inc tst_addr+1 0bne tst_addr 0inc tst_addr+2 tst_addr lda tst_addr 0rts (jsr save_pass  CALL m_msg0,p_confirm_msg (CALL m_msg,p_password (CALL m_getchar (and #5f (cmp #"Y" (bne $005 $010 CALL m_msg0,p_lock_msg (CALL m_getline (jsr compare (lda match_flag  beq $010 (rts get_lchar CALL m_get_lchar 0rts 0 save_pass (ldy #0ff $010 iny (jsr get_lchar (sta password,y (cmp #0d (bne $010 $090 lda #0ff (sta password,y (rts compare (moveb #00,mat .proc pkymod,0 ;----------------------------------------------------------------- ; ; Module Name : LockOut Cmd Key: (L)ock keyboard ; ; Date : 08/04/86 Version : 2.00 Name Code : LOCK ; ; Description : lock uO^Fp_lock_msg .word lock_msg  password .block 50,20 p_password .word password    end .end rd gpass_msg confirm_msg .ascii "LOCK> Confirm (Y/N) this Password : " 0.byte 0ff p_confirm_msg .word confirm_msg lock_msg .byte 01c ;clear screen 0.ascii "LOCK> Enter PASSWORD to resume : " 0.byte 0ff (beq $010 ( $020 lda #0ff (cmp password,y (bne $090 (  $080 moveb #0ff,match_flag ;ff for match $090 rts  gpass_msg .ascii "LOCK> Enter Locking Password : " 0.byte 0ff  p_gpass_msg .woch_flag ;00 for no match (ldy #0ff ( $010 iny (jsr get_lchar ( (cmp #0d (beq $020 ( (cmp #1b ;escape hatch (beq $080 ;for testing (cmp password,y (bne $090 p keyboard until password typed ; ;----------------------------------------------------------------- (.include zpcommon (.include pkymacs (.include callmacs start jmp entry .ascii "L" ;command key for module .word start-1 .word end-start .ascii "LockOut " ;module name ( match_flag .byte 00 ;2.01  entry $005 CALL m_msg0,p_gpass_msg (CALL m_getlineO^IIp_lock_msg .word lock_msg  password .block 50,20 p_password .word password    end .end rd gpass_msg confirm_msg .ascii "LOCK> Confirm (Y/N) this Password : " 0.byte 0ff p_confirm_msg .word confirm_msg lock_msg .byte 01c ;clear screen 0.ascii "LOCK> Enter PASSWORD to resume : " 0.byte 0ff (beq $010 ( $020 lda #0ff (cmp password,y (bne $090 (  $080 moveb #0ff,match_flag ;ff for match $090 rts  gpass_msg .ascii "LOCK> Enter Locking Password : " 0.byte 0ff  p_gpass_msg .woch_flag ;00 for no match (ldy #0ff ( $010 iny (jsr get_lchar ( (cmp #0d (beq $020 ( (cmp #1b ;escape hatch (beq $080 ;for testing (cmp password,y (bne $090  beq $010 (rts get_lchar CALL m_get_lchar 0rts 0 save_pass (ldy #0ff $010 iny (jsr get_lchar (sta password,y (cmp #0d (bne $010 $090 lda #0ff (sta password,y (rts compare (moveb #00,mat (jsr save_pass  CALL m_msg0,p_confirm_msg (CALL m_msg,p_password (CALL m_getchar (and #5f (cmp #"Y" (bne $005 $010 CALL m_msg0,p_lock_msg (CALL m_getline (jsr compare (lda match_flag ; ; MAPIT MAPS INT ARRAY INTO HEX LINE DISPLAY ; ; PERFORM MAPIT%(@INTARRAY(),@STRING$,%CODE%) ; ; CODE=0 : INT ARRAY NOrmal (2 bytes per number) ; CODE=80 : INT ARRAY IS compressed ; 1 2 O^wwts lda hexbyte (bmi x3 (cmp #20 (bcc x3 (bcs x4 x3 lda #2e ;this is '.' x4 ldy dotptr (sta @strloc,y (iny (sty dotptr (rts ( (.end ( (jsr nascii (sta ascii2 ( (rts ( ( nascii cmp #0a (bcc nas1 ;branch if high nibble < 10 (clc (adc #7 ;else add 7 so that after adding 30 @; it will be 'A-F' nas1 adc #30 (rts ( ( ( dodo in ascii1,ascii2 8  lda hexbyte (tax ;SAVE ORIG VALUE ( (and #0f0 ;convert high nibble (lsr a (lsr a (lsr a (lsr a (jsr nascii (sta ascii1 ( 8;convert low nibble (txa (and #0f sta @strloc,y (iny (iny (sty strptr ( (ldy intptr (iny (bit code (bmi x2 (iny x2 sty intptr (cpy intmax (bne maploop ( (rts  toascii ;xlate byte in hexbyte to two byte ascii 8;equivalent(ldx #21 (ldy #01 x1 stx intmax (sty intptr ( maploop ldy intptr (lda @parm1,y (sta hexbyte (jsr dodots (jsr toascii  (lda ascii1 (ldy strptr (sta @strloc,y (iny (lda ascii2 ((sta dotptr (lda #00 (sta intptr (sta strptr ( (ldx #10 ;either 16 or 32 bytes of intarray to be (ldy #00 (bit code ;processed depending on expansion state (bmi x1 ;of the array ( ( ( beginz jsr init (jsr xlatestr ;translate string ptr to actual ptr (jsr maphex (push return ( (rts ( ( init (rts  xlatestr (setstrng parm2,parm2xb (rts ( ( maphex lda #33 ;decimal 51 1 .byte 0 ascii2 .byte 0 dotptr .byte 0 intptr .byte 0 strptr .byte 0 intmax .byte 0 parm1 .equ 0e8 parm2 .equ 0ea parm3 .equ 0ec parm1xb .equ 16e9 parm2xb .equ 16eb parm3xb .equ 16ed  strloc .equ 035  ; ; ( (.include tttmacs  (.proc mapit,3 ( (pop return (pop code (pop string (pop intt ( (jmp beginz ( ( return .word 0000 code .word 0000 string .word 0000 intt .word 0000 hexbyte .byte 0 ascii1 2 3 4 5 6 __O^5g( sec ;return cset=no adj, cclr=do adj (lda exp+1 ;check for exp > 15 or exp < -15 (and #7f (bne $090 (lda exp (beq $090 ;no adj for exp=0 (cmp #10 ;cc if exp<16 $090 rts (bne $010 (lda #0ff (sta string,y (rts  get_nxt_num (lda string,x (inx (cmp #"." (beq get_nxt_num (cmp #20 (bne $005 (sta string,x ;bump space right to flag next 0 (lda #"0" $005 rts chk_adj .01 (lda #"." (sta string,y (iny (dec my_len (lda #"0" $005 dec my_exp (beq $010  sta string,y (iny (dec my_len (bne $005 $010 jsr get_nxt_num (sta string,y (iny (dec my_len 1.2 E4 0;to 12000. $005 jsr get_nxt_num  sta my_string,y (iny (dec my_exp (bpl $005 (lda #0ff (sta my_string,y (rts adj_neg ;convert 1.23456 E-3 0;to .00123456 0; 0;also 1 E-2 0;to eb #10,my_len (moveb exp,my_exp (lda #00 (tax ;index to old string (tay ;index to my new string (bit exp+1 (bmi adj_neg ( adj_pos ;convert 1.23456 E3 0;to 1234.56 0; 0;also my_exp .byte 00 my_len .byte 00  my_string .block 30,0ff p_my_string .word my_string adj_display (jsr chk_adj (bcs $090 (jsr do_adj (lda p_my_string (ldy p_my_string+1 $090 rts  do_adj mov( .if test 0.ascii "SYSDOUT" 0.endc ( ;**************************************** ;* * ;* SYSDOUT - DOUBLE PRECISION OUTPUT * ;* * ;* CONVERTS BINARY DOUBLE PRECISI STRING,Y ADC #1 STA STRING,Y CMP #":" BNE RM2 LDA #"1" ;...=10 STA STRING,Y INC2 SOUT_EXP RM2 INY STY CHAR ; ; REMOVE TRAILING ZEROS ; RZ1 LDY #3 (S) RM1 DEY CLC LDA STRING,Y ADC #1 STA STRING,Y CMP #":" BEQ RM1 CMP #"."+1 ;CHECK FOR "." BNE RM2 DEY ;DO ONE"S DIGIT CLC LDA ; ROUND THE MANTISSA. IF ROUNDING IS ; NOT NEEDED, OMIT ALL CODE FROM HERE ; TO THE NEXT BLOCK COMMENT. ; LDA FR1+1 ;SKIP IF FR1<.5 BNE RZ1 ORA FR1 BEQ RZ1 LDY CHAR ;ADD 1 TO DIGITR SYSDMUL JSR SYSDFIX LDA M1L ORA #"0" LDY CHAR STA STRING,Y INC CHAR LDA FR1 ORA FR1+1 BEQ RZ1 ' 'dec lcnt 'bne mn1 ;DBNE LCNT,MN1 ' ; AR STA STRING,Y INC CHAR LDA FR1 ORA FR1+1 BEQ RZ1 LDA #"." STA STRING+1,Y INC CHAR LM LCNT,#12 ;OUTPUT THE NEXT MN1 movenum N10,FR2 ;18 DIGITS JS LDA #"1" LDY CHAR STA STRING,Y INY LDA #"." STA STRING,Y INY LDA #"0" STA STRING,Y INY STY CHAR LM LCNT,#11 BNE MN1 MN0 ORA #"0" LDY CH; OUTPUT THE MANTISSA ; JSR SYSDFIX ;OUTPUT FIRST DIGIT LDA M1L ;AND DECIMAL POINT CMP #0a ;SPECIAL CASE: INITIAL BNE MN0 ;DIGIT IS 10 INC2 SOUT_EXP SYSDFIX movew M1L,SOUT_EXP JSR SYSDFLT ;FR1=TR1*10^(-EXP) LDA FR1+2 EOR #080 STA FR1+2 movenum LN10,FR2 JSR SYSDMUL JSR SYSDEXP movenum TR1,FR2 JSR SYSDMUL ; NC CHAR ; ; STRIP OFF THE EXPONENT, LEAVING A ; NUMBER X SUCH THAT 1.0 <= X < 10.0 ; SE1_b movenum FR1,TR1 ;EXP=INT(LOG(FR1)) JSR SYSDLOG LDA FR1+2 BPL SE2 movenum N1,FR2 JSR SYSDSUB SE2 JSR _a1 moveb #"0",string moveb #0ff,string+1 LDA p_STRING LDY p_STRING+1 RTS IN_a1 LDA FR1+2 ;OUTPUT SIGN BPL SE1_b AND #07F STA FR1+2 LM STRING,#"-" I;* * ;**************************************** ;* SYSDOUT ; ; INIT AND OUTPUT THE SIGN ; LM CHAR,#0 ;INIT CHAR COUNT LDA FR1 ;CHECK FOR 0 ORA FR1+1 BNE IN;* CHARACTERS * ;* * ;* NOTES: * ;* 1) THE STRING ENDS IN A HEX 00 * ;* 2) USES SYSDLOG, SYSDEXP, * ;* SYSDMUL, SYSDFIX AND SYSCVDC * * ;* * ;* INPUTS: * ;* FR1 - NUMBER TO CONVERT * ;* * ;* OUTPUTS: * ;* Y-A - ADDRESS OF STRING * ON * ;* NUMBERS TO APPLE SCREEN CHARACTER * ;* STRINGS. * ;* * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 * ;* BY HAYDEN BOOK COMPANY, INC. ;INSURE TRAILING ZEROS LDA #"." ;CAN EXIST RZ2 CMP STRING,Y BEQ RZ3 DBNE Y,RZ2 BEQ EX_a1 RZ3 LDY CHAR LDA #"0" RZ4 CMP STRING-1,Y BNE RZ5 DEY BNE RZ4 RZ5 LDA STRING-1,Y CMP #"." BNE RZ6 DEY RZ6 STY CHAR ; ; OUTPUT THE EXPONENT ; EX_a1 LDA SOUT_EXP ;CHECK FOR 0 ORA SOUT_EXP+1 BEQ RT1 LDY CHAR ;OUTPUT "E" IT JSR GETCHR ;LOOP JMP EE1 EE2 LDA ESIGN ;SET EXPONENT SIGN BEQ EE3 LDA FR1+2 EOR #080 STA FR1+2 EE3 movenum FR1,FR2 ;FR1=FR1+M3 E CMP #"E" BNE EE3 JSR GETCHR ;SET SIGN JSR FSN STX ESIGN EE1 JSR SYSNMID ;BR IF NOT NUMBER BCC EE2 JSR DIGIT ;FR1=FR1*10+DIG JMP FN_a1 FN_a4 movenum FR1,MANT ;SAVE MANTISA ; ; EVALUATE EXPONENT ; (lda #00 ;was LA FR1,0 FR1=0 (sta fr1  sta fr1+1   LDA @R10,Y ;BR IF CHAR <> ;BR IF DP=NO BEQ LOOP ' lda m3l ;was DEC2 M3L EXP-EXP-1 'bne $010 'dec m3l+1 $010 dec m3l ' LOOP JSR GETCHR ;LOOP NEXT CHARACTER ;SET DP BEQ FN_a2 OVFLOW FERR #2 RTS FN_a2 INC DP JMP LOOP FN_a3 JSR SYSNMID ;BR IF NOT DIGIT BCC FN_a4 JSR DIGIT ;FR1=FR1*10+DIGIT LDA DP ;FIND SIGN STX MSIGN ldx #00 ;was LA FR1,0,X FR1=0 (stx fr1 (stx fr1+1  FN_a1 CMP #02E ; was #0AE BR IF NOT . BNE FN_a3 LDA DP IN_b0 LDA @R10,Y ;GET 1ST NON-BLANK CMP #" " ;CHARACTER BNE IN_b1 INY JMP IN_b0 IN_b1 STY LY ;SAVE Y ; ; FIND NUMBER ; JSR FSN ********************** ;* SYSDPIN ; ; INITIALIZATION ; STA R11 STY R10 LDY #0 STY DP ;NO DECIMAL POINT STY M3L ;EXP=0 STY M3H DDRESS OF FLOATING POINT * ;* STRING * ;* * ;* OUTPUTS: * ;* FR1 - FLOATING POINT NUMBER * ;* * ;****************** * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 * ;* BY HAYDEN BOOK COMPANY, INC. * ;* * ;* INPUTS: * ;* A-Y - A LDY p_STRING+1 RTS SOUT_EXP .BLOCK 0B,00 .if test (.ascii "SYSDPIN" (.endc ' ;**************************************** ;* * ;* SYSDPIN - DOUBLE PRECISION INPUT * ;* STRING,Y INX INY CPX #5 BNE EX_a5 STY CHAR ; ; SET AND FLAG AND RETURN ; RT1 LDY CHAR LDA #0ff ;*** DA STA STRING,Y LDA p_STRING STY CHAR movew SOUT_EXP,R0 ;OUTPUT DIGITS JSR SYSCVDC LDX #0 LDA #"0" EX_a3 CMP R2,X BNE EX_a4 INX CPX #4 BNE EX_a3 EX_a4 LDY CHAR EX_a5 LDA R2,X STA LDA #" " STA STRING,Y INY LDA #"E" STA STRING,Y INY LDA SOUT_EXP+1 ;OUTPUT SIGN BPL EX_a2 SUB0 SOUT_EXP,SOUT_EXP LDA #"-" STA STRING,Y INY EX_a2 movew M3L,M1L JSR SYSDFLT JSR SYSDADD movenum LN10,FR2 JSR SYSDMUL JSR SYSDEXP ;FR1=EXP(FR1) movenum MANT,FR2 ;FR1=FR1*MANT JSR SYSDMUL ; ; SET SIGN AND ROUND FINAL ANSWER ; LDA FR1+2 AND #07F ORA MSIGN STA FR1+2 JSR SYSDRND RTS ; ; INTERNAL SUBROUTINES ; FSN LDX #0 ;FIND SIGN, PUT IT CMP #"+" DO 9 BYTE DIVIDE UNTIL LEFT JUSTIFIED ; (lda #0B7 ;LA M1L,-73 SET SHIFT COUNT (sta m1l (lda #0ff (sta m1l+1 (nop (nop (nop ( ( DV_a2 JSR CP12 BLT DV_a4 SEC 9 DEC FR1 IN_f9 LDA FR1 ORA FR1+1 BEQ OVFL_1 IN_f10 LSR FR2+2 ROR FR2+3 ROR FR2+4 ROR FR2+5 ROR FR2+6 ROR FR2+7 ROR FR2+8 ROR FR2+9 ROR FR2+0a ; ; ROR FR1+14. ROR FR1+15. ROR FR1+16. ROR FR1+17. ROR FR1+18. ROR FR1+19. JMP IN_f10 IN_f8 DEC FR1+1 ;PRESHIFT FR2 LDA FR1+1 CMP #0FF BNE IN_f+2,X STA FR1+11.,X STY FR1+2,X DBPL X,IN_f7 JSR CP12 ;CHECK FOR PRESHIFT BLT IN_f8 ;OF FR1 LSR FR1+11. ROR FR1+12. ROR FR1+13. LDA FR1 EOR FR2 BPL IN_f6 PLA OVFL_1 FERR #2 RTS IN_f6 PLA STA FR1 LDX #8 ;MOVE NUMBER TO WORK LDY #0 ;AREA AND ZERO FR1 IN_f7 LDA FR1EOR #080 STA FR2+2 IN_f5 SEC ;SUBTRACT EXPONENTS LDA FR1+1 SBC FR2+1 STA FR1+1 LDA FR1 SBC FR2 EOR #080 PHA EOR FR1 BPL IN_f6 STA FR1+2 LDA #0 IN_f3 STA SIGN LDA FR2+2 ;FR2=ABS(FR2); BPL IN_f4 ;SIGN = SIGN(FR1*FR2) LDA SIGN EOR #080 STA SIGN JMP IN_f5 IN_f4 ;ZERO IF FR1 IS ZERO ORA FR1+1 BEQ RTS_2 LDA FR1+2 ;FR1=ABS(FR1) BPL IN_f2 ;SIGN = SIGN(FR1) LDA #080 BNE IN_f3 IN_f2 EOR #080 ********************************* ;* SYSDDIV ; ; INITIALIZATION ; LDA FR2 ;EXCEPTION IF FR2 IS ORA FR2+1 ;ZERO BNE IN_f1 FERR #4 RTS_2 RTS IN_f1 LDA FR1 FR1 - NUMERATOR * ;* FR2 - DENOMINATOR * ;* * ;* OUTPUTS: * ;* FR1 - RESULT * ;* * ;*******;* * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 * ;* BY HAYDEN BOOK COMPANY, INC. * ;* * ;* INPUTS: * ;* movenum FR1,FR2 JSR SYSDFLT JMP SYSDADD (.if test (.ascii "SYSDDIV" (.endc  ;**************************************** ;* * ;* SYSDDIV - DOUBLE PRECISION DIVIDE * GT1 LDA @R10,Y CMP #" " BNE RTS_1 INY JMP GT1 RTS_1 STY LY RTS DIGIT AND #0F ;FR1=FR1*10+A STA M1L LM M1H,#0 movenum N10,FR2 JSR SYSDMUL ;IN X AND THE NEXT BEQ GETCHR ;CHARACTER IN A CMP #"-" BNE RTS_1 LDX #080 GETCHR LDY LY ;GET NEXT NON-BLANK INY ;CHARACTER ;SUBTRACT LDX #8 DV_a3 LDA FR1+11.,X SBC FR2+2,X STA FR1+11.,X DBPL X,DV_a3 DV_a4 ROL FR1+0a ;SHIFT IN DIVIDE BIT ROL FR1+9 ROL FR1+8 ROL FR1+7 ROL FR1+6 ROL FR1+5 ROL FR1+4 ROL FR1+3 ROL FR1+2 ROL FR1+19. ROL FR1+18. ROL FR1+17. ROL FR1+16. ROL FR1+15. ROL FR1+14. ROL FR1+13. ROL F ;SHIFT RIGHT 8 BITS ML2 LDA FR1+2,X STA FR1+3,X DBPL X,ML2 LDA #0 STA FR1+2 SEC TYA SBC #8 TAY BNE ML1 BEQ SS1 ML3 LSR FR1+2 STY FR1+1,X DBNE X,IN_d7 ; ; DO 9 DIGIT MULTIPLY ; LDY #72. ;72 BIT MULTIPLY ML1 LDA FR1+19. ;CHECK FOR 8 CLEAR BNE ML3 CPY #8 BLT ML3 LDX #16. STA FR2+11. ;OVERFLOW CLC JSR SYSDR2R IN_d6 LDX #9 ;MOVE NUMBER TO WORK LDY #0 ;AREA AND ZERO FR1 IN_d7 LDA FR1+1,X STA FR1+10.,X IN_d5A OVFL_3 FERR #2 RTS IN_d5 JSR AEXP ;SIGNS DIFFERENT- NO ;OVERFLOW POSSIBLE IN_d5A LDA #0 ;SHIELD FROM TS EOR FR2 ;SPLIT BASED ON BMI IN_d5 ;EXPONENT SIGNS JSR AEXP ;BOTH THE SAME ;ADD EXPONENTS EOR FR2 BPL ;FR2=ABS(FR2); BPL IN_d3 ;SIGN=SIGN(FR1*FR2) LDA SIGN EOR #080 STA SIGN JMP IN_d4 IN_d3 EOR #080 STA FR2+2 IN_d4 LDA FR1 ;ADD EXPONEN IN_d0A LDA FR1+2 ;FR1=ABS(FR1); BPL IN_d1 ;SIGN=SIGN(FR1) LDA #080 BNE IN_d2 IN_d1 EOR #080 STA FR1+2 LDA #0 IN_d2 STA SIGN LDA FR2+2 ; ; INITIALIZATION ; LDA FR1 ;ZERO IF FR1 OR FR2 ORA FR1+1 ;IS ZERO BEQ RTS_3 LDA FR2 ORA FR2+1 BNE IN_d0A STA FR1 STA FR1+1 RTS_3 RTS FR1,FR2 - NUMBERS TO MULTIPLY * ;* * ;* OUTPUTS: * ;* FR1 - RESULT * ;* * ;**************************************** ;* SYSDMUL * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 * ;* BY HAYDEN BOOK COMPANY, INC. * ;* * ;* INPUTS: * ;* BNE CP2 INX CPX #9 BNE CP1 CP2 RTS (.if test (.ascii "SYSDMUL" (.endc  ;**************************************** ;* * ;* SYSDMUL - DOUBLE PRECISION MULTIPLY * ;* LDA FR1+2 ;SET SIGN AND #07F ORA SIGN STA FR1+2 RTS OVFL_2 JMP OVFL_1 ; ; INTERNAL ROUTINE: COMPARE FR1 AND FR2 ; MANTISAS ; CP12 LDX #0 CP1 LDA FR1+11.,X CMP FR2+2,X ;SHIFTS SBC M1L STA FR1+1 LDA FR1 SBC M1H STA FR1 BCS DV_a5 LDA #0FF CMP M1L BNE OVFL_2 CMP M1H BNE OVFL_2 DV_a5 ORA FR1+1 BEQ OVFL_2 R1+12. ROL FR1+11. INC2 M1L ;INC SHIFT COUNT LDA FR1+2 ;CHECK FOR DONE BPL DV_a2 SEC ;ACCOUNT FOR EXTRA LDA FR1+1 ;SHIFT RIGHT 1 BIT ROR FR1+3 ROR FR1+4 ROR FR1+5 ROR FR1+6 ROR FR1+7 ROR FR1+8 ROR FR1+9 ROR FR1+10. ROR FR1+11. ROR FR1+12. ROR FR1+13. ROR FR1+14. ROR FR1+15. ROR FR1+16. ROR FR1+17. ROR FR1+18. ROR FR1+19. BCC ML4 CLC ;ADD PARTIAL PRODUCT LDA FR1+10. ADC FR2+10. STAa SEC XP8 LDA #0 SBC FR2,X STA FR2,X DBNE X,XP8 BEQ SF1_c XP9 ORA #080 ;SET HIGH BIT FOR STA FR2+2 ;POSITIVE NUMBER ; ; MATCH EXPONENTS BY SHIFTING ; SBEQ XP7 XP6 ORA #080 ;SET HIGH BIT FOR STA FR1+2 ;POSITIVE NUMBER XP7 LDA FR2+2 ;COMPLEMENT FR2 IF BPL XP9 ;IT IS NEGATIVE LDX #0 STA FR1+1 ;ROUNDING BIT STA FR2+1 STA FR1+11. STA FR2+11. LDA FR1+2 ;COMPLEMEMT FR1 IF BPL XP6 ;IT IS NEGATIVE JSR CFR1 ;SAVE EXPONENT STA R3 ;OF FR2 movew FR1,R0 ;SAVE EXPONENT ;OF FR1 LDA #0 ;SET HIGH BYTES AND LDX #0a XP3 LDA FR2,X LDY FR1,X STA FR1,X STY FR2,X DBPL X,XP3 XP3A LDA FR2 ;QUIT IF FR2=0 STA R2 ORA FR2+1 BNE XP3C RTS XP3C LDA FR2+1 FR1 ;IF THE EXPONENT OF CMP FR2 ;FR1 IS SMALLER BNE XP1 ;THAN THAT OF FR2, LDA FR1+1 ;SWITCH THEM CMP FR2+1 XP1 BGE XP3A ;* FR1-FR2 * ;* * ;**************************************** ;* SYSDSUB LDA FR2+2 EOR #080 STA FR2+2 SYSDADD ; ; INITIALIZE NUMBERS FOR SHIFTING ; LDA * ;* FR1,FR2 - NUMBERS TO ADD OR * ;* SUBTRACT * ;* * ;* OUTPUTS: * ;* FR1 - ANSWER: FR1+FR2 OR * SION ADD * ;* * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 * ;* BY HAYDEN BOOK COMPANY, INC. * ;* * ;* INPUTS: EOR #080 STA FR1 RTS (.if test (.ascii "SYSDSUB & SYSDADD" (.endc  ;**************************************** ;* * ;* SYSDSUB - DOUBLE PRECISION SUBTRACT * ;* SYSDADD - DOUBLE PRECISS2 LDA FR1+2 ;SET SIGN AND #07F ORA SIGN STA FR1+2 RTS ; ; INTERNAL ROUTINE: ADD EXPONENTS ; AEXP CLC LDA FR1+1 ADC FR2+1 STA FR1+1 LDA FR1 ADC FR2T BIT H;was DEY Y ??!? H JNE ML1 ; ; SET SIGN ; SS1 LDA FR1+2 ;SHIFT LEFT 1 BIT IF BMI SS2 ;SHIELD BIT NOT JSR SYSDROL ;USED 5 ADC FR2+5 STA FR1+5 LDA FR1+4 ADC FR2+4 STA FR1+4 LDA FR1+3 ADC FR2+3 STA FR1+3 LDA FR1+2 ADC FR2+2 STA FR1+2 ML4 DEY ;NEX FR1+10. LDA FR1+9 ADC FR2+9 STA FR1+9 LDA FR1+8 ADC FR2+8 STA FR1+8 LDA FR1+7 ADC FR2+7 STA FR1+7 LDA FR1+6 ADC FR2+6 STA FR1+6 LDA FR1+F1_c SEC ;SET # SHIFTS LDA R1 SBC R3 STA R4 LDA R0 SBC R2 BNE SF1A ;QUIT IF # SHIFTS LDA R4 ;> 80 CMP #81. BLT SF1B SF1A JMP SE1_a SF1B lsr a ; was MLSR A,3 SHIFT RIGHT BY FULL (lsr a (lsr a ( BEQ SF4 ;BYTES, MAINTAINING STA R5 THE EXPONENT. * ;* * ;**************************************** ;* SYSDROL LDA #0FF ;DEC EXPONENT DEC FR1+1 CMP FR1+1 BNE RL1 DEC FR1 MANTISSA * ;* FR1 - RESULT * ;* * ;* NOTES: * ;* 1) ENTRY AT SYSDR10 SHIFTS THE * ;* MANTISSA WITHOUT CHANGING * ;* ;* * ;* INPUTS: * ;* FR1 - NUMBER TO SHIFT * ;* * ;* OUTPUTS: * ;* C - MOST SIGNIFICANT BIT OF * ;* THE HIGH BIT OF THE * ;* MANTISSA IS LEFT IN THE CARRY FLAG. * ;* * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 * ;* BY HAYDEN BOOK COMPANY, INC. * ******************************** ;* * ;* SYSDROL - ROLL FR1 LEFT 1 BIT * ;* * ;* THIS ROUTINE SHIFTS THE MANTISSA * ;* LEFT 1 BIT AND DECRIMENTS THE * ;* EXPONENT. ;1 BIT ROR FR1+4 ROR FR1+5 ROR FR1+6 ROR FR1+7 ROR FR1+8 ROR FR1+9 ROR FR1+10. ROR FR1+11. RTS ' ' (.if test (.ascii "SYSDROL" (.endc  ;********; INTERNAL SUBROUTINES ; CFR1 LDX #0a ;COMPLEMENT FR1 SEC CF2 LDA #0 SBC FR1,X STA FR1,X DBNE X,CF2 RTS ROR_1 % ROR FR1+2 ;ROLL FR1 RIGHT ROR FR1+3 LOOP IF NOT NORMAL BPL NM3 ; ; SET THE SIGN AND EXPONENT AND QUIT ; SE1_a movew R0,FR1 ;SET EXPONENT LDA FR1+2 ;SET SIGN AND #07F ORA SIGN STA FR1+2 RTS ; NM3 ASL FR1+11. ;SHIFT LEFT 1 BIT JSR SYSDR10 DEC R1 LDX #0FF CPX R1 BNE NM4 DEC R0 NM4 LDA R0 ORA R1 BEQ OVFL_4 NM5 LDA FR1+2 ;DBNE X,NM1A STA FR1 RTS NM2 LDA FR1+1 BEQ NM5 SEC ;SHIFT RIGHT 1 BIT JSR ROR_1 INC R1 BNE NM2A INC R0 NM2A BNE SE1_a OVFL_4 FERR #2 RTS STA SIGN BPL NM1 ;BR IF FR1 > 0 JSR CFR1 ;COMPLEMENT FR1 ; ; NORMALIZE THE RESULT ; NM1 LDX #9 ;CHECK FOR ZERO NM1A LDA FR1,X BNE NM2 X,SF5 ; ; ADD FR1 AND FR2 ; AD1_a CLC ;10 BYTE ADD LDX #0b AD2 LDA FR1,X ADC FR2,X STA FR1,X DBNE X,AD2 LDA FR1+1 ;SAVE SIGN AND #080 X,SF3 SF4 LDA R4 ;SHIFT RIGHT BIT BY AND #7 ;BIT, MAINTAINING BEQ AD1_a ;SIGN BIT. TAX SF5 LDA FR2+1 ASL A JSR SYSDR2R DBNE ;SIGN BITS. SEC LDA #0b SBC R5 TAY LDX #0b SF2 LDA FR2,Y STA FR2,X DEX DBNE Y,SF2 LDA #0 LDY FR2+1 BPL SF3 LDA #0FF SF3 STA FR2,X DBNE LDA FR1 ORA FR1+1 BNE RL1 FERR #5 RTS RL1 ASL FR1+17. ;SHIFT LEFT 1 BIT ROL FR1+16. ROL FR1+15. ROL FR1+14. ROL FR1+13. ROL FR1+12. ROL FR1+11. SYSDR10 ROL FR1+10. ROL FR1+9 ROL FR1+8 ROL FR1+7 ROL FR1+6 ROL FR1+5 ROL FR1+4 ROL FR1+3 ROL FR1+2 RTS  .if test (.ascii "SYSDR2 ereg .equ 0ffdf breg .equ 0ffef 0.macro dbstr 0.if debug 0jmp $090  .ascii "**** " 0.ascii %1 0.ascii " ****" $090 0.endc 0.endm   (.macro saveaxy (pha (txa (pha (tya (pha (.endm (1 2 RO^< ROR FR2+7 ROR FR2+8 ROR FR2+9 ROR FR2+10. ROR FR2+11. RTS * ;* FR2 - SHIFTED RIGHT 1 BIT * ;* * ;**************************************** ;* SYSDR2R ROR FR2+2 ROR FR2+3 ROR FR2+4 ROR FR2+5 ROR FR2+6 * ;* BY HAYDEN BOOK COMPANY, INC. * ;* * ;* INPUTS: * ;* FR2 - REGISTER TO ROLL * ;* * ;* OUTPUTS: R" (.endc  ;**************************************** ;* * ;* SYSDR2R - ROLL 2 RIGHT 1 BIT * ;* * ;* BY MIKE WESTERFIELD * ;* COPYRIGHT (C) JANUARY 1983 (.macro restaxy (pla (tay (pla (tax (pla (.endm (.macro copy_filename (lda %1 (pha (lda %1+1 (pha (CALL copy_pname  .endm  (.macro movew (lda %1 (sta %2 (lda %1+1 (sta %2+1 (.endm ( ( (.macro old_movew (lda %2 (sta %1 (lda %2+1 (sta %1+1 (.endm ( (.macro moveb (lda %1 (sta %2 (.endm  (.macro msg0 (movew %1,%2+1 (jsr do_msg0  .endm ( (.macro msg (movew %1,%2+1 (jsr do_msg   79C";"PRESS ANY KEY TO HALT LISTING"::202 1020#2,B$(I),16,B)ž#242:::1160Z=1#2;A$:"78A";A$Z=Z+1:Z>1842:::Z=1980*:=23:=0::"79C";"CONTINUE...?":1C$:C$<>"Y"C$<>"y"C$<>"N"C$<>"n"10 MENU.MAKER TEXT MODULESEG=0"MENU.MAKER"890&*X=11000: TEXT SLOW-DOWN LOOP ,X.1,180,22:2,280,21:2,2380,23:z:A$="LISTING "+B$(I),16,B)$=01:=0::"80C";A$;::12)>=23:=0::"OMMON.TEX -: -: 8.TEX; QMON.205.TEX; QMON.TEX;REMO.100.TEX; REMO.101.TEX; REMO.102.TEX; REMO.103.TEX; REMO.TEX; SCAN.201.TEX; SCAN.TEX; SHELL.TEX; TEST.ONOFF.TEX; TYPE.203.TEX; TYPE.TEX; ZPCOMMENT.TEX; ZPCOMMON.TEX X; TYPE.203.TEX; TYPE.TEX; ZPCOMMENT.TEX; -: ZPCALC.SCT.TEX; CALC.TEX; CALLMACS.TEX; CRPT.202.TEX; CRPT.TEX; DUMP.201.TEX DUMP.TEX; FONT.201.TEX; FONT.TEX; LOAD.TEX; LOCK.201.TEX; LOCK.TEX; MAPIT.TEX; MY.DISP.TEX; OLDCALC.1.TEX; PKYMACS.TEX Side Two files include: BUK2.TEX; BUK4.TEX; BUK6.TEX; BUK WAP /// SIG PUBLIC DOMAIN LIBRARY PDS NAME: Powerkeys DM+ Source Code: Disk 2 DISK ID#: 3SRC-03 BOOTABLE? Bootable More Pascal Source Code Files for Daryl Anderson's Power Keys Background Utility program. Side One files include: Cbat (lda %1 (sta @%2,y (iny (.endm ( (.macro set1mhz (php (sei (lda ereg (ora #80 (sta ereg (plp (.endm ( (.macro set2mhz (php (sei (lda ereg (and #7f (sta ereg (plp (.endm ( acro addwiac (clc (ldy #00 (lda @%1,y (adc %2 (sta @%3,y (iny (lda @%1,y (adc %2+1 (sta @%3,y (.endm (.macro movewat (lda %1 (sta @%2,y (iny (lda %1+1 (sta @%2,y (iny (.endm ( (.macro move %2+1 (sta %3+1 (.endm ( (.macro movewia (ldy #00 (lda @%1,y (sta %2 (iny (lda @%1,y (sta %2+1 (.endm ( (.macro movewib (ldy #00 (lda %1 (sta @%2,y (iny (lda %1+1 (sta @%2,y (.endm ( (.m(inc %1 (bne $901 (inc %1+1 $901 .endm (.macro addw (clc (lda %1 (adc %2 (sta %3 (lda %1+1 (adc %2+1 (sta %3+1 (.endm ( (.macro sbcw (sec (lda %1 (sbc %2 (sta %3 (lda %1+1 (sbc .endm  ( (.macro decw (inc %1 ;is lsb zero (from Leventhal) (dec %1 (bne $901 (dec %1+1 $901 dec %1 (lda %1 (ora %1+1 ;to set Z flag properly (.endm  (.macro incw (from Leventhal) 30C$="N"C$="n"1160;:=23:=0::"79C";"PRESS ANY KEY TO HALT LISTING": $1020.202 8::Z=1B::=23:=0::"79C";"WOULD YOU LIKE A PRINTED COPY?":1C$:C$<>"Y"C$<>"y"C$<>"N"C$<>"n"1170*C$="N"C$="n"B$(I);v:520: 500THPOS=4:I/2=I/2)I=I-1I=IBOTM THPOS=44:I/2<>I/2)I=I+1I2=-1:I=I-2:IBOTM<30THPOS=44I=IBOTM/2)*2:=+IBOTM/2)-1:CA)"PRINT.ALL": OA+P 3HA=(81+UCA)A=(81+LCA):::: OA+Q Quits 3IA=(83+LCA)A=(83+UCA)"PRINT.SHOW": OA+S 2JA=(68+LCA)A=(68+UCA)/Screen.Savers/HELLON=THPOS:B$(I);XA<8A>11540bA-7640,660,690,720l:=THPOS:ٺ1600 =Q:WW=0A=:A=21A=9&oldprefix$=40A=31410: Control C "aborts" program to Basic(:A=13770: Return Selects a file *DA=27:50: Escape to change disks/FA=324000: back out one directory level 3GA=(80+UCA)A=(80+L"BASIC 0":150A$="TEXT 0":150A$="CAT 0":150A$="FONT 0":150A$="FOTO 0":150A$(L),"BLOCKS")510*=27:=19:"FREE MEMORY AVAILABLE: ";=7:=20:"80C";A$(L);$:=5:THPOS=4:I=1:IBOTM=J-1:620Q=:=26:=21:sic; +Q Quits."r12);::"80C";a$;:+w#9,"DISKNAME.DAT":#9;DISKNAME$:#9|d$=DISKNAME$$=23:=0::"80C";d$;::12)201M=3:=14:"This /// SIG Disk is \^ 19";Р,2)", Washington Apple `, Ltd."=4:B$(1)="":B$(2)=""A$=16,B) THEN 240 #1, d$="":=10:"80C";d$ ž#1300I=0"I=I+1:#1;A$(I):290,#1 6L=I-1@j=1:same=0 J:SEG=0 Tœ2030^CT<1CT=1cCT>13000Zha$="{,|,~,}; selects; to new disk; J/2)=4:=+1:ۙ=44B$(J);:J=J+1I:1,180,22:2,280,21:2,2380,23:8A$(1000),B$(1000),C%(511),C$(20),name$(20):=10:=0UCA=128:LCA=UCA+32CT=15 IF PREFIX$= PREFIX$+MID$(B$(I), VOLUME NAME (/DISKNAME) OR DEVICE NAME (.Dx)"P12);::"80C";a$;:Zb$="CHANGING DISKS"$d=23:=0::"80C";b$;::12).n=12:=20:"MAKE A NEW MENU FOR DISK: ";N$xN$)<2110=N$ :210 I=1L(A$(I),A$))200B$0 WAP /// SIG MENU.MAKER PROGRAM (v. 6.2) =".D1"210: Coldstart (320: Warmstart &*X=11000: TEXT SLOW-DOWN LOOP ,X.1 CHANGE DISK SUBROUTINE23œ202:2200<RFa$=" YOU MAY SELECT YOUR DISK BY EAD PASCAL TEXT FILES."04=10:"78C";"ANY KEY RETURNS TO THE MENU."!>G$:::".D1/MENU.MAKER",320R",220(204::"79A";""; 2D=1:F=1 <#4;a$ FD=D+1 P#5;a$ZD=60#5;12)dD=60D=1nF=F+1::d$;::Y=1100:Y x13402  CATCH PASCAL TEXT FILES 202 :F*=08:"78C";"SORRY BUT MENU.MAKER CAN'T R".D1/MENU.MAKER",220 d$="" A$="PRINTING "+B$(I),16,B)=01:=0::"80C";A$;:#3,B$(I),16,B)Z=1#3;b$:"78A";b$Z=Z+1:Z=18:1290 1260 #4,B$(I),16,B)#5,".PRINTER"+ž#4#5;12):::".D1/MENU.MAKE0=+IBOTM/2-.5):I=IBOTM:I/2=I/2)I=I-1 œ2120B=B$(I),16)," ")-1 B$(I),"BASIC 0")850B$(I),"TEXT 0")890 B$(I),"CAT 0")1140*B$(I),"FONT 0")18504B$(I),"FOTO 0")1930>B$(I),"PASTXT 0")2070H540R\A$="RUNNING "+B$(I),16,B)f"79C";A$;:=0pB$(I),16,B) z::SEG=1".D1/SEG.T"t=+B$(I),16,B) yCT=CT+1~240:=24:=0:"@ ..... "DATE.TIME.LINE" ....JM=Ҡ,4,2))BTM1630,1640,1650,$007 sta 1600,x ;clear out xbytes 0inx 0bne $007 0 0ldx #0f $010 lda 1900,x 0sta s_1900,x 0lda x1900_stuff,x 0sta 1900,x 0dex 0bpl $010 0 lda MONro page $005 lda 1600,x 0sta s_1600,x 0lda 1a00,x 0sta s_1a00,x 0lda 1b00,x 0sta s_1b00,x 0lda 1e00,x 0sta s_1e00,x 0lda 1f00,x 0sta s_1f00,x 0inx 0bne $005 0 0txa php 0plp 0sta s_pstat 0sei 0tsx 0stx s_stack save_em moveb monzpg+66,s_m66 0moveb monzpg+67,s_m67 0moveb monzpg+68,s_m68 0moveb b_reg,s_breg 0moveb e_reg,s_ereg 0 ldx #00 ;save ze ;normal vid 0.byte 0ff p_start_msg .word start_msg  entry 0CALL m_msg0,p_init_msg 0CALL m_get_char 0and #5c 0cmp #"X" 0bne do_it 0rts  do_it CALL m_msg,p_start_msg 0 p_init_msg .word init_msg  start_msg .byte 1c,1a,00,12,12 ;clear inverse 0.ascii "Entering Monitor...Type 1900J to EXIT" 0.byte 0d 0.ascii "512 bytes from 1E00-1FFF available for I/O buffer" 0.byte 11 .equ 0300 MONENTRY .equ 0F901 ; ; Interpreter Header ; ; init_msg .byte 12 0.ascii "Press Any Key to enter MONITOR... X to quit now" 0.byte 11 0.byte 0ff key for module .word start-1 .word end-start .ascii "QuikMon "  ; Interpreter Monitor Source Code ; ; 0 ENVIRON .equ 0FFDF USERZPG .equ 1A00 MONZPG a$,1)="/"5060:s=s-1 5030=a$240 MENU.MAKER 6.2 * Thanks to C.M.Davidson for his help!l; G$:::320H: Error Routine 202:U=11:"79C";"BAD PATH ERROR (NO DISK IN DISK DRIVE OR DESIRED FILE NOT FOUND.)"X=11000:X:::210Z a$="{,|,~,}; selects; back 1 leve 1600 &:WW=1:0 :SEG=1;".D1/SEG.F" SEG=1".D1/SEG.G"diskname$=3802  CATCH PASCAL TEXT FILES 202 :F*=08:"78C";"SORRY BUT MENU.MAKER CAN'T READ PASCAL TEXT FILES."04=10:"7M$="NOVEMBER":1750M$="DECEMBER":1750826);"-";M$;" ";Ѡ,2));", ";"19";Р,2);" ";/П,2))=>13П,2))-12;џ,6);:1780$П,2))=0"12";џ,6);:ٟ;$П,2))=>12" PM-":" AM-" 1830WW=1530 =26:=211660,1670,1680,1690,1700,1710,1720,1730,1740^M$="JANUARY":1750hM$="FEBRUARY":1750rM$="MARCH":1750|M$="APRIL":1750M$="MAY":1750M$="JUNE":1750M$="JULY":1750M$="AUGUST":1750M$="SEPTEMBER":1750M$="OCTOBER":1750ZPG+68 ; ??? ora #40 sta MONZPG+68 ora #7F and #0A0 sta MONZPG+66 sta MONZPG+67