PROGRAM include (input, output); CONST (* standard file descriptors. subscripts in open, etc. *) (* these are not to be changed *) STDIN = 1; STDOUT = 2; STDERR = 3; (* other io-related stuff *) IOERROR = 0; (* status values for open files *) IOAVAIL = 1; IOREAD = 2; IOWRITE = 3; MAXOPEN = 10; (* maximum number of open files *) (* universal manifest constants *) ENDFILE = -1; ENDSTR = 0; (* null-terminated strings *) MAXSTR = 100; (* longest possible string *) (* ascii character set in decimal *) TAB = 9; NEWLINE = 10; BLANK = 32; TYPE character = -1..127; (* byte-sized. ascii + other stuff *) string = ARRAY [1..MAXSTR] OF character; filedesc = IOERROR..MAXOPEN; ioblock = RECORD (* to keep track of open files *) filevar: TEXT; mode: IOERROR..IOWRITE; END; VAR openlist : ARRAY [1..MAXOPEN] of ioblock; (* open files *) { getc (UCB) -- get one character from standard input } function getc (var c : character) : character; var ch : char; begin if eof then c := ENDFILE else if eoln then begin readln; c := NEWLINE end else begin read(ch); c := ord(ch) end; getc := c end; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getcf (UCB) -- get one character from file } function getcf (var c: character; fd : filedesc) : character; var ch : char; begin if (fd = STDIN) then getcf := getc(c) else if eof(openlist[fd].filevar) then c := ENDFILE else if eoln(openlist[fd].filevar) then begin read(openlist[fd].filevar, ch); c := NEWLINE end else begin read(openlist[fd].filevar, ch); c := ord(ch) end; getcf := c end; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getline (UCB) -- get a line from file } function getline (var s : string; fd : filedesc; maxsize : integer) : boolean; var i : integer; c : character; begin i := 1; repeat s[i] := getcf(c, fd); i := i + 1 until (c = ENDFILE) or (c = NEWLINE) or (i >= maxsize); if (c = ENDFILE) then { went one too far } i := i - 1; s[i] := ENDSTR; getline := (c <> ENDFILE) end; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { equal -- test two strings for equality } function equal (var str1, str2 : string) : boolean; var i : integer; begin i := 1; while (str1[i] = str2[i]) and (str1[i] <> ENDSTR) do i := i + 1; equal := (str1[i] = str2[i]) end; (* message: print a message to STDERR. *) PROCEDURE message (CONST s: shortstring); BEGIN (* FPC standard error specific output: *) WRITELN(erroutput, s) END; (* error (FPC): Print an error to STDERR and halt. *) PROCEDURE error(CONST s: shortstring); BEGIN message(s); halt(1) END; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putc (UCB) -- put one character on standard output } procedure putc (c : character); begin if c = NEWLINE then writeln else write(chr(c)) end; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putcf (UCB) -- put a single character on file fd } procedure putcf (c : character; fd : filedesc); begin if (fd = STDOUT) then putc(c) else if c = NEWLINE then writeln(openlist[fd].filevar) else write(openlist[fd].filevar, chr(c)) end; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putstr (UCB) -- put out string on file } procedure putstr (var s : string; f : filedesc); var i : integer; begin i := 1; while (s[i] <> ENDSTR) do begin putcf(s[i], f); i := i + 1 end end; (*$i-*) FUNCTION open (VAR name: string; mode: INTEGER): filedesc; VAR i: INTEGER; intname: shortstring; (* FPC shortstring *) found: BOOLEAN; BEGIN i := 1; WHILE (name[i] <> ENDSTR) DO BEGIN intname[i] := CHR(name[i]); i := i + 1 END; intname[0] := CHR(i - 1); (* Find a free slot in openlist. *) open := IOERROR; found := FALSE; i := 1; WHILE (i <= MAXOPEN) AND (NOT found) DO BEGIN IF (openlist[i].mode = IOAVAIL) THEN BEGIN openlist[i].mode := mode; assign(openlist[i].filevar, intname); IF (mode = IOREAD) THEN RESET(openlist[i].filevar) ELSE REWRITE(openlist[i].filevar); open := i; found := TRUE END; i := i + 1 END; IF (ioresult <> 0) THEN open := IOERROR END; (*$i-*) { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { mustopen -- open file or die } function mustopen (var name : string; mode : integer) : filedesc; var fd : filedesc; begin fd := open(name, mode); if (fd = IOERROR) then begin putstr(name, STDERR); error(': can''t open file') end; mustopen := fd end; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { length -- compute length of string } function length (var s : string) : integer; var n : integer; begin n := 1; while (s[n] <> ENDSTR) do n := n + 1; length := n - 1 end; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { close (UCB) -- release file descriptor slot for open file } procedure xclose (fd : filedesc); begin if (fd > STDERR) and (fd <= MAXOPEN) then begin flush(openlist[fd].filevar); { in case buffered } openlist[fd].mode := IOAVAIL end end; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { include -- replace #include "file" by contents of file } procedure include; var incl : string; { value is '#include' } { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { finclude -- include file desc f } procedure finclude (f : filedesc); var line, str : string; loc, i : integer; f1 : filedesc; { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getword -- get word from s[i] into out } function getword (var s : string; i : integer; var out : string) : integer; var j : integer; begin while (s[i] in [BLANK, TAB, NEWLINE]) do i := i + 1; j := 1; while (not (s[i] in [ENDSTR,BLANK,TAB,NEWLINE])) do begin out[j] := s[i]; i := i + 1; j := j + 1 end; out[j] := ENDSTR; if (s[i] = ENDSTR) then getword := 0 else getword := i end; begin while (getline(line, f, MAXSTR)) do begin loc := getword(line, 1, str); if (not equal(str, incl)) then putstr(line, STDOUT) else begin loc := getword(line, loc, str); str[length(str)] := ENDSTR; { remove quotes } for i := 1 to length(str) do str[i] := str[i+1]; f1 := mustopen(str, IOREAD); finclude(f1); xclose(f1) end end end; begin { setstring(incl, '#include'); } incl[1] := ord('#'); incl[2] := ord('i'); incl[3] := ord('n'); incl[4] := ord('c'); incl[5] := ord('l'); incl[6] := ord('u'); incl[7] := ord('d'); incl[8] := ord('e'); incl[9] := ENDSTR; finclude(STDIN) end; PROCEDURE initio; VAR i: filedesc; BEGIN openlist[STDIN].mode := IOREAD; openlist[STDOUT].mode := IOWRITE; openlist[STDERR].mode := IOWRITE; (* Connect STDERR to user's terminal. *) assign(openlist[STDERR].filevar, ''); (* FPC specific. *) REWRITE(openlist[STDERR].filevar); FOR i := STDERR+1 TO MAXOPEN DO openlist[i].mode := IOAVAIL; END; BEGIN (* main program *) initio; include END.