The Wiert Corner – irregular stream of stuff

Jeroen W. Pluimers on .NET, C#, Delphi, databases, and personal interests

  • My badges

    Mastodon

  • Twitter Updates

  • My Flickr Stream

    20140508-Delphi-2007--Project-Options--Cannot-Edit-Application-Title-HelpFile-Icon-Theming20140430-Fiddler-Filter-Actions-Button-Run-Filterset-now20140424-VMware-Fusion-6.0.3.-no-reclaimable
    More Photos

  • Pages

  • All categories

  • Enter your email address to subscribe to this blog and receive notifications of new posts by email.

    Join 1,860 other subscribers
«
»

Trip down memory lane: book on p-Code based UCSD Pascal

Posted by jpluimers on 2025/05/06

Last week I wrote on File scoped namespaces – C# 10.0 draft specifications | Microsoft Learn, promising to write more on p-Code and UCSD Pascal. That’s now (:

I started with [Wayback/Archive] “java byte code” “ucsd” “p-code” – Google Search as I was looking for really old material on this (Java 1.0 versions became available in the 1994-1995 time frame, and a lot of material back then either did not make it to the World Wide Web (which slowly gained popularity around that time, see History of the World Wide Web) or has vanished due to link rot.

The cool thing is that many “new” people are not even aware of p-Code, as the 2019 thread [Wayback/Archive] What do you think about something like Pascal bytecode? shows.

I learned a thing or two from it as well, for instance that there has been a “recent” book on UCSD Pascal:

The p-code was invented by Urs Amman, a student of Niklas Wirth in the mid 70th.
Kenneth Bowles at the University San Diego California put Pascal and p-code together and developed UCSD Pascal, also known as Apple Pascal or UCSD Power Pascal.

Because only 15% of the OS are machine dependent UCSD Pascal became wide spread and was  implemented on over different 80 machine types. The most work was to rewrite the system.interpreter in the Assembler dialect of ther machine. Later the interpreter was rewritten in C by Knowledge Software GB. The Java byte code is based on the p-code.

…

A short book about the UCSD Pascal Compiler and the p-system.
From 1982.
Chapter 10 is about p-code.

https://homepages.cwi.nl/~steven/pascal/book/pascalimplementation.html

…

The book is not totally correct, but close. I started with UCSD pascal on an Apple 11e. (so, after the language originated)
The idea from the P-code originated with Wirth. The implementation of which is done by his student.
This is quite common in University circles.

…

Can I conclude that the idea of string [complex type] was invented at UCSD Pascal, but Borland Turbo Pascal 1.0 in 1983 was the first one to really implement the String [simple] type?

…

Yes, that is the correct history.

UCSD was inteded for educational reasons – to learn Pascal, to learn how to build a compiler and was very puristic with the syntax and the types. Anyway – there were a lot of programms for buisiness use made with UCSD. And it came free with Apple II and Clones.

Turbo came some years later and came from the practical side: you could make sound, you could write a working terminal program (with pascal extension port), the compiler was optimized – as Anders Heilsberg said – not along the rules but with some hacks to speed it up. And you should not forget: A compiler in these days  had a price of 1000.- $ and more. Turbo was sold in US for 99 $ and in Germany for 299.- DM (German Marks).

With Turbo you could play around with the hardware so you could get a serial RS 232 with 115.000 Baud – which was not due to the specifications but it worked. Later they sold this as “Poor mens network” with a serial (crossed) cable and some software (Kischbaum Link). You could connect 2 PCs and use neighbours disk C: as drive D: (or higher).

With UCSD you could not do such hardware hacks because it was machine independent. Then they recognized this and inserted unitread and unitwrite, but they tried to keep it secret before the students.

…

I vaguely remembered the first part about Pascal (and was happy about the refresher: I knew it was not Niklaus Wirth himself, now I know the name of the student at the ETH Zürich), but unlike [Wayback/Archive] ETH Zurich / N. Wirth / Books / PASCAL – User Manual, this book by Steven Pemberton and Martin Daniels was totally new for me!

The “Pascal Implementation” book: 20 years of work?!

Probably not 20 years of continuous work, but the copyright goes from 1982 to 2002, annotating the source code for the Pascal P4 Compiler.

It is at [Wayback/Archive] Pascal Implementation:

The full text of Pascal Implementation has been scanned from the original book, and OCR’d, before being updated. This initial release should therefore be considered a DRAFT. As a service to the community, you are therefore asked to communicate any errors, problems, or suggestions back to the authors at the email address below. Thanks!
If you understand this is a draft, and will endeavour to communicate errors you find back to the author, then [Wayback/Archive] please proceed.

Then continues at [Wayback/Archive] Pascal Implementation; I added the archive links to the table of contents.

The P4 Compiler and Interpreter

Part 1: The Compiler

Part 2: The Interpreter

Appendices

Copyright © 1982, 2002 Steven Pemberton and Martin Daniels, all rights reserved.

The compiler and interpreter themselves start at at another page named [Wayback/Archive] Pascal Implementation

Pascal Implementation: A Book and Sources

Included here is the Pascal source of a public-domain Pascal compiler and interpreter, the P4 compiler and interpreter. It is coded entirely in Pascal, and produces a high-level so-called intermediate code as output. The program ‘pint’ is an assembler and interpreter for this language.

The entire compiler and interpreter is documented in the book:

[Wayback/Archive] Pascal Implementation: The P4 Compiler and Interpreter, by [Wayback/Archive] Steven Pemberton and [Wayback/Archive] Martin Daniels, Ellis Horwood, ISBN: [W/Archive] 0-13-653-0311 (also available in [Wayback/Archive] Japanese).

It was distributed by John Wiley in other countries, but now that Prentice Hall has taken over Ellis Horwood, that will have changed.

Steven Pemberton is contactable by email as Steven.Pemberton@cwi.nl. He did not write the compiler, only documented it in the book.

What you have to do to use this compiler

  • Compile pcom.p and pint.p with a Pascal compiler. You obviously have to have a Pascal compiler already. This gives you a Pascal compiler (pcom) that produces P4 code, and an interpreter (pint) that runs P4 code.
  • To use the compiler, run pcom with the Pascal program as standard input. This produces any diagnostics on standard output, and its code on a Pascal file that is called prr. Check with your Pascal compiler how this gets assigned to a file in the filestore. You may have to change the lines ‘rewrite(prr)‘ in pcom.p and pint.p and ‘reset(prd)‘ in pint.p for your compiler, for instance to “rewrite(prr, 'prr')” etc.
  • To run the resulting code, run pint with the prr output produced by pcom as input for the file ‘prd‘, and input for the compiled pascal program on standard input.

For instance, do this once:

  • pc -o pcom pcom.p
  • pc -o pint pint.p

and for each program:

  • pcom < test.p # produces file prr containing the p4 code
  • mv prr prd
  • pint < input

You have to supply input to pint, even if the program doesn’t read from it, for instance:

  • pint < /dev/null

If you intend to compile pcom with itself, there are two lines that have to be commented out when you do; search for the word ‘comment‘ in the pcom source. There is no reason why you should want to compile pint.p with pcom.

What If You Haven’t Got a Pascal Compiler?

Differences with the Book

The code here is slightly different from that in the book, but the line numbers have been kept the same. The changes were to allow modern Pascal compilers to compile the source (there were some laxities in the original code).

[Wayback/Archive] The Compiler Source

[Wayback/Archive] The Interpreter Source

[Wayback/Archive] The Differences with the book

Source files themselves

Source files in HTML form

Two of the above files are also on Steven’s web site in HTML form:

  1. [Wayback/Archive] https://homepages.cwi.nl/~steven/pascal/book/pcom.html
         1  (*$c+,t-,d-,l-*)
     2   (***********************************************
     3    *                                             *
     4    *      Portable Pascal compiler               *
     5    *      ************************               *
     6    *                                             *
     7    *             Pascal P4                       *
     8    *                                             *
     9    *     Authors:                                *
    10    *           Urs Ammann                        *
    11    *           Kesav Nori                        *
    12    *           Christian Jacobi                  *
    13    *     Address:                                *
    14    *       Institut Fuer Informatik              *
    15    *       Eidg. Technische Hochschule           *
    16    *       CH-8096 Zuerich                       *
    17    *                                             *
    18    *  This code is fully documented in the book  *
    19    *        "Pascal Implementation"              *
    20    *   by Steven Pemberton and Martin Daniels    *
    21    * published by Ellis Horwood, Chichester, UK  *
    22    *         ISBN: 0-13-653-0311                 *
    23    *       (also available in Japanese)          *
    24    *                                             *
    25    * Steven Pemberton, CWI, Amsterdam            *
    26    * http://www.cwi.nl/~steven/                  *
    27    * Steven.Pemberton@cwi.nl                     *
    28    *                                             *
    29    ***********************************************)
  2. [Wayback/Archive] https://homepages.cwi.nl/~steven/pascal/book/pint.html
         1 (*Assembler and interpreter of Pascal code*)
     2 (*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*)
     3
     4 program pcode(input,output,prd,prr);
     5 
     6 (* Note for the implementation.
     7    ===========================
     8 This interpreter is written for the case where all the fundamental types
     9 take one storage unit.
    10 In an actual implementation, the handling of the sp pointer has to take
    11 into account the fact that the types may have lengths different from one:
    12 in push and pop operations the sp has to be increased and decreased not
    13 by 1, but by a number depending on the type concerned.
    14 However, where the number of units of storage has been computed by the
    15 compiler, the value must not be corrected, since the lengths of the types
    16 involved have already been taken into account.
    17          *)

Page 2 of the “Pascal bytecode?” thread

I learned a few more things from [Wayback/Archive] What do you think about something like Pascal bytecode? (Page 2)

Well, [Wayback/Archive] https://sourceforge.net/projects/pascalp5/ is a pascal bytecode compiler(it is actually used in the tests to test ISO conformance in {$mode iso})
And the author sometimes visits this forum. Freepascal – at least 3.2.0 and trunk- can compile this compiler…
Scott Franco, the author, is a bit of a ISO standards guru, at least to me.

His website also contains the original pascal-s and some previous efforts.

…

Perhaps more to the point, having a compiler emit a bytecode sequence as a well-documented intermediate representation is “very 1980s”. With all respect to Scott, Bernd and the other maintainers of historic compilers, the way it’s done these days is for the frontend to generate a parse tree which might- or might not- be published and documented: and if OP wants to help document some of the FPC arcana I’m sure his help would be appreciated :-)

Noting that Bernd’s port of P4 http://bernd-oppolzer.de/job9.htm runs on at least some of the classic mainframe OSes, I’d add that poor understanding of FPC’s internal operation was one of the reasons that FPC didn’t get ported to those platforms.

…

Why did he port that? The original author already did that: Scott Franco (a.k.a. Scott Moore). Better use the source, the source and not some vague ports.

…

IIRC P4 originated at ETH, was built for portability by Wirth’s team in the seventies. and was indeed ported to many platforms. Stanford Pascal was one of those ports, for IBM mainframes. Scott Moore was not  the original author, but he did (much later in time!) quite a remarkable job digging up the original source code and publishing it. And made a ‘P5’ out of it. All compiler-interpreters with p-code (not bytecode!)

…

Afaik, ETH’s P4 was meant as bootstrap compiler because the small bytecode interpreter would be easily portable.
Since the compiler didn’t use the full ISO dialect, neither did P4.

That’s why Scott made P5, which is P4 expanded to support the full ISO dialect.

Hopefully more on that in a future blog post.

--jeroen

Gist with P4C source files from https://homepages.cwi.nl/~steven/pascal/p4c.tar.gz

[Wayback/Archive] P4C files by I.J.A.vanGeel@twi.tudelft.nl from https://homepages.cwi.nl/~steven/pascal/p4c.tar.gz (P2C translated C version of the P4 Pascal compiler, originally for UNIX and OS/2; requires GCC)


README for P4 compiler/interpreter
Included are the sources to the P4 Pascal -> P-code compiler and to the
P-code interpreter. The original source-code was written in Pascal, which
was transformed to C-code, using p2c.
(Details of the conversion can be found in the headers of the C-files)
You can redistribute all the source code freely, the p2c library source
and the code generated by it are NOT subject to the GNU general public
license. The original Pascal source-code is public domain.
Makefiles are included to compile the programs using gcc and Unix or
gcc (emx) and OS/2.
To make just enter:
make
or
make -f makefile.os2
Enjoy
Send reactions to
I.J.A.vanGeel@twi.tudelft.nl
Date: august 22 1996

view raw

README

hosted with ❤ by GitHub


# UNIX Makefile
# Makefile for the P4 pascal compiler and interpreter
CC = gcc
CFLAGS = -O3 -fomit-frame-pointer -funroll-loops
#CFLAGS = -Wall -g
.c.o:
$(CC) -I. $(CFLAGS) -c $<
all: pcom pint
pcom: libp2c.a pcom.o
$(CC) pcom.o -o pcom -L. -lp2c
pcom.o: pcom.c p2c.h
pint: libp2c.a pint.o
$(CC) pint.o -o pint -L. -lp2c -lm
pint.o: pint.c p2c.h
libp2c.a: p2clib.o
ar rv libp2c.a p2clib.o
ranlib libp2c.a
p2clib.o: p2clib.c p2c.h
clean:
$(RM) *% *.o *.a pint pcom core prr prd

view raw

Makefile

hosted with ❤ by GitHub


# OS/2 Makefile
# Makefile for the P4 pascal compiler and interpreter
CC = gcc
CFLAGS = -O3 -fomit-frame-pointer -funroll-loops
#CFLAGS = -Wall -g
RM = del
.c.o:
$(CC) -I. $(CFLAGS) -c $<
all: pcom.exe pint.exe
pcom.exe: p2c.a pcom.o
$(CC) pcom.o -o pcom.exe -L. -lp2c
pcom.o: pcom.c p2c.h
pint.exe: p2c.a pint.o
$(CC) pint.o -o pint.exe -L. -lp2c -lm
pint.o: pint.c p2c.h
p2c.a: p2clib.o
ar rv p2c.a p2clib.o
p2clib.o: p2clib.c p2c.h
clean:
$(RM) *.o *.a pint.exe pcom.exe core prr prd


view raw

Makefile.OS2

hosted with ❤ by GitHub


# UNIX Makefile
# Makefile for the P4 pascal compiler and interpreter
CC = gcc
CFLAGS = -O3 -fomit-frame-pointer -funroll-loops
#CFLAGS = -Wall -g
.c.o:
$(CC) -I. $(CFLAGS) -c $<
all: pcom pint
pcom: libp2c.a pcom.o
$(CC) pcom.o -o pcom -L. -lp2c
pcom.o: pcom.c p2c.h
pint: libp2c.a pint.o
$(CC) pint.o -o pint -L. -lp2c -lm
pint.o: pint.c p2c.h
libp2c.a: p2clib.o
ar rv libp2c.a p2clib.o
ranlib libp2c.a
p2clib.o: p2clib.c p2c.h
clean:
$(RM) *% *.o *.a pint pcom core prr prd

view raw

Makefile.unx

hosted with ❤ by GitHub


#ifndef P2C_H
#define P2C_H
/* Header file for code generated by "p2c", the Pascal-to-C translator */
/* "p2c" Copyright (C) 1989, 1990, 1991 Free Software Foundation.
* By Dave Gillespie, daveg@csvax.cs.caltech.edu. Version 1.20.
* This file may be copied, modified, etc. in any way. It is not restricted
* by the licence agreement accompanying p2c itself.
*/
#include <stdio.h>
/* If the following heuristic fails, compile -DBSD=0 for non-BSD systems,
or -DBSD=1 for BSD systems. */
#ifdef M_XENIX
# define BSD 0
#endif
#ifdef vms
# define BSD 0
# ifndef __STDC__
# define __STDC__ 1
# endif
#endif
#ifdef __TURBOC__
# define MSDOS 1
#endif
#ifdef MSDOS
# define BSD 0
#endif
#ifdef FILE /* a #define in BSD, a typedef in SYSV (hp-ux, at least) */
# ifndef BSD /* (a convenient, but horrible kludge!) */
# define BSD 1
# endif
#endif
#ifdef BSD
# if !BSD
# undef BSD
# endif
#endif
#if (defined(__STDC__) && !defined(M_XENIX)) || defined(__TURBOC__)
# include <stddef.h>
# include <stdlib.h>
# define HAS_STDLIB
# if defined(vms) || defined(__TURBOC__)
# define __ID__(a)a
# endif
#else
# ifndef BSD
# ifndef __TURBOC__
# include <memory.h>
# endif
# endif
# ifdef hpux
# ifdef _INCLUDE__STDC__
# include <stddef.h>
# include <stdlib.h>
# endif
# endif
# include <sys/types.h>
# if !defined(MSDOS) || defined(__TURBOC__)
# define __ID__(a)a
# endif
#endif
#ifdef __ID__
# define __CAT__(a,b)__ID__(a)b
#else
# define __CAT__(a,b)a##b
#endif
#ifdef BSD
# include <strings.h>
# define memcpy(a,b,n) (bcopy(b,a,n),a)
# define memcmp(a,b,n) bcmp(a,b,n)
# define strchr(s,c) index(s,c)
# define strrchr(s,c) rindex(s,c)
#else
# include <string.h>
#endif
#include <ctype.h>
#include <math.h>
#include <setjmp.h>
#include <assert.h>
#define NO_LACK
#ifndef NO_LACK
#ifdef vms
#define LACK_LABS
#define LACK_MEMMOVE
#define LACK_MEMCPY
#else
#define LACK_LABS /* Undefine these if your library has these */
#define LACK_MEMMOVE
#endif
#endif
typedef struct __p2c_jmp_buf {
struct __p2c_jmp_buf *next;
jmp_buf jbuf;
} __p2c_jmp_buf;
/* Warning: The following will not work if setjmp is used simultaneously.
This also violates the ANSI restriction about using vars after longjmp,
but a typical implementation of longjmp will get it right anyway. */
#ifndef FAKE_TRY
# define TRY(x) do { __p2c_jmp_buf __try_jb; \
__try_jb.next = __top_jb; \
if (!setjmp((__top_jb = &__try_jb)->jbuf)) {
# define RECOVER(x) __top_jb = __try_jb.next; } else {
# define RECOVER2(x,L) __top_jb = __try_jb.next; } else { \
if (0) { L: __top_jb = __try_jb.next; }
# define ENDTRY(x) } } while (0)
#else
# define TRY(x) if (1) {
# define RECOVER(x) } else do {
# define RECOVER2(x,L) } else do { L: ;
# define ENDTRY(x) } while (0)
#endif
#ifdef M_XENIX /* avoid compiler bug */
# define SHORT_MAX (32767)
# define SHORT_MIN (-32768)
#endif
/* The following definitions work only on twos-complement machines */
#ifndef SHORT_MAX
# define SHORT_MAX ((short)(((unsigned short) -1) >> 1))
# define SHORT_MIN (~SHORT_MAX)
#endif
#ifndef INT_MAX
# define INT_MAX ((int)(((unsigned int) -1) >> 1))
# define INT_MIN (~INT_MAX)
#endif
#ifndef LONG_MAX
# define LONG_MAX ((long)(((unsigned long) -1) >> 1))
# define LONG_MIN (~LONG_MAX)
#endif
#ifndef SEEK_SET
# define SEEK_SET 0
# define SEEK_CUR 1
# define SEEK_END 2
#endif
#ifndef EXIT_SUCCESS
# ifdef vms
# define EXIT_SUCCESS 1
# define EXIT_FAILURE (02000000000L)
# else
# define EXIT_SUCCESS 0
# define EXIT_FAILURE 1
# endif
#endif
#define SETBITS 32
#if defined(__STDC__) || defined(__TURBOC__)
# if !defined(vms) && !defined(M_LINT)
# define Signed signed
# else
# define Signed
# endif
# define Void void /* Void f() = procedure */
# ifndef Const
# define Const const
# endif
# ifndef Volatile
# define Volatile volatile
# endif
# ifdef M_LINT
# define PP(x) ()
# define PV() ()
typedef char *Anyptr;
# else
# define PP(x) x /* function prototype */
# define PV() (void) /* null function prototype */
typedef void *Anyptr;
# endif
#else
# define Signed
# define Void void
# ifndef Const
# define Const
# endif
# ifndef Volatile
# define Volatile
# endif
# define PP(x) ()
# define PV() ()
typedef char *Anyptr;
#endif
#ifdef __GNUC__
# define Inline inline
#else
# define Inline
#endif
#define Register register /* Register variables */
#define Char char /* Characters (not bytes) */
#ifndef Static
# define Static static /* Private global funcs and vars */
#endif
#ifndef Local
# define Local static /* Nested functions */
#endif
typedef Signed char schar;
typedef unsigned char uchar;
typedef unsigned char boolean;
#ifndef true
# define true 1
# define false 0
#endif
#ifndef TRUE
# define TRUE 1
# define FALSE 0
#endif
typedef struct {
Anyptr proc, link;
} _PROCEDURE;
#ifndef _FNSIZE
# define _FNSIZE 120
#endif
extern Void PASCAL_MAIN PP( (int, Char **) );
extern Char **P_argv;
extern int P_argc;
extern short P_escapecode;
extern int P_ioresult;
extern __p2c_jmp_buf *__top_jb;
#ifdef P2C_H_PROTO /* if you have Ansi C but non-prototyped header files */
extern Char *strcat PP( (Char *, Const Char *) );
extern Char *strchr PP( (Const Char *, int) );
extern int strcmp PP( (Const Char *, Const Char *) );
extern Char *strcpy PP( (Char *, Const Char *) );
extern size_t strlen PP( (Const Char *) );
extern Char *strncat PP( (Char *, Const Char *, size_t) );
extern int strncmp PP( (Const Char *, Const Char *, size_t) );
extern Char *strncpy PP( (Char *, Const Char *, size_t) );
extern Char *strrchr PP( (Const Char *, int) );
extern Anyptr memchr PP( (Const Anyptr, int, size_t) );
extern Anyptr memmove PP( (Anyptr, Const Anyptr, size_t) );
extern Anyptr memset PP( (Anyptr, int, size_t) );
#ifndef memcpy
extern Anyptr memcpy PP( (Anyptr, Const Anyptr, size_t) );
extern int memcmp PP( (Const Anyptr, Const Anyptr, size_t) );
#endif
extern int atoi PP( (Const Char *) );
extern double atof PP( (Const Char *) );
extern long atol PP( (Const Char *) );
extern double strtod PP( (Const Char *, Char **) );
extern long strtol PP( (Const Char *, Char **, int) );
#endif /*P2C_H_PROTO*/
#ifndef HAS_STDLIB
extern Anyptr malloc PP( (size_t) );
extern Void free PP( (Anyptr) );
#endif
extern int _OutMem PV();
extern int _CaseCheck PV();
extern int _NilCheck PV();
extern int _Escape PP( (int) );
extern int _EscIO PP( (int) );
extern long ipow PP( (long, long) );
extern Char *strsub PP( (Char *, Char *, int, int) );
extern Char *strltrim PP( (Char *) );
extern Char *strrtrim PP( (Char *) );
extern Char *strrpt PP( (Char *, Char *, int) );
extern Char *strpad PP( (Char *, Char *, int, int) );
extern int strpos2 PP( (Char *, Char *, int) );
extern long memavail PV();
extern int P_peek PP( (FILE *) );
extern int P_eof PP( (FILE *) );
extern int P_eoln PP( (FILE *) );
extern Void P_readpaoc PP( (FILE *, Char *, int) );
extern Void P_readlnpaoc PP( (FILE *, Char *, int) );
extern long P_maxpos PP( (FILE *) );
extern Char *P_trimname PP( (Char *, int) );
extern long *P_setunion PP( (long *, long *, long *) );
extern long *P_setint PP( (long *, long *, long *) );
extern long *P_setdiff PP( (long *, long *, long *) );
extern long *P_setxor PP( (long *, long *, long *) );
extern int P_inset PP( (unsigned, long *) );
extern int P_setequal PP( (long *, long *) );
extern int P_subset PP( (long *, long *) );
extern long *P_addset PP( (long *, unsigned) );
extern long *P_addsetr PP( (long *, unsigned, unsigned) );
extern long *P_remset PP( (long *, unsigned) );
extern long *P_setcpy PP( (long *, long *) );
extern long *P_expset PP( (long *, long) );
extern long P_packset PP( (long *) );
extern int P_getcmdline PP( (int, int, Char *) );
extern Void TimeStamp PP( (int *, int *, int *,
int *, int *, int *) );
extern Void P_sun_argv PP( (char *, int, int) );
/* I/O error handling */
#define _CHKIO(cond,ior,val,def) ((cond) ? P_ioresult=0,(val) \
: P_ioresult=(ior),(def))
#define _SETIO(cond,ior) (P_ioresult = (cond) ? 0 : (ior))
/* Following defines are suitable for the HP Pascal operating system */
#define FileNotFound 10
#define FileNotOpen 13
#define FileWriteError 38
#define BadInputFormat 14
#define EndOfFile 30
#define FILENOTFOUND 10
#define FILENOTOPEN 13
#define FILEWRITEERROR 38
#define BADINPUTFORMAT 14
#define ENDOFFILE 30
/* Creating temporary files */
#if (defined(BSD) || defined(NO_TMPFILE)) && !defined(HAVE_TMPFILE)
# define tmpfile() (fopen(tmpnam(NULL), "w+"))
#endif
/* File buffers */
#define FILEBUF(f,sc,type) sc int __CAT__(f,_BFLAGS); \
sc type __CAT__(f,_BUFFER)
#define FILEBUFNC(f,type) int __CAT__(f,_BFLAGS); \
type __CAT__(f,_BUFFER)
#define RESETBUF(f,type) (__CAT__(f,_BFLAGS) = 1)
#define SETUPBUF(f,type) (__CAT__(f,_BFLAGS) = 0)
#define GETFBUF(f,type) (*((__CAT__(f,_BFLAGS) == 1 && \
((__CAT__(f,_BFLAGS) = 2), \
fread(&__CAT__(f,_BUFFER), \
sizeof(type),1,(f)))),\
&__CAT__(f,_BUFFER)))
#define AGETFBUF(f,type) ((__CAT__(f,_BFLAGS) == 1 && \
((__CAT__(f,_BFLAGS) = 2), \
fread(__CAT__(f,_BUFFER), \
sizeof(type),1,(f)))),\
__CAT__(f,_BUFFER))
#define PUTFBUF(f,type,v) (GETFBUF(f,type) = (v))
#define CPUTFBUF(f,v) (PUTFBUF(f,char,v))
#define APUTFBUF(f,type,v) (memcpy(AGETFBUF(f,type), (v), \
sizeof(__CAT__(f,_BUFFER))))
#define GET(f,type) (__CAT__(f,_BFLAGS) == 1 ? \
fread(&__CAT__(f,_BUFFER),sizeof(type),1,(f)) : \
(__CAT__(f,_BFLAGS) = 1))
#define PUT(f,type) (fwrite(&__CAT__(f,_BUFFER),sizeof(type),1,(f)), \
(__CAT__(f,_BFLAGS) = 0))
#define CPUT(f) (PUT(f,char))
#define BUFEOF(f) (__CAT__(f,_BFLAGS) != 2 && P_eof(f))
#define BUFFPOS(f) (ftell(f) – (__CAT__(f,_BFLAGS) == 2))
typedef struct {
FILE *f;
FILEBUFNC(f,Char);
Char name[_FNSIZE];
} _TEXT;
/* Memory allocation */
#ifdef __GCC__
# define Malloc(n) (malloc(n) ?: (Anyptr)_OutMem())
#else
extern Anyptr __MallocTemp__;
# define Malloc(n) ((__MallocTemp__ = malloc(n)) ? __MallocTemp__ : (Anyptr)_OutMem())
#endif
#define FreeR(p) (free((Anyptr)(p))) /* used if arg is an rvalue */
#define Free(p) (free((Anyptr)(p)), (p)=NULL)
/* sign extension */
#define SEXT(x,n) ((x) | -(((x) & (1L<<((n)-1))) << 1))
/* packed arrays */ /* BEWARE: these are untested! */
#define P_getbits_UB(a,i,n,L) ((int)((a)[(i)>>(L)-(n)] >> \
(((~(i))&((1<<(L)-(n))-1)) << (n)) & \
(1<<(1<<(n)))-1))
#define P_getbits_SB(a,i,n,L) ((int)((a)[(i)>>(L)-(n)] << \
(16 – ((((~(i))&((1<<(L)-(n))-1))+1) <<\
(n)) >> (16-(1<<(n))))))
#define P_putbits_UB(a,i,x,n,L) ((a)[(i)>>(L)-(n)] |= \
(x) << (((~(i))&((1<<(L)-(n))-1)) << (n)))
#define P_putbits_SB(a,i,x,n,L) ((a)[(i)>>(L)-(n)] |= \
((x) & (1<<(1<<(n)))-1) << \
(((~(i))&((1<<(L)-(n))-1)) << (n)))
#define P_clrbits_B(a,i,n,L) ((a)[(i)>>(L)-(n)] &= \
~( ((1<<(1<<(n)))-1) << \
(((~(i))&((1<<(L)-(n))-1)) << (n))) )
/* small packed arrays */
#define P_getbits_US(v,i,n) ((int)((v) >> ((i)<<(n)) & (1<<(1<<(n)))-1))
#define P_getbits_SS(v,i,n) ((int)((long)(v) << (SETBITS – (((i)+1) << (n))) >> (SETBITS-(1<<(n)))))
#define P_putbits_US(v,i,x,n) ((v) |= (x) << ((i) << (n)))
#define P_putbits_SS(v,i,x,n) ((v) |= ((x) & (1<<(1<<(n)))-1) << ((i)<<(n)))
#define P_clrbits_S(v,i,n) ((v) &= ~( ((1<<(1<<(n)))-1) << ((i)<<(n)) ))
#define P_max(a,b) ((a) > (b) ? (a) : (b))
#define P_min(a,b) ((a) < (b) ? (a) : (b))
/* Fix ANSI-isms */
#ifdef LACK_LABS
# ifndef labs
# define labs my_labs
extern long my_labs PP( (long) );
# endif
#endif
#ifdef LACK_MEMMOVE
# ifndef memmove
# define memmove my_memmove
extern Anyptr my_memmove PP( (Anyptr, Const Anyptr, size_t) );
# endif
#endif
#ifdef LACK_MEMCPY
# ifndef memcpy
# define memcpy my_memcpy
extern Anyptr my_memcpy PP( (Anyptr, Const Anyptr, size_t) );
# endif
# ifndef memcmp
# define memcmp my_memcmp
extern int my_memcmp PP( (Const Anyptr, Const Anyptr, size_t) );
# endif
# ifndef memset
# define memset my_memset
extern Anyptr my_memset PP( (Anyptr, int, size_t) );
# endif
#endif
#endif /* P2C_H */
/* End. */

view raw

p2c.h

hosted with ❤ by GitHub


/* Run-time library for use with "p2c", the Pascal to C translator */
/* "p2c" Copyright (C) 1989, 1990, 1991 Free Software Foundation.
* By Dave Gillespie, daveg@csvax.cs.caltech.edu. Version –VERSION–.
* This file may be copied, modified, etc. in any way. It is not restricted
* by the licence agreement accompanying p2c itself.
*/
#include "p2c.h"
#ifndef NO_TIME
# include <time.h>
#endif
#define Isspace(c) isspace(c) /* or "((c) == ' ')" if preferred */
int P_argc;
char **P_argv;
short P_escapecode;
int P_ioresult;
long EXCP_LINE; /* Used by Pascal workstation system */
Anyptr __MallocTemp__;
__p2c_jmp_buf *__top_jb;
void PASCAL_MAIN(argc, argv)
int argc;
char **argv;
{
P_argc = argc;
P_argv = argv;
__top_jb = NULL;
#ifdef LOCAL_INIT
LOCAL_INIT();
#endif
}
/* In case your system lacks these… */
long my_labs(x)
long x;
{
return((x > 0) ? x : -x);
}
#ifdef __STDC__
Anyptr my_memmove(Anyptr d, Const Anyptr s, size_t n)
#else
Anyptr my_memmove(d, s, n)
Anyptr d, s;
register int n;
#endif
{
register char *dd = (char *)d, *ss = (char *)s;
if (dd < ss || dd – ss >= n) {
memcpy(dd, ss, n);
} else if (n > 0) {
dd += n;
ss += n;
while (n– > 0)
*–dd = *–ss;
}
return d;
}
#ifdef __STDC__
Anyptr my_memcpy(Anyptr d, Const Anyptr s, size_t n)
#else
Anyptr my_memcpy(d, s, n)
Anyptr d, s;
register int n;
#endif
{
register char *ss = (char *)s, *dd = (char *)d;
while (n– > 0)
*dd++ = *ss++;
return d;
}
#ifdef __STDC__
int my_memcmp(Const Anyptr s1, Const Anyptr s2, size_t n)
#else
int my_memcmp(s1, s2, n)
Anyptr s1, s2;
register int n;
#endif
{
register char *a = (char *)s1, *b = (char *)s2;
register int i;
while (n– > 0)
if ((i = (*a++) – (*b++)) != 0)
return i;
return 0;
}
#ifdef __STDC__
Anyptr my_memset(Anyptr d, int c, size_t n)
#else
Anyptr my_memset(d, c, n)
Anyptr d;
register int c;
register int n;
#endif
{
register char *dd = (char *)d;
while (n– > 0)
*dd++ = c;
return d;
}
int my_toupper(c)
int c;
{
if (islower(c))
return _toupper(c);
else
return c;
}
int my_tolower(c)
int c;
{
if (isupper(c))
return _tolower(c);
else
return c;
}
long ipow(a, b)
long a, b;
{
long v;
if (a == 0 || a == 1)
return a;
if (a == -1)
return (b & 1) ? -1 : 1;
if (b < 0)
return 0;
if (a == 2)
return 1L << b;
v = (b & 1) ? a : 1;
while ((b >>= 1) > 0) {
a *= a;
if (b & 1)
v *= a;
}
return v;
}
/* Common string functions: */
/* Store in "ret" the substring of length "len" starting from "pos" (1-based).
Store a shorter or null string if out-of-range. Return "ret". */
char *strsub(ret, s, pos, len)
register char *ret, *s;
register int pos, len;
{
register char *s2;
if (–pos < 0 || len <= 0) {
*ret = 0;
return ret;
}
while (pos > 0) {
if (!*s++) {
*ret = 0;
return ret;
}
pos–;
}
s2 = ret;
while (–len >= 0) {
if (!(*s2++ = *s++))
return ret;
}
*s2 = 0;
return ret;
}
/* Return the index of the first occurrence of "pat" as a substring of "s",
starting at index "pos" (1-based). Result is 1-based, 0 if not found. */
int strpos2(s, pat, pos)
char *s;
register char *pat;
register int pos;
{
register char *cp, ch;
register int slen;
if (–pos < 0)
return 0;
slen = strlen(s) – pos;
cp = s + pos;
if (!(ch = *pat++))
return 0;
pos = strlen(pat);
slen -= pos;
while (–slen >= 0) {
if (*cp++ == ch && !strncmp(cp, pat, pos))
return cp – s;
}
return 0;
}
/* Case-insensitive version of strcmp. */
int strcicmp(s1, s2)
register char *s1, *s2;
{
register unsigned char c1, c2;
while (*s1) {
if (*s1++ != *s2++) {
if (!s2[-1])
return 1;
c1 = toupper(s1[-1]);
c2 = toupper(s2[-1]);
if (c1 != c2)
return c1 – c2;
}
}
if (*s2)
return -1;
return 0;
}
/* HP and Turbo Pascal string functions: */
/* Trim blanks at left end of string. */
char *strltrim(s)
register char *s;
{
while (Isspace(*s++)) ;
return s – 1;
}
/* Trim blanks at right end of string. */
char *strrtrim(s)
register char *s;
{
register char *s2 = s;
if (!*s)
return s;
while (*++s2) ;
while (s2 > s && Isspace(*–s2))
*s2 = 0;
return s;
}
/* Store in "ret" "num" copies of string "s". Return "ret". */
char *strrpt(ret, s, num)
char *ret;
register char *s;
register int num;
{
register char *s2 = ret;
register char *s1;
while (–num >= 0) {
s1 = s;
while ((*s2++ = *s1++)) ;
s2–;
}
return ret;
}
/* Store in "ret" string "s" with enough pad chars added to reach "size". */
char *strpad(ret, s, padchar, num)
char *ret;
register char *s;
register int padchar, num;
{
register char *d = ret;
if (s == d) {
while (*d++) ;
} else {
while ((*d++ = *s++)) ;
}
num -= (–d – ret);
while (–num >= 0)
*d++ = padchar;
*d = 0;
return ret;
}
/* Copy the substring of length "len" from index "spos" of "s" (1-based)
to index "dpos" of "d", lengthening "d" if necessary. Length and
indices must be in-range. */
void strmove(len, s, spos, d, dpos)
register char *s, *d;
register int len, spos, dpos;
{
s += spos – 1;
d += dpos – 1;
while (*d && –len >= 0)
*d++ = *s++;
if (len > 0) {
while (–len >= 0)
*d++ = *s++;
*d = 0;
}
}
/* Delete the substring of length "len" at index "pos" from "s".
Delete less if out-of-range. */
void strdelete(s, pos, len)
register char *s;
register int pos, len;
{
register int slen;
if (–pos < 0)
return;
slen = strlen(s) – pos;
if (slen <= 0)
return;
s += pos;
if (slen <= len) {
*s = 0;
return;
}
while ((*s = s[len])) s++;
}
/* Insert string "src" at index "pos" of "dst". */
void strinsert(src, dst, pos)
register char *src, *dst;
register int pos;
{
register int slen, dlen;
if (–pos < 0)
return;
dlen = strlen(dst);
dst += dlen;
dlen -= pos;
if (dlen <= 0) {
strcpy(dst, src);
return;
}
slen = strlen(src);
do {
dst[slen] = *dst;
–dst;
} while (–dlen >= 0);
dst++;
while (–slen >= 0)
*dst++ = *src++;
}
/* File functions */
/* Peek at next character of input stream; return EOF at end-of-file. */
int P_peek(f)
FILE *f;
{
int ch;
ch = fgetc(f);
if (ch == EOF)
return EOF;
ungetc(ch, f);
return (ch == '\n') ? ' ' : ch;
}
/* Check if at end of file, using Pascal "eof" semantics. End-of-file for
stdin is broken; remove the special case for it to be broken in a
different way. */
int P_eof(f)
FILE *f;
{
register int ch;
if (feof(f))
return 1;
ch = fgetc(f);
if (ch == EOF)
return 1;
ungetc(ch, f);
return 0;
}
/* Check if at end of line (or end of entire file). */
int P_eoln(f)
FILE *f;
{
register int ch;
ch = fgetc(f);
if (ch == EOF)
return 1;
ungetc(ch, f);
return (ch == '\n');
}
/* Read a packed array of characters from a file. */
Void P_readpaoc(f, s, len)
FILE *f;
char *s;
int len;
{
int ch;
for (;;) {
if (len <= 0)
return;
ch = fgetc(f);
if (ch == EOF || ch == '\n')
break;
*s++ = ch;
–len;
}
while (–len >= 0)
*s++ = ' ';
if (ch != EOF)
ungetc(ch, f);
}
Void P_readlnpaoc(f, s, len)
FILE *f;
char *s;
int len;
{
int ch;
for (;;) {
ch = fgetc(f);
if (ch == EOF || ch == '\n')
break;
if (len > 0) {
*s++ = ch;
–len;
}
}
while (–len >= 0)
*s++ = ' ';
}
/* Compute maximum legal "seek" index in file (0-based). */
long P_maxpos(f)
FILE *f;
{
long savepos = ftell(f);
long val;
if (fseek(f, 0L, SEEK_END))
return -1;
val = ftell(f);
if (fseek(f, savepos, SEEK_SET))
return -1;
return val;
}
/* Use packed array of char for a file name. */
Char *P_trimname(fn, len)
register Char *fn;
register int len;
{
static Char fnbuf[256];
register Char *cp = fnbuf;
while (–len >= 0 && *fn && !isspace(*fn))
*cp++ = *fn++;
*cp = 0;
return fnbuf;
}
/* Pascal's "memavail" doesn't make much sense in Unix with virtual memory.
We fix memory size as 10Meg as a reasonable compromise. */
long memavail()
{
return 10000000; /* worry about this later! */
}
long maxavail()
{
return memavail();
}
/* Sets are stored as an array of longs. S[0] is the size of the set;
S[N] is the N'th 32-bit chunk of the set. S[0] equals the maximum
I such that S[I] is nonzero. S[0] is zero for an empty set. Within
each long, bits are packed from lsb to msb. The first bit of the
set is the element with ordinal value 0. (Thus, for a "set of 5..99",
the lowest five bits of the first long are unused and always zero.) */
/* (Sets with 32 or fewer elements are normally stored as plain longs.) */
long *P_setunion(d, s1, s2) /* d := s1 + s2 */
register long *d, *s1, *s2;
{
long *dbase = d++;
register int sz1 = *s1++, sz2 = *s2++;
while (sz1 > 0 && sz2 > 0) {
*d++ = *s1++ | *s2++;
sz1–, sz2–;
}
while (–sz1 >= 0)
*d++ = *s1++;
while (–sz2 >= 0)
*d++ = *s2++;
*dbase = d – dbase – 1;
return dbase;
}
long *P_setint(d, s1, s2) /* d := s1 * s2 */
register long *d, *s1, *s2;
{
long *dbase = d++;
register int sz1 = *s1++, sz2 = *s2++;
while (–sz1 >= 0 && –sz2 >= 0)
*d++ = *s1++ & *s2++;
while (–d > dbase && !*d) ;
*dbase = d – dbase;
return dbase;
}
long *P_setdiff(d, s1, s2) /* d := s1 – s2 */
register long *d, *s1, *s2;
{
long *dbase = d++;
register int sz1 = *s1++, sz2 = *s2++;
while (–sz1 >= 0 && –sz2 >= 0)
*d++ = *s1++ & ~*s2++;
if (sz1 >= 0) {
while (sz1– >= 0)
*d++ = *s1++;
}
while (–d > dbase && !*d) ;
*dbase = d – dbase;
return dbase;
}
long *P_setxor(d, s1, s2) /* d := s1 / s2 */
register long *d, *s1, *s2;
{
long *dbase = d++;
register int sz1 = *s1++, sz2 = *s2++;
while (sz1 > 0 && sz2 > 0) {
*d++ = *s1++ ^ *s2++;
sz1–, sz2–;
}
while (–sz1 >= 0)
*d++ = *s1++;
while (–sz2 >= 0)
*d++ = *s2++;
while (–d > dbase && !*d) ;
*dbase = d – dbase;
return dbase;
}
int P_inset(val, s) /* val IN s */
register unsigned val;
register long *s;
{
register int bit;
bit = val % SETBITS;
val /= SETBITS;
if (val < *s++ && ((1L<<bit) & s[val]))
return 1;
return 0;
}
long *P_addset(s, val) /* s := s + [val] */
register long *s;
register unsigned val;
{
register long *sbase = s;
register int bit, size;
bit = val % SETBITS;
val /= SETBITS;
size = *s;
if (++val > size) {
s += size;
while (val > size)
*++s = 0, size++;
*sbase = size;
} else
s += val;
*s |= 1L<<bit;
return sbase;
}
long *P_addsetr(s, v1, v2) /* s := s + [v1..v2] */
register long *s;
register unsigned v1, v2;
{
register long *sbase = s;
register int b1, b2, size;
if ((int)v1 > (int)v2)
return sbase;
b1 = v1 % SETBITS;
v1 /= SETBITS;
b2 = v2 % SETBITS;
v2 /= SETBITS;
size = *s;
v1++;
if (++v2 > size) {
while (v2 > size)
s[++size] = 0;
s[v2] = 0;
*s = v2;
}
s += v1;
if (v1 == v2) {
*s |= (~((-2L)<<(b2-b1))) << b1;
} else {
*s++ |= (-1L) << b1;
while (++v1 < v2)
*s++ = -1;
*s |= ~((-2L) << b2);
}
return sbase;
}
long *P_remset(s, val) /* s := s – [val] */
register long *s;
register unsigned val;
{
register int bit;
bit = val % SETBITS;
val /= SETBITS;
if (++val <= *s) {
if (!(s[val] &= ~(1L<<bit)))
while (*s && !s[*s])
(*s)–;
}
return s;
}
int P_setequal(s1, s2) /* s1 = s2 */
register long *s1, *s2;
{
register int size = *s1++;
if (*s2++ != size)
return 0;
while (–size >= 0) {
if (*s1++ != *s2++)
return 0;
}
return 1;
}
int P_subset(s1, s2) /* s1 <= s2 */
register long *s1, *s2;
{
register int sz1 = *s1++, sz2 = *s2++;
if (sz1 > sz2)
return 0;
while (–sz1 >= 0) {
if (*s1++ & ~*s2++)
return 0;
}
return 1;
}
long *P_setcpy(d, s) /* d := s */
register long *d, *s;
{
register long *save_d = d;
#ifdef SETCPY_MEMCPY
memcpy(d, s, (*s + 1) * sizeof(long));
#else
register int i = *s + 1;
while (–i >= 0)
*d++ = *s++;
#endif
return save_d;
}
/* s is a "smallset", i.e., a 32-bit or less set stored
directly in a long. */
long *P_expset(d, s) /* d := s */
register long *d;
register long s;
{
if (s) {
d[1] = s;
*d = 1;
} else
*d = 0;
return d;
}
long P_packset(s) /* convert s to a small-set */
register long *s;
{
if (*s++)
return *s;
else
return 0;
}
/* Oregon Software Pascal extensions, courtesy of William Bader */
int P_getcmdline(l, h, line)
int l, h;
Char *line;
{
int i, len;
char *s;
h = h – l + 1;
len = 0;
for(i = 1; i < P_argc; i++) {
s = P_argv[i];
while (*s) {
if (len >= h) return len;
line[len++] = *s++;
}
if (len >= h) return len;
line[len++] = ' ';
}
return len;
}
Void TimeStamp(Day, Month, Year, Hour, Min, Sec)
int *Day, *Month, *Year, *Hour, *Min, *Sec;
{
#ifndef NO_TIME
struct tm *tm;
long clock;
time(&clock);
tm = localtime(&clock);
*Day = tm->tm_mday;
*Month = tm->tm_mon + 1; /* Jan = 0 */
*Year = tm->tm_year;
if (*Year < 1900)
*Year += 1900; /* year since 1900 */
*Hour = tm->tm_hour;
*Min = tm->tm_min;
*Sec = tm->tm_sec;
#endif
}
Void VAXdate(s)
char *s;
{
long clock;
char *c;
int i;
static int where[] = {8, 9, 0, 4, 5, 6, 0, 20, 21, 22, 23};
time(&clock);
c = ctime(&clock);
for (i = 0; i < 11; i++)
s[i] = my_toupper(c[where[i]]);
s[2] = '-';
s[6] = '-';
}
Void VAXtime(s)
char *s;
{
long clock;
char *c;
int i;
time(&clock);
c = ctime(&clock);
for (i = 0; i < 8; i++)
s[i] = c[i+11];
s[8] = '.';
s[9] = '0';
s[10] = '0';
}
/* SUN Berkeley Pascal extensions */
Void P_sun_argv(s, len, n)
register char *s;
register int len, n;
{
register char *cp;
if ((unsigned)n < P_argc)
cp = P_argv[n];
else
cp = "";
while (*cp && –len >= 0)
*s++ = *cp++;
while (–len >= 0)
*s++ = ' ';
}
int _OutMem()
{
return _Escape(-2);
}
int _CaseCheck()
{
return _Escape(-9);
}
int _NilCheck()
{
return _Escape(-3);
}
/* The following is suitable for the HP Pascal operating system.
It might want to be revised when emulating another system. */
char *_ShowEscape(buf, code, ior, prefix)
char *buf, *prefix;
int code, ior;
{
char *bufp;
if (prefix && *prefix) {
strcpy(buf, prefix);
strcat(buf, ": ");
bufp = buf + strlen(buf);
} else {
bufp = buf;
}
if (code == -10) {
sprintf(bufp, "Pascal system I/O error %d", ior);
switch (ior) {
case 3:
strcat(buf, " (illegal I/O request)");
break;
case 7:
strcat(buf, " (bad file name)");
break;
case FileNotFound: /*10*/
strcat(buf, " (file not found)");
break;
case FileNotOpen: /*13*/
strcat(buf, " (file not open)");
break;
case BadInputFormat: /*14*/
strcat(buf, " (bad input format)");
break;
case 24:
strcat(buf, " (not open for reading)");
break;
case 25:
strcat(buf, " (not open for writing)");
break;
case 26:
strcat(buf, " (not open for direct access)");
break;
case 28:
strcat(buf, " (string subscript out of range)");
break;
case EndOfFile: /*30*/
strcat(buf, " (end-of-file)");
break;
case FileWriteError: /*38*/
strcat(buf, " (file write error)");
break;
}
} else {
sprintf(bufp, "Pascal system error %d", code);
switch (code) {
case -2:
strcat(buf, " (out of memory)");
break;
case -3:
strcat(buf, " (reference to NIL pointer)");
break;
case -4:
strcat(buf, " (integer overflow)");
break;
case -5:
strcat(buf, " (divide by zero)");
break;
case -6:
strcat(buf, " (real math overflow)");
break;
case -8:
strcat(buf, " (value range error)");
break;
case -9:
strcat(buf, " (CASE value range error)");
break;
case -12:
strcat(buf, " (bus error)");
break;
case -20:
strcat(buf, " (stopped by user)");
break;
}
}
return buf;
}
int _Escape(code)
int code;
{
char buf[100];
P_escapecode = code;
if (__top_jb) {
__p2c_jmp_buf *jb = __top_jb;
__top_jb = jb->next;
longjmp(jb->jbuf, 1);
}
if (code == 0)
exit(EXIT_SUCCESS);
if (code == -1)
exit(EXIT_FAILURE);
fprintf(stderr, "%s\n", _ShowEscape(buf, P_escapecode, P_ioresult, ""));
exit(EXIT_FAILURE);
}
int _EscIO(code)
int code;
{
P_ioresult = code;
return _Escape(-10);
}
/* End. */

view raw

p2clib.c

hosted with ❤ by GitHub


#!/bin/csh -fb
if ($#argv == 0) then
echo "No filename given !"
exit
endif
if ($#argv > 1) then
echo "Too many parameters !"
exit
endif
rm -f $1.pc prr prd
pcom < $1.p && cp -f prr $1.pc && mv -f prr prd && pint && mv -f prr $1.out
rm -f prd prr

view raw

p4

hosted with ❤ by GitHub


@echo off
if "%1" == "" goto error
del %1.pc %1.out prr prd > NUL: 2>&1
pcom < %1.p && copy prr %1.pc > NUL: 2>&1 && move prr prd > NUL: 2>&1 && pint && move prr %1.out > NUL: 2>&1
del prd prr > NUL: 2>&1
goto end
:error
echo No filename given !
:end


view raw

p4.cmd

hosted with ❤ by GitHub


/* Output from p2c, the Pascal-to-C translator */
/* From input file "pcom.p" */
/* P2c command-line options: -M0 (due to bug in p2c) */
/* P2c options:
Language BERK
StructFiles 1 */
/* P2c produced macro calls "BUFEOF(stdin)",
which were edited to "P_eof(stdin)" */
/* Translation and editing done by I.J.A. van Geel
e-mail: I.J.A.vanGeel@twi.tudelft.nl */
/* Date: august 22 1996 */
/*$c+,t-,d-,l-*/
/************************************************
* *
* Portable Pascal compiler *
* ************************ *
* *
*Pascal P4 *
* *
* Authors: *
* Urs Ammann *
* Kesav Nori *
* Christian Jacobi *
* Address: *
* Institut Fuer Informatik *
* Eidg. Technische Hochschule *
* CH-8096 Zuerich *
* *
* This code is fully documented in the book *
* "Pascal Implementation" *
* by Steven Pemberton and Martin Daniels *
* published by Ellis Horwood, Chichester, UK *
* ISBN: 0-13-653-0311 *
* (also available in Japanese) *
* *
* Steven Pemberton, CWI/AA, *
* Kruislaan 413, 1098 SJ Amsterdam, NL *
* Steven.Pemberton@cwi.nl *
* *
************************************************/
#include "p2c.h"
#define displimit 20
#define maxlevel 10
#define intsize 1
#define intal 1
#define realsize 1
#define realal 1
#define charsize 1
#define charal 1
#define charmax 1
#define boolsize 1
#define boolal 1
#define ptrsize 1
#define adral 1
#define setsize 1
#define setal 1
#define stackal 1
#define stackelsize 1
#define strglgth 16
#define sethigh 47
#define setlow 0
#define ordmaxchar 63
#define ordminchar 0
#define maxint 32767
#define lcaftermarkstack 5
#define fileal charal
/* stackelsize = minimum size for 1 stackelement
= k*stackal
stackal = scm(all other al-constants)
charmax = scm(charsize,charal)
scm = smallest common multiple
lcaftermarkstack >= 4*ptrsize+max(x-size)
= k1*stackelsize */
#define maxstack 1
#define parmal stackal
#define parmsize stackelsize
#define recal stackal
#define filebuffer 4
#define maxaddr maxint
/*describing:*/
/*************/
/*basic symbols*/
/***************/
typedef enum {
ident, intconst, realconst, stringconst, notsy, mulop, addop, relop,
lparent, rparent, lbrack, rbrack, comma, semicolon, period, arrow, colon,
becomes, labelsy, constsy, typesy, varsy, funcsy, progsy, procsy, setsy,
packedsy, arraysy, recordsy, filesy, forwardsy, beginsy, ifsy, casesy,
repeatsy, whilesy, forsy, withsy, gotosy, endsy, elsesy, untilsy, ofsy,
dosy, tosy, downtosy, thensy, othersy
} symbol;
typedef enum {
mul, rdiv, andop, idiv, imod, plus, minus, orop, ltop, leop, geop, gtop,
neop, eqop, inop, noop
} operator_;
typedef long setofsys[3];
typedef enum {
letter, number, special, illegal, chstrquo, chcolon, chperiod, chlt, chgt,
chlparen, chspace
} chtp;
/*constants*/
/***********/
typedef long setty[sethigh / 32 + 2];
typedef enum {
reel, pset, strg
} cstclass;
typedef struct constant {
cstclass cclass;
union {
Char rval[strglgth];
setty pval;
struct {
char slgth;
Char sval[strglgth];
} U2;
} UU;
} constant;
typedef struct valu {
/*intval never set nor tested*/
boolean intval;
union {
long ival;
constant *valp;
} UU;
} valu;
/*data structures*/
/*****************/
typedef char levrange;
typedef short addrrange;
typedef enum {
scalar, subrange, pointer, power, arrays, records, files, tagfld, variant
} structform;
typedef enum {
standard, declared
} declkind;
typedef struct structure {
unsigned marked : 1; /*for test phase only*/
unsigned size : 15;
/* p2c: pcom.p, line 121: Note:
* Field width for form assumes enum structform has 9 elements [105] */
unsigned form : 4;
union {
struct {
/* p2c: pcom.p, line 122: Note:
* Field width for scalkind assumes enum declkind has 2 elements [105] */
unsigned scalkind : 1;
union {
struct identifier *fconst;
} UU;
} U0;
struct {
struct structure *rangetype;
valu min, max;
} U1;
struct structure *eltype;
struct structure *elset;
struct {
struct structure *aeltype, *inxtype;
} U4;
struct {
struct identifier *fstfld;
struct structure *recvar;
} U5;
struct structure *filtype;
struct {
struct identifier *tagfieldp;
struct structure *fstvar;
} U7;
struct {
struct structure *nxtvar, *subvar;
valu varval;
} U8;
} UU;
} structure;
/*names*/
/*******/
typedef enum {
types, konst, vars, field, proc, func
} idclass;
typedef long setofids;
typedef enum {
actual, formal
} idkind;
typedef Char alpha[8];
typedef struct identifier {
alpha name;
struct identifier *llink, *rlink;
structure *idtype;
struct identifier *next;
/* p2c: pcom.p, line 145:
* Note: Field width for klass assumes enum idclass has 6 elements [105] */
unsigned klass : 3;
union {
valu values;
struct {
unsigned vkind : 1;
/* p2c: pcom.p, line 148:
* Note: Field width for vkind assumes enum idkind has 2 elements [105] */
unsigned vlev : 4, vaddr : 15;
} U2;
unsigned fldaddr;
struct {
/* p2c: pcom.p, line 150: Note:
* Field width for pfdeckind assumes enum declkind has 2 elements [105] */
unsigned pfdeckind : 1;
union {
unsigned key;
struct {
unsigned pflev : 4;
long pfname;
/* p2c: pcom.p, line 153:
* Note: Field width for pfkind assumes enum idkind has 2 elements [105] */
unsigned pfkind : 1;
union {
struct {
unsigned forwdecl : 1, externl : 1;
} U0;
} UU;
} U1;
} UU;
} U4;
} UU;
} identifier;
typedef char disprange;
typedef enum {
blck, crec, vrec, rec
} where;
/*expressions*/
/*************/
typedef enum {
cst, varbl, expr
} attrkind;
typedef enum {
drct, indrct, inxd
} vaccess;
typedef struct attr {
structure *typtr;
attrkind kind;
union {
valu cval;
struct {
vaccess access;
union {
struct {
levrange vlevel;
addrrange dplmt;
} U0;
addrrange idplmt;
} UU;
} U1;
} UU;
} attr;
typedef struct testpointer {
structure *elt1, *elt2;
struct testpointer *lasttestp;
} testpointer;
/*labels*/
/********/
typedef struct labl {
struct labl *nextlab;
boolean defined_;
long labval, labname;
} labl;
typedef struct filerec {
alpha filename;
struct filerec *nextfile;
} filerec;
/*————————————————————————-*/
typedef struct _REC_display {
/*=blck: id is variable id*/
identifier *fname;
labl *flabel; /*=crec: id is field id in record with*/
/* p2c: pcom.p, line 254:
* Note: Field width for occur assumes enum where has 4 elements [105] */
/* constant address*/
unsigned occur : 2;
union {
struct {
levrange clev; /*=vrec: id is field id in record with*/
addrrange cdspl; /* variable address*/
} U1;
addrrange vdspl;
} UU;
} _REC_display;
typedef struct _REC_errlist {
long pos;
unsigned nmr : 9;
} _REC_errlist;
Static _TEXT prr; /* comment this out when compiling with pcom */
/*returned by source program scanner
insymbol:
**********/
Static symbol sy; /*last symbol*/
Static operator_ op; /*classification of last symbol*/
Static valu val; /*value of last constant*/
Static long lgth; /*length of last string constant*/
Static alpha id; /*last identifier (possibly truncated)*/
Static char kk; /*nr of chars in last identifier*/
Static Char ch; /*last character*/
Static boolean eol; /*end of line flag*/
/*counters:*/
/***********/
Static long chcnt; /*character counter*/
Static addrrange lc, ic; /*data location and instruction counter*/
Static long linecount;
/*switches:*/
/***********/
Static boolean dp; /*declaration part*/
Static boolean prterr;
/*to allow forward references in pointer type
declaration by suppressing error message*/
Static boolean list, prcode, prtables;
/*output options for
— source program listing
— printing symbolic code
— displaying ident and struct tables
–> procedure option*/
Static boolean debug;
/*pointers:*/
/***********/
Static structure *parmptr, *intptr, *realptr, *charptr, *boolptr, *nilptr,
*textptr;
/*pointers to entries of standard ids*/
Static identifier *utypptr, *ucstptr, *uvarptr, *ufldptr, *uprcptr, *ufctptr;
/*pointers to entries for undeclared ids*/
Static identifier *fwptr; /*head of chain of forw decl type ids*/
Static filerec *fextfilep; /*head of chain of external files*/
Static testpointer *globtestp; /*last testpointer*/
/*bookkeeping of declaration levels:*/
/************************************/
Static levrange level; /*current static level*/
Static disprange disx; /*level of last id searched by searchid*/
Static disprange top; /*top of display*/
/*where: means:*/
Static _REC_display display[displimit + 1]; /* –> procedure withstatement*/
/*error messages:*/
/*****************/
Static char errinx; /*nr of errors in current source line*/
Static _REC_errlist errlist[10];
Static boolean input_ok = true;
/*expression compilation:*/
/*************************/
Static attr gattr; /*describes the expr currently compiled*/
/*structured constants:*/
/***********************/
Static setofsys constbegsys, simptypebegsys, typebegsys, blockbegsys,
selectsys, facbegsys, statbegsys, typedels;
Static chtp chartp[256];
/*nr. of res. words*/
Static alpha rw[35];
/*nr. of res. words + 1*/
Static char frw[9];
/*nr. of res. words*/
Static symbol rsy[35];
Static symbol ssy[256];
/*nr. of res. words*/
Static operator_ rop[35];
Static operator_ sop[256];
Static alpha na[35];
Static Char mn[61][4];
Static Char sna[23][4];
Static schar cdx[61];
Static schar pdx[23];
Static long ordint[256];
Static long intlabel, mxint10, digmax;
/*————————————————————————-*/
Static void mark_(long **p)
{
}
Static void release_(long *p)
{
}
Static void endofline(void)
{
long lastpos, freepos, currpos, currnmr, f, k, FORLIM;
_REC_errlist *WITH;
/*endofline*/
if (errinx > 0) { /*output error messages*/
printf("%6ld%9s", linecount, " **** ");
lastpos = 0;
freepos = 1;
FORLIM = errinx;
for (k = 0; k < FORLIM; k++) {
WITH = &errlist[k];
currpos = WITH->pos;
currnmr = WITH->nmr;
if (currpos == lastpos)
putchar(',');
else {
while (freepos < currpos) {
putchar(' ');
freepos++;
}
putchar('^');
lastpos = currpos;
}
if (currnmr < 10)
f = 1;
else if (currnmr < 100)
f = 2;
else
f = 3;
printf("%*ld", (int)f, currnmr);
freepos += f + 1;
}
putchar('\n');
errinx = 0;
}
linecount++;
if (list & (!P_eof(stdin))) {
printf("%6ld%2s", linecount, " ");
if (dp)
printf("%7d", lc);
else
printf("%7d", ic);
putchar(' ');
}
chcnt = 0;
}
Static void error(long ferrnr)
{
/*error*/
if (errinx >= 9) {
errlist[9].nmr = 255;
errinx = 10;
} else {
errinx++;
errlist[errinx – 1].nmr = ferrnr;
}
errlist[errinx – 1].pos = chcnt;
input_ok = false;
}
/* Local variables for insymbol: */
struct LOC_insymbol {
boolean test;
} ;
Local void nextch(struct LOC_insymbol *LINK)
{
if (eol) {
if (list)
putchar('\n');
endofline();
}
if (P_eof(stdin)) {
printf(" *** eof encountered\n");
LINK->test = false;
return;
}
eol = P_eoln(stdin);
ch = fgetc (stdin);
if (ch == '\n')
ch = ' ';
else
if (isupper (ch))
ch = tolower (ch);
if (list)
putchar(ch);
chcnt++;
}
Local void options(struct LOC_insymbol *LINK)
{
/*options*/
do {
nextch(LINK);
if (ch != '*') {
if (ch == 't') {
nextch(LINK);
prtables = (ch == '+');
} else {
if (ch == 'l') {
nextch(LINK);
list = (ch == '+');
if (!list)
putchar('\n');
} else {
if (ch == 'd') {
nextch(LINK);
debug = (ch == '+');
} else {
if (ch == 'c') {
nextch(LINK);
prcode = (ch == '+');
}
}
}
}
nextch(LINK);
}
} while (ch == ',');
}
Static void insymbol(void)
{
/*read next basic symbol of source program and return its
description in the global variables sy, op, id, val and lgth*/
struct LOC_insymbol V;
long i, k;
Char digit[strglgth];
Char string[strglgth];
constant *lvp;
long FORLIM;
/*insymbol*/
_L1:
do {
while ((ch == ' ' || ch == '\t') && !eol)
nextch(&V);
V.test = eol;
if (V.test)
nextch(&V);
} while (V.test);
/*
if (P_eof (stdin)) {
sy = othersy;
op = noop;
error(399);
return;
}
*/
if (chartp[ch] == illegal) {
sy = othersy;
op = noop;
error(399);
nextch(&V);
return;
}
switch (chartp[ch]) {
case letter:
k = 0;
do {
if (k < 8) {
k++;
id[k – 1] = ch;
}
nextch(&V);
} while (((1L << ((long)chartp[ch])) & ((1L << ((long)special)) |
(1L << ((long)illegal)) | (1L << ((long)chstrquo)) |
(1L << ((long)chcolon)) | (1L << ((long)chperiod)) |
(1L << ((long)chlt)) | (1L << ((long)chgt)) |
(1L << ((long)chlparen)) | (1L << ((long)chspace)))) == 0);
if (k >= kk)
kk = k;
else {
do {
id[kk – 1] = ' ';
kk–;
} while (kk != k);
}
FORLIM = frw[k] – 2;
for (i = frw[k – 1] – 1; i <= FORLIM; i++) {
if (!strncmp(rw[i], id, sizeof(alpha))) {
sy = rsy[i];
op = rop[i];
goto _L2;
}
}
sy = ident;
op = noop;
_L2: ;
break;
case number:
op = noop;
i = 0;
do {
i++;
if (i <= digmax)
digit[i – 1] = ch;
nextch(&V);
} while (chartp[ch] == number);
if (((ch == '.') & (P_peek(stdin) != '.')) || ch == 'e') {
k = i;
if (ch == '.') {
k++;
if (k <= digmax)
digit[k – 1] = ch;
nextch(&V); /*if ch = '.' then begin ch := ':'; goto 3 end;*/
if (chartp[ch] != number)
error(201);
else {
do {
k++;
if (k <= digmax)
digit[k – 1] = ch;
nextch(&V);
} while (chartp[ch] == number);
}
}
if (ch == 'e') {
k++;
if (k <= digmax)
digit[k – 1] = ch;
nextch(&V);
if (ch == '+' || ch == '-') {
k++;
if (k <= digmax)
digit[k – 1] = ch;
nextch(&V);
}
if (chartp[ch] != number)
error(201);
else {
do {
k++;
if (k <= digmax)
digit[k – 1] = ch;
nextch(&V);
} while (chartp[ch] == number);
}
}
/* p2c: pcom.p, line 454:
* Note: No SpecialMalloc form known for CONSTANT.REEL [187] */
lvp = Malloc(sizeof(constant));
sy = realconst;
lvp->cclass = reel;
for (i = 0; i < strglgth; i++)
lvp->UU.rval[i] = ' ';
if (k <= digmax) {
for (i = 2; i <= k + 1; i++)
lvp->UU.rval[i – 1] = digit[i – 2];
} else {
error(203);
lvp->UU.rval[1] = '0';
lvp->UU.rval[2] = '.';
lvp->UU.rval[3] = '0';
}
val.UU.valp = lvp;
} else {
if (i > digmax) {
error(203);
val.UU.ival = 0;
} else {
val.UU.ival = 0;
for (k = 0; k < i; k++) {
if (val.UU.ival <= mxint10)
val.UU.ival = val.UU.ival * 10 + ordint[digit[k]];
else {
error(203);
val.UU.ival = 0;
}
}
sy = intconst;
}
}
break;
case chstrquo:
lgth = 0;
sy = stringconst;
op = noop;
do {
do {
nextch(&V);
lgth++;
if (lgth <= strglgth)
string[lgth – 1] = ch;
} while (!(eol || ch == '\''));
if (eol)
error(202);
else
nextch(&V);
} while (ch == '\'');
lgth–; /*now lgth = nr of chars in string*/
if (lgth == 0)
error(205);
else {
if (lgth == 1)
val.UU.ival = string[0];
else {
lvp = Malloc(sizeof(constant));
lvp->cclass = strg;
if (lgth > strglgth) {
error(399);
lgth = strglgth;
}
lvp->UU.U2.slgth = lgth;
FORLIM = lgth;
for (i = 0; i < FORLIM; i++)
lvp->UU.U2.sval[i] = string[i];
val.UU.valp = lvp;
}
}
break;
case chcolon:
op = noop;
nextch(&V);
if (ch == '=') {
sy = becomes;
nextch(&V);
} else
sy = colon;
break;
case chperiod:
op = noop;
nextch(&V);
if (ch == '.') {
sy = colon;
nextch(&V);
} else
sy = period;
break;
case chlt:
nextch(&V);
sy = relop;
if (ch == '=') {
op = leop;
nextch(&V);
} else {
if (ch == '>') {
op = neop;
nextch(&V);
} else
op = ltop;
}
break;
case chgt:
nextch(&V);
sy = relop;
if (ch == '=') {
op = geop;
nextch(&V);
} else
op = gtop;
break;
case chlparen:
nextch(&V);
if (ch == '*') {
nextch(&V);
if (ch == '$')
options(&V);
do {
while ((ch != '*') & (!P_eof(stdin)))
nextch(&V);
nextch(&V);
} while (!((ch == ')') | P_eof(stdin)));
nextch(&V);
goto _L1;
}
sy = lparent;
op = noop;
break;
case special:
sy = ssy[ch];
op = sop[ch];
nextch(&V);
break;
case chspace:
sy = othersy;
break;
}/*case*/
/* p2c: pcom.p, line 493:
* Note: No SpecialMalloc form known for CONSTANT.STRG [187] */
}
Static void enterid(identifier *fcp)
{
/*enter id pointed at by fcp into the name-table,
which on each declaration level is organised as
an unbalanced binary tree*/
alpha nam;
identifier *lcp, *lcp1;
boolean lleft;
/*enterid*/
memcpy(nam, fcp->name, sizeof(alpha));
lcp = display[top].fname;
if (lcp == NULL)
display[top].fname = fcp;
else {
do {
lcp1 = lcp;
if (!strncmp(lcp->name, nam, sizeof(alpha)))
{ /*name conflict, follow right link*/
error(101);
lcp = lcp->rlink;
lleft = false;
} else {
if (strncmp(lcp->name, nam, sizeof(alpha)) < 0) {
lcp = lcp->rlink;
lleft = false;
} else {
lcp = lcp->llink;
lleft = true;
}
}
} while (lcp != NULL);
if (lleft)
lcp1->llink = fcp;
else
lcp1->rlink = fcp;
}
fcp->llink = NULL;
fcp->rlink = NULL;
}
Static void searchsection(identifier *fcp, identifier **fcp1)
{
/*to find record fields and forward declared procedure id's
–> procedure proceduredeclaration
–> procedure selector*/
/*searchsection*/
while (fcp != NULL) {
if (!strncmp(fcp->name, id, sizeof(alpha)))
goto _L1;
if (strncmp(fcp->name, id, sizeof(alpha)) < 0)
fcp = fcp->rlink;
else
fcp = fcp->llink;
}
_L1:
*fcp1 = fcp;
}
Static void searchid(setofids fidcls, identifier **fcp)
{
identifier *lcp;
/*searchid*/
for (disx = top; disx >= 0; disx–) {
lcp = display[disx].fname;
while (lcp != NULL) {
if (strncmp(lcp->name, id, sizeof(alpha))) {
if (strncmp(lcp->name, id, sizeof(alpha)) < 0)
lcp = lcp->rlink;
else
lcp = lcp->llink;
continue;
}
if (((1L << lcp->klass) & fidcls) != 0)
goto _L1;
if (prterr)
error(103);
lcp = lcp->rlink;
}
}
/*search not successful; suppress error message in case
of forward referenced type id in pointer type definition
–> procedure simpletype*/
if (prterr) {
error(104);
/*to avoid returning nil, reference an entry
for an undeclared id of appropriate class
–> procedure enterundecl*/
if (((1L << ((long)types)) & fidcls) != 0)
lcp = utypptr;
else {
if (((1L << ((long)vars)) & fidcls) != 0)
lcp = uvarptr;
else {
if (((1L << ((long)field)) & fidcls) != 0)
lcp = ufldptr;
else {
if (((1L << ((long)konst)) & fidcls) != 0)
lcp = ucstptr;
else {
if (((1L << ((long)proc)) & fidcls) != 0)
lcp = uprcptr;
else
lcp = ufctptr;
}
}
}
}
}
_L1:
*fcp = lcp;
}
Static void getbounds(structure *fsp, long *fmin, long *fmax)
{
/*get internal bounds of subrange or scalar type*/
/*assume fsp<>intptr and fsp<>realptr*/
/*getbounds*/
*fmin = 0;
*fmax = 0;
if (fsp == NULL)
return;
if ((structform)fsp->form == subrange) {
*fmin = fsp->UU.U1.min.UU.ival;
*fmax = fsp->UU.U1.max.UU.ival;
return;
}
if (fsp == charptr) {
*fmin = ordminchar;
*fmax = ordmaxchar;
} else {
if (fsp->UU.U0.UU.fconst != NULL)
*fmax = fsp->UU.U0.UU.fconst->UU.values.UU.ival;
}
}
Static long alignquot(structure *fsp)
{
long Result;
/*alignquot*/
Result = 1;
if (fsp == NULL)
return Result;
switch ((structform)fsp->form) {
case scalar:
if (fsp == intptr)
Result = intal;
else if (fsp == boolptr)
Result = boolal;
else if ((declkind)fsp->UU.U0.scalkind == declared)
Result = intal;
else if (fsp == charptr)
Result = charal;
else if (fsp == realptr)
Result = realal;
else
Result = parmal;
break;
case subrange:
Result = alignquot(fsp->UU.U1.rangetype);
break;
case pointer:
Result = adral;
break;
case power:
Result = setal;
break;
case files:
Result = fileal;
break;
case arrays:
Result = alignquot(fsp->UU.U4.aeltype);
break;
case records:
Result = recal;
break;
case variant:
case tagfld:
error(501);
break;
}
return Result;
/*parmptr*/
}
Static void align(structure *fsp, addrrange *flc)
{
long k, l;
/*align*/
k = alignquot(fsp);
l = *flc – 1;
*flc = l + k – (k + l) % k;
}
/* Local variables for printtables: */
struct LOC_printtables {
disprange lim;
} ;
Local void followctp(identifier *fp, struct LOC_printtables *LINK);
Local void markctp(identifier *fp);
Local void markstp(structure *fp)
{
/*mark data structures, prevent cycles*/
/*markstp*/
if (fp == NULL)
return;
fp->marked = true;
switch ((structform)fp->form) { /*with*/
case scalar:
/* blank case */
break;
case subrange:
markstp(fp->UU.U1.rangetype);
break;
case pointer:
/* blank case */
break;
/*don't mark eltype: cycle possible; will be marked
anyway, if fp = true*/
case power:
markstp(fp->UU.elset);
break;
case arrays:
markstp(fp->UU.U4.aeltype);
markstp(fp->UU.U4.inxtype);
break;
case records:
markctp(fp->UU.U5.fstfld);
markstp(fp->UU.U5.recvar);
break;
case files:
markstp(fp->UU.filtype);
break;
case tagfld:
markstp(fp->UU.U7.fstvar);
break;
case variant:
markstp(fp->UU.U8.nxtvar);
markstp(fp->UU.U8.subvar);
break;
}/*case*/
}
Local void markctp(identifier *fp)
{
/*markctp*/
if (fp == NULL)
return;
markctp(fp->llink);
markctp(fp->rlink);
markstp(fp->idtype);
}
Local void marker(struct LOC_printtables *LINK)
{
/*mark data structure entries to avoid multiple printout*/
long i, FORLIM;
/*marker*/
FORLIM = LINK->lim;
for (i = top; i >= FORLIM; i–)
markctp(display[i].fname);
}
Local void followstp(structure *fp, struct LOC_printtables *LINK)
{
/*followstp*/
if (fp == NULL)
return;
if (!fp->marked) {
return;
} /*if marked*/
fp->marked = false;
printf("%4c%6ld%10d", ' ', (long)fp, fp->size);
switch ((structform)fp->form) {
case scalar:
printf("%10s", "scalar");
if ((declkind)fp->UU.U0.scalkind == standard)
printf("%10s", "standard");
else
printf("%10s%4c%6ld", "declared", ' ', (long)fp->UU.U0.UU.fconst);
putchar('\n');
break;
case subrange:
printf("%10s%4c%6ld", "subrange", ' ', (long)fp->UU.U1.rangetype);
if (fp->UU.U1.rangetype != realptr)
printf("%12ld%12ld", fp->UU.U1.min.UU.ival, fp->UU.U1.max.UU.ival);
else {
if (fp->UU.U1.min.UU.valp != NULL && fp->UU.U1.max.UU.valp != NULL)
printf(" %.9s %.9s",
fp->UU.U1.min.UU.valp->UU.rval,
fp->UU.U1.max.UU.valp->UU.rval);
/* p2c: pcom.p, line 742: Note:
* Format for packed-array-of-char will work only if width < length [321] */
/* p2c: pcom.p, line 743: Note:
* Format for packed-array-of-char will work only if width < length [321] */
}
putchar('\n');
followstp(fp->UU.U1.rangetype, LINK);
break;
case pointer:
printf("%10s%4c%6ld\n", "pointer", ' ', (long)fp->UU.eltype);
break;
case power:
printf("%10s%4c%6ld\n", "set", ' ', (long)fp->UU.elset);
followstp(fp->UU.elset, LINK);
break;
case arrays:
printf("%10s%4c%6ld%4c%6ld\n",
"array", ' ', (long)fp->UU.U4.aeltype, ' ',
(long)fp->UU.U4.inxtype);
followstp(fp->UU.U4.aeltype, LINK);
followstp(fp->UU.U4.inxtype, LINK);
break;
case records:
printf("%10s%4c%6ld%4c%6ld\n",
"record", ' ', (long)fp->UU.U5.fstfld, ' ',
(long)fp->UU.U5.recvar);
followctp(fp->UU.U5.fstfld, LINK);
followstp(fp->UU.U5.recvar, LINK);
break;
case files:
printf("%10s%4c%6ld", "file", ' ', (long)fp->UU.filtype);
followstp(fp->UU.filtype, LINK);
break;
case tagfld:
printf("%10s%4c%6ld%4c%6ld\n",
"tagfld", ' ', (long)fp->UU.U7.tagfieldp, ' ',
(long)fp->UU.U7.fstvar);
followstp(fp->UU.U7.fstvar, LINK);
break;
case variant:
printf("%10s%4c%6ld%4c%6ld%12ld\n",
"variant", ' ', (long)fp->UU.U8.nxtvar, ' ',
(long)fp->UU.U8.subvar, fp->UU.U8.varval.UU.ival);
followstp(fp->UU.U8.nxtvar, LINK);
followstp(fp->UU.U8.subvar, LINK);
break;
}/*case*/
}
Local void followctp(identifier *fp, struct LOC_printtables *LINK)
{
long i;
constant *WITH1;
long FORLIM;
/*followctp*/
if (fp == NULL)
return;
printf("%4c%6ld %.8s%4c%6ld%4c%6ld%4c%6ld",
' ', (long)fp, fp->name, ' ', (long)fp->llink, ' ', (long)fp->rlink,
' ', (long)fp->idtype);
switch ((idclass)fp->klass) { /*case*/
case types:
printf("%10s", "type");
break;
case konst:
printf("%10s%4c%6ld", "constant", ' ', (long)fp->next);
if (fp->idtype != NULL) {
if (fp->idtype == realptr) {
if (fp->UU.values.UU.valp != NULL)
printf(" %.9s", fp->UU.values.UU.valp->UU.rval);
/* p2c: pcom.p, line 789: Note:
* Format for packed-array-of-char will work only if width < length [321] */
} else {
if ((structform)fp->idtype->form == arrays) { /*stringconst*/
if (fp->UU.values.UU.valp != NULL) {
putchar(' ');
WITH1 = fp->UU.values.UU.valp;
FORLIM = WITH1->UU.U2.slgth;
for (i = 0; i < FORLIM; i++)
putchar(WITH1->UU.U2.sval[i]);
}
} else
printf("%12ld", fp->UU.values.UU.ival);
}
}
break;
case vars:
printf("%10s", "variable");
if ((idkind)fp->UU.U2.vkind == actual)
printf("%10s", "actual");
else
printf("%10s", "formal");
printf("%4c%6ld%12d%4c%6d",
' ', (long)fp->next, fp->UU.U2.vlev, ' ', fp->UU.U2.vaddr);
break;
case field:
printf("%10s%4c%6ld%4c%6d",
"field", ' ', (long)fp->next, ' ', fp->UU.fldaddr);
break;
case proc:
case func:
if ((idclass)fp->klass == proc)
printf("%10s", "procedure");
else
printf("%10s", "function");
if ((declkind)fp->UU.U4.pfdeckind == standard)
printf("%10s%10d", "standard", fp->UU.U4.UU.key);
else {
printf("%10s%4c%6ld", "declared", ' ', (long)fp->next);
printf("%12d%4c%6ld",
fp->UU.U4.UU.U1.pflev, ' ', fp->UU.U4.UU.U1.pfname);
if ((idkind)fp->UU.U4.UU.U1.pfkind == actual) {
printf("%10s", "actual");
if (fp->UU.U4.UU.U1.UU.U0.forwdecl)
printf("%10s", "forward");
else
printf("%10s", "notforward");
if (fp->UU.U4.UU.U1.UU.U0.externl)
printf("%10s", "extern");
else
printf("%10s", "not extern");
} else
printf("%10s", "formal");
}
break;
}
putchar('\n');
followctp(fp->llink, LINK);
followctp(fp->rlink, LINK);
followstp(fp->idtype, LINK); /*with*/
}
Static void printtables(boolean fb)
{
/*print data structure and name table*/
struct LOC_printtables V;
disprange i, FORLIM;
/*printtables*/
printf("\n\n\n");
if (fb)
V.lim = 0;
else {
V.lim = top;
printf(" local");
}
printf(" tables \n\n");
marker(&V);
FORLIM = V.lim;
for (i = top; i >= FORLIM; i–)
followctp(display[i].fname, &V);
putchar('\n');
if (!eol)
printf("%*c", (int)(chcnt + 16), ' ');
}
Static void genlabel(long *nxtlab)
{
/*genlabel*/
intlabel++;
*nxtlab = intlabel;
}
Static void block(long *fsys, symbol fsy, identifier *fprocp);
#define cstoccmax 65
#define cixmax 1000
typedef char oprange;
typedef struct caseinfo {
struct caseinfo *next;
long csstart, cslab;
} caseinfo;
/* Local variables for block: */
struct LOC_block {
setofsys fsys;
identifier *fprocp;
boolean test;
} ;
Local void typ(long *fsys, structure **fsp, addrrange *fsize,
struct LOC_block *LINK);
Local void skip(long *fsys, struct LOC_block *LINK)
{
/*skip input string until relevant symbol found*/
/*skip*/
if (P_eof(stdin))
return;
while ((!P_inset(sy, fsys)) & (!P_eof(stdin)))
insymbol();
if (!P_inset(sy, fsys))
insymbol();
}
Local void constant_(long *fsys, structure **fsp, valu *fvalu,
struct LOC_block *LINK)
{
structure *lsp;
identifier *lcp;
enum {
none, pos_, neg
} sign;
constant *lvp;
char i;
setofsys SET;
/*constant*/
lsp = NULL;
fvalu->UU.ival = 0;
if (!P_inset(sy, constbegsys)) {
error(50);
skip(P_setunion(SET, fsys, constbegsys), LINK);
}
if (P_inset(sy, constbegsys)) {
if (sy == stringconst) {
if (lgth == 1)
lsp = charptr;
else {
lsp = Malloc(sizeof(structure));
lsp->UU.U4.aeltype = charptr;
lsp->UU.U4.inxtype = NULL;
lsp->size = lgth;
(structform)lsp->form = arrays;
}
*fvalu = val;
insymbol();
} else {
sign = none;
if (sy == addop &&
((1L << ((long)op)) & ((1L << ((long)plus)) | (1L << ((long)minus)))) !=
0) {
if (op == plus)
sign = pos_;
else
sign = neg;
insymbol();
}
if (sy == ident) {
searchid(1L << ((long)konst), &lcp);
lsp = lcp->idtype;
*fvalu = lcp->UU.values;
if (sign != none) {
if (lsp == intptr) {
if (sign == neg)
fvalu->UU.ival = -fvalu->UU.ival;
} else {
if (lsp == realptr) {
if (sign == neg) {
lvp = Malloc(sizeof(constant));
if (fvalu->UU.valp->UU.rval[0] == '-')
lvp->UU.rval[0] = '+';
else
lvp->UU.rval[0] = '-';
for (i = 1; i < strglgth; i++)
lvp->UU.rval[i] = fvalu->UU.valp->UU.rval[i];
fvalu->UU.valp = lvp;
}
/* p2c: pcom.p, line 903:
* Note: No SpecialMalloc form known for CONSTANT.REEL [187] */
} else
error(105);
}
}
insymbol();
} else {
if (sy == intconst) {
if (sign == neg)
val.UU.ival = -val.UU.ival;
lsp = intptr;
*fvalu = val;
insymbol();
} else {
if (sy == realconst) {
if (sign == neg)
val.UU.valp->UU.rval[0] = '-';
lsp = realptr;
*fvalu = val;
insymbol();
} else {
error(106);
skip(fsys, LINK);
}
}
}
}
if (!P_inset(sy, fsys)) {
error(6);
skip(fsys, LINK);
}
}
*fsp = lsp;
/* p2c: pcom.p, line 877:
* Note: No SpecialMalloc form known for STRUCTURE.ARRAYS [187] */
}
Local boolean equalbounds(structure *fsp1, structure *fsp2,
struct LOC_block *LINK)
{
long lmin1, lmin2, lmax1, lmax2;
/*equalbounds*/
if (fsp1 == NULL || fsp2 == NULL)
return true;
else {
getbounds(fsp1, &lmin1, &lmax1);
getbounds(fsp2, &lmin2, &lmax2);
return (lmin1 == lmin2 && lmax1 == lmax2);
}
}
Local boolean comptypes(structure *fsp1, structure *fsp2,
struct LOC_block *LINK)
{
/*decide whether structures pointed at by fsp1 and fsp2 are compatible*/
boolean Result;
identifier *nxt1, *nxt2;
boolean comp;
testpointer *ltestp1, *ltestp2, *WITH;
/*comptypes*/
if (fsp1 == fsp2)
return true;
else {
if (fsp1 != NULL && fsp2 != NULL) {
if ((structform)fsp1->form == (structform)fsp2->form) {
switch ((structform)fsp1->form) {
case scalar:
Result = false;
break;
/* identical scalars declared on different levels are
not recognized to be compatible*/
case subrange:
Result = comptypes(fsp1->UU.U1.rangetype, fsp2->UU.U1.rangetype,
LINK);
break;
case pointer:
comp = false;
ltestp1 = globtestp;
ltestp2 = globtestp;
while (ltestp1 != NULL) {
WITH = ltestp1;
if (WITH->elt1 == fsp1->UU.eltype && WITH->elt2 == fsp2->UU.eltype)
comp = true;
ltestp1 = WITH->lasttestp;
}
if (!comp) {
ltestp1 = Malloc(sizeof(testpointer));
ltestp1->elt1 = fsp1->UU.eltype;
ltestp1->elt2 = fsp2->UU.eltype;
ltestp1->lasttestp = globtestp;
globtestp = ltestp1;
comp = comptypes(fsp1->UU.eltype, fsp2->UU.eltype, LINK);
}
Result = comp;
globtestp = ltestp2;
break;
case power:
Result = comptypes(fsp1->UU.elset, fsp2->UU.elset, LINK);
break;
case arrays:
comp = comptypes(fsp1->UU.U4.aeltype, fsp2->UU.U4.aeltype, LINK) &
comptypes(fsp1->UU.U4.inxtype, fsp2->UU.U4.inxtype, LINK);
Result = (comp && fsp1->size == fsp2->size) & equalbounds(
fsp1->UU.U4.inxtype, fsp2->UU.U4.inxtype, LINK);
break;
case records:
nxt1 = fsp1->UU.U5.fstfld;
nxt2 = fsp2->UU.U5.fstfld;
comp = true;
while (nxt1 != NULL && nxt2 != NULL) {
comp &= comptypes(nxt1->idtype, nxt2->idtype, LINK);
nxt1 = nxt1->next;
nxt2 = nxt2->next;
}
Result = (comp && nxt1 == NULL && nxt2 == NULL &&
fsp1->UU.U5.recvar == NULL && fsp2->UU.U5.recvar == NULL);
break;
/*identical records are recognized to be compatible
iff no variants occur*/
case files:
Result = comptypes(fsp1->UU.filtype, fsp2->UU.filtype, LINK);
break;
}/*case*/
return Result;
} else { /*fsp1^.form <> fsp2^.form*/
if ((structform)fsp1->form == subrange)
return (comptypes(fsp1->UU.U1.rangetype, fsp2, LINK));
else {
if ((structform)fsp2->form == subrange)
return (comptypes(fsp1, fsp2->UU.U1.rangetype, LINK));
else
return false;
}
}
} else
return true;
}
return Result;
}
Local boolean string(structure *fsp, struct LOC_block *LINK)
{
boolean Result;
/*string*/
Result = false;
if (fsp == NULL)
return Result;
if ((structform)fsp->form == arrays) {
if (comptypes(fsp->UU.U4.aeltype, charptr, LINK))
return true;
}
return Result;
}
/* Local variables for typ: */
struct LOC_typ {
struct LOC_block *LINK;
addrrange displ;
} ;
Local void simpletype(long *fsys, structure **fsp, addrrange *fsize,
struct LOC_typ *LINK)
{
structure *lsp, *lsp1;
identifier *lcp, *lcp1;
disprange ttop;
long lcnt;
valu lvalu;
setofsys SET, SET1, SET2, SET3;
/*simpletype*/
*fsize = 1;
if (!P_inset(sy, simptypebegsys)) {
error(1);
skip(P_setunion(SET, fsys, simptypebegsys), LINK->LINK);
}
if (!P_inset(sy, simptypebegsys)) {
*fsp = NULL;
return;
}
if (sy == lparent) {
ttop = top; /*decl. consts local to innermost block*/
while ((where)display[top].occur != blck)
top–;
/* p2c: pcom.p, line 1040:
* Note: No SpecialMalloc form known for STRUCTURE.SCALAR.DECLARED [187] */
lsp = Malloc(sizeof(structure));
lsp->size = intsize;
(structform)lsp->form = scalar;
(declkind)lsp->UU.U0.scalkind = declared;
lcp1 = NULL;
lcnt = 0;
do {
insymbol();
if (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = lsp;
lcp->next = lcp1;
lcp->UU.values.UU.ival = lcnt;
(idclass)lcp->klass = konst;
enterid(lcp);
lcnt++;
lcp1 = lcp;
insymbol();
} else
error(2);
/* p2c: pcom.p, line 1048:
* Note: No SpecialMalloc form known for IDENTIFIER.KONST [187] */
if (!P_inset(sy, P_setunion(SET1, fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)rparent)))))) {
error(6);
skip(P_setunion(SET3, fsys, P_expset(SET2,
(1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK->LINK);
}
} while (sy == comma);
lsp->UU.U0.UU.fconst = lcp1;
top = ttop;
if (sy == rparent)
insymbol();
else
error(4);
} else {
if (sy == ident) {
searchid((1L << ((long)types)) | (1L << ((long)konst)), &lcp);
insymbol();
if ((idclass)lcp->klass == konst) {
lsp = Malloc(sizeof(structure));
lsp->UU.U1.rangetype = lcp->idtype;
(structform)lsp->form = subrange;
if (string(lsp->UU.U1.rangetype, LINK->LINK)) {
error(148);
lsp->UU.U1.rangetype = NULL;
}
lsp->UU.U1.min = lcp->UU.values;
lsp->size = intsize;
if (sy == colon)
insymbol();
else
error(5);
constant_(fsys, &lsp1, &lvalu, LINK->LINK);
lsp->UU.U1.max = lvalu;
if (lsp->UU.U1.rangetype != lsp1)
error(107);
} else {
lsp = lcp->idtype;
if (lsp != NULL)
*fsize = lsp->size;
}
/* p2c: pcom.p, line 1070:
* Note: No SpecialMalloc form known for STRUCTURE.SUBRANGE [187] */
} /*sy = ident*/
else {
lsp = Malloc(sizeof(structure));
(structform)lsp->form = subrange;
constant_(P_setunion(SET1, fsys, P_expset(SET, 1L << ((long)colon))),
&lsp1, &lvalu, LINK->LINK);
if (string(lsp1, LINK->LINK)) {
error(148);
lsp1 = NULL;
}
lsp->UU.U1.rangetype = lsp1;
lsp->UU.U1.min = lvalu;
lsp->size = intsize;
if (sy == colon)
insymbol();
else
error(5);
constant_(fsys, &lsp1, &lvalu, LINK->LINK);
lsp->UU.U1.max = lvalu;
if (lsp->UU.U1.rangetype != lsp1)
error(107);
}
if (lsp != NULL) {
if ((structform)lsp->form == subrange) {
if (lsp->UU.U1.rangetype != NULL) {
if (lsp->UU.U1.rangetype == realptr)
error(399);
else {
if (lsp->UU.U1.min.UU.ival > lsp->UU.U1.max.UU.ival)
error(102);
}
}
}
}
}
*fsp = lsp;
if (!P_inset(sy, fsys)) {
error(6);
skip(fsys, LINK->LINK);
}
/* p2c: pcom.p, line 1088:
* Note: No SpecialMalloc form known for STRUCTURE.SUBRANGE [187] */
}
Local void fieldlist(long *fsys, structure **frecvar, struct LOC_typ *LINK)
{
identifier *lcp, *lcp1, *nxt, *nxt1;
structure *lsp, *lsp1, *lsp2, *lsp3, *lsp4;
addrrange minsize, maxsize, lsize;
valu lvalu;
long SET[(long)casesy / 32 + 2];
setofsys SET1;
long SET2[(long)casesy / 32 + 2];
setofsys SET3;
identifier *WITH;
structure *WITH1;
long SET4[(long)ofsy / 32 + 2];
setofsys SET5, SET6, SET7, SET8;
/*fieldlist*/
nxt1 = NULL;
lsp = NULL;
P_addset(P_expset(SET, 0), (long)ident);
if (!P_inset(sy, P_setunion(SET1, fsys, P_addset(SET, (long)casesy)))) {
error(19);
P_addset(P_expset(SET2, 0), (long)ident);
skip(P_setunion(SET3, fsys, P_addset(SET2, (long)casesy)), LINK->LINK);
}
while (sy == ident) { /*while*/
nxt = nxt1;
do {
if (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = NULL;
lcp->next = nxt;
(idclass)lcp->klass = field;
nxt = lcp;
enterid(lcp);
insymbol();
} else
error(2);
/* p2c: pcom.p, line 1124:
* Note: No SpecialMalloc form known for IDENTIFIER.FIELD [187] */
if ((unsigned long)sy >= 32 ||
((1L << ((long)sy)) & ((1L << ((long)comma)) | (1L << ((long)colon)))) ==
0) {
error(6);
P_addset(P_expset(SET, 0), (long)comma);
P_addset(SET, (long)colon);
P_addset(SET, (long)semicolon);
skip(P_setunion(SET1, fsys, P_addset(SET, (long)casesy)), LINK->LINK);
}
LINK->LINK->test = (sy != comma);
if (!LINK->LINK->test)
insymbol();
} while (!LINK->LINK->test);
if (sy == colon)
insymbol();
else
error(5);
P_addset(P_expset(SET, 0), (long)casesy);
typ(P_setunion(SET1, fsys, P_addset(SET, (long)semicolon)), &lsp, &lsize,
LINK->LINK);
while (nxt != nxt1) {
WITH = nxt;
align(lsp, &LINK->displ);
WITH->idtype = lsp;
WITH->UU.fldaddr = LINK->displ;
nxt = WITH->next;
LINK->displ += lsize;
}
nxt1 = lcp;
while (sy == semicolon) {
insymbol();
P_addset(P_expset(SET, 0), (long)ident);
P_addset(SET, (long)casesy);
if (!P_inset(sy, P_setunion(SET1, fsys, P_addset(SET, (long)semicolon)))) {
error(19);
P_addset(P_expset(SET2, 0), (long)ident);
skip(P_setunion(SET3, fsys, P_addset(SET2, (long)casesy)), LINK->LINK);
}
}
}
nxt = NULL;
while (nxt1 != NULL) {
WITH = nxt1;
lcp = WITH->next;
WITH->next = nxt;
nxt = nxt1;
nxt1 = lcp;
}
if (sy != casesy) {
*frecvar = NULL;
return;
}
/* p2c: pcom.p, line 1160:
* Note: No SpecialMalloc form known for STRUCTURE.TAGFLD [187] */
lsp = Malloc(sizeof(structure));
lsp->UU.U7.tagfieldp = NULL;
lsp->UU.U7.fstvar = NULL;
(structform)lsp->form = tagfld;
*frecvar = lsp;
insymbol();
if (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = NULL;
(idclass)lcp->klass = field;
lcp->next = NULL;
lcp->UU.fldaddr = LINK->displ;
enterid(lcp);
insymbol();
if (sy == colon)
insymbol();
else
error(5);
if (sy == ident) {
searchid(1L << ((long)types), &lcp1);
lsp1 = lcp1->idtype;
if (lsp1 != NULL) {
align(lsp1, &LINK->displ);
lcp->UU.fldaddr = LINK->displ;
LINK->displ += lsp1->size;
if (((structform)lsp1->form <= subrange) | string(lsp1, LINK->LINK)) {
if (comptypes(realptr, lsp1, LINK->LINK))
error(109);
else if (string(lsp1, LINK->LINK))
error(399);
lcp->idtype = lsp1;
lsp->UU.U7.tagfieldp = lcp;
} else
error(110);
}
insymbol();
} else {
error(2);
P_addset(P_expset(SET4, 0), (long)ofsy);
skip(P_setunion(SET1, fsys, P_addset(SET4, (long)lparent)), LINK->LINK);
}
} else {
error(2);
P_addset(P_expset(SET4, 0), (long)ofsy);
skip(P_setunion(SET1, fsys, P_addset(SET4, (long)lparent)), LINK->LINK);
}
/* p2c: pcom.p, line 1166:
* Note: No SpecialMalloc form known for IDENTIFIER.FIELD [187] */
lsp->size = LINK->displ;
if (sy == ofsy)
insymbol();
else
error(8);
lsp1 = NULL;
minsize = LINK->displ;
maxsize = LINK->displ;
do {
lsp2 = NULL;
if (!P_inset(sy, P_setunion(SET3, fsys,
P_expset(SET1, 1L << ((long)semicolon))))) {
do {
constant_(P_setunion(SET6, fsys, P_expset(SET5,
(1L << ((long)comma)) | (1L << ((long)colon)) |
(1L << ((long)lparent)))), &lsp3, &lvalu,
LINK->LINK);
if (lsp->UU.U7.tagfieldp != NULL) {
if (!comptypes(lsp->UU.U7.tagfieldp->idtype, lsp3, LINK->LINK))
error(111);
}
/* p2c: pcom.p, line 1202:
* Note: No SpecialMalloc form known for STRUCTURE.VARIANT [187] */
lsp3 = Malloc(sizeof(structure));
lsp3->UU.U8.nxtvar = lsp1;
lsp3->UU.U8.subvar = lsp2;
lsp3->UU.U8.varval = lvalu;
(structform)lsp3->form = variant;
lsp4 = lsp1;
while (lsp4 != NULL) {
WITH1 = lsp4;
if (WITH1->UU.U8.varval.UU.ival == lvalu.UU.ival)
error(178);
lsp4 = WITH1->UU.U8.nxtvar;
}
lsp1 = lsp3;
lsp2 = lsp3;
LINK->LINK->test = (sy != comma);
if (!LINK->LINK->test)
insymbol();
} while (!LINK->LINK->test);
if (sy == colon)
insymbol();
else
error(5);
if (sy == lparent)
insymbol();
else
error(9);
fieldlist(P_setunion(SET6, fsys, P_expset(SET5,
(1L << ((long)rparent)) | (1L << ((long)semicolon)))),
&lsp2, LINK);
if (LINK->displ > maxsize)
maxsize = LINK->displ;
while (lsp3 != NULL) {
lsp4 = lsp3->UU.U8.subvar;
lsp3->UU.U8.subvar = lsp2;
lsp3->size = LINK->displ;
lsp3 = lsp4;
}
if (sy == rparent) {
insymbol();
if (!P_inset(sy,
P_setunion(SET6, fsys,
P_expset(SET5, 1L << ((long)semicolon))))) {
error(6);
skip(P_setunion(SET8, fsys, P_expset(SET7, 1L << ((long)semicolon))),
LINK->LINK);
}
} else
error(4);
}
LINK->LINK->test = (sy != semicolon);
if (!LINK->LINK->test) {
LINK->displ = minsize;
insymbol();
}
} while (!LINK->LINK->test);
LINK->displ = maxsize;
lsp->UU.U7.fstvar = lsp1;
}
Local void typ(long *fsys, structure **fsp, addrrange *fsize,
struct LOC_block *LINK)
{
struct LOC_typ V;
structure *lsp, *lsp1, *lsp2;
disprange oldtop;
identifier *lcp;
addrrange lsize;
long lmin, lmax;
setofsys SET;
_REC_display *WITH;
long SET1[(long)ofsy / 32 + 2];
setofsys SET2;
long SET3[(long)endsy / 32 + 2];
setofsys SET4;
V.LINK = LINK;
/*typ*/
if (!P_inset(sy, typebegsys)) {
error(10);
skip(P_setunion(SET, fsys, typebegsys), LINK);
}
if (P_inset(sy, typebegsys)) {
if (P_inset(sy, simptypebegsys))
simpletype(fsys, fsp, fsize, &V);
else {
/*^*/
if (sy == arrow) {
lsp = Malloc(sizeof(structure));
*fsp = lsp;
lsp->UU.eltype = NULL;
lsp->size = ptrsize;
(structform)lsp->form = pointer;
insymbol();
if (sy == ident) {
prterr = false; /*no error if search not successful*/
searchid(1L << ((long)types), &lcp);
prterr = true;
if (lcp == NULL) { /*forward referenced type id*/
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = lsp;
lcp->next = fwptr;
(idclass)lcp->klass = types;
fwptr = lcp;
} else {
if (lcp->idtype != NULL) {
if ((structform)lcp->idtype->form == files)
error(108);
else
lsp->UU.eltype = lcp->idtype;
}
}
/* p2c: pcom.p, line 1262:
* Note: No SpecialMalloc form known for IDENTIFIER.TYPES [187] */
insymbol();
} else
error(2);
} else {
if (sy == packedsy) {
insymbol();
if (!P_inset(sy, typedels)) {
error(10);
skip(P_setunion(SET, fsys, typedels), LINK);
}
}
/*array*/
if (sy == arraysy) {
insymbol();
if (sy == lbrack)
insymbol();
else
error(11);
lsp1 = NULL;
do {
lsp = Malloc(sizeof(structure));
lsp->UU.U4.aeltype = lsp1;
lsp->UU.U4.inxtype = NULL;
(structform)lsp->form = arrays;
lsp1 = lsp;
P_addset(P_expset(SET1, 0), (long)comma);
P_addset(SET1, (long)rbrack);
simpletype(P_setunion(SET, fsys, P_addset(SET1, (long)ofsy)),
&lsp2, &lsize, &V);
lsp1->size = lsize;
if (lsp2 != NULL) {
if ((structform)lsp2->form <= subrange) {
if (lsp2 == realptr) {
error(109);
lsp2 = NULL;
} else {
if (lsp2 == intptr) {
error(149);
lsp2 = NULL;
}
}
lsp->UU.U4.inxtype = lsp2;
} else {
error(113);
lsp2 = NULL;
}
}
LINK->test = (sy != comma);
if (!LINK->test)
insymbol();
} while (!LINK->test);
/* p2c: pcom.p, line 1292:
* Note: No SpecialMalloc form known for STRUCTURE.ARRAYS [187] */
if (sy == rbrack)
insymbol();
else
error(12);
if (sy == ofsy)
insymbol();
else
error(8);
typ(fsys, &lsp, &lsize, LINK);
do {
lsp2 = lsp1->UU.U4.aeltype;
lsp1->UU.U4.aeltype = lsp;
if (lsp1->UU.U4.inxtype != NULL) {
getbounds(lsp1->UU.U4.inxtype, &lmin, &lmax);
align(lsp, &lsize);
lsize *= lmax – lmin + 1;
lsp1->size = lsize;
}
lsp = lsp1;
lsp1 = lsp2;
} while (lsp1 != NULL);
} else {
/*record*/
if (sy == recordsy) {
insymbol();
oldtop = top;
if (top < displimit) {
top++;
WITH = &display[top];
WITH->fname = NULL;
WITH->flabel = NULL;
(where)WITH->occur = rec;
} else
error(250);
V.displ = 0;
fieldlist(P_setunion(SET4,
P_setdiff(SET2, fsys, P_expset(SET, 1L << ((long)semicolon))),
P_addset(P_expset(SET3, 0), (long)endsy)), &lsp1, &V);
/* p2c: pcom.p, line 1343:
* Note: No SpecialMalloc form known for STRUCTURE.RECORDS [187] */
lsp = Malloc(sizeof(structure));
lsp->UU.U5.fstfld = display[top].fname;
lsp->UU.U5.recvar = lsp1;
lsp->size = V.displ;
(structform)lsp->form = records;
top = oldtop;
if (sy == endsy)
insymbol();
else
error(13);
} else {
/*set*/
if (sy == setsy) {
insymbol();
if (sy == ofsy)
insymbol();
else
error(8);
simpletype(fsys, &lsp1, &lsize, &V);
if (lsp1 != NULL) {
if ((structform)lsp1->form > subrange) {
error(115);
lsp1 = NULL;
} else {
if (lsp1 == realptr) {
error(114);
lsp1 = NULL;
} else if (lsp1 == intptr) {
error(169);
lsp1 = NULL;
} else {
getbounds(lsp1, &lmin, &lmax);
if (lmin < setlow || lmax > sethigh)
error(169);
}
}
}
/* p2c: pcom.p, line 1369:
* Note: No SpecialMalloc form known for STRUCTURE.POWER [187] */
lsp = Malloc(sizeof(structure));
lsp->UU.elset = lsp1;
lsp->size = setsize;
(structform)lsp->form = power;
} else {
/*file*/
if (sy == filesy) {
insymbol();
error(399);
skip(fsys, LINK);
lsp = NULL;
}
}
}
}
*fsp = lsp;
}
/* p2c: pcom.p, line 1254:
* Note: No SpecialMalloc form known for STRUCTURE.POINTER [187] */
}
if (!P_inset(sy, fsys)) {
error(6);
skip(fsys, LINK);
}
} else
*fsp = NULL;
if (*fsp == NULL)
*fsize = 1;
else
*fsize = (*fsp)->size;
}
Local void labeldeclaration(struct LOC_block *LINK)
{
labl *llp;
boolean redef;
long lbname;
_REC_display *WITH;
setofsys SET, SET1, SET2, SET3;
/* labeldeclaration */
do {
if (sy == intconst) {
WITH = &display[top];
llp = WITH->flabel;
redef = false;
while (llp != NULL && !redef) {
if (llp->labval != val.UU.ival)
llp = llp->nextlab;
else {
redef = true;
error(166);
}
}
if (!redef) {
llp = Malloc(sizeof(labl));
llp->labval = val.UU.ival;
genlabel(&lbname);
llp->defined_ = false;
llp->nextlab = WITH->flabel;
llp->labname = lbname;
WITH->flabel = llp;
}
insymbol();
} else
error(15);
if (!P_inset(sy, P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)semicolon)))))) {
error(6);
skip(P_setunion(SET3, LINK->fsys, P_expset(SET2,
(1L << ((long)comma)) | (1L << ((long)semicolon)))),
LINK);
}
LINK->test = (sy != comma);
if (!LINK->test)
insymbol();
} while (!LINK->test);
if (sy == semicolon)
insymbol();
else
error(14);
}
Local void constdeclaration(struct LOC_block *LINK)
{
identifier *lcp;
structure *lsp;
valu lvalu;
setofsys SET, SET1, SET2, SET3;
/*constdeclaration*/
if (sy != ident) {
error(2);
skip(P_setunion(SET1, LINK->fsys, P_expset(SET, 1L << ((long)ident))),
LINK);
}
while (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = NULL;
lcp->next = NULL;
(idclass)lcp->klass = konst;
insymbol();
if (sy == relop && op == eqop)
insymbol();
else
error(16);
constant_(P_setunion(SET1, LINK->fsys,
P_expset(SET, 1L << ((long)semicolon))), &lsp,
&lvalu, LINK);
enterid(lcp);
lcp->idtype = lsp;
lcp->UU.values = lvalu;
if (sy == semicolon) {
insymbol();
if (!P_inset(sy, P_setunion(SET1, LINK->fsys,
P_expset(SET, 1L << ((long)ident))))) {
error(6);
skip(P_setunion(SET3, LINK->fsys, P_expset(SET2, 1L << ((long)ident))),
LINK);
}
} else
error(14);
}
/* p2c: pcom.p, line 1423:
* Note: No SpecialMalloc form known for IDENTIFIER.KONST [187] */
}
Local void typedeclaration(struct LOC_block *LINK)
{
identifier *lcp, *lcp1, *lcp2;
structure *lsp;
addrrange lsize;
setofsys SET, SET1, SET2, SET3;
/*typedeclaration*/
if (sy != ident) {
error(2);
skip(P_setunion(SET1, LINK->fsys, P_expset(SET, 1L << ((long)ident))),
LINK);
}
while (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = NULL;
(idclass)lcp->klass = types;
insymbol();
if (sy == relop && op == eqop)
insymbol();
else
error(16);
typ(P_setunion(SET1, LINK->fsys, P_expset(SET, 1L << ((long)semicolon))),
&lsp, &lsize, LINK);
enterid(lcp);
lcp->idtype = lsp;
/*has any forward reference been satisfied:*/
lcp1 = fwptr;
while (lcp1 != NULL) {
if (!strncmp(lcp1->name, lcp->name, sizeof(alpha))) {
lcp1->idtype->UU.eltype = lcp->idtype;
if (lcp1 != fwptr)
lcp2->next = lcp1->next;
else
fwptr = lcp1->next;
} else
lcp2 = lcp1;
lcp1 = lcp1->next;
}
if (sy == semicolon) {
insymbol();
if (!P_inset(sy, P_setunion(SET1, LINK->fsys,
P_expset(SET, 1L << ((long)ident))))) {
error(6);
skip(P_setunion(SET3, LINK->fsys, P_expset(SET2, 1L << ((long)ident))),
LINK);
}
} else
error(14);
}
/* p2c: pcom.p, line 1446:
* Note: No SpecialMalloc form known for IDENTIFIER.TYPES [187] */
if (fwptr == NULL)
return;
error(117);
putchar('\n');
do {
printf(" type-id %.8s\n", fwptr->name);
fwptr = fwptr->next;
} while (fwptr != NULL);
if (!eol)
printf("%*c", (int)(chcnt + 16), ' ');
}
Local void vardeclaration(struct LOC_block *LINK)
{
identifier *lcp, *nxt;
structure *lsp;
addrrange lsize;
identifier *WITH;
setofsys SET, SET1, SET2, SET3, SET4, SET5;
/*vardeclaration*/
nxt = NULL;
do {
do {
if (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->next = nxt;
(idclass)lcp->klass = vars;
lcp->idtype = NULL;
(idkind)lcp->UU.U2.vkind = actual;
lcp->UU.U2.vlev = level;
enterid(lcp);
nxt = lcp;
insymbol();
} else
error(2);
/* p2c: pcom.p, line 1489:
* Note: No SpecialMalloc form known for IDENTIFIER.VARS [187] */
if (!P_inset(sy, P_setunion(SET2, P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)colon)))),
typedels))) {
error(6);
skip(P_setunion(SET5, P_setunion(SET4, LINK->fsys, P_expset(SET3,
(1L << ((long)comma)) | (1L << ((long)colon)) |
(1L << ((long)semicolon)))), typedels), LINK);
}
LINK->test = (sy != comma);
if (!LINK->test)
insymbol();
} while (!LINK->test);
if (sy == colon)
insymbol();
else
error(5);
typ(P_setunion(SET2, P_setunion(SET1, LINK->fsys,
P_expset(SET, 1L << ((long)semicolon))),
typedels), &lsp, &lsize, LINK);
while (nxt != NULL) {
WITH = nxt;
align(lsp, &lc);
WITH->idtype = lsp;
WITH->UU.U2.vaddr = lc;
lc += lsize;
nxt = WITH->next;
}
if (sy == semicolon) {
insymbol();
if (!P_inset(sy, P_setunion(SET1, LINK->fsys,
P_expset(SET, 1L << ((long)ident))))) {
error(6);
skip(P_setunion(SET3, LINK->fsys, P_expset(SET2, 1L << ((long)ident))),
LINK);
}
} else
error(14);
} while (!((sy != ident) & (!P_inset(sy, typedels))));
if (fwptr == NULL)
return;
error(117);
putchar('\n');
do {
printf(" type-id %.8s\n", fwptr->name);
fwptr = fwptr->next;
} while (fwptr != NULL);
if (!eol)
printf("%*c", (int)(chcnt + 16), ' ');
}
/* Local variables for procdeclaration: */
struct LOC_procdeclaration {
struct LOC_block *LINK;
boolean forw;
} ;
Local void parameterlist(long *fsy, identifier **fpar,
struct LOC_procdeclaration *LINK)
{
identifier *lcp, *lcp1, *lcp2, *lcp3;
structure *lsp;
idkind lkind;
addrrange llc, lsize;
long count;
setofsys SET, SET1, SET2, SET3, SET4;
identifier *WITH;
/*parameterlist*/
lcp1 = NULL;
if (!P_inset(sy,
P_setunion(SET1, fsy, P_expset(SET, 1L << ((long)lparent))))) {
error(7);
skip(P_setunion(SET4, P_setunion(SET2, LINK->LINK->fsys, fsy),
P_expset(SET3, 1L << ((long)lparent))), LINK->LINK);
}
if (sy != lparent) {
*fpar = NULL;
return;
}
if (LINK->forw)
error(119);
insymbol();
if ((unsigned long)sy >= 32 ||
((1L << ((long)sy)) & ((1L << ((long)ident)) | (1L << ((long)varsy)) |
(1L << ((long)procsy)) | (1L << ((long)funcsy)))) == 0) {
error(7);
skip(P_setunion(SET1, LINK->LINK->fsys,
P_expset(SET, (1L << ((long)ident)) | (1L << ((long)rparent)))),
LINK->LINK);
}
while ((unsigned long)sy < 32 &&
((1L << ((long)sy)) & ((1L << ((long)ident)) | (1L << ((long)varsy)) |
(1L << ((long)procsy)) | (1L << ((long)funcsy)))) != 0)
{ /*while*/
if (sy == procsy) {
error(399);
do {
insymbol();
if (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = NULL;
lcp->next = lcp1;
lcp->UU.U4.UU.U1.pflev = level; /*beware of parameter procedures*/
(idclass)lcp->klass = proc;
(declkind)lcp->UU.U4.pfdeckind = declared;
(idkind)lcp->UU.U4.UU.U1.pfkind = formal;
enterid(lcp);
lcp1 = lcp;
align(parmptr, &lc);
/*lc := lc + some size */
insymbol();
} else
error(2);
/* p2c: pcom.p, line 1550: Note:
* No SpecialMalloc form known for IDENTIFIER.PROC.DECLARED.FORMAL [187] */
if (!P_inset(sy, P_setunion(SET1, LINK->LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)semicolon)) |
(1L << ((long)rparent)))))) {
error(7);
skip(P_setunion(SET3, LINK->LINK->fsys,
P_expset(SET2,
(1L << ((long)comma)) | (1L << ((long)semicolon)) |
(1L << ((long)rparent)))), LINK->LINK);
}
} while (sy == comma);
} else {
if (sy == funcsy) {
error(399);
lcp2 = NULL;
do {
insymbol();
if (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = NULL;
lcp->next = lcp2;
lcp->UU.U4.UU.U1.pflev = level; /*beware param funcs*/
(idclass)lcp->klass = func;
(declkind)lcp->UU.U4.pfdeckind = declared;
(idkind)lcp->UU.U4.UU.U1.pfkind = formal;
enterid(lcp);
lcp2 = lcp;
align(parmptr, &lc);
/*lc := lc + some size*/
insymbol();
}
/* p2c: pcom.p, line 1573: Note:
* No SpecialMalloc form known for IDENTIFIER.FUNC.DECLARED.FORMAL [187] */
if (!P_inset(sy, P_setunion(SET1,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)colon))),
LINK->LINK->fsys))) {
error(7);
skip(P_setunion(SET3, LINK->LINK->fsys, P_expset(SET2,
(1L << ((long)comma)) | (1L << ((long)semicolon)) |
(1L << ((long)rparent)))), LINK->LINK);
}
} while (sy == comma);
if (sy == colon) {
insymbol();
if (sy == ident) {
searchid(1L << ((long)types), &lcp);
lsp = lcp->idtype;
if (lsp != NULL) {
if (((1L << lsp->form) & ((1L << ((long)scalar)) |
(1L << ((long)subrange)) | (1L << ((long)pointer)))) == 0) {
error(120);
lsp = NULL;
}
}
lcp3 = lcp2;
while (lcp2 != NULL) {
lcp2->idtype = lsp;
lcp = lcp2;
lcp2 = lcp2->next;
}
lcp->next = lcp1;
lcp1 = lcp3;
insymbol();
} else
error(2);
if (!P_inset(sy, P_setunion(SET1, LINK->LINK->fsys, P_expset(SET,
(1L << ((long)semicolon)) | (1L << ((long)rparent)))))) {
error(7);
skip(P_setunion(SET3, LINK->LINK->fsys, P_expset(SET2,
(1L << ((long)semicolon)) | (1L << ((long)rparent)))),
LINK->LINK);
}
} else
error(5);
} else {
if (sy == varsy) {
lkind = formal;
insymbol();
} else
lkind = actual;
lcp2 = NULL;
count = 0;
do {
if (sy == ident) {
lcp = Malloc(sizeof(identifier));
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = NULL;
(idclass)lcp->klass = vars;
(idkind)lcp->UU.U2.vkind = lkind;
lcp->next = lcp2;
lcp->UU.U2.vlev = level;
enterid(lcp);
lcp2 = lcp;
count++;
insymbol();
}
/* p2c: pcom.p, line 1621:
* Note: No SpecialMalloc form known for IDENTIFIER.VARS [187] */
if (!P_inset(sy, P_setunion(SET1,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)colon))),
LINK->LINK->fsys))) {
error(7);
skip(P_setunion(SET3, LINK->LINK->fsys, P_expset(SET2,
(1L << ((long)comma)) | (1L << ((long)semicolon)) |
(1L << ((long)rparent)))), LINK->LINK);
}
LINK->LINK->test = (sy != comma);
if (!LINK->LINK->test)
insymbol();
} while (!LINK->LINK->test);
if (sy == colon) {
insymbol();
if (sy == ident) {
searchid(1L << ((long)types), &lcp);
lsp = lcp->idtype;
lsize = ptrsize;
if (lsp != NULL) {
if (lkind == actual) {
if ((structform)lsp->form <= power)
lsize = lsp->size;
else if ((structform)lsp->form == files)
error(121);
}
}
align(parmptr, &lsize);
lcp3 = lcp2;
align(parmptr, &lc);
lc += count * lsize;
llc = lc;
while (lcp2 != NULL) {
lcp = lcp2;
lcp2->idtype = lsp;
llc -= lsize;
lcp2->UU.U2.vaddr = llc;
lcp2 = lcp2->next;
}
lcp->next = lcp1;
lcp1 = lcp3;
insymbol();
} else
error(2);
if (!P_inset(sy, P_setunion(SET1, LINK->LINK->fsys, P_expset(SET,
(1L << ((long)semicolon)) | (1L << ((long)rparent)))))) {
error(7);
skip(P_setunion(SET3, LINK->LINK->fsys, P_expset(SET2,
(1L << ((long)semicolon)) | (1L << ((long)rparent)))),
LINK->LINK);
}
} else
error(5);
}
}
if (sy == semicolon) {
insymbol();
if (!P_inset(sy, P_setunion(SET1, LINK->LINK->fsys, P_expset(SET,
(1L << ((long)ident)) | (1L << ((long)varsy)) |
(1L << ((long)procsy)) | (1L << ((long)funcsy)))))) {
error(7);
skip(P_setunion(SET3, LINK->LINK->fsys, P_expset(SET2,
(1L << ((long)ident)) | (1L << ((long)rparent)))),
LINK->LINK);
}
}
}
if (sy == rparent) {
insymbol();
if (!P_inset(sy, P_setunion(SET, fsy, LINK->LINK->fsys))) {
error(6);
skip(P_setunion(SET1, fsy, LINK->LINK->fsys), LINK->LINK);
}
} else
error(4);
lcp3 = NULL;
/*reverse pointers and reserve local cells for copies of multiple
values*/
while (lcp1 != NULL) {
WITH = lcp1;
lcp2 = WITH->next;
WITH->next = lcp3;
if ((idclass)WITH->klass == vars) {
if (WITH->idtype != NULL) {
if ((idkind)WITH->UU.U2.vkind == actual &&
(structform)WITH->idtype->form > power) {
align(WITH->idtype, &lc);
WITH->UU.U2.vaddr = lc;
lc += WITH->idtype->size;
}
}
}
lcp3 = lcp1;
lcp1 = lcp2;
}
*fpar = lcp3;
}
Local void procdeclaration(symbol fsy, struct LOC_block *LINK)
{
struct LOC_procdeclaration V;
char oldlev;
identifier *lcp, *lcp1;
structure *lsp;
disprange oldtop;
addrrange llc, lcm;
long lbname, *markp;
_REC_display *WITH;
setofsys SET, SET1;
V.LINK = LINK;
/*procdeclaration*/
llc = lc;
lc = lcaftermarkstack;
V.forw = false;
if (sy == ident) {
searchsection(display[top].fname, &lcp); /*decide whether forw.*/
if (lcp != NULL) {
if ((idclass)lcp->klass == proc)
V.forw = (lcp->UU.U4.UU.U1.UU.U0.forwdecl && fsy == procsy &&
(idkind)lcp->UU.U4.UU.U1.pfkind == actual);
else {
if ((idclass)lcp->klass == func)
V.forw = (lcp->UU.U4.UU.U1.UU.U0.forwdecl && fsy == funcsy &&
(idkind)lcp->UU.U4.UU.U1.pfkind == actual);
else
V.forw = false;
}
if (!V.forw)
error(160);
}
if (!V.forw) {
if (fsy == procsy)
lcp = Malloc(sizeof(identifier));
else
lcp = Malloc(sizeof(identifier));
/* p2c: pcom.p, line 1719: Note:
* No SpecialMalloc form known for IDENTIFIER.PROC.DECLARED.ACTUAL [187] */
memcpy(lcp->name, id, sizeof(alpha));
lcp->idtype = NULL;
lcp->UU.U4.UU.U1.UU.U0.externl = false;
lcp->UU.U4.UU.U1.pflev = level;
genlabel(&lbname);
(declkind)lcp->UU.U4.pfdeckind = declared;
(idkind)lcp->UU.U4.UU.U1.pfkind = actual;
lcp->UU.U4.UU.U1.pfname = lbname;
if (fsy == procsy)
(idclass)lcp->klass = proc;
else
(idclass)lcp->klass = func;
enterid(lcp);
} else {
lcp1 = lcp->next;
while (lcp1 != NULL) {
if ((idclass)lcp1->klass == vars) {
if (lcp1->idtype != NULL) {
lcm = lcp1->UU.U2.vaddr + lcp1->idtype->size;
if (lcm > lc)
lc = lcm;
}
}
lcp1 = lcp1->next;
}
}
insymbol();
} else {
error(2);
lcp = ufctptr;
}
oldlev = level;
oldtop = top;
if (level < maxlevel)
level++;
else
error(251);
if (top < displimit) {
top++;
WITH = &display[top];
if (V.forw)
WITH->fname = lcp->next;
else
WITH->fname = NULL;
WITH->flabel = NULL;
(where)WITH->occur = blck;
} else
error(250);
if (fsy == procsy) {
parameterlist(P_expset(SET, 1L << ((long)semicolon)), &lcp1, &V);
if (!V.forw)
lcp->next = lcp1;
} else {
parameterlist(P_expset(SET,
(1L << ((long)semicolon)) | (1L << ((long)colon))),
&lcp1, &V);
if (!V.forw)
lcp->next = lcp1;
if (sy == colon) {
insymbol();
if (sy == ident) {
if (V.forw)
error(122);
searchid(1L << ((long)types), &lcp1);
lsp = lcp1->idtype;
lcp->idtype = lsp;
if (lsp != NULL) {
if (((1L << lsp->form) & ((1L << ((long)scalar)) |
(1L << ((long)subrange)) | (1L << ((long)pointer)))) == 0) {
error(120);
lcp->idtype = NULL;
}
}
insymbol();
} else {
error(2);
skip(P_setunion(SET1, LINK->fsys,
P_expset(SET, 1L << ((long)semicolon))), LINK);
}
} else {
if (!V.forw)
error(123);
}
}
if (sy == semicolon)
insymbol();
else
error(14);
if (sy == forwardsy) {
if (V.forw)
error(161);
else
lcp->UU.U4.UU.U1.UU.U0.forwdecl = true;
insymbol();
if (sy == semicolon)
insymbol();
else
error(14);
if (!P_inset(sy, LINK->fsys)) {
error(6);
skip(LINK->fsys, LINK);
}
} else {
lcp->UU.U4.UU.U1.UU.U0.forwdecl = false;
mark_(&markp);
do {
block(LINK->fsys, semicolon, lcp);
if (sy == semicolon) {
if (prtables)
printtables(false);
insymbol();
if ((unsigned long)sy >= 32 ||
((1L << ((long)sy)) & ((1L << ((long)beginsy)) |
(1L << ((long)procsy)) | (1L << ((long)funcsy)))) == 0) {
error(6);
skip(LINK->fsys, LINK);
}
} else
error(14);
} while (!(((unsigned long)sy < 32 &&
((1L << ((long)sy)) & ((1L << ((long)beginsy)) |
(1L << ((long)procsy)) | (1L << ((long)funcsy)))) !=
0) | P_eof(stdin)));
release_(markp); /* return local entries on runtime heap */
}
level = oldlev;
top = oldtop;
lc = llc;
/* p2c: pcom.p, line 1719: Note:
* No SpecialMalloc form known for IDENTIFIER.FUNC.DECLARED.ACTUAL [187] */
}
/* Local variables for body: */
struct LOC_body {
struct LOC_block *LINK;
constant *cstptr[cstoccmax];
char cstptrix;
long topnew, topmax;
addrrange lcmax;
} ;
Local void statement(long *fsys, struct LOC_body *LINK);
Local void mes(long i, struct LOC_body *LINK)
{
LINK->topnew += cdx[i];
if (LINK->topnew > LINK->topmax)
LINK->topmax = LINK->topnew;
}
Local void putic(struct LOC_body *LINK)
{
if (ic % 10 == 0)
fprintf(prr.f, "i%5d\n", ic);
}
Local void gen0(oprange fop, struct LOC_body *LINK)
{
/*gen0*/
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s\n", mn[fop]);
}
ic++;
mes(fop, LINK);
}
Local void gen1(oprange fop, long fp2, struct LOC_body *LINK)
{
long k;
constant *WITH;
long FORLIM;
/*gen1*/
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s", mn[fop]);
if (fop == 30) {
fprintf(prr.f, " %.4s\n", sna[fp2 – 1]);
LINK->topnew += pdx[fp2 – 1];
if (LINK->topnew > LINK->topmax)
LINK->topmax = LINK->topnew;
} else {
if (fop == 38) {
putc('\'', prr.f);
WITH = LINK->cstptr[fp2 – 1];
FORLIM = WITH->UU.U2.slgth;
for (k = 0; k < FORLIM; k++)
putc(WITH->UU.U2.sval[k], prr.f);
for (k = WITH->UU.U2.slgth + 1; k <= strglgth; k++)
putc(' ', prr.f);
fprintf(prr.f, "'\n");
} else if (fop == 42)
fprintf(prr.f, "%c\n", (Char)fp2);
else
fprintf(prr.f, "%12ld\n", fp2);
mes(fop, LINK);
}
}
ic++;
}
Local void gen2(oprange fop, long fp1, long fp2, struct LOC_body *LINK)
{
long k;
constant *WITH;
/*gen2*/
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s", mn[fop]);
switch (fop) {
case 45:
case 50:
case 54:
case 56:
fprintf(prr.f, " %3ld%8ld\n", fp1, fp2);
break;
case 47:
case 48:
case 49:
case 52:
case 53:
case 55:
putc((Char)fp1, prr.f);
if (fp1 == 'm')
fprintf(prr.f, "%11ld", fp2);
putc('\n', prr.f);
break;
case 51:
switch (fp1) {
case 1:
fprintf(prr.f, "i %12ld\n", fp2);
break;
case 2:
fprintf(prr.f, "r ");
WITH = LINK->cstptr[fp2 – 1];
for (k = 0; k < strglgth; k++)
putc(WITH->UU.rval[k], prr.f);
putc('\n', prr.f);
break;
case 3:
fprintf(prr.f, "b %12ld\n", fp2);
break;
case 4:
fprintf(prr.f, "n\n");
break;
case 6:
fprintf(prr.f, "%3s%c'\n", "c '", (Char)fp2);
break;
case 5:
putc('(', prr.f);
WITH = LINK->cstptr[fp2 – 1];
for (k = setlow; k <= sethigh; k++) {
if (P_inset(k, WITH->UU.pval))
fprintf(prr.f, "%3ld", k);
}
fprintf(prr.f, ")\n");
break;
}
break;
}
}
ic++;
mes(fop, LINK);
}
Local void gentypindicator(structure *fsp, struct LOC_body *LINK)
{
/*typindicator*/
if (fsp == NULL)
return;
switch ((structform)fsp->form) {
case scalar:
if (fsp == intptr)
putc('i', prr.f);
else {
if (fsp == boolptr)
putc('b', prr.f);
else {
if (fsp == charptr)
putc('c', prr.f);
else {
if ((declkind)fsp->UU.U0.scalkind == declared)
putc('i', prr.f);
else
putc('r', prr.f);
}
}
}
break;
case subrange:
gentypindicator(fsp->UU.U1.rangetype, LINK);
break;
case pointer:
putc('a', prr.f);
break;
case power:
putc('s', prr.f);
break;
case records:
case arrays:
putc('m', prr.f);
break;
case files:
case tagfld:
case variant:
error(500);
break;
}
}
Local void gen0t(oprange fop, structure *fsp, struct LOC_body *LINK)
{
/*gen0t*/
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s", mn[fop]);
gentypindicator(fsp, LINK);
putc('\n', prr.f);
}
ic++;
mes(fop, LINK);
}
Local void gen1t(oprange fop, long fp2, structure *fsp, struct LOC_body *LINK)
{
/*gen1t*/
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s", mn[fop]);
gentypindicator(fsp, LINK);
fprintf(prr.f, "%11ld\n", fp2);
}
ic++;
mes(fop, LINK);
}
Local void gen2t(oprange fop, long fp1, long fp2, structure *fsp,
struct LOC_body *LINK)
{
/*gen2t*/
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s", mn[fop]);
gentypindicator(fsp, LINK);
fprintf(prr.f, "%*ld%8ld\n", (labs(fp1) > 99) * 5 + 3, fp1, fp2);
}
ic++;
mes(fop, LINK);
}
Local void load(struct LOC_body *LINK)
{
/*load*/
if (gattr.typtr == NULL)
return;
switch (gattr.kind) {
case cst:
if ((structform)gattr.typtr->form == scalar && gattr.typtr != realptr) {
if (gattr.typtr == boolptr) /*ldc*/
gen2(51, 3, gattr.UU.cval.UU.ival, LINK);
else {
if (gattr.typtr == charptr) /*ldc*/
gen2(51, 6, gattr.UU.cval.UU.ival, LINK);
else /*ldc*/
gen2(51, 1, gattr.UU.cval.UU.ival, LINK);
}
} else {
if (gattr.typtr == nilptr) /*ldc*/
gen2(51, 4, 0, LINK);
else {
if (LINK->cstptrix >= cstoccmax)
error(254);
else {
LINK->cstptrix++;
LINK->cstptr[LINK->cstptrix – 1] = gattr.UU.cval.UU.valp;
if (gattr.typtr == realptr) /*ldc*/
gen2(51, 2, LINK->cstptrix, LINK);
else /*ldc*/
gen2(51, 5, LINK->cstptrix, LINK);
}
}
}
break;
case varbl:
switch (gattr.UU.U1.access) {
case drct:
if (gattr.UU.U1.UU.U0.vlevel <= 1) /*ldo*/
gen1t(39, gattr.UU.U1.UU.U0.dplmt, gattr.typtr, LINK);
else /*lod*/
gen2t(54, level – gattr.UU.U1.UU.U0.vlevel, gattr.UU.U1.UU.U0.dplmt,
gattr.typtr, LINK);
break;
case indrct: /*ind*/
gen1t(35, gattr.UU.U1.UU.idplmt, gattr.typtr, LINK);
break;
case inxd:
error(400);
break;
}
break;
case expr:
/* blank case */
break;
}
gattr.kind = expr;
}
Local void store(attr *fattr, struct LOC_body *LINK)
{
/*store*/
if (fattr->typtr == NULL)
return;
switch (fattr->UU.U1.access) {
case drct:
if (fattr->UU.U1.UU.U0.vlevel <= 1) /*sro*/
gen1t(43, fattr->UU.U1.UU.U0.dplmt, fattr->typtr, LINK);
else /*str*/
gen2t(56, level – fattr->UU.U1.UU.U0.vlevel, fattr->UU.U1.UU.U0.dplmt,
fattr->typtr, LINK);
break;
case indrct:
if (fattr->UU.U1.UU.idplmt != 0)
error(400);
else /*sto*/
gen0t(26, fattr->typtr, LINK);
break;
case inxd:
error(400);
break;
}
}
Local void loadaddress(struct LOC_body *LINK)
{
/*loadaddress*/
if (gattr.typtr == NULL)
return;
switch (gattr.kind) {
case cst:
if (string(gattr.typtr, LINK->LINK)) {
if (LINK->cstptrix >= cstoccmax)
error(254);
else {
LINK->cstptrix++;
LINK->cstptr[LINK->cstptrix – 1] = gattr.UU.cval.UU.valp; /*lca*/
gen1(38, LINK->cstptrix, LINK);
}
} else
error(400);
break;
case varbl:
switch (gattr.UU.U1.access) {
case drct:
if (gattr.UU.U1.UU.U0.vlevel <= 1) /*lao*/
gen1(37, gattr.UU.U1.UU.U0.dplmt, LINK);
else /*lda*/
gen2(50, level – gattr.UU.U1.UU.U0.vlevel, gattr.UU.U1.UU.U0.dplmt,
LINK);
break;
case indrct:
if (gattr.UU.U1.UU.idplmt != 0) /*inc*/
gen1t(34, gattr.UU.U1.UU.idplmt, nilptr, LINK);
break;
case inxd:
error(400);
break;
}
break;
case expr:
error(400);
break;
}
gattr.kind = varbl;
gattr.UU.U1.access = indrct;
gattr.UU.U1.UU.idplmt = 0;
}
Local void genfjp(long faddr, struct LOC_body *LINK)
{
/*genfjp*/
load(LINK);
if (gattr.typtr != NULL) {
if (gattr.typtr != boolptr)
error(144);
}
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s%8s%4ld\n", mn[33], " l", faddr);
}
ic++;
mes(33, LINK);
}
Local void genujpxjp(oprange fop, long fp2, struct LOC_body *LINK)
{
/*genujpxjp*/
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s%8s%4ld\n", mn[fop], " l", fp2);
}
ic++;
mes(fop, LINK);
}
Local void gencupent(oprange fop, long fp1, long fp2, struct LOC_body *LINK)
{
if (prcode) {
putic(LINK);
fprintf(prr.f, "%.4s%4ld%4c%4ld\n", mn[fop], fp1, 'l', fp2);
}
ic++;
mes(fop, LINK);
}
Local void checkbnds(structure *fsp, struct LOC_body *LINK)
{
long lmin, lmax;
/*checkbnds*/
if (fsp == NULL)
return;
if (fsp == intptr)
return;
if (fsp == realptr)
return;
if ((structform)fsp->form <= subrange) {
getbounds(fsp, &lmin, &lmax); /*chk*/
gen2t(45, lmin, lmax, fsp, LINK);
}
}
Local void putlabel(long labname, struct LOC_body *LINK)
{
/*putlabel*/
if (prcode)
fprintf(prr.f, "l%4ld\n", labname);
}
/* Local variables for statement: */
struct LOC_statement {
struct LOC_body *LINK;
setofsys fsys;
identifier *lcp;
} ;
Local void expression(long *fsys, struct LOC_statement *LINK);
Local void selector(long *fsys, identifier *fcp, struct LOC_statement *LINK)
{
attr lattr;
identifier *lcp;
addrrange lsize;
long lmin, lmax;
structure *WITH;
_REC_display *WITH1;
setofsys SET, SET1;
/*selector*/
gattr.typtr = fcp->idtype;
gattr.kind = varbl;
switch ((idclass)fcp->klass) { /*with*/
case vars:
if ((idkind)fcp->UU.U2.vkind == actual) {
gattr.UU.U1.access = drct;
gattr.UU.U1.UU.U0.vlevel = fcp->UU.U2.vlev;
gattr.UU.U1.UU.U0.dplmt = fcp->UU.U2.vaddr;
} else { /*lod*/
gen2t(54, level – fcp->UU.U2.vlev, fcp->UU.U2.vaddr, nilptr, LINK->LINK);
gattr.UU.U1.access = indrct;
gattr.UU.U1.UU.idplmt = 0;
}
break;
case field:
WITH1 = &display[disx];
if ((where)WITH1->occur == crec) {
gattr.UU.U1.access = drct;
gattr.UU.U1.UU.U0.vlevel = WITH1->UU.U1.clev;
gattr.UU.U1.UU.U0.dplmt = WITH1->UU.U1.cdspl + fcp->UU.fldaddr;
} else {
if (level == 1) /*ldo*/
gen1t(39, WITH1->UU.vdspl, nilptr, LINK->LINK);
else /*lod*/
gen2t(54, 0, WITH1->UU.vdspl, nilptr, LINK->LINK);
gattr.UU.U1.access = indrct;
gattr.UU.U1.UU.idplmt = fcp->UU.fldaddr;
}
break;
case func:
if ((declkind)fcp->UU.U4.pfdeckind == standard) {
error(150);
gattr.typtr = NULL;
} else {
if ((idkind)fcp->UU.U4.UU.U1.pfkind == formal)
error(151);
else {
if (fcp->UU.U4.UU.U1.pflev + 1 != level ||
LINK->LINK->LINK->fprocp != fcp)
error(177);
}
gattr.UU.U1.access = drct;
gattr.UU.U1.UU.U0.vlevel = fcp->UU.U4.UU.U1.pflev + 1;
gattr.UU.U1.UU.U0.dplmt = 0; /*impl. relat. addr. of fct. result*/
}
break;
}/*case*/
if (!P_inset(sy, P_setunion(SET, selectsys, fsys))) {
error(59);
skip(P_setunion(SET1, selectsys, fsys), LINK->LINK->LINK);
}
while (P_inset(sy, selectsys)) {
/*[*/
if (sy == lbrack) {
do {
lattr = gattr;
if (lattr.typtr != NULL) {
if ((structform)lattr.typtr->form != arrays) {
error(138);
lattr.typtr = NULL;
}
}
loadaddress(LINK->LINK);
insymbol();
expression(P_setunion(SET1, fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rbrack)))),
LINK);
load(LINK->LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != scalar)
error(113);
else if (!comptypes(gattr.typtr, intptr, LINK->LINK->LINK))
gen0t(58, gattr.typtr, LINK->LINK);
}
if (lattr.typtr != NULL) {
WITH = lattr.typtr;
if (comptypes(WITH->UU.U4.inxtype, gattr.typtr, LINK->LINK->LINK)) {
if (WITH->UU.U4.inxtype != NULL) {
getbounds(WITH->UU.U4.inxtype, &lmin, &lmax);
if (debug) /*chk*/
gen2t(45, lmin, lmax, intptr, LINK->LINK);
if (lmin > 0) /*dec*/
gen1t(31, lmin, intptr, LINK->LINK);
else if (lmin < 0)
gen1t(34, -lmin, intptr, LINK->LINK);
/*or simply gen1(31,lmin)*/
}
} else
error(139);
gattr.typtr = WITH->UU.U4.aeltype;
gattr.kind = varbl;
gattr.UU.U1.access = indrct;
gattr.UU.U1.UU.idplmt = 0;
if (gattr.typtr != NULL) {
lsize = gattr.typtr->size;
align(gattr.typtr, &lsize); /*ixa*/
gen1(36, lsize, LINK->LINK);
}
}
} while (sy == comma);
if (sy == rbrack)
insymbol();
else
error(12);
} /*if sy = lbrack*/
else {
/*.*/
if (sy == period) {
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != records) {
error(140);
gattr.typtr = NULL;
}
}
insymbol();
if (sy == ident) { /*with gattr*/
if (gattr.typtr != NULL) {
searchsection(gattr.typtr->UU.U5.fstfld, &lcp);
if (lcp == NULL) {
error(152);
gattr.typtr = NULL;
} else {
gattr.typtr = lcp->idtype;
switch (gattr.UU.U1.access) {
case drct:
gattr.UU.U1.UU.U0.dplmt += lcp->UU.fldaddr;
break;
case indrct:
gattr.UU.U1.UU.idplmt += lcp->UU.fldaddr;
break;
case inxd:
error(400);
break;
}
}
}
insymbol();
} /*sy = ident*/
else
error(2);
} /*if sy = period*/
else {
/*^*/
if (gattr.typtr != NULL) {
WITH = gattr.typtr;
if ((structform)WITH->form == pointer) {
load(LINK->LINK);
gattr.typtr = WITH->UU.eltype;
if (debug) /*chk*/
gen2t(45, 1, maxaddr, nilptr, LINK->LINK);
gattr.kind = varbl;
gattr.UU.U1.access = indrct;
gattr.UU.U1.UU.idplmt = 0;
} else {
if ((structform)WITH->form == files)
gattr.typtr = WITH->UU.filtype;
else
error(141);
}
}
insymbol();
}
}
if (!P_inset(sy, P_setunion(SET, fsys, selectsys))) {
error(6);
skip(P_setunion(SET1, fsys, selectsys), LINK->LINK->LINK);
}
} /*while*/
/*ord*/
/*inc*/
}
/* Local variables for call: */
struct LOC_call {
struct LOC_statement *LINK;
setofsys fsys;
identifier *fcp;
char lkey;
} ;
Local void variable(long *fsys, struct LOC_call *LINK)
{
identifier *lcp;
/*variable*/
if (sy == ident) {
searchid((1L << ((long)vars)) | (1L << ((long)field)), &lcp);
insymbol();
} else {
error(2);
lcp = uvarptr;
}
selector(fsys, lcp, LINK->LINK);
}
Local void getputresetrewrite(struct LOC_call *LINK)
{
setofsys SET, SET1;
/*getputresetrewrite*/
variable(P_setunion(SET1, LINK->fsys, P_expset(SET, 1L << ((long)rparent))),
LINK);
loadaddress(LINK->LINK->LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != files)
error(116);
}
if (LINK->lkey <= 2) /*csp*/
gen1(30, LINK->lkey, LINK->LINK->LINK);
else
error(399);
/*get,put*/
}
Local void read(struct LOC_call *LINK)
{
levrange llev;
addrrange laddr;
structure *lsp;
setofsys SET, SET1;
/*read*/
llev = 1;
laddr = lcaftermarkstack;
if (sy == lparent) {
insymbol();
variable(P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK);
lsp = gattr.typtr;
LINK->LINK->LINK->LINK->test = false;
if (lsp != NULL) {
if ((structform)lsp->form == files) {
if (lsp->UU.filtype == charptr) {
llev = gattr.UU.U1.UU.U0.vlevel;
laddr = gattr.UU.U1.UU.U0.dplmt;
} else
error(399);
if (sy == rparent) {
if (LINK->lkey == 5)
error(116);
LINK->LINK->LINK->LINK->test = true;
} else {
if (sy != comma) {
error(116);
skip(P_setunion(SET1, LINK->fsys,
P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK->LINK->LINK->LINK);
}
}
if (sy == comma) {
insymbol();
variable(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK);
} else
LINK->LINK->LINK->LINK->test = true;
}
}
if (!LINK->LINK->LINK->LINK->test) {
do {
loadaddress(LINK->LINK->LINK); /*lda*/
gen2(50, level – llev, laddr, LINK->LINK->LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form <= subrange) {
if (comptypes(intptr, gattr.typtr, LINK->LINK->LINK->LINK))
/*csp*/
gen1(30, 3, LINK->LINK->LINK);
else {
if (comptypes(realptr, gattr.typtr, LINK->LINK->LINK->LINK))
/*csp*/
gen1(30, 4, LINK->LINK->LINK);
else {
if (comptypes(charptr, gattr.typtr, LINK->LINK->LINK->LINK))
/*csp*/
gen1(30, 5, LINK->LINK->LINK);
else
error(399);
/*rdc*/
}
/*rdr*/
}
/*rdi*/
} else
error(116);
}
LINK->LINK->LINK->LINK->test = (sy != comma);
if (!LINK->LINK->LINK->LINK->test) {
insymbol();
variable(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK);
}
} while (!LINK->LINK->LINK->LINK->test);
}
if (sy == rparent)
insymbol();
else
error(4);
} else if (LINK->lkey == 5)
error(116);
if (LINK->lkey == 11) { /*lda*/
gen2(50, level – llev, laddr, LINK->LINK->LINK); /*csp*/
/*rln*/
gen1(30, 21, LINK->LINK->LINK);
}
}
Local void write(struct LOC_call *LINK)
{
structure *lsp;
boolean default_;
char llkey;
levrange llev;
addrrange laddr, len;
setofsys SET, SET1;
/*write*/
llkey = LINK->lkey;
llev = 1;
laddr = lcaftermarkstack + charmax;
if (sy == lparent) {
insymbol();
expression(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)colon)) |
(1L << ((long)rparent)))), LINK->LINK);
lsp = gattr.typtr;
LINK->LINK->LINK->LINK->test = false;
if (lsp != NULL) {
if ((structform)lsp->form == files) {
if (lsp->UU.filtype == charptr) {
llev = gattr.UU.U1.UU.U0.vlevel;
laddr = gattr.UU.U1.UU.U0.dplmt;
} else
error(399);
if (sy == rparent) {
if (llkey == 6)
error(116);
LINK->LINK->LINK->LINK->test = true;
} else {
if (sy != comma) {
error(116);
skip(P_setunion(SET1, LINK->fsys,
P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK->LINK->LINK->LINK);
}
}
if (sy == comma) {
insymbol();
expression(P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)colon)) |
(1L << ((long)rparent)))), LINK->LINK);
} else
LINK->LINK->LINK->LINK->test = true;
}
}
if (!LINK->LINK->LINK->LINK->test) {
do {
lsp = gattr.typtr;
if (lsp != NULL) {
if ((structform)lsp->form <= subrange)
load(LINK->LINK->LINK);
else
loadaddress(LINK->LINK->LINK);
}
if (sy == colon) {
insymbol();
expression(P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)colon)) |
(1L << ((long)rparent)))), LINK->LINK);
if (gattr.typtr != NULL) {
if (gattr.typtr != intptr)
error(116);
}
load(LINK->LINK->LINK);
default_ = false;
} else
default_ = true;
if (sy == colon) {
insymbol();
expression(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK->LINK);
if (gattr.typtr != NULL) {
if (gattr.typtr != intptr)
error(116);
}
if (lsp != realptr)
error(124);
load(LINK->LINK->LINK);
error(399);
} else {
if (lsp == intptr) {
if (default_) /*ldc*/
gen2(51, 1, 10, LINK->LINK->LINK);
/*lda*/
gen2(50, level – llev, laddr, LINK->LINK->LINK); /*csp*/
/*wri*/
gen1(30, 6, LINK->LINK->LINK);
} else {
if (lsp == realptr) {
if (default_) /*ldc*/
gen2(51, 1, 20, LINK->LINK->LINK);
/*lda*/
gen2(50, level – llev, laddr, LINK->LINK->LINK); /*csp*/
/*wrr*/
gen1(30, 8, LINK->LINK->LINK);
} else {
if (lsp == charptr) {
if (default_) /*ldc*/
gen2(51, 1, 1, LINK->LINK->LINK);
/*lda*/
gen2(50, level – llev, laddr, LINK->LINK->LINK); /*csp*/
/*wrc*/
gen1(30, 9, LINK->LINK->LINK);
} else {
if (lsp != NULL) {
if ((structform)lsp->form == scalar)
error(399);
else {
if (string(lsp, LINK->LINK->LINK->LINK)) {
len = lsp->size;
if (default_) /*ldc*/
gen2(51, 1, len, LINK->LINK->LINK);
/*ldc*/
gen2(51, 1, len, LINK->LINK->LINK); /*lda*/
gen2(50, level – llev, laddr, LINK->LINK->LINK);
/*csp*/
/*wrs*/
gen1(30, 10, LINK->LINK->LINK);
} else
error(116);
}
}
}
}
}
}
LINK->LINK->LINK->LINK->test = (sy != comma);
if (!LINK->LINK->LINK->LINK->test) {
insymbol();
expression(P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)colon)) |
(1L << ((long)rparent)))), LINK->LINK);
}
} while (!LINK->LINK->LINK->LINK->test);
}
if (sy == rparent)
insymbol();
else
error(4);
} else if (LINK->lkey == 6)
error(116);
if (llkey == 12) { /*writeln*/
gen2(50, level – llev, laddr, LINK->LINK->LINK); /*csp*/
/*wln*/
gen1(30, 22, LINK->LINK->LINK);
}
/*lda*/
}
Local void pack(struct LOC_call *LINK)
{
structure *lsp, *lsp1;
setofsys SET, SET1;
structure *WITH;
/*pack*/
error(399);
variable(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK);
lsp = NULL;
lsp1 = NULL;
if (gattr.typtr != NULL) {
WITH = gattr.typtr;
if ((structform)WITH->form == arrays) {
lsp = WITH->UU.U4.inxtype;
lsp1 = WITH->UU.U4.aeltype;
} else
error(116);
}
if (sy == comma)
insymbol();
else
error(20);
expression(P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK->LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != scalar)
error(116);
else {
if (!comptypes(lsp, gattr.typtr, LINK->LINK->LINK->LINK))
error(116);
}
}
if (sy == comma)
insymbol();
else
error(20);
variable(P_setunion(SET1, LINK->fsys, P_expset(SET, 1L << ((long)rparent))),
LINK);
if (gattr.typtr == NULL)
return;
WITH = gattr.typtr;
if ((structform)WITH->form == arrays) {
if ((!comptypes(WITH->UU.U4.aeltype, lsp1, LINK->LINK->LINK->LINK)) |
(!comptypes(WITH->UU.U4.inxtype, lsp, LINK->LINK->LINK->LINK)))
error(116);
} else
error(116);
}
Local void unpack(struct LOC_call *LINK)
{
structure *lsp, *lsp1;
setofsys SET, SET1;
structure *WITH;
/*unpack*/
error(399);
variable(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK);
lsp = NULL;
lsp1 = NULL;
if (gattr.typtr != NULL) {
WITH = gattr.typtr;
if ((structform)WITH->form == arrays) {
lsp = WITH->UU.U4.inxtype;
lsp1 = WITH->UU.U4.aeltype;
} else
error(116);
}
if (sy == comma)
insymbol();
else
error(20);
variable(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK);
if (gattr.typtr != NULL) {
WITH = gattr.typtr;
if ((structform)WITH->form == arrays) {
if ((!comptypes(WITH->UU.U4.aeltype, lsp1, LINK->LINK->LINK->LINK)) |
(!comptypes(WITH->UU.U4.inxtype, lsp, LINK->LINK->LINK->LINK)))
error(116);
} else
error(116);
}
if (sy == comma)
insymbol();
else
error(20);
expression(P_setunion(SET1, LINK->fsys,
P_expset(SET, 1L << ((long)rparent))), LINK->LINK);
if (gattr.typtr == NULL)
return;
if ((structform)gattr.typtr->form != scalar)
error(116);
else {
if (!comptypes(lsp, gattr.typtr, LINK->LINK->LINK->LINK))
error(116);
}
}
Local void new_(struct LOC_call *LINK)
{
structure *lsp, *lsp1;
long varts;
addrrange lsize;
valu lval;
setofsys SET, SET1;
structure *WITH;
/*new*/
variable(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK);
loadaddress(LINK->LINK->LINK);
lsp = NULL;
varts = 0;
lsize = 0;
if (gattr.typtr != NULL) {
WITH = gattr.typtr;
if ((structform)WITH->form == pointer) {
if (WITH->UU.eltype != NULL) {
lsize = WITH->UU.eltype->size;
if ((structform)WITH->UU.eltype->form == records)
lsp = WITH->UU.eltype->UU.U5.recvar;
}
} else
error(116);
}
while (sy == comma) { /*while*/
insymbol();
constant_(P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)rparent)))),
&lsp1, &lval, LINK->LINK->LINK->LINK);
varts++;
/*check to insert here: is constant in tagfieldtype range*/
if (lsp == NULL)
error(158);
else {
if ((structform)lsp->form != tagfld)
error(162);
else {
if (lsp->UU.U7.tagfieldp != NULL) {
if (string(lsp1, LINK->LINK->LINK->LINK) || lsp1 == realptr)
error(159);
else {
if (comptypes(lsp->UU.U7.tagfieldp->idtype, lsp1,
LINK->LINK->LINK->LINK)) {
lsp1 = lsp->UU.U7.fstvar;
while (lsp1 != NULL) {
WITH = lsp1;
if (WITH->UU.U8.varval.UU.ival == lval.UU.ival) {
lsize = WITH->size;
lsp = WITH->UU.U8.subvar;
goto _L1;
}
lsp1 = WITH->UU.U8.nxtvar;
}
lsize = lsp->size;
lsp = NULL;
} else
error(116);
}
}
}
}
_L1: ;
}
/*ldc*/
gen2(51, 1, lsize, LINK->LINK->LINK); /*csp*/
/*new*/
gen1(30, 12, LINK->LINK->LINK);
}
Local void mark__(struct LOC_call *LINK)
{
setofsys SET, SET1;
/*mark*/
variable(P_setunion(SET1, LINK->fsys, P_expset(SET, 1L << ((long)rparent))),
LINK);
if (gattr.typtr == NULL)
return;
if ((structform)gattr.typtr->form == pointer) {
loadaddress(LINK->LINK->LINK); /*csp*/
/*sav*/
gen1(30, 23, LINK->LINK->LINK);
} else
error(116);
}
Local void release__(struct LOC_call *LINK)
{
setofsys SET, SET1;
/*release*/
variable(P_setunion(SET1, LINK->fsys, P_expset(SET, 1L << ((long)rparent))),
LINK);
if (gattr.typtr == NULL)
return;
if ((structform)gattr.typtr->form == pointer) {
load(LINK->LINK->LINK); /*csp*/
/*rst*/
gen1(30, 13, LINK->LINK->LINK);
} else
error(116);
}
Local void abs_(struct LOC_call *LINK)
{
/*abs*/
if (gattr.typtr == NULL)
return;
if (gattr.typtr == intptr) { /*abi*/
gen0(0, LINK->LINK->LINK);
return;
}
if (gattr.typtr == realptr) /*abr*/
gen0(1, LINK->LINK->LINK);
else {
error(125);
gattr.typtr = intptr;
}
}
Local void sqr_(struct LOC_call *LINK)
{
/*sqr*/
if (gattr.typtr == NULL)
return;
if (gattr.typtr == intptr) { /*sqi*/
gen0(24, LINK->LINK->LINK);
return;
}
if (gattr.typtr == realptr) /*sqr*/
gen0(25, LINK->LINK->LINK);
else {
error(125);
gattr.typtr = intptr;
}
}
Local void trunc_(struct LOC_call *LINK)
{
/*trunc*/
if (gattr.typtr != NULL) { /*trc*/
if (gattr.typtr != realptr)
error(125);
}
gen0(27, LINK->LINK->LINK);
gattr.typtr = intptr;
}
Local void odd_(struct LOC_call *LINK)
{
/*odd*/
if (gattr.typtr != NULL) { /*odd*/
if (gattr.typtr != intptr)
error(125);
}
gen0(20, LINK->LINK->LINK);
gattr.typtr = boolptr;
}
Local void ord_(struct LOC_call *LINK)
{
/*ord*/
if (gattr.typtr != NULL) { /*ord*/
if ((structform)gattr.typtr->form >= power)
error(125);
}
gen0t(58, gattr.typtr, LINK->LINK->LINK);
gattr.typtr = intptr;
}
Local void chr_(struct LOC_call *LINK)
{
/*chr*/
if (gattr.typtr != NULL) { /*chr*/
if (gattr.typtr != intptr)
error(125);
}
gen0(59, LINK->LINK->LINK);
gattr.typtr = charptr;
}
Local void predsucc(struct LOC_call *LINK)
{
/*predsucc*/
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != scalar)
error(125);
}
if (LINK->lkey == 7) /*dec*/
gen1t(31, 1, gattr.typtr, LINK->LINK->LINK);
else /*inc*/
gen1t(34, 1, gattr.typtr, LINK->LINK->LINK);
}
Local void eof_(struct LOC_call *LINK)
{
setofsys SET, SET1;
/*eof*/
if (sy == lparent) {
insymbol();
variable(P_setunion(SET1, LINK->fsys,
P_expset(SET, 1L << ((long)rparent))), LINK);
if (sy == rparent)
insymbol();
else
error(4);
} else {
gattr.typtr = textptr;
gattr.kind = varbl;
gattr.UU.U1.access = drct;
gattr.UU.U1.UU.U0.vlevel = 1;
gattr.UU.U1.UU.U0.dplmt = lcaftermarkstack;
}
loadaddress(LINK->LINK->LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != files)
error(125);
}
if (LINK->lkey == 9) /*eof*/
gen0(8, LINK->LINK->LINK);
else /*csp*/
gen1(30, 14, LINK->LINK->LINK);
gattr.typtr = boolptr;
/*eln*/
}
Local void callnonstandard(struct LOC_call *LINK)
{
identifier *nxt, *lcp;
structure *lsp;
idkind lkind;
boolean lb;
addrrange locpar, llc;
identifier *WITH;
setofsys SET, SET1, SET2, SET3;
/*callnonstandard*/
locpar = 0;
WITH = LINK->fcp;
nxt = WITH->next;
lkind = (idkind)WITH->UU.U4.UU.U1.pfkind;
if (!WITH->UU.U4.UU.U1.UU.U0.externl) /*mst*/
gen1(41, level – WITH->UU.U4.UU.U1.pflev, LINK->LINK->LINK);
if (sy == lparent) { /*if lparent*/
llc = lc;
do {
lb = false; /*decide whether proc/func must be passed*/
if (lkind == actual) {
if (nxt == NULL)
error(126);
else
lb = (((1L << nxt->klass) &
((1L << ((long)proc)) | (1L << ((long)func)))) != 0);
} else
error(399);
/*For formal proc/func, lb is false and expression
will be called, which will always interpret a proc/func id
at its beginning as a call rather than a parameter passing.
In this implementation, parameter procedures/functions
are therefore not allowed to have procedure/function
parameters*/
insymbol();
if (lb) { /*pass function or procedure*/
error(399);
if (sy != ident) {
error(2);
skip(P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK->LINK->LINK->LINK);
} else {
if ((idclass)nxt->klass == proc)
searchid(1L << ((long)proc), &lcp);
else {
searchid(1L << ((long)func), &lcp);
if (!comptypes(lcp->idtype, nxt->idtype, LINK->LINK->LINK->LINK))
error(128);
}
insymbol();
if (!P_inset(sy, P_setunion(SET1, LINK->fsys, P_expset(SET,
(1L << ((long)comma)) | (1L << ((long)rparent)))))) {
error(6);
skip(P_setunion(SET3, LINK->fsys,
P_expset(SET2,
(1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK->LINK->LINK->LINK);
}
}
} /*if lb*/
else {
expression(P_setunion(SET1, LINK->fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rparent)))),
LINK->LINK);
if (gattr.typtr != NULL) {
if (lkind == actual) {
if (nxt != NULL) {
lsp = nxt->idtype;
if (lsp != NULL) {
if ((idkind)nxt->UU.U2.vkind == actual) {
if ((structform)lsp->form <= power) {
load(LINK->LINK->LINK);
if (debug)
checkbnds(lsp, LINK->LINK->LINK);
if (comptypes(realptr, lsp, LINK->LINK->LINK->LINK) &&
gattr.typtr == intptr)
{ /*flt*/
gen0(10, LINK->LINK->LINK);
gattr.typtr = realptr;
}
locpar += lsp->size;
align(parmptr, &locpar);
} else {
loadaddress(LINK->LINK->LINK);
locpar += ptrsize;
align(parmptr, &locpar);
}
} else {
if (gattr.kind == varbl) {
loadaddress(LINK->LINK->LINK);
locpar += ptrsize;
align(parmptr, &locpar);
} else
error(154);
}
if (!comptypes(lsp, gattr.typtr, LINK->LINK->LINK->LINK))
error(142);
}
}
}
}
}
if (lkind == actual && nxt != NULL)
nxt = nxt->next;
} while (sy == comma);
lc = llc;
if (sy == rparent)
insymbol();
else
error(4);
}
if (lkind == actual) {
if (nxt != NULL)
error(126);
WITH = LINK->fcp;
if (WITH->UU.U4.UU.U1.UU.U0.externl) /*csp*/
gen1(30, WITH->UU.U4.UU.U1.pfname, LINK->LINK->LINK);
else /*cup*/
gencupent(46, locpar, WITH->UU.U4.UU.U1.pfname, LINK->LINK->LINK);
}
gattr.typtr = LINK->fcp->idtype;
/*lkind = formal*/
/*pass formal param*/
}
Local void call(long *fsys_, identifier *fcp_, struct LOC_statement *LINK)
{
struct LOC_call V;
setofsys SET, SET1;
V.LINK = LINK;
/*call*/
P_setcpy(V.fsys, fsys_);
V.fcp = fcp_;
if ((declkind)V.fcp->UU.U4.pfdeckind != standard) {
callnonstandard(&V);
return;
} /*standard procedures and functions*/
V.lkey = V.fcp->UU.U4.UU.key;
if ((idclass)V.fcp->klass == proc) {
if (((1L << V.lkey) & 0x1860) == 0) {
if (sy == lparent)
insymbol();
else
error(9);
}
switch (V.lkey) {
case 1:
case 2:
case 3:
case 4:
getputresetrewrite(&V);
break;
case 5:
case 11:
read(&V);
break;
case 6:
case 12:
write(&V);
break;
case 7:
pack(&V);
break;
case 8:
unpack(&V);
break;
case 9:
new_(&V);
break;
case 10:
release__(&V);
break;
case 13:
mark__(&V);
break;
}
if (((1L << V.lkey) & 0x1860) != 0)
return;
if (sy == rparent)
insymbol();
else
error(4);
return;
}
if (V.lkey <= 8) {
if (sy == lparent)
insymbol();
else
error(9);
expression(P_setunion(SET1, V.fsys, P_expset(SET, 1L << ((long)rparent))),
LINK);
load(LINK->LINK);
}
switch (V.lkey) {
case 1:
abs_(&V);
break;
case 2:
sqr_(&V);
break;
case 3:
trunc_(&V);
break;
case 4:
odd_(&V);
break;
case 5:
ord_(&V);
break;
case 6:
chr_(&V);
break;
case 7:
case 8:
predsucc(&V);
break;
case 9:
case 10:
eof_(&V);
break;
}
if (V.lkey > 8)
return;
if (sy == rparent)
insymbol();
else
error(4);
}
/* Local variables for expression: */
struct LOC_expression {
struct LOC_statement *LINK;
} ;
/* Local variables for simpleexpression: */
struct LOC_simpleexpression {
struct LOC_expression *LINK;
} ;
/* Local variables for term: */
struct LOC_term {
struct LOC_simpleexpression *LINK;
} ;
Local void factor(long *fsys, struct LOC_term *LINK)
{
identifier *lcp;
constant *lvp;
boolean varpart;
setty cstpart;
structure *lsp;
setofsys SET;
structure *WITH;
setofsys SET1;
/*factor*/
if (!P_inset(sy, facbegsys)) {
error(58);
skip(P_setunion(SET, fsys, facbegsys), LINK->LINK->LINK->LINK->LINK->LINK);
gattr.typtr = NULL;
}
while (P_inset(sy, facbegsys)) {
switch (sy) { /*case*/
/*id*/
case ident:
searchid((1L << ((long)konst)) | (1L << ((long)vars)) |
(1L << ((long)field)) | (1L << ((long)func)), &lcp);
insymbol();
if ((idclass)lcp->klass == func) {
call(fsys, lcp, LINK->LINK->LINK->LINK);
gattr.kind = expr;
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form == subrange)
gattr.typtr = gattr.typtr->UU.U1.rangetype;
}
} else {
if ((idclass)lcp->klass == konst) {
gattr.typtr = lcp->idtype;
gattr.kind = cst;
gattr.UU.cval = lcp->UU.values;
} else {
selector(fsys, lcp, LINK->LINK->LINK->LINK);
if (gattr.typtr != NULL) { /*elim.subr.types to*/
WITH = gattr.typtr;
if ((structform)WITH->form == subrange)
gattr.typtr = WITH->UU.U1.rangetype;
}
/*simplify later tests*/
}
}
break;
/*cst*/
case intconst:
gattr.typtr = intptr;
gattr.kind = cst;
gattr.UU.cval = val;
insymbol();
break;
case realconst:
gattr.typtr = realptr;
gattr.kind = cst;
gattr.UU.cval = val;
insymbol();
break;
case stringconst:
if (lgth == 1)
gattr.typtr = charptr;
else {
lsp = Malloc(sizeof(structure));
lsp->UU.U4.aeltype = charptr;
(structform)lsp->form = arrays;
lsp->UU.U4.inxtype = NULL;
lsp->size = lgth;
gattr.typtr = lsp;
}
gattr.kind = cst;
gattr.UU.cval = val;
insymbol();
break;
/* ( */
case lparent:
insymbol();
expression(P_setunion(SET1, fsys, P_expset(SET, 1L << ((long)rparent))),
LINK->LINK->LINK->LINK);
if (sy == rparent)
insymbol();
else
error(4);
break;
/*not*/
case notsy:
insymbol();
factor(fsys, LINK);
load(LINK->LINK->LINK->LINK->LINK); /*not*/
gen0(19, LINK->LINK->LINK->LINK->LINK);
if (gattr.typtr != NULL) {
if (gattr.typtr != boolptr) {
error(135);
gattr.typtr = NULL;
}
}
break;
/*[*/
case lbrack:
insymbol();
P_expset(cstpart, 0);
varpart = false;
/* p2c: pcom.p, line 2831:
* Note: No SpecialMalloc form known for STRUCTURE.POWER [187] */
lsp = Malloc(sizeof(structure));
lsp->UU.elset = NULL;
lsp->size = setsize;
(structform)lsp->form = power;
if (sy == rbrack) {
gattr.typtr = lsp;
gattr.kind = cst;
insymbol();
} else {
do {
expression(P_setunion(SET1, fsys,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)rbrack)))),
LINK->LINK->LINK->LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != scalar) {
error(136);
gattr.typtr = NULL;
} else {
if (comptypes(lsp->UU.elset, gattr.typtr,
LINK->LINK->LINK->LINK->LINK->LINK)) {
if (gattr.kind == cst) {
if ((unsigned long)gattr.UU.cval.UU.ival > sethigh)
error(304);
else
P_addset(cstpart, gattr.UU.cval.UU.ival);
} else {
load(LINK->LINK->LINK->LINK->LINK);
if (!comptypes(gattr.typtr, intptr,
LINK->LINK->LINK->LINK->LINK->LINK))
/*ord*/
gen0t(58, gattr.typtr, LINK->LINK->LINK->LINK->LINK);
/*sgs*/
gen0(23, LINK->LINK->LINK->LINK->LINK);
if (varpart) /*uni*/
gen0(28, LINK->LINK->LINK->LINK->LINK);
else
varpart = true;
}
lsp->UU.elset = gattr.typtr;
gattr.typtr = lsp;
} else
error(137);
}
}
LINK->LINK->LINK->LINK->LINK->LINK->test = (sy != comma);
if (!LINK->LINK->LINK->LINK->LINK->LINK->test)
insymbol();
} while (!LINK->LINK->LINK->LINK->LINK->LINK->test);
if (sy == rbrack)
insymbol();
else
error(12);
}
if (varpart) {
if (*cstpart != 0) {
lvp = Malloc(sizeof(constant));
P_setcpy(lvp->UU.pval, cstpart);
lvp->cclass = pset;
if (LINK->LINK->LINK->LINK->LINK->cstptrix == cstoccmax)
error(254);
else {
LINK->LINK->LINK->LINK->LINK->cstptrix++;
LINK->LINK->LINK->LINK->LINK->cstptr[LINK->LINK->LINK->LINK->
LINK->cstptrix – 1] = lvp;
/*ldc*/
gen2(51, 5, LINK->LINK->LINK->LINK->LINK->cstptrix,
LINK->LINK->LINK->LINK->LINK);
/*uni*/
gen0(28, LINK->LINK->LINK->LINK->LINK);
gattr.kind = expr;
}
}
/* p2c: pcom.p, line 2875:
* Note: No SpecialMalloc form known for CONSTANT.PSET [187] */
} else {
lvp = Malloc(sizeof(constant));
P_setcpy(lvp->UU.pval, cstpart);
lvp->cclass = pset;
gattr.UU.cval.UU.valp = lvp;
}
break;
}
if (!P_inset(sy, fsys)) {
error(6);
skip(P_setunion(SET, fsys, facbegsys),
LINK->LINK->LINK->LINK->LINK->LINK);
}
} /*while*/
/* p2c: pcom.p, line 2807:
* Note: No SpecialMalloc form known for STRUCTURE.ARRAYS [187] */
/* p2c: pcom.p, line 2887:
* Note: No SpecialMalloc form known for CONSTANT.PSET [187] */
}
Local void term(long *fsys, struct LOC_simpleexpression *LINK)
{
struct LOC_term V;
attr lattr;
operator_ lop;
setofsys SET, SET1;
V.LINK = LINK;
/*term*/
factor(P_setunion(SET1, fsys, P_expset(SET, 1L << ((long)mulop))), &V);
while (sy == mulop) {
load(LINK->LINK->LINK->LINK);
lattr = gattr;
lop = op;
insymbol();
factor(P_setunion(SET1, fsys, P_expset(SET, 1L << ((long)mulop))), &V);
load(LINK->LINK->LINK->LINK);
if (lattr.typtr == NULL || gattr.typtr == NULL) {
gattr.typtr = NULL;
continue;
}
switch (lop) {
/***/
case mul:
if (lattr.typtr == intptr && gattr.typtr == intptr) /*mpi*/
gen0(15, LINK->LINK->LINK->LINK);
else {
if (lattr.typtr == intptr) { /*flo*/
gen0(9, LINK->LINK->LINK->LINK);
lattr.typtr = realptr;
} else {
if (gattr.typtr == intptr) { /*flt*/
gen0(10, LINK->LINK->LINK->LINK);
gattr.typtr = realptr;
}
}
if (lattr.typtr == realptr && gattr.typtr == realptr) /*mpr*/
gen0(16, LINK->LINK->LINK->LINK);
else {
if (((structform)lattr.typtr->form == power) & comptypes(lattr.typtr,
gattr.typtr, LINK->LINK->LINK->LINK->LINK))
/*int*/
gen0(12, LINK->LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
}
}
break;
/* / */
case rdiv:
if (gattr.typtr == intptr) { /*flt*/
gen0(10, LINK->LINK->LINK->LINK);
gattr.typtr = realptr;
}
if (lattr.typtr == intptr) { /*flo*/
gen0(9, LINK->LINK->LINK->LINK);
lattr.typtr = realptr;
}
if (lattr.typtr == realptr && gattr.typtr == realptr) /*dvr*/
gen0(7, LINK->LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
break;
/*div*/
case idiv:
if (lattr.typtr == intptr && gattr.typtr == intptr) /*dvi*/
gen0(6, LINK->LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
break;
/*mod*/
case imod:
if (lattr.typtr == intptr && gattr.typtr == intptr) /*mod*/
gen0(14, LINK->LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
break;
/*and*/
case andop:
if (lattr.typtr == boolptr && gattr.typtr == boolptr) /*and*/
gen0(4, LINK->LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
break;
}/*case*/
} /*while*/
}
Local void simpleexpression(long *fsys, struct LOC_expression *LINK)
{
struct LOC_simpleexpression V;
attr lattr;
operator_ lop;
boolean signed_;
setofsys SET, SET1;
V.LINK = LINK;
/*simpleexpression*/
signed_ = false;
if (sy == addop &&
((1L << ((long)op)) & ((1L << ((long)plus)) | (1L << ((long)minus)))) != 0) {
signed_ = (op == minus);
insymbol();
}
term(P_setunion(SET1, fsys, P_expset(SET, 1L << ((long)addop))), &V);
if (signed_) {
load(LINK->LINK->LINK);
if (gattr.typtr == intptr) /*ngi*/
gen0(17, LINK->LINK->LINK);
else {
if (gattr.typtr == realptr) /*ngr*/
gen0(18, LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
}
}
while (sy == addop) {
load(LINK->LINK->LINK);
lattr = gattr;
lop = op;
insymbol();
term(P_setunion(SET1, fsys, P_expset(SET, 1L << ((long)addop))), &V);
load(LINK->LINK->LINK);
if (lattr.typtr == NULL || gattr.typtr == NULL) {
gattr.typtr = NULL;
continue;
}
switch (lop) {
/*+*/
case plus:
if (lattr.typtr == intptr && gattr.typtr == intptr) /*adi*/
gen0(2, LINK->LINK->LINK);
else {
if (lattr.typtr == intptr) { /*flo*/
gen0(9, LINK->LINK->LINK);
lattr.typtr = realptr;
} else {
if (gattr.typtr == intptr) { /*flt*/
gen0(10, LINK->LINK->LINK);
gattr.typtr = realptr;
}
}
if (lattr.typtr == realptr && gattr.typtr == realptr) /*adr*/
gen0(3, LINK->LINK->LINK);
else if (((structform)lattr.typtr->form == power) &
comptypes(lattr.typtr, gattr.typtr, LINK->LINK->LINK->LINK))
gen0(28, LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
}
break;
/*-*/
case minus:
if (lattr.typtr == intptr && gattr.typtr == intptr) /*sbi*/
gen0(21, LINK->LINK->LINK);
else {
if (lattr.typtr == intptr) { /*flo*/
gen0(9, LINK->LINK->LINK);
lattr.typtr = realptr;
} else {
if (gattr.typtr == intptr) { /*flt*/
gen0(10, LINK->LINK->LINK);
gattr.typtr = realptr;
}
}
if (lattr.typtr == realptr && gattr.typtr == realptr) /*sbr*/
gen0(22, LINK->LINK->LINK);
else {
if (((structform)lattr.typtr->form == power) &
comptypes(lattr.typtr, gattr.typtr, LINK->LINK->LINK->LINK))
/*dif*/
gen0(5, LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
}
}
break;
/*or*/
case orop:
if (lattr.typtr == boolptr && gattr.typtr == boolptr) /*ior*/
gen0(13, LINK->LINK->LINK);
else {
error(134);
gattr.typtr = NULL;
}
break;
}/*case*/
} /*while*/
/*uni*/
}
Local void expression(long *fsys, struct LOC_statement *LINK)
{
struct LOC_expression V;
attr lattr;
operator_ lop;
Char typind;
addrrange lsize;
setofsys SET, SET1;
V.LINK = LINK;
/*expression*/
simpleexpression(P_setunion(SET1, fsys, P_expset(SET, 1L << ((long)relop))),
&V);
if (sy != relop) {
return;
} /*sy = relop*/
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form <= power)
load(LINK->LINK);
else
loadaddress(LINK->LINK);
}
lattr = gattr;
lop = op;
if (lop == inop) {
if (!comptypes(gattr.typtr, intptr, LINK->LINK->LINK)) /*ord*/
gen0t(58, gattr.typtr, LINK->LINK);
}
insymbol();
simpleexpression(fsys, &V);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form <= power)
load(LINK->LINK);
else
loadaddress(LINK->LINK);
}
if (lattr.typtr != NULL && gattr.typtr != NULL) {
if (lop == inop) {
if ((structform)gattr.typtr->form == power) {
if (comptypes(lattr.typtr, gattr.typtr->UU.elset, LINK->LINK->LINK))
/*inn*/
gen0(11, LINK->LINK);
else {
error(129);
gattr.typtr = NULL;
}
} else {
error(130);
gattr.typtr = NULL;
}
} else {
if (lattr.typtr != gattr.typtr) {
if (lattr.typtr == intptr) { /*flo*/
gen0(9, LINK->LINK);
lattr.typtr = realptr;
} else {
if (gattr.typtr == intptr) { /*flt*/
gen0(10, LINK->LINK);
gattr.typtr = realptr;
}
}
}
if (comptypes(lattr.typtr, gattr.typtr, LINK->LINK->LINK)) {
lsize = lattr.typtr->size;
switch ((structform)lattr.typtr->form) {
case scalar:
if (lattr.typtr == realptr)
typind = 'r';
else {
if (lattr.typtr == boolptr)
typind = 'b';
else {
if (lattr.typtr == charptr)
typind = 'c';
else
typind = 'i';
}
}
break;
case pointer:
if (((1L << ((long)lop)) & ((1L << ((long)ltop)) | (1L << ((long)leop)) |
(1L << ((long)gtop)) | (1L << ((long)geop)))) != 0)
error(131);
typind = 'a';
break;
case power:
if (((1L << ((long)lop)) &
((1L << ((long)ltop)) | (1L << ((long)gtop)))) != 0)
error(132);
typind = 's';
break;
case arrays:
if (!string(lattr.typtr, LINK->LINK->LINK))
error(134);
typind = 'm';
break;
case records:
error(134);
typind = 'm';
break;
case files:
error(133);
typind = 'f';
break;
}
switch (lop) {
case ltop: /*les*/
gen2(53, typind, lsize, LINK->LINK);
break;
case leop: /*leq*/
gen2(52, typind, lsize, LINK->LINK);
break;
case gtop: /*grt*/
gen2(49, typind, lsize, LINK->LINK);
break;
case geop: /*geq*/
gen2(48, typind, lsize, LINK->LINK);
break;
case neop: /*neq*/
gen2(55, typind, lsize, LINK->LINK);
break;
case eqop: /*equ*/
gen2(47, typind, lsize, LINK->LINK);
break;
}
} else
error(129);
}
}
gattr.typtr = boolptr;
gattr.kind = expr;
}
Local void assignment(identifier *fcp, struct LOC_statement *LINK)
{
attr lattr;
setofsys SET, SET1;
/*assignment*/
selector(P_setunion(SET1, LINK->fsys, P_expset(SET, 1L << ((long)becomes))),
fcp, LINK);
if (sy != becomes) {
error(51);
return;
} /*sy = becomes*/
if (gattr.typtr != NULL) {
if (gattr.UU.U1.access != drct || (structform)gattr.typtr->form > power)
loadaddress(LINK->LINK);
}
lattr = gattr;
insymbol();
expression(LINK->fsys, LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form <= power)
load(LINK->LINK);
else
loadaddress(LINK->LINK);
}
if (lattr.typtr == NULL || gattr.typtr == NULL)
return;
if (comptypes(realptr, lattr.typtr, LINK->LINK->LINK) &&
gattr.typtr == intptr)
{ /*flt*/
gen0(10, LINK->LINK);
gattr.typtr = realptr;
}
if (!comptypes(lattr.typtr, gattr.typtr, LINK->LINK->LINK)) {
error(129);
return;
}
switch ((structform)lattr.typtr->form) {
case scalar:
case subrange:
if (debug)
checkbnds(lattr.typtr, LINK->LINK);
store(&lattr, LINK->LINK);
break;
case pointer:
if (debug) /*chk*/
gen2t(45, 0, maxaddr, nilptr, LINK->LINK);
store(&lattr, LINK->LINK);
break;
case power:
store(&lattr, LINK->LINK);
break;
case arrays:
case records: /*mov*/
gen1(40, lattr.typtr->size, LINK->LINK);
break;
case files:
error(146);
break;
}
}
Local void gotostatement(struct LOC_statement *LINK)
{
labl *llp;
boolean found;
disprange ttop, ttop1;
labl *WITH;
/*gotostatement*/
if (sy != intconst) {
error(15);
return;
}
found = false;
ttop = top;
while ((where)display[ttop].occur != blck)
ttop–;
ttop1 = ttop;
do {
llp = display[ttop].flabel;
while (llp != NULL && !found) {
WITH = llp;
if (WITH->labval == val.UU.ival) {
found = true;
if (ttop == ttop1) /*ujp*/
genujpxjp(57, WITH->labname, LINK->LINK);
else /*goto leads out of procedure*/
error(399);
} else
llp = WITH->nextlab;
}
ttop–;
} while (!(found || ttop == 0));
if (!found)
error(167);
insymbol();
}
Local void compoundstatement(struct LOC_statement *LINK)
{
long SET[(long)endsy / 32 + 2];
setofsys SET1;
/*compoundstatemenet*/
do {
do {
P_addset(P_expset(SET, 0), (long)semicolon);
statement(P_setunion(SET1, LINK->fsys, P_addset(SET, (long)endsy)),
LINK->LINK);
} while (P_inset(sy, statbegsys));
LINK->LINK->LINK->test = (sy != semicolon);
if (!LINK->LINK->LINK->test)
insymbol();
} while (!LINK->LINK->LINK->test);
if (sy == endsy)
insymbol();
else
error(13);
}
Local void ifstatement(struct LOC_statement *LINK)
{
long lcix1, lcix2;
long SET[(long)thensy / 32 + 2];
setofsys SET1;
long SET2[(long)elsesy / 32 + 2];
/*ifstatement*/
expression(P_setunion(SET1, LINK->fsys,
P_addset(P_expset(SET, 0), (long)thensy)), LINK);
genlabel(&lcix1);
genfjp(lcix1, LINK->LINK);
if (sy == thensy)
insymbol();
else
error(52);
statement(P_setunion(SET1, LINK->fsys,
P_addset(P_expset(SET2, 0), (long)elsesy)),
LINK->LINK);
if (sy != elsesy) {
putlabel(lcix1, LINK->LINK);
return;
}
genlabel(&lcix2); /*ujp*/
genujpxjp(57, lcix2, LINK->LINK);
putlabel(lcix1, LINK->LINK);
insymbol();
statement(LINK->fsys, LINK->LINK);
putlabel(lcix2, LINK->LINK);
}
Local void casestatement(struct LOC_statement *LINK)
{
structure *lsp, *lsp1;
caseinfo *fstptr, *lpt1, *lpt2, *lpt3;
valu lval;
long laddr, lcix, lcix1, lmin, lmax;
long SET[(long)ofsy / 32 + 2];
setofsys SET1, SET2;
caseinfo *WITH;
setofsys SET3, SET4;
/*casestatement*/
P_addset(P_expset(SET, 0), (long)ofsy);
P_addset(SET, (long)comma);
expression(P_setunion(SET1, LINK->fsys, P_addset(SET, (long)colon)), LINK);
load(LINK->LINK);
genlabel(&lcix);
lsp = gattr.typtr;
if (lsp != NULL) { /*ujp*/
if ((structform)lsp->form != scalar || lsp == realptr) {
error(144);
lsp = NULL;
} else if (!comptypes(lsp, intptr, LINK->LINK->LINK))
gen0t(58, lsp, LINK->LINK);
}
genujpxjp(57, lcix, LINK->LINK);
if (sy == ofsy)
insymbol();
else
error(8);
fstptr = NULL;
genlabel(&laddr);
do {
lpt3 = NULL;
genlabel(&lcix1);
if (sy != (long)endsy && sy != (long)semicolon) {
do {
constant_(P_setunion(SET2, LINK->fsys,
P_expset(SET1, (1L << ((long)comma)) | (1L << ((long)colon)))),
&lsp1, &lval, LINK->LINK->LINK);
if (lsp != NULL) {
if (comptypes(lsp, lsp1, LINK->LINK->LINK)) {
lpt1 = fstptr;
lpt2 = NULL;
while (lpt1 != NULL) {
WITH = lpt1;
if (WITH->cslab <= lval.UU.ival) {
if (WITH->cslab == lval.UU.ival)
error(156);
goto _L1;
}
lpt2 = lpt1;
lpt1 = WITH->next;
}
_L1:
lpt3 = Malloc(sizeof(caseinfo));
lpt3->next = lpt1;
lpt3->cslab = lval.UU.ival;
lpt3->csstart = lcix1;
if (lpt2 == NULL)
fstptr = lpt3;
else
lpt2->next = lpt3;
} else
error(147);
}
LINK->LINK->LINK->test = (sy != comma);
if (!LINK->LINK->LINK->test)
insymbol();
} while (!LINK->LINK->LINK->test);
if (sy == colon)
insymbol();
else
error(5);
putlabel(lcix1, LINK->LINK);
do {
statement(P_setunion(SET4, LINK->fsys,
P_expset(SET3, 1L << ((long)semicolon))),
LINK->LINK);
} while (P_inset(sy, statbegsys));
if (lpt3 != NULL) /*ujp*/
genujpxjp(57, laddr, LINK->LINK);
}
LINK->LINK->LINK->test = (sy != semicolon);
if (!LINK->LINK->LINK->test)
insymbol();
} while (!LINK->LINK->LINK->test);
putlabel(lcix, LINK->LINK);
if (fstptr != NULL) {
lmax = fstptr->cslab;
/*reverse pointers*/
lpt1 = fstptr;
fstptr = NULL;
do {
lpt2 = lpt1->next;
lpt1->next = fstptr;
fstptr = lpt1;
lpt1 = lpt2;
} while (lpt1 != NULL);
lmin = fstptr->cslab;
if (lmax – lmin < cixmax) { /*chk*/
gen2t(45, lmin, lmax, intptr, LINK->LINK); /*ldc*/
gen2(51, 1, lmin, LINK->LINK); /*sbi*/
gen0(21, LINK->LINK);
genlabel(&lcix); /*xjp*/
genujpxjp(44, lcix, LINK->LINK);
putlabel(lcix, LINK->LINK);
do {
WITH = fstptr;
while (WITH->cslab > lmin) { /*ujc error*/
gen0(60, LINK->LINK);
lmin++;
}
/*ujp*/
genujpxjp(57, WITH->csstart, LINK->LINK);
fstptr = WITH->next;
lmin++;
} while (fstptr != NULL);
putlabel(laddr, LINK->LINK);
} else
error(157);
}
if (sy == endsy)
insymbol();
else
error(13);
/*ord*/
}
Local void repeatstatement(struct LOC_statement *LINK)
{
long laddr;
long SET[(long)untilsy / 32 + 2];
setofsys SET1;
/*repeatstatement*/
genlabel(&laddr);
putlabel(laddr, LINK->LINK);
do {
P_addset(P_expset(SET, 0), (long)semicolon);
statement(P_setunion(SET1, LINK->fsys, P_addset(SET, (long)untilsy)),
LINK->LINK);
if (P_inset(sy, statbegsys))
error(14);
} while (P_inset(sy, statbegsys));
while (sy == semicolon) {
insymbol();
do {
P_addset(P_expset(SET, 0), (long)semicolon);
statement(P_setunion(SET1, LINK->fsys, P_addset(SET, (long)untilsy)),
LINK->LINK);
if (P_inset(sy, statbegsys))
error(14);
} while (P_inset(sy, statbegsys));
}
if (sy != untilsy) {
error(53);
return;
}
insymbol();
expression(LINK->fsys, LINK);
genfjp(laddr, LINK->LINK);
}
Local void whilestatement(struct LOC_statement *LINK)
{
long laddr, lcix;
long SET[(long)dosy / 32 + 2];
setofsys SET1;
/*whilestatement*/
genlabel(&laddr);
putlabel(laddr, LINK->LINK);
expression(P_setunion(SET1, LINK->fsys,
P_addset(P_expset(SET, 0), (long)dosy)), LINK);
genlabel(&lcix);
genfjp(lcix, LINK->LINK);
if (sy == dosy)
insymbol();
else
error(54);
statement(LINK->fsys, LINK->LINK); /*ujp*/
genujpxjp(57, laddr, LINK->LINK);
putlabel(lcix, LINK->LINK);
}
Local void forstatement(struct LOC_statement *LINK)
{
attr lattr;
symbol lsy;
long lcix, laddr;
addrrange llc;
identifier *WITH;
long SET[(long)downtosy / 32 + 2];
setofsys SET1;
long SET2[(long)dosy / 32 + 2];
/*forstatement*/
llc = lc;
lattr.typtr = NULL;
lattr.kind = varbl;
lattr.UU.U1.access = drct;
lattr.UU.U1.UU.U0.vlevel = level;
lattr.UU.U1.UU.U0.dplmt = 0;
if (sy == ident) {
searchid(1L << ((long)vars), &LINK->lcp);
WITH = LINK->lcp;
lattr.typtr = WITH->idtype;
lattr.kind = varbl;
if ((idkind)WITH->UU.U2.vkind == actual) {
lattr.UU.U1.access = drct;
lattr.UU.U1.UU.U0.vlevel = WITH->UU.U2.vlev;
lattr.UU.U1.UU.U0.dplmt = WITH->UU.U2.vaddr;
} else {
error(155);
lattr.typtr = NULL;
}
if (lattr.typtr != NULL) {
if (((structform)lattr.typtr->form > subrange) | comptypes(realptr,
lattr.typtr, LINK->LINK->LINK)) {
error(143);
lattr.typtr = NULL;
}
}
insymbol();
} else {
error(2);
P_addset(P_expset(SET, 0), (long)becomes);
P_addset(SET, (long)tosy);
P_addset(SET, (long)downtosy);
skip(P_setunion(SET1, LINK->fsys, P_addset(SET, (long)dosy)),
LINK->LINK->LINK);
}
if (sy == becomes) {
insymbol();
P_addset(P_expset(SET, 0), (long)tosy);
P_addset(SET, (long)downtosy);
expression(P_setunion(SET1, LINK->fsys, P_addset(SET, (long)dosy)), LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != scalar)
error(144);
else {
if (comptypes(lattr.typtr, gattr.typtr, LINK->LINK->LINK)) {
load(LINK->LINK);
store(&lattr, LINK->LINK);
} else
error(145);
}
}
} else {
error(51);
P_addset(P_expset(SET, 0), (long)tosy);
P_addset(SET, (long)downtosy);
skip(P_setunion(SET1, LINK->fsys, P_addset(SET, (long)dosy)),
LINK->LINK->LINK);
}
if (sy == (long)downtosy || sy == (long)tosy) {
lsy = sy;
insymbol();
expression(P_setunion(SET1, LINK->fsys,
P_addset(P_expset(SET2, 0), (long)dosy)), LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form != scalar)
error(144);
else {
if (comptypes(lattr.typtr, gattr.typtr, LINK->LINK->LINK)) {
load(LINK->LINK);
if (!comptypes(lattr.typtr, intptr, LINK->LINK->LINK)) /*ord*/
gen0t(58, gattr.typtr, LINK->LINK);
align(intptr, &lc); /*str*/
gen2t(56, 0, lc, intptr, LINK->LINK);
genlabel(&laddr);
putlabel(laddr, LINK->LINK);
gattr = lattr;
load(LINK->LINK);
if (!comptypes(gattr.typtr, intptr, LINK->LINK->LINK)) /*ord*/
gen0t(58, gattr.typtr, LINK->LINK);
/*lod*/
gen2t(54, 0, lc, intptr, LINK->LINK);
lc += intsize;
if (lc > LINK->LINK->lcmax)
LINK->LINK->lcmax = lc;
if (lsy == tosy) /*leq*/
gen2(52, 'i', 1, LINK->LINK);
else /*geq*/
gen2(48, 'i', 1, LINK->LINK);
} else
error(145);
}
}
} else {
error(55);
skip(P_setunion(SET1, LINK->fsys, P_addset(P_expset(SET2, 0), (long)dosy)),
LINK->LINK->LINK);
}
genlabel(&lcix); /*fjp*/
genujpxjp(33, lcix, LINK->LINK);
if (sy == dosy)
insymbol();
else
error(54);
statement(LINK->fsys, LINK->LINK);
gattr = lattr;
load(LINK->LINK);
if (lsy == tosy) /*inc*/
gen1t(34, 1, gattr.typtr, LINK->LINK);
else /*dec*/
gen1t(31, 1, gattr.typtr, LINK->LINK);
store(&lattr, LINK->LINK); /*ujp*/
genujpxjp(57, laddr, LINK->LINK);
putlabel(lcix, LINK->LINK);
lc = llc;
}
Local void withstatement(struct LOC_statement *LINK)
{
identifier *lcp;
disprange lcnt1;
addrrange llc;
long SET[(long)dosy / 32 + 2];
setofsys SET1;
_REC_display *WITH;
/*withstatement*/
lcnt1 = 0;
llc = lc;
do {
if (sy == ident) {
searchid((1L << ((long)vars)) | (1L << ((long)field)), &lcp);
insymbol();
} else {
error(2);
lcp = uvarptr;
}
P_addset(P_expset(SET, 0), (long)comma);
selector(P_setunion(SET1, LINK->fsys, P_addset(SET, (long)dosy)), lcp,
LINK);
if (gattr.typtr != NULL) {
if ((structform)gattr.typtr->form == records) {
if (top < displimit) {
top++;
lcnt1++;
WITH = &display[top];
WITH->fname = gattr.typtr->UU.U5.fstfld;
WITH->flabel = NULL;
if (gattr.UU.U1.access == drct) {
WITH = &display[top];
(where)WITH->occur = crec;
WITH->UU.U1.clev = gattr.UU.U1.UU.U0.vlevel;
WITH->UU.U1.cdspl = gattr.UU.U1.UU.U0.dplmt;
} else {
loadaddress(LINK->LINK);
align(nilptr, &lc); /*str*/
gen2t(56, 0, lc, nilptr, LINK->LINK);
WITH = &display[top];
(where)WITH->occur = vrec;
WITH->UU.vdspl = lc;
lc += ptrsize;
if (lc > LINK->LINK->lcmax)
LINK->LINK->lcmax = lc;
}
} else
error(250);
} else
error(140);
}
LINK->LINK->LINK->test = (sy != comma);
if (!LINK->LINK->LINK->test)
insymbol();
} while (!LINK->LINK->LINK->test);
if (sy == dosy)
insymbol();
else
error(54);
statement(LINK->fsys, LINK->LINK);
top -= lcnt1;
lc = llc;
}
Local void statement(long *fsys_, struct LOC_body *LINK)
{
struct LOC_statement V;
labl *llp, *WITH;
setofsys SET, SET1;
V.LINK = LINK;
/*statement*/
P_setcpy(V.fsys, fsys_);
if (sy == intconst) { /*label*/
llp = display[level].flabel;
while (llp != NULL) {
WITH = llp;
if (WITH->labval == val.UU.ival) {
if (WITH->defined_)
error(165);
putlabel(WITH->labname, LINK);
WITH->defined_ = true;
goto _L1;
} else {
llp = WITH->nextlab;
continue;
}
}
error(167);
_L1:
insymbol();
if (sy == colon)
insymbol();
else
error(5);
}
if (!P_inset(sy, P_setunion(SET1, V.fsys,
P_expset(SET, 1L << ((long)ident))))) {
error(6);
skip(V.fsys, LINK->LINK);
}
if (!P_inset(sy, P_setunion(SET1, statbegsys,
P_expset(SET, 1L << ((long)ident)))))
return;
switch (sy) {
case ident:
searchid((1L << ((long)vars)) | (1L << ((long)field)) |
(1L << ((long)func)) | (1L << ((long)proc)), &V.lcp);
insymbol();
if ((idclass)V.lcp->klass == proc)
call(V.fsys, V.lcp, &V);
else
assignment(V.lcp, &V);
break;
case beginsy:
insymbol();
compoundstatement(&V);
break;
case gotosy:
insymbol();
gotostatement(&V);
break;
case ifsy:
insymbol();
ifstatement(&V);
break;
case casesy:
insymbol();
casestatement(&V);
break;
case whilesy:
insymbol();
whilestatement(&V);
break;
case repeatsy:
insymbol();
repeatstatement(&V);
break;
case forsy:
insymbol();
forstatement(&V);
break;
case withsy:
insymbol();
withstatement(&V);
break;
}
if (sy != (long)untilsy && sy != (long)elsesy && sy != (long)endsy &&
sy != (long)semicolon) {
error(6);
skip(V.fsys, LINK->LINK);
}
}
Local void body(long *fsys, struct LOC_block *LINK)
{
struct LOC_body V;
identifier *llcp;
alpha saveid;
/*allows referencing of noninteger constants by an index
(instead of a pointer), which can be stored in the p2-field
of the instruction record until writeout.
–> procedure load, procedure writeout*/
long entname, segsize, stacktop;
addrrange llc1;
identifier *lcp;
labl *llp;
identifier *WITH;
long SET[(long)endsy / 32 + 2];
setofsys SET1;
labl *WITH1;
filerec *WITH2;
V.LINK = LINK;
/*body*/
if (LINK->fprocp != NULL)
entname = LINK->fprocp->UU.U4.UU.U1.pfname;
else
genlabel(&entname);
V.cstptrix = 0;
V.topnew = lcaftermarkstack;
V.topmax = lcaftermarkstack;
putlabel(entname, &V);
genlabel(&segsize);
genlabel(&stacktop); /*ent1*/
gencupent(32, 1, segsize, &V); /*ent2*/
gencupent(32, 2, stacktop, &V);
if (LINK->fprocp != NULL) { /*copy multiple values into local cells*/
llc1 = lcaftermarkstack;
lcp = LINK->fprocp->next;
while (lcp != NULL) {
WITH = lcp;
align(parmptr, &llc1);
if ((idclass)WITH->klass == vars) {
if (WITH->idtype != NULL) {
if ((structform)WITH->idtype->form > power) {
if ((idkind)WITH->UU.U2.vkind == actual) { /*lda*/
gen2(50, 0, WITH->UU.U2.vaddr, &V); /*lod*/
gen2t(54, 0, llc1, nilptr, &V); /*mov*/
gen1(40, WITH->idtype->size, &V);
}
llc1 += ptrsize;
} else
llc1 += WITH->idtype->size;
}
}
lcp = lcp->next;
}
}
V.lcmax = lc;
do {
do {
P_addset(P_expset(SET, 0), (long)semicolon);
statement(P_setunion(SET1, fsys, P_addset(SET, (long)endsy)), &V);
} while (P_inset(sy, statbegsys));
LINK->test = (sy != semicolon);
if (!LINK->test)
insymbol();
} while (!LINK->test);
if (sy == endsy)
insymbol();
else
error(13);
llp = display[top].flabel; /*test for undefined labels*/
while (llp != NULL) {
WITH1 = llp;
if (!WITH1->defined_) {
error(168);
printf("\n label %12ld\n", WITH1->labval);
printf("%*c", (int)(chcnt + 16), ' ');
}
llp = WITH1->nextlab;
}
if (LINK->fprocp != NULL) {
if (LINK->fprocp->idtype == NULL) /*ret*/
gen1(42, 'p', &V);
else /*ret*/
gen0t(42, LINK->fprocp->idtype, &V);
align(parmptr, &V.lcmax);
if (prcode) {
fprintf(prr.f, "l%4ld=%12d\n", segsize, V.lcmax);
fprintf(prr.f, "l%4ld=%12ld\n", stacktop, V.topmax);
}
return;
}
gen1(42, 'p', &V);
align(parmptr, &V.lcmax);
if (prcode) {
fprintf(prr.f, "l%4ld=%12d\n", segsize, V.lcmax);
fprintf(prr.f, "l%4ld=%12ld\n", stacktop, V.topmax);
fprintf(prr.f, "q\n");
}
ic = 0; /*mst*/
/*generate call of main program; note that this call must be loaded
at absolute address zero*/
gen1(41, 0, &V); /*cup*/
gencupent(46, 0, entname, &V); /*stp*/
gen0(29, &V);
if (prcode)
fprintf(prr.f, "q\n");
memcpy(saveid, id, sizeof(alpha));
while (fextfilep != NULL) {
WITH2 = fextfilep;
if (strncmp(WITH2->filename, "input ", sizeof(alpha)) &&
strncmp(WITH2->filename, "output ", sizeof(alpha)) &&
strncmp(WITH2->filename, "prd ", sizeof(alpha)) &&
strncmp(WITH2->filename, "prr ", sizeof(alpha))) {
memcpy(id, WITH2->filename, sizeof(alpha));
searchid(1L << ((long)vars), &llcp);
if (llcp->idtype != NULL) {
if ((structform)llcp->idtype->form != files) {
printf("\n%8cundeclared external file%.8s\n",
' ', fextfilep->filename);
printf("%*c", (int)(chcnt + 16), ' ');
}
}
}
fextfilep = fextfilep->nextfile;
}
memcpy(id, saveid, sizeof(alpha));
if (prtables) {
putchar('\n');
printtables(true);
}
/*ret*/
}
#undef cstoccmax
#undef cixmax
Static void block(long *fsys_, symbol fsy, identifier *fprocp_)
{
struct LOC_block V;
symbol lsy;
long SET[(long)casesy / 32 + 2];
setofsys SET1;
/*block*/
P_setcpy(V.fsys, fsys_);
V.fprocp = fprocp_;
dp = true;
do {
if (sy == labelsy) {
insymbol();
labeldeclaration(&V);
}
if (sy == constsy) {
insymbol();
constdeclaration(&V);
}
if (sy == typesy) {
insymbol();
typedeclaration(&V);
}
if (sy == varsy) {
insymbol();
vardeclaration(&V);
}
while ((unsigned long)sy < 32 &&
((1L << ((long)sy)) &
((1L << ((long)procsy)) | (1L << ((long)funcsy)))) != 0) {
lsy = sy;
insymbol();
procdeclaration(lsy, &V);
}
if (sy != beginsy) {
error(18);
skip(V.fsys, &V);
}
} while (!(P_inset(sy, statbegsys) | P_eof(stdin)));
dp = false;
if (sy == beginsy)
insymbol();
else
error(17);
do {
body(P_setunion(SET1, V.fsys, P_addset(P_expset(SET, 0), (long)casesy)),
&V);
if (sy != fsy) {
error(6);
skip(V.fsys, &V);
}
} while (!((sy == fsy) | P_inset(sy, blockbegsys) | P_eof(stdin)));
}
Static void programme(long *fsys)
{
filerec *extfp;
/*programme*/
if (sy == progsy) {
insymbol();
if (sy != ident)
error(2);
insymbol();
if ((unsigned long)sy >= 32 ||
((1L << ((long)sy)) &
((1L << ((long)lparent)) | (1L << ((long)semicolon)))) == 0)
error(14);
if (sy == lparent) {
do {
insymbol();
if (sy == ident) {
extfp = Malloc(sizeof(filerec));
memcpy(extfp->filename, id, sizeof(alpha));
extfp->nextfile = fextfilep;
fextfilep = extfp;
insymbol();
if ((unsigned long)sy >= 32 ||
((1L << ((long)sy)) &
((1L << ((long)comma)) | (1L << ((long)rparent)))) == 0)
error(20);
} else
error(2);
} while (sy == comma);
if (sy != rparent)
error(4);
insymbol();
}
if (sy != semicolon)
error(14);
else
insymbol();
}
do {
block(fsys, period, NULL);
if (sy != period)
error(21);
} while (!((sy == period) | P_eof(stdin)));
if (list)
putchar('\n');
if (errinx != 0) {
list = false;
endofline();
}
}
Static void stdnames(void)
{
/*stdnames*/
memcpy(na[0], "false ", sizeof(alpha));
memcpy(na[1], "true ", sizeof(alpha));
memcpy(na[2], "input ", sizeof(alpha));
memcpy(na[3], "output ", sizeof(alpha));
memcpy(na[4], "get ", sizeof(alpha));
memcpy(na[5], "put ", sizeof(alpha));
memcpy(na[6], "reset ", sizeof(alpha));
memcpy(na[7], "rewrite ", sizeof(alpha));
memcpy(na[8], "read ", sizeof(alpha));
memcpy(na[9], "write ", sizeof(alpha));
memcpy(na[10], "pack ", sizeof(alpha));
memcpy(na[11], "unpack ", sizeof(alpha));
memcpy(na[12], "new ", sizeof(alpha));
memcpy(na[13], "release ", sizeof(alpha));
memcpy(na[14], "readln ", sizeof(alpha));
memcpy(na[15], "writeln ", sizeof(alpha));
memcpy(na[16], "abs ", sizeof(alpha));
memcpy(na[17], "sqr ", sizeof(alpha));
memcpy(na[18], "trunc ", sizeof(alpha));
memcpy(na[19], "odd ", sizeof(alpha));
memcpy(na[20], "ord ", sizeof(alpha));
memcpy(na[21], "chr ", sizeof(alpha));
memcpy(na[22], "pred ", sizeof(alpha));
memcpy(na[23], "succ ", sizeof(alpha));
memcpy(na[24], "eof ", sizeof(alpha));
memcpy(na[25], "eoln ", sizeof(alpha));
memcpy(na[26], "sin ", sizeof(alpha));
memcpy(na[27], "cos ", sizeof(alpha));
memcpy(na[28], "exp ", sizeof(alpha));
memcpy(na[29], "sqrt ", sizeof(alpha));
memcpy(na[30], "ln ", sizeof(alpha));
memcpy(na[31], "arctan ", sizeof(alpha));
memcpy(na[32], "prd ", sizeof(alpha));
memcpy(na[33], "prr ", sizeof(alpha));
memcpy(na[34], "mark ", sizeof(alpha));
}
Static void enterstdtypes(void)
{ /*type underlying:*/
structure *WITH;
/******************/
/* p2c: pcom.p, line 3646:
* Note: No SpecialMalloc form known for STRUCTURE.SCALAR.STANDARD [187] */
/*enterstdtypes*/
intptr = Malloc(sizeof(structure)); /*integer*/
WITH = intptr;
/* p2c: pcom.p, line 3649:
* Note: No SpecialMalloc form known for STRUCTURE.SCALAR.STANDARD [187] */
WITH->size = intsize;
(structform)WITH->form = scalar;
(declkind)WITH->UU.U0.scalkind = standard;
realptr = Malloc(sizeof(structure)); /*real*/
WITH = realptr;
/* p2c: pcom.p, line 3652:
* Note: No SpecialMalloc form known for STRUCTURE.SCALAR.STANDARD [187] */
WITH->size = realsize;
(structform)WITH->form = scalar;
(declkind)WITH->UU.U0.scalkind = standard;
charptr = Malloc(sizeof(structure)); /*char*/
WITH = charptr;
/* p2c: pcom.p, line 3655:
* Note: No SpecialMalloc form known for STRUCTURE.SCALAR.DECLARED [187] */
WITH->size = charsize;
(structform)WITH->form = scalar;
(declkind)WITH->UU.U0.scalkind = standard;
boolptr = Malloc(sizeof(structure)); /*boolean*/
WITH = boolptr;
/* p2c: pcom.p, line 3658:
* Note: No SpecialMalloc form known for STRUCTURE.POINTER [187] */
WITH->size = boolsize;
(structform)WITH->form = scalar;
(declkind)WITH->UU.U0.scalkind = declared;
nilptr = Malloc(sizeof(structure)); /*nil*/
WITH = nilptr;
/* p2c: pcom.p, line 3661:
* Note: No SpecialMalloc form known for STRUCTURE.SCALAR.STANDARD [187] */
WITH->UU.eltype = NULL;
WITH->size = ptrsize;
(structform)WITH->form = pointer;
parmptr = Malloc(sizeof(structure)); /*for alignment of parameters*/
WITH = parmptr;
/* p2c: pcom.p, line 3664:
* Note: No SpecialMalloc form known for STRUCTURE.FILES [187] */
WITH->size = parmsize;
(structform)WITH->form = scalar;
(declkind)WITH->UU.U0.scalkind = standard;
textptr = Malloc(sizeof(structure)); /*text*/
WITH = textptr;
WITH->UU.filtype = charptr;
WITH->size = charsize;
(structform)WITH->form = files;
}
Static void entstdnames(void)
{ /*name:*/
identifier *cp, *cp1;
long i;
/*******/
/* p2c: pcom.p, line 3674:
* Note: No SpecialMalloc form known for IDENTIFIER.TYPES [187] */
/*entstdnames*/
cp = Malloc(sizeof(identifier)); /*integer*/
memcpy(cp->name, "integer ", sizeof(alpha));
cp->idtype = intptr;
(idclass)cp->klass = types;
enterid(cp);
/* p2c: pcom.p, line 3678:
* Note: No SpecialMalloc form known for IDENTIFIER.TYPES [187] */
cp = Malloc(sizeof(identifier)); /*real*/
memcpy(cp->name, "real ", sizeof(alpha));
cp->idtype = realptr;
(idclass)cp->klass = types;
enterid(cp);
/* p2c: pcom.p, line 3682:
* Note: No SpecialMalloc form known for IDENTIFIER.TYPES [187] */
cp = Malloc(sizeof(identifier)); /*char*/
memcpy(cp->name, "char ", sizeof(alpha));
cp->idtype = charptr;
(idclass)cp->klass = types;
enterid(cp);
/* p2c: pcom.p, line 3686:
* Note: No SpecialMalloc form known for IDENTIFIER.TYPES [187] */
cp = Malloc(sizeof(identifier)); /*boolean*/
memcpy(cp->name, "boolean ", sizeof(alpha));
cp->idtype = boolptr;
(idclass)cp->klass = types;
enterid(cp);
cp1 = NULL;
for (i = 0; i <= 1; i++) {
cp = Malloc(sizeof(identifier)); /*false,true*/
memcpy(cp->name, na[i], sizeof(alpha));
cp->idtype = boolptr;
cp->next = cp1;
cp->UU.values.UU.ival = i;
(idclass)cp->klass = konst;
enterid(cp);
cp1 = cp;
}
/* p2c: pcom.p, line 3692:
* Note: No SpecialMalloc form known for IDENTIFIER.KONST [187] */
boolptr->UU.U0.UU.fconst = cp;
/* p2c: pcom.p, line 3700:
* Note: No SpecialMalloc form known for IDENTIFIER.KONST [187] */
cp = Malloc(sizeof(identifier)); /*nil*/
memcpy(cp->name, "nil ", sizeof(alpha));
cp->idtype = nilptr;
cp->next = NULL;
cp->UU.values.UU.ival = 0;
(idclass)cp->klass = konst;
enterid(cp);
for (i = 3; i <= 4; i++) {
cp = Malloc(sizeof(identifier)); /*input,output*/
memcpy(cp->name, na[i – 1], sizeof(alpha));
cp->idtype = textptr;
(idclass)cp->klass = vars;
(idkind)cp->UU.U2.vkind = actual;
cp->next = NULL;
cp->UU.U2.vlev = 1;
cp->UU.U2.vaddr = lcaftermarkstack + i – 3;
enterid(cp);
}
/* p2c: pcom.p, line 3707:
* Note: No SpecialMalloc form known for IDENTIFIER.VARS [187] */
for (i = 33; i <= 34; i++) {
cp = Malloc(sizeof(identifier)); /*prd,prr files*/
memcpy(cp->name, na[i – 1], sizeof(alpha));
cp->idtype = textptr;
(idclass)cp->klass = vars;
(idkind)cp->UU.U2.vkind = actual;
cp->next = NULL;
cp->UU.U2.vlev = 1;
cp->UU.U2.vaddr = lcaftermarkstack + i – 31;
enterid(cp);
}
/* p2c: pcom.p, line 3716:
* Note: No SpecialMalloc form known for IDENTIFIER.VARS [187] */
for (i = 5; i <= 16; i++) {
cp = Malloc(sizeof(identifier)); /*get,put,reset*/
/*rewrite,read*/
memcpy(cp->name, na[i – 1], sizeof(alpha));
cp->idtype = NULL; /*write,pack*/
cp->next = NULL;
cp->UU.U4.UU.key = i – 4; /*unpack,pack*/
(idclass)cp->klass = proc;
(declkind)cp->UU.U4.pfdeckind = standard;
enterid(cp);
}
/* p2c: pcom.p, line 3725:
* Note: No SpecialMalloc form known for IDENTIFIER.PROC.STANDARD [187] */
/* p2c: pcom.p, line 3733:
* Note: No SpecialMalloc form known for IDENTIFIER.PROC.STANDARD [187] */
cp = Malloc(sizeof(identifier));
memcpy(cp->name, na[34], sizeof(alpha));
cp->idtype = NULL;
cp->next = NULL;
cp->UU.U4.UU.key = 13;
(idclass)cp->klass = proc;
(declkind)cp->UU.U4.pfdeckind = standard;
enterid(cp);
for (i = 17; i <= 26; i++) {
cp = Malloc(sizeof(identifier)); /*abs,sqr,trunc*/
/*odd,ord,chr*/
memcpy(cp->name, na[i – 1], sizeof(alpha));
cp->idtype = NULL; /*pred,succ,eof*/
cp->next = NULL;
cp->UU.U4.UU.key = i – 16;
(idclass)cp->klass = func;
(declkind)cp->UU.U4.pfdeckind = standard;
enterid(cp);
}
/* p2c: pcom.p, line 3740:
* Note: No SpecialMalloc form known for IDENTIFIER.FUNC.STANDARD [187] */
/* p2c: pcom.p, line 3748:
* Note: No SpecialMalloc form known for IDENTIFIER.VARS [187] */
cp = Malloc(sizeof(identifier)); /*parameter of predeclared functions*/
memcpy(cp->name, " ", sizeof(alpha));
cp->idtype = realptr;
(idclass)cp->klass = vars;
(idkind)cp->UU.U2.vkind = actual;
cp->next = NULL;
cp->UU.U2.vlev = 1;
cp->UU.U2.vaddr = 0;
for (i = 27; i <= 32; i++) {
cp1 = Malloc(sizeof(identifier)); /*sin,cos,exp*/
/*sqrt,ln,arctan*/
memcpy(cp1->name, na[i – 1], sizeof(alpha));
cp1->idtype = realptr;
cp1->next = cp;
cp1->UU.U4.UU.U1.UU.U0.forwdecl = false;
cp1->UU.U4.UU.U1.UU.U0.externl = true;
cp1->UU.U4.UU.U1.pflev = 0;
cp1->UU.U4.UU.U1.pfname = i – 12;
(idclass)cp1->klass = func;
(declkind)cp1->UU.U4.pfdeckind = declared;
(idkind)cp1->UU.U4.UU.U1.pfkind = actual;
enterid(cp1);
}
/* p2c: pcom.p, line 3754: Note:
* No SpecialMalloc form known for IDENTIFIER.FUNC.DECLARED.ACTUAL [187] */
}
Static void enterundecl(void)
{
identifier *WITH;
/* p2c: pcom.p, line 3766:
* Note: No SpecialMalloc form known for IDENTIFIER.TYPES [187] */
/*enterundecl*/
utypptr = Malloc(sizeof(identifier));
WITH = utypptr;
/* p2c: pcom.p, line 3769:
* Note: No SpecialMalloc form known for IDENTIFIER.KONST [187] */
memcpy(WITH->name, " ", sizeof(alpha));
WITH->idtype = NULL;
(idclass)WITH->klass = types;
ucstptr = Malloc(sizeof(identifier));
WITH = ucstptr;
/* p2c: pcom.p, line 3774:
* Note: No SpecialMalloc form known for IDENTIFIER.VARS [187] */
memcpy(WITH->name, " ", sizeof(alpha));
WITH->idtype = NULL;
WITH->next = NULL;
WITH->UU.values.UU.ival = 0;
(idclass)WITH->klass = konst;
uvarptr = Malloc(sizeof(identifier));
WITH = uvarptr;
/* p2c: pcom.p, line 3779:
* Note: No SpecialMalloc form known for IDENTIFIER.FIELD [187] */
memcpy(WITH->name, " ", sizeof(alpha));
WITH->idtype = NULL;
(idkind)WITH->UU.U2.vkind = actual;
WITH->next = NULL;
WITH->UU.U2.vlev = 0;
WITH->UU.U2.vaddr = 0;
(idclass)WITH->klass = vars;
ufldptr = Malloc(sizeof(identifier));
WITH = ufldptr;
/* p2c: pcom.p, line 3784: Note:
* No SpecialMalloc form known for IDENTIFIER.PROC.DECLARED.ACTUAL [187] */
memcpy(WITH->name, " ", sizeof(alpha));
WITH->idtype = NULL;
WITH->next = NULL;
WITH->UU.fldaddr = 0;
(idclass)WITH->klass = field;
uprcptr = Malloc(sizeof(identifier));
WITH = uprcptr;
/* p2c: pcom.p, line 3790: Note:
* No SpecialMalloc form known for IDENTIFIER.FUNC.DECLARED.ACTUAL [187] */
memcpy(WITH->name, " ", sizeof(alpha));
WITH->idtype = NULL;
WITH->UU.U4.UU.U1.UU.U0.forwdecl = false;
WITH->next = NULL;
WITH->UU.U4.UU.U1.UU.U0.externl = false;
WITH->UU.U4.UU.U1.pflev = 0;
genlabel(&WITH->UU.U4.UU.U1.pfname);
(idclass)WITH->klass = proc;
(declkind)WITH->UU.U4.pfdeckind = declared;
(idkind)WITH->UU.U4.UU.U1.pfkind = actual;
ufctptr = Malloc(sizeof(identifier));
WITH = ufctptr;
memcpy(WITH->name, " ", sizeof(alpha));
WITH->idtype = NULL;
WITH->next = NULL;
WITH->UU.U4.UU.U1.UU.U0.forwdecl = false;
WITH->UU.U4.UU.U1.UU.U0.externl = false;
WITH->UU.U4.UU.U1.pflev = 0;
genlabel(&WITH->UU.U4.UU.U1.pfname);
(idclass)WITH->klass = func;
(declkind)WITH->UU.U4.pfdeckind = declared;
(idkind)WITH->UU.U4.UU.U1.pfkind = actual;
}
Static void initscalars(void)
{
/*initscalars*/
fwptr = NULL;
prtables = false;
list = true;
prcode = true;
debug = true;
dp = true;
prterr = true;
errinx = 0;
intlabel = 0;
kk = 8;
fextfilep = NULL;
lc = lcaftermarkstack + filebuffer;
/* note in the above reservation of buffer store for 2 text files */
ic = 3;
eol = true;
linecount = 0;
ch = ' ';
chcnt = 0;
globtestp = NULL;
mxint10 = maxint / 10;
digmax = strglgth – 1;
}
Static void initsets(void)
{
setofsys SET;
/*initsets*/
P_expset(constbegsys, (1L << ((long)addop)) | (1L << ((long)intconst)) |
(1L << ((long)realconst)) |
(1L << ((long)stringconst)) | (1L << ((long)ident)));
P_setunion(simptypebegsys, P_expset(SET, 1L << ((long)lparent)),
constbegsys);
P_setunion(typebegsys,
P_expset(SET, (1L << ((long)arrow)) | (1L << ((long)packedsy)) |
(1L << ((long)arraysy)) | (1L << ((long)recordsy)) |
(1L << ((long)setsy)) | (1L << ((long)filesy))),
simptypebegsys);
P_expset(typedels, (1L << ((long)arraysy)) | (1L << ((long)recordsy)) |
(1L << ((long)setsy)) | (1L << ((long)filesy)));
P_expset(blockbegsys,
(1L << ((long)labelsy)) | (1L << ((long)constsy)) |
(1L << ((long)typesy)) | (1L << ((long)varsy)) | (1L << ((long)procsy)) |
(1L << ((long)funcsy)) | (1L << ((long)beginsy)));
P_expset(selectsys,
(1L << ((long)arrow)) | (1L << ((long)period)) | (1L << ((long)lbrack)));
P_expset(facbegsys,
(1L << ((long)intconst)) | (1L << ((long)realconst)) |
(1L << ((long)stringconst)) | (1L << ((long)ident)) |
(1L << ((long)lparent)) | (1L << ((long)lbrack)) | (1L << ((long)notsy)));
P_addset(P_expset(statbegsys, 0), (long)beginsy);
P_addset(statbegsys, (long)gotosy);
P_addset(statbegsys, (long)ifsy);
P_addset(statbegsys, (long)whilesy);
P_addset(statbegsys, (long)repeatsy);
P_addset(statbegsys, (long)forsy);
P_addset(statbegsys, (long)withsy);
P_addset(statbegsys, (long)casesy);
}
Local void reswords(void)
{
/*reswords*/
memcpy(rw[0], "if ", sizeof(alpha));
memcpy(rw[1], "do ", sizeof(alpha));
memcpy(rw[2], "of ", sizeof(alpha));
memcpy(rw[3], "to ", sizeof(alpha));
memcpy(rw[4], "in ", sizeof(alpha));
memcpy(rw[5], "or ", sizeof(alpha));
memcpy(rw[6], "end ", sizeof(alpha));
memcpy(rw[7], "for ", sizeof(alpha));
memcpy(rw[8], "var ", sizeof(alpha));
memcpy(rw[9], "div ", sizeof(alpha));
memcpy(rw[10], "mod ", sizeof(alpha));
memcpy(rw[11], "set ", sizeof(alpha));
memcpy(rw[12], "and ", sizeof(alpha));
memcpy(rw[13], "not ", sizeof(alpha));
memcpy(rw[14], "then ", sizeof(alpha));
memcpy(rw[15], "else ", sizeof(alpha));
memcpy(rw[16], "with ", sizeof(alpha));
memcpy(rw[17], "goto ", sizeof(alpha));
memcpy(rw[18], "case ", sizeof(alpha));
memcpy(rw[19], "type ", sizeof(alpha));
memcpy(rw[20], "file ", sizeof(alpha));
memcpy(rw[21], "begin ", sizeof(alpha));
memcpy(rw[22], "until ", sizeof(alpha));
memcpy(rw[23], "while ", sizeof(alpha));
memcpy(rw[24], "array ", sizeof(alpha));
memcpy(rw[25], "const ", sizeof(alpha));
memcpy(rw[26], "label ", sizeof(alpha));
memcpy(rw[27], "repeat ", sizeof(alpha));
memcpy(rw[28], "record ", sizeof(alpha));
memcpy(rw[29], "downto ", sizeof(alpha));
memcpy(rw[30], "packed ", sizeof(alpha));
memcpy(rw[31], "forward ", sizeof(alpha));
memcpy(rw[32], "program ", sizeof(alpha));
memcpy(rw[33], "function", sizeof(alpha));
memcpy(rw[34], "procedur", sizeof(alpha));
frw[0] = 1;
frw[1] = 1;
frw[2] = 7;
frw[3] = 15;
frw[4] = 22;
frw[5] = 28;
frw[6] = 32;
frw[7] = 34;
frw[8] = 36;
}
Local void symbols(void)
{
/*symbols*/
rsy[0] = ifsy;
rsy[1] = dosy;
rsy[2] = ofsy;
rsy[3] = tosy;
rsy[4] = relop;
rsy[5] = addop;
rsy[6] = endsy;
rsy[7] = forsy;
rsy[8] = varsy;
rsy[9] = mulop;
rsy[10] = mulop;
rsy[11] = setsy;
rsy[12] = mulop;
rsy[13] = notsy;
rsy[14] = thensy;
rsy[15] = elsesy;
rsy[16] = withsy;
rsy[17] = gotosy;
rsy[18] = casesy;
rsy[19] = typesy;
rsy[20] = filesy;
rsy[21] = beginsy;
rsy[22] = untilsy;
rsy[23] = whilesy;
rsy[24] = arraysy;
rsy[25] = constsy;
rsy[26] = labelsy;
rsy[27] = repeatsy;
rsy[28] = recordsy;
rsy[29] = downtosy;
rsy[30] = packedsy;
rsy[31] = forwardsy;
rsy[32] = progsy;
rsy[33] = funcsy;
rsy[34] = procsy;
ssy['+'] = addop;
ssy['-'] = addop;
ssy['*'] = mulop;
ssy['/'] = mulop;
ssy['('] = lparent;
ssy[')'] = rparent;
ssy['$'] = othersy;
ssy['='] = relop;
ssy[' '] = othersy;
ssy[','] = comma;
ssy['.'] = period;
ssy['\''] = othersy;
ssy['['] = lbrack;
ssy[']'] = rbrack;
ssy[':'] = colon;
ssy['^'] = arrow;
ssy['<'] = relop;
ssy['>'] = relop;
ssy[';'] = semicolon;
}
Local void rators(void)
{
long i;
/*rators*/
for (i = 0; i <= 34; i++) /*nr of res words*/
rop[i] = noop;
rop[4] = inop;
rop[9] = idiv;
rop[10] = imod;
rop[5] = orop;
rop[12] = andop;
for (i = ordminchar; i <= ordmaxchar; i++)
sop[(Char)i] = noop;
sop['+'] = plus;
sop['-'] = minus;
sop['*'] = mul;
sop['/'] = rdiv;
sop['='] = eqop;
sop['<'] = ltop;
sop['>'] = gtop;
}
Local void procmnemonics(void)
{
/*procmnemonics*/
memcpy(sna[0], " get", 4);
memcpy(sna[1], " put", 4);
memcpy(sna[2], " rdi", 4);
memcpy(sna[3], " rdr", 4);
memcpy(sna[4], " rdc", 4);
memcpy(sna[5], " wri", 4);
memcpy(sna[6], " wro", 4);
memcpy(sna[7], " wrr", 4);
memcpy(sna[8], " wrc", 4);
memcpy(sna[9], " wrs", 4);
memcpy(sna[10], " pak", 4);
memcpy(sna[11], " new", 4);
memcpy(sna[12], " rst", 4);
memcpy(sna[13], " eln", 4);
memcpy(sna[14], " sin", 4);
memcpy(sna[15], " cos", 4);
memcpy(sna[16], " exp", 4);
memcpy(sna[17], " sqt", 4);
memcpy(sna[18], " log", 4);
memcpy(sna[19], " atn", 4);
memcpy(sna[20], " rln", 4);
memcpy(sna[21], " wln", 4);
memcpy(sna[22], " sav", 4);
}
Local void instrmnemonics(void)
{
/*instrmnemonics*/
memcpy(mn[0], " abi", 4);
memcpy(mn[1], " abr", 4);
memcpy(mn[2], " adi", 4);
memcpy(mn[3], " adr", 4);
memcpy(mn[4], " and", 4);
memcpy(mn[5], " dif", 4);
memcpy(mn[6], " dvi", 4);
memcpy(mn[7], " dvr", 4);
memcpy(mn[8], " eof", 4);
memcpy(mn[9], " flo", 4);
memcpy(mn[10], " flt", 4);
memcpy(mn[11], " inn", 4);
memcpy(mn[12], " int", 4);
memcpy(mn[13], " ior", 4);
memcpy(mn[14], " mod", 4);
memcpy(mn[15], " mpi", 4);
memcpy(mn[16], " mpr", 4);
memcpy(mn[17], " ngi", 4);
memcpy(mn[18], " ngr", 4);
memcpy(mn[19], " not", 4);
memcpy(mn[20], " odd", 4);
memcpy(mn[21], " sbi", 4);
memcpy(mn[22], " sbr", 4);
memcpy(mn[23], " sgs", 4);
memcpy(mn[24], " sqi", 4);
memcpy(mn[25], " sqr", 4);
memcpy(mn[26], " sto", 4);
memcpy(mn[27], " trc", 4);
memcpy(mn[28], " uni", 4);
memcpy(mn[29], " stp", 4);
memcpy(mn[30], " csp", 4);
memcpy(mn[31], " dec", 4);
memcpy(mn[32], " ent", 4);
memcpy(mn[33], " fjp", 4);
memcpy(mn[34], " inc", 4);
memcpy(mn[35], " ind", 4);
memcpy(mn[36], " ixa", 4);
memcpy(mn[37], " lao", 4);
memcpy(mn[38], " lca", 4);
memcpy(mn[39], " ldo", 4);
memcpy(mn[40], " mov", 4);
memcpy(mn[41], " mst", 4);
memcpy(mn[42], " ret", 4);
memcpy(mn[43], " sro", 4);
memcpy(mn[44], " xjp", 4);
memcpy(mn[45], " chk", 4);
memcpy(mn[46], " cup", 4);
memcpy(mn[47], " equ", 4);
memcpy(mn[48], " geq", 4);
memcpy(mn[49], " grt", 4);
memcpy(mn[50], " lda", 4);
memcpy(mn[51], " ldc", 4);
memcpy(mn[52], " leq", 4);
memcpy(mn[53], " les", 4);
memcpy(mn[54], " lod", 4);
memcpy(mn[55], " neq", 4);
memcpy(mn[56], " str", 4);
memcpy(mn[57], " ujp", 4);
memcpy(mn[58], " ord", 4);
memcpy(mn[59], " chr", 4);
memcpy(mn[60], " ujc", 4);
}
Local void chartypes(void)
{
long i;
for (i = ordminchar; i <= ordmaxchar; i++)
chartp[(Char)i] = illegal;
chartp['a'] = letter;
chartp['b'] = letter;
chartp['c'] = letter;
chartp['d'] = letter;
chartp['e'] = letter;
chartp['f'] = letter;
chartp['g'] = letter;
chartp['h'] = letter;
chartp['i'] = letter;
chartp['j'] = letter;
chartp['k'] = letter;
chartp['l'] = letter;
chartp['m'] = letter;
chartp['n'] = letter;
chartp['o'] = letter;
chartp['p'] = letter;
chartp['q'] = letter;
chartp['r'] = letter;
chartp['s'] = letter;
chartp['t'] = letter;
chartp['u'] = letter;
chartp['v'] = letter;
chartp['w'] = letter;
chartp['x'] = letter;
chartp['y'] = letter;
chartp['z'] = letter;
chartp['0'] = number;
chartp['1'] = number;
chartp['2'] = number;
chartp['3'] = number;
chartp['4'] = number;
chartp['5'] = number;
chartp['6'] = number;
chartp['7'] = number;
chartp['8'] = number;
chartp['9'] = number;
chartp['+'] = special;
chartp['-'] = special;
chartp['*'] = special;
chartp['/'] = special;
chartp['('] = chlparen;
chartp[')'] = special;
chartp['$'] = special;
chartp['='] = special;
chartp[' '] = chspace;
chartp[','] = special;
chartp['.'] = chperiod;
chartp['\''] = chstrquo;
chartp['['] = special;
chartp[']'] = special;
chartp[':'] = chcolon;
chartp['^'] = special;
chartp[';'] = special;
chartp['<'] = chlt;
chartp['>'] = chgt;
ordint['0'] = 0;
ordint['1'] = 1;
ordint['2'] = 2;
ordint['3'] = 3;
ordint['4'] = 4;
ordint['5'] = 5;
ordint['6'] = 6;
ordint['7'] = 7;
ordint['8'] = 8;
ordint['9'] = 9;
}
Local void initdx(void)
{
cdx[0] = 0;
cdx[1] = 0;
cdx[2] = -1;
cdx[3] = -1;
cdx[4] = -1;
cdx[5] = -1;
cdx[6] = -1;
cdx[7] = -1;
cdx[8] = 0;
cdx[9] = 0;
cdx[10] = 0;
cdx[11] = -1;
cdx[12] = -1;
cdx[13] = -1;
cdx[14] = -1;
cdx[15] = -1;
cdx[16] = -1;
cdx[17] = 0;
cdx[18] = 0;
cdx[19] = 0;
cdx[20] = 0;
cdx[21] = -1;
cdx[22] = -1;
cdx[23] = 0;
cdx[24] = 0;
cdx[25] = 0;
cdx[26] = -2;
cdx[27] = 0;
cdx[28] = -1;
cdx[29] = 0;
cdx[30] = 0;
cdx[31] = 0;
cdx[32] = 0;
cdx[33] = -1;
cdx[34] = 0;
cdx[35] = 0;
cdx[36] = -1;
cdx[37] = 1;
cdx[38] = 1;
cdx[39] = 1;
cdx[40] = -2;
cdx[41] = 0;
cdx[42] = 0;
cdx[43] = -1;
cdx[44] = -1;
cdx[45] = 0;
cdx[46] = 0;
cdx[47] = -1;
cdx[48] = -1;
cdx[49] = -1;
cdx[50] = 1;
cdx[51] = 1;
cdx[52] = -1;
cdx[53] = -1;
cdx[54] = 1;
cdx[55] = -1;
cdx[56] = -1;
cdx[57] = 0;
cdx[58] = 0;
cdx[59] = 0;
cdx[60] = 0;
pdx[0] = -1;
pdx[1] = -1;
pdx[2] = -2;
pdx[3] = -2;
pdx[4] = -2;
pdx[5] = -3;
pdx[6] = -3;
pdx[7] = -3;
pdx[8] = -3;
pdx[9] = -4;
pdx[10] = 0;
pdx[11] = -2;
pdx[12] = -1;
pdx[13] = 0;
pdx[14] = 0;
pdx[15] = 0;
pdx[16] = 0;
pdx[17] = 0;
pdx[18] = 0;
pdx[19] = 0;
pdx[20] = -1;
pdx[21] = -1;
pdx[22] = -1;
}
Static void inittables(void)
{
/*inittables*/
reswords();
symbols();
rators();
instrmnemonics();
procmnemonics();
chartypes();
initdx();
}
int main(int argc, Char *argv[])
{
_REC_display *WITH;
setofsys SET;
long SET1[(long)casesy / 32 + 2];
setofsys SET2;
PASCAL_MAIN(argc, argv);
prr.f = NULL;
strcpy(prr.name, "prr");
/*initialize*/
/************/
initscalars();
initsets();
inittables();
/*enter standard names and standard types:*/
/******************************************/
level = 0;
top = 0;
WITH = display;
WITH->fname = NULL;
WITH->flabel = NULL;
(where)WITH->occur = blck;
enterstdtypes();
stdnames();
entstdnames();
enterundecl();
top = 1;
level = 1;
WITH = &display[1];
/*compile:*/
WITH->fname = NULL;
WITH->flabel = NULL;
(where)WITH->occur = blck;
if (*prr.name != '\0') {
if (prr.f != NULL)
prr.f = freopen(prr.name, "w", prr.f);
else
prr.f = fopen(prr.name, "w");
} else {
if (prr.f != NULL)
rewind(prr.f);
else
prr.f = tmpfile();
}
if (prr.f == NULL)
_EscIO(FileNotFound);
SETUPBUF(prr.f, Char);
/*comment this out when compiling with pcom */
/**********/
insymbol();
programme(P_setdiff(SET2, P_setunion(SET, blockbegsys, statbegsys),
P_addset(P_expset(SET1, 0), (long)casesy)));
if (prr.f != NULL)
fclose(prr.f);
if (input_ok == true)
return 0;
else
return 1;
}
/* End. */

view raw

pcom.c

hosted with ❤ by GitHub


(*$c+,t-,d-,l-*)
(***********************************************
* *
* Portable Pascal compiler *
* ************************ *
* *
* Pascal P4 *
* *
* Authors: *
* Urs Ammann *
* Kesav Nori *
* Christian Jacobi *
* Address: *
* Institut Fuer Informatik *
* Eidg. Technische Hochschule *
* CH-8096 Zuerich *
* *
* This code is fully documented in the book *
* "Pascal Implementation" *
* by Steven Pemberton and Martin Daniels *
* published by Ellis Horwood, Chichester, UK *
* ISBN: 0-13-653-0311 *
* (also available in Japanese) *
* *
* Steven Pemberton, CWI/AA, *
* Kruislaan 413, 1098 SJ Amsterdam, NL *
* Steven.Pemberton@cwi.nl *
* *
***********************************************)
program pascalcompiler(input,output,prr);
const displimit = 20; maxlevel = 10;
intsize = 1;
intal = 1;
realsize = 1;
realal = 1;
charsize = 1;
charal = 1;
charmax = 1;
boolsize = 1;
boolal = 1;
ptrsize = 1;
adral = 1;
setsize = 1;
setal = 1;
stackal = 1;
stackelsize = 1;
strglgth = 16;
sethigh = 47;
setlow = 0;
ordmaxchar = 63;
ordminchar = 0;
maxint = 32767;
lcaftermarkstack = 5;
fileal = charal;
(* stackelsize = minimum size for 1 stackelement
= k*stackal
stackal = scm(all other al-constants)
charmax = scm(charsize,charal)
scm = smallest common multiple
lcaftermarkstack >= 4*ptrsize+max(x-size)
= k1*stackelsize *)
maxstack = 1;
parmal = stackal;
parmsize = stackelsize;
recal = stackal;
filebuffer = 4;
maxaddr = maxint;
type (*describing:*)
(*************)
marktype= ^integer;
(*basic symbols*)
(***************)
symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
colon,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy,
procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy,
beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,
gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
thensy,othersy);
operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
neop,eqop,inop,noop);
setofsys = set of symbol;
chtp = (letter,number,special,illegal,
chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace);
(*constants*)
(***********)
setty = set of setlow..sethigh;
cstclass = (reel,pset,strg);
csp = ^ constant;
constant = record case cclass: cstclass of
reel: (rval: packed array [1..strglgth] of char);
pset: (pval: setty);
strg: (slgth: 0..strglgth;
sval: packed array [1..strglgth] of char)
end;
valu = record case intval: boolean of (*intval never set nor tested*)
true: (ival: integer);
false: (valp: csp)
end;
(*data structures*)
(*****************)
levrange = 0..maxlevel; addrrange = 0..maxaddr;
structform = (scalar,subrange,pointer,power,arrays,records,files,
tagfld,variant);
declkind = (standard,declared);
stp = ^ structure; ctp = ^ identifier;
structure = packed record
marked: boolean; (*for test phase only*)
size: addrrange;
case form: structform of
scalar: (case scalkind: declkind of
declared: (fconst: ctp); standard: ());
subrange: (rangetype: stp; min,max: valu);
pointer: (eltype: stp);
power: (elset: stp);
arrays: (aeltype,inxtype: stp);
records: (fstfld: ctp; recvar: stp);
files: (filtype: stp);
tagfld: (tagfieldp: ctp; fstvar: stp);
variant: (nxtvar,subvar: stp; varval: valu)
end;
(*names*)
(*******)
idclass = (types,konst,vars,field,proc,func);
setofids = set of idclass;
idkind = (actual,formal);
alpha = packed array [1..8] of char;
identifier = packed record
name: alpha; llink, rlink: ctp;
idtype: stp; next: ctp;
case klass: idclass of
types: ();
konst: (values: valu);
vars: (vkind: idkind; vlev: levrange; vaddr: addrrange);
field: (fldaddr: addrrange);
proc, func: (case pfdeckind: declkind of
standard: (key: 1..15);
declared: (pflev: levrange; pfname: integer;
case pfkind: idkind of
actual: (forwdecl, externl: boolean);
formal: ()))
end;
disprange = 0..displimit;
where = (blck,crec,vrec,rec);
(*expressions*)
(*************)
attrkind = (cst,varbl,expr);
vaccess = (drct,indrct,inxd);
attr = record typtr: stp;
case kind: attrkind of
cst: (cval: valu);
varbl: (case access: vaccess of
drct: (vlevel: levrange; dplmt: addrrange);
indrct: (idplmt: addrrange))
end;
testp = ^ testpointer;
testpointer = packed record
elt1,elt2 : stp;
lasttestp : testp
end;
(*labels*)
(********)
lbp = ^ labl;
labl = record nextlab: lbp; defined: boolean;
labval, labname: integer
end;
extfilep = ^filerec;
filerec = record filename:alpha; nextfile:extfilep end;
(*————————————————————————-*)
var
prr: text; (* comment this out when compiling with pcom *)
(*returned by source program scanner
insymbol:
**********)
sy: symbol; (*last symbol*)
op: operator; (*classification of last symbol*)
val: valu; (*value of last constant*)
lgth: integer; (*length of last string constant*)
id: alpha; (*last identifier (possibly truncated)*)
kk: 1..8; (*nr of chars in last identifier*)
ch: char; (*last character*)
eol: boolean; (*end of line flag*)
(*counters:*)
(***********)
chcnt: integer; (*character counter*)
lc,ic: addrrange; (*data location and instruction counter*)
linecount: integer;
(*switches:*)
(***********)
dp, (*declaration part*)
prterr, (*to allow forward references in pointer type
declaration by suppressing error message*)
list,prcode,prtables: boolean; (*output options for
— source program listing
— printing symbolic code
— displaying ident and struct tables
–> procedure option*)
debug: boolean;
(*pointers:*)
(***********)
parmptr,
intptr,realptr,charptr,
boolptr,nilptr,textptr: stp; (*pointers to entries of standard ids*)
utypptr,ucstptr,uvarptr,
ufldptr,uprcptr,ufctptr, (*pointers to entries for undeclared ids*)
fwptr: ctp; (*head of chain of forw decl type ids*)
fextfilep: extfilep; (*head of chain of external files*)
globtestp: testp; (*last testpointer*)
(*bookkeeping of declaration levels:*)
(************************************)
level: levrange; (*current static level*)
disx, (*level of last id searched by searchid*)
top: disprange; (*top of display*)
display: (*where: means:*)
array [disprange] of
packed record (*=blck: id is variable id*)
fname: ctp; flabel: lbp; (*=crec: id is field id in record with*)
case occur: where of (* constant address*)
crec: (clev: levrange; (*=vrec: id is field id in record with*)
cdspl: addrrange);(* variable address*)
vrec: (vdspl: addrrange)
end; (* –> procedure withstatement*)
(*error messages:*)
(*****************)
errinx: 0..10; (*nr of errors in current source line*)
errlist:
array [1..10] of
packed record pos: integer;
nmr: 1..400
end;
(*expression compilation:*)
(*************************)
gattr: attr; (*describes the expr currently compiled*)
(*structured constants:*)
(***********************)
constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
statbegsys,typedels: setofsys;
chartp : array[char] of chtp;
rw: array [1..35(*nr. of res. words*)] of alpha;
frw: array [1..9] of 1..36(*nr. of res. words + 1*);
rsy: array [1..35(*nr. of res. words*)] of symbol;
ssy: array [char] of symbol;
rop: array [1..35(*nr. of res. words*)] of operator;
sop: array [char] of operator;
na: array [1..35] of alpha;
mn: array [0..60] of packed array [1..4] of char;
sna: array [1..23] of packed array [1..4] of char;
cdx: array [0..60] of -4..+4;
pdx: array [1..23] of -7..+7;
ordint: array [char] of integer;
intlabel,mxint10,digmax: integer;
(*————————————————————————-*)
procedure mark(var p: marktype); begin end;
procedure release(p: marktype); begin end;
procedure endofline;
var lastpos,freepos,currpos,currnmr,f,k: integer;
begin
if errinx > 0 then (*output error messages*)
begin write(output,linecount:6,' **** ':9);
lastpos := 0; freepos := 1;
for k := 1 to errinx do
begin
with errlist[k] do
begin currpos := pos; currnmr := nmr end;
if currpos = lastpos then write(output,',')
else
begin
while freepos < currpos do
begin write(output,' '); freepos := freepos + 1 end;
write(output,'^');
lastpos := currpos
end;
if currnmr < 10 then f := 1
else if currnmr < 100 then f := 2
else f := 3;
write(output,currnmr:f);
freepos := freepos + f + 1
end;
writeln(output); errinx := 0
end;
linecount := linecount + 1;
if list and (not eof(input)) then
begin write(output,linecount:6,' ':2);
if dp then write(output,lc:7) else write(output,ic:7);
write(output,' ')
end;
chcnt := 0
end (*endofline*) ;
procedure error(ferrnr: integer);
begin
if errinx >= 9 then
begin errlist[10].nmr := 255; errinx := 10 end
else
begin errinx := errinx + 1;
errlist[errinx].nmr := ferrnr
end;
errlist[errinx].pos := chcnt
end (*error*) ;
procedure insymbol;
(*read next basic symbol of source program and return its
description in the global variables sy, op, id, val and lgth*)
label 1,2,3;
var i,k: integer;
digit: packed array [1..strglgth] of char;
string: packed array [1..strglgth] of char;
lvp: csp; test: boolean;
procedure nextch;
begin if eol then
begin if list then writeln(output); endofline
end;
if not eof(input) then
begin eol := eoln(input); read(input,ch);
if list then write(output,ch);
chcnt := chcnt + 1
end
else
begin writeln(output,' *** eof ','encountered');
test := false
end
end;
procedure options;
begin
repeat nextch;
if ch <> '*' then
begin
if ch = 't' then
begin nextch; prtables := ch = '+' end
else
if ch = 'l' then
begin nextch; list := ch = '+';
if not list then writeln(output)
end
else
if ch = 'd' then
begin nextch; debug := ch = '+' end
else
if ch = 'c' then
begin nextch; prcode := ch = '+' end;
nextch
end
until ch <> ','
end (*options*) ;
begin (*insymbol*)
1:
repeat while ((ch = ' ') or (ch = ' ')) and not eol do nextch;
test := eol;
if test then nextch
until not test;
if chartp[ch] = illegal then
begin sy := othersy; op := noop;
error(399); nextch
end
else
case chartp[ch] of
letter:
begin k := 0;
repeat
if k < 8 then
begin k := k + 1; id[k] := ch end ;
nextch
until chartp[ch] in [special,illegal,chstrquo,chcolon,
chperiod,chlt,chgt,chlparen,chspace];
if k >= kk then kk := k
else
repeat id[kk] := ' '; kk := kk – 1
until kk = k;
for i := frw[k] to frw[k+1] – 1 do
if rw[i] = id then
begin sy := rsy[i]; op := rop[i]; goto 2 end;
sy := ident; op := noop;
2: end;
number:
begin op := noop; i := 0;
repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
until chartp[ch] <> number;
if ((ch = '.') and (input^ <> '.')) or (ch = 'e') then
begin
k := i;
if ch = '.' then
begin k := k+1; if k <= digmax then digit[k] := ch;
nextch; (*if ch = '.' then begin ch := ':'; goto 3 end;*)
if chartp[ch] <> number then error(201)
else
repeat k := k + 1;
if k <= digmax then digit[k] := ch; nextch
until chartp[ch] <> number
end;
if ch = 'e' then
begin k := k+1; if k <= digmax then digit[k] := ch;
nextch;
if (ch = '+') or (ch ='-') then
begin k := k+1; if k <= digmax then digit[k] := ch;
nextch
end;
if chartp[ch] <> number then error(201)
else
repeat k := k+1;
if k <= digmax then digit[k] := ch; nextch
until chartp[ch] <> number
end;
new(lvp,reel); sy:= realconst; lvp^.cclass := reel;
with lvp^ do
begin for i := 1 to strglgth do rval[i] := ' ';
if k <= digmax then
for i := 2 to k + 1 do rval[i] := digit[i-1]
else begin error(203); rval[2] := '0';
rval[3] := '.'; rval[4] := '0'
end
end;
val.valp := lvp
end
else
3: begin
if i > digmax then begin error(203); val.ival := 0 end
else
with val do
begin ival := 0;
for k := 1 to i do
begin
if ival <= mxint10 then
ival := ival*10+ordint[digit[k]]
else begin error(203); ival := 0 end
end;
sy := intconst
end
end
end;
chstrquo:
begin lgth := 0; sy := stringconst; op := noop;
repeat
repeat nextch; lgth := lgth + 1;
if lgth <= strglgth then string[lgth] := ch
until (eol) or (ch = '''');
if eol then error(202) else nextch
until ch <> '''';
lgth := lgth – 1; (*now lgth = nr of chars in string*)
if lgth = 0 then error(205) else
if lgth = 1 then val.ival := ord(string[1])
else
begin new(lvp,strg); lvp^.cclass:=strg;
if lgth > strglgth then
begin error(399); lgth := strglgth end;
with lvp^ do
begin slgth := lgth;
for i := 1 to lgth do sval[i] := string[i]
end;
val.valp := lvp
end
end;
chcolon:
begin op := noop; nextch;
if ch = '=' then
begin sy := becomes; nextch end
else sy := colon
end;
chperiod:
begin op := noop; nextch;
if ch = '.' then
begin sy := colon; nextch end
else sy := period
end;
chlt:
begin nextch; sy := relop;
if ch = '=' then
begin op := leop; nextch end
else
if ch = '>' then
begin op := neop; nextch end
else op := ltop
end;
chgt:
begin nextch; sy := relop;
if ch = '=' then
begin op := geop; nextch end
else op := gtop
end;
chlparen:
begin nextch;
if ch = '*' then
begin nextch;
if ch = '$' then options;
repeat
while (ch <> '*') and not eof(input) do nextch;
nextch
until (ch = ')') or eof(input);
nextch; goto 1
end;
sy := lparent; op := noop
end;
special:
begin sy := ssy[ch]; op := sop[ch];
nextch
end;
chspace: sy := othersy
end (*case*)
end (*insymbol*) ;
procedure enterid(fcp: ctp);
(*enter id pointed at by fcp into the name-table,
which on each declaration level is organised as
an unbalanced binary tree*)
var nam: alpha; lcp, lcp1: ctp; lleft: boolean;
begin nam := fcp^.name;
lcp := display[top].fname;
if lcp = nil then
display[top].fname := fcp
else
begin
repeat lcp1 := lcp;
if lcp^.name = nam then (*name conflict, follow right link*)
begin error(101); lcp := lcp^.rlink; lleft := false end
else
if lcp^.name < nam then
begin lcp := lcp^.rlink; lleft := false end
else begin lcp := lcp^.llink; lleft := true end
until lcp = nil;
if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
end;
fcp^.llink := nil; fcp^.rlink := nil
end (*enterid*) ;
procedure searchsection(fcp: ctp; var fcp1: ctp);
(*to find record fields and forward declared procedure id's
–> procedure proceduredeclaration
–> procedure selector*)
label 1;
begin
while fcp <> nil do
if fcp^.name = id then goto 1
else if fcp^.name < id then fcp := fcp^.rlink
else fcp := fcp^.llink;
1: fcp1 := fcp
end (*searchsection*) ;
procedure searchid(fidcls: setofids; var fcp: ctp);
label 1;
var lcp: ctp;
begin
for disx := top downto 0 do
begin lcp := display[disx].fname;
while lcp <> nil do
if lcp^.name = id then
if lcp^.klass in fidcls then goto 1
else
begin if prterr then error(103);
lcp := lcp^.rlink
end
else
if lcp^.name < id then
lcp := lcp^.rlink
else lcp := lcp^.llink
end;
(*search not successful; suppress error message in case
of forward referenced type id in pointer type definition
–> procedure simpletype*)
if prterr then
begin error(104);
(*to avoid returning nil, reference an entry
for an undeclared id of appropriate class
–> procedure enterundecl*)
if types in fidcls then lcp := utypptr
else
if vars in fidcls then lcp := uvarptr
else
if field in fidcls then lcp := ufldptr
else
if konst in fidcls then lcp := ucstptr
else
if proc in fidcls then lcp := uprcptr
else lcp := ufctptr;
end;
1: fcp := lcp
end (*searchid*) ;
procedure getbounds(fsp: stp; var fmin,fmax: integer);
(*get internal bounds of subrange or scalar type*)
(*assume fsp<>intptr and fsp<>realptr*)
begin
fmin := 0; fmax := 0;
if fsp <> nil then
with fsp^ do
if form = subrange then
begin fmin := min.ival; fmax := max.ival end
else
if fsp = charptr then
begin fmin := ordminchar; fmax := ordmaxchar
end
else
if fconst <> nil then
fmax := fconst^.values.ival
end (*getbounds*) ;
function alignquot(fsp: stp): integer;
begin
alignquot := 1;
if fsp <> nil then
with fsp^ do
case form of
scalar: if fsp=intptr then alignquot := intal
else if fsp=boolptr then alignquot := boolal
else if scalkind=declared then alignquot := intal
else if fsp=charptr then alignquot := charal
else if fsp=realptr then alignquot := realal
else (*parmptr*) alignquot := parmal;
subrange: alignquot := alignquot(rangetype);
pointer: alignquot := adral;
power: alignquot := setal;
files: alignquot := fileal;
arrays: alignquot := alignquot(aeltype);
records: alignquot := recal;
variant,tagfld: error(501)
end
end (*alignquot*);
procedure align(fsp: stp; var flc: addrrange);
var k,l: integer;
begin
k := alignquot(fsp);
l := flc-1;
flc := l + k – (k+l) mod k
end (*align*);
procedure printtables(fb: boolean);
(*print data structure and name table*)
var i, lim: disprange;
procedure marker;
(*mark data structure entries to avoid multiple printout*)
var i: integer;
procedure markctp(fp: ctp); forward;
procedure markstp(fp: stp);
(*mark data structures, prevent cycles*)
begin
if fp <> nil then
with fp^ do
begin marked := true;
case form of
scalar: ;
subrange: markstp(rangetype);
pointer: (*don't mark eltype: cycle possible; will be marked
anyway, if fp = true*) ;
power: markstp(elset) ;
arrays: begin markstp(aeltype); markstp(inxtype) end;
records: begin markctp(fstfld); markstp(recvar) end;
files: markstp(filtype);
tagfld: markstp(fstvar);
variant: begin markstp(nxtvar); markstp(subvar) end
end (*case*)
end (*with*)
end (*markstp*);
procedure markctp;
begin
if fp <> nil then
with fp^ do
begin markctp(llink); markctp(rlink);
markstp(idtype)
end
end (*markctp*);
begin (*marker*)
for i := top downto lim do
markctp(display[i].fname)
end (*marker*);
procedure followctp(fp: ctp); forward;
procedure followstp(fp: stp);
begin
if fp <> nil then
with fp^ do
if marked then
begin marked := false; write(output,' ':4,ord(fp):6,size:10);
case form of
scalar: begin write(output,'scalar':10);
if scalkind = standard then
write(output,'standard':10)
else write(output,'declared':10,' ':4,ord(fconst):6);
writeln(output)
end;
subrange: begin
write(output,'subrange':10,' ':4,ord(rangetype):6);
if rangetype <> realptr then
write(output,min.ival,max.ival)
else
if (min.valp <> nil) and (max.valp <> nil) then
write(output,' ',min.valp^.rval:9,
' ',max.valp^.rval:9);
writeln(output); followstp(rangetype);
end;
pointer: writeln(output,'pointer':10,' ':4,ord(eltype):6);
power: begin writeln(output,'set':10,' ':4,ord(elset):6);
followstp(elset)
end;
arrays: begin
writeln(output,'array':10,' ':4,ord(aeltype):6,' ':4,
ord(inxtype):6);
followstp(aeltype); followstp(inxtype)
end;
records: begin
writeln(output,'record':10,' ':4,ord(fstfld):6,' ':4,
ord(recvar):6); followctp(fstfld);
followstp(recvar)
end;
files: begin write(output,'file':10,' ':4,ord(filtype):6);
followstp(filtype)
end;
tagfld: begin writeln(output,'tagfld':10,' ':4,ord(tagfieldp):6,
' ':4,ord(fstvar):6);
followstp(fstvar)
end;
variant: begin writeln(output,'variant':10,' ':4,ord(nxtvar):6,
' ':4,ord(subvar):6,varval.ival);
followstp(nxtvar); followstp(subvar)
end
end (*case*)
end (*if marked*)
end (*followstp*);
procedure followctp;
var i: integer;
begin
if fp <> nil then
with fp^ do
begin write(output,' ':4,ord(fp):6,' ',name:9,' ':4,ord(llink):6,
' ':4,ord(rlink):6,' ':4,ord(idtype):6);
case klass of
types: write(output,'type':10);
konst: begin write(output,'constant':10,' ':4,ord(next):6);
if idtype <> nil then
if idtype = realptr then
begin
if values.valp <> nil then
write(output,' ',values.valp^.rval:9)
end
else
if idtype^.form = arrays then (*stringconst*)
begin
if values.valp <> nil then
begin write(output,' ');
with values.valp^ do
for i := 1 to slgth do
write(output,sval[i])
end
end
else write(output,values.ival)
end;
vars: begin write(output,'variable':10);
if vkind = actual then write(output,'actual':10)
else write(output,'formal':10);
write(output,' ':4,ord(next):6,vlev,' ':4,vaddr:6 );
end;
field: write(output,'field':10,' ':4,ord(next):6,' ':4,fldaddr:6);
proc,
func: begin
if klass = proc then write(output,'procedure':10)
else write(output,'function':10);
if pfdeckind = standard then
write(output,'standard':10, key:10)
else
begin write(output,'declared':10,' ':4,ord(next):6);
write(output,pflev,' ':4,pfname:6);
if pfkind = actual then
begin write(output,'actual':10);
if forwdecl then write(output,'forward':10)
else write(output,'notforward':10);
if externl then write(output,'extern':10)
else write(output,'not extern':10);
end
else write(output,'formal':10)
end
end
end (*case*);
writeln(output);
followctp(llink); followctp(rlink);
followstp(idtype)
end (*with*)
end (*followctp*);
begin (*printtables*)
writeln(output); writeln(output); writeln(output);
if fb then lim := 0
else begin lim := top; write(output,' local') end;
writeln(output,' tables '); writeln(output);
marker;
for i := top downto lim do
followctp(display[i].fname);
writeln(output);
if not eol then write(output,' ':chcnt+16)
end (*printtables*);
procedure genlabel(var nxtlab: integer);
begin intlabel := intlabel + 1;
nxtlab := intlabel
end (*genlabel*);
procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp);
var lsy: symbol; test: boolean;
procedure skip(fsys: setofsys);
(*skip input string until relevant symbol found*)
begin
if not eof(input) then
begin while not(sy in fsys) and (not eof(input)) do insymbol;
if not (sy in fsys) then insymbol
end
end (*skip*) ;
procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu);
var lsp: stp; lcp: ctp; sign: (none,pos,neg);
lvp: csp; i: 2..strglgth;
begin lsp := nil; fvalu.ival := 0;
if not(sy in constbegsys) then
begin error(50); skip(fsys+constbegsys) end;
if sy in constbegsys then
begin
if sy = stringconst then
begin
if lgth = 1 then lsp := charptr
else
begin
new(lsp,arrays);
with lsp^ do
begin aeltype := charptr; inxtype := nil;
size := lgth*charsize; form := arrays
end
end;
fvalu := val; insymbol
end
else
begin
sign := none;
if (sy = addop) and (op in [plus,minus]) then
begin if op = plus then sign := pos else sign := neg;
insymbol
end;
if sy = ident then
begin searchid([konst],lcp);
with lcp^ do
begin lsp := idtype; fvalu := values end;
if sign <> none then
if lsp = intptr then
begin if sign = neg then fvalu.ival := -fvalu.ival end
else
if lsp = realptr then
begin
if sign = neg then
begin new(lvp,reel);
if fvalu.valp^.rval[1] = '-' then
lvp^.rval[1] := '+'
else lvp^.rval[1] := '-';
for i := 2 to strglgth do
lvp^.rval[i] := fvalu.valp^.rval[i];
fvalu.valp := lvp;
end
end
else error(105);
insymbol;
end
else
if sy = intconst then
begin if sign = neg then val.ival := -val.ival;
lsp := intptr; fvalu := val; insymbol
end
else
if sy = realconst then
begin if sign = neg then val.valp^.rval[1] := '-';
lsp := realptr; fvalu := val; insymbol
end
else
begin error(106); skip(fsys) end
end;
if not (sy in fsys) then
begin error(6); skip(fsys) end
end;
fsp := lsp
end (*constant*) ;
function equalbounds(fsp1,fsp2: stp): boolean;
var lmin1,lmin2,lmax1,lmax2: integer;
begin
if (fsp1=nil) or (fsp2=nil) then equalbounds := true
else
begin
getbounds(fsp1,lmin1,lmax1);
getbounds(fsp2,lmin2,lmax2);
equalbounds := (lmin1=lmin2) and (lmax1=lmax2)
end
end (*equalbounds*) ;
function comptypes(fsp1,fsp2: stp) : boolean;
(*decide whether structures pointed at by fsp1 and fsp2 are compatible*)
var nxt1,nxt2: ctp; comp: boolean;
ltestp1,ltestp2 : testp;
begin
if fsp1 = fsp2 then comptypes := true
else
if (fsp1 <> nil) and (fsp2 <> nil) then
if fsp1^.form = fsp2^.form then
case fsp1^.form of
scalar:
comptypes := false;
(* identical scalars declared on different levels are
not recognized to be compatible*)
subrange:
comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype);
pointer:
begin
comp := false; ltestp1 := globtestp;
ltestp2 := globtestp;
while ltestp1 <> nil do
with ltestp1^ do
begin
if (elt1 = fsp1^.eltype) and
(elt2 = fsp2^.eltype) then comp := true;
ltestp1 := lasttestp
end;
if not comp then
begin new(ltestp1);
with ltestp1^ do
begin elt1 := fsp1^.eltype;
elt2 := fsp2^.eltype;
lasttestp := globtestp
end;
globtestp := ltestp1;
comp := comptypes(fsp1^.eltype,fsp2^.eltype)
end;
comptypes := comp; globtestp := ltestp2
end;
power:
comptypes := comptypes(fsp1^.elset,fsp2^.elset);
arrays:
begin
comp := comptypes(fsp1^.aeltype,fsp2^.aeltype)
and comptypes(fsp1^.inxtype,fsp2^.inxtype);
comptypes := comp and (fsp1^.size = fsp2^.size) and
equalbounds(fsp1^.inxtype,fsp2^.inxtype)
end;
records:
begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true;
while (nxt1 <> nil) and (nxt2 <> nil) do
begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype);
nxt1 := nxt1^.next; nxt2 := nxt2^.next
end;
comptypes := comp and (nxt1 = nil) and (nxt2 = nil)
and(fsp1^.recvar = nil)and(fsp2^.recvar = nil)
end;
(*identical records are recognized to be compatible
iff no variants occur*)
files:
comptypes := comptypes(fsp1^.filtype,fsp2^.filtype)
end (*case*)
else (*fsp1^.form <> fsp2^.form*)
if fsp1^.form = subrange then
comptypes := comptypes(fsp1^.rangetype,fsp2)
else
if fsp2^.form = subrange then
comptypes := comptypes(fsp1,fsp2^.rangetype)
else comptypes := false
else comptypes := true
end (*comptypes*) ;
function string(fsp: stp) : boolean;
begin string := false;
if fsp <> nil then
if fsp^.form = arrays then
if comptypes(fsp^.aeltype,charptr) then string := true
end (*string*) ;
procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange);
var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
lsize,displ: addrrange; lmin,lmax: integer;
procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange);
var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
lcnt: integer; lvalu: valu;
begin fsize := 1;
if not (sy in simptypebegsys) then
begin error(1); skip(fsys + simptypebegsys) end;
if sy in simptypebegsys then
begin
if sy = lparent then
begin ttop := top; (*decl. consts local to innermost block*)
while display[top].occur <> blck do top := top – 1;
new(lsp,scalar,declared);
with lsp^ do
begin size := intsize; form := scalar;
scalkind := declared
end;
lcp1 := nil; lcnt := 0;
repeat insymbol;
if sy = ident then
begin new(lcp,konst);
with lcp^ do
begin name := id; idtype := lsp; next := lcp1;
values.ival := lcnt; klass := konst
end;
enterid(lcp);
lcnt := lcnt + 1;
lcp1 := lcp; insymbol
end
else error(2);
if not (sy in fsys + [comma,rparent]) then
begin error(6); skip(fsys + [comma,rparent]) end
until sy <> comma;
lsp^.fconst := lcp1; top := ttop;
if sy = rparent then insymbol else error(4)
end
else
begin
if sy = ident then
begin searchid([types,konst],lcp);
insymbol;
if lcp^.klass = konst then
begin new(lsp,subrange);
with lsp^, lcp^ do
begin rangetype := idtype; form := subrange;
if string(rangetype) then
begin error(148); rangetype := nil end;
min := values; size := intsize
end;
if sy = colon then insymbol else error(5);
constant(fsys,lsp1,lvalu);
lsp^.max := lvalu;
if lsp^.rangetype <> lsp1 then error(107)
end
else
begin lsp := lcp^.idtype;
if lsp <> nil then fsize := lsp^.size
end
end (*sy = ident*)
else
begin new(lsp,subrange); lsp^.form := subrange;
constant(fsys + [colon],lsp1,lvalu);
if string(lsp1) then
begin error(148); lsp1 := nil end;
with lsp^ do
begin rangetype:=lsp1; min:=lvalu; size:=intsize end;
if sy = colon then insymbol else error(5);
constant(fsys,lsp1,lvalu);
lsp^.max := lvalu;
if lsp^.rangetype <> lsp1 then error(107)
end;
if lsp <> nil then
with lsp^ do
if form = subrange then
if rangetype <> nil then
if rangetype = realptr then error(399)
else
if min.ival > max.ival then error(102)
end;
fsp := lsp;
if not (sy in fsys) then
begin error(6); skip(fsys) end
end
else fsp := nil
end (*simpletype*) ;
procedure fieldlist(fsys: setofsys; var frecvar: stp);
var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp;
minsize,maxsize,lsize: addrrange; lvalu: valu;
begin nxt1 := nil; lsp := nil;
if not (sy in (fsys+[ident,casesy])) then
begin error(19); skip(fsys + [ident,casesy]) end;
while sy = ident do
begin nxt := nxt1;
repeat
if sy = ident then
begin new(lcp,field);
with lcp^ do
begin name := id; idtype := nil; next := nxt;
klass := field
end;
nxt := lcp;
enterid(lcp);
insymbol
end
else error(2);
if not (sy in [comma,colon]) then
begin error(6); skip(fsys + [comma,colon,semicolon,casesy])
end;
test := sy <> comma;
if not test then insymbol
until test;
if sy = colon then insymbol else error(5);
typ(fsys + [casesy,semicolon],lsp,lsize);
while nxt <> nxt1 do
with nxt^ do
begin align(lsp,displ);
idtype := lsp; fldaddr := displ;
nxt := next; displ := displ + lsize
end;
nxt1 := lcp;
while sy = semicolon do
begin insymbol;
if not (sy in fsys + [ident,casesy,semicolon]) then
begin error(19); skip(fsys + [ident,casesy]) end
end
end (*while*);
nxt := nil;
while nxt1 <> nil do
with nxt1^ do
begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end;
if sy = casesy then
begin new(lsp,tagfld);
with lsp^ do
begin tagfieldp := nil; fstvar := nil; form:=tagfld end;
frecvar := lsp;
insymbol;
if sy = ident then
begin new(lcp,field);
with lcp^ do
begin name := id; idtype := nil; klass:=field;
next := nil; fldaddr := displ
end;
enterid(lcp);
insymbol;
if sy = colon then insymbol else error(5);
if sy = ident then
begin searchid([types],lcp1);
lsp1 := lcp1^.idtype;
if lsp1 <> nil then
begin align(lsp1,displ);
lcp^.fldaddr := displ;
displ := displ+lsp1^.size;
if (lsp1^.form <= subrange) or string(lsp1) then
begin if comptypes(realptr,lsp1) then error(109)
else if string(lsp1) then error(399);
lcp^.idtype := lsp1; lsp^.tagfieldp := lcp;
end
else error(110);
end;
insymbol;
end
else begin error(2); skip(fsys + [ofsy,lparent]) end
end
else begin error(2); skip(fsys + [ofsy,lparent]) end;
lsp^.size := displ;
if sy = ofsy then insymbol else error(8);
lsp1 := nil; minsize := displ; maxsize := displ;
repeat lsp2 := nil;
if not (sy in fsys + [semicolon]) then
begin
repeat constant(fsys + [comma,colon,lparent],lsp3,lvalu);
if lsp^.tagfieldp <> nil then
if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then error(111);
new(lsp3,variant);
with lsp3^ do
begin nxtvar := lsp1; subvar := lsp2; varval := lvalu;
form := variant
end;
lsp4 := lsp1;
while lsp4 <> nil do
with lsp4^ do
begin
if varval.ival = lvalu.ival then error(178);
lsp4 := nxtvar
end;
lsp1 := lsp3; lsp2 := lsp3;
test := sy <> comma;
if not test then insymbol
until test;
if sy = colon then insymbol else error(5);
if sy = lparent then insymbol else error(9);
fieldlist(fsys + [rparent,semicolon],lsp2);
if displ > maxsize then maxsize := displ;
while lsp3 <> nil do
begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2;
lsp3^.size := displ;
lsp3 := lsp4
end;
if sy = rparent then
begin insymbol;
if not (sy in fsys + [semicolon]) then
begin error(6); skip(fsys + [semicolon]) end
end
else error(4);
end;
test := sy <> semicolon;
if not test then
begin displ := minsize;
insymbol
end
until test;
displ := maxsize;
lsp^.fstvar := lsp1;
end
else frecvar := nil
end (*fieldlist*) ;
begin (*typ*)
if not (sy in typebegsys) then
begin error(10); skip(fsys + typebegsys) end;
if sy in typebegsys then
begin
if sy in simptypebegsys then simpletype(fsys,fsp,fsize)
else
(*^*) if sy = arrow then
begin new(lsp,pointer); fsp := lsp;
with lsp^ do
begin eltype := nil; size := ptrsize; form:=pointer end;
insymbol;
if sy = ident then
begin prterr := false; (*no error if search not successful*)
searchid([types],lcp); prterr := true;
if lcp = nil then (*forward referenced type id*)
begin new(lcp,types);
with lcp^ do
begin name := id; idtype := lsp;
next := fwptr; klass := types
end;
fwptr := lcp
end
else
begin
if lcp^.idtype <> nil then
if lcp^.idtype^.form = files then error(108)
else lsp^.eltype := lcp^.idtype
end;
insymbol;
end
else error(2);
end
else
begin
if sy = packedsy then
begin insymbol;
if not (sy in typedels) then
begin
error(10); skip(fsys + typedels)
end
end;
(*array*) if sy = arraysy then
begin insymbol;
if sy = lbrack then insymbol else error(11);
lsp1 := nil;
repeat new(lsp,arrays);
with lsp^ do
begin aeltype := lsp1; inxtype := nil; form:=arrays end;
lsp1 := lsp;
simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize);
lsp1^.size := lsize;
if lsp2 <> nil then
if lsp2^.form <= subrange then
begin
if lsp2 = realptr then
begin error(109); lsp2 := nil end
else
if lsp2 = intptr then
begin error(149); lsp2 := nil end;
lsp^.inxtype := lsp2
end
else begin error(113); lsp2 := nil end;
test := sy <> comma;
if not test then insymbol
until test;
if sy = rbrack then insymbol else error(12);
if sy = ofsy then insymbol else error(8);
typ(fsys,lsp,lsize);
repeat
with lsp1^ do
begin lsp2 := aeltype; aeltype := lsp;
if inxtype <> nil then
begin getbounds(inxtype,lmin,lmax);
align(lsp,lsize);
lsize := lsize*(lmax – lmin + 1);
size := lsize
end
end;
lsp := lsp1; lsp1 := lsp2
until lsp1 = nil
end
else
(*record*) if sy = recordsy then
begin insymbol;
oldtop := top;
if top < displimit then
begin top := top + 1;
with display[top] do
begin fname := nil;
flabel := nil;
occur := rec
end
end
else error(250);
displ := 0;
fieldlist(fsys-[semicolon]+[endsy],lsp1);
new(lsp,records);
with lsp^ do
begin fstfld := display[top].fname;
recvar := lsp1; size := displ; form := records
end;
top := oldtop;
if sy = endsy then insymbol else error(13)
end
else
(*set*) if sy = setsy then
begin insymbol;
if sy = ofsy then insymbol else error(8);
simpletype(fsys,lsp1,lsize);
if lsp1 <> nil then
if lsp1^.form > subrange then
begin error(115); lsp1 := nil end
else
if lsp1 = realptr then
begin error(114); lsp1 := nil end
else if lsp1 = intptr then
begin error(169); lsp1 := nil end
else
begin getbounds(lsp1,lmin,lmax);
if (lmin < setlow) or (lmax > sethigh)
then error(169);
end;
new(lsp,power);
with lsp^ do
begin elset:=lsp1; size:=setsize; form:=power end;
end
else
(*file*) if sy = filesy then
begin insymbol;
error(399); skip(fsys); lsp := nil
end;
fsp := lsp
end;
if not (sy in fsys) then
begin error(6); skip(fsys) end
end
else fsp := nil;
if fsp = nil then fsize := 1 else fsize := fsp^.size
end (*typ*) ;
procedure labeldeclaration;
var llp: lbp; redef: boolean; lbname: integer;
begin
repeat
if sy = intconst then
with display[top] do
begin llp := flabel; redef := false;
while (llp <> nil) and not redef do
if llp^.labval <> val.ival then
llp := llp^.nextlab
else begin redef := true; error(166) end;
if not redef then
begin new(llp);
with llp^ do
begin labval := val.ival; genlabel(lbname);
defined := false; nextlab := flabel; labname := lbname
end;
flabel := llp
end;
insymbol
end
else error(15);
if not ( sy in fsys + [comma, semicolon] ) then
begin error(6); skip(fsys+[comma,semicolon]) end;
test := sy <> comma;
if not test then insymbol
until test;
if sy = semicolon then insymbol else error(14)
end (* labeldeclaration *) ;
procedure constdeclaration;
var lcp: ctp; lsp: stp; lvalu: valu;
begin
if sy <> ident then
begin error(2); skip(fsys + [ident]) end;
while sy = ident do
begin new(lcp,konst);
with lcp^ do
begin name := id; idtype := nil; next := nil; klass:=konst end;
insymbol;
if (sy = relop) and (op = eqop) then insymbol else error(16);
constant(fsys + [semicolon],lsp,lvalu);
enterid(lcp);
lcp^.idtype := lsp; lcp^.values := lvalu;
if sy = semicolon then
begin insymbol;
if not (sy in fsys + [ident]) then
begin error(6); skip(fsys + [ident]) end
end
else error(14)
end
end (*constdeclaration*) ;
procedure typedeclaration;
var lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
begin
if sy <> ident then
begin error(2); skip(fsys + [ident]) end;
while sy = ident do
begin new(lcp,types);
with lcp^ do
begin name := id; idtype := nil; klass := types end;
insymbol;
if (sy = relop) and (op = eqop) then insymbol else error(16);
typ(fsys + [semicolon],lsp,lsize);
enterid(lcp);
lcp^.idtype := lsp;
(*has any forward reference been satisfied:*)
lcp1 := fwptr;
while lcp1 <> nil do
begin
if lcp1^.name = lcp^.name then
begin lcp1^.idtype^.eltype := lcp^.idtype;
if lcp1 <> fwptr then
lcp2^.next := lcp1^.next
else fwptr := lcp1^.next;
end
else lcp2 := lcp1;
lcp1 := lcp1^.next
end;
if sy = semicolon then
begin insymbol;
if not (sy in fsys + [ident]) then
begin error(6); skip(fsys + [ident]) end
end
else error(14)
end;
if fwptr <> nil then
begin error(117); writeln(output);
repeat writeln(output,' type-id ',fwptr^.name);
fwptr := fwptr^.next
until fwptr = nil;
if not eol then write(output,' ': chcnt+16)
end
end (*typedeclaration*) ;
procedure vardeclaration;
var lcp,nxt: ctp; lsp: stp; lsize: addrrange;
begin nxt := nil;
repeat
repeat
if sy = ident then
begin new(lcp,vars);
with lcp^ do
begin name := id; next := nxt; klass := vars;
idtype := nil; vkind := actual; vlev := level
end;
enterid(lcp);
nxt := lcp;
insymbol;
end
else error(2);
if not (sy in fsys + [comma,colon] + typedels) then
begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end;
test := sy <> comma;
if not test then insymbol
until test;
if sy = colon then insymbol else error(5);
typ(fsys + [semicolon] + typedels,lsp,lsize);
while nxt <> nil do
with nxt^ do
begin align(lsp,lc);
idtype := lsp; vaddr := lc;
lc := lc + lsize; nxt := next
end;
if sy = semicolon then
begin insymbol;
if not (sy in fsys + [ident]) then
begin error(6); skip(fsys + [ident]) end
end
else error(14)
until (sy <> ident) and not (sy in typedels);
if fwptr <> nil then
begin error(117); writeln(output);
repeat writeln(output,' type-id ',fwptr^.name);
fwptr := fwptr^.next
until fwptr = nil;
if not eol then write(output,' ': chcnt+16)
end
end (*vardeclaration*) ;
procedure procdeclaration(fsy: symbol);
var oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp;
forw: boolean; oldtop: disprange;
llc,lcm: addrrange; lbname: integer; markp: marktype;
procedure parameterlist(fsy: setofsys; var fpar: ctp);
var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind;
llc,lsize: addrrange; count: integer;
begin lcp1 := nil;
if not (sy in fsy + [lparent]) then
begin error(7); skip(fsys + fsy + [lparent]) end;
if sy = lparent then
begin if forw then error(119);
insymbol;
if not (sy in [ident,varsy,procsy,funcsy]) then
begin error(7); skip(fsys + [ident,rparent]) end;
while sy in [ident,varsy,procsy,funcsy] do
begin
if sy = procsy then
begin error(399);
repeat insymbol;
if sy = ident then
begin new(lcp,proc,declared,formal);
with lcp^ do
begin name := id; idtype := nil; next := lcp1;
pflev := level (*beware of parameter procedures*);
klass:=proc;pfdeckind:=declared;pfkind:=formal
end;
enterid(lcp);
lcp1 := lcp;
align(parmptr,lc);
(*lc := lc + some size *)
insymbol
end
else error(2);
if not (sy in fsys + [comma,semicolon,rparent]) then
begin error(7);skip(fsys+[comma,semicolon,rparent])end
until sy <> comma
end
else
begin
if sy = funcsy then
begin error(399); lcp2 := nil;
repeat insymbol;
if sy = ident then
begin new(lcp,func,declared,formal);
with lcp^ do
begin name := id; idtype := nil; next := lcp2;
pflev := level (*beware param funcs*);
klass:=func;pfdeckind:=declared;
pfkind:=formal
end;
enterid(lcp);
lcp2 := lcp;
align(parmptr,lc);
(*lc := lc + some size*)
insymbol;
end;
if not (sy in [comma,colon] + fsys) then
begin error(7);skip(fsys+[comma,semicolon,rparent])
end
until sy <> comma;
if sy = colon then
begin insymbol;
if sy = ident then
begin searchid([types],lcp);
lsp := lcp^.idtype;
if lsp <> nil then
if not(lsp^.form in[scalar,subrange,pointer])
then begin error(120); lsp := nil end;
lcp3 := lcp2;
while lcp2 <> nil do
begin lcp2^.idtype := lsp; lcp := lcp2;
lcp2 := lcp2^.next
end;
lcp^.next := lcp1; lcp1 := lcp3;
insymbol
end
else error(2);
if not (sy in fsys + [semicolon,rparent]) then
begin error(7);skip(fsys+[semicolon,rparent])end
end
else error(5)
end
else
begin
if sy = varsy then
begin lkind := formal; insymbol end
else lkind := actual;
lcp2 := nil;
count := 0;
repeat
if sy = ident then
begin new(lcp,vars);
with lcp^ do
begin name:=id; idtype:=nil; klass:=vars;
vkind := lkind; next := lcp2; vlev := level;
end;
enterid(lcp);
lcp2 := lcp; count := count+1;
insymbol;
end;
if not (sy in [comma,colon] + fsys) then
begin error(7);skip(fsys+[comma,semicolon,rparent])
end;
test := sy <> comma;
if not test then insymbol
until test;
if sy = colon then
begin insymbol;
if sy = ident then
begin searchid([types],lcp);
lsp := lcp^.idtype;
lsize := ptrsize;
if lsp <> nil then
if lkind=actual then
if lsp^.form<=power then lsize := lsp^.size
else if lsp^.form=files then error(121);
align(parmptr,lsize);
lcp3 := lcp2;
align(parmptr,lc);
lc := lc+count*lsize;
llc := lc;
while lcp2 <> nil do
begin lcp := lcp2;
with lcp2^ do
begin idtype := lsp;
llc := llc-lsize;
vaddr := llc;
end;
lcp2 := lcp2^.next
end;
lcp^.next := lcp1; lcp1 := lcp3;
insymbol
end
else error(2);
if not (sy in fsys + [semicolon,rparent]) then
begin error(7);skip(fsys+[semicolon,rparent])end
end
else error(5);
end;
end;
if sy = semicolon then
begin insymbol;
if not (sy in fsys + [ident,varsy,procsy,funcsy]) then
begin error(7); skip(fsys + [ident,rparent]) end
end
end (*while*) ;
if sy = rparent then
begin insymbol;
if not (sy in fsy + fsys) then
begin error(6); skip(fsy + fsys) end
end
else error(4);
lcp3 := nil;
(*reverse pointers and reserve local cells for copies of multiple
values*)
while lcp1 <> nil do
with lcp1^ do
begin lcp2 := next; next := lcp3;
if klass = vars then
if idtype <> nil then
if (vkind=actual)and(idtype^.form>power) then
begin align(idtype,lc);
vaddr := lc;
lc := lc+idtype^.size;
end;
lcp3 := lcp1; lcp1 := lcp2
end;
fpar := lcp3
end
else fpar := nil
end (*parameterlist*) ;
begin (*procdeclaration*)
llc := lc; lc := lcaftermarkstack; forw := false;
if sy = ident then
begin searchsection(display[top].fname,lcp); (*decide whether forw.*)
if lcp <> nil then
begin
if lcp^.klass = proc then
forw := lcp^.forwdecl and(fsy=procsy)and(lcp^.pfkind=actual)
else
if lcp^.klass = func then
forw:=lcp^.forwdecl and(fsy=funcsy)and(lcp^.pfkind=actual)
else forw := false;
if not forw then error(160)
end;
if not forw then
begin
if fsy = procsy then new(lcp,proc,declared,actual)
else new(lcp,func,declared,actual);
with lcp^ do
begin name := id; idtype := nil;
externl := false; pflev := level; genlabel(lbname);
pfdeckind := declared; pfkind := actual; pfname := lbname;
if fsy = procsy then klass := proc
else klass := func
end;
enterid(lcp)
end
else
begin lcp1 := lcp^.next;
while lcp1 <> nil do
begin
with lcp1^ do
if klass = vars then
if idtype <> nil then
begin lcm := vaddr + idtype^.size;
if lcm > lc then lc := lcm
end;
lcp1 := lcp1^.next
end
end;
insymbol
end
else
begin error(2); lcp := ufctptr end;
oldlev := level; oldtop := top;
if level < maxlevel then level := level + 1 else error(251);
if top < displimit then
begin top := top + 1;
with display[top] do
begin
if forw then fname := lcp^.next
else fname := nil;
flabel := nil;
occur := blck
end
end
else error(250);
if fsy = procsy then
begin parameterlist([semicolon],lcp1);
if not forw then lcp^.next := lcp1
end
else
begin parameterlist([semicolon,colon],lcp1);
if not forw then lcp^.next := lcp1;
if sy = colon then
begin insymbol;
if sy = ident then
begin if forw then error(122);
searchid([types],lcp1);
lsp := lcp1^.idtype;
lcp^.idtype := lsp;
if lsp <> nil then
if not (lsp^.form in [scalar,subrange,pointer]) then
begin error(120); lcp^.idtype := nil end;
insymbol
end
else begin error(2); skip(fsys + [semicolon]) end
end
else
if not forw then error(123)
end;
if sy = semicolon then insymbol else error(14);
if sy = forwardsy then
begin
if forw then error(161)
else lcp^.forwdecl := true;
insymbol;
if sy = semicolon then insymbol else error(14);
if not (sy in fsys) then
begin error(6); skip(fsys) end
end
else
begin lcp^.forwdecl := false; mark(markp);
repeat block(fsys,semicolon,lcp);
if sy = semicolon then
begin if prtables then printtables(false); insymbol;
if not (sy in [beginsy,procsy,funcsy]) then
begin error(6); skip(fsys) end
end
else error(14)
until (sy in [beginsy,procsy,funcsy]) or eof(input);
release(markp); (* return local entries on runtime heap *)
end;
level := oldlev; top := oldtop; lc := llc;
end (*procdeclaration*) ;
procedure body(fsys: setofsys);
const cstoccmax=65; cixmax=1000;
type oprange = 0..63;
var
llcp:ctp; saveid:alpha;
cstptr: array [1..cstoccmax] of csp;
cstptrix: 0..cstoccmax;
(*allows referencing of noninteger constants by an index
(instead of a pointer), which can be stored in the p2-field
of the instruction record until writeout.
–> procedure load, procedure writeout*)
entname, segsize: integer;
stacktop, topnew, topmax: integer;
lcmax,llc1: addrrange; lcp: ctp;
llp: lbp;
procedure mes(i: integer);
begin topnew := topnew + cdx[i]*maxstack;
if topnew > topmax then topmax := topnew
end;
procedure putic;
begin if ic mod 10 = 0 then writeln(prr,'i',ic:5) end;
procedure gen0(fop: oprange);
begin
if prcode then begin putic; writeln(prr,mn[fop]:4) end;
ic := ic + 1; mes(fop)
end (*gen0*) ;
procedure gen1(fop: oprange; fp2: integer);
var k: integer;
begin
if prcode then
begin putic; write(prr,mn[fop]:4);
if fop = 30 then
begin writeln(prr,sna[fp2]:12);
topnew := topnew + pdx[fp2]*maxstack;
if topnew > topmax then topmax := topnew
end
else
begin
if fop = 38 then
begin write(prr,'''');
with cstptr[fp2]^ do
begin
for k := 1 to slgth do write(prr,sval[k]:1);
for k := slgth+1 to strglgth do write(prr,' ');
end;
writeln(prr,'''')
end
else if fop = 42 then writeln(prr,chr(fp2))
else writeln(prr,fp2:12);
mes(fop)
end
end;
ic := ic + 1
end (*gen1*) ;
procedure gen2(fop: oprange; fp1,fp2: integer);
var k : integer;
begin
if prcode then
begin putic; write(prr,mn[fop]:4);
case fop of
45,50,54,56:
writeln(prr,' ',fp1:3,fp2:8);
47,48,49,52,53,55:
begin write(prr,chr(fp1));
if chr(fp1) = 'm' then write(prr,fp2:11);
writeln(prr)
end;
51:
case fp1 of
1: writeln(prr,'i ',fp2);
2: begin write(prr,'r ');
with cstptr[fp2]^ do
for k := 1 to strglgth do write(prr,rval[k]);
writeln(prr)
end;
3: writeln(prr,'b ',fp2);
4: writeln(prr,'n');
6: writeln(prr,'c ''':3,chr(fp2),'''');
5: begin write(prr,'(');
with cstptr[fp2]^ do
for k := setlow to sethigh do
if k in pval then write(prr,k:3);
writeln(prr,')')
end
end
end;
end;
ic := ic + 1; mes(fop)
end (*gen2*) ;
procedure gentypindicator(fsp: stp);
begin
if fsp<>nil then
with fsp^ do
case form of
scalar: if fsp=intptr then write(prr,'i')
else
if fsp=boolptr then write(prr,'b')
else
if fsp=charptr then write(prr,'c')
else
if scalkind = declared then write(prr,'i')
else write(prr,'r');
subrange: gentypindicator(rangetype);
pointer: write(prr,'a');
power: write(prr,'s');
records,arrays: write(prr,'m');
files,tagfld,variant: error(500)
end
end (*typindicator*);
procedure gen0t(fop: oprange; fsp: stp);
begin
if prcode then
begin putic;
write(prr,mn[fop]:4);
gentypindicator(fsp);
writeln(prr);
end;
ic := ic + 1; mes(fop)
end (*gen0t*);
procedure gen1t(fop: oprange; fp2: integer; fsp: stp);
begin
if prcode then
begin putic;
write(prr,mn[fop]:4);
gentypindicator(fsp);
writeln(prr,fp2:11)
end;
ic := ic + 1; mes(fop)
end (*gen1t*);
procedure gen2t(fop: oprange; fp1,fp2: integer; fsp: stp);
begin
if prcode then
begin putic;
write(prr,mn[fop]: 4);
gentypindicator(fsp);
writeln(prr,fp1:3+5*ord(abs(fp1)>99),fp2:8);
end;
ic := ic + 1; mes(fop)
end (*gen2t*);
procedure load;
begin
with gattr do
if typtr <> nil then
begin
case kind of
cst: if (typtr^.form = scalar) and (typtr <> realptr) then
if typtr = boolptr then gen2(51(*ldc*),3,cval.ival)
else
if typtr=charptr then
gen2(51(*ldc*),6,cval.ival)
else gen2(51(*ldc*),1,cval.ival)
else
if typtr = nilptr then gen2(51(*ldc*),4,0)
else
if cstptrix >= cstoccmax then error(254)
else
begin cstptrix := cstptrix + 1;
cstptr[cstptrix] := cval.valp;
if typtr = realptr then
gen2(51(*ldc*),2,cstptrix)
else
gen2(51(*ldc*),5,cstptrix)
end;
varbl: case access of
drct: if vlevel<=1 then
gen1t(39(*ldo*),dplmt,typtr)
else gen2t(54(*lod*),level-vlevel,dplmt,typtr);
indrct: gen1t(35(*ind*),idplmt,typtr);
inxd: error(400)
end;
expr:
end;
kind := expr
end
end (*load*) ;
procedure store(var fattr: attr);
begin
with fattr do
if typtr <> nil then
case access of
drct: if vlevel <= 1 then gen1t(43(*sro*),dplmt,typtr)
else gen2t(56(*str*),level-vlevel,dplmt,typtr);
indrct: if idplmt <> 0 then error(400)
else gen0t(26(*sto*),typtr);
inxd: error(400)
end
end (*store*) ;
procedure loadaddress;
begin
with gattr do
if typtr <> nil then
begin
case kind of
cst: if string(typtr) then
if cstptrix >= cstoccmax then error(254)
else
begin cstptrix := cstptrix + 1;
cstptr[cstptrix] := cval.valp;
gen1(38(*lca*),cstptrix)
end
else error(400);
varbl: case access of
drct: if vlevel <= 1 then gen1(37(*lao*),dplmt)
else gen2(50(*lda*),level-vlevel,dplmt);
indrct: if idplmt <> 0 then
gen1t(34(*inc*),idplmt,nilptr);
inxd: error(400)
end;
expr: error(400)
end;
kind := varbl; access := indrct; idplmt := 0
end
end (*loadaddress*) ;
procedure genfjp(faddr: integer);
begin load;
if gattr.typtr <> nil then
if gattr.typtr <> boolptr then error(144);
if prcode then begin putic; writeln(prr,mn[33]:4,' l':8,faddr:4) end;
ic := ic + 1; mes(33)
end (*genfjp*) ;
procedure genujpxjp(fop: oprange; fp2: integer);
begin
if prcode then
begin putic; writeln(prr, mn[fop]:4, ' l':8,fp2:4) end;
ic := ic + 1; mes(fop)
end (*genujpxjp*);
procedure gencupent(fop: oprange; fp1,fp2: integer);
begin
if prcode then
begin putic;
writeln(prr,mn[fop]:4,fp1:4,'l':4,fp2:4)
end;
ic := ic + 1; mes(fop)
end;
procedure checkbnds(fsp: stp);
var lmin,lmax: integer;
begin
if fsp <> nil then
if fsp <> intptr then
if fsp <> realptr then
if fsp^.form <= subrange then
begin
getbounds(fsp,lmin,lmax);
gen2t(45(*chk*),lmin,lmax,fsp)
end
end (*checkbnds*);
procedure putlabel(labname: integer);
begin if prcode then writeln(prr, 'l', labname:4)
end (*putlabel*);
procedure statement(fsys: setofsys);
label 1;
var lcp: ctp; llp: lbp;
procedure expression(fsys: setofsys); forward;
procedure selector(fsys: setofsys; fcp: ctp);
var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: integer;
begin
with fcp^, gattr do
begin typtr := idtype; kind := varbl;
case klass of
vars:
if vkind = actual then
begin access := drct; vlevel := vlev;
dplmt := vaddr
end
else
begin gen2t(54(*lod*),level-vlev,vaddr,nilptr);
access := indrct; idplmt := 0
end;
field:
with display[disx] do
if occur = crec then
begin access := drct; vlevel := clev;
dplmt := cdspl + fldaddr
end
else
begin
if level = 1 then gen1t(39(*ldo*),vdspl,nilptr)
else gen2t(54(*lod*),0,vdspl,nilptr);
access := indrct; idplmt := fldaddr
end;
func:
if pfdeckind = standard then
begin error(150); typtr := nil end
else
begin
if pfkind = formal then error(151)
else
if (pflev+1<>level)or(fprocp<>fcp) then error(177);
begin access := drct; vlevel := pflev + 1;
dplmt := 0 (*impl. relat. addr. of fct. result*)
end
end
end (*case*)
end (*with*);
if not (sy in selectsys + fsys) then
begin error(59); skip(selectsys + fsys) end;
while sy in selectsys do
begin
(*[*) if sy = lbrack then
begin
repeat lattr := gattr;
with lattr do
if typtr <> nil then
if typtr^.form <> arrays then
begin error(138); typtr := nil end;
loadaddress;
insymbol; expression(fsys + [comma,rbrack]);
load;
if gattr.typtr <> nil then
if gattr.typtr^.form<>scalar then error(113)
else if not comptypes(gattr.typtr,intptr) then
gen0t(58(*ord*),gattr.typtr);
if lattr.typtr <> nil then
with lattr.typtr^ do
begin
if comptypes(inxtype,gattr.typtr) then
begin
if inxtype <> nil then
begin getbounds(inxtype,lmin,lmax);
if debug then
gen2t(45(*chk*),lmin,lmax,intptr);
if lmin>0 then gen1t(31(*dec*),lmin,intptr)
else if lmin<0 then
gen1t(34(*inc*),-lmin,intptr);
(*or simply gen1(31,lmin)*)
end
end
else error(139);
with gattr do
begin typtr := aeltype; kind := varbl;
access := indrct; idplmt := 0
end;
if gattr.typtr <> nil then
begin
lsize := gattr.typtr^.size;
align(gattr.typtr,lsize);
gen1(36(*ixa*),lsize)
end
end
until sy <> comma;
if sy = rbrack then insymbol else error(12)
end (*if sy = lbrack*)
else
(*.*) if sy = period then
begin
with gattr do
begin
if typtr <> nil then
if typtr^.form <> records then
begin error(140); typtr := nil end;
insymbol;
if sy = ident then
begin
if typtr <> nil then
begin searchsection(typtr^.fstfld,lcp);
if lcp = nil then
begin error(152); typtr := nil end
else
with lcp^ do
begin typtr := idtype;
case access of
drct: dplmt := dplmt + fldaddr;
indrct: idplmt := idplmt + fldaddr;
inxd: error(400)
end
end
end;
insymbol
end (*sy = ident*)
else error(2)
end (*with gattr*)
end (*if sy = period*)
else
(*^*) begin
if gattr.typtr <> nil then
with gattr,typtr^ do
if form = pointer then
begin load; typtr := eltype;
if debug then gen2t(45(*chk*),1,maxaddr,nilptr);
with gattr do
begin kind := varbl; access := indrct;
idplmt := 0
end
end
else
if form = files then typtr := filtype
else error(141);
insymbol
end;
if not (sy in fsys + selectsys) then
begin error(6); skip(fsys + selectsys) end
end (*while*)
end (*selector*) ;
procedure call(fsys: setofsys; fcp: ctp);
var lkey: 1..15;
procedure variable(fsys: setofsys);
var lcp: ctp;
begin
if sy = ident then
begin searchid([vars,field],lcp); insymbol end
else begin error(2); lcp := uvarptr end;
selector(fsys,lcp)
end (*variable*) ;
procedure getputresetrewrite;
begin variable(fsys + [rparent]); loadaddress;
if gattr.typtr <> nil then
if gattr.typtr^.form <> files then error(116);
if lkey <= 2 then gen1(30(*csp*),lkey(*get,put*))
else error(399)
end (*getputresetrewrite*) ;
procedure read;
var llev:levrange; laddr:addrrange;
lsp : stp;
begin
llev := 1; laddr := lcaftermarkstack;
if sy = lparent then
begin insymbol;
variable(fsys + [comma,rparent]);
lsp := gattr.typtr; test := false;
if lsp <> nil then
if lsp^.form = files then
with gattr, lsp^ do
begin
if filtype = charptr then
begin llev := vlevel; laddr := dplmt end
else error(399);
if sy = rparent then
begin if lkey = 5 then error(116);
test := true
end
else
if sy <> comma then
begin error(116); skip(fsys + [comma,rparent]) end;
if sy = comma then
begin insymbol; variable(fsys + [comma,rparent])
end
else test := true
end;
if not test then
repeat loadaddress;
gen2(50(*lda*),level-llev,laddr);
if gattr.typtr <> nil then
if gattr.typtr^.form <= subrange then
if comptypes(intptr,gattr.typtr) then
gen1(30(*csp*),3(*rdi*))
else
if comptypes(realptr,gattr.typtr) then
gen1(30(*csp*),4(*rdr*))
else
if comptypes(charptr,gattr.typtr) then
gen1(30(*csp*),5(*rdc*))
else error(399)
else error(116);
test := sy <> comma;
if not test then
begin insymbol; variable(fsys + [comma,rparent])
end
until test;
if sy = rparent then insymbol else error(4)
end
else if lkey = 5 then error(116);
if lkey = 11 then
begin gen2(50(*lda*),level-llev,laddr);
gen1(30(*csp*),21(*rln*))
end
end (*read*) ;
procedure write;
var lsp: stp; default : boolean; llkey: 1..15;
llev:levrange; laddr,len:addrrange;
begin llkey := lkey;
llev := 1; laddr := lcaftermarkstack + charmax;
if sy = lparent then
begin insymbol;
expression(fsys + [comma,colon,rparent]);
lsp := gattr.typtr; test := false;
if lsp <> nil then
if lsp^.form = files then
with gattr, lsp^ do
begin
if filtype = charptr then
begin llev := vlevel; laddr := dplmt end
else error(399);
if sy = rparent then
begin if llkey = 6 then error(116);
test := true
end
else
if sy <> comma then
begin error(116); skip(fsys+[comma,rparent]) end;
if sy = comma then
begin insymbol; expression(fsys+[comma,colon,rparent])
end
else test := true
end;
if not test then
repeat
lsp := gattr.typtr;
if lsp <> nil then
if lsp^.form <= subrange then load else loadaddress;
if sy = colon then
begin insymbol; expression(fsys + [comma,colon,rparent]);
if gattr.typtr <> nil then
if gattr.typtr <> intptr then error(116);
load; default := false
end
else default := true;
if sy = colon then
begin insymbol; expression(fsys + [comma,rparent]);
if gattr.typtr <> nil then
if gattr.typtr <> intptr then error(116);
if lsp <> realptr then error(124);
load; error(399);
end
else
if lsp = intptr then
begin if default then gen2(51(*ldc*),1,10);
gen2(50(*lda*),level-llev,laddr);
gen1(30(*csp*),6(*wri*))
end
else
if lsp = realptr then
begin if default then gen2(51(*ldc*),1,20);
gen2(50(*lda*),level-llev,laddr);
gen1(30(*csp*),8(*wrr*))
end
else
if lsp = charptr then
begin if default then gen2(51(*ldc*),1,1);
gen2(50(*lda*),level-llev,laddr);
gen1(30(*csp*),9(*wrc*))
end
else
if lsp <> nil then
begin
if lsp^.form = scalar then error(399)
else
if string(lsp) then
begin len := lsp^.size div charmax;
if default then
gen2(51(*ldc*),1,len);
gen2(51(*ldc*),1,len);
gen2(50(*lda*),level-llev,laddr);
gen1(30(*csp*),10(*wrs*))
end
else error(116)
end;
test := sy <> comma;
if not test then
begin insymbol; expression(fsys + [comma,colon,rparent])
end
until test;
if sy = rparent then insymbol else error(4)
end
else if lkey = 6 then error(116);
if llkey = 12 then (*writeln*)
begin gen2(50(*lda*),level-llev,laddr);
gen1(30(*csp*),22(*wln*))
end
end (*write*) ;
procedure pack;
var lsp,lsp1: stp;
begin error(399); variable(fsys + [comma,rparent]);
lsp := nil; lsp1 := nil;
if gattr.typtr <> nil then
with gattr.typtr^ do
if form = arrays then
begin lsp := inxtype; lsp1 := aeltype end
else error(116);
if sy = comma then insymbol else error(20);
expression(fsys + [comma,rparent]);
if gattr.typtr <> nil then
if gattr.typtr^.form <> scalar then error(116)
else
if not comptypes(lsp,gattr.typtr) then error(116);
if sy = comma then insymbol else error(20);
variable(fsys + [rparent]);
if gattr.typtr <> nil then
with gattr.typtr^ do
if form = arrays then
begin
if not comptypes(aeltype,lsp1)
or not comptypes(inxtype,lsp) then
error(116)
end
else error(116)
end (*pack*) ;
procedure unpack;
var lsp,lsp1: stp;
begin error(399); variable(fsys + [comma,rparent]);
lsp := nil; lsp1 := nil;
if gattr.typtr <> nil then
with gattr.typtr^ do
if form = arrays then
begin lsp := inxtype; lsp1 := aeltype end
else error(116);
if sy = comma then insymbol else error(20);
variable(fsys + [comma,rparent]);
if gattr.typtr <> nil then
with gattr.typtr^ do
if form = arrays then
begin
if not comptypes(aeltype,lsp1)
or not comptypes(inxtype,lsp) then
error(116)
end
else error(116);
if sy = comma then insymbol else error(20);
expression(fsys + [rparent]);
if gattr.typtr <> nil then
if gattr.typtr^.form <> scalar then error(116)
else
if not comptypes(lsp,gattr.typtr) then error(116);
end (*unpack*) ;
procedure new;
label 1;
var lsp,lsp1: stp; varts: integer;
lsize: addrrange; lval: valu;
begin variable(fsys + [comma,rparent]); loadaddress;
lsp := nil; varts := 0; lsize := 0;
if gattr.typtr <> nil then
with gattr.typtr^ do
if form = pointer then
begin
if eltype <> nil then
begin lsize := eltype^.size;
if eltype^.form = records then lsp := eltype^.recvar
end
end
else error(116);
while sy = comma do
begin insymbol;constant(fsys + [comma,rparent],lsp1,lval);
varts := varts + 1;
(*check to insert here: is constant in tagfieldtype range*)
if lsp = nil then error(158)
else
if lsp^.form <> tagfld then error(162)
else
if lsp^.tagfieldp <> nil then
if string(lsp1) or (lsp1 = realptr) then error(159)
else
if comptypes(lsp^.tagfieldp^.idtype,lsp1) then
begin
lsp1 := lsp^.fstvar;
while lsp1 <> nil do
with lsp1^ do
if varval.ival = lval.ival then
begin lsize := size; lsp := subvar;
goto 1
end
else lsp1 := nxtvar;
lsize := lsp^.size; lsp := nil;
end
else error(116);
1: end (*while*) ;
gen2(51(*ldc*),1,lsize);
gen1(30(*csp*),12(*new*));
end (*new*) ;
procedure mark;
begin variable(fsys+[rparent]);
if gattr.typtr <> nil then
if gattr.typtr^.form = pointer then
begin loadaddress; gen1(30(*csp*),23(*sav*)) end
else error(116)
end(*mark*);
procedure release;
begin variable(fsys+[rparent]);
if gattr.typtr <> nil then
if gattr.typtr^.form = pointer then
begin load; gen1(30(*csp*),13(*rst*)) end
else error(116)
end (*release*);
procedure abs;
begin
if gattr.typtr <> nil then
if gattr.typtr = intptr then gen0(0(*abi*))
else
if gattr.typtr = realptr then gen0(1(*abr*))
else begin error(125); gattr.typtr := intptr end
end (*abs*) ;
procedure sqr;
begin
if gattr.typtr <> nil then
if gattr.typtr = intptr then gen0(24(*sqi*))
else
if gattr.typtr = realptr then gen0(25(*sqr*))
else begin error(125); gattr.typtr := intptr end
end (*sqr*) ;
procedure trunc;
begin
if gattr.typtr <> nil then
if gattr.typtr <> realptr then error(125);
gen0(27(*trc*));
gattr.typtr := intptr
end (*trunc*) ;
procedure odd;
begin
if gattr.typtr <> nil then
if gattr.typtr <> intptr then error(125);
gen0(20(*odd*));
gattr.typtr := boolptr
end (*odd*) ;
procedure ord;
begin
if gattr.typtr <> nil then
if gattr.typtr^.form >= power then error(125);
gen0t(58(*ord*),gattr.typtr);
gattr.typtr := intptr
end (*ord*) ;
procedure chr;
begin
if gattr.typtr <> nil then
if gattr.typtr <> intptr then error(125);
gen0(59(*chr*));
gattr.typtr := charptr
end (*chr*) ;
procedure predsucc;
begin
if gattr.typtr <> nil then
if gattr.typtr^.form <> scalar then error(125);
if lkey = 7 then gen1t(31(*dec*),1,gattr.typtr)
else gen1t(34(*inc*),1,gattr.typtr)
end (*predsucc*) ;
procedure eof;
begin
if sy = lparent then
begin insymbol; variable(fsys + [rparent]);
if sy = rparent then insymbol else error(4)
end
else
with gattr do
begin typtr := textptr; kind := varbl; access := drct;
vlevel := 1; dplmt := lcaftermarkstack
end;
loadaddress;
if gattr.typtr <> nil then
if gattr.typtr^.form <> files then error(125);
if lkey = 9 then gen0(8(*eof*)) else gen1(30(*csp*),14(*eln*));
gattr.typtr := boolptr
end (*eof*) ;
procedure callnonstandard;
var nxt,lcp: ctp; lsp: stp; lkind: idkind; lb: boolean;
locpar, llc: addrrange;
begin locpar := 0;
with fcp^ do
begin nxt := next; lkind := pfkind;
if not externl then gen1(41(*mst*),level-pflev)
end;
if sy = lparent then
begin llc := lc;
repeat lb := false; (*decide whether proc/func must be passed*)
if lkind = actual then
begin
if nxt = nil then error(126)
else lb := nxt^.klass in [proc,func]
end else error(399);
(*For formal proc/func, lb is false and expression
will be called, which will always interpret a proc/func id
at its beginning as a call rather than a parameter passing.
In this implementation, parameter procedures/functions
are therefore not allowed to have procedure/function
parameters*)
insymbol;
if lb then (*pass function or procedure*)
begin error(399);
if sy <> ident then
begin error(2); skip(fsys + [comma,rparent]) end
else
begin
if nxt^.klass = proc then searchid([proc],lcp)
else
begin searchid([func],lcp);
if not comptypes(lcp^.idtype,nxt^.idtype) then
error(128)
end;
insymbol;
if not (sy in fsys + [comma,rparent]) then
begin error(6); skip(fsys + [comma,rparent]) end
end
end (*if lb*)
else
begin expression(fsys + [comma,rparent]);
if gattr.typtr <> nil then
if lkind = actual then
begin
if nxt <> nil then
begin lsp := nxt^.idtype;
if lsp <> nil then
begin
if (nxt^.vkind = actual) then
if lsp^.form <= power then
begin load;
if debug then checkbnds(lsp);
if comptypes(realptr,lsp)
and (gattr.typtr = intptr) then
begin gen0(10(*flt*));
gattr.typtr := realptr
end;
locpar := locpar+lsp^.size;
align(parmptr,locpar);
end
else
begin
loadaddress;
locpar := locpar+ptrsize;
align(parmptr,locpar)
end
else
if gattr.kind = varbl then
begin loadaddress;
locpar := locpar+ptrsize;
align(parmptr,locpar);
end
else error(154);
if not comptypes(lsp,gattr.typtr) then
error(142)
end
end
end
else (*lkind = formal*)
begin (*pass formal param*)
end
end;
if (lkind = actual) and (nxt <> nil) then nxt := nxt^.next
until sy <> comma;
lc := llc;
if sy = rparent then insymbol else error(4)
end (*if lparent*);
if lkind = actual then
begin if nxt <> nil then error(126);
with fcp^ do
begin
if externl then gen1(30(*csp*),pfname)
else gencupent(46(*cup*),locpar,pfname);
end
end;
gattr.typtr := fcp^.idtype
end (*callnonstandard*) ;
begin (*call*)
if fcp^.pfdeckind = standard then
begin lkey := fcp^.key;
if fcp^.klass = proc then
begin
if not(lkey in [5,6,11,12]) then
if sy = lparent then insymbol else error(9);
case lkey of
1,2,
3,4: getputresetrewrite;
5,11: read;
6,12: write;
7: pack;
8: unpack;
9: new;
10: release;
13: mark
end;
if not(lkey in [5,6,11,12]) then
if sy = rparent then insymbol else error(4)
end
else
begin
if lkey <= 8 then
begin
if sy = lparent then insymbol else error(9);
expression(fsys+[rparent]); load
end;
case lkey of
1: abs;
2: sqr;
3: trunc;
4: odd;
5: ord;
6: chr;
7,8: predsucc;
9,10: eof
end;
if lkey <= 8 then
if sy = rparent then insymbol else error(4)
end;
end (*standard procedures and functions*)
else callnonstandard
end (*call*) ;
procedure expression;
var lattr: attr; lop: operator; typind: char; lsize: addrrange;
procedure simpleexpression(fsys: setofsys);
var lattr: attr; lop: operator; signed: boolean;
procedure term(fsys: setofsys);
var lattr: attr; lop: operator;
procedure factor(fsys: setofsys);
var lcp: ctp; lvp: csp; varpart: boolean;
cstpart: setty; lsp: stp;
begin
if not (sy in facbegsys) then
begin error(58); skip(fsys + facbegsys);
gattr.typtr := nil
end;
while sy in facbegsys do
begin
case sy of
(*id*) ident:
begin searchid([konst,vars,field,func],lcp);
insymbol;
if lcp^.klass = func then
begin call(fsys,lcp);
with gattr do
begin kind := expr;
if typtr <> nil then
if typtr^.form=subrange then
typtr := typtr^.rangetype
end
end
else
if lcp^.klass = konst then
with gattr, lcp^ do
begin typtr := idtype; kind := cst;
cval := values
end
else
begin selector(fsys,lcp);
if gattr.typtr<>nil then(*elim.subr.types to*)
with gattr,typtr^ do(*simplify later tests*)
if form = subrange then
typtr := rangetype
end
end;
(*cst*) intconst:
begin
with gattr do
begin typtr := intptr; kind := cst;
cval := val
end;
insymbol
end;
realconst:
begin
with gattr do
begin typtr := realptr; kind := cst;
cval := val
end;
insymbol
end;
stringconst:
begin
with gattr do
begin
if lgth = 1 then typtr := charptr
else
begin new(lsp,arrays);
with lsp^ do
begin aeltype := charptr; form:=arrays;
inxtype := nil; size := lgth*charsize
end;
typtr := lsp
end;
kind := cst; cval := val
end;
insymbol
end;
(* ( *) lparent:
begin insymbol; expression(fsys + [rparent]);
if sy = rparent then insymbol else error(4)
end;
(*not*) notsy:
begin insymbol; factor(fsys);
load; gen0(19(*not*));
if gattr.typtr <> nil then
if gattr.typtr <> boolptr then
begin error(135); gattr.typtr := nil end;
end;
(*[*) lbrack:
begin insymbol; cstpart := [ ]; varpart := false;
new(lsp,power);
with lsp^ do
begin elset:=nil;size:=setsize;form:=power end;
if sy = rbrack then
begin
with gattr do
begin typtr := lsp; kind := cst end;
insymbol
end
else
begin
repeat expression(fsys + [comma,rbrack]);
if gattr.typtr <> nil then
if gattr.typtr^.form <> scalar then
begin error(136); gattr.typtr := nil end
else
if comptypes(lsp^.elset,gattr.typtr) then
begin
if gattr.kind = cst then
if (gattr.cval.ival < setlow) or
(gattr.cval.ival > sethigh) then
error(304)
else
cstpart := cstpart+[gattr.cval.ival]
else
begin load;
if not comptypes(gattr.typtr,intptr)
then gen0t(58(*ord*),gattr.typtr);
gen0(23(*sgs*));
if varpart then gen0(28(*uni*))
else varpart := true
end;
lsp^.elset := gattr.typtr;
gattr.typtr := lsp
end
else error(137);
test := sy <> comma;
if not test then insymbol
until test;
if sy = rbrack then insymbol else error(12)
end;
if varpart then
begin
if cstpart <> [ ] then
begin new(lvp,pset); lvp^.pval := cstpart;
lvp^.cclass := pset;
if cstptrix = cstoccmax then error(254)
else
begin cstptrix := cstptrix + 1;
cstptr[cstptrix] := lvp;
gen2(51(*ldc*),5,cstptrix);
gen0(28(*uni*)); gattr.kind := expr
end
end
end
else
begin new(lvp,pset); lvp^.pval := cstpart;
lvp^.cclass := pset;
gattr.cval.valp := lvp
end
end
end (*case*) ;
if not (sy in fsys) then
begin error(6); skip(fsys + facbegsys) end
end (*while*)
end (*factor*) ;
begin (*term*)
factor(fsys + [mulop]);
while sy = mulop do
begin load; lattr := gattr; lop := op;
insymbol; factor(fsys + [mulop]); load;
if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
case lop of
(***) mul: if (lattr.typtr=intptr)and(gattr.typtr=intptr)
then gen0(15(*mpi*))
else
begin
if lattr.typtr = intptr then
begin gen0(9(*flo*));
lattr.typtr := realptr
end
else
if gattr.typtr = intptr then
begin gen0(10(*flt*));
gattr.typtr := realptr
end;
if (lattr.typtr = realptr)
and(gattr.typtr=realptr)then gen0(16(*mpr*))
else
if(lattr.typtr^.form=power)
and comptypes(lattr.typtr,gattr.typtr)then
gen0(12(*int*))
else begin error(134); gattr.typtr:=nil end
end;
(* / *) rdiv: begin
if gattr.typtr = intptr then
begin gen0(10(*flt*));
gattr.typtr := realptr
end;
if lattr.typtr = intptr then
begin gen0(9(*flo*));
lattr.typtr := realptr
end;
if (lattr.typtr = realptr)
and (gattr.typtr=realptr)then gen0(7(*dvr*))
else begin error(134); gattr.typtr := nil end
end;
(*div*) idiv: if (lattr.typtr = intptr)
and (gattr.typtr = intptr) then gen0(6(*dvi*))
else begin error(134); gattr.typtr := nil end;
(*mod*) imod: if (lattr.typtr = intptr)
and (gattr.typtr = intptr) then gen0(14(*mod*))
else begin error(134); gattr.typtr := nil end;
(*and*) andop:if (lattr.typtr = boolptr)
and (gattr.typtr = boolptr) then gen0(4(*and*))
else begin error(134); gattr.typtr := nil end
end (*case*)
else gattr.typtr := nil
end (*while*)
end (*term*) ;
begin (*simpleexpression*)
signed := false;
if (sy = addop) and (op in [plus,minus]) then
begin signed := op = minus; insymbol end;
term(fsys + [addop]);
if signed then
begin load;
if gattr.typtr = intptr then gen0(17(*ngi*))
else
if gattr.typtr = realptr then gen0(18(*ngr*))
else begin error(134); gattr.typtr := nil end
end;
while sy = addop do
begin load; lattr := gattr; lop := op;
insymbol; term(fsys + [addop]); load;
if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
case lop of
(*+*) plus:
if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
gen0(2(*adi*))
else
begin
if lattr.typtr = intptr then
begin gen0(9(*flo*));
lattr.typtr := realptr
end
else
if gattr.typtr = intptr then
begin gen0(10(*flt*));
gattr.typtr := realptr
end;
if (lattr.typtr = realptr)and(gattr.typtr = realptr)
then gen0(3(*adr*))
else if(lattr.typtr^.form=power)
and comptypes(lattr.typtr,gattr.typtr) then
gen0(28(*uni*))
else begin error(134); gattr.typtr:=nil end
end;
(*-*) minus:
if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
gen0(21(*sbi*))
else
begin
if lattr.typtr = intptr then
begin gen0(9(*flo*));
lattr.typtr := realptr
end
else
if gattr.typtr = intptr then
begin gen0(10(*flt*));
gattr.typtr := realptr
end;
if (lattr.typtr = realptr)and(gattr.typtr = realptr)
then gen0(22(*sbr*))
else
if (lattr.typtr^.form = power)
and comptypes(lattr.typtr,gattr.typtr) then
gen0(5(*dif*))
else begin error(134); gattr.typtr := nil end
end;
(*or*) orop:
if(lattr.typtr=boolptr)and(gattr.typtr=boolptr)then
gen0(13(*ior*))
else begin error(134); gattr.typtr := nil end
end (*case*)
else gattr.typtr := nil
end (*while*)
end (*simpleexpression*) ;
begin (*expression*)
simpleexpression(fsys + [relop]);
if sy = relop then
begin
if gattr.typtr <> nil then
if gattr.typtr^.form <= power then load
else loadaddress;
lattr := gattr; lop := op;
if lop = inop then
if not comptypes(gattr.typtr,intptr) then
gen0t(58(*ord*),gattr.typtr);
insymbol; simpleexpression(fsys);
if gattr.typtr <> nil then
if gattr.typtr^.form <= power then load
else loadaddress;
if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
if lop = inop then
if gattr.typtr^.form = power then
if comptypes(lattr.typtr,gattr.typtr^.elset) then
gen0(11(*inn*))
else begin error(129); gattr.typtr := nil end
else begin error(130); gattr.typtr := nil end
else
begin
if lattr.typtr <> gattr.typtr then
if lattr.typtr = intptr then
begin gen0(9(*flo*));
lattr.typtr := realptr
end
else
if gattr.typtr = intptr then
begin gen0(10(*flt*));
gattr.typtr := realptr
end;
if comptypes(lattr.typtr,gattr.typtr) then
begin lsize := lattr.typtr^.size;
case lattr.typtr^.form of
scalar:
if lattr.typtr = realptr then typind := 'r'
else
if lattr.typtr = boolptr then typind := 'b'
else
if lattr.typtr = charptr then typind := 'c'
else typind := 'i';
pointer:
begin
if lop in [ltop,leop,gtop,geop] then error(131);
typind := 'a'
end;
power:
begin if lop in [ltop,gtop] then error(132);
typind := 's'
end;
arrays:
begin
if not string(lattr.typtr)
then error(134);
typind := 'm'
end;
records:
begin
error(134);
typind := 'm'
end;
files:
begin error(133); typind := 'f' end
end;
case lop of
ltop: gen2(53(*les*),ord(typind),lsize);
leop: gen2(52(*leq*),ord(typind),lsize);
gtop: gen2(49(*grt*),ord(typind),lsize);
geop: gen2(48(*geq*),ord(typind),lsize);
neop: gen2(55(*neq*),ord(typind),lsize);
eqop: gen2(47(*equ*),ord(typind),lsize)
end
end
else error(129)
end;
gattr.typtr := boolptr; gattr.kind := expr
end (*sy = relop*)
end (*expression*) ;
procedure assignment(fcp: ctp);
var lattr: attr;
begin selector(fsys + [becomes],fcp);
if sy = becomes then
begin
if gattr.typtr <> nil then
if (gattr.access<>drct) or (gattr.typtr^.form>power) then
loadaddress;
lattr := gattr;
insymbol; expression(fsys);
if gattr.typtr <> nil then
if gattr.typtr^.form <= power then load
else loadaddress;
if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
begin
if comptypes(realptr,lattr.typtr)and(gattr.typtr=intptr)then
begin gen0(10(*flt*));
gattr.typtr := realptr
end;
if comptypes(lattr.typtr,gattr.typtr) then
case lattr.typtr^.form of
scalar,
subrange: begin
if debug then checkbnds(lattr.typtr);
store(lattr)
end;
pointer: begin
if debug then
gen2t(45(*chk*),0,maxaddr,nilptr);
store(lattr)
end;
power: store(lattr);
arrays,
records: gen1(40(*mov*),lattr.typtr^.size);
files: error(146)
end
else error(129)
end
end (*sy = becomes*)
else error(51)
end (*assignment*) ;
procedure gotostatement;
var llp: lbp; found: boolean; ttop,ttop1: disprange;
begin
if sy = intconst then
begin
found := false;
ttop := top;
while display[ttop].occur <> blck do ttop := ttop – 1;
ttop1 := ttop;
repeat
llp := display[ttop].flabel;
while (llp <> nil) and not found do
with llp^ do
if labval = val.ival then
begin found := true;
if ttop = ttop1 then
genujpxjp(57(*ujp*),labname)
else (*goto leads out of procedure*) error(399)
end
else llp := nextlab;
ttop := ttop – 1
until found or (ttop = 0);
if not found then error(167);
insymbol
end
else error(15)
end (*gotostatement*) ;
procedure compoundstatement;
begin
repeat
repeat statement(fsys + [semicolon,endsy])
until not (sy in statbegsys);
test := sy <> semicolon;
if not test then insymbol
until test;
if sy = endsy then insymbol else error(13)
end (*compoundstatemenet*) ;
procedure ifstatement;
var lcix1,lcix2: integer;
begin expression(fsys + [thensy]);
genlabel(lcix1); genfjp(lcix1);
if sy = thensy then insymbol else error(52);
statement(fsys + [elsesy]);
if sy = elsesy then
begin genlabel(lcix2); genujpxjp(57(*ujp*),lcix2);
putlabel(lcix1);
insymbol; statement(fsys);
putlabel(lcix2)
end
else putlabel(lcix1)
end (*ifstatement*) ;
procedure casestatement;
label 1;
type cip = ^caseinfo;
caseinfo = packed
record next: cip;
csstart: integer;
cslab: integer
end;
var lsp,lsp1: stp; fstptr,lpt1,lpt2,lpt3: cip; lval: valu;
laddr, lcix, lcix1, lmin, lmax: integer;
begin expression(fsys + [ofsy,comma,colon]);
load; genlabel(lcix);
lsp := gattr.typtr;
if lsp <> nil then
if (lsp^.form <> scalar) or (lsp = realptr) then
begin error(144); lsp := nil end
else if not comptypes(lsp,intptr) then gen0t(58(*ord*),lsp);
genujpxjp(57(*ujp*),lcix);
if sy = ofsy then insymbol else error(8);
fstptr := nil; genlabel(laddr);
repeat
lpt3 := nil; genlabel(lcix1);
if not(sy in [semicolon,endsy]) then
begin
repeat constant(fsys + [comma,colon],lsp1,lval);
if lsp <> nil then
if comptypes(lsp,lsp1) then
begin lpt1 := fstptr; lpt2 := nil;
while lpt1 <> nil do
with lpt1^ do
begin
if cslab <= lval.ival then
begin if cslab = lval.ival then error(156);
goto 1
end;
lpt2 := lpt1; lpt1 := next
end;
1: new(lpt3);
with lpt3^ do
begin next := lpt1; cslab := lval.ival;
csstart := lcix1
end;
if lpt2 = nil then fstptr := lpt3
else lpt2^.next := lpt3
end
else error(147);
test := sy <> comma;
if not test then insymbol
until test;
if sy = colon then insymbol else error(5);
putlabel(lcix1);
repeat statement(fsys + [semicolon])
until not (sy in statbegsys);
if lpt3 <> nil then
genujpxjp(57(*ujp*),laddr);
end;
test := sy <> semicolon;
if not test then insymbol
until test;
putlabel(lcix);
if fstptr <> nil then
begin lmax := fstptr^.cslab;
(*reverse pointers*)
lpt1 := fstptr; fstptr := nil;
repeat lpt2 := lpt1^.next; lpt1^.next := fstptr;
fstptr := lpt1; lpt1 := lpt2
until lpt1 = nil;
lmin := fstptr^.cslab;
if lmax – lmin < cixmax then
begin
gen2t(45(*chk*),lmin,lmax,intptr);
gen2(51(*ldc*),1,lmin); gen0(21(*sbi*)); genlabel(lcix);
genujpxjp(44(*xjp*),lcix); putlabel(lcix);
repeat
with fstptr^ do
begin
while cslab > lmin do
begin gen0(60(*ujc error*));
lmin := lmin+1
end;
genujpxjp(57(*ujp*),csstart);
fstptr := next; lmin := lmin + 1
end
until fstptr = nil;
putlabel(laddr)
end
else error(157)
end;
if sy = endsy then insymbol else error(13)
end (*casestatement*) ;
procedure repeatstatement;
var laddr: integer;
begin genlabel(laddr); putlabel(laddr);
repeat statement(fsys + [semicolon,untilsy]);
if sy in statbegsys then error(14)
until not(sy in statbegsys);
while sy = semicolon do
begin insymbol;
repeat statement(fsys + [semicolon,untilsy]);
if sy in statbegsys then error(14)
until not (sy in statbegsys);
end;
if sy = untilsy then
begin insymbol; expression(fsys); genfjp(laddr)
end
else error(53)
end (*repeatstatement*) ;
procedure whilestatement;
var laddr, lcix: integer;
begin genlabel(laddr); putlabel(laddr);
expression(fsys + [dosy]); genlabel(lcix); genfjp(lcix);
if sy = dosy then insymbol else error(54);
statement(fsys); genujpxjp(57(*ujp*),laddr); putlabel(lcix)
end (*whilestatement*) ;
procedure forstatement;
var lattr: attr; lsy: symbol;
lcix, laddr: integer;
llc: addrrange;
begin llc := lc;
with lattr do
begin typtr := nil; kind := varbl;
access := drct; vlevel := level; dplmt := 0
end;
if sy = ident then
begin searchid([vars],lcp);
with lcp^, lattr do
begin typtr := idtype; kind := varbl;
if vkind = actual then
begin access := drct; vlevel := vlev;
dplmt := vaddr
end
else begin error(155); typtr := nil end
end;
if lattr.typtr <> nil then
if (lattr.typtr^.form > subrange)
or comptypes(realptr,lattr.typtr) then
begin error(143); lattr.typtr := nil end;
insymbol
end
else
begin error(2); skip(fsys + [becomes,tosy,downtosy,dosy]) end;
if sy = becomes then
begin insymbol; expression(fsys + [tosy,downtosy,dosy]);
if gattr.typtr <> nil then
if gattr.typtr^.form <> scalar then error(144)
else
if comptypes(lattr.typtr,gattr.typtr) then
begin load; store(lattr) end
else error(145)
end
else
begin error(51); skip(fsys + [tosy,downtosy,dosy]) end;
if sy in [tosy,downtosy] then
begin lsy := sy; insymbol; expression(fsys + [dosy]);
if gattr.typtr <> nil then
if gattr.typtr^.form <> scalar then error(144)
else
if comptypes(lattr.typtr,gattr.typtr) then
begin load;
if not comptypes(lattr.typtr,intptr) then
gen0t(58(*ord*),gattr.typtr);
align(intptr,lc);
gen2t(56(*str*),0,lc,intptr);
genlabel(laddr); putlabel(laddr);
gattr := lattr; load;
if not comptypes(gattr.typtr,intptr) then
gen0t(58(*ord*),gattr.typtr);
gen2t(54(*lod*),0,lc,intptr);
lc := lc + intsize;
if lc > lcmax then lcmax := lc;
if lsy = tosy then gen2(52(*leq*),ord('i'),1)
else gen2(48(*geq*),ord('i'),1);
end
else error(145)
end
else begin error(55); skip(fsys + [dosy]) end;
genlabel(lcix); genujpxjp(33(*fjp*),lcix);
if sy = dosy then insymbol else error(54);
statement(fsys);
gattr := lattr; load;
if lsy=tosy then gen1t(34(*inc*),1,gattr.typtr)
else gen1t(31(*dec*),1,gattr.typtr);
store(lattr); genujpxjp(57(*ujp*),laddr); putlabel(lcix);
lc := llc;
end (*forstatement*) ;
procedure withstatement;
var lcp: ctp; lcnt1: disprange; llc: addrrange;
begin lcnt1 := 0; llc := lc;
repeat
if sy = ident then
begin searchid([vars,field],lcp); insymbol end
else begin error(2); lcp := uvarptr end;
selector(fsys + [comma,dosy],lcp);
if gattr.typtr <> nil then
if gattr.typtr^.form = records then
if top < displimit then
begin top := top + 1; lcnt1 := lcnt1 + 1;
with display[top] do
begin fname := gattr.typtr^.fstfld;
flabel := nil
end;
if gattr.access = drct then
with display[top] do
begin occur := crec; clev := gattr.vlevel;
cdspl := gattr.dplmt
end
else
begin loadaddress;
align(nilptr,lc);
gen2t(56(*str*),0,lc,nilptr);
with display[top] do
begin occur := vrec; vdspl := lc end;
lc := lc+ptrsize;
if lc > lcmax then lcmax := lc
end
end
else error(250)
else error(140);
test := sy <> comma;
if not test then insymbol
until test;
if sy = dosy then insymbol else error(54);
statement(fsys);
top := top-lcnt1; lc := llc;
end (*withstatement*) ;
begin (*statement*)
if sy = intconst then (*label*)
begin llp := display[level].flabel;
while llp <> nil do
with llp^ do
if labval = val.ival then
begin if defined then error(165);
putlabel(labname); defined := true;
goto 1
end
else llp := nextlab;
error(167);
1: insymbol;
if sy = colon then insymbol else error(5)
end;
if not (sy in fsys + [ident]) then
begin error(6); skip(fsys) end;
if sy in statbegsys + [ident] then
begin
case sy of
ident: begin searchid([vars,field,func,proc],lcp); insymbol;
if lcp^.klass = proc then call(fsys,lcp)
else assignment(lcp)
end;
beginsy: begin insymbol; compoundstatement end;
gotosy: begin insymbol; gotostatement end;
ifsy: begin insymbol; ifstatement end;
casesy: begin insymbol; casestatement end;
whilesy: begin insymbol; whilestatement end;
repeatsy: begin insymbol; repeatstatement end;
forsy: begin insymbol; forstatement end;
withsy: begin insymbol; withstatement end
end;
if not (sy in [semicolon,endsy,elsesy,untilsy]) then
begin error(6); skip(fsys) end
end
end (*statement*) ;
begin (*body*)
if fprocp <> nil then entname := fprocp^.pfname
else genlabel(entname);
cstptrix := 0; topnew := lcaftermarkstack; topmax := lcaftermarkstack;
putlabel(entname); genlabel(segsize); genlabel(stacktop);
gencupent(32(*ent1*),1,segsize); gencupent(32(*ent2*),2,stacktop);
if fprocp <> nil then (*copy multiple values into local cells*)
begin llc1 := lcaftermarkstack;
lcp := fprocp^.next;
while lcp <> nil do
with lcp^ do
begin
align(parmptr,llc1);
if klass = vars then
if idtype <> nil then
if idtype^.form > power then
begin
if vkind = actual then
begin
gen2(50(*lda*),0,vaddr);
gen2t(54(*lod*),0,llc1,nilptr);
gen1(40(*mov*),idtype^.size);
end;
llc1 := llc1 + ptrsize
end
else llc1 := llc1 + idtype^.size;
lcp := lcp^.next;
end;
end;
lcmax := lc;
repeat
repeat statement(fsys + [semicolon,endsy])
until not (sy in statbegsys);
test := sy <> semicolon;
if not test then insymbol
until test;
if sy = endsy then insymbol else error(13);
llp := display[top].flabel; (*test for undefined labels*)
while llp <> nil do
with llp^ do
begin
if not defined then
begin error(168);
writeln(output); writeln(output,' label ',labval);
write(output,' ':chcnt+16)
end;
llp := nextlab
end;
if fprocp <> nil then
begin
if fprocp^.idtype = nil then gen1(42(*ret*),ord('p'))
else gen0t(42(*ret*),fprocp^.idtype);
align(parmptr,lcmax);
if prcode then
begin writeln(prr,'l',segsize:4,'=',lcmax);
writeln(prr,'l',stacktop:4,'=',topmax)
end
end
else
begin gen1(42(*ret*),ord('p'));
align(parmptr,lcmax);
if prcode then
begin writeln(prr,'l',segsize:4,'=',lcmax);
writeln(prr,'l',stacktop:4,'=',topmax);
writeln(prr,'q')
end;
ic := 0;
(*generate call of main program; note that this call must be loaded
at absolute address zero*)
gen1(41(*mst*),0); gencupent(46(*cup*),0,entname); gen0(29(*stp*));
if prcode then
writeln(prr,'q');
saveid := id;
while fextfilep <> nil do
begin
with fextfilep^ do
if not ((filename = 'input ') or (filename = 'output ') or
(filename = 'prd ') or (filename = 'prr '))
then begin id := filename;
searchid([vars],llcp);
if llcp^.idtype<>nil then
if llcp^.idtype^.form<>files then
begin writeln(output);
writeln(output,' ':8,'undeclared ','external ',
'file',fextfilep^.filename:8);
write(output,' ':chcnt+16)
end
end;
fextfilep := fextfilep^.nextfile
end;
id := saveid;
if prtables then
begin writeln(output); printtables(true)
end
end;
end (*body*) ;
begin (*block*)
dp := true;
repeat
if sy = labelsy then
begin insymbol; labeldeclaration end;
if sy = constsy then
begin insymbol; constdeclaration end;
if sy = typesy then
begin insymbol; typedeclaration end;
if sy = varsy then
begin insymbol; vardeclaration end;
while sy in [procsy,funcsy] do
begin lsy := sy; insymbol; procdeclaration(lsy) end;
if sy <> beginsy then
begin error(18); skip(fsys) end
until (sy in statbegsys) or eof(input);
dp := false;
if sy = beginsy then insymbol else error(17);
repeat body(fsys + [casesy]);
if sy <> fsy then
begin error(6); skip(fsys) end
until ((sy = fsy) or (sy in blockbegsys)) or eof(input);
end (*block*) ;
procedure programme(fsys:setofsys);
var extfp:extfilep;
begin
if sy = progsy then
begin insymbol; if sy <> ident then error(2); insymbol;
if not (sy in [lparent,semicolon]) then error(14);
if sy = lparent then
begin
repeat insymbol;
if sy = ident then
begin new(extfp);
with extfp^ do
begin filename := id; nextfile := fextfilep end;
fextfilep := extfp;
insymbol;
if not ( sy in [comma,rparent] ) then error(20)
end
else error(2)
until sy <> comma;
if sy <> rparent then error(4);
insymbol
end;
if sy <> semicolon then error(14)
else insymbol;
end;
repeat block(fsys,period,nil);
if sy <> period then error(21)
until (sy = period) or eof(input);
if list then writeln(output);
if errinx <> 0 then
begin list := false; endofline end
end (*programme*) ;
procedure stdnames;
begin
na[ 1] := 'false '; na[ 2] := 'true '; na[ 3] := 'input ';
na[ 4] := 'output '; na[ 5] := 'get '; na[ 6] := 'put ';
na[ 7] := 'reset '; na[ 8] := 'rewrite '; na[ 9] := 'read ';
na[10] := 'write '; na[11] := 'pack '; na[12] := 'unpack ';
na[13] := 'new '; na[14] := 'release '; na[15] := 'readln ';
na[16] := 'writeln ';
na[17] := 'abs '; na[18] := 'sqr '; na[19] := 'trunc ';
na[20] := 'odd '; na[21] := 'ord '; na[22] := 'chr ';
na[23] := 'pred '; na[24] := 'succ '; na[25] := 'eof ';
na[26] := 'eoln ';
na[27] := 'sin '; na[28] := 'cos '; na[29] := 'exp ';
na[30] := 'sqrt '; na[31] := 'ln '; na[32] := 'arctan ';
na[33] := 'prd '; na[34] := 'prr '; na[35] := 'mark ';
end (*stdnames*) ;
procedure enterstdtypes;
begin (*type underlying:*)
(******************)
new(intptr,scalar,standard); (*integer*)
with intptr^ do
begin size := intsize; form := scalar; scalkind := standard end;
new(realptr,scalar,standard); (*real*)
with realptr^ do
begin size := realsize; form := scalar; scalkind := standard end;
new(charptr,scalar,standard); (*char*)
with charptr^ do
begin size := charsize; form := scalar; scalkind := standard end;
new(boolptr,scalar,declared); (*boolean*)
with boolptr^ do
begin size := boolsize; form := scalar; scalkind := declared end;
new(nilptr,pointer); (*nil*)
with nilptr^ do
begin eltype := nil; size := ptrsize; form := pointer end;
new(parmptr,scalar,standard); (*for alignment of parameters*)
with parmptr^ do
begin size := parmsize; form := scalar; scalkind := standard end ;
new(textptr,files); (*text*)
with textptr^ do
begin filtype := charptr; size := charsize; form := files end
end (*enterstdtypes*) ;
procedure entstdnames;
var cp,cp1: ctp; i: integer;
begin (*name:*)
(*******)
new(cp,types); (*integer*)
with cp^ do
begin name := 'integer '; idtype := intptr; klass := types end;
enterid(cp);
new(cp,types); (*real*)
with cp^ do
begin name := 'real '; idtype := realptr; klass := types end;
enterid(cp);
new(cp,types); (*char*)
with cp^ do
begin name := 'char '; idtype := charptr; klass := types end;
enterid(cp);
new(cp,types); (*boolean*)
with cp^ do
begin name := 'boolean '; idtype := boolptr; klass := types end;
enterid(cp);
cp1 := nil;
for i := 1 to 2 do
begin new(cp,konst); (*false,true*)
with cp^ do
begin name := na[i]; idtype := boolptr;
next := cp1; values.ival := i – 1; klass := konst
end;
enterid(cp); cp1 := cp
end;
boolptr^.fconst := cp;
new(cp,konst); (*nil*)
with cp^ do
begin name := 'nil '; idtype := nilptr;
next := nil; values.ival := 0; klass := konst
end;
enterid(cp);
for i := 3 to 4 do
begin new(cp,vars); (*input,output*)
with cp^ do
begin name := na[i]; idtype := textptr; klass := vars;
vkind := actual; next := nil; vlev := 1;
vaddr := lcaftermarkstack+(i-3)*charmax;
end;
enterid(cp)
end;
for i:=33 to 34 do
begin new(cp,vars); (*prd,prr files*)
with cp^ do
begin name := na[i]; idtype := textptr; klass := vars;
vkind := actual; next := nil; vlev := 1;
vaddr := lcaftermarkstack+(i-31)*charmax;
end;
enterid(cp)
end;
for i := 5 to 16 do
begin new(cp,proc,standard); (*get,put,reset*)
with cp^ do (*rewrite,read*)
begin name := na[i]; idtype := nil; (*write,pack*)
next := nil; key := i – 4; (*unpack,pack*)
klass := proc; pfdeckind := standard
end;
enterid(cp)
end;
new(cp,proc,standard);
with cp^ do
begin name:=na[35]; idtype:=nil;
next:= nil; key:=13;
klass:=proc; pfdeckind:= standard
end; enterid(cp);
for i := 17 to 26 do
begin new(cp,func,standard); (*abs,sqr,trunc*)
with cp^ do (*odd,ord,chr*)
begin name := na[i]; idtype := nil; (*pred,succ,eof*)
next := nil; key := i – 16;
klass := func; pfdeckind := standard
end;
enterid(cp)
end;
new(cp,vars); (*parameter of predeclared functions*)
with cp^ do
begin name := ' '; idtype := realptr; klass := vars;
vkind := actual; next := nil; vlev := 1; vaddr := 0
end;
for i := 27 to 32 do
begin new(cp1,func,declared,actual); (*sin,cos,exp*)
with cp1^ do (*sqrt,ln,arctan*)
begin name := na[i]; idtype := realptr; next := cp;
forwdecl := false; externl := true; pflev := 0; pfname := i – 12;
klass := func; pfdeckind := declared; pfkind := actual
end;
enterid(cp1)
end
end (*entstdnames*) ;
procedure enterundecl;
begin
new(utypptr,types);
with utypptr^ do
begin name := ' '; idtype := nil; klass := types end;
new(ucstptr,konst);
with ucstptr^ do
begin name := ' '; idtype := nil; next := nil;
values.ival := 0; klass := konst
end;
new(uvarptr,vars);
with uvarptr^ do
begin name := ' '; idtype := nil; vkind := actual;
next := nil; vlev := 0; vaddr := 0; klass := vars
end;
new(ufldptr,field);
with ufldptr^ do
begin name := ' '; idtype := nil; next := nil; fldaddr := 0;
klass := field
end;
new(uprcptr,proc,declared,actual);
with uprcptr^ do
begin name := ' '; idtype := nil; forwdecl := false;
next := nil; externl := false; pflev := 0; genlabel(pfname);
klass := proc; pfdeckind := declared; pfkind := actual
end;
new(ufctptr,func,declared,actual);
with ufctptr^ do
begin name := ' '; idtype := nil; next := nil;
forwdecl := false; externl := false; pflev := 0; genlabel(pfname);
klass := func; pfdeckind := declared; pfkind := actual
end
end (*enterundecl*) ;
procedure initscalars;
begin fwptr := nil;
prtables := false; list := true; prcode := true; debug := true;
dp := true; prterr := true; errinx := 0;
intlabel := 0; kk := 8; fextfilep := nil;
lc := lcaftermarkstack+filebuffer*charmax;
(* note in the above reservation of buffer store for 2 text files *)
ic := 3; eol := true; linecount := 0;
ch := ' '; chcnt := 0;
globtestp := nil;
mxint10 := maxint div 10; digmax := strglgth – 1;
end (*initscalars*) ;
procedure initsets;
begin
constbegsys := [addop,intconst,realconst,stringconst,ident];
simptypebegsys := [lparent] + constbegsys;
typebegsys:=[arrow,packedsy,arraysy,recordsy,setsy,filesy]+simptypebegsys;
typedels := [arraysy,recordsy,setsy,filesy];
blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy];
selectsys := [arrow,period,lbrack];
facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy];
statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy];
end (*initsets*) ;
procedure inittables;
procedure reswords;
begin
rw[ 1] := 'if '; rw[ 2] := 'do '; rw[ 3] := 'of ';
rw[ 4] := 'to '; rw[ 5] := 'in '; rw[ 6] := 'or ';
rw[ 7] := 'end '; rw[ 8] := 'for '; rw[ 9] := 'var ';
rw[10] := 'div '; rw[11] := 'mod '; rw[12] := 'set ';
rw[13] := 'and '; rw[14] := 'not '; rw[15] := 'then ';
rw[16] := 'else '; rw[17] := 'with '; rw[18] := 'goto ';
rw[19] := 'case '; rw[20] := 'type ';
rw[21] := 'file '; rw[22] := 'begin ';
rw[23] := 'until '; rw[24] := 'while '; rw[25] := 'array ';
rw[26] := 'const '; rw[27] := 'label ';
rw[28] := 'repeat '; rw[29] := 'record '; rw[30] := 'downto ';
rw[31] := 'packed '; rw[32] := 'forward '; rw[33] := 'program ';
rw[34] := 'function'; rw[35] := 'procedur';
frw[1] := 1; frw[2] := 1; frw[3] := 7; frw[4] := 15; frw[5] := 22;
frw[6] := 28; frw[7] := 32; frw[8] := 34; frw[9] := 36;
end (*reswords*) ;
procedure symbols;
begin
rsy[ 1] := ifsy; rsy[ 2] := dosy; rsy[ 3] := ofsy;
rsy[ 4] := tosy; rsy[ 5] := relop; rsy[ 6] := addop;
rsy[ 7] := endsy; rsy[ 8] := forsy; rsy[ 9] := varsy;
rsy[10] := mulop; rsy[11] := mulop; rsy[12] := setsy;
rsy[13] := mulop; rsy[14] := notsy; rsy[15] := thensy;
rsy[16] := elsesy; rsy[17] := withsy; rsy[18] := gotosy;
rsy[19] := casesy; rsy[20] := typesy;
rsy[21] := filesy; rsy[22] := beginsy;
rsy[23] := untilsy; rsy[24] := whilesy; rsy[25] := arraysy;
rsy[26] := constsy; rsy[27] := labelsy;
rsy[28] := repeatsy; rsy[29] := recordsy; rsy[30] := downtosy;
rsy[31] := packedsy; rsy[32] := forwardsy; rsy[33] := progsy;
rsy[34] := funcsy; rsy[35] := procsy;
ssy['+'] := addop ; ssy['-'] := addop; ssy['*'] := mulop;
ssy['/'] := mulop ; ssy['('] := lparent; ssy[')'] := rparent;
ssy['$'] := othersy ; ssy['='] := relop; ssy[' '] := othersy;
ssy[','] := comma ; ssy['.'] := period; ssy['''']:= othersy;
ssy['['] := lbrack ; ssy[']'] := rbrack; ssy[':'] := colon;
ssy['^'] := arrow ; ssy['<'] := relop; ssy['>'] := relop;
ssy[';'] := semicolon;
end (*symbols*) ;
procedure rators;
var i: integer;
begin
for i := 1 to 35 (*nr of res words*) do rop[i] := noop;
rop[5] := inop; rop[10] := idiv; rop[11] := imod;
rop[6] := orop; rop[13] := andop;
for i := ordminchar to ordmaxchar do sop[chr(i)] := noop;
sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
sop['='] := eqop; sop['<'] := ltop; sop['>'] := gtop;
end (*rators*) ;
procedure procmnemonics;
begin
sna[ 1] :=' get'; sna[ 2] :=' put'; sna[ 3] :=' rdi'; sna[ 4] :=' rdr';
sna[ 5] :=' rdc'; sna[ 6] :=' wri'; sna[ 7] :=' wro'; sna[ 8] :=' wrr';
sna[ 9] :=' wrc'; sna[10] :=' wrs'; sna[11] :=' pak'; sna[12] :=' new';
sna[13] :=' rst'; sna[14] :=' eln'; sna[15] :=' sin'; sna[16] :=' cos';
sna[17] :=' exp'; sna[18] :=' sqt'; sna[19] :=' log'; sna[20] :=' atn';
sna[21] :=' rln'; sna[22] :=' wln'; sna[23] :=' sav';
end (*procmnemonics*) ;
procedure instrmnemonics;
begin
mn[ 0] :=' abi'; mn[ 1] :=' abr'; mn[ 2] :=' adi'; mn[ 3] :=' adr';
mn[ 4] :=' and'; mn[ 5] :=' dif'; mn[ 6] :=' dvi'; mn[ 7] :=' dvr';
mn[ 8] :=' eof'; mn[ 9] :=' flo'; mn[10] :=' flt'; mn[11] :=' inn';
mn[12] :=' int'; mn[13] :=' ior'; mn[14] :=' mod'; mn[15] :=' mpi';
mn[16] :=' mpr'; mn[17] :=' ngi'; mn[18] :=' ngr'; mn[19] :=' not';
mn[20] :=' odd'; mn[21] :=' sbi'; mn[22] :=' sbr'; mn[23] :=' sgs';
mn[24] :=' sqi'; mn[25] :=' sqr'; mn[26] :=' sto'; mn[27] :=' trc';
mn[28] :=' uni'; mn[29] :=' stp'; mn[30] :=' csp'; mn[31] :=' dec';
mn[32] :=' ent'; mn[33] :=' fjp'; mn[34] :=' inc'; mn[35] :=' ind';
mn[36] :=' ixa'; mn[37] :=' lao'; mn[38] :=' lca'; mn[39] :=' ldo';
mn[40] :=' mov'; mn[41] :=' mst'; mn[42] :=' ret'; mn[43] :=' sro';
mn[44] :=' xjp'; mn[45] :=' chk'; mn[46] :=' cup'; mn[47] :=' equ';
mn[48] :=' geq'; mn[49] :=' grt'; mn[50] :=' lda'; mn[51] :=' ldc';
mn[52] :=' leq'; mn[53] :=' les'; mn[54] :=' lod'; mn[55] :=' neq';
mn[56] :=' str'; mn[57] :=' ujp'; mn[58] :=' ord'; mn[59] :=' chr';
mn[60] :=' ujc';
end (*instrmnemonics*) ;
procedure chartypes;
var i : integer;
begin
for i := ordminchar to ordmaxchar do chartp[chr(i)] := illegal;
chartp['a'] := letter ;
chartp['b'] := letter ; chartp['c'] := letter ;
chartp['d'] := letter ; chartp['e'] := letter ;
chartp['f'] := letter ; chartp['g'] := letter ;
chartp['h'] := letter ; chartp['i'] := letter ;
chartp['j'] := letter ; chartp['k'] := letter ;
chartp['l'] := letter ; chartp['m'] := letter ;
chartp['n'] := letter ; chartp['o'] := letter ;
chartp['p'] := letter ; chartp['q'] := letter ;
chartp['r'] := letter ; chartp['s'] := letter ;
chartp['t'] := letter ; chartp['u'] := letter ;
chartp['v'] := letter ; chartp['w'] := letter ;
chartp['x'] := letter ; chartp['y'] := letter ;
chartp['z'] := letter ; chartp['0'] := number ;
chartp['1'] := number ; chartp['2'] := number ;
chartp['3'] := number ; chartp['4'] := number ;
chartp['5'] := number ; chartp['6'] := number ;
chartp['7'] := number ; chartp['8'] := number ;
chartp['9'] := number ; chartp['+'] := special ;
chartp['-'] := special ; chartp['*'] := special ;
chartp['/'] := special ; chartp['('] := chlparen;
chartp[')'] := special ; chartp['$'] := special ;
chartp['='] := special ; chartp[' '] := chspace ;
chartp[','] := special ; chartp['.'] := chperiod;
chartp['''']:= chstrquo; chartp['['] := special ;
chartp[']'] := special ; chartp[':'] := chcolon ;
chartp['^'] := special ; chartp[';'] := special ;
chartp['<'] := chlt ; chartp['>'] := chgt ;
ordint['0'] := 0; ordint['1'] := 1; ordint['2'] := 2;
ordint['3'] := 3; ordint['4'] := 4; ordint['5'] := 5;
ordint['6'] := 6; ordint['7'] := 7; ordint['8'] := 8;
ordint['9'] := 9;
end;
procedure initdx;
begin
cdx[ 0] := 0; cdx[ 1] := 0; cdx[ 2] := -1; cdx[ 3] := -1;
cdx[ 4] := -1; cdx[ 5] := -1; cdx[ 6] := -1; cdx[ 7] := -1;
cdx[ 8] := 0; cdx[ 9] := 0; cdx[10] := 0; cdx[11] := -1;
cdx[12] := -1; cdx[13] := -1; cdx[14] := -1; cdx[15] := -1;
cdx[16] := -1; cdx[17] := 0; cdx[18] := 0; cdx[19] := 0;
cdx[20] := 0; cdx[21] := -1; cdx[22] := -1; cdx[23] := 0;
cdx[24] := 0; cdx[25] := 0; cdx[26] := -2; cdx[27] := 0;
cdx[28] := -1; cdx[29] := 0; cdx[30] := 0; cdx[31] := 0;
cdx[32] := 0; cdx[33] := -1; cdx[34] := 0; cdx[35] := 0;
cdx[36] := -1; cdx[37] := +1; cdx[38] := +1; cdx[39] := +1;
cdx[40] := -2; cdx[41] := 0; cdx[42] := 0; cdx[43] := -1;
cdx[44] := -1; cdx[45] := 0; cdx[46] := 0; cdx[47] := -1;
cdx[48] := -1; cdx[49] := -1; cdx[50] := +1; cdx[51] := +1;
cdx[52] := -1; cdx[53] := -1; cdx[54] := +1; cdx[55] := -1;
cdx[56] := -1; cdx[57] := 0; cdx[58] := 0; cdx[59] := 0;
cdx[60] := 0;
pdx[ 1] := -1; pdx[ 2] := -1; pdx[ 3] := -2; pdx[ 4] := -2;
pdx[ 5] := -2; pdx[ 6] := -3; pdx[ 7] := -3; pdx[ 8] := -3;
pdx[ 9] := -3; pdx[10] := -4; pdx[11] := 0; pdx[12] := -2;
pdx[13] := -1; pdx[14] := 0; pdx[15] := 0; pdx[16] := 0;
pdx[17] := 0; pdx[18] := 0; pdx[19] := 0; pdx[20] := 0;
pdx[21] := -1; pdx[22] := -1; pdx[23] := -1;
end;
begin (*inittables*)
reswords; symbols; rators;
instrmnemonics; procmnemonics;
chartypes; initdx;
end (*inittables*) ;
begin
(*initialize*)
(************)
initscalars; initsets; inittables;
(*enter standard names and standard types:*)
(******************************************)
level := 0; top := 0;
with display[0] do
begin fname := nil; flabel := nil; occur := blck end;
enterstdtypes; stdnames; entstdnames; enterundecl;
top := 1; level := 1;
with display[1] do
begin fname := nil; flabel := nil; occur := blck end;
(*compile:*) rewrite(prr); (*comment this out when compiling with pcom *)
(**********)
insymbol;
programme(blockbegsys+statbegsys-[casesy]);
end.

view raw

pcom.p

hosted with ❤ by GitHub


/* Output from p2c, the Pascal-to-C translator */
/* From input file "pint.p" */
/* P2c options:
Language BERK
StructFiles 1 */
/* P2c produced macro calls "BUFEOF(stdin)",
which were edited to "P_eof(stdin)" */
/* Translation and editing done by I.J.A. van Geel
e-mail: I.J.A.vanGeel@twi.tudelft.nl */
/* Date: august 22 1996 */
/*Assembler and interpreter of Pascal code*/
/*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*/
#include "p2c.h"
#include <math.h>
/* Note for the implementation.
===========================
This interpreter is written for the case where all the fundamental types
take one storage unit.
In an actual implementation, the handling of the sp pointer has to take
into account the fact that the types may have lengths different from one:
in push and pop operations the sp has to be increased and decreased not
by 1, but by a number depending on the type concerned.
However, where the number of units of storage has been computed by the
compiler, the value must not be corrected, since the lengths of the types
involved have already been taken into account.
*/
#define codemax 8650
#define pcmax 17500
#define maxstk 13650 /* size of variable store */
#define overi 13655 /* size of integer constant table = 5 */
#define overr 13660 /* size of real constant table = 5 */
#define overs 13730 /* size of set constant table = 70 */
#define overb 13820
#define overm 18000
#define maxstr 18001
#define largeint 26144
#define begincode 3
#define inputadr 5
#define outputadr 6
#define prdadr 7
#define prradr 8
#define duminst 62
typedef char bit4;
typedef char bit6;
typedef short bit20;
typedef enum {
undef, int_, reel, bool, sett, adr, mark_, car
} datatype;
typedef short address;
typedef Char beta[25]; /*error message*/
typedef long settype[3];
typedef Char alfa_[10];
typedef struct _REC_code {
/* the program */
unsigned op1 : 7, p1 : 4;
signed int q1 : 16;
unsigned op2 : 7, p2 : 4;
short q2;
} _REC_code;
typedef union _REC_store {
long vi;
double vr;
boolean vb;
settype vs;
Char vc;
address va;
/*address in store*/
long vm;
} _REC_store;
Static _REC_code code[codemax + 1];
Static short pc; /*program address register*/
Static bit6 op;
Static bit4 p;
Static bit20 q; /*instruction register*/
Static _REC_store store[overm + 1];
Static address mp, sp, np, ep; /* address registers */
/*mp points to beginning of a data segment
sp points to top of the stack
ep points to the maximum extent of the stack
np points to top of the dynamically allocated area*/
Static boolean interpreting;
Static _TEXT prd, prr; /*prd for read only, prr for write only */
Static alfa_ instr[128]; /* mnemonic instruction codes */
Static long cop[128];
Static alfa_ sptable[21]; /*standard functions and procedures*/
/*locally used for interpreting one instruction*/
Static address ad;
Static boolean b;
Static long i, i1, i2;
#define maxlabel 1850
typedef enum {
entered, defined_
} labelst; /*label situation*/
typedef short labelrg;
/*label range*/
typedef struct labelrec {
address val;
labelst st;
} labelrec;
/* Local variables for load: */
struct LOC_load {
address icp, rcp, scp, bcp, mcp; /*pointers to next free position*/
Char word[10];
Char ch;
labelrec labeltab[maxlabel + 1];
address labelvalue;
} ;
Local void assemble(struct LOC_load *LINK);
Local void init(struct LOC_load *LINK)
{
long i;
labelrec *WITH;
memcpy(instr[0], "lod ", sizeof(alfa_));
memcpy(instr[1], "ldo ", sizeof(alfa_));
memcpy(instr[2], "str ", sizeof(alfa_));
memcpy(instr[3], "sro ", sizeof(alfa_));
memcpy(instr[4], "lda ", sizeof(alfa_));
memcpy(instr[5], "lao ", sizeof(alfa_));
memcpy(instr[6], "sto ", sizeof(alfa_));
memcpy(instr[7], "ldc ", sizeof(alfa_));
memcpy(instr[8], "… ", sizeof(alfa_));
memcpy(instr[9], "ind ", sizeof(alfa_));
memcpy(instr[10], "inc ", sizeof(alfa_));
memcpy(instr[11], "mst ", sizeof(alfa_));
memcpy(instr[12], "cup ", sizeof(alfa_));
memcpy(instr[13], "ent ", sizeof(alfa_));
memcpy(instr[14], "ret ", sizeof(alfa_));
memcpy(instr[15], "csp ", sizeof(alfa_));
memcpy(instr[16], "ixa ", sizeof(alfa_));
memcpy(instr[17], "equ ", sizeof(alfa_));
memcpy(instr[18], "neq ", sizeof(alfa_));
memcpy(instr[19], "geq ", sizeof(alfa_));
memcpy(instr[20], "grt ", sizeof(alfa_));
memcpy(instr[21], "leq ", sizeof(alfa_));
memcpy(instr[22], "les ", sizeof(alfa_));
memcpy(instr[23], "ujp ", sizeof(alfa_));
memcpy(instr[24], "fjp ", sizeof(alfa_));
memcpy(instr[25], "xjp ", sizeof(alfa_));
memcpy(instr[26], "chk ", sizeof(alfa_));
memcpy(instr[27], "eof ", sizeof(alfa_));
memcpy(instr[28], "adi ", sizeof(alfa_));
memcpy(instr[29], "adr ", sizeof(alfa_));
memcpy(instr[30], "sbi ", sizeof(alfa_));
memcpy(instr[31], "sbr ", sizeof(alfa_));
memcpy(instr[32], "sgs ", sizeof(alfa_));
memcpy(instr[33], "flt ", sizeof(alfa_));
memcpy(instr[34], "flo ", sizeof(alfa_));
memcpy(instr[35], "trc ", sizeof(alfa_));
memcpy(instr[36], "ngi ", sizeof(alfa_));
memcpy(instr[37], "ngr ", sizeof(alfa_));
memcpy(instr[38], "sqi ", sizeof(alfa_));
memcpy(instr[39], "sqr ", sizeof(alfa_));
memcpy(instr[40], "abi ", sizeof(alfa_));
memcpy(instr[41], "abr ", sizeof(alfa_));
memcpy(instr[42], "not ", sizeof(alfa_));
memcpy(instr[43], "and ", sizeof(alfa_));
memcpy(instr[44], "ior ", sizeof(alfa_));
memcpy(instr[45], "dif ", sizeof(alfa_));
memcpy(instr[46], "int ", sizeof(alfa_));
memcpy(instr[47], "uni ", sizeof(alfa_));
memcpy(instr[48], "inn ", sizeof(alfa_));
memcpy(instr[49], "mod ", sizeof(alfa_));
memcpy(instr[50], "odd ", sizeof(alfa_));
memcpy(instr[51], "mpi ", sizeof(alfa_));
memcpy(instr[52], "mpr ", sizeof(alfa_));
memcpy(instr[53], "dvi ", sizeof(alfa_));
memcpy(instr[54], "dvr ", sizeof(alfa_));
memcpy(instr[55], "mov ", sizeof(alfa_));
memcpy(instr[56], "lca ", sizeof(alfa_));
memcpy(instr[57], "dec ", sizeof(alfa_));
memcpy(instr[58], "stp ", sizeof(alfa_));
memcpy(instr[59], "ord ", sizeof(alfa_));
memcpy(instr[60], "chr ", sizeof(alfa_));
memcpy(instr[61], "ujc ", sizeof(alfa_));
memcpy(sptable[0], "get ", sizeof(alfa_));
memcpy(sptable[1], "put ", sizeof(alfa_));
memcpy(sptable[2], "rst ", sizeof(alfa_));
memcpy(sptable[3], "rln ", sizeof(alfa_));
memcpy(sptable[4], "new ", sizeof(alfa_));
memcpy(sptable[5], "wln ", sizeof(alfa_));
memcpy(sptable[6], "wrs ", sizeof(alfa_));
memcpy(sptable[7], "eln ", sizeof(alfa_));
memcpy(sptable[8], "wri ", sizeof(alfa_));
memcpy(sptable[9], "wrr ", sizeof(alfa_));
memcpy(sptable[10], "wrc ", sizeof(alfa_));
memcpy(sptable[11], "rdi ", sizeof(alfa_));
memcpy(sptable[12], "rdr ", sizeof(alfa_));
memcpy(sptable[13], "rdc ", sizeof(alfa_));
memcpy(sptable[14], "sin ", sizeof(alfa_));
memcpy(sptable[15], "cos ", sizeof(alfa_));
memcpy(sptable[16], "exp ", sizeof(alfa_));
memcpy(sptable[17], "log ", sizeof(alfa_));
memcpy(sptable[18], "sqt ", sizeof(alfa_));
memcpy(sptable[19], "atn ", sizeof(alfa_));
memcpy(sptable[20], "sav ", sizeof(alfa_));
cop[0] = 105;
cop[1] = 65;
cop[2] = 70;
cop[3] = 75;
cop[6] = 80;
cop[9] = 85;
cop[10] = 90;
cop[26] = 95;
cop[57] = 100;
pc = begincode;
LINK->icp = maxstk + 1;
LINK->rcp = overi + 1;
LINK->scp = overr + 1;
LINK->bcp = overs + 2;
LINK->mcp = overb + 1;
for (i = 0; i <= 9; i++)
LINK->word[i] = ' ';
for (i = 0; i <= maxlabel; i++) {
WITH = &LINK->labeltab[i];
WITH->val = -1;
WITH->st = entered;
}
if (*prd.name != '\0') {
if (prd.f != NULL)
prd.f = freopen(prd.name, "r", prd.f);
else
prd.f = fopen(prd.name, "r");
} else
rewind(prd.f);
if (prd.f == NULL)
_EscIO(FileNotFound);
RESETBUF(prd.f, Char);
} /*init*/
Local void errorl(Char *string, struct LOC_load *LINK)
{
/*error in loading*/
printf("\n%.25s", string);
_Escape(0);
} /*errorl*/
Local void update(labelrg x, struct LOC_load *LINK)
{
/*when a label definition lx is found*/
short curr, succ;
/*resp. current element and successor element
of a list of future references*/
boolean endlist;
_REC_code *WITH;
if (LINK->labeltab[x].st == defined_) {
errorl(" duplicated label\t ", LINK);
return;
}
if (LINK->labeltab[x].val != -1) { /*forward reference(s)*/
curr = LINK->labeltab[x].val;
endlist = false;
while (!endlist) {
WITH = &code[curr / 2];
if (curr & 1) {
succ = WITH->q2;
WITH->q2 = LINK->labelvalue;
} else {
succ = WITH->q1;
WITH->q1 = LINK->labelvalue;
}
if (succ == -1)
endlist = true;
else
curr = succ;
}
}
LINK->labeltab[x].st = defined_;
LINK->labeltab[x].val = LINK->labelvalue;
} /*update*/
Local void generate(struct LOC_load *LINK)
{
/*generate segment of code*/
long x; /* label number */
boolean again;
again = true;
while (again) {
LINK->ch = getc(prd.f); /* first character of line*/
if (LINK->ch == '\n')
LINK->ch = ' ';
switch (LINK->ch) {
case 'i':
fscanf(prd.f, "%*[^\n]");
getc(prd.f);
break;
case 'l':
fscanf(prd.f, "%ld", &x);
if (!P_eoln(prd.f)) {
LINK->ch = getc(prd.f);
if (LINK->ch == '\n')
LINK->ch = ' ';
}
if (LINK->ch == '=')
fscanf(prd.f, "%hd", &LINK->labelvalue);
else
LINK->labelvalue = pc;
update(x, LINK);
fscanf(prd.f, "%*[^\n]");
getc(prd.f);
break;
case 'q':
again = false;
fscanf(prd.f, "%*[^\n]");
getc(prd.f);
break;
case ' ':
LINK->ch = getc(prd.f);
if (LINK->ch == '\n')
LINK->ch = ' ';
assemble(LINK);
break;
}
}
} /*generate*/
/* Local variables for assemble: */
struct LOC_assemble {
struct LOC_load *LINK;
/*goto 1 for instructions without code generation*/
alfa_ name;
} ;
Local void lookup(labelrg x, struct LOC_assemble *LINK)
{
/* search in label table*/
switch (LINK->LINK->labeltab[x].st) {
case entered:
q = LINK->LINK->labeltab[x].val;
LINK->LINK->labeltab[x].val = pc;
break;
case defined_:
q = LINK->LINK->labeltab[x].val;
break;
}/*case label..*/
} /*lookup*/
Local void labelsearch(struct LOC_assemble *LINK)
{
labelrg x;
while ((LINK->LINK->ch != 'l') & (!P_eoln(prd.f))) {
LINK->LINK->ch = getc(prd.f);
if (LINK->LINK->ch == '\n')
LINK->LINK->ch = ' ';
}
fscanf(prd.f, "%hd", &x);
lookup(x, LINK);
} /*labelsearch*/
Local void getname(struct LOC_assemble *LINK)
{
LINK->LINK->word[0] = LINK->LINK->ch;
LINK->LINK->word[1] = getc(prd.f);
LINK->LINK->word[2] = getc(prd.f);
if (LINK->LINK->word[1] == '\n')
LINK->LINK->word[1] = ' ';
if (LINK->LINK->word[2] == '\n')
LINK->LINK->word[2] = ' ';
if (!P_eoln(prd.f)) {
LINK->LINK->ch = getc(prd.f); /*next character*/
if (LINK->LINK->ch == '\n')
LINK->LINK->ch = ' ';
}
memcpy(LINK->name, LINK->LINK->word, sizeof(alfa_));
} /*getname*/
Local void typesymbol(struct LOC_assemble *LINK)
{
long i;
/*typesymbol*/
if (LINK->LINK->ch == 'i')
return;
switch (LINK->LINK->ch) {
case 'a':
i = 0;
break;
case 'r':
i = 1;
break;
case 's':
i = 2;
break;
case 'b':
i = 3;
break;
case 'c':
i = 4;
break;
}
op = cop[op] + i;
}
Local void assemble(struct LOC_load *LINK)
{
/*translate symbolic code into machine code and store*/
struct LOC_assemble V;
double r;
settype s;
long i, s1, lb, ub;
int TEMP;
_REC_code *WITH;
V.LINK = LINK;
p = 0;
q = 0;
op = 0;
getname(&V);
memcpy(instr[duminst], V.name, sizeof(alfa_));
while (strncmp(instr[op], V.name, sizeof(alfa_)))
op++;
if (op == duminst)
errorl(" illegal instruction ", LINK);
switch (op) { /* get parameters p,q */
/*equ,neq,geq,grt,leq,les*/
case 17:
case 18:
case 19:
case 20:
case 21:
case 22:
switch (LINK->ch) {
case 'a': /*p = 0*/
break;
case 'i':
p = 1;
break;
case 'r':
p = 2;
break;
case 'b':
p = 3;
break;
case 's':
p = 4;
break;
case 'c':
p = 6;
break;
case 'm':
p = 5;
fscanf(prd.f, "%hd", &q);
break;
}
break;
/*lod,str*/
case 0:
case 2:
typesymbol(&V);
fscanf(prd.f, "%d%hd", &TEMP, &q);
p = TEMP;
break;
case 4: /*lda*/
fscanf(prd.f, "%d%hd", &TEMP, &q);
p = TEMP;
break;
case 12: /*cup*/
fscanf(prd.f, "%d", &TEMP);
p = TEMP;
labelsearch(&V);
break;
case 11: /*mst*/
fscanf(prd.f, "%d", &TEMP);
p = TEMP;
break;
case 14: /*ret*/
switch (LINK->ch) {
case 'p':
p = 0;
break;
case 'i':
p = 1;
break;
case 'r':
p = 2;
break;
case 'c':
p = 3;
break;
case 'b':
p = 4;
break;
case 'a':
p = 5;
break;
}
break;
/*lao,ixa,mov*/
case 5:
case 16:
case 55:
fscanf(prd.f, "%hd", &q);
break;
/*ldo,sro,ind,inc,dec*/
case 1:
case 3:
case 9:
case 10:
case 57:
typesymbol(&V);
fscanf(prd.f, "%hd", &q);
break;
/*ujp,fjp,xjp*/
case 23:
case 24:
case 25:
labelsearch(&V);
break;
case 13: /*ent*/
fscanf(prd.f, "%d", &TEMP);
p = TEMP;
labelsearch(&V);
break;
case 15: /*csp*/
for (i = 1; i <= 9; i++) {
LINK->ch = getc(prd.f);
if (LINK->ch == '\n')
LINK->ch = ' ';
}
getname(&V);
while (strncmp(V.name, sptable[q], sizeof(alfa_)))
q++;
break;
case 7: /*ldc*/
switch (LINK->ch) { /*get q*/
case 'i':
p = 1;
fscanf(prd.f, "%ld", &i);
if (labs(i) >= largeint) {
op = 8;
store[LINK->icp].vi = i;
q = maxstk;
do {
q++;
} while (store[q].vi != i);
if (q == LINK->icp) {
LINK->icp++;
if (LINK->icp == overi)
errorl(" integer table overflow ", LINK);
}
} else
q = i;
break;
case 'r':
op = 8;
p = 2;
fscanf(prd.f, "%lg", &r);
store[LINK->rcp].vr = r;
q = overi;
do {
q++;
} while (store[q].vr != r);
if (q == LINK->rcp) {
LINK->rcp++;
if (LINK->rcp == overr)
errorl(" real table overflow ", LINK);
}
break;
case 'n': /*p,q = 0*/
break;
case 'b':
p = 3;
fscanf(prd.f, "%hd", &q);
break;
case 'c':
p = 6;
do {
LINK->ch = getc(prd.f);
if (LINK->ch == '\n')
LINK->ch = ' ';
} while (LINK->ch == ' ');
if (LINK->ch != '\'')
errorl(" illegal character ", LINK);
LINK->ch = getc(prd.f);
if (LINK->ch == '\n')
LINK->ch = ' ';
q = LINK->ch;
LINK->ch = getc(prd.f);
if (LINK->ch == '\n')
LINK->ch = ' ';
if (LINK->ch != '\'')
errorl(" illegal character ", LINK);
break;
case '(':
op = 8;
p = 4;
P_expset(s, 0);
LINK->ch = getc(prd.f);
if (LINK->ch == '\n')
LINK->ch = ' ';
while (LINK->ch != ')') {
fscanf(prd.f, "%ld%c", &s1, &LINK->ch);
if (LINK->ch == '\n')
LINK->ch = ' ';
P_addset(s, s1);
}
P_setcpy(store[LINK->scp].vs, s);
q = overr;
do {
q++;
} while (!P_setequal(store[q].vs, s));
if (q == LINK->scp) {
LINK->scp++;
if (LINK->scp == overs)
errorl(" set table overflow ", LINK);
}
break;
}/*case*/
break;
case 26: /*chk*/
typesymbol(&V);
fscanf(prd.f, "%ld%ld", &lb, &ub);
if (op == 95)
q = lb;
else {
store[LINK->bcp – 1].vi = lb;
store[LINK->bcp].vi = ub;
q = overs;
do {
q += 2;
} while (store[q – 1].vi != lb || store[q].vi != ub);
if (q == LINK->bcp) {
LINK->bcp += 2;
if (LINK->bcp == overb)
errorl(" boundary table overflow ", LINK);
}
}
break;
case 56: /*lca*/
if (LINK->mcp + 16 >= overm)
errorl(" multiple table overflow ", LINK);
LINK->mcp += 16;
q = LINK->mcp;
for (i = 0; i <= 15; i++) { /*stringlgth*/
LINK->ch = getc(prd.f);
if (LINK->ch == '\n')
LINK->ch = ' ';
store[q + i].vc = LINK->ch;
}
break;
case 6: /*sto*/
typesymbol(&V);
break;
case 27:
case 28:
case 29:
case 30:
case 31:
case 32:
case 33:
case 34:
case 35:
case 36:
case 37:
case 38:
case 39:
case 40:
case 41:
case 42:
case 43:
case 44:
case 45:
case 46:
case 47:
case 48:
case 49:
case 50:
case 51:
case 52:
case 53:
case 54:
case 58:
break;
/*ord,chr*/
case 59:
case 60:
goto _L1;
break;
case 61: /*ujc*/
break;
/*must have same length as ujp*/
}/*case*/
WITH = &code[pc / 2];
/* store instruction */
if (pc & 1) {
WITH->op2 = op;
WITH->p2 = p;
WITH->q2 = q;
} else {
WITH->op1 = op;
WITH->p1 = p;
WITH->q1 = q;
}
pc++;
_L1:
fscanf(prd.f, "%*[^\n]");
getc(prd.f);
} /*assemble*/
/*——————————————————————–*/
Static void load(void)
{
struct LOC_load V;
init(&V);
generate(&V);
pc = 0;
generate(&V);
} /*load*/
#undef maxlabel
/* Local variables for pmd: */
struct LOC_pmd {
long s, i;
} ;
Local void pt(struct LOC_pmd *LINK)
{
printf("%6ld", LINK->s);
if (labs(store[LINK->s].vi) < LONG_MAX)
printf("%12ld", store[LINK->s].vi);
else
printf("too big ");
LINK->s–;
LINK->i++;
if (LINK->i == 4) {
putchar('\n');
LINK->i = 0;
}
} /*pt*/
/*————————————————————————*/
Static void pmd(void)
{
struct LOC_pmd V;
printf(" pc =%5d op =%3d sp =%5d mp =%5d np =%5d\n",
pc – 1, op, sp, mp, np);
printf("————————————–\n");
V.s = sp;
V.i = 0;
while (V.s >= 0)
pt(&V);
V.s = maxstk;
while (V.s >= np)
pt(&V);
} /*pmd*/
Static jmp_buf _JL1;
Static void errori(Char *string)
{
printf("\n%.25s\n", string);
pmd();
longjmp(_JL1, 1);
} /*errori*/
Static address base(long ld)
{
address ad;
ad = mp;
while (ld > 0) {
ad = store[ad + 1].vm;
ld–;
}
return ad;
} /*base*/
Static void compare(void)
{
/*comparing is only correct if result by comparing integers will be*/
i1 = store[sp].va;
i2 = store[sp + 1].va;
i = 0;
b = true;
while (b && i != q) {
if (store[i1 + i].vi == store[i2 + i].vi)
i++;
else
b = false;
}
} /*compare*/
Local void readi(_TEXT *f)
{
address ad;
ad = store[sp – 1].va;
fscanf(f->f, "%ld", &store[ad].vi);
store[store[sp].va].vc = P_peek(f->f);
sp -= 2;
} /*readi*/
Local void readr(_TEXT *f)
{
address ad;
ad = store[sp – 1].va;
fscanf(f->f, "%lg", &store[ad].vr);
store[store[sp].va].vc = P_peek(f->f);
sp -= 2;
} /*readr*/
Local void readc(_TEXT *f)
{
Char c;
address ad;
c = getc(f->f);
if (c == '\n')
c = ' ';
ad = store[sp – 1].va;
store[ad].vc = c;
store[store[sp].va].vc = P_peek(f->f);
store[store[sp].va].vi = P_peek(f->f);
sp -= 2;
} /*readc*/
Local void writestr(_TEXT *f)
{
long i, j, k;
address ad;
long FORLIM;
ad = store[sp – 3].va;
k = store[sp – 2].vi;
j = store[sp – 1].vi;
/* j and k are numbers of characters */
if (k > j) {
FORLIM = k – j;
for (i = 1; i <= FORLIM; i++)
putc(' ', f->f);
} else
j = k;
for (i = 0; i < j; i++)
putc(store[ad + i].vc, f->f);
sp -= 4;
} /*writestr*/
Local void getfile(_TEXT *f)
{
address ad;
ad = store[sp].va;
getc(f->f);
store[ad].vc = P_peek(f->f);
sp–;
} /*getfile*/
Local void putfile(_TEXT *f)
{
address ad;
ad = store[sp].va;
putc(store[ad].vc, f->f);
sp–;
} /*putfile*/
Static void callsp(void)
{
boolean line;
_TEXT TEMP;
switch (q) {
case 0: /*get*/
switch (store[sp].va) {
case 5:
TEMP.f = stdin;
*TEMP.name = '\0';
getfile(&TEMP);
break;
case 6:
errori(" get on output file ");
break;
case 7:
getfile(&prd);
break;
case 8:
errori(" get on prr file\t ");
break;
}
break;
case 1: /*put*/
switch (store[sp].va) {
case 5:
errori(" put on read file\t ");
break;
case 6:
TEMP.f = stdout;
*TEMP.name = '\0';
putfile(&TEMP);
break;
case 7:
errori(" put on prd file\t ");
break;
case 8:
putfile(&prr);
break;
}
break;
case 2: /*rst*/
/*for testphase*/
np = store[sp].va;
sp–;
break;
case 3: /*rln*/
switch (store[sp].va) {
case 5:
scanf("%*[^\n]");
getchar();
store[inputadr].vc = P_peek(stdin);
break;
case 6:
errori(" readln on output file ");
break;
case 7:
scanf("%*[^\n]");
getchar();
store[inputadr].vc = P_peek(stdin);
break;
case 8:
errori(" readln on prr file ");
break;
}
sp–;
break;
case 4: /*new*/
ad = np – store[sp].va;
/*top of stack gives the length in units of storage */
if (ad <= ep)
errori(" store overflow\t ");
np = ad;
ad = store[sp – 1].va;
store[ad].va = np;
sp -= 2;
break;
case 5: /*wln*/
switch (store[sp].va) {
case 5:
errori(" writeln on input file ");
break;
case 6:
putchar('\n');
break;
case 7:
errori(" writeln on prd file ");
break;
case 8:
putc('\n', prr.f);
break;
}
sp–;
break;
case 6: /*wrs*/
switch (store[sp].va) {
case 5:
errori(" write on input file ");
break;
case 6:
TEMP.f = stdout;
*TEMP.name = '\0';
writestr(&TEMP);
break;
case 7:
errori(" write on prd file ");
break;
case 8:
writestr(&prr);
break;
}
break;
case 7: /*eln*/
switch (store[sp].va) {
case 5:
line = P_eoln(stdin);
break;
case 6:
errori(" eoln output file\t ");
break;
case 7:
line = P_eoln(prd.f);
break;
case 8:
errori(" eoln on prr file\t ");
break;
}
store[sp].vb = line;
break;
case 8: /*wri*/
switch (store[sp].va) {
case 5:
errori(" write on input file ");
break;
case 6:
printf("%*ld", (int)store[sp – 1].vi, store[sp – 2].vi);
break;
case 7:
errori(" write on prd file ");
break;
case 8:
fprintf(prr.f, "%*ld", (int)store[sp – 1].vi, store[sp – 2].vi);
break;
}
sp -= 3;
break;
case 9: /*wrr*/
switch (store[sp].va) {
case 5:
errori(" write on input file ");
break;
case 6:
printf("% .*E", P_max((int)store[sp – 1].vi – 7, 1), store[sp – 2].vr);
break;
case 7:
errori(" write on prd file ");
break;
case 8:
fprintf(prr.f, "% .*E",
P_max((int)store[sp – 1].vi – 7, 1), store[sp – 2].vr);
break;
}
sp -= 3;
break;
case 10: /*wrc*/
switch (store[sp].va) {
case 5:
errori(" write on input file ");
break;
case 6:
printf("%*c", (int)store[sp – 1].vi, store[sp – 2].vc);
break;
case 7:
errori(" write on prd file ");
break;
case 8:
fprintf(prr.f, "%*c", (int)store[sp – 1].vi, (Char)store[sp – 2].vi);
break;
}
sp -= 3;
break;
case 11: /*rdi*/
switch (store[sp].va) {
case 5:
TEMP.f = stdin;
*TEMP.name = '\0';
readi(&TEMP);
break;
case 6:
errori(" read on output file ");
break;
case 7:
readi(&prd);
break;
case 8:
errori(" read on prr file\t ");
break;
}
break;
case 12: /*rdr*/
switch (store[sp].va) {
case 5:
TEMP.f = stdin;
*TEMP.name = '\0';
readr(&TEMP);
break;
case 6:
errori(" read on output file ");
break;
case 7:
readr(&prd);
break;
case 8:
errori(" read on prr file\t ");
break;
}
break;
case 13: /*rdc*/
switch (store[sp].va) {
case 5:
TEMP.f = stdin;
*TEMP.name = '\0';
readc(&TEMP);
break;
case 6:
errori(" read on output file ");
break;
case 7:
readc(&prd);
break;
case 8:
errori(" read on prr file\t ");
break;
}
break;
case 14: /*sin*/
store[sp].vr = sin(store[sp].vr);
break;
case 15: /*cos*/
store[sp].vr = cos(store[sp].vr);
break;
case 16: /*exp*/
store[sp].vr = exp(store[sp].vr);
break;
case 17: /*log*/
store[sp].vr = log(store[sp].vr);
break;
case 18: /*sqt*/
store[sp].vr = sqrt(store[sp].vr);
break;
case 19: /*atn*/
store[sp].vr = atan(store[sp].vr);
break;
case 20: /*sav*/
ad = store[sp].va;
store[ad].va = np;
sp–;
break;
}/*case q*/
} /*callsp*/
int main(int argc, Char *argv[])
{ /* main */
_REC_code *WITH;
settype SET;
long TEMP;
double TEMP1;
long FORLIM;
PASCAL_MAIN(argc, argv);
if (setjmp(_JL1))
goto _L1;
prr.f = NULL;
strcpy(prr.name, "prr");
prd.f = NULL;
strcpy(prd.name, "prd");
if (*prr.name != '\0') {
if (prr.f != NULL)
prr.f = freopen(prr.name, "w", prr.f);
else
prr.f = fopen(prr.name, "w");
} else {
if (prr.f != NULL)
rewind(prr.f);
else
prr.f = tmpfile();
}
if (prr.f == NULL)
_EscIO(FileNotFound);
SETUPBUF(prr.f, Char);
load(); /* assembles and stores code */
/* writeln(output); for testing */
pc = 0;
sp = -1;
mp = 0;
np = maxstk + 1;
ep = 5;
/* store[inputadr].vc = P_peek(stdin); */
store[inputadr].vc = ' ';
store[prdadr].vc = P_peek(prd.f);
interpreting = true;
while (interpreting) {
WITH = &code[pc / 2];
/*fetch*/
if (pc & 1) {
op = WITH->op2;
p = WITH->p2;
q = WITH->q2;
} else {
op = WITH->op1;
p = WITH->p1;
q = WITH->q1;
}
pc++;
/*execute*/
switch (op) {
case 105:
case 106:
case 107:
case 108:
case 109:
case 0: /*lod*/
ad = base(p) + q;
sp++;
store[sp] = store[ad];
break;
case 65:
case 66:
case 67:
case 68:
case 69:
case 1: /*ldo*/
sp++;
store[sp] = store[q];
break;
case 70:
case 71:
case 72:
case 73:
case 74:
case 2: /*str*/
store[base(p) + q] = store[sp];
sp–;
break;
case 75:
case 76:
case 77:
case 78:
case 79:
case 3: /*sro*/
store[q] = store[sp];
sp–;
break;
case 4: /*lda*/
sp++;
store[sp].va = base(p) + q;
break;
case 5: /*lao*/
sp++;
store[sp].va = q;
break;
case 80:
case 81:
case 82:
case 83:
case 84:
case 6: /*sto*/
store[store[sp – 1].va] = store[sp];
sp -= 2;
break;
case 7: /*ldc*/
sp++;
if (p == 1)
store[sp].vi = q;
else {
if (p == 6)
store[sp].vc = q;
else {
if (p == 3)
store[sp].vb = (q == 1);
else /* load nil */
store[sp].va = maxstr;
}
}
break;
case 8: /*lci*/
sp++;
store[sp] = store[q];
break;
case 85:
case 86:
case 87:
case 88:
case 89:
case 9: /*ind*/
ad = store[sp].va + q;
/* q is a number of storage units */
store[sp] = store[ad];
break;
case 90:
case 91:
case 92:
case 93:
case 94:
case 10: /*inc*/
store[sp].vi += q;
break;
case 11: /*mst*/
/*p=level of calling procedure minus level of called
procedure + 1; set dl and sl, increment sp*/
/* then length of this element is
max(intsize,realsize,boolsize,charsize,ptrsize */
store[sp + 2].vm = base(p);
/* the length of this element is ptrsize */
store[sp + 3].vm = mp;
/* idem */
store[sp + 4].vm = ep;
/* idem */
sp += 5;
break;
case 12: /*cup*/
/*p=no of locations for parameters, q=entry point*/
mp = sp – p – 4;
store[mp + 4].vm = pc;
pc = q;
break;
case 13: /*ent*/
if (p == 1) {
sp = mp + q; /*q = length of dataseg*/
if (sp > np)
errori(" store overflow\t ");
} else {
ep = sp + q;
if (ep > np)
errori(" store overflow\t ");
}
break;
/*q = max space required on stack*/
case 14: /*ret*/
switch (p) {
case 0:
sp = mp – 1;
break;
case 1:
case 2:
case 3:
case 4:
case 5:
sp = mp;
break;
}
pc = store[mp + 4].vm;
ep = store[mp + 3].vm;
mp = store[mp + 2].vm;
break;
case 15: /*csp*/
callsp();
break;
case 16: /*ixa*/
i = store[sp].vi;
sp–;
store[sp].va += q * i;
break;
case 17: /*equ*/
sp–;
switch (p) {
case 1:
store[sp].vb = (store[sp].vi == store[sp + 1].vi);
break;
case 0:
store[sp].vb = (store[sp].va == store[sp + 1].va);
break;
case 6:
store[sp].vb = (store[sp].vc == store[sp + 1].vc);
break;
case 2:
store[sp].vb = (store[sp].vr == store[sp + 1].vr);
break;
case 3:
store[sp].vb = (store[sp].vb == store[sp + 1].vb);
break;
case 4:
store[sp].vb = P_setequal(store[sp].vs, store[sp + 1].vs);
break;
case 5:
compare();
store[sp].vb = b;
break;
}/*case p*/
break;
case 18: /*neq*/
sp–;
switch (p) {
case 0:
store[sp].vb = (store[sp].va != store[sp + 1].va);
break;
case 1:
store[sp].vb = (store[sp].vi != store[sp + 1].vi);
break;
case 6:
store[sp].vb = (store[sp].vc != store[sp + 1].vc);
break;
case 2:
store[sp].vb = (store[sp].vr != store[sp + 1].vr);
break;
case 3:
store[sp].vb = (store[sp].vb != store[sp + 1].vb);
break;
case 4:
store[sp].vb = !P_setequal(store[sp].vs, store[sp + 1].vs);
break;
case 5:
compare();
store[sp].vb = !b;
break;
}/*case p*/
break;
case 19: /*geq*/
sp–;
switch (p) {
case 0:
errori(" <,<=,>,>= for address ");
break;
case 1:
store[sp].vb = (store[sp].vi >= store[sp + 1].vi);
break;
case 6:
store[sp].vb = (store[sp].vc >= store[sp + 1].vc);
break;
case 2:
store[sp].vb = (store[sp].vr >= store[sp + 1].vr);
break;
case 3:
store[sp].vb = (store[sp].vb >= store[sp + 1].vb);
break;
case 4:
store[sp].vb = P_subset(store[sp + 1].vs, store[sp].vs);
break;
case 5:
compare();
store[sp].vb = (b || store[i1 + i].vi >= store[i2 + i].vi);
break;
}/*case p*/
break;
case 20: /*grt*/
sp–;
switch (p) {
case 0:
errori(" <,<=,>,>= for address ");
break;
case 1:
store[sp].vb = (store[sp].vi > store[sp + 1].vi);
break;
case 6:
store[sp].vb = (store[sp].vc > store[sp + 1].vc);
break;
case 2:
store[sp].vb = (store[sp].vr > store[sp + 1].vr);
break;
case 3:
store[sp].vb = (store[sp].vb > store[sp + 1].vb);
break;
case 4:
errori(" set inclusion\t ");
break;
case 5:
compare();
store[sp].vb = (!b && store[i1 + i].vi > store[i2 + i].vi);
break;
}/*case p*/
break;
case 21: /*leq*/
sp–;
switch (p) {
case 0:
errori(" <,<=,>,>= for address ");
break;
case 1:
store[sp].vb = (store[sp].vi <= store[sp + 1].vi);
break;
case 6:
store[sp].vb = (store[sp].vc <= store[sp + 1].vc);
break;
case 2:
store[sp].vb = (store[sp].vr <= store[sp + 1].vr);
break;
case 3:
store[sp].vb = (store[sp].vb <= store[sp + 1].vb);
break;
case 4:
store[sp].vb = P_subset(store[sp].vs, store[sp + 1].vs);
break;
case 5:
compare();
store[sp].vb = (b || store[i1 + i].vi <= store[i2 + i].vi);
break;
}/*case p*/
break;
case 22: /*les*/
sp–;
switch (p) {
case 0:
errori(" <,<=,>,>= for address ");
break;
case 1:
store[sp].vb = (store[sp].vi < store[sp + 1].vi);
break;
case 6:
store[sp].vb = (store[sp].vc < store[sp + 1].vc);
break;
case 2:
store[sp].vb = (store[sp].vr < store[sp + 1].vr);
break;
case 3:
store[sp].vb = (store[sp].vb < store[sp + 1].vb);
break;
case 5:
compare();
store[sp].vb = (!b && store[i1 + i].vi < store[i2 + i].vi);
break;
}/*case p*/
break;
case 23: /*ujp*/
pc = q;
break;
case 24: /*fjp*/
if (!store[sp].vb)
pc = q;
sp–;
break;
case 25: /*xjp*/
pc = store[sp].vi + q;
sp–;
break;
case 95: /*chka*/
if (store[sp].va < np || store[sp].va > maxstr – q)
errori(" bad pointer value ");
break;
case 96:
case 97:
case 98:
case 99:
case 26: /*chk*/
if (store[sp].vi < store[q – 1].vi || store[sp].vi > store[q].vi)
errori(" value out of range ");
break;
case 27: /*eof*/
i = store[sp].vi;
if (i == inputadr)
store[sp].vb = P_eof(stdin);
else
errori(" code in error\t ");
break;
case 28: /*adi*/
sp–;
store[sp].vi += store[sp + 1].vi;
break;
case 29: /*adr*/
sp–;
store[sp].vr += store[sp + 1].vr;
break;
case 30: /*sbi*/
sp–;
store[sp].vi -= store[sp + 1].vi;
break;
case 31: /*sbr*/
sp–;
store[sp].vr -= store[sp + 1].vr;
break;
case 32: /*sgs*/
P_setcpy(store[sp].vs, P_addset(P_expset(SET, 0), store[sp].vi));
break;
case 33: /*flt*/
store[sp].vr = store[sp].vi;
break;
case 34: /*flo*/
store[sp – 1].vr = store[sp – 1].vi;
break;
case 35: /*trc*/
store[sp].vi = (long)store[sp].vr;
break;
case 36: /*ngi*/
store[sp].vi = -store[sp].vi;
break;
case 37: /*ngr*/
store[sp].vr = -store[sp].vr;
break;
case 38: /*sqi*/
TEMP = store[sp].vi;
store[sp].vi = TEMP * TEMP;
break;
case 39: /*sqr*/
TEMP1 = store[sp].vr;
store[sp].vr = TEMP1 * TEMP1;
break;
case 40: /*abi*/
store[sp].vi = labs(store[sp].vi);
break;
case 41: /*abr*/
store[sp].vr = fabs(store[sp].vr);
break;
case 42: /*not*/
store[sp].vb = !store[sp].vb;
break;
case 43: /*and*/
sp–;
store[sp].vb = (store[sp].vb && store[sp + 1].vb);
break;
case 44: /*ior*/
sp–;
store[sp].vb = (store[sp].vb || store[sp + 1].vb);
break;
case 45: /*dif*/
sp–;
P_setdiff(store[sp].vs, store[sp].vs, store[sp + 1].vs);
break;
case 46: /*int*/
sp–;
P_setint(store[sp].vs, store[sp].vs, store[sp + 1].vs);
break;
case 47: /*uni*/
sp–;
P_setunion(store[sp].vs, store[sp].vs, store[sp + 1].vs);
break;
case 48: /*inn*/
sp–;
i = store[sp].vi;
store[sp].vb = P_inset(i, store[sp + 1].vs);
break;
case 49: /*mod*/
sp–;
store[sp].vi %= store[sp + 1].vi;
break;
case 50: /*odd*/
store[sp].vb = store[sp].vi & 1;
break;
case 51: /*mpi*/
sp–;
store[sp].vi *= store[sp + 1].vi;
break;
case 52: /*mpr*/
sp–;
store[sp].vr *= store[sp + 1].vr;
break;
case 53: /*dvi*/
sp–;
store[sp].vi /= store[sp + 1].vi;
break;
case 54: /*dvr*/
sp–;
store[sp].vr /= store[sp + 1].vr;
break;
case 55: /*mov*/
i1 = store[sp – 1].va;
i2 = store[sp].va;
sp -= 2;
FORLIM = q;
for (i = 0; i < FORLIM; i++) {
store[i1 + i] = store[i2 + i];
/* q is a number of storage units */
}
break;
case 56: /*lca*/
sp++;
store[sp].va = q;
break;
case 100:
case 101:
case 102:
case 103:
case 104:
case 57: /*dec*/
store[sp].vi -= q;
break;
case 58: /*stp*/
interpreting = false;
break;
case 59: /*ord*/
break;
/*only used to change the tagfield*/
case 60: /*chr*/
break;
case 61: /*ujc*/
errori(" case – error\t ");
break;
}
} /*while interpreting*/
_L1:
if (prd.f != NULL)
fclose(prd.f);
if (prr.f != NULL)
fclose(prr.f);
return 0;
}
/* End. */

view raw

pint.c

hosted with ❤ by GitHub


(*Assembler and interpreter of Pascal code*)
(*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*)
program pcode(input,output,prd,prr);
(* Note for the implementation.
===========================
This interpreter is written for the case where all the fundamental types
take one storage unit.
In an actual implementation, the handling of the sp pointer has to take
into account the fact that the types may have lengths different from one:
in push and pop operations the sp has to be increased and decreased not
by 1, but by a number depending on the type concerned.
However, where the number of units of storage has been computed by the
compiler, the value must not be corrected, since the lengths of the types
involved have already been taken into account.
*)
label 1;
const codemax = 8650;
pcmax = 17500;
maxstk = 13650; (* size of variable store *)
overi = 13655; (* size of integer constant table = 5 *)
overr = 13660; (* size of real constant table = 5 *)
overs = 13730; (* size of set constant table = 70 *)
overb = 13820;
overm = 18000;
maxstr = 18001;
largeint = 26144;
begincode = 3;
inputadr = 5;
outputadr = 6;
prdadr = 7;
prradr = 8;
duminst = 62;
type bit4 = 0..15;
bit6 = 0..127;
bit20 = -26143..26143;
datatype = (undef,int,reel,bool,sett,adr,mark,car);
address = -1..maxstr;
beta = packed array[1..25] of char; (*error message*)
settype = set of 0..58;
alfa = packed array[1..10] of char;
var code : array[0..codemax] of (* the program *)
packed record op1 :bit6;
p1 :bit4;
q1 :bit20;
op2 :bit6;
p2 :bit4;
q2 :bit20
end;
pc : 0..pcmax; (*program address register*)
op : bit6; p : bit4; q : bit20; (*instruction register*)
store : array [0..overm] of
record case datatype of
int :(vi :integer);
reel :(vr :real);
bool :(vb :boolean);
sett :(vs :settype);
car :(vc :char);
adr :(va :address);
(*address in store*)
mark :(vm :integer)
end;
mp,sp,np,ep : address; (* address registers *)
(*mp points to beginning of a data segment
sp points to top of the stack
ep points to the maximum extent of the stack
np points to top of the dynamically allocated area*)
interpreting: boolean;
prd,prr : text;(*prd for read only, prr for write only *)
instr : array[bit6] of alfa; (* mnemonic instruction codes *)
cop : array[bit6] of integer;
sptable : array[0..20] of alfa; (*standard functions and procedures*)
(*locally used for interpreting one instruction*)
ad,ad1 : address;
b : boolean;
i,j,i1,i2 : integer;
c : char;
(*——————————————————————–*)
procedure load;
const maxlabel = 1850;
type labelst = (entered,defined); (*label situation*)
labelrg = 0..maxlabel; (*label range*)
labelrec = record
val: address;
st: labelst
end;
var icp,rcp,scp,bcp,mcp : address; (*pointers to next free position*)
word : array[1..10] of char; i : integer; ch : char;
labeltab: array[labelrg] of labelrec;
labelvalue: address;
procedure init;
var i: integer;
begin instr[ 0]:='lod '; instr[ 1]:='ldo ';
instr[ 2]:='str '; instr[ 3]:='sro ';
instr[ 4]:='lda '; instr[ 5]:='lao ';
instr[ 6]:='sto '; instr[ 7]:='ldc ';
instr[ 8]:='… '; instr[ 9]:='ind ';
instr[10]:='inc '; instr[11]:='mst ';
instr[12]:='cup '; instr[13]:='ent ';
instr[14]:='ret '; instr[15]:='csp ';
instr[16]:='ixa '; instr[17]:='equ ';
instr[18]:='neq '; instr[19]:='geq ';
instr[20]:='grt '; instr[21]:='leq ';
instr[22]:='les '; instr[23]:='ujp ';
instr[24]:='fjp '; instr[25]:='xjp ';
instr[26]:='chk '; instr[27]:='eof ';
instr[28]:='adi '; instr[29]:='adr ';
instr[30]:='sbi '; instr[31]:='sbr ';
instr[32]:='sgs '; instr[33]:='flt ';
instr[34]:='flo '; instr[35]:='trc ';
instr[36]:='ngi '; instr[37]:='ngr ';
instr[38]:='sqi '; instr[39]:='sqr ';
instr[40]:='abi '; instr[41]:='abr ';
instr[42]:='not '; instr[43]:='and ';
instr[44]:='ior '; instr[45]:='dif ';
instr[46]:='int '; instr[47]:='uni ';
instr[48]:='inn '; instr[49]:='mod ';
instr[50]:='odd '; instr[51]:='mpi ';
instr[52]:='mpr '; instr[53]:='dvi ';
instr[54]:='dvr '; instr[55]:='mov ';
instr[56]:='lca '; instr[57]:='dec ';
instr[58]:='stp '; instr[59]:='ord ';
instr[60]:='chr '; instr[61]:='ujc ';
sptable[ 0]:='get '; sptable[ 1]:='put ';
sptable[ 2]:='rst '; sptable[ 3]:='rln ';
sptable[ 4]:='new '; sptable[ 5]:='wln ';
sptable[ 6]:='wrs '; sptable[ 7]:='eln ';
sptable[ 8]:='wri '; sptable[ 9]:='wrr ';
sptable[10]:='wrc '; sptable[11]:='rdi ';
sptable[12]:='rdr '; sptable[13]:='rdc ';
sptable[14]:='sin '; sptable[15]:='cos ';
sptable[16]:='exp '; sptable[17]:='log ';
sptable[18]:='sqt '; sptable[19]:='atn ';
sptable[20]:='sav ';
cop[ 0] := 105; cop[ 1] := 65;
cop[ 2] := 70; cop[ 3] := 75;
cop[ 6] := 80; cop[ 9] := 85;
cop[10] := 90; cop[26] := 95;
cop[57] := 100;
pc := begincode;
icp := maxstk + 1;
rcp := overi + 1;
scp := overr + 1;
bcp := overs + 2;
mcp := overb + 1;
for i:= 1 to 10 do word[i]:= ' ';
for i:= 0 to maxlabel do
with labeltab[i] do begin val:=-1; st:= entered end;
reset(prd);
end;(*init*)
procedure errorl(string: beta); (*error in loading*)
begin writeln;
write(string);
halt
end; (*errorl*)
procedure update(x: labelrg); (*when a label definition lx is found*)
var curr,succ: -1..pcmax; (*resp. current element and successor element
of a list of future references*)
endlist: boolean;
begin
if labeltab[x].st=defined then errorl(' duplicated label ')
else begin
if labeltab[x].val<>-1 then (*forward reference(s)*)
begin curr:= labeltab[x].val; endlist:= false;
while not endlist do
with code[curr div 2] do
begin
if odd(curr) then begin succ:= q2;
q2:= labelvalue
end
else begin succ:= q1;
q1:= labelvalue
end;
if succ=-1 then endlist:= true
else curr:= succ
end;
end;
labeltab[x].st := defined;
labeltab[x].val:= labelvalue;
end
end;(*update*)
procedure assemble; forward;
procedure generate;(*generate segment of code*)
var x: integer; (* label number *)
again: boolean;
begin
again := true;
while again do
begin read(prd,ch);(* first character of line*)
case ch of
'i': readln(prd);
'l': begin read(prd,x);
if not eoln(prd) then read(prd,ch);
if ch='=' then read(prd,labelvalue)
else labelvalue:= pc;
update(x); readln(prd);
end;
'q': begin again := false; readln(prd) end;
' ': begin read(prd,ch); assemble end
end;
end
end; (*generate*)
procedure assemble; (*translate symbolic code into machine code and store*)
label 1; (*goto 1 for instructions without code generation*)
var name :alfa; b :boolean; r :real; s :settype;
c1 :char; i,s1,lb,ub :integer;
procedure lookup(x: labelrg); (* search in label table*)
begin case labeltab[x].st of
entered: begin q := labeltab[x].val;
labeltab[x].val := pc
end;
defined: q:= labeltab[x].val
end(*case label..*)
end;(*lookup*)
procedure labelsearch;
var x: labelrg;
begin while (ch<>'l') and not eoln(prd) do read(prd,ch);
read(prd,x); lookup(x)
end;(*labelsearch*)
procedure getname;
begin word[1] := ch;
read(prd,word[2],word[3]);
if not eoln(prd) then read(prd,ch) (*next character*);
pack(word,1,name)
end; (*getname*)
procedure typesymbol;
var i: integer;
begin
if ch <> 'i' then
begin
case ch of
'a': i := 0;
'r': i := 1;
's': i := 2;
'b': i := 3;
'c': i := 4;
end;
op := cop[op]+i;
end;
end (*typesymbol*) ;
begin p := 0; q := 0; op := 0;
getname;
instr[duminst] := name;
while instr[op]<>name do op := op+1;
if op = duminst then errorl(' illegal instruction ');
case op of (* get parameters p,q *)
(*equ,neq,geq,grt,leq,les*)
17,18,19,
20,21,22: begin case ch of
'a': ; (*p = 0*)
'i': p := 1;
'r': p := 2;
'b': p := 3;
's': p := 4;
'c': p := 6;
'm': begin p := 5;
read(prd,q)
end
end
end;
(*lod,str*)
0,2: begin typesymbol; read(prd,p,q)
end;
4 (*lda*): read(prd,p,q);
12 (*cup*): begin read(prd,p); labelsearch end;
11 (*mst*): read(prd,p);
14 (*ret*): case ch of
'p': p:=0;
'i': p:=1;
'r': p:=2;
'c': p:=3;
'b': p:=4;
'a': p:=5
end;
(*lao,ixa,mov*)
5,16,55: read(prd,q);
(*ldo,sro,ind,inc,dec*)
1,3,9,10,57: begin typesymbol; read(prd,q)
end;
(*ujp,fjp,xjp*)
23,24,25: labelsearch;
13 (*ent*): begin read(prd,p); labelsearch end;
15 (*csp*): begin for i:=1 to 9 do read(prd,ch); getname;
while name<>sptable[q] do q := q+1
end;
7 (*ldc*): begin case ch of (*get q*)
'i': begin p := 1; read(prd,i);
if abs(i)>=largeint then
begin op := 8;
store[icp].vi := i; q := maxstk;
repeat q := q+1 until store[q].vi=i;
if q=icp then
begin icp := icp+1;
if icp=overi then
errorl(' integer table overflow ');
end
end else q := i
end;
'r': begin op := 8; p := 2;
read(prd,r);
store[rcp].vr := r; q := overi;
repeat q := q+1 until store[q].vr=r;
if q=rcp then
begin rcp := rcp+1;
if rcp = overr then
errorl(' real table overflow ');
end
end;
'n': ; (*p,q = 0*)
'b': begin p := 3; read(prd,q) end;
'c': begin p := 6;
repeat read(prd,ch); until ch <> ' ';
if ch <> '''' then
errorl(' illegal character ');
read(prd,ch); q := ord(ch);
read(prd,ch);
if ch <> '''' then
errorl(' illegal character ');
end;
'(': begin op := 8; p := 4;
s := [ ]; read(prd,ch);
while ch<>')' do
begin read(prd,s1,ch); s := s + [s1]
end;
store[scp].vs := s; q := overr;
repeat q := q+1 until store[q].vs=s;
if q=scp then
begin scp := scp+1;
if scp=overs then
errorl(' set table overflow ');
end
end
end (*case*)
end;
26 (*chk*): begin typesymbol;
read(prd,lb,ub);
if op = 95 then q := lb
else
begin
store[bcp-1].vi := lb; store[bcp].vi := ub;
q := overs;
repeat q := q+2
until (store[q-1].vi=lb)and (store[q].vi=ub);
if q=bcp then
begin bcp := bcp+2;
if bcp=overb then
errorl(' boundary table overflow ');
end
end
end;
56 (*lca*): begin
if mcp + 16 >= overm then
errorl(' multiple table overflow ');
mcp := mcp+16;
q := mcp;
for i := 0 to 15 (*stringlgth*) do
begin read(prd,ch);
store[q+i].vc := ch
end;
end;
6 (*sto*): typesymbol;
27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
48,49,50,51,52,53,54,58: ;
(*ord,chr*)
59,60: goto 1;
61 (*ujc*): ; (*must have same length as ujp*)
end; (*case*)
(* store instruction *)
with code[pc div 2] do
if odd(pc) then
begin op2 := op; p2 := p; q2 := q
end else
begin op1 := op; p1 := p; q1 := q
end;
pc := pc+1;
1: readln(prd);
end; (*assemble*)
begin (*load*)
init;
generate;
pc := 0;
generate;
end; (*load*)
(*————————————————————————*)
procedure pmd;
var s :integer; i: integer;
procedure pt;
begin write(s:6);
if abs(store[s].vi) < maxint then write(store[s].vi)
else write('too big ');
s := s – 1;
i := i + 1;
if i = 4 then
begin writeln(output); i := 0 end;
end; (*pt*)
begin
write(' pc =',pc-1:5,' op =',op:3,' sp =',sp:5,' mp =',mp:5,
' np =',np:5);
writeln; writeln('————————————–');
s := sp; i := 0;
while s>=0 do pt;
s := maxstk;
while s>=np do pt;
end; (*pmd*)
procedure errori(string: beta);
begin writeln; writeln(string);
pmd; goto 1
end;(*errori*)
function base(ld :integer):address;
var ad :address;
begin ad := mp;
while ld>0 do
begin ad := store[ad+1].vm; ld := ld-1
end;
base := ad
end; (*base*)
procedure compare;
(*comparing is only correct if result by comparing integers will be*)
begin
i1 := store[sp].va;
i2 := store[sp+1].va;
i := 0; b := true;
while b and (i<>q) do
if store[i1+i].vi = store[i2+i].vi then i := i+1
else b := false
end; (*compare*)
procedure callsp;
var line: boolean; adptr,adelnt: address;
i: integer;
procedure readi(var f:text);
var ad: address;
begin ad:= store[sp-1].va;
read(f,store[ad].vi);
store[store[sp].va].vc := f^;
sp:= sp-2
end;(*readi*)
procedure readr(var f: text);
var ad: address;
begin ad:= store[sp-1].va;
read(f,store[ad].vr);
store[store[sp].va].vc := f^;
sp:= sp-2
end;(*readr*)
procedure readc(var f: text);
var c: char; ad: address;
begin read(f,c);
ad:= store[sp-1].va;
store[ad].vc := c;
store[store[sp].va].vc := f^;
store[store[sp].va].vi := ord(f^);
sp:= sp-2
end;(*readc*)
procedure writestr(var f: text);
var i,j,k: integer;
ad: address;
begin ad:= store[sp-3].va;
k := store[sp-2].vi; j := store[sp-1].vi;
(* j and k are numbers of characters *)
if k>j then for i:=1 to k-j do write(f,' ')
else j:= k;
for i := 0 to j-1 do write(f,store[ad+i].vc);
sp:= sp-4
end;(*writestr*)
procedure getfile(var f: text);
var ad: address;
begin ad:=store[sp].va;
get(f); store[ad].vc := f^;
sp:=sp-1
end;(*getfile*)
procedure putfile(var f: text);
var ad: address;
begin ad:= store[sp].va;
f^:= store[ad].vc; put(f);
sp:= sp-1;
end;(*putfile*)
begin (*callsp*)
case q of
0 (*get*): case store[sp].va of
5: getfile(input);
6: errori(' get on output file ');
7: getfile(prd);
8: errori(' get on prr file ')
end;
1 (*put*): case store[sp].va of
5: errori(' put on read file ');
6: putfile(output);
7: errori(' put on prd file ');
8: putfile(prr)
end;
2 (*rst*): begin
(*for testphase*)
np := store[sp].va; sp := sp-1
end;
3 (*rln*): begin case store[sp].va of
5: begin readln(input);
store[inputadr].vc := input^
end;
6: errori(' readln on output file ');
7: begin readln(input);
store[inputadr].vc := input^
end;
8: errori(' readln on prr file ')
end;
sp:= sp-1
end;
4 (*new*): begin ad:= np-store[sp].va;
(*top of stack gives the length in units of storage *)
if ad <= ep then
errori(' store overflow ');
np:= ad; ad:= store[sp-1].va;
store[ad].va := np;
sp:=sp-2
end;
5 (*wln*): begin case store[sp].va of
5: errori(' writeln on input file ');
6: writeln(output);
7: errori(' writeln on prd file ');
8: writeln(prr)
end;
sp:= sp-1
end;
6 (*wrs*): case store[sp].va of
5: errori(' write on input file ');
6: writestr(output);
7: errori(' write on prd file ');
8: writestr(prr)
end;
7 (*eln*): begin case store[sp].va of
5: line:= eoln(input);
6: errori(' eoln output file ');
7: line:=eoln(prd);
8: errori(' eoln on prr file ')
end;
store[sp].vb := line
end;
8 (*wri*): begin case store[sp].va of
5: errori(' write on input file ');
6: write(output,
store[sp-2].vi: store[sp-1].vi);
7: errori(' write on prd file ');
8: write(prr,
store[sp-2].vi: store[sp-1].vi)
end;
sp:=sp-3
end;
9 (*wrr*): begin case store[sp].va of
5: errori(' write on input file ');
6: write(output,
store[sp-2].vr: store[sp-1].vi);
7: errori(' write on prd file ');
8: write(prr,
store[sp-2].vr: store[sp-1].vi)
end;
sp:=sp-3
end;
10(*wrc*): begin case store[sp].va of
5: errori(' write on input file ');
6: write(output,store[sp-2].vc:
store[sp-1].vi);
7: errori(' write on prd file ');
8: write(prr,chr(store[sp-2].vi):
store[sp-1].vi);
end;
sp:=sp-3
end;
11(*rdi*): case store[sp].va of
5: readi(input);
6: errori(' read on output file ');
7: readi(prd);
8: errori(' read on prr file ')
end;
12(*rdr*): case store[sp].va of
5: readr(input);
6: errori(' read on output file ');
7: readr(prd);
8: errori(' read on prr file ')
end;
13(*rdc*): case store[sp].va of
5: readc(input);
6: errori(' read on output file ');
7: readc(prd);
8: errori(' read on prr file ')
end;
14(*sin*): store[sp].vr:= sin(store[sp].vr);
15(*cos*): store[sp].vr:= cos(store[sp].vr);
16(*exp*): store[sp].vr:= exp(store[sp].vr);
17(*log*): store[sp].vr:= ln(store[sp].vr);
18(*sqt*): store[sp].vr:= sqrt(store[sp].vr);
19(*atn*): store[sp].vr:= arctan(store[sp].vr);
20(*sav*): begin ad:=store[sp].va;
store[ad].va := np;
sp:= sp-1
end;
end;(*case q*)
end;(*callsp*)
begin (* main *)
rewrite(prr);
load; (* assembles and stores code *)
(* writeln(output); for testing *)
pc := 0; sp := -1; mp := 0; np := maxstk+1; ep := 5;
store[inputadr].vc := input^;
store[prdadr].vc := prd^;
interpreting := true;
while interpreting do
begin
(*fetch*)
with code[pc div 2] do
if odd(pc) then
begin op := op2; p := p2; q := q2
end else
begin op := op1; p := p1; q := q1
end;
pc := pc+1;
(*execute*)
case op of
105,106,107,108,109,
0 (*lod*): begin ad := base(p) + q;
sp := sp+1;
store[sp] := store[ad]
end;
65,66,67,68,69,
1 (*ldo*): begin
sp := sp+1;
store[sp] := store[q]
end;
70,71,72,73,74,
2 (*str*): begin store[base(p)+q] := store[sp];
sp := sp-1
end;
75,76,77,78,79,
3 (*sro*): begin store[q] := store[sp];
sp := sp-1
end;
4 (*lda*): begin sp := sp+1;
store[sp].va := base(p) + q
end;
5 (*lao*): begin sp := sp+1;
store[sp].va := q
end;
80,81,82,83,84,
6 (*sto*): begin
store[store[sp-1].va] := store[sp];
sp := sp-2;
end;
7 (*ldc*): begin sp := sp+1;
if p=1 then
begin store[sp].vi := q;
end else
if p = 6 then store[sp].vc := chr(q)
else
if p = 3 then store[sp].vb := q = 1
else (* load nil *) store[sp].va := maxstr
end;
8 (*lci*): begin sp := sp+1;
store[sp] := store[q]
end;
85,86,87,88,89,
9 (*ind*): begin ad := store[sp].va + q;
(* q is a number of storage units *)
store[sp] := store[ad]
end;
90,91,92,93,94,
10 (*inc*): store[sp].vi := store[sp].vi+q;
11 (*mst*): begin (*p=level of calling procedure minus level of called
procedure + 1; set dl and sl, increment sp*)
(* then length of this element is
max(intsize,realsize,boolsize,charsize,ptrsize *)
store[sp+2].vm := base(p);
(* the length of this element is ptrsize *)
store[sp+3].vm := mp;
(* idem *)
store[sp+4].vm := ep;
(* idem *)
sp := sp+5
end;
12 (*cup*): begin (*p=no of locations for parameters, q=entry point*)
mp := sp-(p+4);
store[mp+4].vm := pc;
pc := q
end;
13 (*ent*): if p = 1 then
begin sp := mp + q; (*q = length of dataseg*)
if sp > np then errori(' store overflow ');
end
else
begin ep := sp+q;
if ep > np then errori(' store overflow ');
end;
(*q = max space required on stack*)
14 (*ret*): begin case p of
0: sp:= mp-1;
1,2,3,4,5: sp:= mp
end;
pc := store[mp+4].vm;
ep := store[mp+3].vm;
mp:= store[mp+2].vm;
end;
15 (*csp*): callsp;
16 (*ixa*): begin
i := store[sp].vi;
sp := sp-1;
store[sp].va := q*i+store[sp].va;
end;
17 (*equ*): begin sp := sp-1;
case p of
1: store[sp].vb := store[sp].vi = store[sp+1].vi;
0: store[sp].vb := store[sp].va = store[sp+1].va;
6: store[sp].vb := store[sp].vc = store[sp+1].vc;
2: store[sp].vb := store[sp].vr = store[sp+1].vr;
3: store[sp].vb := store[sp].vb = store[sp+1].vb;
4: store[sp].vb := store[sp].vs = store[sp+1].vs;
5: begin compare;
store[sp].vb := b;
end;
end; (*case p*)
end;
18 (*neq*): begin sp := sp-1;
case p of
0: store[sp].vb := store[sp].va <> store[sp+1].va;
1: store[sp].vb := store[sp].vi <> store[sp+1].vi;
6: store[sp].vb := store[sp].vc <> store[sp+1].vc;
2: store[sp].vb := store[sp].vr <> store[sp+1].vr;
3: store[sp].vb := store[sp].vb <> store[sp+1].vb;
4: store[sp].vb := store[sp].vs <> store[sp+1].vs;
5: begin compare;
store[sp].vb := not b;
end
end; (*case p*)
end;
19 (*geq*): begin sp := sp-1;
case p of
0: errori(' <,<=,>,>= for address ');
1: store[sp].vb := store[sp].vi >= store[sp+1].vi;
6: store[sp].vb := store[sp].vc >= store[sp+1].vc;
2: store[sp].vb := store[sp].vr >= store[sp+1].vr;
3: store[sp].vb := store[sp].vb >= store[sp+1].vb;
4: store[sp].vb := store[sp].vs >= store[sp+1].vs;
5: begin compare;
store[sp].vb := b or
(store[i1+i].vi >= store[i2+i].vi)
end
end; (*case p*)
end;
20 (*grt*): begin sp := sp-1;
case p of
0: errori(' <,<=,>,>= for address ');
1: store[sp].vb := store[sp].vi > store[sp+1].vi;
6: store[sp].vb := store[sp].vc > store[sp+1].vc;
2: store[sp].vb := store[sp].vr > store[sp+1].vr;
3: store[sp].vb := store[sp].vb > store[sp+1].vb;
4: errori(' set inclusion ');
5: begin compare;
store[sp].vb := not b and
(store[i1+i].vi > store[i2+i].vi)
end
end; (*case p*)
end;
21 (*leq*): begin sp := sp-1;
case p of
0: errori(' <,<=,>,>= for address ');
1: store[sp].vb := store[sp].vi <= store[sp+1].vi;
6: store[sp].vb := store[sp].vc <= store[sp+1].vc;
2: store[sp].vb := store[sp].vr <= store[sp+1].vr;
3: store[sp].vb := store[sp].vb <= store[sp+1].vb;
4: store[sp].vb := store[sp].vs <= store[sp+1].vs;
5: begin compare;
store[sp].vb := b or
(store[i1+i].vi <= store[i2+i].vi)
end;
end; (*case p*)
end;
22 (*les*): begin sp := sp-1;
case p of
0: errori(' <,<=,>,>= for address ');
1: store[sp].vb := store[sp].vi < store[sp+1].vi;
6: store[sp].vb := store[sp].vc < store[sp+1].vc;
2: store[sp].vb := store[sp].vr < store[sp+1].vr;
3: store[sp].vb := store[sp].vb < store[sp+1].vb;
5: begin compare;
store[sp].vb := not b and
(store[i1+i].vi < store[i2+i].vi)
end
end; (*case p*)
end;
23 (*ujp*): pc := q;
24 (*fjp*): begin if not store[sp].vb then pc := q;
sp := sp-1
end;
25 (*xjp*): begin
pc := store[sp].vi + q;
sp := sp-1
end;
95 (*chka*): if (store[sp].va < np) or
(store[sp].va > (maxstr-q)) then
errori(' bad pointer value ');
96,97,98,99,
26 (*chk*): if (store[sp].vi < store[q-1].vi) or
(store[sp].vi > store[q].vi) then
errori(' value out of range ');
27 (*eof*): begin i := store[sp].vi;
if i=inputadr then
begin store[sp].vb := eof(input);
end else errori(' code in error ')
end;
28 (*adi*): begin sp := sp-1;
store[sp].vi := store[sp].vi + store[sp+1].vi
end;
29 (*adr*): begin sp := sp-1;
store[sp].vr := store[sp].vr + store[sp+1].vr
end;
30 (*sbi*): begin sp := sp-1;
store[sp].vi := store[sp].vi – store[sp+1].vi
end;
31 (*sbr*): begin sp := sp-1;
store[sp].vr := store[sp].vr – store[sp+1].vr
end;
32 (*sgs*): store[sp].vs := [store[sp].vi];
33 (*flt*): store[sp].vr := store[sp].vi;
34 (*flo*): store[sp-1].vr := store[sp-1].vi;
35 (*trc*): store[sp].vi := trunc(store[sp].vr);
36 (*ngi*): store[sp].vi := -store[sp].vi;
37 (*ngr*): store[sp].vr := -store[sp].vr;
38 (*sqi*): store[sp].vi := sqr(store[sp].vi);
39 (*sqr*): store[sp].vr := sqr(store[sp].vr);
40 (*abi*): store[sp].vi := abs(store[sp].vi);
41 (*abr*): store[sp].vr := abs(store[sp].vr);
42 (*not*): store[sp].vb := not store[sp].vb;
43 (*and*): begin sp := sp-1;
store[sp].vb := store[sp].vb and store[sp+1].vb
end;
44 (*ior*): begin sp := sp-1;
store[sp].vb := store[sp].vb or store[sp+1].vb
end;
45 (*dif*): begin sp := sp-1;
store[sp].vs := store[sp].vs – store[sp+1].vs
end;
46 (*int*): begin sp := sp-1;
store[sp].vs := store[sp].vs * store[sp+1].vs
end;
47 (*uni*): begin sp := sp-1;
store[sp].vs := store[sp].vs + store[sp+1].vs
end;
48 (*inn*): begin
sp := sp – 1; i := store[sp].vi;
store[sp].vb := i in store[sp+1].vs;
end;
49 (*mod*): begin sp := sp-1;
store[sp].vi := store[sp].vi mod store[sp+1].vi
end;
50 (*odd*): store[sp].vb := odd(store[sp].vi);
51 (*mpi*): begin sp := sp-1;
store[sp].vi := store[sp].vi * store[sp+1].vi
end;
52 (*mpr*): begin sp := sp-1;
store[sp].vr := store[sp].vr * store[sp+1].vr
end;
53 (*dvi*): begin sp := sp-1;
store[sp].vi := store[sp].vi div store[sp+1].vi
end;
54 (*dvr*): begin sp := sp-1;
store[sp].vr := store[sp].vr / store[sp+1].vr
end;
55 (*mov*): begin i1 := store[sp-1].va;
i2 := store[sp].va; sp := sp-2;
for i := 0 to q-1 do store[i1+i] := store[i2+i]
(* q is a number of storage units *)
end;
56 (*lca*): begin sp := sp+1;
store[sp].va := q;
end;
100,101,102,103,104,
57 (*dec*): store[sp].vi := store[sp].vi-q;
58 (*stp*): interpreting := false;
59 (*ord*): (*only used to change the tagfield*)
begin
end;
60 (*chr*): begin
end;
61 (*ujc*): errori(' case – error ');
end
end; (*while interpreting*)
1 :
end.

view raw

pint.p

hosted with ❤ by GitHub

This entry was posted on 2025/05/06 at 12:00 and is filed under Apple Pascal, Conference Topics, Conferences, Development, DVCS - Distributed Version Control, Event, gist, GitHub, History, Internet, link rot, Pascal, Power User, Software Development, Source Code Management, Standard Pascal, Turbo Pascal, UCSD Pascal, WWW - the World Wide Web of information. You can follow any responses to this entry through the RSS 2.0 feed. You can leave a response, or trackback from your own site.

Leave a comment

This site uses Akismet to reduce spam. Learn how your comment data is processed.

«
»