curzon@kaoa01.dec.com (Richard Curzon KAO4-3/7A DTN 621-2196) (11/10/87)
For those interested in the Action! language, this is the LittleLister
source code. In order to represent the non-ASCII characters, it was
prepared by LittleLister itself. It prefixes the inverse video
characters with a "@" -- so it will need some editing to run...
If you are checking out compiled languages for the 8bit, you will note
Action! has similarities to Pascal and C, as can be seen in this
example. And it is faster in compilation, and compactness of code
produced than any other hi-level language on the 8 bit. A pleasure
to use, comes with a good built-in program editor.
Potentially interesting things:
procedure GetAD(), PutAD() - block I/O suggested by Bruce
Langdon
procedure Get_Wds() - gets the words from the command line for
Sparta DOS, DOS XL as well as detecting whether
the DOS in use has command line capability
procedure End() - goes to DOS (not too tricky), but
this procedure also keeps the stack clear, regardless
of how deeply nested you are when you call it.
procedure Clr_Dos() - a work around. I found that if I returned to
SpartaDOS, when the last disk access was for write or
update, I often got some out-of-control disk writing.
This function ensures that the last disk access was a
read before we exit to DOS. [If anybody can explain, I
would like to know what causes this!]
---------------------------------------------
;LL.ACT OCT 15,1987 - R CURZON
;(I/O from PRINT.ACT by Bruce Langdon)
;locate above the G: device by
;CF Johnson, to allow graphics
;output
SET 14=$2F01
SET $491=$2F01
; command line dos will try to run
; twice unless we put rts at start
BYTE rts = [$60]
; --System Variables
BYTE shflok = $2BE, ch = $2FC,
crsinh = $2F0
CARD sdslst = $230
; --Working globals
; First global ARRAY, other than
; BYTE ARRAY of length < 257,
; is placed AFTER rest of program
BYTE ARRAY in_b(257) ; locate
; the in_buff
; variables array
BYTE ARRAY vars
BYTE pr_wid = [80], file_lim = [39],
col_lim = [2], file_marg = [2],
line_lim = [56], page_len = [66],
top_bl = [5], bott_bl = [5],
pause_fl = ['Y], convert_fl = ['S],
page_st = [1]
; PRECEDING SHOULD BE CHANGED ONLY
; WITH CARE IN ORDER FOR "S" COMMAND
; TO UPDATE LL.COM TO WORK
BYTE ARRAY convert_st = " "
BYTE c_wds ;command line flag
BYTE r_ent =[0] ;flags if program
;entered through Run_Ent
BYTE file_l, col_l, line_l
BYTE ARRAY out_b
CHAR ARRAY out_dev(20),
in_fil(20)
CARD line_c, file_c, col_c, out_s,
in_s, in_c, out_i, in_i
BYTE op_ok, b, page_n, b_wid,
col_wid
BYTE cio_status ; global for CIO
; return value (per ACS convention)
INCLUDE "RTIME.ACT"
PROC End=*()
[$68$AA$68$CD$2E8
$90$5$CD$2E6$90$F3
$48$8A$48$60]
; entry: PLA; TAX; PLA; CMP MEMLO+1;
; BCC lab; CMP MEMTOP+1; BCC entry;
; lab: PHA; TXA; PHA; RTS
;
; Trace back thru RTS's and
; return to cartridge or DOS.
; From ACS bulletin board.
; error routines
PROC Sys_Error(BYTE errno)
PROC Clr_Dos(BYTE chan)
; seems to clear Spartados
; settings for exit to DOS
; (dummy directory)
Close(chan)
Open(chan,"D:*.*",6,0)
Close(chan)
RETURN
PROC My_Error(BYTE errno)
Close(2) Close(3)
PrintF("error %I. Rerun%E",errno)
End()
PROC D_Error(BYTE errno)
BYTE i
IF errno=128 THEN
Close(2) Clr_Dos(3) End() FI
PrintF("error %I. Try again%E",errno)
op_ok = 0
RETURN
CARD FUNC GetAD(BYTE chan CARD addr,
len) ; Block read
TYPE IOCB = [BYTE hid,dno,com,sta
CARD badr,put,blen
BYTE aux1,aux2,aux3,
aux4,aux5,aux6]
IOCB POINTER ic
BYTE chan16
chan16 = (chan&$07) LSH 4
ic = $340+chan16
ic.com = 7 ; read
ic.blen = len
ic.badr = addr
[$AE chan16 $20 $E456 $8C cio_status]
; LDX chan JSR CIO STY cio_status
IF cio_status = $88 THEN
eof(chan) = 1
FI
RETURN (ic.blen)
CARD FUNC PutAD(BYTE chan CARD addr,
len) ; Block write
TYPE IOCB = [BYTE hid,dno,com,sta
CARD badr,put,blen
BYTE aux1,aux2,aux3,
aux4,aux5,aux6]
IOCB POINTER ic
BYTE chan16
chan16 = (chan&$07) LSH 4
ic = $340+chan16
ic.com = 11 ; write
ic.blen = len
ic.badr = addr
[$AE chan16 $20 $E456 $8C cio_status]
; LDX chan JSR CIO STY cio_status
RETURN(ic.sta)
PROC Fix_FlSp(BYTE ARRAY filespec)
CARD i
IF filespec(2) <> ': AND filespec(3)
<> ': THEN
; if no device, prefix "D:" to file
filespec^ == +2
i=filespec^
WHILE i>2 DO
filespec(i) = filespec(i-2)
i == -1
OD
filespec(1) ='D filespec(2) =':
FI
RETURN
PROC Show_Hdr()
Print(
" @L@i@t@t@l@e@L@i@s@t@e@r@ @2 - R Curzon
'LL' =setup @ @ 'RUN 4A60' =rerun
'LL [input [output]]' =command line
")
RETURN
PROC Show_Vars()
PutE()
PrintF("@A Printer width : %U%E",
pr_wid)
PrintF("@B Width per column : %U%E",
file_lim)
PrintF("@C Number of columns: %U%E",
col_lim)
PrintF("@D Between columns : %U%E",
file_marg)
PrintF("@E Text lines/page : %U%E",
line_lim)
PrintF("@F Total lines/page : %U%E",
page_len)
PrintF("@G Filler lines/top : %U%E",
top_bl)
PrintF("@H Filler lines/bot : %U%E",
bott_bl)
PrintF("@I Page pause Y/N : %C%E",
pause_fl)
PrintF("@J ASCII/ATASCII/HEX: %S%E",
convert_st)
PrintF("@K Starting page num: %U%E",
page_st)
PrintF("@L Output device : %S%E",
out_dev)
PutE()
PrintE("@S Save configuration - @A-@J")
PrintE("@X Execute")
RETURN
PROC Set_Defs()
BYTE i
FOR i = 1 TO 20 DO
in_fil(i) = '
OD
in_fil(0) = 0
page_n = 0
out_dev(0)=2
out_dev(1)='P
out_dev(2)=':
vars = @pr_wid
RETURN
PROC Set_Vars()
BYTE change, i, j, save_fail
BYTE loc_err
ch = 255
Close(4)
Open(4,"K:",4,0)
loc_err = 0
save_fail = 0
DO ; check for bad values, allow
; changes to program variables
IF col_lim = 0 THEN col_lim =1 FI
IF line_lim=0 THEN line_lim =1 FI
IF convert_fl ='S THEN
convert_st = "ASCII "
ELSEIF convert_fl ='T THEN
convert_st = "ATASCII"
ELSE convert_st = "HEX "
FI
crsinh = 1
Put(125)
Show_Hdr()
Show_Vars()
Position(5,21)
IF pr_wid< file_lim * col_lim
+file_marg * (col_lim-1) THEN
loc_err = 1
Print("@I@N@V@A@L@I@D@ @A@,@ @B@,@ @C@,@ @D")
ELSEIF page_len # line_lim +
top_bl + bott_bl THEN
loc_err = 1
Print("@I@N@V@A@L@I@D@ @E@,@ @F@,@ @G@,@ @H")
ELSEIF out_dev(1) >= 'a THEN
loc_err = 1 ;should be upperc.
Print("@I@N@V@A@L@I@D@ @L")
ELSEIF save_fail = 1 THEN
Print("@N@O@ @F@I@L@E@ @D@:@L@L@.@C@O@M")
save_fail = 0
loc_err = 0 ; not fatal error
ELSEIF change = 'S THEN
Print("LL.COM revised")
loc_err = 0 ; not error
ELSE loc_err = 0
FI
shflok = $40 ; upper case
change = GetD(4)
Position(0,21)
Print(" ")
crsinh = 0
IF change>= 'a THEN
change == -32 FI
IF change>='A and change<='L THEN
Position(23,change-61)
Print(" ")
Position(21,change-61)
Print(": ")
IF change<'I OR change ='K THEN
vars(change - 65) = InputB()
ELSEIF change = 'I THEN
IF pause_fl = 'N
THEN pause_fl = 'Y
ELSE pause_fl = 'N
FI
ELSEIF change = 'J THEN
IF convert_fl = 'S
THEN convert_fl = 'T
ELSEIF convert_fl = 'T
THEN convert_fl = 'H
ELSE convert_fl = 'S
FI
ELSEIF change = 'L THEN
InputMD(0,out_dev,20)
Fix_FlSp(out_dev)
FI
FI
IF change='S AND loc_err= 0 THEN
Close(3)
Error = D_Error op_ok = 1
Open(3,"D:LL.COM",12,0)
Error = My_Error
IF op_ok = 1 THEN
FOR i = 1 TO 13 DO
j = GetD(3)
OD ; find the 14th byte
FOR i = 0 TO 9 DO
PutD(3,vars(i))
OD ; update the variables
ELSE save_fail = 1
FI
Clr_Dos(3)
FI
UNTIL loc_err= 0 AND change= 'X OD
Close(4)
RETURN
PROC Alloc_Buffs()
CARD size
col_wid = file_lim + file_marg
b_wid = col_wid *(col_lim)
-file_marg + 1
; set index values
file_l = file_lim -1
col_l = col_lim -1
line_l = line_lim -1
ch = 255
; find size and location of
; the output buffer
out_s = (line_lim) * b_wid
out_b = sdslst - out_s
; input buffer starting point
; was set to end of program
; in variable declarations
IF in_b > out_b - 200 THEN
PrintE(
"@n@o@t@ @e@n@o@u@g@h@ @m@e@m@o@r@y@!@!")
End() FI
; find size of input buffer
in_s = sdslst - out_s - in_b
RETURN
PROC Print_Clear()
CARD i, b_ptr, o_b_ptr
BYTE j, k, n, tc, bc, test
b_ptr = 0 o_b_ptr = 0
FOR i = 0 to line_l DO
; trim trailng spaces from
; each print line
n = 0
FOR j = 0 to b_wid - 1 DO
IF out_b(b_ptr + j) # ' THEN
n = j FI
OD
; line will be chopped at "n"
b_ptr == + n + 1
out_b(b_ptr) = $9B
b_ptr == +1
; slide everything else down
; over the unused space
MoveBlock(out_b + b_ptr,
out_b + o_b_ptr + b_wid,
(line_l - i) * b_wid)
o_b_ptr = b_ptr
OD
tc = top_bl bc = bott_bl
WHILE tc > 0 DO
IF top_bl >3 AND tc= top_bl-2
THEN
; if enough room print page header
PrintD(3,in_fil)
FOR i= 9 TO pr_wid-in_fil(0) DO
PutD(3,' )
OD
PrintD(3,"Page ")
PrintBDE(3,page_n)
tc == -1
ELSE
PutDE(3) tc == -1
FI
OD
PutAD(3,out_b,b_ptr)
WHILE bc > 0 DO ;bottom fill lines
PutDE(3) bc == -1
OD
IF pause_fl= 'Y AND
out_dev(1) # 'D THEN
PutE()
PrintE("@R@E@T@U@R@N@ @=@m@o@r@e@ @,@B@R@E@A@K@ @=@q@u@i@t")
Close(4)
Open(4,"K:",4,0)
ch = 255
DO test = GetD(4)
UNTIL test = $9B OD
Close(4)
FI
RETURN
PROC Rst_Outb()
file_c = 0 line_c = 0 col_c = 0
out_i = 0
SetBlock(out_b,out_s,' )
; 'blank' is not $00!
RETURN
PROC Compose(BYTE chx)
; find where each character belongs
; in the output buffer
IF chx = $9B OR file_c>file_l THEN
out_i == -file_c + b_wid
line_c == +1
file_c = 0
FI
IF chx = $9B THEN RETURN FI
IF line_c>line_l THEN
col_c == +1
out_i = col_c * col_wid
line_c = 0
file_c = 0
FI
IF col_c>col_l THEN
page_n == +1
IF page_n >= page_st THEN
Print_Clear()
FI
Rst_Outb() ;clear/reset ptrs
FI
;
; out_i now points to where to put
; this character
;
out_b(out_i) = chx
file_c == +1 out_i == +1
RETURN
PROC Op_File()
BYTE dnum
BYTE ARRAY dir_wk(21)
BYTE ARRAY dir_nm = "Dn:*.*"
ch = 255
dnum = 0
op_ok = 1
DO
IF in_fil(0) = 0 OR r_ent = 1
OR op_ok = 0
THEN
; if menu, set position
IF (c_wds < 2 OR r_ent = 1)
AND dnum = 0 THEN
Position(25,21)
Print(" ")
Position(2,21)
FI
Print("@S@o@u@r@c@e(RET quits/1-4,8):")
shflok = $40 ; upper case
dnum = 0
DO UNTIL ch # 255 OD
IF ch = 31 THEN dnum = 1 FI
IF ch = 30 THEN dnum = 2 FI
IF ch = 26 THEN dnum = 3 FI
IF ch = 24 THEN dnum = 4 FI
IF ch = 53 THEN dnum = 8 FI
IF dnum # 0 THEN
dir_nm(2) = dnum + '0
ch = 255
op_ok = 1
Error = D_Error
Close(2)
Open(2,dir_nm,6,0)
IF op_ok = 1 THEN
PrintF("%E%E@D@r@i@v@e@ @#@ %C%E%E",
dnum + '@0 )
DO
InputMD(2,dir_wk,20)
IF op_ok = 0 THEN EXIT FI
PrintE(dir_wk)
IF dir_wk(1) >= '0 AND
dir_wk(1) <= '9 THEN EXIT
FI
OD
PutE()
FI
Close(2) op_ok = 0
Error = My_Error
ELSE
InputS(in_fil)
IF in_fil^ = 0 THEN
End() FI
Fix_FlSp(in_fil)
FI
FI
Error = D_Error
IF dnum = 0 THEN
Close(2)
op_ok = 1
Open(2,in_fil,4,0)
FI
UNTIL op_ok OD
Error = My_Error
RETURN
PROC Hcompose(BYTE chx)
BYTE t
Compose('$)
t =(chx&$F0) RSH 4 + '0
IF t > '9 THEN t == +7 FI
Compose(t) ; first digit
t =(chx&$0F) + '0
IF t > '9 THEN t == +7 FI
Compose(t) ; last digit
RETURN
PROC Print_File()
BYTE t
CARD i
Rst_Outb()
Op_File()
Close(3)
Open(3,out_dev,8,0)
IF convert_fl = 'T THEN
DO
in_c =GetAD(2,in_b,in_s)
FOR i = 0 TO in_c - 1 DO
Compose(in_b(i))
OD
IF eof(2) THEN
page_n == +1
Print_Clear() EXIT
FI
UNTIL eof(2) OD
ELSEIF convert_fl = 'H THEN
DO
in_c =GetAD(2,in_b,in_s)
FOR i = 0 TO in_c - 1 DO
Hcompose(in_b(i))
OD
IF eof(2) THEN
page_n == +1
Print_Clear() EXIT
FI
UNTIL eof(2) OD
ELSEIF convert_fl ='S THEN
DO
in_c =GetAD(2,in_b,in_s)
FOR i = 0 TO in_c - 1 DO
IF in_b(i) =$9B THEN
Compose($9B)
ELSE t = in_b(i) & $7F
IF t >26 AND t <32 OR
t =96 OR t >122 THEN
Hcompose(in_b(i))
ELSE
IF in_b(i) > $7F THEN
Compose('@) FI
IF t < 27 THEN
Compose('^)
Compose(t + $40)
ELSE Compose(t)
FI
FI
FI
OD
IF eof(2) THEN
page_n == +1
Print_Clear() EXIT
FI
UNTIL eof(2) OD
FI
Close(2)
Clr_Dos(3)
RETURN
PROC Get_wds()
CARD POINTER dosvec = $0A
BYTE POINTER comtab_ptr1
BYTE POINTER comtab_ptr2
BYTE ARRAY c_line, wk_d
BYTE i, j, eol_fl
in_fil(0) = 0
comtab_ptr1 = dosvec^ + 3
c_wds = 0
; no of words on command line
; 0 means not a comm line type DOS
; command line DOS's have a JMP instr
; at comtab + 3 to file crunch
; routine
IF (comtab_ptr1^) # $4C THEN
RETURN
FI
; but make sure it's not Machdos
; (no command line)
comtab_ptr1 = dosvec^ + 6
comtab_ptr2 = dosvec^ + 9
IF (comtab_ptr1^) = $4C AND
(comtab_ptr2^) = $4C THEN
RETURN
FI
c_line = dosvec^ + 63
; get command line words
eol_fl = 0
i = 0
DO
; find start of word
DO
IF c_line(i) = $9B OR
i > 63 THEN
eol_fl = 1 EXIT
ELSEIF c_line(i) # ' THEN EXIT
ELSE i == +1 FI
OD
IF eol_fl THEN EXIT FI
; trace to end of word, store
j = 1
c_wds == +1
; ignore 1st word only
IF c_wds = 2 THEN wk_d = in_fil
ELSEIF c_wds=3 THEN wk_d=out_dev
FI
IF c_wds > 1 THEN
DO
wk_d(j) = c_line(i)
i == +1
IF c_line(i) = $9B OR i > 63
THEN eol_fl = 1 FI
IF c_line(i) =' OR eol_fl =1
THEN wk_d(0) = j EXIT FI
j == +1
OD
Fix_FlSp(wk_d)
ELSE
DO
i ==+1
IF c_line(i) = $9B THEN
eol_fl = 1 EXIT
ELSEIF c_line(i)=' THEN EXIT
FI
OD
FI
UNTIL eol_fl = 1 OR c_wds = 3 OD
RETURN
PROC Run_Ent()
; entry point for RUN dos command
r_ent = 1
PROC Main()
device = 0 ; suggested by ACS
Sys_Error = Error
Error = My_Error
Set_Defs()
; check if command line type DOS,
; and if filename on the command
; line
Get_wds()
DO
IF c_wds > 1 AND r_ent = 0 THEN
Show_Hdr()
ELSE Set_Vars()
FI
Alloc_Buffs()
Print_File()
Set_Defs()
IF c_wds > 1 THEN EXIT FI
OD
Close(2)
IF out_dev(1) = 'D THEN Clr_Dos(3)
ELSE Close(3) FI
RETURN