Skip to content

Commit 62e4d24

Browse files
gitosaurusgitosaurus
committed
Initial commit of Turbo Pascal source code
0 parents  commit 62e4d24

27 files changed

+8541
-0
lines changed

‎ARCHSYS.PAS

Lines changed: 1004 additions & 0 deletions
Large diffs are not rendered by default.

‎CREATE.PAS

Lines changed: 128 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,128 @@
1+
{ CREATE.PAS
2+
3+
The translator for an Archetype program.
4+
5+
Usage:
6+
CREATE [(/E=(None|Simple|Complex) | /D )] [/K] [/A] source-code [/O=binary-code]
7+
8+
}
9+
10+
program create(input, output);
11+
12+
uses
13+
misc, crypt, id_table, semantic, syntax;
14+
15+
var
16+
17+
name, infile, outfile : string;
18+
19+
option : string;
20+
i, j : integer;
21+
f : progfile; { dummy progfile to help out classify_as }
22+
f_out : file; { pointer to .ACX file }
23+
24+
begin
25+
26+
writeln(VERSION);
27+
28+
name := ''; infile := ''; outfile := '';
29+
if ParamCount = 0 then begin
30+
writeln('Copyright 1995 Derek T. Jones');
31+
writeln;
32+
writeln('Usage:');
33+
writeln('CREATE [(/E=(N|S|D|C) | /D)] [/K] [/A] source-code [/O=binary-code]');
34+
writeln;
35+
writeln('/E=encryption None(default), Simple, Dynamic, or Complex');
36+
writeln('/D add Debugging information');
37+
writeln('/K insist on Keywords being declared');
38+
writeln('/A report All errors (until fatal syntax error encountered)');
39+
writeln('/O=.ACX file name (source-code.ACX by default)');
40+
halt
41+
end;
42+
43+
for i := 1 to ParamCount do begin
44+
option := ParamStr(i);
45+
for j := 1 to length(option) do option[j] := upcase(option[j]);
46+
if option[1] <> '/' then begin
47+
if name = '' then
48+
name := option
49+
else
50+
writeln('Cannot specify more than one input file - ignoring others')
51+
end
52+
else if option[2] in ['E', 'O'] then begin
53+
if option[3] <> '=' then
54+
writeln('"', option[2], '" must have "=" followed by value')
55+
else
56+
case option[2] of
57+
'O' : outfile := DOSname(Copy(option, 4, length(option)),
58+
'ACX', FALSE);
59+
'E' :
60+
case option[4] of
61+
'N' : Encryption := NONE;
62+
'S' : Encryption := SIMPLE;
63+
'D' : Encryption := PURPLE;
64+
'C' : Encryption := COMPLEX;
65+
else
66+
writeln('Unrecognized encryption "', option[4], '"');
67+
end
68+
end
69+
end
70+
else
71+
case option[2] of
72+
'D' : Encryption := DEBUGGING_ON;
73+
'K' : DefaultClassification := UNDEFINED_ID;
74+
'A' : AllErrors := TRUE;
75+
else
76+
writeln('Unrecognized option ''/', option[2], '''');
77+
end
78+
end; { Parameter loop }
79+
80+
{ Use the pathname of the CREATE program as the location of include
81+
files not located in the current directory. Need to back up to
82+
the last slash. }
83+
IncludePath := ParamStr(0);
84+
i := length(IncludePath);
85+
while (i > 0) and not (IncludePath[i] in ['\', '/', ':']) do dec(i);
86+
if i <= 0 then
87+
IncludePath := ''
88+
else
89+
IncludePath := Copy(IncludePath, 1, i);
90+
91+
if infile = '' then infile := DOSname(name, 'ACH', FALSE);
92+
if outfile = '' then outfile := DOSname(name, 'ACX', TRUE);
93+
94+
{ Set up the special "system" and "main" identifiers }
95+
name := 'system';
96+
if not ((add_ident(name) = 1) and
97+
(classify_as(f, 1, OBJECT_ID, nil) = 0)) then begin
98+
writeln('Internal error: cannot initialize identifier table');
99+
halt
100+
end;
101+
102+
name := 'main';
103+
if not (add_ident(name) = 2) then begin
104+
writeln('Internal error: cannot initialize identifier table');
105+
halt
106+
end;
107+
108+
writeln('Translating ', infile, ' to ', outfile, ' :');
109+
if not syntax_stream(infile, FALSE) then
110+
writeln('Could not translate ', infile)
111+
else begin
112+
write('Writing ', outfile);
113+
case Encryption of
114+
SIMPLE:
115+
write(' using simple encryption');
116+
PURPLE:
117+
write(' using self-referential (dynamic) encryption');
118+
COMPLEX:
119+
write(' using pseudorandom (complex) encryption');
120+
end; { case }
121+
writeln;
122+
if not dump_game(outfile) then
123+
writeln('Could not write ', outfile)
124+
else
125+
writeln(infile, ' translated successfully.')
126+
end
127+
128+
end.

‎CRYPT.PAS

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
unit crypt;
2+
3+
interface
4+
5+
type
6+
encryption_type = (NONE,
7+
SIMPLE,
8+
PURPLE, UNPURPLE,
9+
COMPLEX,
10+
DEBUGGING_ON);
11+
12+
var
13+
CryptMask : byte;
14+
Encryption : encryption_type;
15+
16+
procedure cryptinit(crypt_kind : encryption_type; seed : longint);
17+
procedure cryptstr(var s : string);
18+
19+
implementation
20+
21+
22+
procedure cryptinit(crypt_kind : encryption_type; seed : longint);
23+
24+
begin
25+
26+
CryptMask := seed AND $FF;
27+
Encryption := crypt_kind;
28+
if Encryption = COMPLEX then RandSeed := seed
29+
30+
end; { cryptinit }
31+
32+
33+
34+
{ cryptstr
35+
36+
Description:
37+
Encrypts or decrypts a string. Since all encryption methods are based
38+
on XOR, the same method both encrypts and decrypts.
39+
If <method> is SIMPLE, the CryptMask is simply XORed with each byte in
40+
the string.
41+
If <method> is PURPLE, the CryptMask is changed each time after using it,
42+
by adding to it the lowest three bits of the result of the last encrypted
43+
byte. This way the mask changes frequently and dynamically in a way that
44+
is difficult to predict.
45+
If <method> is UNPURPLE, the same algorithm as PURPLE is used except that
46+
the next CryptMask must be determined before altering the byte under
47+
consideration.
48+
if <method> is COMPLEX, a pseudorandom sequence is used to alter the
49+
CryptMask. This can make prediction well-nigh impossible.
50+
51+
}
52+
53+
procedure cryptstr(var s : string);
54+
55+
var
56+
nextmask : byte;
57+
i : integer;
58+
59+
begin
60+
61+
case Encryption of
62+
SIMPLE :
63+
for i := 1 to length(s) do
64+
s[i] := chr(ord(s[i]) XOR CryptMask);
65+
PURPLE:
66+
for i := 1 to length(s) do begin
67+
s[i] := chr(ord(s[i]) XOR CryptMask);
68+
inc(CryptMask, ord(s[i]) AND $7)
69+
end;
70+
UNPURPLE:
71+
for i := 1 to length(s) do begin
72+
nextmask := CryptMask + (ord(s[i]) AND $7);
73+
s[i] := chr(ord(s[i]) XOR CryptMask);
74+
CryptMask := nextmask
75+
end;
76+
COMPLEX :
77+
for i := 1 to length(s) do begin
78+
s[i] := chr(ord(s[i]) XOR CryptMask);
79+
CryptMask := random($100)
80+
end;
81+
end { case }
82+
83+
end; { cryptstr }
84+
85+
86+
begin
87+
88+
Encryption := NONE;
89+
CryptMask := $55
90+
91+
end. { unit crypt }

‎ERROR.PAS

Lines changed: 120 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,120 @@
1+
{ ERROR.PAS
2+
3+
Description:
4+
Writes out all kinds of compile-time errors. Does not perform
5+
a halt; expects the program itself to "unravel" the process.
6+
7+
}
8+
9+
unit error;
10+
11+
interface
12+
13+
uses misc, keywords, token;
14+
15+
{ Functions and Procedures }
16+
procedure hit_eof(var f: progfile; expecting: acl_type; specific:integer);
17+
procedure expected(var f: progfile;
18+
expect_ttype: acl_type; expect_specific: integer);
19+
procedure expect_general(var f: progfile;
20+
general_desc: string);
21+
procedure error_message(var f: progfile; message: string);
22+
function insist_on(var f: progfile;
23+
some_type: acl_type; some_number: integer): boolean;
24+
25+
26+
implementation
27+
28+
29+
procedure hit_eof(var f: progfile; expecting: acl_type; specific: integer);
30+
31+
begin
32+
33+
if KeepLooking then begin
34+
KeepLooking := FALSE;
35+
write('Found end of file; expected ');
36+
write_token(expecting, specific);
37+
writeln
38+
end
39+
40+
end;
41+
42+
43+
44+
procedure expected(var f: progfile;
45+
expect_ttype: acl_type; expect_specific: integer);
46+
47+
begin
48+
49+
if KeepLooking then begin
50+
source_pos(f);
51+
write('Expected ');
52+
write_token(expect_ttype, expect_specific);
53+
write('; found ');
54+
write_token(f.ttype, f.tnum);
55+
writeln
56+
end
57+
58+
end; { expected }
59+
60+
61+
62+
procedure expect_general(var f: progfile;
63+
general_desc: string);
64+
65+
begin
66+
67+
if KeepLooking then begin
68+
source_pos(f);
69+
write('Expected ');
70+
write(general_desc, '; found ');
71+
write_token(f.ttype, f.tnum);
72+
writeln
73+
end
74+
75+
end; { expected }
76+
77+
78+
79+
procedure error_message(var f: progfile; message: string);
80+
81+
begin
82+
83+
if KeepLooking then begin
84+
source_pos(f);
85+
writeln(message)
86+
end
87+
88+
end;
89+
90+
91+
92+
{ insist_on
93+
94+
Description:
95+
Used when a particular token is insisted upon by the syntax, usually
96+
for readability. It will be an error for the token not to exist.
97+
98+
}
99+
100+
function insist_on(var f: progfile;
101+
some_type: acl_type; some_number: integer): boolean;
102+
103+
begin
104+
if not get_token(f) then begin
105+
hit_eof(f, some_type, some_number);
106+
insist_on := FALSE
107+
end
108+
else if (f.ttype <> some_type) and (f.tnum <> some_number) then begin
109+
expected(f, some_type, some_number);
110+
KeepLooking := FALSE;
111+
insist_on := FALSE
112+
end
113+
else
114+
insist_on := TRUE
115+
116+
end; { insist_on }
117+
118+
119+
end. { unit error }
120+


0 commit comments

Comments
 (0)