|
|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 4480 (0x1180)
Types: TextFile
Names: »PPMOD1.PAS«
└─⟦02f213fda⟧ Bits:30008919 MT+ SPP 2/3
└─⟦this⟧ »PPMOD1.PAS«
(* VERSION 0032 *)
(* 5.5 STARTS WITH VERSION 32 *)
MODULE PPMOD1;
(*$I PPTYPES*)
(*$I PPEXTS*)
PROCEDURE GETCHAR;
VAR
CH : CHAR;
EOLCURSOR : INTEGER;
CH2 : ARRAY Æ1..2Å OF CHAR;
BEGIN
CUR := NXT;
IF CURSOR <= BUFSZ THEN
CH := BUFÆCURSORÅ
ELSE
CH := ' ';
WITH NXT DO
BEGIN
IF CURSOR > ENDFILE THEN
NAME := FILEMARK
ELSE IF CH = CHR(CR) THEN
BEGIN
CURSOR := CURSOR + 2;
WRITE('.');
EOLCURSOR := CURSOR;
NAME := END_OF_LINE;
(* CURSOR NOW POINTS TO CHAR AFTER LF *)
WHILE BUFÆCURSORÅ = ' ' DO
CURSOR := CURSOR + 1;
MOVE(BUFÆCURSORÅ,CH2,2);
æIF (CH2= '(*') OR (BUFÆCURSORÅ='æ') THEN
CURSOR := EOLCURSOR;å
CURSOR := CURSOR - 1
END
ELSE IF ((CH >='@') AND (CH <='Z')) OR
((CH >='a') AND (CH <='z')) OR
( CH = '_') THEN
NAME := LETTER
ELSE IF ((CH >= '0') AND (CH <= '9')) THEN
NAME := DIGIT
ELSE IF CH = '''' THEN
NAME := QUOTE
ELSE IF CH = SPACE THEN
NAME := BLANK
ELSE NAME := OTHERCHAR;
IF (NAME=FILEMARK) OR (NAME=END_OF_LINE) THEN
VALUE := SPACE
ELSE
VALUE := CH; æno longer convert to uppercase as of 5.5 å
IF NAME <> FILEMARK THEN
CURSOR := CURSOR + 1
END
END;
(*$P*)
PROCEDURE STORENXT(VAR LENGTH:INTEGER;
VAR VALUE : STRING);
BEGIN
GETCHAR;
IF LENGTH < MAXSYMSIZE THEN
BEGIN
LENGTH := LENGTH + 1;
VALUEÆLENGTHÅ := CUR.VALUE
END
END;
(*$P*)
PROCEDURE SKIPSPACES(VAR SPACESBEFORE,CRSBEFORE : INTEGER);
BEGIN
SPACESBEFORE := 0;
CRSBEFORE := 0;
WHILE (NXT.NAME = BLANK) OR (NXT.NAME = ENDOFLINE) DO
BEGIN
GETCHAR;
CASE CUR.NAME OF
BLANK : SPACESBEFORE := SPACESBEFORE + 1;
ENDOFLINE : BEGIN
CRSBEFORE := CRSBEFORE + 1;
SPACESBEFORE := 0
END
END
END
END;
(*$P*)
PROCEDURE GETCOMMENT(VAR NAME : KEYSYMBOL;
VAR VALUE : STRING;
VAR LENGTH : INTEGER;
BRACE : BOOLEAN);
BEGIN
BRACE := NEXTSYM.VALUEÆ1Å = 'æ';
NAME := OPENCOMMENT;
IF NOT BRACE THEN
WHILE NOT(((CUR.VALUE = '*') AND (NXT.VALUE=')'))
OR (NXT.NAME = ENDOFLINE)
OR (NXT.NAME = FILEMARK)) DO
STORENXT(LENGTH,VALUE)
ELSE
WHILE NOT((NXT.VALUE='å')
OR (NXT.NAME = ENDOFLINE)
OR (NXT.NAME = FILEMARK)) DO
STORENXT(LENGTH,VALUE);
IF (CUR.VALUE = '*') AND (NXT.VALUE = ')') THEN
BEGIN
STORENXT(LENGTH,VALUE);
NAME := CLOSECOMMENT
END
ELSE IF (NXT.VALUE = 'å') THEN
NAME := CLOSECOMMENT
END;
(*$P*)
FUNCTION IDTYPE(VALUE:STRING;
LENGTH:INTEGER):KEYSYMBOL;
VAR
I : INTEGER;
KEYVALUE : KEY;
HIT : BOOLEAN;
THISKEY : KEYSYMBOL;
BEGIN
IDTYPE := OTHERSY;
IF LENGTH <= MAXKEYLEN THEN
BEGIN
FOR I := 1 TO LENGTH DO
KEYVALUEÆIÅ := CHR(VALUEÆIÅ & $DF);
FOR I := LENGTH+1 TO MAXKEYLENGTH DO
KEYVALUEÆIÅ := SPACE;
THISKEY := PROGSY;
HIT := FALSE;
WHILE NOT(HIT OR (PRED(THISKEY) = UNTILSY)) DO
IF KEYVALUE = KEYWORDÆTHISKEYÅ THEN
HIT := TRUE
ELSE
THISKEY := SUCC(THISKEY);
IF HIT THEN
IDTYPE := THISKEY
END
END;
(*$P*)
PROCEDURE GETIDENTIFIER(VAR NAME : KEYSYMBOL;
VAR VALUE : STRING;
VAR LENGTH : INTEGER);
BEGIN
WHILE (NXT.NAME = LETTER) OR (NXT.NAME = DIGIT) DO
STORENXT(LENGTH,VALUE);
NAME := IDTYPE(VALUE,LENGTH);
CASE NAME OF
RECORDSY : RECORDSEEN := TRUE;
EXTSY : IF COLONSEEN THEN
NAME := ANOTHERSY
ELSE
EXTSEEN := TRUE;
PROCSY,
FUNCSY : IF EXTSEEN THEN
NAME := ANOTHERSY;
CASESY : IF RECORDSEEN THEN
NAME := CASEVARSY;
ENDSY : RECORDSEEN := FALSE
END
END;
MODEND.
«eof»