Jump to content
acadiel

Neat stuff from Falcor4's Hard drive image

Recommended Posts

I'll be putting tidbits from DC's HDD image (mostly BASIC programs or documents) in this thread as we find them. His whole drive dump, which Ksarul and I have, is 70 disks.

 

For the first one, here's a name that you all should know. Assembly Object to XB Call Load converter by Paolo Bagnaresi.

1 ! ACE : Assembly Object to   Extended Basic CALL LOADs    Converter      8/3/1984
2 !           By                   Paolo Bagnaresi            Tel.(02)-514.202      Address:
3 !  Via J.F. Kennedy 17      20097 San Donato Milanese        (Milan)- Italy
10 GOTO 40 :: DIM STDEF$(100) :: D$,N$,F$,DEF$,PB$,SC$,RI$,CT$,L$,HEX$,H$,DSC$,DECC$,PROG$
20 CALL LOAD :: CALL INIT :: CALL LINK :: CALL PEEK :: CALL CHAR :: CALL HCHAR :: CALL KEY
30 AUT,N,A,B,C,D,E,F,G,H,I,L,M,N,CT,MS,LS,DBM,DBL,FINELOC,LOC,INIZLOC,INDEF,NDEF,NLINK,NL,NLINE,NST,KY,ST,DEC,PO,Z
40 CALL CLEAR :: CALL SCREEN(16) :: FOR T=0 TO 14 :: CALL COLOR(T,13,16) :: NEXT T :: [email protected]
50 CALL CHAR(128,"00282828",131,"000000FF") :: L$=RPT$(CHR$(131),28) :: H$="0123456789ABCDEF" :: CALL CLEAR
60 PB$="By Paolo Bagnaresi             Via J..F.. Kennedy 17         20097 San Donato Milanese   (Milan)- ITALY"
70 DISPLAY AT(1,1):L$:L$: : TAB (13);"ACE": : TAB (14);"by": TAB (7);"Paolo Bagnaresi": TAB (7);"Tel(02)-514..202":"San Donato Milanese-ITALY":L$
80 DISPLAY AT(11,1): TAB (10);"Assembly": TAB (10);"Converter to": TAB (10);"Extended":L$
90 DISPLAY AT(14,1):L$:"ACE converts the Object":"of an Assembly Program into":"an Extended Basic Program..":"The Assembly Program MUST be"
100 DISPLAY AT(19,1):"suitable for Extended Basic":"environment and MUST NOT":"contain any AORG..":L$
110 DISPLAY AT(24,6) BEEP :"Press any key"
120 CALL KEY(0,KY,ST) :: IF ST=0 THEN 120 ELSE CALL CLEAR
130 DISPLAY AT(1,1):L$: TAB (5);"Are the Assembly":"Objects already loaded ?": :"  Answer: (Y/N) N":L$
140 ACCEPT AT(5,17) SIZE(-1) VALIDATE ("YN") BEEP :RI$ :: IF RI$="" THEN 50 ELSE IF RI$="Y" THEN CALL CLEAR :: GOTO 370 ELSE N$="1" :: CT$="Y" :: GOSUB 900
150 DISPLAY AT(6,1):L$:"Insert the diskette with the":"assembly object and enter":"the object progr.. name": :"Name :  ";PROG$:L$
160 DISPLAY AT(22,1):L$:"erase and press ENTER if you": TAB (9);"are through"
170 ACCEPT AT(11,9) SIZE(-10) BEEP :PROG$ :: IF PROG$="" THEN CALL CLEAR :: GOTO 320
180 DISPLAY AT(13,1):"Disk Drive ? (1-3) ";N$:L$ :: ACCEPT AT(13,20) SIZE(-1) VALIDATE ("123") BEEP :N$ :: IF N$="" THEN 130
190 ON ERROR 360 :: CALL LOAD("DSK"&N$&".."&PROG$) :: ON ERROR STOP
200 DISPLAY AT(15,1):"Do you want to check the":"loaded program ? (Y/N) ";CT$:L$ :: ACCEPT AT(16,24) SIZE(-1) VALIDATE ("YN") BEEP :CT$ :: IF CT$="N" THEN 150
210 DISPLAY AT(18,1):"Does the program come back":"to Extended Basic ? (Y/N) Y":L$ :: ACCEPT AT(19,27) SIZE(-1) VALIDATE ("YN") BEEP :SC$
220 IF SC$="Y" THEN 240 ELSE FOR T=1 TO 10 :: DISPLAY AT(21,1) BEEP :"In this case no check":"is possible ":L$:L$
230 FOR I=1 TO 100 :: NEXT I :: CALL HCHAR(21,1,32,96) :: NEXT T :: GOTO 150
240 CALL PEEK(8196,A,B) :: NST=0 :: INDEF=A*256+B :: FOR T=16376 TO INDEF STEP -8 :: NL=T :: GOSUB 870 :: NST=NST+1 :: STDEF$(NST)=DEF$ :: NEXT T
250 CALL CLEAR :: A=0 :: D$="1"
260 DISPLAY AT(1,1):L$:"List of DEFS to choose from":"for checking pourposes":L$
270 FOR T=5 TO 20 STEP 2 :: FOR Z=1 TO 19 STEP 9 :: A=A+1 :: DISPLAY AT(T,Z) BEEP :A;STDEF$(A) :: IF A>=NST THEN 280 ELSE NEXT Z :: NEXT T
280 DISPLAY AT(T+1,1):L$ :: DISPLAY AT(20,1):L$:"DEF No.. ? (1 -";NST;") ":L$:"Press ENTER when finished":L$ :: ACCEPT AT(21,21) VALIDATE (DIGIT) SIZE(-2) BEEP $ :: IF D$<>"" THEN 340
290 CALL CLEAR :: DISPLAY AT(1,1):L$:"Are the programs loaded": :"so far OK.. ? (Y/N) Y":L$ :: ACCEPT AT(4,20) VALIDATE ("YN") SIZE(-1) BEEP :SC$ :: IF SC$="Y" THEN 320
300 DISPLAY AT(6,1):L$:"Unfortunately in this case": :"it's not possible to": :"eliminate just one program": :"but it's necessary to load"
310 DISPLAY AT(15,1):"all the program(s) all ": :"over again..": :"OK? (Y) Y":L$ :: ACCEPT AT(19,9) VALIDATE ("Y") SIZE(-1) BEEP :SC$ :: CALL INIT :: CALL CLEAR :: GOTO 150
320 DISPLAY AT(6,1):L$:"Are all the programs": :"loaded already ? (Y/N) Y":L$ :: ACCEPT AT(9,24) VALIDATE ("YN") SIZE(-1) BEEP :SC$
330 IF SC$="N" OR SC$="" THEN CALL CLEAR :: GOTO 150 ELSE 370
340 A=VAL(D$) :: IF A>NST THEN 280 ELSE CALL LINK(STDEF$(A)) :: GOTO 250
350 ! Error handling
360 FOR T=1 TO 8 :: DISPLAY AT(20,1) BEEP :L$: TAB (6);"Drive error or": TAB (6);"Program name error":L$:L$ :: FOR I=1 TO 100 :: NEXT I :: CALL HCHAR(20,1,32,128) :: NEXT T :: RETURN 150
370 CALL CLEAR
380 ON ERROR 400 :: CALL PEEK(8194,A,B,C,D) :: FINELOC=A*256+B :: NL,INDEF=C*256+D :: GOSUB 870 :: IF ASC(DEF$)=255 THEN 400 ELSE INIZLOC=DBM*256+DBL
390 ON ERROR STOP :: GOTO 430
400 CALL CLEAR :: FOR I=1 TO 10 :: DISPLAY AT(10,1) BEEP :L$:L$:"  The Assembly Programs": :"   have not been loaded": : TAB (10);"LOAD THEM!":L$:L$
410 FOR T=1 TO 100 :: NEXT T :: CALL HCHAR(12,1,32,160) :: NEXT I :: GOSUB 900 :: GOTO 150
420 !Disk-printing routine
430 CALL CLEAR :: GOSUB 790 :: IF F$="" OR N$="" THEN 32767 :: ON ERROR 840 :: GOSUB 920 :: OPEN #2:"DSK"&N$&".."&F$,VARIABLE 163 :: ON ERROR STOP :: N=0
440 !Address of the programmer
450 PRINT #2:CHR$(0)&CHR$(N)&CHR$(131)&CHR$(199)&CHR$(LEN(PB$))&PB$&CHR$(0) :: N=1 :: GOSUB 940
460 !Insert CALL INIT
470 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"INIT"&CHR$(0) :: N=2 :: LOC=INDEF :: GOSUB 940
480 ! DEFs name printing
490 FOR NDEF=INDEF TO 16376 STEP 8
500 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"LOAD"&CHR$(183)&CHR$(200)&CHR$(LEN(STR$(NDEF)))&STR$(NDEF);
510 FOR LOC=NDEF TO NDEF+6 STEP 2
520 CALL PEEK(LOC,MS,LS) :: PRINT #2:CHR$(179)&CHR$(200)&CHR$(LEN(STR$(MS)))&STR$(MS)&CHR$(179)&CHR$(200)&CHR$(LEN(STR$(LS)))&STR$(LS);
530 NEXT LOC
540 PRINT #2:CHR$(182)&CHR$(0) :: GOSUB 940 :: N=N+1 :: NEXT NDEF
550 !Print DEF pointer and FFALM
560 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"LOAD"&CHR$(183)&CHR$(200)&CHR$(LEN(STR$(8194)))&STR$(8194);
570 FOR LOC=8194 TO 8196 STEP 2
580 CALL PEEK(LOC,MS,LS) :: PRINT #2:CHR$(179)&CHR$(200)&CHR$(LEN(STR$(MS)))&STR$(MS)&CHR$(179)&CHR$(200)&CHR$(LEN(STR$(LS)))&STR$(LS);
590 NEXT LOC
600 PRINT #2:CHR$(182)&CHR$(0) :: GOSUB 940 :: N=N+1 :: LOC=9460
610 ! Main program printing
620 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"LOAD"&CHR$(183)&CHR$(200)&CHR$(LEN(STR$(LOC)))&STR$(LOC);
630 FOR LOC=LOC TO LOC+20 STEP 2
640 IF LOC>FINELOC THEN 670 :: CALL PEEK(LOC,MS,LS) :: PRINT #2:CHR$(179)&CHR$(200)&CHR$(LEN(STR$(MS)))&STR$(MS)&CHR$(179)&CHR$(200)&CHR$(LEN(STR$(LS)))&STR$(LS);
650 NEXT LOC
660 PRINT #2:CHR$(182)&CHR$(0) :: GOSUB 940 :: N=N+1 :: IF LOC<=FINELOC THEN 620 ELSE 680
670 PRINT #2:CHR$(182)&CHR$(0) :: GOSUB 940
680 N=N+1
690 ! CALL LINK printing
700 FOR NLINK=INDEF TO 16376 STEP 8 :: NL=NLINK :: GOSUB 870
710 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"LINK"&CHR$(183)&CHR$(199)&CHR$(LEN(DEF$))&DEF$&CHR$(182)&CHR$(0) :: GOSUB 940
720 N=N+1 :: NEXT NLINK
730 PRINT #2:CHR$(255)&CHR$(255) :: CLOSE #2
740 CALL CLEAR :: DISPLAY AT(5,1) BEEP :L$:"The assembly program ";DEF$: :"has been recorded as a": :"DIS/VAR 163 file.. The name": :"of this file is ";F$:L$
750 DISPLAY AT(14,1):"You can MERGE this file": :"and obtain an Ext..B..Program":L$:"Execute now in command mode:": :">NEW":">MERGE DSK";N$;"..";F$
760 FOR T=1 TO 70 :: DISPLAY AT(23,1) BEEP :">SAVE DSK";N$;"..";SEG$(F$,1,LEN(F$)-3)&"EXT":L$ :: CALL KEY(0,KY,ST) :: IF ST<>0 THEN STOP
770 NEXT T :: END
780 ! Open file: disk drive & name selection
790 DISPLAY AT(1,1):L$:"Name of the last DEF":"of the  assembly programs": :"loaded in memory : ";DEF$:L$
800 F$=DEF$&"MRG" :: DISPLAY AT(8,1):L$:"proposed name for the file": :"Max 10 characters ";F$: :L$ :: ACCEPT AT(11,19) SIZE(-10) BEEP :F$
810 IF F$="" THEN RETURN ELSE IF POS(F$," ",1)>0 OR POS(F$,"..",1)>0 THEN 800
820 DISPLAY AT(14,1):L$:"Disk Drive? (1-3) ";N$:L$ :: ACCEPT AT(15,19) VALIDATE ("123") SIZE(-1) BEEP :N$ :: RETURN
830 ! Sub file error
840 ON ERROR 850 :: CLOSE #2
850 RETURN 430
860 ! call peek DEF names
870 CALL PEEK(NL,E,F,G,H,I,L,DBM,DBL) :: DEF$=CHR$(E)&CHR$(F)&CHR$(G)&CHR$(H)&CHR$(I)&CHR$(L)
880 PO=POS(DEF$," ",1) :: IF PO>0 THEN DEF$=SEG$(DEF$,1,PO-1) :: RETURN ELSE RETURN
890 ! Sub CALL INIT once only
900 IF CT=1 THEN RETURN ELSE CALL INIT :: CT=1 :: RETURN
910 ! Sub # of necessary printings
920 NLINE=ABS(INT(-((FINELOC-9460)/22+(16384-INDEF)/4+3))) :: DISPLAY AT(17,1) BEEP :"The necessary Printing":"operations with Disk Drive": :"(max 172) will be";NLINE:L$
930 IF NLINE>172 THEN FOR T=1 TO 10 :: FOR I=1 TO 90 :: NEXT I :: CALL HCHAR(23,1,32,32) :: DISPLAY AT(22,1) BEEP :L$:"OBJECT SIZE IS TOO  LARGE":L$ :: NEXT T :: STOP ELSE RETURN
940 NLINE=NLINE-1 :: DISPLAY AT(21,1):L$:"# of printings yet to be":"executed will be";NLINE:L$ :: RETURN

  • Like 2

Share this post


Link to post
Share on other sites

And another fun one. Typewriter by Extended Software Company.

100 CALL CLEAR :: CALL CHAR(127,"186699A1A1996618") !COPYRIGHT 1981,82,83 EXTENDED SOFTWARE CO.
110 DISPLAY AT(12,2):"Extended Software Company":" 11987 Cedarcreek Drive":" Cincinnati, Ohio 45240" :: DISPLAY AT(23,2):". 1981 VERSION 3..6" :: C$="TYPWRITER"
114 FOR A=28 TO 11 STEP -1 :: B=B+1 :: CALL SOUND(-9,-5,5) :: DISPLAY AT(8,A):SEG$(C$,1,B) :: NEXT A :: !CALL INIT :: CALL LOAD(-31878):: NL=280 :: DIM A$(286)
120 !CALL INIT :: CALL LOAD(-31878):: NL=280 :: DIM A$(286)
122 NL=120 :: DIM A$(126)
130 CALL KEY(5,K,E) :: FOR Z=97 TO 131 :: READ Z$ :: IF Z<123 THEN CALL CHAR(Z,"0000"&Z$) ELSE M$(Z-122)=Z$
150 NEXT Z :: F$=RPT$(" ",150) :: @,G0,G1,G2=1 :: G3=10 :: G4,G5=60 :: @2=2 :: @3=3 :: @4=4 :: @5=5 :: @6=6 :: @9=9 :: @A=21 :: @B=200 :: @0=20 :: FOR [email protected] TO 12 :: CALL COLOR(R,@2, :: NEXT R
180 ON BREAK NEXT :: GOTO 500 :: CALL SCREEN :: CALL GCHAR :: CALL HCHAR :: CALL VCHAR :: CALL ERR
190 B$(@),D$,E$,G$,H$,I$,N$,P$,Q$,R$,S$,T$,W$,Z$="" :: _,C,D,F,G,H,I,J,L,M,N,O,P,Q,S,T,U,V,W,X=Y :: CO,D1,D2,L1,L3,LP,P1,P3,QQ,ST,SW=ZL
210 [email protected]
500 CALL CLEAR :: CALL SCREEN(@5) :: ON ERROR 11000
510 DISPLAY AT(@3,@9):"TYPWRITER": : : TAB (@9);"MAIN MENU" :: FOR [email protected] TO @6 :: DISPLAY AT(R+8,@):CHR$(R+48);"=";M$(R) :: NEXT R :: DISPLAY AT(18,@):"CHOICE?" :: R=18 :: N=6 :: GOSUB 10300 :: CALL CLEAR :: M=I :: DISPLAY AT(@,15):M$(M)
550 ON M GOTO 1000,2000,3000,4000,5000,7000
1000 [email protected] :: GOSUB 10000 :: DISPLAY AT(@5,@):"CLEARING MEMORY..": : : :: FOR [email protected] TO NL :: A$(L)="" :: NEXT L :: U,L=_ :: G$="" :: DISPLAY AT(@5,@):""
1020 [email protected]
1030 CALL SCREEN(@6) :: DISPLAY AT(@,@):M$(;INT(L/@0)[email protected],M$(@) :: FOR D=D TO @A :: [email protected] :: DISPLAY AT(D,@):;:"^^^^^^^^^^^^^^^^^^^^^^^^^^^^" :: ACCEPT AT(D,@):A$(U)
1070 CALL KEY(_,K,E) :: IF A$(U)="" THEN [email protected] :: IF K=11 THEN 8000 ELSE 500
1110 NEXT D :: IF U>[email protected] THEN V=7 :: GOSUB 10000 :: GOTO 4000 ELSE DISPLAY AT(22,@):"" :: L=L+20 :: GOTO 1020
2000 G=_ :: CALL SCREEN(7) :: [email protected] :: GOSUB 10000 :: T$=M$(@2) :: IF G$="" THEN N$="CS1" ELSE N$=G$
2020 GOSUB 10200 :: G$=N$
2100 OPEN #@:G$,INPUT,INTERNAL,FIXED 192 :: FOR [email protected] TO NL STEP @6 :: INPUT #@:A$(L),A$([email protected]),A$([email protected]),A$([email protected]),A$([email protected]),A$([email protected]) :: CALL KEY(_,K,E) :: IF K=13 OR A$(L)=M$(@9) THEN 2170
2150 S=INT(([email protected])/[email protected]) :: DISPLAY AT(23,@):"S=";S;"L=";([email protected])-20*([email protected]) :: NEXT L
2170 FOR L=MIN(NL,[email protected]) TO @ STEP [email protected] :: IF A$(L)<>"" AND A$(L)<>M$(@9) THEN U=L :: GOTO 2190
2180 NEXT L
2190 FOR [email protected] TO NL :: A$(R)="" :: NEXT R :: CLOSE #@
2200 IF [email protected] THEN CALL SCREEN(2) :: [email protected] :: GOTO 5140 ELSE 500
3000 [email protected] :: CALL SCREEN(@5) :: DISPLAY AT(@,@):"STARTING AT SCREEN#:" :: [email protected] :: C=24 :: N=9 :: GOSUB 10310 :: [email protected]*([email protected]) :: IF L>=U THEN 3000 ELSE CALL CLEAR :: DISPLAY AT(@,15):M$(@3) :: GOTO 8500
3010 GOSUB 10010 :: IF K>15 THEN 8500 ELSE 8000
4000 CALL SCREEN(13) :: T$=M$(4) :: IF G$="" THEN IF E$<>"" THEN N$=E$ ELSE N$="CS1" ELSE N$=G$
4010 GOSUB 10200 :: E$=N$ :: OPEN #@:E$,OUTPUT,INTERNAL,FIXED 192 :: FOR [email protected] TO U STEP @6 :: CALL KEY(_,K,E) :: IF K=13 OR A$(L)="" THEN 4200
4150 PRINT #@:A$(L),A$([email protected]),A$([email protected]),A$([email protected]),A$([email protected]),A$([email protected]) :: S=INT(([email protected])/@[email protected]) :: DISPLAY AT(23,@):"S=";S;"L=";[email protected]@0*([email protected]),L;"OF";U :: NEXT L
4200 PRINT #@:M$(@9),M$(@9),M$(@9),M$(@9),M$(@9),M$(@9) :: CLOSE #@ :: GOTO 500
5000 CALL SCREEN(@2) :: SW,G,O,L3,B=_ :: R$="N" :: C$,D$="" :: IF [email protected] THEN F=_ :: CLOSE #F
5010 DISPLAY AT(@5,@):"WHAT TYPE PRINTER?":"1=RS232,PIO OR TP":"2=SCREEN":"3=FORMAT FOR TI-WRITER":;:;:"CHOICE? ";G0
5020 R=11 :: C=10 :: [email protected] :: GOSUB 5307 :: G0=I :: IF [email protected] THEN [email protected] :: [email protected] ELSE IF [email protected] THEN F=_ :: GOTO 5050 ELSE [email protected] :: IF P$="" THEN N$="RS232" ELSE N$=P$
5040 T$=M$(@5) :: GOSUB 10200 :: P$=N$
5050 DISPLAY AT(@5,@):;:;:;:"BEGIN AT SCREEN #:";G1:"LINE #:";G2 :: DISPLAY AT(10,@):"# OF SPACES IN MARGIN:";G3:"# OF CHARACTERS/LINE:";G4:"# OF LINES/PAGE:";G5
5070 R=8 :: C=20 :: [email protected] :: GOSUB 5307 :: IF I>@6 THEN 5070 ELSE G1,S=I
5075 [email protected] :: [email protected] :: GOSUB 5307 :: IF I>@0 THEN 5075 ELSE G2=I :: [email protected]*([email protected])
5080 R=10 :: C=24 :: GOSUB 5307 :: IF I>79 THEN 5080 ELSE G3,A=I
5085 R=11 :: C=23 :: [email protected] :: GOSUB 5307 :: IF I>227 THEN 5085 ELSE G4,Z=I
5087 R=12 :: C=18 :: GOSUB 5307 :: G5,LP=I :: DISPLAY AT(@,15):M$(@5) :: IF [email protected] THEN IF G=_ AND POS(SEG$(P$,@,@3),"TP",@)=_ THEN OPEN #F:P$,VARIABLE 254,OUTPUT ELSE OPEN #F:P$,OUTPUT
5140 DISPLAY AT(@0,@):M$(@9):">HOLD DOWN SPACE BAR TO HALT":G$:;:
5150 FOR L=L TO U :: CALL KEY(0,K,E) :: IF A$(L)="" OR ([email protected] AND K=13) THEN 5310 ELSE IF K=32 THEN 5308
5160 S$=A$(L) :: S=INT(([email protected])/@[email protected]) :: DISPLAY AT(@,@):,M$(M):"S=";S;"L=";[email protected]*([email protected]),L;"OF";U
5170 IF SEG$(S$,@,@)="@" THEN 5360
5230 IF [email protected] THEN C$=C$&S$ ELSE IF [email protected] OR C$="" THEN C$=C$&S$ :: O=_ ELSE C$=C$&" "&S$
5240 IF LEN(C$)>[email protected] THEN GOSUB 5260
5250 NEXT L :: GOTO 5310
5260 FOR [email protected] TO @ STEP [email protected] :: P=POS(C$," ",J) :: IF P>_ AND P<[email protected] THEN 5290
5270 NEXT J :: P=Z :: GOTO 5290
5280 IF C$="" THEN RETURN ELSE IF LEN(C$)>Z THEN 5260 ELSE P=LEN(C$)[email protected] :: [email protected]
5290 D$=SEG$(F$,@,A+B)&SEG$(C$,@,[email protected]) :: IF SW=_ AND R$="Y" THEN [email protected] :: GOSUB 32000
5292 PRINT #F:D$ :: C$=SEG$(C$,[email protected],254) :: SW=_
5300 [email protected] :: IF LEN(C$)>Z THEN 5280 ELSE IF F<>_ THEN DISPLAY AT(12,17):L3;"OF";LP
5302 IF L3>=LP THEN L3=_ :: GOSUB 10010
5305 RETURN
5307 ACCEPT AT(R,C) VALIDATE (DIGIT) SIZE(-N) BEEP :I$ :: IF I$="" THEN F=_ :: GOTO 500 ELSE I=VAL(I$) :: RETURN
5308 CALL KEY(_,K,E) :: DISPLAY AT(24,1):"HALTED - PRESS 'C' TO CONT.." :: IF E=1 THEN DISPLAY AT(24,1) :: GOTO 5150 ELSE 5308
5310 GOSUB 5280 :: IF [email protected] THEN F=_ :: CLOSE #@2
5320 GOTO 500
5360 W$=SEG$(S$,@2,@) :: W=POS("LPTCMNSAOJUD",W$,@) :: ON W GOTO 5400,5440,5460,5480,5490,5500,5510,5520,5530,5540,5560,5570
5400 GOSUB 5280 :: PRINT #F:"" :: GOSUB 5300 :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5440 H$=SEG$(S$,@4,@B) :: DISPLAY AT(14,@):H$ :: ACCEPT AT(15,@) BEEP :S$ :: GOTO 5170
5460 Y=VAL(SEG$(S$,@3,@3))[email protected] :: IF O=_ THEN [email protected]
5465 IF LEN(C$)<=Y THEN C$=C$&SEG$(F$,@,Y-LEN(C$)) ELSE GOSUB 5280 :: C$=SEG$(F$,@,Y)
5470 S$=SEG$(S$,7,@B) :: GOTO 5170
5480 C$=SEG$(F$,@,INT((Z-LEN(C$)[email protected])/@2))&C$ :: GOSUB 5280 :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5490 GOSUB 5280 :: B=VAL(SEG$(S$,@3,@2)) :: Z=VAL(SEG$(S$,@6,@3)) :: S$=SEG$(S$,10,@B) :: GOTO 5170
5500 GOSUB 5280 :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5510 Y=VAL(SEG$(S$,@3,@3)) :: C$=C$&CHR$(Y) :: S$=SEG$(S$,7,@B) :: GOTO 5170
5520 N$=SEG$(S$,@4,@B) :: [email protected] :: IF N$="R" THEN 2200 ELSE G$=N$ :: GOTO 2100
5530 [email protected] :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5540 S$=SEG$(S$,@4,@B) :: IF R$="Y" THEN R$="N" ELSE R$="Y"
5550 GOTO 5170
5560 PRINT #F:SEG$(F$,@,A+B)&C$&CHR$(13); :: C$="" :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5570 S$=SEG$(S$,@4,@B) :: IF [email protected] THEN O=_ ELSE [email protected]
5580 GOTO 5170
7000 V,X=6 :: GOSUB 10000 :: END
8000 CALL SCREEN(10) :: DISPLAY AT(@,15):"EDIT MODE" :: DISPLAY AT(23,@2):"""BEGIN""";" TO CONTINUE TEXT" :: IF A$([email protected])="" THEN 8450
8010 CALL HCHAR(D,@2,30) :: CALL KEY(_,K,E) :: CALL VCHAR(@2,@2,32,@0) :: IF K<@3 OR K>15 THEN 8010
8020 ON [email protected] GOTO 8200,8010,8010,8300,8010,8800,8400,8450,8500,500,8700,8600
8200 [email protected] :: CALL CLEAR :: [email protected] :: ZL=L :: DISPLAY AT(@,14):"INSERT MODE" :: FOR [email protected] TO @5 :: DISPLAY AT(16+I,@):A$(Z+I) :: IF ([email protected]+I)>_ THEN DISPLAY AT([email protected],@):A$([email protected]+I)
8220 NEXT I :: FOR [email protected] TO MIN(10,NL-U) :: ACCEPT AT([email protected],@) SIZE(-28):B$(I) :: CALL KEY(_,K,E) :: IF B$(I)="" AND K<>10 THEN 8270
8260 NEXT I
8270 [email protected] :: FOR L=U+I TO Z+I STEP [email protected] :: IF L-I<@ THEN 8290
8280 A$(L)=A$(L-I) :: NEXT L
8290 FOR [email protected] TO I :: A$(J+Z)=B$(J) :: B$(J)="" :: NEXT J :: L=ZL :: U=U+I :: DISPLAY AT(@,@):M$(,M$(@2) :: GOSUB 10090 :: GOTO 8010
8300 Z=L :: [email protected] :: FOR [email protected] TO [email protected] :: A$(L)=A$([email protected]) :: NEXT L :: L=Z :: GOSUB 10090 :: GOTO 8010
8400 IF A$(L+D)<>"" AND D<@A THEN [email protected] :: CALL HCHAR(D,@2,30) :: CALL KEY(_,K,E) :: CALL VCHAR(@2,@2,32,@0) :: IF K=10 THEN 8400 ELSE IF K=11 THEN 8450 ELSE 8010 ELSE IF [email protected] THEN 8500 ELSE 8010
8450 IF D>@2 THEN [email protected] :: CALL HCHAR(D,@2,30) :: CALL KEY(_,K,E) :: CALL VCHAR(@2,@2,32,@0) :: IF K=11 THEN 8450 ELSE IF K=10 THEN 8400 ELSE 8010 ELSE 8600
8500 [email protected] :: IF L+40<U THEN [email protected] :: GOSUB 10090 ELSE 8530
8510 IF K>15 THEN 3010 ELSE 8010
8530 IF [email protected]<U THEN [email protected] :: [email protected] :: GOSUB 10100
8540 IF K>15 THEN 8700 ELSE 8010
8600 [email protected] :: IF INT(L/@0)>_ THEN [email protected] :: GOSUB 10090 ELSE [email protected]
8610 GOTO 8010
8700 L1=INT(U/@0)*@0 :: D,[email protected] :: IF L<INT(U/@0)*[email protected] THEN [email protected]
8710 L=L1 :: GOSUB 10100 :: DISPLAY AT(22,@):;:;:;: :: GOTO 1030
8800 [email protected] :: ACCEPT AT(D,@) SIZE(-28):A$(L1) :: GOTO 8400
10000 CALL CLEAR :: CALL SCREEN(7) :: DISPLAY AT(2,@):">>>>>>"&M$(V)&"<<<<<":;:;:"CAUTION!":"ANY DOCUMENT IN CONSOLE":"WILL BE ERASED!"
10010 DISPLAY AT(23,@) BEEP :" PRESS ANY KEY TO CONTINUE   OR 'ENTER' FOR MAIN MENU"
10020 CALL KEY(_,K,E) :: IF E<>@ THEN 10020 ELSE IF K=13 THEN 500 ELSE DISPLAY AT(22,1):;:;:;:
10030 [email protected] :: RETURN
10090 [email protected]
10100 DISPLAY AT(@,@) SIZE(10):M$(;INT(L/@0)[email protected] :: FOR [email protected] TO D2 :: DISPLAY AT(D1,@):A$([email protected]) :: NEXT D1 :: RETURN
10200 DISPLAY AT(@5,@):"ENTER NULL FOR MAIN MENU":;:;:;:;:;:;: :: DISPLAY AT(17,@):"OPEN #1:":N$:;:;:"ENTER DEVICE OPEN STATEMENT (CS1, DSK1..FILENAME, TP..E,  RS232..BA=600..EC, ETC..)"
10208 ACCEPT AT(18,@) SIZE(-28) BEEP :N$ :: IF N$="" THEN 500
10220 DISPLAY AT(@5,@):"" :: DISPLAY AT(@0,@):;:M$(@9):;:;:; :: RETURN
10300 DISPLAY AT(R,@):"CHOICE?" :: C=11
10310 CALL SOUND(100,1569,_) :: CALL GCHAR(R,C,Q)
10320 CALL HCHAR(R,C,30) :: CALL KEY(_,K,E) :: CALL HCHAR(R,C,Q) :: IF E<>@ THEN 10320
10330 CALL HCHAR(R,C,K) :: IF K=13 THEN 500 ELSE I=K-48 :: IF I<@ OR I>N THEN 10300 ELSE RETURN
11000 CALL ERR(CO,Z,Z,Z) :: ON ERROR 11000
11010 DISPLAY AT(11,@): :"CODE=";CO:"SEE X-BASIC MANUAL, PAGE 217WE HAVE JUST ENCOUNTERED AN ERROR.. ": : :: INPUT "'ENTER' TO CONTINUE ":Q$ :: ON ERROR 11060 :: CLOSE #@
11060 ON ERROR 11065 :: F=_ :: CLOSE #@2
11065 ON ERROR 11070 :: CLOSE #@B
11070 ON ERROR 11000 :: RETURN 500
12990 [email protected]+
13000 DATA 000038484834,40407048483,000038404038,080838484834,0018243C2018,18282038202,38484838083
13010 DATA 202038242424,100030101038,10003010507,404050605048,301010101038,00006C545454,000078484848
13020 DATA 00003048483,70584870404,384848380808,00002830202,00182038083,101038101018,000048484834
13030 DATA 00002424281,000044545428,000028102828,00484830102,000038102038
13040 DATA DOCUMENT Mode,INPUT Document,CONTINUE Mode,SAVE Document,PRINT Document,LEAVE Program
13050 DATA MEMORY NEAR FULL,SCREEN#:,>HOLD DOWN 'ENTER' TO STOP<
32000 IF SEG$(D$,A+B+P1,@)=" " THEN [email protected] :: GOTO 32000 ELSE P3=P1+A+B :: IF POS(D$," ",P3)=_ THEN RETURN
32010 IF LEN(D$)>=A+B+Z THEN RETURN ELSE P3=POS(D$," ",[email protected]) :: IF P3=_ THEN 32000
32020 D$=SEG$(D$,@,P3)&" "&SEG$(D$,[email protected],LEN(D$)) :: GOTO 32010

  • Like 3

Share this post


Link to post
Share on other sites

Pascal Directory from Extended Basic (P-Code?) by P.E. Schippnick

100 REM 8410110156
110 REM PASCAL DIRECTORY    FROM EXTENDED BASIC *V2.0*
120 REM BY P.E.SCHIPPNICK              POMONA, CA 91766            (714) 629-8956
130 ON ERROR 1080
140 CALL CHARPAT(76,A$) :: IF SEG$(A$,15,2)="00" THEN GOSUB 1270
150 DEVICE$="PIO"
160 CALL CLEAR
170 DISPLAY AT(12,7):"PASCAL DIRECTORY"
180 OPEN #1:"DSK1..",INPUT,RELATIVE,INTERNAL
190 INPUT #1:DISKNAME$,[1,[2,[3
200 IF [3<>0 THEN 240
210 INPUT #1:FILENAME$,[4,[5,[6
220 IF FILENAME$<>"PASCAL" OR [4<>1 OR [6<>128 THEN 240
230 CLOSE #1 :: GOTO 260
240 CLOSE #1 :: GOSUB 1170
250 GOTO 160
260 OPEN #1:"DSK1..PASCAL",INPUT,DISPLAY,FIXED 128,RELATIVE
270 INPUT "WANT A PRINTOUT? ":I$ :: IF I$="Y" OR I$="y" OR I$="YES" OR I$="yes" OR I$="Yes" THEN F=1
280 IF F=1 THEN PRINT "OUTPUT DEVICE? "&DEVICE$
290 IF F=1 THEN ACCEPT AT(23,16) SIZE(-32) BEEP :DEVICE$
300 IF DEVICE$="" THEN F=0
310 CALL CLEAR
320 IF F=1 THEN OPEN #2:DEVICE$
330 CALL CLEAR
340 IF F=1 THEN IF DEVICE$="TP" THEN F=0 :: Q=2
350 I=1 :: DIM [$(7),DIRECORD$(76),TYPE$(7),MONTH$(11)
360 MONTH$(0)="JAN" :: MONTH$(1)="FEB" :: MONTH$(2)="MAR" :: MONTH$(3)="APR" :: MONTH$(4)="MAY" :: MONTH$(5)="JUN" :: MONTH$(6)="JUL" :: MONTH$(7)="AUG"
370 MONTH$(="SEP" :: MONTH$(9)="OCT" :: MONTH$(10)="NOV" :: MONTH$(11)="DEC"
380 TYPE$(1)="bad" :: TYPE$(2)="code" :: TYPE$(3)="text" :: TYPE$(4)="info" :: TYPE$(5)="data" :: TYPE$(6)="graf" :: TYPE$(7)="foto"
390 A=([5-31)*2 :: LINPUT #1,REC A:[$(0)
400 LINPUT #1:[$(1)
410 LINPUT #1:[$(2)
420 LINPUT #1:[$(3)
430 LINPUT #1:[$(4)
440 LINPUT #1:[$(5)
450 LINPUT #1:[$(6)
460 LINPUT #1:[$(7)
470 USED=ASC(SEG$([$(0),4,1))
480 LAST=USED
490 BLOCKS=ASC(SEG$([$(0),15,1))*256+ASC(SEG$([$(0),16,1))
500 NUMREC=ASC(SEG$([$(0),18,1))
510 DIR$=SEG$([$(0),27,102)
520 FOR DIRLIST=0 TO NUMREC-1
530 DIRECORD$(DIRLIST)=SEG$(DIR$,1,26)
540 DIR$=SEG$(DIR$,27,255)
550 IF I=8 THEN 570
560 IF LEN(DIR$)<128 THEN DIR$=DIR$&[$(I) :: I=I+1
570 NEXT DIRLIST
580 REM
590 PRINT #Q: TAB (7);"PASCAL DIRECTORY": :
600 IF F=1 THEN PRINT #2: TAB (17);"PASCAL DIRECTORY": :
610 PRINT #Q:"VOLUME: ";SEG$([$(0),8,ASC(SEG$([$(0),7,1)))
620 IF F=1 THEN PRINT #2:"VOLUME: ";SEG$([$(0),8,ASC(SEG$([$(0),7,1)))
630 PRINT #Q:"filename"; TAB (16);"size"; TAB (21);"blk"; TAB (25);"type"
640 IF F=1 THEN PRINT #2:"filename"; TAB (18);"size"; TAB (27);"date"; TAB (36);"block"; TAB (42);"type"
650 FOR DIRLIST=0 TO NUMREC-1
660 YEAR=INT(ASC(SEG$(DIRECORD$(DIRLIST),25,1))/2)
670 YEAR$=SEG$("0"&STR$(YEAR),LEN(STR$(YEAR)),2)
680 DAY=INT(ASC(SEG$(DIRECORD$(DIRLIST),26,1))/16)+(ASC(SEG$(DIRECORD$(DIRLIST),25,1))-2*YEAR)*16
690 DAY$=SEG$("0"&STR$(DAY),LEN(STR$(DAY)),2)
700 MONTH=ASC(SEG$(DIRECORD$(DIRLIST),26,1))-INT(ASC(SEG$(DIRECORD$(DIRLIST),26,1))/16)*16
710 FIRST=ASC(DIRECORD$(DIRLIST))*256+ASC(SEG$(DIRECORD$(DIRLIST),2,1))
720 IF FIRST>LAST THEN GOSUB 1010
730 FIRST$=SEG$("  "&STR$(FIRST),LEN(STR$(FIRST)),3)
740 LAST=ASC(SEG$(DIRECORD$(DIRLIST),3,1))*256+ASC(SEG$(DIRECORD$(DIRLIST),4,1))
750 FILELEN=LAST-FIRST
760 USED=USED+FILELEN
770 FILELEN$=SEG$("  "&STR$(FILELEN),LEN(STR$(FILELEN)),3)
780 TYPE=ASC(SEG$(DIRECORD$(DIRLIST),6,1))
790 NAMELEN=ASC(SEG$(DIRECORD$(DIRLIST),7,1))
800 PRINT #Q:SEG$(DIRECORD$(DIRLIST),8,NAMELEN); TAB (17);FILELEN$; TAB (21);FIRST$; TAB (25);TYPE$(TYPE)
810 IF F=1 THEN PRINT #2:SEG$(DIRECORD$(DIRLIST),8,NAMELEN); TAB (19);FILELEN$; TAB (25);DAY$&"-"&MONTH$(MONTH-1)&"-"&YEAR$; TAB (37);FIRST$; TAB (42);TYPE$(TYPE)&"file"
820 CALL KEY(0,KEY,STATUS) :: IF STATUS<>0 THEN GOSUB 990
830 NEXT DIRLIST
840 FILELEN=BLOCKS-LAST
850 FILELEN$=SEG$("  "&STR$(FILELEN),LEN(STR$(FILELEN)),3)
860 FIRST$=SEG$("  "&STR$(LAST),LEN(STR$(LAST)),3)
870 PRINT #Q:"< unused >"; TAB (17);FILELEN$; TAB (21);FIRST$
880 IF F=1 THEN PRINT #2:"< unused >"; TAB (19);FILELEN$; TAB (25);"         "; TAB (37);FIRST$
890 PRINT #Q: :: IF F=1 THEN PRINT #2:
900 PRINT #Q:"Blocks free:";BLOCKS-USED
910 IF F=1 THEN PRINT #2:"Blocks free:";BLOCKS-USED
920 PRINT #Q: :: IF F=1 THEN PRINT #2:
930 PRINT "press any key to continue   press Q to quit"
940 CALL KEY(0,KEY,STATUS) :: IF STATUS=0 THEN 940
950 CLOSE #1 :: IF F=1 THEN CLOSE #2 :: F=0
960 IF Q=2 THEN CLOSE #2 :: Q=0
970 IF KEY<>81 AND KEY<>112 THEN 160
980 END
990 CALL KEY(0,KEY,STATUS) :: IF STATUS<1 THEN 990
1000 RETURN
1010 IF LAST=0 THEN RETURN
1020 FILELEN=FIRST-LAST
1030 FILELEN$=SEG$("  "&STR$(FILELEN),LEN(STR$(FILELEN)),3)
1040 FIRST$=SEG$("  "&STR$(LAST),LEN(STR$(LAST)),3)
1050 PRINT #Q:"< unused >"; TAB (17);FILELEN$; TAB (21);FIRST$
1060 IF F=1 THEN PRINT #2:"< unused >"; TAB (19);FILELEN$; TAB (25);"         "; TAB (37);FIRST$
1070 RETURN
1080 CALL ERR(CODE,TYPE,SEVERITY,LINE)
1090 ON ERROR 1080
1100 IF LINE=180 OR LINE=260 THEN 1170
1110 IF LINE>=390 AND LINE<=460 OR LINE=190 OR LINE=210 THEN ERR=1 :: GOTO 1170
1120 IF LINE=320 THEN 1220
1130 CALL SOUND(300,150,0)
1140 PRINT "ERROR #"&STR$(CODE)&" IN LINE";LINE
1150 PRINT "see APPENDIX 'N' page 217"
1160 STOP
1170 PRINT "Please insert PASCAL disk   in DRIVE 1"
1180 PRINT "press any key to continue"
1190 CALL KEY(0,KEY,STATUS) :: IF STATUS=0 THEN 1190
1200 IF ERR=1 THEN RUN
1210 RETURN
1220 PRINT "Please re-enter"
1230 PRINT "OUTPUT DEVICE? "
1240 ACCEPT AT(23,16) BEEP :DEVICE$
1250 IF DEVICE$="" THEN RUN
1260 RETURN
1270 FOR J=65 TO 90 :: CALL CHARPAT(J,A$) :: A$="0000"&SEG$(A$,1,4)&SEG$(A$,7,4)&SEG$(A$,13,4) :: CALL CHAR(J+32,A$) :: NEXT J
1280 RETURN

  • Like 3

Share this post


Link to post
Share on other sites

That last one looks like it is taking the directory data from a UCSD p-System disk and parsing it out to view it in Extended BASIC. I think I've seen mention of this program before, in an old issue of the USUS Newsletter. . .

  • Like 2

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...