diff options
| author | patacongo <patacongo@7fd9a85b-ad96-42d3-883c-3090e2eb8679> | 2009-12-18 17:14:06 +0000 |
|---|---|---|
| committer | patacongo <patacongo@7fd9a85b-ad96-42d3-883c-3090e2eb8679> | 2009-12-18 17:14:06 +0000 |
| commit | 47f8e8a18f38f52450db0d421bed88f492a99e81 (patch) | |
| tree | a513983f09fde1f49a29d63f76475311a5c8ff4a /misc | |
| parent | 8361ddf7d35e3dfd59f46c1ca5ce3347d83cc3ce (diff) | |
Update to use stdint/stdbool.h
git-svn-id: https://nuttx.svn.sourceforge.net/svnroot/nuttx/trunk@2386 7fd9a85b-ad96-42d3-883c-3090e2eb8679
Diffstat (limited to 'misc')
65 files changed, 13736 insertions, 13678 deletions
diff --git a/misc/pascal/ChangeLog b/misc/pascal/ChangeLog index 9b8debd369..a5572f6d9d 100644 --- a/misc/pascal/ChangeLog +++ b/misc/pascal/ChangeLog @@ -16,4 +16,8 @@ pascal-0.1.2 2008-02-10 Gregory Nutt <spudmonkey@racsa.co.cr> and eliminate a compiler bug * Changes so that runtime compiles with SDCC. -pascal-0.1.3 2008-xx-xx Gregory Nutt <spudmonkey@racsa.co.cr> +pascal-2.0 2009-xx-xx Gregory Nutt <spudmonkey@racsa.co.cr> + + * Updated to use standard C99 types in stdint.h and + stdbool.h. This change was necessary for compatibility + with NuttX-5.0. diff --git a/misc/pascal/ReleaseNotes b/misc/pascal/ReleaseNotes index 2abb1dd3c4..d5c0ab3336 100644 --- a/misc/pascal/ReleaseNotes +++ b/misc/pascal/ReleaseNotes @@ -8,3 +8,15 @@ different platforms. This release is synchronized with the release of NuttX-0.3.8. This tarball contains a complete CVS snapshot from February 10, 2008. + +pascal-0.1.3 +^^^^^^^^^^^^ + +This was a bug-fix release + +pascal-2.0 +^^^^^^^^^^ + +This release updates all of the code to use the standard types defined +in the C99 files stdint.h and stdbool.h. This change was necessary for +compatibility with NuttX-5.0. No functional changes were made. diff --git a/misc/pascal/include/keywords.h b/misc/pascal/include/keywords.h index aed438af8b..6025524d94 100644 --- a/misc/pascal/include/keywords.h +++ b/misc/pascal/include/keywords.h @@ -44,11 +44,12 @@ #include "config.h"
/*************************************************************
- * Definitions
+ *Pre-processor Definitions
*************************************************************/
-#define TRUE 1
-#define FALSE 0
+#ifndef NULL
+# define NULL ((void*)0)
+#endif
#ifndef CONFIG_DEBUG
# define CONFIG_DEBUG 0
diff --git a/misc/pascal/libpoff/pfdbgcontainer.c b/misc/pascal/libpoff/pfdbgcontainer.c index d5eb03c271..572f1c2e6d 100644 --- a/misc/pascal/libpoff/pfdbgcontainer.c +++ b/misc/pascal/libpoff/pfdbgcontainer.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfdbginfo.c b/misc/pascal/libpoff/pfdbginfo.c index 5d2e889bc9..41ea995cdb 100644 --- a/misc/pascal/libpoff/pfdbginfo.c +++ b/misc/pascal/libpoff/pfdbginfo.c @@ -49,7 +49,7 @@ #include "pofflib.h" /* POFF library interface */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfdreloc.c b/misc/pascal/libpoff/pfdreloc.c index e082bee35d..5e9f5bcfee 100644 --- a/misc/pascal/libpoff/pfdreloc.c +++ b/misc/pascal/libpoff/pfdreloc.c @@ -48,7 +48,7 @@ #include "pofflib.h" /* Public interfaces */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfdsymbol.c b/misc/pascal/libpoff/pfdsymbol.c index 384d5b362d..cce272616f 100644 --- a/misc/pascal/libpoff/pfdsymbol.c +++ b/misc/pascal/libpoff/pfdsymbol.c @@ -48,7 +48,7 @@ #include "pofflib.h" /* Public interfaces */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfiprog.c b/misc/pascal/libpoff/pfiprog.c index 5cbf1b79ee..c768cb0753 100644 --- a/misc/pascal/libpoff/pfiprog.c +++ b/misc/pascal/libpoff/pfiprog.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfirodata.c b/misc/pascal/libpoff/pfirodata.c index 35e65268f5..baaed6f7f9 100644 --- a/misc/pascal/libpoff/pfirodata.c +++ b/misc/pascal/libpoff/pfirodata.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pflabel.c b/misc/pascal/libpoff/pflabel.c index 073e73292a..088ad77cac 100644 --- a/misc/pascal/libpoff/pflabel.c +++ b/misc/pascal/libpoff/pflabel.c @@ -50,7 +50,7 @@ #include "poff.h" /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ #define INITIAL_DEFINED_ALLOCATION (1024*sizeof(optDefinedLabelRef_t)) diff --git a/misc/pascal/libpoff/pflineno.c b/misc/pascal/libpoff/pflineno.c index ed257d52d6..de6e79ca17 100644 --- a/misc/pascal/libpoff/pflineno.c +++ b/misc/pascal/libpoff/pflineno.c @@ -53,7 +53,7 @@ poffLibLineNumber_t /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ #define INITIAL_LINENUMBER_TABLE_SIZE 2048*sizeof(poffLibLineNumber_t) diff --git a/misc/pascal/libpoff/pfprivate.h b/misc/pascal/libpoff/pfprivate.h index afcd3da9d8..76fdc867ea 100644 --- a/misc/pascal/libpoff/pfprivate.h +++ b/misc/pascal/libpoff/pfprivate.h @@ -39,10 +39,6 @@ #define __PFPRIVATE_H /*************************************************************************** - * Compilation Switches - ***************************************************************************/ - -/*************************************************************************** * Included Files ***************************************************************************/ @@ -52,7 +48,7 @@ #include "paslib.h" /* Endian-ness support */ /*************************************************************************** - * Definitions + * Pre-processor Definitions ***************************************************************************/ #define INITIAL_STRING_TABLE_SIZE 4096 diff --git a/misc/pascal/libpoff/pfrdbgfunc.c b/misc/pascal/libpoff/pfrdbgfunc.c index 052bd735cc..0efce43800 100644 --- a/misc/pascal/libpoff/pfrdbgfunc.c +++ b/misc/pascal/libpoff/pfrdbgfunc.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfread.c b/misc/pascal/libpoff/pfread.c index 1c03cd2743..f10dd8c9a6 100644 --- a/misc/pascal/libpoff/pfread.c +++ b/misc/pascal/libpoff/pfread.c @@ -54,7 +54,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfrfname.c b/misc/pascal/libpoff/pfrfname.c index 68fc2fb4c3..20d964a9e2 100644 --- a/misc/pascal/libpoff/pfrfname.c +++ b/misc/pascal/libpoff/pfrfname.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfrhdr.c b/misc/pascal/libpoff/pfrhdr.c index 8415c31fbb..1605511a87 100644 --- a/misc/pascal/libpoff/pfrhdr.c +++ b/misc/pascal/libpoff/pfrhdr.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfrlineno.c b/misc/pascal/libpoff/pfrlineno.c index f7d76a973a..8ca13c5266 100644 --- a/misc/pascal/libpoff/pfrlineno.c +++ b/misc/pascal/libpoff/pfrlineno.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfrrawlineno.c b/misc/pascal/libpoff/pfrrawlineno.c index 9855bc5931..ec2e950c06 100644 --- a/misc/pascal/libpoff/pfrrawlineno.c +++ b/misc/pascal/libpoff/pfrrawlineno.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfrrawreloc.c b/misc/pascal/libpoff/pfrrawreloc.c index 50e6e1bf87..a9f44a89ee 100644 --- a/misc/pascal/libpoff/pfrrawreloc.c +++ b/misc/pascal/libpoff/pfrrawreloc.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfrseek.c b/misc/pascal/libpoff/pfrseek.c index e7c0577809..e3dc1bcc2c 100644 --- a/misc/pascal/libpoff/pfrseek.c +++ b/misc/pascal/libpoff/pfrseek.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfrstring.c b/misc/pascal/libpoff/pfrstring.c index 664620cbbc..2f8c7ae49b 100644 --- a/misc/pascal/libpoff/pfrstring.c +++ b/misc/pascal/libpoff/pfrstring.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfrsymbol.c b/misc/pascal/libpoff/pfrsymbol.c index fe41e43b00..fe22de2706 100644 --- a/misc/pascal/libpoff/pfrsymbol.c +++ b/misc/pascal/libpoff/pfrsymbol.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfswap.c b/misc/pascal/libpoff/pfswap.c index 9c30aad8f2..a33e633c35 100644 --- a/misc/pascal/libpoff/pfswap.c +++ b/misc/pascal/libpoff/pfswap.c @@ -45,7 +45,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pftprog.c b/misc/pascal/libpoff/pftprog.c index 3a7e71e210..a2a16aa3da 100644 --- a/misc/pascal/libpoff/pftprog.c +++ b/misc/pascal/libpoff/pftprog.c @@ -50,7 +50,7 @@ #include "pofflib.h" /* Public interfaces */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pftsymbol.c b/misc/pascal/libpoff/pftsymbol.c index d30de5fb94..a8d9aed8bb 100644 --- a/misc/pascal/libpoff/pftsymbol.c +++ b/misc/pascal/libpoff/pftsymbol.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwdbgfunc.c b/misc/pascal/libpoff/pfwdbgfunc.c index babec18e8d..f6879c0882 100644 --- a/misc/pascal/libpoff/pfwdbgfunc.c +++ b/misc/pascal/libpoff/pfwdbgfunc.c @@ -51,7 +51,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + *Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwfname.c b/misc/pascal/libpoff/pfwfname.c index dde752f5a2..3d2bea32dc 100644 --- a/misc/pascal/libpoff/pfwfname.c +++ b/misc/pascal/libpoff/pfwfname.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwhdr.c b/misc/pascal/libpoff/pfwhdr.c index b8f9983b7a..710721c273 100644 --- a/misc/pascal/libpoff/pfwhdr.c +++ b/misc/pascal/libpoff/pfwhdr.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwlineno.c b/misc/pascal/libpoff/pfwlineno.c index ca72bc1563..1b7cdab15d 100644 --- a/misc/pascal/libpoff/pfwlineno.c +++ b/misc/pascal/libpoff/pfwlineno.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwprog.c b/misc/pascal/libpoff/pfwprog.c index a9cb42e3a0..22d47d49b1 100644 --- a/misc/pascal/libpoff/pfwprog.c +++ b/misc/pascal/libpoff/pfwprog.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwreloc.c b/misc/pascal/libpoff/pfwreloc.c index 21abbb0cbd..db2a2febaf 100644 --- a/misc/pascal/libpoff/pfwreloc.c +++ b/misc/pascal/libpoff/pfwreloc.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwrite.c b/misc/pascal/libpoff/pfwrite.c index 5debe7ec69..916f25dc54 100644 --- a/misc/pascal/libpoff/pfwrite.c +++ b/misc/pascal/libpoff/pfwrite.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwrodata.c b/misc/pascal/libpoff/pfwrodata.c index 882eb94d18..7d059a547e 100644 --- a/misc/pascal/libpoff/pfwrodata.c +++ b/misc/pascal/libpoff/pfwrodata.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwstring.c b/misc/pascal/libpoff/pfwstring.c index b2e58c29a9..9c3d854d75 100644 --- a/misc/pascal/libpoff/pfwstring.c +++ b/misc/pascal/libpoff/pfwstring.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfwsymbol.c b/misc/pascal/libpoff/pfwsymbol.c index 4bfd559b36..534e7651a4 100644 --- a/misc/pascal/libpoff/pfwsymbol.c +++ b/misc/pascal/libpoff/pfwsymbol.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfxprog.c b/misc/pascal/libpoff/pfxprog.c index e580905778..caa1d4864c 100644 --- a/misc/pascal/libpoff/pfxprog.c +++ b/misc/pascal/libpoff/pfxprog.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pfxrodata.c b/misc/pascal/libpoff/pfxrodata.c index b10eea6424..f778ab42b3 100644 --- a/misc/pascal/libpoff/pfxrodata.c +++ b/misc/pascal/libpoff/pfxrodata.c @@ -52,7 +52,7 @@ #include "pfprivate.h" /* POFF private definitions */ /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/libpoff/pofferr.c b/misc/pascal/libpoff/pofferr.c index 87fdc0265b..f32db04752 100644 --- a/misc/pascal/libpoff/pofferr.c +++ b/misc/pascal/libpoff/pofferr.c @@ -48,7 +48,7 @@ #include "perr.h" /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ /********************************************************************** diff --git a/misc/pascal/nuttx/keywords.h b/misc/pascal/nuttx/keywords.h index 2ebfcd8f69..762fa594ed 100644 --- a/misc/pascal/nuttx/keywords.h +++ b/misc/pascal/nuttx/keywords.h @@ -42,7 +42,6 @@ #include <nuttx/config.h>
#include <nuttx/compiler.h>
-#include <sys/types.h>
#include <debug.h>
/*************************************************************
diff --git a/misc/pascal/pascal/pas.c b/misc/pascal/pascal/pas.c index 8b8a03c53d..23cc12b924 100644 --- a/misc/pascal/pascal/pas.c +++ b/misc/pascal/pascal/pas.c @@ -1,536 +1,538 @@ -/**********************************************************************
- * pas.c
- * Main process
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- **********************************************************************/
-
-/**********************************************************************
- * Included Files
- **********************************************************************/
-
-#define _GNU_SOURCE
-#include <stdio.h>
-#include <stdlib.h>
-#include <ctype.h>
-#include <string.h>
-#include <signal.h>
-#include <errno.h>
-
-#include "config.h"
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "podefs.h"
-#include "pedefs.h"
-
-#include "pas.h"
-#include "paslib.h" /* For extension */
-#include "pproc.h" /* For primeBuiltInProcedures */
-#include "pfunc.h" /* For primeBuiltInFunctions */
-#include "ptkn.h" /* For primeTokenizer */
-#include "ptbl.h" /* For primeSymbolTable */
-#include "pofflib.h" /* For poffInitializeForOutput() */
-#include "poff.h" /* For POFF definitions */
-#include "pprgm.h" /* for program() */
-#include "punit.h" /* for unit() */
-#include "perr.h" /* for error() */
-
-/**********************************************************************
- * Definitions
- **********************************************************************/
-
-/**********************************************************************
- * Global Variables
- **********************************************************************/
-
-/* Unitialized Global Data */
-
-uint16 token; /* Current token */
-uint16 tknSubType; /* Extended token type */
-sint32 tknInt; /* Integer token value */
-float64 tknReal; /* Real token value */
-STYPE *tknPtr; /* Pointer to symbol token*/
-WTYPE withRecord; /* RECORD used with WITH statement */
-FTYPE files[MAX_FILES+1]; /* File Table */
-fileState_t fileState[MAX_INCL]; /* State of all open files */
-
-/* sourceFileName : Program name from command line
- * includePath[] : Pathes to search when including file
- */
-
-char *sourceFileName;
-char *includePath[MAX_INCPATHES];
-
-poffHandle_t poffHandle; /* Handle for POFF object */
-
-FILE *poffFile; /* Pass1 POFF output file */
-FILE *lstFile; /* List File pointer */
-FILE *errFile; /* Error file pointer */
-
-/* Initialized Global Data */
-
-sint16 level = 0; /* Static nesting level */
-sint16 includeIndex = 0; /* Include file index */
-sint16 nIncPathes = 0; /* Number pathes in includePath[] */
-uint16 label = 0; /* Last label number */
-sint16 nsym = 0; /* Number symbol table entries */
-sint16 nconst = 0; /* Number constant table entries */
-sint16 sym_strt = 0; /* Symbol search start index */
-sint16 const_strt = 0; /* Constant search start index */
-sint16 err_count = 0; /* Error counter */
-sint16 nfiles = 0; /* Program file counter */
-sint32 warn_count = 0; /* Warning counter */
-sint32 dstack = 0; /* data stack size */
-
-/**********************************************************************
- * Private Type Definitions
- **********************************************************************/
-
-struct outFileDesc_s
-{
- const char *extension;
- const char *flags;
- FILE **stream;
-};
-typedef struct outFileDesc_s outFileDesc_t;
-
-/**********************************************************************
- * Private Variables
- **********************************************************************/
-
-static const outFileDesc_t outFiles[] =
-{
- { "o1", "wb", &poffFile }, /* Pass 1 POFF object file */
-#if LSTTOFILE
- { "lst", "w", &lstFile }, /* List file */
-#endif
- { "err", "w", &errFile }, /* Error file */
- { NULL, NULL } /* (terminates list */
-};
-
-static const char *programName;
-
-/***********************************************************************
- * Private Function Prototypes
- ***********************************************************************/
-
-static void closeFiles(void);
-static void openOutputFiles(void);
-static void showUsage(void);
-static void parseArguments(int argc, char **argv);
-
-/***********************************************************************
- * Private Functions
- ***********************************************************************/
-
-static void closeFiles(void)
-{
- const outFileDesc_t *outFile;
-
- /* Close input source files */
-
- for(; includeIndex >= 0; includeIndex--)
- {
- if (FP->stream)
- {
- (void)fclose(FP->stream);
- FP->stream = NULL;
- }
- }
-
- /* Close output files */
-
- for (outFile = outFiles; outFile->extension; outFile++)
- {
- if (*outFile->stream)
- {
- (void)fclose(*outFile->stream);
- *outFile->stream = NULL;
- }
- }
-}
-
-/***********************************************************************/
-
-static void openOutputFiles(void)
-{
- const outFileDesc_t *outFile;
- char tmpname[FNAME_SIZE+1];
-
- /* Open output files */
-
- for (outFile = outFiles; outFile->extension; outFile++)
- {
- /* Generate an output file name from the source file
- * name and an extension associated with the output file.
- */
-
- (void)extension(sourceFileName, outFile->extension, tmpname, 1);
- *outFile->stream = fopen(tmpname, outFile->flags);
- if (*outFile->stream == NULL)
- {
- fprintf(stderr, "Could not open output file '%s': %s\n",
- tmpname, strerror(errno));
- showUsage();
- }
- }
-}
-
-/***********************************************************************/
-
-static void signalHandler(int signo)
-{
-#ifdef _GNU_SOURCE
- fprintf(errFile, "Received signal: %s\n", strsignal(signo));
- fprintf(lstFile, "Received signal: %s\n", strsignal(signo));
-#else
- fprintf(errFile, "Received signal %d\n", signo);
- fprintf(lstFile, "Received signal %d\n", signo);
-#endif
- closeFiles();
- error(eRCVDSIGNAL);
- exit(1);
-}
-
-/***********************************************************************/
-
-static void primeSignalHandlers(void)
-{
- (void)signal(SIGHUP, signalHandler);
- (void)signal(SIGINT, signalHandler);
- (void)signal(SIGQUIT, signalHandler);
- (void)signal(SIGILL, signalHandler);
- (void)signal(SIGABRT, signalHandler);
- (void)signal(SIGSEGV, signalHandler);
- (void)signal(SIGTERM, signalHandler);
-}
-
-/***********************************************************************/
-
-static void showUsage(void)
-{
- fprintf(stderr, "USAGE:\n");
- fprintf(stderr, " %s [options] <filename>\n", programName);
- fprintf(stderr, "[options]\n");
- fprintf(stderr, " -I<include-path>\n");
- fprintf(stderr, " Search in <include-path> for additional file\n");
- fprintf(stderr, " A maximum of %d pathes may be specified\n",
- MAX_INCPATHES);
- fprintf(stderr, " (default is current directory)\n");
- closeFiles();
- exit(1);
-} /* end showUsage */
-
-/***********************************************************************/
-
-static void parseArguments(int argc, char **argv)
-{
- int i;
-
- programName = argv[0];
-
- /* Check for existence of at least the filename argument */
-
- if (argc < 2)
- {
- fprintf(stderr, "Invalid number of arguments\n");
- showUsage();
- }
-
- /* Parse any optional command line arguments */
-
- for (i = 1; i < argc-1; i++)
- {
- char *ptr = argv[i];
- if (ptr[0] == '-')
- {
- switch (ptr[1])
- {
- case 'I' :
- if (nIncPathes >= MAX_INCPATHES)
- {
- fprintf(stderr, "Unrecognized [option]\n");
- showUsage();
- }
- else
- {
- includePath[nIncPathes] = &ptr[2];
- nIncPathes++;
- }
- break;
- default:
- fprintf(stderr, "Unrecognized [option]\n");
- showUsage();
- }
- }
- else
- {
- fprintf(stderr, "Unrecognized [option]\n");
- showUsage();
- }
- }
-
- /* Extract the Pascal program name from the command line */
-
- sourceFileName = argv[argc-1];
-}
-
-/***********************************************************************
- * Public Functions
- ***********************************************************************/
-
-int main(int argc, char *argv[])
-{
- char filename [FNAME_SIZE+1];
-
- /* Parse command line arguments */
-
- parseArguments(argc, argv);
-
- /* Open all output files */
-
- openOutputFiles();
-
-#if !LSTTOFILE
- lstFile = stdout;
-#endif
-
- /* Open source file -- Use .PAS or command line extension, if supplied */
-
- (void)extension(sourceFileName, "PAS", filename, 0);
- fprintf(errFile, "%01x=%s\n", FP->include, filename);
-
- memset(FP, 0, sizeof(fileState_t));
- FP->stream = fopen(filename, "r");
- if (!FP->stream)
- {
- errmsg("Could not open source file '%s': %s\n",
- filename, strerror(errno));
- showUsage();
- }
-
- /* Initialization */
-
- primeSignalHandlers();
- primeSymbolTable(MAX_SYM);
- primeBuiltInProcedures();
- primeBuiltInFunctions();
- primeTokenizer(MAX_STRINGS);
-
- /* Initialize the POFF object */
-
- poffHandle = poffCreateHandle();
- if (poffHandle == NULL)
- fatal(eNOMEMORY);
-
- /* Save the soure file name in the POFF output file */
-
- FP->include = poffAddFileName(poffHandle, filename);
-
- /* Define standard input/output file characteristics */
-
- files[0].defined = -1;
- files[0].flevel = level;
- files[0].ftype = sCHAR;
- files[0].faddr = dstack;
- files[0].fsize = sCHAR_SIZE;
- dstack += sCHAR_SIZE;
-
- /* We need the following in order to calculate relative stack positions. */
-
- FP->dstack = dstack;
-
- /* Indicate that no WITH statement has been processed */
-
- memset(&withRecord, 0, sizeof(WTYPE));
-
- /* Process the pascal program
- *
- * FORM: pascal = program | unit
- * FORM: program = program-heading ';' [uses-section ] block '.'
- * FORM: program-heading = 'program' identifier [ '(' identifier-list ')' ]
- * FORM: unit = unit-heading ';' interface-section implementation-section init-section
- * FORM: unit-heading = 'unit' identifer
- */
-
- getToken();
- if (token == tPROGRAM)
- {
- /* Compile a pascal program */
-
- FP->kind = eIsProgram;
- FP->section = eIsProgramSection;
- getToken();
- program();
- }
- else if (token == tUNIT)
- {
- /* Compile a pascal unit */
-
- FP->kind = eIsUnit;
- FP->section = eIsOtherSection;
- getToken();
- unitImplementation();
- }
- else
- {
- /* Expected 'program' or 'unit' */
-
- error(ePROGRAM);
- }
-
- /* Dump the symbol table content (debug only) */
-
-#if CONFIG_DEBUG
- dumpTables();
-#endif
-
- /* Write the POFF output file */
-
- poffWriteFile(poffHandle, poffFile);
- poffDestroyHandle(poffHandle);
-
- /* Close all output files */
-
- closeFiles();
-
- /* Write Closing Message */
-
- if (warn_count > 0)
- {
- printf(" %ld Warnings Issued\n", warn_count);
- } /* end if */
-
- if (err_count > 0)
- {
- printf(" %d Errors Detected\n\n", err_count);
- return -1;
- } /* end if */
-
- return 0;
-
-} /* end main */
-
-/***********************************************************************/
-
-void openNestedFile(const char *fileName)
-{
- fileState_t *prev = FP;
- char fullpath[FNAME_SIZE + 1];
- int i;
-
- /* Make sure we can handle another nested file */
-
- if (++includeIndex >= MAX_INCL) fatal(eOVF);
- else
- {
- /* Clear the file state structure for the new include level */
-
- memset(FP, 0, sizeof(fileState_t));
-
- /* Try all source include pathes until we find the file or
- * until we exhaust the include path list.
- */
-
- for (i = 0; ; i++)
- {
- /* Open the nested file -- try all possible pathes or
- * until we successfully open the file.
- */
-
- /* The final path that we will try is the current directory */
-
- if (i == nIncPathes)
- {
- sprintf(fullpath, "./%s", fileName);
- }
- else
- {
- sprintf(fullpath, "%s/%s", includePath[i], fileName);
- }
-
- FP->stream = fopen (fullpath, "rb");
- if (!FP->stream)
- {
- /* We failed to open the file. If there are no more
- * include pathes to examine (including the current directory),
- * then error out. This is fatal. Otherwise, continue
- * looping.
- */
-
- if (i == nIncPathes)
- {
- errmsg("Failed to open '%s': %s\n",
- fileName, strerror(errno));
- fatal(eINCLUDE);
- break; /* Won't get here */
- }
- } /* end else if */
- else
- break;
- }
-
- /* Setup the newly opened file */
-
- fprintf(errFile, "%01x=%s\n", FP->include, fullpath);
- FP->include = poffAddFileName(poffHandle, fullpath);
-
- /* The caller may change this, but the default behavior is
- * to inherit the kind and section of the including file
- * and the current data stack offset.
- */
-
- FP->kind = prev->kind;
- FP->section = prev->section;
- FP->dstack = dstack;
-
- rePrimeTokenizer();
-
- /* Get the first token from the file */
-
- getToken();
- } /* end else */
-}
-
-/***********************************************************************/
-
-void closeNestedFile(void)
-{
- if (FP->stream)
- {
- (void)fclose(FP->stream);
- includeIndex--;
- }
-}
-
-/***********************************************************************/
+/********************************************************************** + * pas.c + * Main process + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + **********************************************************************/ + +/********************************************************************** + * Included Files + **********************************************************************/ + +#define _GNU_SOURCE +#include <sys/types.h> +#include <stdint.h> +#include <stdio.h> +#include <stdlib.h> +#include <ctype.h> +#include <string.h> +#include <signal.h> +#include <errno.h> + +#include "config.h" +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "podefs.h" +#include "pedefs.h" + +#include "pas.h" +#include "paslib.h" /* For extension */ +#include "pproc.h" /* For primeBuiltInProcedures */ +#include "pfunc.h" /* For primeBuiltInFunctions */ +#include "ptkn.h" /* For primeTokenizer */ +#include "ptbl.h" /* For primeSymbolTable */ +#include "pofflib.h" /* For poffInitializeForOutput() */ +#include "poff.h" /* For POFF definitions */ +#include "pprgm.h" /* for program() */ +#include "punit.h" /* for unit() */ +#include "perr.h" /* for error() */ + +/********************************************************************** + * Pre-processor Definitions + **********************************************************************/ + +/********************************************************************** + * Global Variables + **********************************************************************/ + +/* Unitialized Global Data */ + +uint16_t token; /* Current token */ +uint16_t tknSubType; /* Extended token type */ +int32_t tknInt; /* Integer token value */ +double tknReal; /* Real token value */ +STYPE *tknPtr; /* Pointer to symbol token*/ +WTYPE withRecord; /* RECORD used with WITH statement */ +FTYPE files[MAX_FILES+1]; /* File Table */ +fileState_t fileState[MAX_INCL]; /* State of all open files */ + +/* sourceFileName : Program name from command line + * includePath[] : Pathes to search when including file + */ + +char *sourceFileName; +char *includePath[MAX_INCPATHES]; + +poffHandle_t poffHandle; /* Handle for POFF object */ + +FILE *poffFile; /* Pass1 POFF output file */ +FILE *lstFile; /* List File pointer */ +FILE *errFile; /* Error file pointer */ + +/* Initialized Global Data */ + +int16_t level = 0; /* Static nesting level */ +int16_t includeIndex = 0; /* Include file index */ +int16_t nIncPathes = 0; /* Number pathes in includePath[] */ +uint16_t label = 0; /* Last label number */ +int16_t nsym = 0; /* Number symbol table entries */ +int16_t nconst = 0; /* Number constant table entries */ +int16_t sym_strt = 0; /* Symbol search start index */ +int16_t const_strt = 0; /* Constant search start index */ +int16_t err_count = 0; /* Error counter */ +int16_t nfiles = 0; /* Program file counter */ +int32_t warn_count = 0; /* Warning counter */ +int32_t dstack = 0; /* data stack size */ + +/********************************************************************** + * Private Type Definitions + **********************************************************************/ + +struct outFileDesc_s +{ + const char *extension; + const char *flags; + FILE **stream; +}; +typedef struct outFileDesc_s outFileDesc_t; + +/********************************************************************** + * Private Variables + **********************************************************************/ + +static const outFileDesc_t outFiles[] = +{ + { "o1", "wb", &poffFile }, /* Pass 1 POFF object file */ +#if LSTTOFILE + { "lst", "w", &lstFile }, /* List file */ +#endif + { "err", "w", &errFile }, /* Error file */ + { NULL, NULL } /* (terminates list */ +}; + +static const char *programName; + +/*********************************************************************** + * Private Function Prototypes + ***********************************************************************/ + +static void closeFiles(void); +static void openOutputFiles(void); +static void showUsage(void); +static void parseArguments(int argc, char **argv); + +/*********************************************************************** + * Private Functions + ***********************************************************************/ + +static void closeFiles(void) +{ + const outFileDesc_t *outFile; + + /* Close input source files */ + + for(; includeIndex >= 0; includeIndex--) + { + if (FP->stream) + { + (void)fclose(FP->stream); + FP->stream = NULL; + } + } + + /* Close output files */ + + for (outFile = outFiles; outFile->extension; outFile++) + { + if (*outFile->stream) + { + (void)fclose(*outFile->stream); + *outFile->stream = NULL; + } + } +} + +/***********************************************************************/ + +static void openOutputFiles(void) +{ + const outFileDesc_t *outFile; + char tmpname[FNAME_SIZE+1]; + + /* Open output files */ + + for (outFile = outFiles; outFile->extension; outFile++) + { + /* Generate an output file name from the source file + * name and an extension associated with the output file. + */ + + (void)extension(sourceFileName, outFile->extension, tmpname, 1); + *outFile->stream = fopen(tmpname, outFile->flags); + if (*outFile->stream == NULL) + { + fprintf(stderr, "Could not open output file '%s': %s\n", + tmpname, strerror(errno)); + showUsage(); + } + } +} + +/***********************************************************************/ + +static void signalHandler(int signo) +{ +#ifdef _GNU_SOURCE + fprintf(errFile, "Received signal: %s\n", strsignal(signo)); + fprintf(lstFile, "Received signal: %s\n", strsignal(signo)); +#else + fprintf(errFile, "Received signal %d\n", signo); + fprintf(lstFile, "Received signal %d\n", signo); +#endif + closeFiles(); + error(eRCVDSIGNAL); + exit(1); +} + +/***********************************************************************/ + +static void primeSignalHandlers(void) +{ + (void)signal(SIGHUP, signalHandler); + (void)signal(SIGINT, signalHandler); + (void)signal(SIGQUIT, signalHandler); + (void)signal(SIGILL, signalHandler); + (void)signal(SIGABRT, signalHandler); + (void)signal(SIGSEGV, signalHandler); + (void)signal(SIGTERM, signalHandler); +} + +/***********************************************************************/ + +static void showUsage(void) +{ + fprintf(stderr, "USAGE:\n"); + fprintf(stderr, " %s [options] <filename>\n", programName); + fprintf(stderr, "[options]\n"); + fprintf(stderr, " -I<include-path>\n"); + fprintf(stderr, " Search in <include-path> for additional file\n"); + fprintf(stderr, " A maximum of %d pathes may be specified\n", + MAX_INCPATHES); + fprintf(stderr, " (default is current directory)\n"); + closeFiles(); + exit(1); +} /* end showUsage */ + +/***********************************************************************/ + +static void parseArguments(int argc, char **argv) +{ + int i; + + programName = argv[0]; + + /* Check for existence of at least the filename argument */ + + if (argc < 2) + { + fprintf(stderr, "Invalid number of arguments\n"); + showUsage(); + } + + /* Parse any optional command line arguments */ + + for (i = 1; i < argc-1; i++) + { + char *ptr = argv[i]; + if (ptr[0] == '-') + { + switch (ptr[1]) + { + case 'I' : + if (nIncPathes >= MAX_INCPATHES) + { + fprintf(stderr, "Unrecognized [option]\n"); + showUsage(); + } + else + { + includePath[nIncPathes] = &ptr[2]; + nIncPathes++; + } + break; + default: + fprintf(stderr, "Unrecognized [option]\n"); + showUsage(); + } + } + else + { + fprintf(stderr, "Unrecognized [option]\n"); + showUsage(); + } + } + + /* Extract the Pascal program name from the command line */ + + sourceFileName = argv[argc-1]; +} + +/*********************************************************************** + * Public Functions + ***********************************************************************/ + +int main(int argc, char *argv[]) +{ + char filename [FNAME_SIZE+1]; + + /* Parse command line arguments */ + + parseArguments(argc, argv); + + /* Open all output files */ + + openOutputFiles(); + +#if !LSTTOFILE + lstFile = stdout; +#endif + + /* Open source file -- Use .PAS or command line extension, if supplied */ + + (void)extension(sourceFileName, "PAS", filename, 0); + fprintf(errFile, "%01x=%s\n", FP->include, filename); + + memset(FP, 0, sizeof(fileState_t)); + FP->stream = fopen(filename, "r"); + if (!FP->stream) + { + errmsg("Could not open source file '%s': %s\n", + filename, strerror(errno)); + showUsage(); + } + + /* Initialization */ + + primeSignalHandlers(); + primeSymbolTable(MAX_SYM); + primeBuiltInProcedures(); + primeBuiltInFunctions(); + primeTokenizer(MAX_STRINGS); + + /* Initialize the POFF object */ + + poffHandle = poffCreateHandle(); + if (poffHandle == NULL) + fatal(eNOMEMORY); + + /* Save the soure file name in the POFF output file */ + + FP->include = poffAddFileName(poffHandle, filename); + + /* Define standard input/output file characteristics */ + + files[0].defined = -1; + files[0].flevel = level; + files[0].ftype = sCHAR; + files[0].faddr = dstack; + files[0].fsize = sCHAR_SIZE; + dstack += sCHAR_SIZE; + + /* We need the following in order to calculate relative stack positions. */ + + FP->dstack = dstack; + + /* Indicate that no WITH statement has been processed */ + + memset(&withRecord, 0, sizeof(WTYPE)); + + /* Process the pascal program + * + * FORM: pascal = program | unit + * FORM: program = program-heading ';' [uses-section ] block '.' + * FORM: program-heading = 'program' identifier [ '(' identifier-list ')' ] + * FORM: unit = unit-heading ';' interface-section implementation-section init-section + * FORM: unit-heading = 'unit' identifer + */ + + getToken(); + if (token == tPROGRAM) + { + /* Compile a pascal program */ + + FP->kind = eIsProgram; + FP->section = eIsProgramSection; + getToken(); + program(); + } + else if (token == tUNIT) + { + /* Compile a pascal unit */ + + FP->kind = eIsUnit; + FP->section = eIsOtherSection; + getToken(); + unitImplementation(); + } + else + { + /* Expected 'program' or 'unit' */ + + error(ePROGRAM); + } + + /* Dump the symbol table content (debug only) */ + +#if CONFIG_DEBUG + dumpTables(); +#endif + + /* Write the POFF output file */ + + poffWriteFile(poffHandle, poffFile); + poffDestroyHandle(poffHandle); + + /* Close all output files */ + + closeFiles(); + + /* Write Closing Message */ + + if (warn_count > 0) + { + printf(" %ld Warnings Issued\n", warn_count); + } /* end if */ + + if (err_count > 0) + { + printf(" %d Errors Detected\n\n", err_count); + return -1; + } /* end if */ + + return 0; + +} /* end main */ + +/***********************************************************************/ + +void openNestedFile(const char *fileName) +{ + fileState_t *prev = FP; + char fullpath[FNAME_SIZE + 1]; + int i; + + /* Make sure we can handle another nested file */ + + if (++includeIndex >= MAX_INCL) fatal(eOVF); + else + { + /* Clear the file state structure for the new include level */ + + memset(FP, 0, sizeof(fileState_t)); + + /* Try all source include pathes until we find the file or + * until we exhaust the include path list. + */ + + for (i = 0; ; i++) + { + /* Open the nested file -- try all possible pathes or + * until we successfully open the file. + */ + + /* The final path that we will try is the current directory */ + + if (i == nIncPathes) + { + sprintf(fullpath, "./%s", fileName); + } + else + { + sprintf(fullpath, "%s/%s", includePath[i], fileName); + } + + FP->stream = fopen (fullpath, "rb"); + if (!FP->stream) + { + /* We failed to open the file. If there are no more + * include pathes to examine (including the current directory), + * then error out. This is fatal. Otherwise, continue + * looping. + */ + + if (i == nIncPathes) + { + errmsg("Failed to open '%s': %s\n", + fileName, strerror(errno)); + fatal(eINCLUDE); + break; /* Won't get here */ + } + } /* end else if */ + else + break; + } + + /* Setup the newly opened file */ + + fprintf(errFile, "%01x=%s\n", FP->include, fullpath); + FP->include = poffAddFileName(poffHandle, fullpath); + + /* The caller may change this, but the default behavior is + * to inherit the kind and section of the including file + * and the current data stack offset. + */ + + FP->kind = prev->kind; + FP->section = prev->section; + FP->dstack = dstack; + + rePrimeTokenizer(); + + /* Get the first token from the file */ + + getToken(); + } /* end else */ +} + +/***********************************************************************/ + +void closeNestedFile(void) +{ + if (FP->stream) + { + (void)fclose(FP->stream); + includeIndex--; + } +} + +/***********************************************************************/ diff --git a/misc/pascal/pascal/pas.h b/misc/pascal/pascal/pas.h index 8b55187fe5..5c9037ed0a 100644 --- a/misc/pascal/pascal/pas.h +++ b/misc/pascal/pascal/pas.h @@ -1,114 +1,116 @@ -/***************************************************************************
- * pas.h
- * External Declarations associated with pas.c
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************************/
-
-#ifndef __PAS_H
-#define __PAS_H
-
-/***************************************************************************
- * Compilation Switches
- ***************************************************************************/
-
-#define LSTTOFILE 1
-
-/***************************************************************************
- * Included Files
- ***************************************************************************/
-
-#include "pasdefs.h"
-#include "pofflib.h"
-
-/***************************************************************************
- * Definitions
- ***************************************************************************/
-
-/* This is a helper macro just to make things pretty in the source code */
-
-#define FP0 (&fileState[0]) /* Main file description */
-#define FP (&fileState[includeIndex]) /* Current file description */
-#define FPP (&fileState[includeIndex-1]) /* Previous file description */
-#define IS_NESTED_UNIT ((includeIndex > 0) && (FP->kind == eIsUnit))
-
-/***************************************************************************
- * Global Types
- ***************************************************************************/
-
-/***************************************************************************
- * Global Variable
- ***************************************************************************/
-
-extern uint16 token; /* Current token */
-extern uint16 tknSubType; /* Extended token type */
-extern sint32 tknInt; /* Integer token value */
-extern float64 tknReal; /* Real token value */
-extern STYPE *tknPtr; /* Pointer to symbol token */
-extern FTYPE files[MAX_FILES+1]; /* File Table */
-extern fileState_t fileState[MAX_INCL]; /* State of all open files */
-
-/* sourceFileName : Source file name from command line
- * includePath[] : Pathes to search when including file
- */
-
-extern char *sourceFileName;
-extern char *includePath[MAX_INCPATHES];
-
-extern poffHandle_t poffHandle; /* Handle for POFF object */
-
-extern FILE *poffFile; /* POFF output file */
-extern FILE *errFile; /* Error file pointer */
-extern FILE *lstFile; /* List file pointer */
-
-extern WTYPE withRecord; /* RECORD of WITH statement */
-extern sint16 level; /* Static nesting level */
-extern sint16 includeIndex; /* Include file index */
-extern sint16 nIncPathes; /* Number pathes in includePath[] */
-extern uint16 label; /* Last label number */
-extern sint16 nsym; /* Number symbol table entries */
-extern sint16 nconst; /* Number constant table entries */
-extern sint16 sym_strt; /* Symbol search start index */
-extern sint16 const_strt; /* Constant search start index */
-extern sint16 err_count; /* Error counter */
-extern sint16 nfiles; /* Program file counter */
-extern sint32 warn_count; /* Warning counter */
-extern sint32 dstack; /* data stack size */
-
-/***************************************************************************
- * Global Function Prototypes
- ***************************************************************************/
-
-extern void openNestedFile (const char *fileName);
-extern void closeNestedFile (void);
-
-#endif /* __PAS_H */
+/*************************************************************************** + * pas.h + * External Declarations associated with pas.c + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************************/ + +#ifndef __PAS_H +#define __PAS_H + +/*************************************************************************** + * Compilation Switches + ***************************************************************************/ + +#define LSTTOFILE 1 + +/*************************************************************************** + * Included Files + ***************************************************************************/ + +#include <sys/types.h> +#include <stdint.h> +#include "pasdefs.h" +#include "pofflib.h" + +/*************************************************************************** + * Pre-processor Definitions + ***************************************************************************/ + +/* This is a helper macro just to make things pretty in the source code */ + +#define FP0 (&fileState[0]) /* Main file description */ +#define FP (&fileState[includeIndex]) /* Current file description */ +#define FPP (&fileState[includeIndex-1]) /* Previous file description */ +#define IS_NESTED_UNIT ((includeIndex > 0) && (FP->kind == eIsUnit)) + +/*************************************************************************** + * Global Types + ***************************************************************************/ + +/*************************************************************************** + * Global Variable + ***************************************************************************/ + +extern uint16_t token; /* Current token */ +extern uint16_t tknSubType; /* Extended token type */ +extern int32_t tknInt; /* Integer token value */ +extern double tknReal; /* Real token value */ +extern STYPE *tknPtr; /* Pointer to symbol token */ +extern FTYPE files[MAX_FILES+1]; /* File Table */ +extern fileState_t fileState[MAX_INCL]; /* State of all open files */ + +/* sourceFileName : Source file name from command line + * includePath[] : Pathes to search when including file + */ + +extern char *sourceFileName; +extern char *includePath[MAX_INCPATHES]; + +extern poffHandle_t poffHandle; /* Handle for POFF object */ + +extern FILE *poffFile; /* POFF output file */ +extern FILE *errFile; /* Error file pointer */ +extern FILE *lstFile; /* List file pointer */ + +extern WTYPE withRecord; /* RECORD of WITH statement */ +extern int16_t level; /* Static nesting level */ +extern int16_t includeIndex; /* Include file index */ +extern int16_t nIncPathes; /* Number pathes in includePath[] */ +extern uint16_t label; /* Last label number */ +extern int16_t nsym; /* Number symbol table entries */ +extern int16_t nconst; /* Number constant table entries */ +extern int16_t sym_strt; /* Symbol search start index */ +extern int16_t const_strt; /* Constant search start index */ +extern int16_t err_count; /* Error counter */ +extern int16_t nfiles; /* Program file counter */ +extern int32_t warn_count; /* Warning counter */ +extern int32_t dstack; /* data stack size */ + +/*************************************************************************** + * Global Function Prototypes + ***************************************************************************/ + +extern void openNestedFile (const char *fileName); +extern void closeNestedFile (void); + +#endif /* __PAS_H */ diff --git a/misc/pascal/pascal/pasdefs.h b/misc/pascal/pascal/pasdefs.h index 081c32a665..7fc05bf769 100644 --- a/misc/pascal/pascal/pasdefs.h +++ b/misc/pascal/pascal/pasdefs.h @@ -1,281 +1,284 @@ -/***********************************************************************
- * pascal/pasdefs.h
- * General definitions for the Pascal Compiler/Optimizer
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***********************************************************************/
-
-#ifndef __PASDEFS_H
-#define __PASDEFS_H
-
-/***********************************************************************
- * Included Files
- ***********************************************************************/
-
-#include <stdio.h> /* for FILE */
-#include <config.h>
-#include "pdefs.h" /* Common definitions */
-
-/***********************************************************************
- * Definitions
- ***********************************************************************/
-
-/* Size Parameters -- some of these can be overridden from the
- * command line.
- */
-
-#define MAX_SYM (4096)
-#define MAX_STRINGS (65536)
-#define MAX_INCL 3 /* Max number of nested include files */
-#define MAX_FILES 8 /* Max number of opened files */
-#define FNAME_SIZE 40 /* Max size file name */
-#define MAX_INCPATHES 8 /* Max number of include pathes */
-
-/* Bit values for the 'flags' field of the symType_t, symProc_t, and
- * symVar_t (see below)
- */
-
-#define STYPE_VARSIZE 0x01 /* Type has variable size */
-#define SPROC_EXTERNAL 0x01 /* Proc/func. is defined externally */
-#define SVAR_EXTERNAL 0x01 /* Variable is defined externally */
-
-/***********************************************************************
- * Public Enumeration Types
- ***********************************************************************/
-
-/* This enumeration identies what kind of binary object we are creating
- * with the compilation. At present, we may be generating either a
- * program binary or a unit binary.
- */
-
-enum fileKind_e
-{
- eIsProgram = 0,
- eIsUnit
-};
-typedef enum fileKind_e fileKind_t;
-
-/* This enumeration determines what part of a file that we are
- * processing now.
- */
-
-enum fileSection_e
-{
- eIsOtherSection = 0, /* Unspecified part of the file */
- eIsProgramSection, /* Any part of a program file */
- eIsInterfaceSection, /* INTERFACE section of a unit file */
- eIsImplementationSection, /* IMPLEMENTATION section of a unit file */
- eIsInitializationSection, /* INITIALIZATION section of a unit file */
-};
-typedef enum fileSection_e fileSection_t;
-
-/***********************************************************************
- * Public Structure/Types
- ***********************************************************************/
-
-/* Reserved word table entry */
-
-struct R
-{
- char *rname; /* pointer to name in string stack */
- ubyte rtype; /* reserved word type */
- ubyte subtype; /* reserved word extended type */
-};
-typedef struct R RTYPE;
-
-/* Symbol table entry */
-
-struct symType_s /* for sKind = sTYPE */
-{
- ubyte type; /* specific type */
- ubyte rtype; /* reference to type */
- ubyte subType; /* constant type for subrange types */
- ubyte flags; /* flags to customize a type (see above) */
- uint32 asize; /* size of allocated instances of this type */
- uint32 rsize; /* size of reference to an instances of this type */
- sint32 minValue; /* minimum value taken subrange */
- sint32 maxValue; /* maximum value taken by subrange or scalar */
- struct S *parent; /* pointer to parent type */
-};
-typedef struct symType_s symType_t;
-
-struct symConst_s /* for sKind == constant type */
-{
- union
- {
- float64 f; /* real value */
- sint32 i; /* integer value */
- } val;
- struct S *parent; /* pointer to parent type */
-};
-typedef struct symConst_s symConst_t;
-
-struct symStringConst_s /* for sKind == sSTRING_CONST */
-{
- uint32 offset; /* RO data section offset of string */
- uint32 size; /* length of string in bytes */
-};
-typedef struct symStringConst_s symStringConst_t;
-
-struct symVarString_s /* for sKind == sSTRING */
-{
- uint16 label; /* label at string declaration */
- uint16 size; /* valid length of string in bytes */
- uint16 alloc; /* max length of string in bytes */
-};
-typedef struct symVarString_s symVarString_t;
-
-struct symLabel_s /* for sKind == sLABEL */
-{
- uint16 label; /* label number */
- boolean unDefined; /* set false when defined */
-};
-typedef struct symLabel_s symLabel_t;
-
-struct symVar_s /* for sKind == type identifier */
-{
- sint32 offset; /* Data stack offset */
- uint32 size; /* Size of variable */
- ubyte flags; /* flags to customize a variable (see above) */
- uint32 symIndex; /* POFF symbol table index (if undefined) */
- struct S *parent; /* pointer to parent type */
-};
-typedef struct symVar_s symVar_t;
-
-struct symProc_s /* for sKind == sPROC or sFUNC */
-{
- uint16 label; /* entry point label */
- uint16 nParms; /* number of parameters that follow */
- ubyte flags; /* flags to customize a proc/func (see above) */
- uint32 symIndex; /* POFF symbol table index (if undefined) */
- struct S *parent; /* pointer to parent type (sFUNC only) */
-};
-typedef struct symProc_s symProc_t;
-
-struct symRecord_s /* for sKind == sRECORD_OBJECT */
-{
- uint32 size; /* size of this field */
- uint32 offset; /* offset into the RECORD */
- struct S *record; /* pointer to parent sRECORD type */
- struct S *parent; /* pointer to parent field type */
-};
-typedef struct symRecord_s symRecord_t;
-
-struct S
-{
- char *sName; /* pointer to name in string stack */
- ubyte sKind; /* kind of symbol */
- ubyte sLevel; /* static nesting level */
- union
- {
- symType_t t; /* for type definitions */
- symConst_t c; /* for constants */
- symStringConst_t s; /* for strings of constant size*/
- symVarString_t vs; /* for strings of variable size*/
- uint16 fileNumber; /* for files */
- symLabel_t l; /* for labels */
- symVar_t v; /* for variables */
- symProc_t p; /* for functions & procedures */
- symRecord_t r; /* for files of RECORDS */
- } sParm;
-};
-typedef struct S STYPE;
-
-/* WITH structure */
-
-struct W
-{
- ubyte level; /* static nesting level */
- boolean pointer; /* TRUE if offset is to pointer to RECORD */
- boolean varParm; /* TRUE if VAR param (+pointer) */
- sint32 offset; /* Data stack offset */
- uint16 index; /* RECORD offset (if pointer) */
- STYPE *parent; /* pointer to parent RECORD type */
-};
-typedef struct W WTYPE;
-
-/* File table record */
-
-struct F
-{
- sint16 defined;
- sint16 flevel;
- sint16 ftype;
- sint32 faddr;
- sint16 fsize;
-};
-typedef struct F FTYPE;
-
-/* This structure captures the parsing state of the compiler for a particular
- * file. Since multiple, nested files can be processed, this represents
- * only level in the "stack" of nested files.
- */
-
-struct fileState_s
-{
- /* These fields are managed by the higher level parsing logic
- *
- * stream - Stream pointer the input stream associated with this
- * file.
- * kind - Kind of file we are processing. If include > 0,
- * this should be eIsUnit.
- * section - This is the part of the program that we are parsing
- * now.
- * dstack - Level zero dstack offset at the time the unit was
- * included. This is used to convert absolute program
- * stack offsets into relative unit stack offsets.
- * include - Is a unique number that identifies the file. In
- * POFF ouput file, this would be the index to the
- * entry in the .files section.
- */
-
- FILE *stream;
- fileKind_t kind;
- fileSection_t section;
- sint32 dstack;
- sint16 include;
-
- /* These fields are managed by the tokenizer. These are all
- * initialized by primeTokenizer().
- *
- * buffer[] - Holds the current input line
- * line - Is the line number in this file for the current line
- * cp - Is the current pointer into buffer[]
- */
-
- uint32 line;
- unsigned char *cp;
- unsigned char buffer[LINE_SIZE + 1];
-};
-typedef struct fileState_s fileState_t;
-
-#endif /* __PASDEFS_H */
+/*********************************************************************** + * pascal/pasdefs.h + * General definitions for the Pascal Compiler/Optimizer + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***********************************************************************/ + +#ifndef __PASDEFS_H +#define __PASDEFS_H + +/*********************************************************************** + * Included Files + ***********************************************************************/ + +#include <sys/types.h> +#include <stdint.h> +#include <stdbool.h> +#include <stdio.h> /* for FILE */ +#include <config.h> +#include "pdefs.h" /* Common definitions */ + +/*********************************************************************** + * Pre-processor Definitions + ***********************************************************************/ + +/* Size Parameters -- some of these can be overridden from the + * command line. + */ + +#define MAX_SYM (4096) +#define MAX_STRINGS (65536) +#define MAX_INCL 3 /* Max number of nested include files */ +#define MAX_FILES 8 /* Max number of opened files */ +#define FNAME_SIZE 40 /* Max size file name */ +#define MAX_INCPATHES 8 /* Max number of include pathes */ + +/* Bit values for the 'flags' field of the symType_t, symProc_t, and + * symVar_t (see below) + */ + +#define STYPE_VARSIZE 0x01 /* Type has variable size */ +#define SPROC_EXTERNAL 0x01 /* Proc/func. is defined externally */ +#define SVAR_EXTERNAL 0x01 /* Variable is defined externally */ + +/*********************************************************************** + * Public Enumeration Types + ***********************************************************************/ + +/* This enumeration identies what kind of binary object we are creating + * with the compilation. At present, we may be generating either a + * program binary or a unit binary. + */ + +enum fileKind_e +{ + eIsProgram = 0, + eIsUnit +}; +typedef enum fileKind_e fileKind_t; + +/* This enumeration determines what part of a file that we are + * processing now. + */ + +enum fileSection_e +{ + eIsOtherSection = 0, /* Unspecified part of the file */ + eIsProgramSection, /* Any part of a program file */ + eIsInterfaceSection, /* INTERFACE section of a unit file */ + eIsImplementationSection, /* IMPLEMENTATION section of a unit file */ + eIsInitializationSection, /* INITIALIZATION section of a unit file */ +}; +typedef enum fileSection_e fileSection_t; + +/*********************************************************************** + * Public Structure/Types + ***********************************************************************/ + +/* Reserved word table entry */ + +struct R +{ + char *rname; /* pointer to name in string stack */ + uint8_t rtype; /* reserved word type */ + uint8_t subtype; /* reserved word extended type */ +}; +typedef struct R RTYPE; + +/* Symbol table entry */ + +struct symType_s /* for sKind = sTYPE */ +{ + uint8_t type; /* specific type */ + uint8_t rtype; /* reference to type */ + uint8_t subType; /* constant type for subrange types */ + uint8_t flags; /* flags to customize a type (see above) */ + uint32_t asize; /* size of allocated instances of this type */ + uint32_t rsize; /* size of reference to an instances of this type */ + int32_t minValue; /* minimum value taken subrange */ + int32_t maxValue; /* maximum value taken by subrange or scalar */ + struct S *parent; /* pointer to parent type */ +}; +typedef struct symType_s symType_t; + +struct symConst_s /* for sKind == constant type */ +{ + union + { + double f; /* real value */ + int32_t i; /* integer value */ + } val; + struct S *parent; /* pointer to parent type */ +}; +typedef struct symConst_s symConst_t; + +struct symStringConst_s /* for sKind == sSTRING_CONST */ +{ + uint32_t offset; /* RO data section offset of string */ + uint32_t size; /* length of string in bytes */ +}; +typedef struct symStringConst_s symStringConst_t; + +struct symVarString_s /* for sKind == sSTRING */ +{ + uint16_t label; /* label at string declaration */ + uint16_t size; /* valid length of string in bytes */ + uint16_t alloc; /* max length of string in bytes */ +}; +typedef struct symVarString_s symVarString_t; + +struct symLabel_s /* for sKind == sLABEL */ +{ + uint16_t label; /* label number */ + bool unDefined; /* set false when defined */ +}; +typedef struct symLabel_s symLabel_t; + +struct symVar_s /* for sKind == type identifier */ +{ + int32_t offset; /* Data stack offset */ + uint32_t size; /* Size of variable */ + uint8_t flags; /* flags to customize a variable (see above) */ + uint32_t symIndex; /* POFF symbol table index (if undefined) */ + struct S *parent; /* pointer to parent type */ +}; +typedef struct symVar_s symVar_t; + +struct symProc_s /* for sKind == sPROC or sFUNC */ +{ + uint16_t label; /* entry point label */ + uint16_t nParms; /* number of parameters that follow */ + uint8_t flags; /* flags to customize a proc/func (see above) */ + uint32_t symIndex; /* POFF symbol table index (if undefined) */ + struct S *parent; /* pointer to parent type (sFUNC only) */ +}; +typedef struct symProc_s symProc_t; + +struct symRecord_s /* for sKind == sRECORD_OBJECT */ +{ + uint32_t size; /* size of this field */ + uint32_t offset; /* offset into the RECORD */ + struct S *record; /* pointer to parent sRECORD type */ + struct S *parent; /* pointer to parent field type */ +}; +typedef struct symRecord_s symRecord_t; + +struct S +{ + char *sName; /* pointer to name in string stack */ + uint8_t sKind; /* kind of symbol */ + uint8_t sLevel; /* static nesting level */ + union + { + symType_t t; /* for type definitions */ + symConst_t c; /* for constants */ + symStringConst_t s; /* for strings of constant size*/ + symVarString_t vs; /* for strings of variable size*/ + uint16_t fileNumber; /* for files */ + symLabel_t l; /* for labels */ + symVar_t v; /* for variables */ + symProc_t p; /* for functions & procedures */ + symRecord_t r; /* for files of RECORDS */ + } sParm; +}; +typedef struct S STYPE; + +/* WITH structure */ + +struct W +{ + uint8_t level; /* static nesting level */ + bool pointer; /* true if offset is to pointer to RECORD */ + bool varParm; /* true if VAR param (+pointer) */ + int32_t offset; /* Data stack offset */ + uint16_t index; /* RECORD offset (if pointer) */ + STYPE *parent; /* pointer to parent RECORD type */ +}; +typedef struct W WTYPE; + +/* File table record */ + +struct F +{ + int16_t defined; + int16_t flevel; + int16_t ftype; + int32_t faddr; + int16_t fsize; +}; +typedef struct F FTYPE; + +/* This structure captures the parsing state of the compiler for a particular + * file. Since multiple, nested files can be processed, this represents + * only level in the "stack" of nested files. + */ + +struct fileState_s +{ + /* These fields are managed by the higher level parsing logic + * + * stream - Stream pointer the input stream associated with this + * file. + * kind - Kind of file we are processing. If include > 0, + * this should be eIsUnit. + * section - This is the part of the program that we are parsing + * now. + * dstack - Level zero dstack offset at the time the unit was + * included. This is used to convert absolute program + * stack offsets into relative unit stack offsets. + * include - Is a unique number that identifies the file. In + * POFF ouput file, this would be the index to the + * entry in the .files section. + */ + + FILE *stream; + fileKind_t kind; + fileSection_t section; + int32_t dstack; + int16_t include; + + /* These fields are managed by the tokenizer. These are all + * initialized by primeTokenizer(). + * + * buffer[] - Holds the current input line + * line - Is the line number in this file for the current line + * cp - Is the current pointer into buffer[] + */ + + uint32_t line; + unsigned char *cp; + unsigned char buffer[LINE_SIZE + 1]; +}; +typedef struct fileState_s fileState_t; + +#endif /* __PASDEFS_H */ diff --git a/misc/pascal/pascal/pblck.c b/misc/pascal/pascal/pblck.c index f3abfb78bc..19b8150385 100644 --- a/misc/pascal/pascal/pblck.c +++ b/misc/pascal/pascal/pblck.c @@ -1,2263 +1,2263 @@ -/***************************************************************
- * pblck.c
- * Process a Pascal Block
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************/
-
-/***************************************************************
- * Included Files
- ***************************************************************/
-
-#include <stdio.h>
-#include <string.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "pedefs.h"
-#include "podefs.h"
-
-#include "pas.h"
-#include "pblck.h"
-#include "pexpr.h"
-#include "pstm.h"
-#include "pgen.h"
-#include "ptkn.h"
-#include "ptbl.h"
-#include "pinsn.h"
-#include "perr.h"
-
-/***************************************************************
- * Private Definitions
- ***************************************************************/
-
-/* This macro implements a test for:
- * FORM: unsigned-constant = integer-number | real-number |
- * character-literal | string-literal | constant-identifier |
- * 'nil'
- */
-
-#define isConstant(x) \
- ( ((x) == tINT_CONST) \
- || ((x) == tBOOLEAN_CONST) \
- || ((x) == tCHAR_CONST) \
- || ((x) == tREAL_CONST) \
- || ((x) == sSCALAR_OBJECT))
-
-#define isIntAligned(x) (((x) & (sINT_SIZE-1)) == 0)
-#define intAlign(x) (((x) + (sINT_SIZE-1)) & (~(sINT_SIZE-1)))
-
-/***************************************************************
- * Private Function Prototypes
- ***************************************************************/
-
-static void pas_DeclareLabel (void);
-static void pas_DeclareConst (void);
-static STYPE *pas_DeclareType (char *typeName);
-static STYPE *pas_DeclareOrdinalType (char *typeName);
-static STYPE *pas_DeclareVar (void);
-static void pas_DeclareFile (void);
-static void pas_ProcedureDeclaration (void);
-static void pas_FunctionDeclaration (void);
-
-static void pas_SetTypeSize (STYPE *typePtr, boolean allocate);
-static STYPE *pas_TypeIdentifier (boolean allocate);
-static STYPE *pas_TypeDenoter (char *typeName, boolean allocate);
-static STYPE *pas_NewComplexType (char *typeName);
-static STYPE *pas_NewOrdinalType (char *typeName);
-static STYPE *pas_OrdinalTypeIdentifier (boolean allocate);
-static STYPE *pas_GetArrayType (void);
-static STYPE *pas_DeclareRecord (char *recordName);
-static STYPE *pas_DeclareField (STYPE *recordPtr);
-static STYPE *pas_DeclareParameter (boolean pointerType);
-static boolean pas_IntAlignRequired (STYPE *typePtr);
-
-/***************************************************************
- * Private Global Variables
- ***************************************************************/
-
-static sint32 g_nParms;
-static sint32 g_dwVarSize;
-
-/***************************************************************
- * Public Functions
- ***************************************************************/
-/* Process BLOCK. This function implements:
- *
- * block = declaration-group compound-statement
- *
- * Where block can appear in the followinging:
- *
- * function-block = block
- * function-declaration =
- * function-heading ';' directive |
- * function-heading ';' function-block
- *
- * procedure-block = block
- * procedure-declaration =
- * procedure-heading ';' directive |
- * procedure-heading ';' procedure-block
- *
- * program = program-heading ';' [ uses-section ] block '.'
- */
-
-void block()
-{
- uint16 beginLabel = ++label; /* BEGIN label */
- sint32 saveDStack = dstack; /* Save DSEG size */
- char *saveStringSP = stringSP; /* Save top of string stack */
- sint16 saveNSym = nsym; /* Save top of symbol table */
- sint16 saveNConst = nconst; /* Save top of constant table */
- register sint16 i;
-
- TRACE(lstFile,"[block]");
-
- /* When we enter block at level zero, then we must be at the
- * entry point to the program. Save the entry point label
- * in the POFF file.
- */
-
- if ((level == 0) && (FP0->kind == eIsProgram))
- {
- poffSetEntryPoint(poffHandle, label);
- }
-
- /* Init size of the new DSEG */
-
- dstack = 0;
-
- /* FORM: block = declaration-group compound-statement
- * Process the declaration-group
- *
- * declaration-group =
- * label-declaration-group |
- * constant-definition-group |
- * type-definition-group |
- * variable-declaration-group |
- * function-declaration |
- * procedure-declaration
- */
-
- declarationGroup(beginLabel);
-
- /* Process the compound-statement
- *
- * FORM: compound-statement = 'begin' statement-sequence 'end'
- */
-
- /* Verify that the compound-statement begins with BEGIN */
-
- if (token != tBEGIN)
- {
- error (eBEGIN);
- }
-
- /* It may be necessary to jump around some local functions to
- * get to the main body of the block. If any jumps are generated,
- * they will come to the beginLabel emitted here.
- */
-
- pas_GenerateDataOperation(opLABEL, (sint32)beginLabel);
-
- /* Since we don't know for certain how we got here, invalidate
- * the level stack pointer (LSP). This is, of course, only
- * meaningful on architectures that implement an LSP.
- */
-
- pas_InvalidateCurrentStackLevel();
-
- /* Then emit the compoundStatement itself */
-
- if (dstack)
- {
- pas_GenerateDataOperation(opINDS, (sint32)dstack);
- }
-
- compoundStatement();
-
- if (dstack)
- {
- pas_GenerateDataOperation(opINDS, -(sint32)dstack);
- }
-
- /* Make sure all declared labels were defined in the block */
-
- verifyLabels(saveNSym);
-
- /* Re-initialize file table -- clear files defined in this level */
-
- for (i = 0; i <= MAX_FILES; i++)
- {
- if ((files [i].defined) && (files [i].flevel >= level)) {
- files [i].defined = 0;
- files [i].flevel = 0;
- files [i].ftype = 0;
- files [i].faddr = 0;
- files [i].fsize = 0;
- }
- }
-
- /* "Pop" declarations local to this block */
-
- dstack = saveDStack; /* Restore old DSEG size */
- stringSP = saveStringSP; /* Restore top of string stack */
- nsym = saveNSym; /* Restore top of symbol table */
- nconst = saveNConst; /* Restore top of constant table */
-}
-
-/***************************************************************/
-/* Process declarative-part */
-
-void declarationGroup(sint32 beginLabel)
-{
- sint16 notFirst = 0; /* Init count of nested procs */
- sint16 saveNSym = nsym; /* Save top of symbol table */
- sint16 saveNConst = nconst; /* Save top of constant table */
-
- TRACE(lstFile,"[declarationGroup]");
-
- /* FORM: declarative-part = { declaration-group }
- * FORM: declaration-group =
- * label-declaration-group | constant-definition-group |
- * type-definition-group | variable-declaration-group |
- * function-declaration | procedure-declaration
- */
-
- /* Process label-declaration-group.
- * FORM: label-declaration-group = 'label' label { ',' label } ';'
- */
-
- if (token == tLABEL) pas_DeclareLabel();
-
- /* Process constant-definition-group.
- * FORM: constant-definition-group =
- * 'const' constant-definition ';' { constant-definition ';' }
- */
-
- if (token == tCONST)
- {
- const_strt = saveNConst; /* Limit search to present level */
- getToken(); /* Get identifier */
- const_strt = 0;
-
- /* Process constant-definition.
- * FORM: constant-definition = identifier '=' constant
- */
-
- constantDefinitionGroup();
- }
-
- /* Process type-definition-group
- * FORM: type-definition-group =
- * 'type' type-definition ';' { type-definition ';' }
- */
-
- if (token == tTYPE)
- {
- const_strt = saveNConst; /* Limit search to present level */
- sym_strt = saveNSym;
- getToken(); /* Get identifier */
- const_strt = 0;
- sym_strt = 0;
-
- /* Process the type-definitions in the type-definition-group
- * FORM: type-definition = identifier '=' type-denoter
- */
-
- typeDefinitionGroup();
- }
-
- /* Process variable-declaration-group
- * FORM: variable-declaration-group =
- * 'var' variable-declaration { ';' variable-declaration }
- */
-
- if (token == tVAR)
- {
- const_strt = saveNConst; /* Limit search to present level */
- sym_strt = saveNSym;
- getToken(); /* Get identifier */
- const_strt = 0;
- sym_strt = 0;
-
- /* Process the variable declarations
- * FORM: variable-declaration = identifier-list ':' type-denoter
- * FORM: identifier-list = identifier { ',' identifier }
- */
-
- variableDeclarationGroup();
- }
-
- /* Process procedure/function-declaration(s) if present
- * FORM: function-declaration =
- * function-heading ';' directive |
- * function-heading ';' function-block
- * FORM: procedure-declaration =
- * procedure-heading ';' directive |
- * procedure-heading ';' procedure-block
- *
- * NOTE: a JMP to the executable body of this block is generated
- * if there are nested procedures and this is not level=0
- */
-
- for (;;)
- {
- /* FORM: function-heading =
- * 'function' identifier [ formal-parameter-list ] ':' result-type
- */
-
- if (token == tFUNCTION)
- {
- /* Check if we need to put a jump around the function */
-
- if ((beginLabel > 0) && !(notFirst) && (level > 0))
- {
- pas_GenerateDataOperation(opJMP, (sint32)beginLabel);
- }
-
- /* Get the procedure-identifier */
-
- const_strt = saveNConst; /* Limit search to present level */
- sym_strt = saveNSym;
- getToken(); /* Get identifier */
- const_strt = 0;
- sym_strt = 0;
-
- /* Define the function */
-
- pas_FunctionDeclaration();
- notFirst++; /* No JMP next time */
- }
-
- /* FORM: procedure-heading =
- * 'procedure' identifier [ formal-parameter-list ]
- */
-
- else if (token == tPROCEDURE)
- {
- /* Check if we need to put a jump around the function */
-
- if ((beginLabel > 0) && !(notFirst) && (level > 0))
- {
- pas_GenerateDataOperation(opJMP, (sint32)beginLabel);
- }
-
- /* Get the procedure-identifier */
-
- const_strt = saveNConst; /* Limit search to present level */
- sym_strt = saveNSym;
- getToken(); /* Get identifier */
- const_strt = 0;
- sym_strt = 0;
-
- /* Define the procedure */
-
- pas_ProcedureDeclaration();
- notFirst++; /* No JMP next time */
- }
- else break;
- }
-}
-
-/***************************************************************/
-
-void constantDefinitionGroup(void)
-{
- /* Process constant-definition-group.
- * FORM: constant-definition-group =
- * 'const' constant-definition ';' { constant-definition ';' }
- * FORM: constant-definition = identifier '=' constant
- *
- * On entry, token should point to the identifier of the first
- * constant-definition.
- */
-
- for (;;)
- {
- if (token == tIDENT)
- {
- pas_DeclareConst();
- if (token != ';') break;
- else getToken();
- }
- else break;
- }
-}
-
-/***************************************************************/
-
-void typeDefinitionGroup(void)
-{
- char *typeName;
-
- /* Process type-definition-group
- * FORM: type-definition-group =
- * 'type' type-definition ';' { type-definition ';' }
- * FORM: type-definition = identifier '=' type-denoter
- *
- * On entry, token refers to the first identifier (if any) of
- * the type-definition list.
- */
-
- for (;;)
- {
- if (token == tIDENT)
- {
- /* Save the type identifier */
-
- typeName = tkn_strt;
- getToken();
-
- /* Verify that '=' follows the type identifier */
-
- if (token != '=') error (eEQ);
- else getToken();
-
- (void)pas_DeclareType(typeName);
- if (token != ';') break;
- else getToken();
-
- }
- else break;
- }
-}
-
-/***************************************************************/
-
-void variableDeclarationGroup(void)
-{
- /* Process variable-declaration-group
- * FORM: variable-declaration-group =
- * 'var' variable-declaration { ';' variable-declaration }
- * FORM: variable-declaration = identifier-list ':' type-denoter
- * FORM: identifier-list = identifier { ',' identifier }
- *
- * Only entry, token holds the first identfier (if any) of the
- * variable-declaration list.
- */
-
- for (;;)
- {
- if (token == tIDENT)
- {
- (void)pas_DeclareVar();
- if (token != ';') break;
- else getToken();
- }
- else if (token == sFILE)
- {
- pas_DeclareFile();
- if (token != ';') break;
- else getToken();
- }
- else break;
- }
-}
-
-/***************************************************************/
-/* Process formal-parameter-list */
-
-sint16 formalParameterList(STYPE *procPtr)
-{
- sint16 parameterOffset;
- sint16 i;
- boolean pointerType;
-
- TRACE(lstFile,"[formalParameterList]");
-
- /* FORM: formal-parameter-list =
- * '(' formal-parameter-section { ';' formal-parameter-section } ')'
- * FORM: formal-parameter-section =
- * value-parameter-specification |
- * variable-parameter-specification |
- * procedure-parameter-specification |
- * function-parameter-specification
- * FORM: value-parameter-specification =
- * identifier-list ':' type-identifier
- * FORM: variable-parameter-specification =
- * 'var' identifier-list ':' type-identifier
- *
- * On entry token should refer to the '(' at the beginning of the
- * (optional) formal parameter list.
- */
-
- g_nParms = 0;
-
- /* Check if the formal-parameter-list is present. It is optional in
- * all contexts in which this function is called.
- */
-
- if (token == '(')
- {
- /* Process each formal-parameter-section */
-
- do
- {
- getToken();
-
- /* Check for variable-parameter-specification */
-
- if (token == tVAR)
- {
- pointerType = 1;
- getToken();
- }
- else pointerType = 0;
-
- /* Process the common part of the variable-parameter-specification
- * and the value-parameter specification.
- * NOTE that procedure-parameter-specification and
- * function-parameter-specification are not yet supported.
- */
-
- (void)pas_DeclareParameter(pointerType);
-
- }
- while (token == ';');
-
- /* Verify that the formal parameter list terminates with a
- * right parenthesis.
- */
-
- if (token != ')') error (eRPAREN);
- else getToken();
-
- }
-
- /* Save the number of parameters found in sPROC/sFUNC symbol table entry */
-
- procPtr->sParm.p.nParms = g_nParms;
-
- /* Now, calculate the parameter offsets from the size of each parameter */
-
- parameterOffset = -sRETURN_SIZE;
- for (i = g_nParms; i > 0; i--)
- {
- /* The offset to the next parameter is the offset to the previous
- * parameter minus the size of the new parameter (aligned to
- * multiples of size of INTEGER).
- */
-
- parameterOffset -= procPtr[i].sParm.v.size;
- parameterOffset = intAlign(parameterOffset);
- procPtr[i].sParm.v.offset = parameterOffset;
- }
-
- return parameterOffset;
-}
-
-/***************************************************************
- * Private Functions
- ***************************************************************/
-/* Process LABEL block */
-
-static void pas_DeclareLabel(void)
-{
- char *labelname; /* Label symbol table name */
-
- TRACE(lstFile,"[pas_DeclareLabel]");
-
- /* FORM: LABEL <integer>[,<integer>[,<integer>][...]]]; */
-
- do
- {
- getToken();
- if ((token == tINT_CONST) && (tknInt >= 0))
- {
- labelname = stringSP;
- (void)sprintf (labelname, "%ld", tknInt);
- while (*stringSP++);
- (void)addLabel(labelname, ++label);
- getToken();
- }
- else error(eINTCONST);
- }
- while (token == ',');
-
- if (token != ';') error (eSEMICOLON);
- else getToken();
-}
-
-/***************************************************************/
-/* Process constant definition:
- * FORM: constant-definition = identifier '=' constant
- * FORM: constant = [ sign ] integer-number |
- * [ sign ] real-number |
- * [ sign ] constant-identifier |
- * character-literal |
- * string-literal
- */
-
-static void pas_DeclareConst(void)
-{
- char *const_name;
-
- TRACE(lstFile,"[pas_DeclareConst]");
-
- /* FORM: <identifier> = <numeric constant|string>
- * NOTE: Only integer constants are supported
- */
-
- /* Save the name of the constant */
-
- const_name = tkn_strt;
-
- /* Verify that the name is followed by '=' and get the
- * following constant value.
- */
-
- getToken();
- if (token != '=') error (eEQ);
- else getToken();
-
- /* Handle constant expressions */
-
- constantExpression();
-
- /* Add the constant to the symbol table based on the type of
- * the constant found following the '= [ sign ]'
- */
-
- switch (constantToken)
- {
- case tINT_CONST :
- case tCHAR_CONST :
- case tBOOLEAN_CONST :
- case sSCALAR_OBJECT :
- (void)addConstant(const_name, constantToken, &constantInt, NULL);
- break;
-
- case tREAL_CONST :
- (void)addConstant(const_name, constantToken, (sint32*)&constantReal, NULL);
- break;
-
- case tSTRING_CONST :
- {
- uint32 offset = poffAddRoDataString(poffHandle, constantStart);
- (void)addStringConst(const_name, offset, strlen(constantStart));
- }
- break;
-
- default :
- error(eINVCONST);
- }
-}
-
-/***************************************************************/
-/* Process TYPE declaration */
-
-static STYPE *pas_DeclareType(char *typeName)
-{
- STYPE *typePtr;
-
- TRACE(lstFile,"[pas_DeclareType]");
-
- /* This function processes the type-denoter in
- * FORM: type-definition = identifier '=' type-denoter
- * FORM: array-type = 'array' '[' index-type-list ']' 'of' type-denoter
- */
-
- /* FORM: type-denoter = type-identifier | new-type
- * FORM: new-type = new-ordinal-type | new-complex-type
- */
-
- typePtr = pas_NewComplexType(typeName);
- if (typePtr == NULL)
- {
- /* Check for Simple Types */
-
- typePtr = pas_DeclareOrdinalType(typeName);
- if (typePtr == NULL)
- {
- error(eINVTYPE);
- }
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-/* Process a simple TYPE declaration */
-
-static STYPE *pas_DeclareOrdinalType(char *typeName)
-{
- STYPE *typePtr;
- STYPE *typeIdPtr;
-
- /* Declare a new ordinal type */
-
- typePtr = pas_NewOrdinalType(typeName);
-
- /* Otherwise, declare a type equivalent to a previously defined type
- * NOTE: the following logic is incomplete. Its is only good for
- * sKind == sType
- */
-
- if (typePtr == NULL)
- {
- typeIdPtr = pas_TypeIdentifier(1);
- if (typeIdPtr)
- {
- typePtr = addTypeDefine(typeName, typeIdPtr->sParm.t.type,
- g_dwVarSize, typeIdPtr);
- }
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-/* Process VAR declaration */
-
-static STYPE *pas_DeclareVar(void)
-{
- STYPE *varPtr;
- STYPE *typePtr;
- char *varName;
-
- TRACE(lstFile,"[pas_DeclareVar]");
-
- /* FORM: variable-declaration = identifier-list ':' type-denoter
- * FORM: identifier-list = identifier { ',' identifier }
- */
-
- typePtr = NULL;
-
- /* Save the current identifier */
-
- varName = tkn_strt;
- getToken();
-
- /* A comma indicates that there is another indentifier int the
- * identifier-list
- */
-
- if (token == ',')
- {
- /* Yes ..Process the next identifer in the indentifier list
- * via recursion
- */
-
- getToken();
- if (token != tIDENT) error(eIDENT);
- else typePtr = pas_DeclareVar();
- }
- else
- {
- /* No.. verify that the identifer-list is followed by ';' */
-
- if (token != ':') error(eCOLON);
- else getToken();
-
- /* Process the type-denoter */
-
- typePtr = pas_TypeDenoter(varName, 1);
- if (typePtr == NULL)
- {
- error(eINVTYPE);
- }
- }
-
- if (typePtr)
- {
- ubyte varType = typePtr->sParm.t.type;
-
- /* Determine if alignment to INTEGER boundaries is necessary */
-
- if ((!isIntAligned(dstack)) && (pas_IntAlignRequired(typePtr)))
- dstack = intAlign(dstack);
-
- /* Add the new variable to the symbol table */
-
- varPtr = addVariable(varName, varType, dstack, g_dwVarSize, typePtr);
-
- /* If the variable is declared in an interface section at level zero,
- * then it is a candidate to imported or exported.
- */
-
- if ((!level) && (FP->section == eIsInterfaceSection))
- {
- /* Are we importing or exporting the interface?
- *
- * PROGRAM EXPORTS:
- * If we are generating a program binary (i.e., FP0->kind ==
- * eIsProgram) then the variable memory allocation must appear
- * on the initial stack allocation; therefore the variable
- * stack offset myst be exported by the program binary.
- *
- * UNIT IMPORTS:
- * If we are generating a unit binary (i.e., FP0->kind ==
- * eIsUnit), then we are importing the level 0 stack offset
- * from the main program.
- */
-
- if (FP0->kind == eIsUnit)
- {
- /* Mark the symbol as external and replace the absolute
- * offset with this relative offset.
- */
-
- varPtr->sParm.v.flags |= SVAR_EXTERNAL;
- varPtr->sParm.v.offset = dstack - FP->dstack;
-
- /* IMPORT the symbol; assign an offset relative to
- * the dstack at the beginning of this file
- */
-
- pas_GenerateStackImport(varPtr);
- }
- else /* if (FP0->kind == eIsProgram) */
- {
- /* EXPORT the symbol */
-
- pas_GenerateStackExport(varPtr);
- }
- }
-
- /* In any event, bump the stack offset to include space for
- * this new symbol. The 'bumped' stack offset will be the
- * offset for the next variable that is declared.
- */
-
- dstack += g_dwVarSize;
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-/* Process VAR FILE OF declaration */
-
-static void pas_DeclareFile(void)
-{
- sint16 fileNumber = tknPtr->sParm.fileNumber;
- STYPE *filePtr;
-
- TRACE(lstFile,"[pas_DeclareFile]");
-
- /* FORM: <file identifier> : FILE OF <type> */
- /* OR: <file identifier> : <FILE OF type identifier> */
- if (!(fileNumber)) error(eINVFILE);
- else if (files [fileNumber].defined) error(eDUPFILE);
- else {
-
- /* Skip over the <file identifier> */
- getToken();
-
- /* Verify that a colon follows the <file identifier> */
- if (token != ':') error (eCOLON);
- else getToken();
-
- /* Make sure that the data stack is aligned to INTEGER boundaries */
- dstack = intAlign(dstack);
-
- /* FORM: <file identifier> : FILE OF <type> */
- if (token == sFILE_OF) {
-
- files[fileNumber].defined = -1;
- files[fileNumber].flevel = level;
- files[fileNumber].ftype = tknPtr->sParm.t.type;
- files[fileNumber].faddr = dstack;
- files[fileNumber].fsize = tknPtr->sParm.t.asize;
- dstack += (tknPtr->sParm.t.asize);
- getToken();
-
- }
-
- /* FORM: <file identifier> : <FILE OF type identifier> */
- else {
- if (token != tFILE) error (eFILE);
- else getToken();
- if (token != tOF) error (eOF);
- else getToken();
-
- filePtr = pas_TypeIdentifier(1);
- if (filePtr) {
-
- files[fileNumber].defined = -1;
- files[fileNumber].flevel = level;
- files[fileNumber].ftype = filePtr->sParm.t.type;
- files[fileNumber].faddr = dstack;
- files[fileNumber].fsize = g_dwVarSize;
- dstack += g_dwVarSize;
-
- }
- }
- }
-}
-
-/***************************************************************/
-/* Process Procedure Declaration Block */
-
-static void pas_ProcedureDeclaration(void)
-{
- uint16 procLabel = ++label;
- char *saveStringSP;
- STYPE *procPtr;
- register int i;
-
- TRACE(lstFile,"[pas_ProcedureDeclaration]");
-
- /* FORM: procedure-declaration =
- * procedure-heading ';' directive |
- * procedure-heading ';' procedure-block
- * FORM: procedure-heading =
- * 'procedure' identifier [ formal-parameter-list ]
- * FORM: procedure-identifier = identifier
- *
- * On entry, token refers to token AFTER the 'procedure' reserved
- * word.
- */
-
- /* Process the procedure-heading */
-
- if (token != tIDENT)
- {
- error (eIDENT);
- return;
- }
-
- /* Add the procedure to the symbol table */
-
- procPtr = addProcedure(tkn_strt, sPROC, procLabel, 0, NULL);
-
- /* Save the string stack pointer so that we can release all
- * formal parameter strings later. Then get the next token.
- */
-
- saveStringSP = stringSP;
- getToken();
-
- /* NOTE: The level associated with the PROCEDURE symbol is the level
- * At which the procedure was declared. Everything declare within the
- * PROCEDURE is at the next level
- */
-
- level++;
-
- /* Process parameter list */
-
- (void)formalParameterList(procPtr);
-
- if (token != ';') error (eSEMICOLON);
- else getToken();
-
- /* If we are here then we know that we are either in a program file
- * or the 'implementation' part of a unit file (see punit.c -- At present,
- * the procedure declarations of the 'interface' section of a unit file
- * follow a different path). In the latter case (only), we should export
- * every procedure declared at level zero.
- */
-
- if ((level == 1) && (FP->kind == eIsUnit))
- {
- /* EXPORT the procedure symbol. */
-
- pas_GenerateProcExport(procPtr);
- }
-
- /* Save debug information about the procedure */
-
- pas_GenerateDebugInfo(procPtr, 0);
-
- /* Process block */
-
- pas_GenerateDataOperation(opLABEL, (sint32)procLabel);
- block();
-
- /* Destroy formal parameter names */
-
- for (i = 1; i <= procPtr->sParm.p.nParms; i++)
- {
- procPtr[i].sName = NULL;
- }
-
- stringSP = saveStringSP;
-
- /* Generate exit from procedure */
-
- pas_GenerateSimple(opRET);
- level--;
-
- /* Verify that END terminates with a semicolon */
-
- if (token != ';') error (eSEMICOLON);
- else getToken();
-}
-
-/***************************************************************/
-/* Process Function Declaration Block */
-
-static void pas_FunctionDeclaration(void)
-{
- uint16 funcLabel = ++label;
- sint16 parameterOffset;
- char *saveStringSP;
- STYPE *funcPtr;
- STYPE *valPtr;
- STYPE *typePtr;
- char *funcName;
- register int i;
-
- TRACE(lstFile,"[pas_FunctionDeclaration]");
-
- /* FORM: function-declaration =
- * function-heading ';' directive |
- * function-heading ';' function-block
- * FORM: function-heading =
- * 'function' function-identifier [ formal-parameter-list ]
- * ':' result-type
- *
- * On entry token should lrefer to the function-identifier.
- */
-
- /* Verify function-identifier */
-
- if (token != tIDENT)
- {
- error (eIDENT);
- return;
- }
-
- funcPtr = addProcedure(tkn_strt, sFUNC, funcLabel, 0, NULL);
-
- /* NOTE: The level associated with the FUNCTION symbol is the level
- * At which the procedure was declared. Everything declare within the
- * PROCEDURE is at the next level
- */
-
- level++;
-
- /* Save the string stack pointer so that we can release all
- * formal parameter strings later. Then get the next token.
- */
-
- funcName = tkn_strt;
- saveStringSP = stringSP;
- getToken();
-
- /* Process parameter list */
-
- parameterOffset = formalParameterList(funcPtr);
-
- /* Verify that the parameter list is followed by a colon */
-
- if (token != ':') error (eCOLON);
- else getToken();
-
- /* Declare the function return value variable. This variable has
- * the same name as the function itself. We fill the variable
- * symbol descriptor with bogus information now (but we fix it
- * below).
- */
-
- valPtr = addVariable(funcName, sINT, 0, sINT_SIZE, NULL);
-
- /* Get function type, return value type/size and offset to return value */
-
- typePtr = pas_TypeIdentifier(0);
- if (typePtr) {
-
- /* The offset to the return value is the offset to the last
- * parameter minus the size of the return value (aligned to
- * multiples of size of INTEGER).
- */
-
- parameterOffset -= g_dwVarSize;
- parameterOffset = intAlign(parameterOffset);
-
- /* Save the TYPE for the function return value local variable */
-
- valPtr->sKind = typePtr->sParm.t.rtype;
- valPtr->sParm.v.offset = parameterOffset;
- valPtr->sParm.v.size = g_dwVarSize;
- valPtr->sParm.v.parent = typePtr;
-
- /* Save the TYPE for the function */
-
- funcPtr->sParm.p.parent = typePtr;
-
- /* If we are here then we know that we are either in a program file
- * or the 'implementation' part of a unit file (see punit.c -- At present,
- * the function declarations of the 'interface' section of a unit file
- * follow a different path). In the latter case (only), we should export
- * every function declared at level zero.
- */
-
- if ((level == 1) && (FP->kind == eIsUnit))
- {
- /* EXPORT the function symbol. */
-
- pas_GenerateProcExport(funcPtr);
- }
- }
- else
- error(eINVTYPE);
-
- /* Save debug information about the function */
-
- pas_GenerateDebugInfo(funcPtr, g_dwVarSize);
-
- /* Process block */
-
- if (token != ';') error (eSEMICOLON);
- else getToken();
-
- pas_GenerateDataOperation(opLABEL, (sint32)funcLabel);
- block();
-
- /* Destroy formal parameter names and the function return value name */
-
- for (i = 1; i <= funcPtr->sParm.p.nParms; i++)
- {
- funcPtr[i].sName = ((char *) NULL);
- }
-
- valPtr->sName = ((char *) NULL);
- stringSP = saveStringSP;
-
- /* Generate exit from procedure/function */
-
- pas_GenerateSimple(opRET);
- level--;
-
- /* Verify that END terminates with a semicolon */
-
- if (token != ';') error (eSEMICOLON);
- else getToken();
-}
-
-/***************************************************************/
-/* Determine the size value to use with this type */
-
-static void pas_SetTypeSize(STYPE *typePtr, boolean allocate)
-{
- TRACE(lstFile,"[pas_SetTypeSize]");
-
- /* Check for type-identifier */
-
- g_dwVarSize = 0;
-
- if (typePtr != NULL)
- {
- /* If allocate is TRUE, then we want to return the size of
- * the type that we would use if we are going to allocate
- * an instance on the stack.
- */
-
- if (allocate)
- {
- /* Could it be a storage size value (such as is used for
- * the enhanced pascal string type?). In an weak attempt to
- * be compatible with everyone in the world, we will allow
- * either '[]' or '()' to delimit the size specification.
- */
-
- if (((token == '[') || (token == '(')) &&
- ((typePtr->sParm.t.flags & STYPE_VARSIZE) != 0))
- {
- uint16 term_token;
- uint16 errcode;
-
- /* Yes... we need to parse the size from the input stream.
- * First, determine which token will terminate the size
- * specification.
- */
-
- if (token == '(')
- {
- term_token = ')'; /* Should end with ')' */
- errcode = eRPAREN; /* If not, this is the error */
- }
- else
- {
- term_token = ']'; /* Should end with ']' */
- errcode = eRBRACKET; /* If not, this is the error */
- }
-
- /* Now, parse the size specification */
-
- /* We expect the size to consist of a single integer constant.
- * We should support any constant integer expression, but this
- * has not yet been implemented.
- */
-
- getToken();
- if (token != tINT_CONST) error(eINTCONST);
- /* else if (tknInt <= 0) error(eINVCONST); see below */
- else if (tknInt <= 2) error(eINVCONST);
- else
- {
- /* Use the value of the integer constant for the size
- * the allocation. NOTE: There is a problem here in
- * that for the sSTRING type, it wants the first 2 bytes
- * for the string length. This means that the actual
- * length is real two less than the specified length.
- */
-
- g_dwVarSize = tknInt;
- }
-
- /* Verify that the correct token terminated the size
- * specification. This could be either ')' or ']'
- */
-
- getToken();
- if (token != term_token) error(errcode);
- else getToken();
- }
- else
- {
- /* Return the fixed size of the allocated instance of
- * this type */
-
- g_dwVarSize = typePtr->sParm.t.asize;
- }
- }
-
- /* If allocate is FALSE, then we want to return the size of
- * the type that we would use if we are going to refer to
- * a reference on the stack. This is really non-standard
- * and is handle certain optimatizations where we cheat and
- * pass some types by reference rather than by value. The
- * enhanced pascal string type is the only example at present.
- */
-
- else
- {
- /* Return the size to a clone, reference to an instance */
-
- g_dwVarSize = typePtr->sParm.t.rsize;
- }
- }
-}
-
-/***************************************************************/
-/* Verify that the next token is a type identifer
- * NOTE: This function modifies the global variable g_dwVarSize
- * as a side-effect
- */
-
-static STYPE *pas_TypeIdentifier(boolean allocate)
-{
- STYPE *typePtr = NULL;
-
- TRACE(lstFile,"[pas_TypeIdentifier]");
-
- /* Check for type-identifier */
-
- if (token == sTYPE)
- {
- /* Return a reference to the type token. */
-
- typePtr = tknPtr;
- getToken();
-
- /* Return the size value associated with this type */
-
- pas_SetTypeSize(typePtr, allocate);
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-
-static STYPE *pas_TypeDenoter(char *typeName, boolean allocate)
-{
- STYPE *typePtr;
-
- TRACE(lstFile,"[pas_TypeDenoter]");
-
- /* FORM: type-denoter = type-identifier | new-type
- *
- * Check for type-identifier
- */
-
- typePtr = pas_TypeIdentifier(allocate);
- if (typePtr != NULL)
- {
- /* Return the type identifier */
-
- return typePtr;
- }
-
- /* Check for new-type
- * FORM: new-type = new-ordinal-type | new-complex-type
- */
-
- /* Check for new-complex-type */
-
- typePtr = pas_NewComplexType(typeName);
- if (typePtr == NULL)
- {
- /* Check for new-ordinal-type */
-
- typePtr = pas_NewOrdinalType(typeName);
- }
-
- /* Return the size value associated with this type */
-
- pas_SetTypeSize(typePtr, allocate);
-
- return typePtr;
-}
-
-/***************************************************************/
-/* Declare is new ordinal type */
-
-static STYPE *pas_NewOrdinalType(char *typeName)
-{
- STYPE *typePtr = NULL;
-
- /* Declare a new-ordinal-type
- * FORM: new-ordinal-type = enumerated-type | subrange-type
- */
-
- /* FORM: enumerated-type = '(' enumerated-constant-list ')' */
-
- if (token == '(')
- {
- sint32 nObjects;
- nObjects = 0;
- typePtr = addTypeDefine(typeName, sSCALAR, sINT_SIZE, NULL);
-
- /* Now declare each instance of the scalar */
-
- do {
- getToken();
- if (token != tIDENT) error(eIDENT);
- else
- {
- (void)addConstant(tkn_strt, sSCALAR_OBJECT, &nObjects, typePtr);
- nObjects++;
- getToken();
- }
- } while (token == ',');
-
- /* Save the number of objects associated with the scalar type (the
- * maximum ORD is nObjects - 1). */
-
- typePtr->sParm.t.maxValue = nObjects - 1;
-
- if (token != ')') error(eRPAREN);
- else getToken();
-
- }
-
- /* Declare a new subrange type
- * FORM: subrange-type = constant '..' constant
- * FORM: constant =
- * [ sign ] integer-number | [ sign ] real-number |
- * [ sign ] constant-identifier | character-literal | string-literal
- *
- * Case 1: <constant> is INTEGER
- */
-
- else if (token == tINT_CONST)
- {
- /* Create the new INTEGER subrange type */
-
- typePtr = addTypeDefine(typeName, sSUBRANGE, sINT_SIZE, NULL);
- typePtr->sParm.t.subType = sINT;
- typePtr->sParm.t.minValue = tknInt;
- typePtr->sParm.t.maxValue = MAXINT;
-
- /* Verify that ".." separates the two constants */
-
- getToken();
- if (token != tSUBRANGE) error(eSUBRANGE);
- else getToken();
-
- /* Verify that the ".." is following by an INTEGER constant */
-
- if ((token != tINT_CONST) || (tknInt < typePtr->sParm.t.minValue))
- error(eSUBRANGETYPE);
- else
- {
- typePtr->sParm.t.maxValue = tknInt;
- getToken();
- }
- }
-
- /* Case 2: <constant> is CHAR */
-
- else if (token == tCHAR_CONST)
- {
- /* Create the new CHAR subrange type */
-
- typePtr = addTypeDefine(typeName, sSUBRANGE, sCHAR_SIZE, NULL);
- typePtr->sParm.t.subType = sCHAR;
- typePtr->sParm.t.minValue = tknInt;
- typePtr->sParm.t.maxValue = MAXCHAR;
-
- /* Verify that ".." separates the two constants */
-
- getToken();
- if (token != tSUBRANGE) error(eSUBRANGE);
- else getToken();
-
- /* Verify that the ".." is following by a CHAR constant */
-
- if ((token != tCHAR_CONST) || (tknInt < typePtr->sParm.t.minValue))
- error(eSUBRANGETYPE);
- else
- {
- typePtr->sParm.t.maxValue = tknInt;
- getToken();
- }
- }
-
- /* Case 3: <constant> is a SCALAR type */
-
- else if (token == sSCALAR_OBJECT)
- {
- /* Create the new SCALAR subrange type */
-
- typePtr = addTypeDefine(typeName, sSUBRANGE, sINT_SIZE, tknPtr);
- typePtr->sParm.t.subType = token;
- typePtr->sParm.t.minValue = tknInt;
- typePtr->sParm.t.maxValue = MAXINT;
-
- /* Verify that ".." separates the two constants */
-
- getToken();
- if (token != tSUBRANGE) error(eSUBRANGE);
- else getToken();
-
- /* Verify that the ".." is following by a SCALAR constant of the same
- * type as the one which preceded it
- */
-
- if ((token != sSCALAR_OBJECT) ||
- (tknPtr != typePtr->sParm.t.parent) ||
- (tknPtr->sParm.c.val.i < typePtr->sParm.t.minValue))
- error(eSUBRANGETYPE);
- else
- {
- typePtr->sParm.t.maxValue = tknPtr->sParm.c.val.i;
- getToken();
- }
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-
-static STYPE *pas_NewComplexType(char *typeName)
-{
- STYPE *typePtr = NULL;
- STYPE *typeIdPtr;
-
- TRACE(lstFile,"[pas_TypeDenoter]");
-
- /* FORM: new-complex-type = new-structured-type | new-pointer-type */
-
- switch (token)
- {
- /* FORM: new-pointer-type = '^' domain-type | '@' domain-type */
-
- case '^' :
- getToken();
- typeIdPtr = pas_TypeIdentifier(1);
- if (typeIdPtr)
- {
- typePtr = addTypeDefine(typeName, sPOINTER, g_dwVarSize, typeIdPtr);
- }
- else
- {
- error(eINVTYPE);
- }
- break;
-
- /* FORM: new-structured-type =
- * [ 'packed' ] array-type | [ 'packed' ] record-type |
- * [ 'packed' ] set-type | [ 'packed' ] file-type |
- * [ 'packed' ] list-type | object-type | string-type
- */
-
- /* PACKED Types */
-
- case tPACKED :
- error (eNOTYET);
- getToken();
- if (token != tARRAY) break;
- /* Fall through to process PACKED ARRAY type */
-
- /* Array Types
- * FORM: array-type = 'array' [ index-type-list ']' 'of' type-denoter
- */
-
- case tARRAY :
- getToken();
- typeIdPtr = pas_GetArrayType();
- if (typeIdPtr)
- {
- typePtr = addTypeDefine(typeName, sARRAY, g_dwVarSize, typeIdPtr);
- }
- else
- {
- error(eINVTYPE);
- }
- break;
-
- /* RECORD Types
- * FORM: record-type = 'record' field-list 'end'
- */
-
- case tRECORD :
- getToken();
- typePtr = pas_DeclareRecord(typeName);
- break;
-
- /* Set Types
- *
- * FORM: set-type = 'set' 'of' ordinal-type
- */
-
- case tSET :
-
- /* Verify that 'set' is followed by 'of' */
-
- getToken();
- if (token != tOF) error (eOF);
- else getToken();
-
- /* Verify that 'set of' is followed by an ordinal-type
- * If not, then declare a new one with no name
- */
-
- typeIdPtr = pas_OrdinalTypeIdentifier(1);
- if (typeIdPtr)
- getToken();
- else
- typeIdPtr = pas_DeclareOrdinalType(NULL);
-
- /* Verify that the ordinal-type is either a scalar or a
- * subrange type. These are the only valid types for 'set of'
- */
-
- if ((typeIdPtr) &&
- ((typeIdPtr->sParm.t.type == sSCALAR) ||
- (typeIdPtr->sParm.t.type == sSUBRANGE)))
- {
- /* Declare the SET type */
-
- typePtr = addTypeDefine(typeName, sSET_OF,
- typeIdPtr->sParm.t.asize, typeIdPtr);
-
- if (typePtr)
- {
- sint16 nObjects;
-
- /* Copy the scalar/subrange characteristics for convenience */
-
- typePtr->sParm.t.subType = typeIdPtr->sParm.t.type;
- typePtr->sParm.t.minValue = typeIdPtr->sParm.t.minValue;
- typePtr->sParm.t.maxValue = typeIdPtr->sParm.t.minValue;
-
- /* Verify that the number of objects associated with the
- * scalar or subrange type will fit into an integer
- * representation of a set as a bit-string.
- */
-
- nObjects = typeIdPtr->sParm.t.maxValue
- - typeIdPtr->sParm.t.minValue + 1;
- if (nObjects > BITS_IN_INTEGER)
- {
- error(eSETRANGE);
- typePtr->sParm.t.maxValue = typePtr->sParm.t.minValue
- + BITS_IN_INTEGER - 1;
- }
- }
- }
- else
- error(eSET);
- break;
-
- /* File Types
- * FORM: file-type = 'file' 'of' type-denoter
- */
-
- /* FORM: file-type = 'file' 'of' type-denoter */
-
- case tFILE :
-
- /* Make sure that 'file' is followed by 'of' */
-
- getToken();
- if (token != tOF) error (eOF);
- else getToken();
-
- /* Get the type-denoter */
-
- typeIdPtr = pas_TypeDenoter(NULL,1);
- if (typeIdPtr)
- {
- typePtr = addTypeDefine(typeName, sFILE_OF, g_dwVarSize, typeIdPtr);
- if (typePtr)
- {
- typePtr->sParm.t.subType = typeIdPtr->sParm.t.type;
- }
- }
- else
- {
- error(eINVTYPE);
- }
- break;
-
- /* FORM: string-type = pascal-string-type | c-string-type
- * FORM: pascal-string-type = 'string' [ max-string-length ]
- */
- case sSTRING :
- error (eNOTYET);
- getToken();
- break;
-
- /* FORM: list-type = 'list' 'of' type-denoter */
- /* FORM: object-type = 'object' | 'class' */
- default :
- break;
-
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-/* Verify that the next token is a type identifer
- */
-
-static STYPE *pas_OrdinalTypeIdentifier(boolean allocate)
-{
- STYPE *typePtr;
-
- TRACE(lstFile,"[pas_OrdinalTypeIdentifier]");
-
- /* Get the next type from the input stream */
-
- typePtr = pas_TypeIdentifier(allocate);
-
- /* Was a type encountered? */
-
- if (typePtr != NULL)
- {
- switch (typePtr->sParm.t.type)
- {
- /* Check for an ordinal type (verify this list!) */
-
- case sINT :
- case sBOOLEAN :
- case sCHAR :
- case sSCALAR :
- case sSUBRANGE:
- /* If it is an ordinal type, then just return the
- * type pointer.
- */
-
- break;
- default :
- /* If not, return NULL */
-
- typePtr = NULL;
- break;
- }
- }
- return typePtr;
-}
-
-/***************************************************************/
-/* get array type argument for TYPE block or variable declaration */
-
-static STYPE *pas_GetArrayType(void)
-{
- STYPE *typePtr = NULL;
-
- TRACE(lstFile,"[pas_GetArrayType]");
-
- /* FORM: array-type = 'array' '[' index-type-list ']' 'of' type-denoter */
- /* FORM: [PACKED] ARRAY [<integer>] OF type-denoter
- * NOTE: Bracketed value is the array size! NONSTANDARD! */
-
- g_dwVarSize = 0;
-
- /* Verify that the index-type-list is preceded by '[' */
-
- if (token != '[') error (eLBRACKET);
- else
- {
- /* FORM: index-type-list = index-type { ',' index-type }
- * FORM: index-type = ordinal-type
- */
-
- getToken();
- if (token != tINT_CONST) error (eINTCONST);
- else
- {
- g_dwVarSize = tknInt;
- getToken();
-
- /* Verify that the index-type-list is followed by ']' */
-
- if (token != ']') error (eRBRACKET);
- else getToken();
-
- /* Verify that 'of' precedes the type-denoter */
-
- if (token != tOF) error (eOF);
- else getToken();
-
- /* We have the array size in elements, not get the type and convert
- * the size for the type found
- */
-
- typePtr = pas_DeclareType(NULL);
- if (typePtr)
- {
- g_dwVarSize *= typePtr->sParm.t.asize;
- }
- }
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-
-static STYPE *pas_DeclareRecord(char *recordName)
-{
- STYPE *recordPtr;
- sint16 recordOffset;
- int recordCount, symbolIndex;
-
- TRACE(lstFile,"[pas_DeclareRecord]");
-
- /* FORM: record-type = 'record' field-list 'end' */
-
- /* Declare the new RECORD type */
-
- recordPtr = addTypeDefine(recordName, sRECORD, 0, NULL);
-
- /* Then declare the field-list associated with the RECORD
- * FORM: field-list =
- * [
- * fixed-part [ ';' ] variant-part [ ';' ] |
- * fixed-part [ ';' ] |
- * variant-part [ ';' ] |
- * ]
- *
- * Process the fixed-part first.
- * FORM: fixed-part = record-section { ';' record-section }
- * FORM: record-section = identifier-list ':' type-denoter
- * FORM: identifier-list = identifier { ',' identifier }
- */
-
- for (;;)
- {
- /* Terminate parsing of the fixed-part when we encounter
- * 'case' indicating the beginning of the variant part of
- * the record. If there is no fixed-part, then 'case' will
- * appear immediately.
- */
-
- if (token == tCASE) break;
-
- /* We now expect to see and indentifier representating the
- * beginning of the next fixed field.
- */
-
- (void)pas_DeclareField(recordPtr);
-
- /* If the field declaration terminates with a semicolon, then
- * we expect to see another <fixed part> declaration in the
- * record.
- */
-
- if (token == ';')
- {
- /* Skip over the semicolon and process the next fixed
- * field declaration.
- */
-
- getToken();
-
- /* We will treat this semi colon as optional. If we
- * hit 'end' or 'case' after the semicolon, then we
- * will terminate the fixed part with no complaint.
- */
-
- if ((token == tEND) || (token == tCASE))
- break;
- }
-
- /* If there is no semicolon after the field declaration,
- * then 'end' or 'case' is expected. This will be verified
- * below.
- */
-
- else break;
- }
-
- /* Get the total size of the RECORD type and the offset of each
- * field within the RECORD.
- */
-
- for (recordOffset = 0, symbolIndex = 1, recordCount = 0;
- recordCount < recordPtr->sParm.t.maxValue;
- symbolIndex++)
- {
- /* We know that 'maxValue' sRECORD_OBJECT symbols follow the sRECORD
- * type declaration. However, these may not be sequential due to the
- * possible declaration of sTYPEs associated with each field.
- */
-
- if (recordPtr[symbolIndex].sKind == sRECORD_OBJECT)
- {
- /* Align the recordOffset (if necessary) */
-
- if ((!isIntAligned(recordOffset)) &&
- (pas_IntAlignRequired(recordPtr[symbolIndex].sParm.r.parent)))
- recordOffset = intAlign(recordOffset);
-
- /* Save the offset associated with this field, and determine the
- * offset to the next field (if there is one)
- */
-
- recordPtr[symbolIndex].sParm.r.offset = recordOffset;
- recordOffset += recordPtr[symbolIndex].sParm.r.size;
- recordCount++;
- }
- }
-
- /* Update the RECORD entry for the total size of all fields */
-
- recordPtr->sParm.t.asize = recordOffset;
-
- /* Now we are ready to process the variant-part.
- * FORM: variant-part = 'case' variant-selector 'of' variant-body
- */
-
- if (token == tCASE)
- {
- sint16 variantOffset;
- uint16 maxRecordSize;
-
- /* Skip over the 'case' */
-
- getToken();
-
- /* Check for variant-selector
- * FORM: variant-selector = [ identifier ':' ] ordinal-type-identifer
- */
-
- if (token != tIDENT) error(eRECORDDECLARE);
-
- /* Add a variant-selector to the fixed-part of the record */
-
- else
- {
- STYPE *typePtr;
- char *fieldName;
-
- /* Save the field name */
-
- fieldName = tkn_strt;
- getToken();
-
- /* Verify that the identifier is followed by a colon */
-
- if (token != ':') error(eCOLON);
- else getToken();
-
- /* Get the ordinal-type-identifier */
-
- typePtr = pas_OrdinalTypeIdentifier(1);
- if (!typePtr) error(eINVTYPE);
- else
- {
- STYPE *fieldPtr;
-
- /* Declare a <field> with this <identifier> as its name */
-
- fieldPtr = addField(fieldName, recordPtr);
-
- /* Increment the number of fields in the record */
-
- recordPtr->sParm.t.maxValue++;
-
- /* Copy the size of field from the sTYPE entry into the
- * <field> type entry. NOTE: This element is not essential
- * since it can be obtained from the parent type pointer
- */
-
- fieldPtr->sParm.r.size = typePtr->sParm.t.asize;
-
- /* Save a pointer back to the parent field type */
-
- fieldPtr->sParm.r.parent = typePtr;
-
- /* Align the recordOffset (if necessary) */
-
- if ((!isIntAligned(recordOffset)) &&
- (pas_IntAlignRequired(typePtr)))
- recordOffset = intAlign(recordOffset);
-
- /* Save the offset associated with this field, and determine
- * the offset to the next field (if there is one)
- */
-
- fieldPtr->sParm.r.offset = recordOffset;
- recordOffset += recordPtr[symbolIndex].sParm.r.size;
- }
- }
-
- /* Save the offset to the start of the variant portion of the RECORD */
-
- variantOffset = recordOffset;
- maxRecordSize = recordOffset;
-
- /* Skip over the 'of' following the variant selector */
-
- if (token != tOF) error(eOF);
- else getToken();
-
- /* Loop to process the variant-body
- * FORM: variant-body =
- * variant-list [ [ ';' ] variant-part-completer ] |
- * variant-part-completer
- * FORM: variant-list = variant { ';' variant }
- * FORM: variant-part-completer = ( 'otherwise' | 'else' ) ( field-list )
- */
-
- for (;;)
- {
- /* Now process each variant where:
- * FORM: variant = case-constant-list ':' '(' field-list ')'
- * FORM: case-constant-list = case-specifier { ',' case-specifier }
- * FORM: case-specifier = case-constant [ '..' case-constant ]
- */
-
- /* Verify that the case selector begins with a case-constant.
- * Note that subrange case-specifiers are not yet supported.
- */
-
- if (!isConstant(token))
- {
- error(eINVCONST);
- break;
- }
-
- /* Just consume the <case selector> for now -- Really need to
- * verify that each constant is of the same type as the type
- * identifier (or the type associated with the tag) in the CASE
- */
-
- do
- {
- getToken();
- if (token == ',') getToken();
- }
- while (isConstant(token));
-
- /* Make sure a colon separates case-constant-list from the
- * field-list
- */
-
- if (token == ':') getToken();
- else error(eCOLON);
-
- /* The field-list must be enclosed in parentheses */
-
- if (token == '(') getToken();
- else error(eLPAREN);
-
- /* Special case the empty variant <field list> */
-
- if (token != ')')
- {
- /* Now process the <field list> for the variant. This works
- * just like the field list of the fixed part, except the
- * offset is reset for each variant.
- * FORM: field-list =
- * [
- * fixed-part [ ';' ] variant-part [ ';' ] |
- * fixed-part [ ';' ] |
- * variant-part [ ';' ] |
- * ]
- */
-
- for (;;)
- {
- /* We now expect to see and indentifier representating the
- * beginning of the next variablefield.
- */
-
- (void)pas_DeclareField(recordPtr);
-
- /* If the field declaration terminates with a semicolon,
- * then we expect to see another <variable part>
- * declaration in the record.
- */
-
- if (token == ';')
- {
- /* Skip over the semicolon and process the next
- * variable field declaration.
- */
-
- getToken();
-
- /* We will treat this semi colon as optional. If we
- * hit 'end' after the semicolon, then we will
- * terminate the fixed part with no complaint.
- */
-
- if (token == tEND)
- break;
- }
- else break;
- }
-
- /* Get the total size of the RECORD type and the offset of each
- * field within the RECORD.
- */
-
- for (recordOffset = variantOffset;
- recordCount < recordPtr->sParm.t.maxValue;
- symbolIndex++)
- {
- /* We know that 'maxValue' sRECORD_OBJECT symbols follow
- * the sRECORD type declaration. However, these may not
- * be sequential due to the possible declaration of sTYPEs
- * associated with each field.
- */
-
- if (recordPtr[symbolIndex].sKind == sRECORD_OBJECT)
- {
- /* Align the recordOffset (if necessary) */
-
- if ((!isIntAligned(recordOffset)) &&
- (pas_IntAlignRequired(recordPtr[symbolIndex].sParm.r.parent)))
- recordOffset = intAlign(recordOffset);
-
- /* Save the offset associated with this field, and
- * determine the offset to the next field (if there
- * is one)
- */
-
- recordPtr[symbolIndex].sParm.r.offset = recordOffset;
- recordOffset += recordPtr[symbolIndex].sParm.r.size;
- recordCount++;
- }
- }
-
- /* Check if this is the largest variant that we have found
- * so far
- */
-
- if (recordOffset > maxRecordSize)
- maxRecordSize = recordOffset;
- }
-
- /* Verify that the <field list> is enclosed in parentheses */
-
- if (token == ')') getToken();
- else error(eRPAREN);
-
- /* A semicolon at this position means that another <variant>
- * follows. Keep looping until all of the variants have been
- * processed (i.e., no semi-colon)
- */
-
- if (token == ';') getToken();
- else break;
- }
-
- /* Update the RECORD entry for the maximum size of all variants */
-
- recordPtr->sParm.t.asize = maxRecordSize;
- }
-
- /* Verify that the RECORD declaration terminates with END */
-
- if (token != tEND) error(eRECORDDECLARE);
- else getToken();
-
- return recordPtr;
-}
-
-/***************************************************************/
-
-static STYPE *pas_DeclareField(STYPE *recordPtr)
-{
- STYPE *fieldPtr = NULL;
- STYPE *typePtr;
-
- TRACE(lstFile,"[pas_DeclareField]");
-
- /* Declare one record-section with a record.
- * FORM: record-section = identifier-list ':' type-denoter
- * FORM: identifier-list = identifier { ',' identifier }
- */
-
- if (token != tIDENT) error(eIDENT);
- else {
-
- /* Declare a <field> with this <identifier> as its name */
-
- fieldPtr = addField(tkn_strt, recordPtr);
- getToken();
-
- /* Check for multiple fields of this <type> */
-
- if (token == ',') {
-
- getToken();
- typePtr = pas_DeclareField(recordPtr);
-
- }
- else {
-
- if (token != ':') error(eCOLON);
- else getToken();
-
- /* Use the existing type or declare a new type with no name */
-
- typePtr = pas_TypeDenoter(NULL, 1);
- }
-
- recordPtr->sParm.t.maxValue++;
- if (typePtr) {
-
- /* Copy the size of field from the sTYPE entry into the <field> */
- /* type entry. NOTE: This element is not essential since it */
- /* can be obtained from the parent type pointer */
-
- fieldPtr->sParm.r.size = typePtr->sParm.t.asize;
-
- /* Save a pointer back to the parent field type */
-
- fieldPtr->sParm.r.parent = typePtr;
-
- }
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-/* Process VAR/value Parameter Declaration */
-/* NOTE: This function increments the global variable g_nParms */
-/* as a side-effect */
-
-static STYPE *pas_DeclareParameter(boolean pointerType)
-{
- sint16 varType = 0;
- STYPE *varPtr;
- STYPE *typePtr;
-
- TRACE(lstFile,"[pas_DeclareParameter]");
-
- /* FORM:
- * <identifier>[,<identifier>[,<identifier>[...]]] : <type identifier>
- */
-
- if (token != tIDENT) error (eIDENT);
- else
- {
- varPtr = addVariable(tkn_strt, sINT, 0, sINT_SIZE, NULL);
- getToken();
-
- if (token == ',')
- {
- getToken();
- typePtr = pas_DeclareParameter(pointerType);
- }
- else
- {
- if (token != ':') error (eCOLON);
- else getToken();
- typePtr = pas_TypeIdentifier(0);
- }
-
- if (pointerType)
- {
- varType = sVAR_PARM;
- g_dwVarSize = sPTR_SIZE;
- }
- else
- {
- varType = typePtr->sParm.t.rtype;
- }
-
- g_nParms++;
- varPtr->sKind = varType;
- varPtr->sParm.v.size = g_dwVarSize;
- varPtr->sParm.v.parent = typePtr;
- }
-
- return typePtr;
-}
-
-/***************************************************************/
-
-static boolean pas_IntAlignRequired(STYPE *typePtr)
-{
- boolean returnValue = FALSE;
-
- /* Type CHAR and ARRAYS of CHAR do not require alignment (unless
- * they are passed as value parameters). Otherwise, alignment
- * to type INTEGER boundaries is required.
- */
-
- if (typePtr)
- {
- if (typePtr->sKind == sCHAR)
- {
- returnValue = TRUE;
- }
- else if (typePtr->sKind == sARRAY)
- {
- typePtr = typePtr->sParm.t.parent;
- if ((typePtr) && (typePtr->sKind == sCHAR))
- {
- returnValue = TRUE;
- }
- }
- }
-
- return returnValue;
-}
-
-/***************************************************************/
+/*************************************************************** + * pblck.c + * Process a Pascal Block + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************/ + +/*************************************************************** + * Included Files + ***************************************************************/ + +#include <stdio.h> +#include <string.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "pedefs.h" +#include "podefs.h" + +#include "pas.h" +#include "pblck.h" +#include "pexpr.h" +#include "pstm.h" +#include "pgen.h" +#include "ptkn.h" +#include "ptbl.h" +#include "pinsn.h" +#include "perr.h" + +/*************************************************************** + * Private Definitions + ***************************************************************/ + +/* This macro implements a test for: + * FORM: unsigned-constant = integer-number | real-number | + * character-literal | string-literal | constant-identifier | + * 'nil' + */ + +#define isConstant(x) \ + ( ((x) == tINT_CONST) \ + || ((x) == tBOOLEAN_CONST) \ + || ((x) == tCHAR_CONST) \ + || ((x) == tREAL_CONST) \ + || ((x) == sSCALAR_OBJECT)) + +#define isIntAligned(x) (((x) & (sINT_SIZE-1)) == 0) +#define intAlign(x) (((x) + (sINT_SIZE-1)) & (~(sINT_SIZE-1))) + +/*************************************************************** + * Private Function Prototypes + ***************************************************************/ + +static void pas_DeclareLabel (void); +static void pas_DeclareConst (void); +static STYPE *pas_DeclareType (char *typeName); +static STYPE *pas_DeclareOrdinalType (char *typeName); +static STYPE *pas_DeclareVar (void); +static void pas_DeclareFile (void); +static void pas_ProcedureDeclaration (void); +static void pas_FunctionDeclaration (void); + +static void pas_SetTypeSize (STYPE *typePtr, bool allocate); +static STYPE *pas_TypeIdentifier (bool allocate); +static STYPE *pas_TypeDenoter (char *typeName, bool allocate); +static STYPE *pas_NewComplexType (char *typeName); +static STYPE *pas_NewOrdinalType (char *typeName); +static STYPE *pas_OrdinalTypeIdentifier (bool allocate); +static STYPE *pas_GetArrayType (void); +static STYPE *pas_DeclareRecord (char *recordName); +static STYPE *pas_DeclareField (STYPE *recordPtr); +static STYPE *pas_DeclareParameter (bool pointerType); +static bool pas_IntAlignRequired (STYPE *typePtr); + +/*************************************************************** + * Private Global Variables + ***************************************************************/ + +static int32_t g_nParms; +static int32_t g_dwVarSize; + +/*************************************************************** + * Public Functions + ***************************************************************/ +/* Process BLOCK. This function implements: + * + * block = declaration-group compound-statement + * + * Where block can appear in the followinging: + * + * function-block = block + * function-declaration = + * function-heading ';' directive | + * function-heading ';' function-block + * + * procedure-block = block + * procedure-declaration = + * procedure-heading ';' directive | + * procedure-heading ';' procedure-block + * + * program = program-heading ';' [ uses-section ] block '.' + */ + +void block() +{ + uint16_t beginLabel = ++label; /* BEGIN label */ + int32_t saveDStack = dstack; /* Save DSEG size */ + char *saveStringSP = stringSP; /* Save top of string stack */ + int16_t saveNSym = nsym; /* Save top of symbol table */ + int16_t saveNConst = nconst; /* Save top of constant table */ + register int16_t i; + + TRACE(lstFile,"[block]"); + + /* When we enter block at level zero, then we must be at the + * entry point to the program. Save the entry point label + * in the POFF file. + */ + + if ((level == 0) && (FP0->kind == eIsProgram)) + { + poffSetEntryPoint(poffHandle, label); + } + + /* Init size of the new DSEG */ + + dstack = 0; + + /* FORM: block = declaration-group compound-statement + * Process the declaration-group + * + * declaration-group = + * label-declaration-group | + * constant-definition-group | + * type-definition-group | + * variable-declaration-group | + * function-declaration | + * procedure-declaration + */ + + declarationGroup(beginLabel); + + /* Process the compound-statement + * + * FORM: compound-statement = 'begin' statement-sequence 'end' + */ + + /* Verify that the compound-statement begins with BEGIN */ + + if (token != tBEGIN) + { + error (eBEGIN); + } + + /* It may be necessary to jump around some local functions to + * get to the main body of the block. If any jumps are generated, + * they will come to the beginLabel emitted here. + */ + + pas_GenerateDataOperation(opLABEL, (int32_t)beginLabel); + + /* Since we don't know for certain how we got here, invalidate + * the level stack pointer (LSP). This is, of course, only + * meaningful on architectures that implement an LSP. + */ + + pas_InvalidateCurrentStackLevel(); + + /* Then emit the compoundStatement itself */ + + if (dstack) + { + pas_GenerateDataOperation(opINDS, (int32_t)dstack); + } + + compoundStatement(); + + if (dstack) + { + pas_GenerateDataOperation(opINDS, -(int32_t)dstack); + } + + /* Make sure all declared labels were defined in the block */ + + verifyLabels(saveNSym); + + /* Re-initialize file table -- clear files defined in this level */ + + for (i = 0; i <= MAX_FILES; i++) + { + if ((files [i].defined) && (files [i].flevel >= level)) { + files [i].defined = 0; + files [i].flevel = 0; + files [i].ftype = 0; + files [i].faddr = 0; + files [i].fsize = 0; + } + } + + /* "Pop" declarations local to this block */ + + dstack = saveDStack; /* Restore old DSEG size */ + stringSP = saveStringSP; /* Restore top of string stack */ + nsym = saveNSym; /* Restore top of symbol table */ + nconst = saveNConst; /* Restore top of constant table */ +} + +/***************************************************************/ +/* Process declarative-part */ + +void declarationGroup(int32_t beginLabel) +{ + int16_t notFirst = 0; /* Init count of nested procs */ + int16_t saveNSym = nsym; /* Save top of symbol table */ + int16_t saveNConst = nconst; /* Save top of constant table */ + + TRACE(lstFile,"[declarationGroup]"); + + /* FORM: declarative-part = { declaration-group } + * FORM: declaration-group = + * label-declaration-group | constant-definition-group | + * type-definition-group | variable-declaration-group | + * function-declaration | procedure-declaration + */ + + /* Process label-declaration-group. + * FORM: label-declaration-group = 'label' label { ',' label } ';' + */ + + if (token == tLABEL) pas_DeclareLabel(); + + /* Process constant-definition-group. + * FORM: constant-definition-group = + * 'const' constant-definition ';' { constant-definition ';' } + */ + + if (token == tCONST) + { + const_strt = saveNConst; /* Limit search to present level */ + getToken(); /* Get identifier */ + const_strt = 0; + + /* Process constant-definition. + * FORM: constant-definition = identifier '=' constant + */ + + constantDefinitionGroup(); + } + + /* Process type-definition-group + * FORM: type-definition-group = + * 'type' type-definition ';' { type-definition ';' } + */ + + if (token == tTYPE) + { + const_strt = saveNConst; /* Limit search to present level */ + sym_strt = saveNSym; + getToken(); /* Get identifier */ + const_strt = 0; + sym_strt = 0; + + /* Process the type-definitions in the type-definition-group + * FORM: type-definition = identifier '=' type-denoter + */ + + typeDefinitionGroup(); + } + + /* Process variable-declaration-group + * FORM: variable-declaration-group = + * 'var' variable-declaration { ';' variable-declaration } + */ + + if (token == tVAR) + { + const_strt = saveNConst; /* Limit search to present level */ + sym_strt = saveNSym; + getToken(); /* Get identifier */ + const_strt = 0; + sym_strt = 0; + + /* Process the variable declarations + * FORM: variable-declaration = identifier-list ':' type-denoter + * FORM: identifier-list = identifier { ',' identifier } + */ + + variableDeclarationGroup(); + } + + /* Process procedure/function-declaration(s) if present + * FORM: function-declaration = + * function-heading ';' directive | + * function-heading ';' function-block + * FORM: procedure-declaration = + * procedure-heading ';' directive | + * procedure-heading ';' procedure-block + * + * NOTE: a JMP to the executable body of this block is generated + * if there are nested procedures and this is not level=0 + */ + + for (;;) + { + /* FORM: function-heading = + * 'function' identifier [ formal-parameter-list ] ':' result-type + */ + + if (token == tFUNCTION) + { + /* Check if we need to put a jump around the function */ + + if ((beginLabel > 0) && !(notFirst) && (level > 0)) + { + pas_GenerateDataOperation(opJMP, (int32_t)beginLabel); + } + + /* Get the procedure-identifier */ + + const_strt = saveNConst; /* Limit search to present level */ + sym_strt = saveNSym; + getToken(); /* Get identifier */ + const_strt = 0; + sym_strt = 0; + + /* Define the function */ + + pas_FunctionDeclaration(); + notFirst++; /* No JMP next time */ + } + + /* FORM: procedure-heading = + * 'procedure' identifier [ formal-parameter-list ] + */ + + else if (token == tPROCEDURE) + { + /* Check if we need to put a jump around the function */ + + if ((beginLabel > 0) && !(notFirst) && (level > 0)) + { + pas_GenerateDataOperation(opJMP, (int32_t)beginLabel); + } + + /* Get the procedure-identifier */ + + const_strt = saveNConst; /* Limit search to present level */ + sym_strt = saveNSym; + getToken(); /* Get identifier */ + const_strt = 0; + sym_strt = 0; + + /* Define the procedure */ + + pas_ProcedureDeclaration(); + notFirst++; /* No JMP next time */ + } + else break; + } +} + +/***************************************************************/ + +void constantDefinitionGroup(void) +{ + /* Process constant-definition-group. + * FORM: constant-definition-group = + * 'const' constant-definition ';' { constant-definition ';' } + * FORM: constant-definition = identifier '=' constant + * + * On entry, token should point to the identifier of the first + * constant-definition. + */ + + for (;;) + { + if (token == tIDENT) + { + pas_DeclareConst(); + if (token != ';') break; + else getToken(); + } + else break; + } +} + +/***************************************************************/ + +void typeDefinitionGroup(void) +{ + char *typeName; + + /* Process type-definition-group + * FORM: type-definition-group = + * 'type' type-definition ';' { type-definition ';' } + * FORM: type-definition = identifier '=' type-denoter + * + * On entry, token refers to the first identifier (if any) of + * the type-definition list. + */ + + for (;;) + { + if (token == tIDENT) + { + /* Save the type identifier */ + + typeName = tkn_strt; + getToken(); + + /* Verify that '=' follows the type identifier */ + + if (token != '=') error (eEQ); + else getToken(); + + (void)pas_DeclareType(typeName); + if (token != ';') break; + else getToken(); + + } + else break; + } +} + +/***************************************************************/ + +void variableDeclarationGroup(void) +{ + /* Process variable-declaration-group + * FORM: variable-declaration-group = + * 'var' variable-declaration { ';' variable-declaration } + * FORM: variable-declaration = identifier-list ':' type-denoter + * FORM: identifier-list = identifier { ',' identifier } + * + * Only entry, token holds the first identfier (if any) of the + * variable-declaration list. + */ + + for (;;) + { + if (token == tIDENT) + { + (void)pas_DeclareVar(); + if (token != ';') break; + else getToken(); + } + else if (token == sFILE) + { + pas_DeclareFile(); + if (token != ';') break; + else getToken(); + } + else break; + } +} + +/***************************************************************/ +/* Process formal-parameter-list */ + +int16_t formalParameterList(STYPE *procPtr) +{ + int16_t parameterOffset; + int16_t i; + bool pointerType; + + TRACE(lstFile,"[formalParameterList]"); + + /* FORM: formal-parameter-list = + * '(' formal-parameter-section { ';' formal-parameter-section } ')' + * FORM: formal-parameter-section = + * value-parameter-specification | + * variable-parameter-specification | + * procedure-parameter-specification | + * function-parameter-specification + * FORM: value-parameter-specification = + * identifier-list ':' type-identifier + * FORM: variable-parameter-specification = + * 'var' identifier-list ':' type-identifier + * + * On entry token should refer to the '(' at the beginning of the + * (optional) formal parameter list. + */ + + g_nParms = 0; + + /* Check if the formal-parameter-list is present. It is optional in + * all contexts in which this function is called. + */ + + if (token == '(') + { + /* Process each formal-parameter-section */ + + do + { + getToken(); + + /* Check for variable-parameter-specification */ + + if (token == tVAR) + { + pointerType = 1; + getToken(); + } + else pointerType = 0; + + /* Process the common part of the variable-parameter-specification + * and the value-parameter specification. + * NOTE that procedure-parameter-specification and + * function-parameter-specification are not yet supported. + */ + + (void)pas_DeclareParameter(pointerType); + + } + while (token == ';'); + + /* Verify that the formal parameter list terminates with a + * right parenthesis. + */ + + if (token != ')') error (eRPAREN); + else getToken(); + + } + + /* Save the number of parameters found in sPROC/sFUNC symbol table entry */ + + procPtr->sParm.p.nParms = g_nParms; + + /* Now, calculate the parameter offsets from the size of each parameter */ + + parameterOffset = -sRETURN_SIZE; + for (i = g_nParms; i > 0; i--) + { + /* The offset to the next parameter is the offset to the previous + * parameter minus the size of the new parameter (aligned to + * multiples of size of INTEGER). + */ + + parameterOffset -= procPtr[i].sParm.v.size; + parameterOffset = intAlign(parameterOffset); + procPtr[i].sParm.v.offset = parameterOffset; + } + + return parameterOffset; +} + +/*************************************************************** + * Private Functions + ***************************************************************/ +/* Process LABEL block */ + +static void pas_DeclareLabel(void) +{ + char *labelname; /* Label symbol table name */ + + TRACE(lstFile,"[pas_DeclareLabel]"); + + /* FORM: LABEL <integer>[,<integer>[,<integer>][...]]]; */ + + do + { + getToken(); + if ((token == tINT_CONST) && (tknInt >= 0)) + { + labelname = stringSP; + (void)sprintf (labelname, "%ld", tknInt); + while (*stringSP++); + (void)addLabel(labelname, ++label); + getToken(); + } + else error(eINTCONST); + } + while (token == ','); + + if (token != ';') error (eSEMICOLON); + else getToken(); +} + +/***************************************************************/ +/* Process constant definition: + * FORM: constant-definition = identifier '=' constant + * FORM: constant = [ sign ] integer-number | + * [ sign ] real-number | + * [ sign ] constant-identifier | + * character-literal | + * string-literal + */ + +static void pas_DeclareConst(void) +{ + char *const_name; + + TRACE(lstFile,"[pas_DeclareConst]"); + + /* FORM: <identifier> = <numeric constant|string> + * NOTE: Only integer constants are supported + */ + + /* Save the name of the constant */ + + const_name = tkn_strt; + + /* Verify that the name is followed by '=' and get the + * following constant value. + */ + + getToken(); + if (token != '=') error (eEQ); + else getToken(); + + /* Handle constant expressions */ + + constantExpression(); + + /* Add the constant to the symbol table based on the type of + * the constant found following the '= [ sign ]' + */ + + switch (constantToken) + { + case tINT_CONST : + case tCHAR_CONST : + case tBOOLEAN_CONST : + case sSCALAR_OBJECT : + (void)addConstant(const_name, constantToken, &constantInt, NULL); + break; + + case tREAL_CONST : + (void)addConstant(const_name, constantToken, (int32_t*)&constantReal, NULL); + break; + + case tSTRING_CONST : + { + uint32_t offset = poffAddRoDataString(poffHandle, constantStart); + (void)addStringConst(const_name, offset, strlen(constantStart)); + } + break; + + default : + error(eINVCONST); + } +} + +/***************************************************************/ +/* Process TYPE declaration */ + +static STYPE *pas_DeclareType(char *typeName) +{ + STYPE *typePtr; + + TRACE(lstFile,"[pas_DeclareType]"); + + /* This function processes the type-denoter in + * FORM: type-definition = identifier '=' type-denoter + * FORM: array-type = 'array' '[' index-type-list ']' 'of' type-denoter + */ + + /* FORM: type-denoter = type-identifier | new-type + * FORM: new-type = new-ordinal-type | new-complex-type + */ + + typePtr = pas_NewComplexType(typeName); + if (typePtr == NULL) + { + /* Check for Simple Types */ + + typePtr = pas_DeclareOrdinalType(typeName); + if (typePtr == NULL) + { + error(eINVTYPE); + } + } + + return typePtr; +} + +/***************************************************************/ +/* Process a simple TYPE declaration */ + +static STYPE *pas_DeclareOrdinalType(char *typeName) +{ + STYPE *typePtr; + STYPE *typeIdPtr; + + /* Declare a new ordinal type */ + + typePtr = pas_NewOrdinalType(typeName); + + /* Otherwise, declare a type equivalent to a previously defined type + * NOTE: the following logic is incomplete. Its is only good for + * sKind == sType + */ + + if (typePtr == NULL) + { + typeIdPtr = pas_TypeIdentifier(1); + if (typeIdPtr) + { + typePtr = addTypeDefine(typeName, typeIdPtr->sParm.t.type, + g_dwVarSize, typeIdPtr); + } + } + + return typePtr; +} + +/***************************************************************/ +/* Process VAR declaration */ + +static STYPE *pas_DeclareVar(void) +{ + STYPE *varPtr; + STYPE *typePtr; + char *varName; + + TRACE(lstFile,"[pas_DeclareVar]"); + + /* FORM: variable-declaration = identifier-list ':' type-denoter + * FORM: identifier-list = identifier { ',' identifier } + */ + + typePtr = NULL; + + /* Save the current identifier */ + + varName = tkn_strt; + getToken(); + + /* A comma indicates that there is another indentifier int the + * identifier-list + */ + + if (token == ',') + { + /* Yes ..Process the next identifer in the indentifier list + * via recursion + */ + + getToken(); + if (token != tIDENT) error(eIDENT); + else typePtr = pas_DeclareVar(); + } + else + { + /* No.. verify that the identifer-list is followed by ';' */ + + if (token != ':') error(eCOLON); + else getToken(); + + /* Process the type-denoter */ + + typePtr = pas_TypeDenoter(varName, 1); + if (typePtr == NULL) + { + error(eINVTYPE); + } + } + + if (typePtr) + { + uint8_t varType = typePtr->sParm.t.type; + + /* Determine if alignment to INTEGER boundaries is necessary */ + + if ((!isIntAligned(dstack)) && (pas_IntAlignRequired(typePtr))) + dstack = intAlign(dstack); + + /* Add the new variable to the symbol table */ + + varPtr = addVariable(varName, varType, dstack, g_dwVarSize, typePtr); + + /* If the variable is declared in an interface section at level zero, + * then it is a candidate to imported or exported. + */ + + if ((!level) && (FP->section == eIsInterfaceSection)) + { + /* Are we importing or exporting the interface? + * + * PROGRAM EXPORTS: + * If we are generating a program binary (i.e., FP0->kind == + * eIsProgram) then the variable memory allocation must appear + * on the initial stack allocation; therefore the variable + * stack offset myst be exported by the program binary. + * + * UNIT IMPORTS: + * If we are generating a unit binary (i.e., FP0->kind == + * eIsUnit), then we are importing the level 0 stack offset + * from the main program. + */ + + if (FP0->kind == eIsUnit) + { + /* Mark the symbol as external and replace the absolute + * offset with this relative offset. + */ + + varPtr->sParm.v.flags |= SVAR_EXTERNAL; + varPtr->sParm.v.offset = dstack - FP->dstack; + + /* IMPORT the symbol; assign an offset relative to + * the dstack at the beginning of this file + */ + + pas_GenerateStackImport(varPtr); + } + else /* if (FP0->kind == eIsProgram) */ + { + /* EXPORT the symbol */ + + pas_GenerateStackExport(varPtr); + } + } + + /* In any event, bump the stack offset to include space for + * this new symbol. The 'bumped' stack offset will be the + * offset for the next variable that is declared. + */ + + dstack += g_dwVarSize; + } + + return typePtr; +} + +/***************************************************************/ +/* Process VAR FILE OF declaration */ + +static void pas_DeclareFile(void) +{ + int16_t fileNumber = tknPtr->sParm.fileNumber; + STYPE *filePtr; + + TRACE(lstFile,"[pas_DeclareFile]"); + + /* FORM: <file identifier> : FILE OF <type> */ + /* OR: <file identifier> : <FILE OF type identifier> */ + if (!(fileNumber)) error(eINVFILE); + else if (files [fileNumber].defined) error(eDUPFILE); + else { + + /* Skip over the <file identifier> */ + getToken(); + + /* Verify that a colon follows the <file identifier> */ + if (token != ':') error (eCOLON); + else getToken(); + + /* Make sure that the data stack is aligned to INTEGER boundaries */ + dstack = intAlign(dstack); + + /* FORM: <file identifier> : FILE OF <type> */ + if (token == sFILE_OF) { + + files[fileNumber].defined = -1; + files[fileNumber].flevel = level; + files[fileNumber].ftype = tknPtr->sParm.t.type; + files[fileNumber].faddr = dstack; + files[fileNumber].fsize = tknPtr->sParm.t.asize; + dstack += (tknPtr->sParm.t.asize); + getToken(); + + } + + /* FORM: <file identifier> : <FILE OF type identifier> */ + else { + if (token != tFILE) error (eFILE); + else getToken(); + if (token != tOF) error (eOF); + else getToken(); + + filePtr = pas_TypeIdentifier(1); + if (filePtr) { + + files[fileNumber].defined = -1; + files[fileNumber].flevel = level; + files[fileNumber].ftype = filePtr->sParm.t.type; + files[fileNumber].faddr = dstack; + files[fileNumber].fsize = g_dwVarSize; + dstack += g_dwVarSize; + + } + } + } +} + +/***************************************************************/ +/* Process Procedure Declaration Block */ + +static void pas_ProcedureDeclaration(void) +{ + uint16_t procLabel = ++label; + char *saveStringSP; + STYPE *procPtr; + register int i; + + TRACE(lstFile,"[pas_ProcedureDeclaration]"); + + /* FORM: procedure-declaration = + * procedure-heading ';' directive | + * procedure-heading ';' procedure-block + * FORM: procedure-heading = + * 'procedure' identifier [ formal-parameter-list ] + * FORM: procedure-identifier = identifier + * + * On entry, token refers to token AFTER the 'procedure' reserved + * word. + */ + + /* Process the procedure-heading */ + + if (token != tIDENT) + { + error (eIDENT); + return; + } + + /* Add the procedure to the symbol table */ + + procPtr = addProcedure(tkn_strt, sPROC, procLabel, 0, NULL); + + /* Save the string stack pointer so that we can release all + * formal parameter strings later. Then get the next token. + */ + + saveStringSP = stringSP; + getToken(); + + /* NOTE: The level associated with the PROCEDURE symbol is the level + * At which the procedure was declared. Everything declare within the + * PROCEDURE is at the next level + */ + + level++; + + /* Process parameter list */ + + (void)formalParameterList(procPtr); + + if (token != ';') error (eSEMICOLON); + else getToken(); + + /* If we are here then we know that we are either in a program file + * or the 'implementation' part of a unit file (see punit.c -- At present, + * the procedure declarations of the 'interface' section of a unit file + * follow a different path). In the latter case (only), we should export + * every procedure declared at level zero. + */ + + if ((level == 1) && (FP->kind == eIsUnit)) + { + /* EXPORT the procedure symbol. */ + + pas_GenerateProcExport(procPtr); + } + + /* Save debug information about the procedure */ + + pas_GenerateDebugInfo(procPtr, 0); + + /* Process block */ + + pas_GenerateDataOperation(opLABEL, (int32_t)procLabel); + block(); + + /* Destroy formal parameter names */ + + for (i = 1; i <= procPtr->sParm.p.nParms; i++) + { + procPtr[i].sName = NULL; + } + + stringSP = saveStringSP; + + /* Generate exit from procedure */ + + pas_GenerateSimple(opRET); + level--; + + /* Verify that END terminates with a semicolon */ + + if (token != ';') error (eSEMICOLON); + else getToken(); +} + +/***************************************************************/ +/* Process Function Declaration Block */ + +static void pas_FunctionDeclaration(void) +{ + uint16_t funcLabel = ++label; + int16_t parameterOffset; + char *saveStringSP; + STYPE *funcPtr; + STYPE *valPtr; + STYPE *typePtr; + char *funcName; + register int i; + + TRACE(lstFile,"[pas_FunctionDeclaration]"); + + /* FORM: function-declaration = + * function-heading ';' directive | + * function-heading ';' function-block + * FORM: function-heading = + * 'function' function-identifier [ formal-parameter-list ] + * ':' result-type + * + * On entry token should lrefer to the function-identifier. + */ + + /* Verify function-identifier */ + + if (token != tIDENT) + { + error (eIDENT); + return; + } + + funcPtr = addProcedure(tkn_strt, sFUNC, funcLabel, 0, NULL); + + /* NOTE: The level associated with the FUNCTION symbol is the level + * At which the procedure was declared. Everything declare within the + * PROCEDURE is at the next level + */ + + level++; + + /* Save the string stack pointer so that we can release all + * formal parameter strings later. Then get the next token. + */ + + funcName = tkn_strt; + saveStringSP = stringSP; + getToken(); + + /* Process parameter list */ + + parameterOffset = formalParameterList(funcPtr); + + /* Verify that the parameter list is followed by a colon */ + + if (token != ':') error (eCOLON); + else getToken(); + + /* Declare the function return value variable. This variable has + * the same name as the function itself. We fill the variable + * symbol descriptor with bogus information now (but we fix it + * below). + */ + + valPtr = addVariable(funcName, sINT, 0, sINT_SIZE, NULL); + + /* Get function type, return value type/size and offset to return value */ + + typePtr = pas_TypeIdentifier(0); + if (typePtr) { + + /* The offset to the return value is the offset to the last + * parameter minus the size of the return value (aligned to + * multiples of size of INTEGER). + */ + + parameterOffset -= g_dwVarSize; + parameterOffset = intAlign(parameterOffset); + + /* Save the TYPE for the function return value local variable */ + + valPtr->sKind = typePtr->sParm.t.rtype; + valPtr->sParm.v.offset = parameterOffset; + valPtr->sParm.v.size = g_dwVarSize; + valPtr->sParm.v.parent = typePtr; + + /* Save the TYPE for the function */ + + funcPtr->sParm.p.parent = typePtr; + + /* If we are here then we know that we are either in a program file + * or the 'implementation' part of a unit file (see punit.c -- At present, + * the function declarations of the 'interface' section of a unit file + * follow a different path). In the latter case (only), we should export + * every function declared at level zero. + */ + + if ((level == 1) && (FP->kind == eIsUnit)) + { + /* EXPORT the function symbol. */ + + pas_GenerateProcExport(funcPtr); + } + } + else + error(eINVTYPE); + + /* Save debug information about the function */ + + pas_GenerateDebugInfo(funcPtr, g_dwVarSize); + + /* Process block */ + + if (token != ';') error (eSEMICOLON); + else getToken(); + + pas_GenerateDataOperation(opLABEL, (int32_t)funcLabel); + block(); + + /* Destroy formal parameter names and the function return value name */ + + for (i = 1; i <= funcPtr->sParm.p.nParms; i++) + { + funcPtr[i].sName = ((char *) NULL); + } + + valPtr->sName = ((char *) NULL); + stringSP = saveStringSP; + + /* Generate exit from procedure/function */ + + pas_GenerateSimple(opRET); + level--; + + /* Verify that END terminates with a semicolon */ + + if (token != ';') error (eSEMICOLON); + else getToken(); +} + +/***************************************************************/ +/* Determine the size value to use with this type */ + +static void pas_SetTypeSize(STYPE *typePtr, bool allocate) +{ + TRACE(lstFile,"[pas_SetTypeSize]"); + + /* Check for type-identifier */ + + g_dwVarSize = 0; + + if (typePtr != NULL) + { + /* If allocate is true, then we want to return the size of + * the type that we would use if we are going to allocate + * an instance on the stack. + */ + + if (allocate) + { + /* Could it be a storage size value (such as is used for + * the enhanced pascal string type?). In an weak attempt to + * be compatible with everyone in the world, we will allow + * either '[]' or '()' to delimit the size specification. + */ + + if (((token == '[') || (token == '(')) && + ((typePtr->sParm.t.flags & STYPE_VARSIZE) != 0)) + { + uint16_t term_token; + uint16_t errcode; + + /* Yes... we need to parse the size from the input stream. + * First, determine which token will terminate the size + * specification. + */ + + if (token == '(') + { + term_token = ')'; /* Should end with ')' */ + errcode = eRPAREN; /* If not, this is the error */ + } + else + { + term_token = ']'; /* Should end with ']' */ + errcode = eRBRACKET; /* If not, this is the error */ + } + + /* Now, parse the size specification */ + + /* We expect the size to consist of a single integer constant. + * We should support any constant integer expression, but this + * has not yet been implemented. + */ + + getToken(); + if (token != tINT_CONST) error(eINTCONST); + /* else if (tknInt <= 0) error(eINVCONST); see below */ + else if (tknInt <= 2) error(eINVCONST); + else + { + /* Use the value of the integer constant for the size + * the allocation. NOTE: There is a problem here in + * that for the sSTRING type, it wants the first 2 bytes + * for the string length. This means that the actual + * length is real two less than the specified length. + */ + + g_dwVarSize = tknInt; + } + + /* Verify that the correct token terminated the size + * specification. This could be either ')' or ']' + */ + + getToken(); + if (token != term_token) error(errcode); + else getToken(); + } + else + { + /* Return the fixed size of the allocated instance of + * this type */ + + g_dwVarSize = typePtr->sParm.t.asize; + } + } + + /* If allocate is false, then we want to return the size of + * the type that we would use if we are going to refer to + * a reference on the stack. This is really non-standard + * and is handle certain optimatizations where we cheat and + * pass some types by reference rather than by value. The + * enhanced pascal string type is the only example at present. + */ + + else + { + /* Return the size to a clone, reference to an instance */ + + g_dwVarSize = typePtr->sParm.t.rsize; + } + } +} + +/***************************************************************/ +/* Verify that the next token is a type identifer + * NOTE: This function modifies the global variable g_dwVarSize + * as a side-effect + */ + +static STYPE *pas_TypeIdentifier(bool allocate) +{ + STYPE *typePtr = NULL; + + TRACE(lstFile,"[pas_TypeIdentifier]"); + + /* Check for type-identifier */ + + if (token == sTYPE) + { + /* Return a reference to the type token. */ + + typePtr = tknPtr; + getToken(); + + /* Return the size value associated with this type */ + + pas_SetTypeSize(typePtr, allocate); + } + + return typePtr; +} + +/***************************************************************/ + +static STYPE *pas_TypeDenoter(char *typeName, bool allocate) +{ + STYPE *typePtr; + + TRACE(lstFile,"[pas_TypeDenoter]"); + + /* FORM: type-denoter = type-identifier | new-type + * + * Check for type-identifier + */ + + typePtr = pas_TypeIdentifier(allocate); + if (typePtr != NULL) + { + /* Return the type identifier */ + + return typePtr; + } + + /* Check for new-type + * FORM: new-type = new-ordinal-type | new-complex-type + */ + + /* Check for new-complex-type */ + + typePtr = pas_NewComplexType(typeName); + if (typePtr == NULL) + { + /* Check for new-ordinal-type */ + + typePtr = pas_NewOrdinalType(typeName); + } + + /* Return the size value associated with this type */ + + pas_SetTypeSize(typePtr, allocate); + + return typePtr; +} + +/***************************************************************/ +/* Declare is new ordinal type */ + +static STYPE *pas_NewOrdinalType(char *typeName) +{ + STYPE *typePtr = NULL; + + /* Declare a new-ordinal-type + * FORM: new-ordinal-type = enumerated-type | subrange-type + */ + + /* FORM: enumerated-type = '(' enumerated-constant-list ')' */ + + if (token == '(') + { + int32_t nObjects; + nObjects = 0; + typePtr = addTypeDefine(typeName, sSCALAR, sINT_SIZE, NULL); + + /* Now declare each instance of the scalar */ + + do { + getToken(); + if (token != tIDENT) error(eIDENT); + else + { + (void)addConstant(tkn_strt, sSCALAR_OBJECT, &nObjects, typePtr); + nObjects++; + getToken(); + } + } while (token == ','); + + /* Save the number of objects associated with the scalar type (the + * maximum ORD is nObjects - 1). */ + + typePtr->sParm.t.maxValue = nObjects - 1; + + if (token != ')') error(eRPAREN); + else getToken(); + + } + + /* Declare a new subrange type + * FORM: subrange-type = constant '..' constant + * FORM: constant = + * [ sign ] integer-number | [ sign ] real-number | + * [ sign ] constant-identifier | character-literal | string-literal + * + * Case 1: <constant> is INTEGER + */ + + else if (token == tINT_CONST) + { + /* Create the new INTEGER subrange type */ + + typePtr = addTypeDefine(typeName, sSUBRANGE, sINT_SIZE, NULL); + typePtr->sParm.t.subType = sINT; + typePtr->sParm.t.minValue = tknInt; + typePtr->sParm.t.maxValue = MAXINT; + + /* Verify that ".." separates the two constants */ + + getToken(); + if (token != tSUBRANGE) error(eSUBRANGE); + else getToken(); + + /* Verify that the ".." is following by an INTEGER constant */ + + if ((token != tINT_CONST) || (tknInt < typePtr->sParm.t.minValue)) + error(eSUBRANGETYPE); + else + { + typePtr->sParm.t.maxValue = tknInt; + getToken(); + } + } + + /* Case 2: <constant> is CHAR */ + + else if (token == tCHAR_CONST) + { + /* Create the new CHAR subrange type */ + + typePtr = addTypeDefine(typeName, sSUBRANGE, sCHAR_SIZE, NULL); + typePtr->sParm.t.subType = sCHAR; + typePtr->sParm.t.minValue = tknInt; + typePtr->sParm.t.maxValue = MAXCHAR; + + /* Verify that ".." separates the two constants */ + + getToken(); + if (token != tSUBRANGE) error(eSUBRANGE); + else getToken(); + + /* Verify that the ".." is following by a CHAR constant */ + + if ((token != tCHAR_CONST) || (tknInt < typePtr->sParm.t.minValue)) + error(eSUBRANGETYPE); + else + { + typePtr->sParm.t.maxValue = tknInt; + getToken(); + } + } + + /* Case 3: <constant> is a SCALAR type */ + + else if (token == sSCALAR_OBJECT) + { + /* Create the new SCALAR subrange type */ + + typePtr = addTypeDefine(typeName, sSUBRANGE, sINT_SIZE, tknPtr); + typePtr->sParm.t.subType = token; + typePtr->sParm.t.minValue = tknInt; + typePtr->sParm.t.maxValue = MAXINT; + + /* Verify that ".." separates the two constants */ + + getToken(); + if (token != tSUBRANGE) error(eSUBRANGE); + else getToken(); + + /* Verify that the ".." is following by a SCALAR constant of the same + * type as the one which preceded it + */ + + if ((token != sSCALAR_OBJECT) || + (tknPtr != typePtr->sParm.t.parent) || + (tknPtr->sParm.c.val.i < typePtr->sParm.t.minValue)) + error(eSUBRANGETYPE); + else + { + typePtr->sParm.t.maxValue = tknPtr->sParm.c.val.i; + getToken(); + } + } + + return typePtr; +} + +/***************************************************************/ + +static STYPE *pas_NewComplexType(char *typeName) +{ + STYPE *typePtr = NULL; + STYPE *typeIdPtr; + + TRACE(lstFile,"[pas_TypeDenoter]"); + + /* FORM: new-complex-type = new-structured-type | new-pointer-type */ + + switch (token) + { + /* FORM: new-pointer-type = '^' domain-type | '@' domain-type */ + + case '^' : + getToken(); + typeIdPtr = pas_TypeIdentifier(1); + if (typeIdPtr) + { + typePtr = addTypeDefine(typeName, sPOINTER, g_dwVarSize, typeIdPtr); + } + else + { + error(eINVTYPE); + } + break; + + /* FORM: new-structured-type = + * [ 'packed' ] array-type | [ 'packed' ] record-type | + * [ 'packed' ] set-type | [ 'packed' ] file-type | + * [ 'packed' ] list-type | object-type | string-type + */ + + /* PACKED Types */ + + case tPACKED : + error (eNOTYET); + getToken(); + if (token != tARRAY) break; + /* Fall through to process PACKED ARRAY type */ + + /* Array Types + * FORM: array-type = 'array' [ index-type-list ']' 'of' type-denoter + */ + + case tARRAY : + getToken(); + typeIdPtr = pas_GetArrayType(); + if (typeIdPtr) + { + typePtr = addTypeDefine(typeName, sARRAY, g_dwVarSize, typeIdPtr); + } + else + { + error(eINVTYPE); + } + break; + + /* RECORD Types + * FORM: record-type = 'record' field-list 'end' + */ + + case tRECORD : + getToken(); + typePtr = pas_DeclareRecord(typeName); + break; + + /* Set Types + * + * FORM: set-type = 'set' 'of' ordinal-type + */ + + case tSET : + + /* Verify that 'set' is followed by 'of' */ + + getToken(); + if (token != tOF) error (eOF); + else getToken(); + + /* Verify that 'set of' is followed by an ordinal-type + * If not, then declare a new one with no name + */ + + typeIdPtr = pas_OrdinalTypeIdentifier(1); + if (typeIdPtr) + getToken(); + else + typeIdPtr = pas_DeclareOrdinalType(NULL); + + /* Verify that the ordinal-type is either a scalar or a + * subrange type. These are the only valid types for 'set of' + */ + + if ((typeIdPtr) && + ((typeIdPtr->sParm.t.type == sSCALAR) || + (typeIdPtr->sParm.t.type == sSUBRANGE))) + { + /* Declare the SET type */ + + typePtr = addTypeDefine(typeName, sSET_OF, + typeIdPtr->sParm.t.asize, typeIdPtr); + + if (typePtr) + { + int16_t nObjects; + + /* Copy the scalar/subrange characteristics for convenience */ + + typePtr->sParm.t.subType = typeIdPtr->sParm.t.type; + typePtr->sParm.t.minValue = typeIdPtr->sParm.t.minValue; + typePtr->sParm.t.maxValue = typeIdPtr->sParm.t.minValue; + + /* Verify that the number of objects associated with the + * scalar or subrange type will fit into an integer + * representation of a set as a bit-string. + */ + + nObjects = typeIdPtr->sParm.t.maxValue + - typeIdPtr->sParm.t.minValue + 1; + if (nObjects > BITS_IN_INTEGER) + { + error(eSETRANGE); + typePtr->sParm.t.maxValue = typePtr->sParm.t.minValue + + BITS_IN_INTEGER - 1; + } + } + } + else + error(eSET); + break; + + /* File Types + * FORM: file-type = 'file' 'of' type-denoter + */ + + /* FORM: file-type = 'file' 'of' type-denoter */ + + case tFILE : + + /* Make sure that 'file' is followed by 'of' */ + + getToken(); + if (token != tOF) error (eOF); + else getToken(); + + /* Get the type-denoter */ + + typeIdPtr = pas_TypeDenoter(NULL,1); + if (typeIdPtr) + { + typePtr = addTypeDefine(typeName, sFILE_OF, g_dwVarSize, typeIdPtr); + if (typePtr) + { + typePtr->sParm.t.subType = typeIdPtr->sParm.t.type; + } + } + else + { + error(eINVTYPE); + } + break; + + /* FORM: string-type = pascal-string-type | c-string-type + * FORM: pascal-string-type = 'string' [ max-string-length ] + */ + case sSTRING : + error (eNOTYET); + getToken(); + break; + + /* FORM: list-type = 'list' 'of' type-denoter */ + /* FORM: object-type = 'object' | 'class' */ + default : + break; + + } + + return typePtr; +} + +/***************************************************************/ +/* Verify that the next token is a type identifer + */ + +static STYPE *pas_OrdinalTypeIdentifier(bool allocate) +{ + STYPE *typePtr; + + TRACE(lstFile,"[pas_OrdinalTypeIdentifier]"); + + /* Get the next type from the input stream */ + + typePtr = pas_TypeIdentifier(allocate); + + /* Was a type encountered? */ + + if (typePtr != NULL) + { + switch (typePtr->sParm.t.type) + { + /* Check for an ordinal type (verify this list!) */ + + case sINT : + case sBOOLEAN : + case sCHAR : + case sSCALAR : + case sSUBRANGE: + /* If it is an ordinal type, then just return the + * type pointer. + */ + + break; + default : + /* If not, return NULL */ + + typePtr = NULL; + break; + } + } + return typePtr; +} + +/***************************************************************/ +/* get array type argument for TYPE block or variable declaration */ + +static STYPE *pas_GetArrayType(void) +{ + STYPE *typePtr = NULL; + + TRACE(lstFile,"[pas_GetArrayType]"); + + /* FORM: array-type = 'array' '[' index-type-list ']' 'of' type-denoter */ + /* FORM: [PACKED] ARRAY [<integer>] OF type-denoter + * NOTE: Bracketed value is the array size! NONSTANDARD! */ + + g_dwVarSize = 0; + + /* Verify that the index-type-list is preceded by '[' */ + + if (token != '[') error (eLBRACKET); + else + { + /* FORM: index-type-list = index-type { ',' index-type } + * FORM: index-type = ordinal-type + */ + + getToken(); + if (token != tINT_CONST) error (eINTCONST); + else + { + g_dwVarSize = tknInt; + getToken(); + + /* Verify that the index-type-list is followed by ']' */ + + if (token != ']') error (eRBRACKET); + else getToken(); + + /* Verify that 'of' precedes the type-denoter */ + + if (token != tOF) error (eOF); + else getToken(); + + /* We have the array size in elements, not get the type and convert + * the size for the type found + */ + + typePtr = pas_DeclareType(NULL); + if (typePtr) + { + g_dwVarSize *= typePtr->sParm.t.asize; + } + } + } + + return typePtr; +} + +/***************************************************************/ + +static STYPE *pas_DeclareRecord(char *recordName) +{ + STYPE *recordPtr; + int16_t recordOffset; + int recordCount, symbolIndex; + + TRACE(lstFile,"[pas_DeclareRecord]"); + + /* FORM: record-type = 'record' field-list 'end' */ + + /* Declare the new RECORD type */ + + recordPtr = addTypeDefine(recordName, sRECORD, 0, NULL); + + /* Then declare the field-list associated with the RECORD + * FORM: field-list = + * [ + * fixed-part [ ';' ] variant-part [ ';' ] | + * fixed-part [ ';' ] | + * variant-part [ ';' ] | + * ] + * + * Process the fixed-part first. + * FORM: fixed-part = record-section { ';' record-section } + * FORM: record-section = identifier-list ':' type-denoter + * FORM: identifier-list = identifier { ',' identifier } + */ + + for (;;) + { + /* Terminate parsing of the fixed-part when we encounter + * 'case' indicating the beginning of the variant part of + * the record. If there is no fixed-part, then 'case' will + * appear immediately. + */ + + if (token == tCASE) break; + + /* We now expect to see and indentifier representating the + * beginning of the next fixed field. + */ + + (void)pas_DeclareField(recordPtr); + + /* If the field declaration terminates with a semicolon, then + * we expect to see another <fixed part> declaration in the + * record. + */ + + if (token == ';') + { + /* Skip over the semicolon and process the next fixed + * field declaration. + */ + + getToken(); + + /* We will treat this semi colon as optional. If we + * hit 'end' or 'case' after the semicolon, then we + * will terminate the fixed part with no complaint. + */ + + if ((token == tEND) || (token == tCASE)) + break; + } + + /* If there is no semicolon after the field declaration, + * then 'end' or 'case' is expected. This will be verified + * below. + */ + + else break; + } + + /* Get the total size of the RECORD type and the offset of each + * field within the RECORD. + */ + + for (recordOffset = 0, symbolIndex = 1, recordCount = 0; + recordCount < recordPtr->sParm.t.maxValue; + symbolIndex++) + { + /* We know that 'maxValue' sRECORD_OBJECT symbols follow the sRECORD + * type declaration. However, these may not be sequential due to the + * possible declaration of sTYPEs associated with each field. + */ + + if (recordPtr[symbolIndex].sKind == sRECORD_OBJECT) + { + /* Align the recordOffset (if necessary) */ + + if ((!isIntAligned(recordOffset)) && + (pas_IntAlignRequired(recordPtr[symbolIndex].sParm.r.parent))) + recordOffset = intAlign(recordOffset); + + /* Save the offset associated with this field, and determine the + * offset to the next field (if there is one) + */ + + recordPtr[symbolIndex].sParm.r.offset = recordOffset; + recordOffset += recordPtr[symbolIndex].sParm.r.size; + recordCount++; + } + } + + /* Update the RECORD entry for the total size of all fields */ + + recordPtr->sParm.t.asize = recordOffset; + + /* Now we are ready to process the variant-part. + * FORM: variant-part = 'case' variant-selector 'of' variant-body + */ + + if (token == tCASE) + { + int16_t variantOffset; + uint16_t maxRecordSize; + + /* Skip over the 'case' */ + + getToken(); + + /* Check for variant-selector + * FORM: variant-selector = [ identifier ':' ] ordinal-type-identifer + */ + + if (token != tIDENT) error(eRECORDDECLARE); + + /* Add a variant-selector to the fixed-part of the record */ + + else + { + STYPE *typePtr; + char *fieldName; + + /* Save the field name */ + + fieldName = tkn_strt; + getToken(); + + /* Verify that the identifier is followed by a colon */ + + if (token != ':') error(eCOLON); + else getToken(); + + /* Get the ordinal-type-identifier */ + + typePtr = pas_OrdinalTypeIdentifier(1); + if (!typePtr) error(eINVTYPE); + else + { + STYPE *fieldPtr; + + /* Declare a <field> with this <identifier> as its name */ + + fieldPtr = addField(fieldName, recordPtr); + + /* Increment the number of fields in the record */ + + recordPtr->sParm.t.maxValue++; + + /* Copy the size of field from the sTYPE entry into the + * <field> type entry. NOTE: This element is not essential + * since it can be obtained from the parent type pointer + */ + + fieldPtr->sParm.r.size = typePtr->sParm.t.asize; + + /* Save a pointer back to the parent field type */ + + fieldPtr->sParm.r.parent = typePtr; + + /* Align the recordOffset (if necessary) */ + + if ((!isIntAligned(recordOffset)) && + (pas_IntAlignRequired(typePtr))) + recordOffset = intAlign(recordOffset); + + /* Save the offset associated with this field, and determine + * the offset to the next field (if there is one) + */ + + fieldPtr->sParm.r.offset = recordOffset; + recordOffset += recordPtr[symbolIndex].sParm.r.size; + } + } + + /* Save the offset to the start of the variant portion of the RECORD */ + + variantOffset = recordOffset; + maxRecordSize = recordOffset; + + /* Skip over the 'of' following the variant selector */ + + if (token != tOF) error(eOF); + else getToken(); + + /* Loop to process the variant-body + * FORM: variant-body = + * variant-list [ [ ';' ] variant-part-completer ] | + * variant-part-completer + * FORM: variant-list = variant { ';' variant } + * FORM: variant-part-completer = ( 'otherwise' | 'else' ) ( field-list ) + */ + + for (;;) + { + /* Now process each variant where: + * FORM: variant = case-constant-list ':' '(' field-list ')' + * FORM: case-constant-list = case-specifier { ',' case-specifier } + * FORM: case-specifier = case-constant [ '..' case-constant ] + */ + + /* Verify that the case selector begins with a case-constant. + * Note that subrange case-specifiers are not yet supported. + */ + + if (!isConstant(token)) + { + error(eINVCONST); + break; + } + + /* Just consume the <case selector> for now -- Really need to + * verify that each constant is of the same type as the type + * identifier (or the type associated with the tag) in the CASE + */ + + do + { + getToken(); + if (token == ',') getToken(); + } + while (isConstant(token)); + + /* Make sure a colon separates case-constant-list from the + * field-list + */ + + if (token == ':') getToken(); + else error(eCOLON); + + /* The field-list must be enclosed in parentheses */ + + if (token == '(') getToken(); + else error(eLPAREN); + + /* Special case the empty variant <field list> */ + + if (token != ')') + { + /* Now process the <field list> for the variant. This works + * just like the field list of the fixed part, except the + * offset is reset for each variant. + * FORM: field-list = + * [ + * fixed-part [ ';' ] variant-part [ ';' ] | + * fixed-part [ ';' ] | + * variant-part [ ';' ] | + * ] + */ + + for (;;) + { + /* We now expect to see and indentifier representating the + * beginning of the next variablefield. + */ + + (void)pas_DeclareField(recordPtr); + + /* If the field declaration terminates with a semicolon, + * then we expect to see another <variable part> + * declaration in the record. + */ + + if (token == ';') + { + /* Skip over the semicolon and process the next + * variable field declaration. + */ + + getToken(); + + /* We will treat this semi colon as optional. If we + * hit 'end' after the semicolon, then we will + * terminate the fixed part with no complaint. + */ + + if (token == tEND) + break; + } + else break; + } + + /* Get the total size of the RECORD type and the offset of each + * field within the RECORD. + */ + + for (recordOffset = variantOffset; + recordCount < recordPtr->sParm.t.maxValue; + symbolIndex++) + { + /* We know that 'maxValue' sRECORD_OBJECT symbols follow + * the sRECORD type declaration. However, these may not + * be sequential due to the possible declaration of sTYPEs + * associated with each field. + */ + + if (recordPtr[symbolIndex].sKind == sRECORD_OBJECT) + { + /* Align the recordOffset (if necessary) */ + + if ((!isIntAligned(recordOffset)) && + (pas_IntAlignRequired(recordPtr[symbolIndex].sParm.r.parent))) + recordOffset = intAlign(recordOffset); + + /* Save the offset associated with this field, and + * determine the offset to the next field (if there + * is one) + */ + + recordPtr[symbolIndex].sParm.r.offset = recordOffset; + recordOffset += recordPtr[symbolIndex].sParm.r.size; + recordCount++; + } + } + + /* Check if this is the largest variant that we have found + * so far + */ + + if (recordOffset > maxRecordSize) + maxRecordSize = recordOffset; + } + + /* Verify that the <field list> is enclosed in parentheses */ + + if (token == ')') getToken(); + else error(eRPAREN); + + /* A semicolon at this position means that another <variant> + * follows. Keep looping until all of the variants have been + * processed (i.e., no semi-colon) + */ + + if (token == ';') getToken(); + else break; + } + + /* Update the RECORD entry for the maximum size of all variants */ + + recordPtr->sParm.t.asize = maxRecordSize; + } + + /* Verify that the RECORD declaration terminates with END */ + + if (token != tEND) error(eRECORDDECLARE); + else getToken(); + + return recordPtr; +} + +/***************************************************************/ + +static STYPE *pas_DeclareField(STYPE *recordPtr) +{ + STYPE *fieldPtr = NULL; + STYPE *typePtr; + + TRACE(lstFile,"[pas_DeclareField]"); + + /* Declare one record-section with a record. + * FORM: record-section = identifier-list ':' type-denoter + * FORM: identifier-list = identifier { ',' identifier } + */ + + if (token != tIDENT) error(eIDENT); + else { + + /* Declare a <field> with this <identifier> as its name */ + + fieldPtr = addField(tkn_strt, recordPtr); + getToken(); + + /* Check for multiple fields of this <type> */ + + if (token == ',') { + + getToken(); + typePtr = pas_DeclareField(recordPtr); + + } + else { + + if (token != ':') error(eCOLON); + else getToken(); + + /* Use the existing type or declare a new type with no name */ + + typePtr = pas_TypeDenoter(NULL, 1); + } + + recordPtr->sParm.t.maxValue++; + if (typePtr) { + + /* Copy the size of field from the sTYPE entry into the <field> */ + /* type entry. NOTE: This element is not essential since it */ + /* can be obtained from the parent type pointer */ + + fieldPtr->sParm.r.size = typePtr->sParm.t.asize; + + /* Save a pointer back to the parent field type */ + + fieldPtr->sParm.r.parent = typePtr; + + } + } + + return typePtr; +} + +/***************************************************************/ +/* Process VAR/value Parameter Declaration */ +/* NOTE: This function increments the global variable g_nParms */ +/* as a side-effect */ + +static STYPE *pas_DeclareParameter(bool pointerType) +{ + int16_t varType = 0; + STYPE *varPtr; + STYPE *typePtr; + + TRACE(lstFile,"[pas_DeclareParameter]"); + + /* FORM: + * <identifier>[,<identifier>[,<identifier>[...]]] : <type identifier> + */ + + if (token != tIDENT) error (eIDENT); + else + { + varPtr = addVariable(tkn_strt, sINT, 0, sINT_SIZE, NULL); + getToken(); + + if (token == ',') + { + getToken(); + typePtr = pas_DeclareParameter(pointerType); + } + else + { + if (token != ':') error (eCOLON); + else getToken(); + typePtr = pas_TypeIdentifier(0); + } + + if (pointerType) + { + varType = sVAR_PARM; + g_dwVarSize = sPTR_SIZE; + } + else + { + varType = typePtr->sParm.t.rtype; + } + + g_nParms++; + varPtr->sKind = varType; + varPtr->sParm.v.size = g_dwVarSize; + varPtr->sParm.v.parent = typePtr; + } + + return typePtr; +} + +/***************************************************************/ + +static bool pas_IntAlignRequired(STYPE *typePtr) +{ + bool returnValue = false; + + /* Type CHAR and ARRAYS of CHAR do not require alignment (unless + * they are passed as value parameters). Otherwise, alignment + * to type INTEGER boundaries is required. + */ + + if (typePtr) + { + if (typePtr->sKind == sCHAR) + { + returnValue = true; + } + else if (typePtr->sKind == sARRAY) + { + typePtr = typePtr->sParm.t.parent; + if ((typePtr) && (typePtr->sKind == sCHAR)) + { + returnValue = true; + } + } + } + + return returnValue; +} + +/***************************************************************/ diff --git a/misc/pascal/pascal/pblck.h b/misc/pascal/pascal/pblck.h index 22b6b75b4f..c44da54526 100644 --- a/misc/pascal/pascal/pblck.h +++ b/misc/pascal/pascal/pblck.h @@ -1,51 +1,57 @@ -/***************************************************************************
- * pblck.h
- * External Declarations associated with pblck.c
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************************/
-
-#ifndef __PBLCK_H
-#define __PBLCK_H
-
-/***************************************************************************
- * Global Function Prototypes
- ***************************************************************************/
-
-extern void block(void);
-extern void declarationGroup(sint32 beginLabel);
-extern void constantDefinitionGroup(void);
-extern void typeDefinitionGroup(void);
-extern void variableDeclarationGroup(void);
-extern sint16 formalParameterList(STYPE *procPtr);
-
-#endif /* __PBLCK_H */
+/*************************************************************************** + * pblck.h + * External Declarations associated with pblck.c + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************************/ + +#ifndef __PBLCK_H +#define __PBLCK_H + +/*************************************************************************** + * Included Files + ***************************************************************************/ + +#include <stdint.h> + +/*************************************************************************** + * Global Function Prototypes + ***************************************************************************/ + +extern void block(void); +extern void declarationGroup(int32_t beginLabel); +extern void constantDefinitionGroup(void); +extern void typeDefinitionGroup(void); +extern void variableDeclarationGroup(void); +extern int16_t formalParameterList(STYPE *procPtr); + +#endif /* __PBLCK_H */ diff --git a/misc/pascal/pascal/pcexpr.c b/misc/pascal/pascal/pcexpr.c index d3ccebd126..52ef49e1aa 100644 --- a/misc/pascal/pascal/pcexpr.c +++ b/misc/pascal/pascal/pcexpr.c @@ -1,574 +1,576 @@ -/***************************************************************
- * pexpr.c
- * Constant expression evaluation
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************/
-
-/***************************************************************
- * Included Files
- ***************************************************************/
-
-#include <stdio.h>
-#include <string.h>
-#include <math.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "pedefs.h"
-
-#include "keywords.h"
-#include "pas.h"
-#include "pstm.h"
-#include "pexpr.h"
-#include "pfunc.h"
-#include "ptkn.h"
-#include "perr.h"
-
-/***************************************************************
- * Private Definitions
- ***************************************************************/
-
-#define ADDRESS_DEREFERENCE 0x01
-#define ADDRESS_FACTOR 0x02
-#define INDEXED_FACTOR 0x04
-#define VAR_PARM_FACTOR 0x08
-
-#define intTrunc(x) ((x) & (~(sINT_SIZE)))
-
-#define isRelationalOperator(t) \
- (((t) == tEQ) || ((t) == tNE) || \
- ((t) == tLT) || ((t) == tLE) || \
- ((t) == tGT) || ((t) == tGE) || \
- ((t) == tIN))
-
-#define isRelationalType(t) \
- (((t) == tINT_CONST) || ((t) == tCHAR_CONST) || \
- (((t) == tBOOLEAN_CONST) || ((t) == tREAL_CONST)))
-
-#define isAdditiveType(t) \
- (((t) == tINT_CONST) || ((t) == tREAL_CONST))
-
-#define isMultiplicativeType(t) \
- (((t) == tINT_CONST) || ((t) == tREAL_CONST))
-
-#define isLogicalType(t) \
- (((t) == tINT_CONST) || ((t) == tBOOLEAN_CONST))
-
-/***************************************************************
- * Private Type Declarations
- ***************************************************************/
-
-/***************************************************************
- * Private Function Prototypes
- ***************************************************************/
-
-static void constantSimpleExpression(void);
-static void constantTerm(void);
-static void constantFactor(void);
-
-/***************************************************************
- * Global Variables
- ***************************************************************/
-
-int constantToken;
-sint32 constantInt;
-float64 constantReal;
-char *constantStart;
-
-/***************************************************************
- * Private Variables
- ***************************************************************/
-
-/***************************************************************/
-/* Evaluate a simple expression of constant values */
-
-void constantExpression(void)
-{
- TRACE(lstFile,"[constantExpression]");
-
- /* Get the value of a simple constant expression */
-
- constantSimpleExpression();
-
- /* Is it followed by a relational operator? */
-
- if (isRelationalOperator(token) && isRelationalType(constantToken))
- {
- int simple1 = constantToken;
- sint32 simple1Int = constantInt;
- float64 simple1Real = constantReal;
- int operator = token;
-
- /* Get the second simple expression */
-
- constantSimpleExpression();
- if (simple1 != constantToken)
- {
- /* Handle the case where the 1st argument is REAL and the
- * second is INTEGER. */
-
- if ((simple1 == tREAL_CONST) && (constantToken == tINT_CONST))
- {
- simple1Real = (float64)simple1Int;
- simple1 = tREAL_CONST;
- }
-
- /* Handle the case where the 1st argument is Integer and the
- * second is REAL. */
-
- else if ((simple1 == tINT_CONST) && (constantToken == tREAL_CONST))
- {
- constantReal = (float64)constantInt;
- }
-
- /* Allow the case of <scalar type> IN <set type>
- * Otherwise, the two terms must agree in type
- * -- NOT YET implemented.
- */
-
- else
- {
- error(eEXPRTYPE);
- }
- }
-
- /* Generate the comparison by type */
-
- switch (simple1)
- {
- case tINT_CONST :
- case tCHAR_CONST :
- case tBOOLEAN_CONST :
- switch (operator)
- {
- case tEQ :
- constantInt = (simple1Int == constantInt);
- break;
- case tNE :
- constantInt = (simple1Int != constantInt);
- break;
- case tLT :
- constantInt = (simple1Int < constantInt);
- break;
- case tLE :
- constantInt = (simple1Int <= constantInt);
- break;
- case tGT :
- constantInt = (simple1Int > constantInt);
- break;
- case tGE :
- constantInt = (simple1Int >= constantInt);
- break;
- case tIN :
- /* Not yet */
- default :
- error(eEXPRTYPE);
- break;
- }
- break;
-
- case tREAL_CONST:
- switch (operator)
- {
- case tEQ :
- constantInt = (simple1Real == constantReal);
- break;
- case tNE :
- constantInt = (simple1Real != constantReal);
- break;
- case tLT :
- constantInt = (simple1Real < constantReal);
- break;
- case tLE :
- constantInt = (simple1Real <= constantReal);
- break;
- case tGT :
- constantInt = (simple1Real > constantReal);
- break;
- case tGE :
- constantInt = (simple1Real >= constantReal);
- break;
- case tIN :
- /* Not yet */
- default :
- error(eEXPRTYPE);
- break;
- }
- break;
-
- default :
- error(eEXPRTYPE);
- break;
- }
-
- /* The type resulting from these operations becomes BOOLEAN */
-
- constantToken = tBOOLEAN_CONST;
- }
-}
-
-/***************************************************************/
-/* Process Simple Expression */
-
-static void constantSimpleExpression(void)
-{
- sint16 unary = ' ';
- int term;
- sint32 termInt;
- float64 termReal;
-
- TRACE(lstFile,"[constantSimpleExpression]");
-
- /* FORM: [+|-] <term> [{+|-} <term> [{+|-} <term> [...]]] */
- /* get +/- unary operation */
-
- if ((token == '+') || (token == '-'))
- {
- unary = token;
- getToken();
- }
-
- /* Process first (non-optional) term and apply unary operation */
-
- constantTerm();
- term = constantToken;
- if ((unary != ' ') && !isAdditiveType(term))
- {
- error(eINVSIGNEDCONST);
- }
- else if (unary == '-')
- {
- termInt = -constantInt;
- termReal = -constantReal;
- }
- else
- {
- termInt = constantInt;
- termReal = constantReal;
- }
-
- /* Process subsequent (optional) terms and binary operations */
-
- for (;;)
- {
- int operator;
-
- /* Check for binary operator */
-
- if ((((token == '+') || (token == '-')) )&& isAdditiveType(term))
- operator = token;
- else if ((token == tOR) && isLogicalType(term))
- operator = token;
- else
- break;
-
- /* Get the 2nd term */
-
- getToken();
- constantTerm();
-
- /* Before generating the operation, verify that the types match.
- * Perform automatic type conversion from INTEGER to REAL as
- * necessary.
- */
-
- if (term != constantToken)
- {
- /* Handle the case where the 1st argument is REAL and the
- * second is INTEGER. */
-
- if ((term == tREAL_CONST) && (constantToken == tINT_CONST))
- {
- constantReal = (float64)constantInt;
- constantToken = tREAL_CONST;
- }
-
- /* Handle the case where the 1st argument is Integer and the
- * second is REAL. */
-
- else if ((term == tINT_CONST) && (constantToken == tREAL_CONST))
- {
- termReal = (float64)termInt;
- term = tREAL_CONST;
- }
-
- /* Otherwise, the two terms must agree in type */
-
- else
- {
- error(eTERMTYPE);
- }
- } /* end if */
-
-
- /* Perform the selected binary operation */
-
- switch (term)
- {
- case tINT_CONST :
- if (operator == '+')
- {
- termInt += constantInt;
- }
- else
- {
- termInt -= constantInt;
- }
- break;
-
- case tREAL_CONST :
- if (operator == '+')
- {
- termReal += constantReal;
- }
- else
- {
- termReal -= constantReal;
- }
- break;
-
- case tBOOLEAN_CONST :
- termInt |= constantInt;
- break;
-
- default :
- error(eEXPRTYPE);
- break;
- }
- }
-
- constantToken = term;
- constantInt = termInt;
- constantReal = termReal;
-}
-
-/***************************************************************/
-/* Evaluate a TERM */
-
-void constantTerm(void)
-{
- int operator;
- int factor;
- sint32 factorInt;
- float64 factorReal;
-
- TRACE(lstFile,"[constantTerm]");
-
- /* FORM: <factor> [<operator> <factor>[<operator><factor>[...]]] */
-
- constantFactor();
- factor = constantToken;
- factorInt = constantInt;
- factorReal = constantReal;
- for (;;) {
- /* Check for binary operator */
-
- if (((token == tMUL) || (token == tMOD)) &&
- (isMultiplicativeType(factor)))
- operator = token;
- else if (((token == tDIV) || (token == tSHL) || (token == tSHR)) &&
- (factor == tINT_CONST))
- operator = token;
- else if ((token == tFDIV) && (factor == tREAL_CONST))
- operator = token;
-#if 0
- else if ((token == tFDIV) && (factor == tINT_CONST))
- {
- factorReal = (float64)factorInt;
- factor = tREAL_CONST;
- operator = token;
- }
-#endif
- else if ((token == tAND) && isLogicalType(factor))
- operator = token;
- else
- {
- constantToken = factor;
- constantInt = factorInt;
- constantReal = factorReal;
- break;
- }
-
- /* Get the next factor */
-
- getToken();
- constantFactor();
-
- /* Before generating the operation, verify that the types match.
- * Perform automatic type conversion from INTEGER to REAL as
- * necessary.
- */
-
- if (factor != constantToken)
- {
- /* Handle the case where the 1st argument is REAL and the
- * second is INTEGER. */
-
- if ((factor == tREAL_CONST) && (constantToken == tINT_CONST))
- {
- constantReal = (float64)constantInt;
- }
-
- /* Handle the case where the 1st argument is Integer and the
- * second is REAL. */
-
- else if ((factor == tINT_CONST) && (constantToken == tREAL_CONST))
- {
- factorReal = (float64)factorInt;
- factor = tREAL_CONST;
- }
-
- /* Otherwise, the two factors must agree in type */
-
- else
- {
- error(eFACTORTYPE);
- }
- } /* end if */
-
- /* Generate code to perform the selected binary operation */
-
- switch (operator)
- {
- case tMUL :
- if (factor == tINT_CONST)
- factorInt *= constantInt;
- else if (factor == tREAL_CONST)
- factorReal *= constantReal;
- else
- error(eFACTORTYPE);
- break;
-
- case tDIV :
- if (factor == tINT_CONST)
- factorInt /= constantInt;
- else
- error(eFACTORTYPE);
- break;
-
- case tFDIV :
- if (factor == tREAL_CONST)
- factorReal /= constantReal;
- else
- error(eFACTORTYPE);
- break;
-
- case tMOD :
- if (factor == tINT_CONST)
- factorInt %= constantInt;
- else if (factor == tREAL_CONST)
- factorReal = fmod(factorReal, constantReal);
- else
- error(eFACTORTYPE);
- break;
-
- case tAND :
- if ((factor == tINT_CONST) || (factor == tBOOLEAN_CONST))
- factorInt &= constantInt;
- else
- error(eFACTORTYPE);
- break;
-
- case tSHL :
- if (factor == tINT_CONST)
- factorInt <<= constantInt;
- else
- error(eFACTORTYPE);
- break;
-
- case tSHR :
- if (factor == tINT_CONST)
- factorInt >>= constantInt;
- else
- error(eFACTORTYPE);
- break;
-
- }
- }
-}
-
-/***************************************************************/
-/* Process a FACTOR */
-
-static void constantFactor(void)
-{
- TRACE(lstFile,"[constantFactor]");
-
- /* Process by token type */
-
- switch (token)
- {
- case tINT_CONST :
- case tBOOLEAN_CONST :
- case tCHAR_CONST :
- constantToken = token;
- constantInt = tknInt;
- getToken();
- break;
-
- case tREAL_CONST :
- constantToken = token;
- constantReal = tknReal;
- getToken();
- break;
-
- case tSTRING_CONST :
- constantToken = token;
- constantStart = tkn_strt;
- getToken();
- break;
-
- /* Highest Priority Operators */
-
- case tNOT:
- getToken();
- constantFactor();
- if ((constantToken != tINT_CONST) && (constantToken != tBOOLEAN_CONST))
- error(eFACTORTYPE);
- constantInt = ~constantInt;
- break;
-
- /* Built-in function? */
-
- case tFUNC:
- builtInFunctionOfConstant();
- break;
-
- /* Hmmm... Try the standard functions */
-
- default :
- error(eINVFACTOR);
- break;
- }
-}
+/*************************************************************** + * pexpr.c + * Constant expression evaluation + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************/ + +/*************************************************************** + * Included Files + ***************************************************************/ + +#include <sys/types.h> +#include <stdint.h> +#include <stdio.h> +#include <string.h> +#include <math.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "pedefs.h" + +#include "keywords.h" +#include "pas.h" +#include "pstm.h" +#include "pexpr.h" +#include "pfunc.h" +#include "ptkn.h" +#include "perr.h" + +/*************************************************************** + * Pre-processor Definitions + ***************************************************************/ + +#define ADDRESS_DEREFERENCE 0x01 +#define ADDRESS_FACTOR 0x02 +#define INDEXED_FACTOR 0x04 +#define VAR_PARM_FACTOR 0x08 + +#define intTrunc(x) ((x) & (~(sINT_SIZE))) + +#define isRelationalOperator(t) \ + (((t) == tEQ) || ((t) == tNE) || \ + ((t) == tLT) || ((t) == tLE) || \ + ((t) == tGT) || ((t) == tGE) || \ + ((t) == tIN)) + +#define isRelationalType(t) \ + (((t) == tINT_CONST) || ((t) == tCHAR_CONST) || \ + (((t) == tBOOLEAN_CONST) || ((t) == tREAL_CONST))) + +#define isAdditiveType(t) \ + (((t) == tINT_CONST) || ((t) == tREAL_CONST)) + +#define isMultiplicativeType(t) \ + (((t) == tINT_CONST) || ((t) == tREAL_CONST)) + +#define isLogicalType(t) \ + (((t) == tINT_CONST) || ((t) == tBOOLEAN_CONST)) + +/*************************************************************** + * Private Type Declarations + ***************************************************************/ + +/*************************************************************** + * Private Function Prototypes + ***************************************************************/ + +static void constantSimpleExpression(void); +static void constantTerm(void); +static void constantFactor(void); + +/*************************************************************** + * Global Variables + ***************************************************************/ + +int constantToken; +int32_t constantInt; +double constantReal; +char *constantStart; + +/*************************************************************** + * Private Variables + ***************************************************************/ + +/***************************************************************/ +/* Evaluate a simple expression of constant values */ + +void constantExpression(void) +{ + TRACE(lstFile,"[constantExpression]"); + + /* Get the value of a simple constant expression */ + + constantSimpleExpression(); + + /* Is it followed by a relational operator? */ + + if (isRelationalOperator(token) && isRelationalType(constantToken)) + { + int simple1 = constantToken; + int32_t simple1Int = constantInt; + double simple1Real = constantReal; + int operator = token; + + /* Get the second simple expression */ + + constantSimpleExpression(); + if (simple1 != constantToken) + { + /* Handle the case where the 1st argument is REAL and the + * second is INTEGER. */ + + if ((simple1 == tREAL_CONST) && (constantToken == tINT_CONST)) + { + simple1Real = (double)simple1Int; + simple1 = tREAL_CONST; + } + + /* Handle the case where the 1st argument is Integer and the + * second is REAL. */ + + else if ((simple1 == tINT_CONST) && (constantToken == tREAL_CONST)) + { + constantReal = (double)constantInt; + } + + /* Allow the case of <scalar type> IN <set type> + * Otherwise, the two terms must agree in type + * -- NOT YET implemented. + */ + + else + { + error(eEXPRTYPE); + } + } + + /* Generate the comparison by type */ + + switch (simple1) + { + case tINT_CONST : + case tCHAR_CONST : + case tBOOLEAN_CONST : + switch (operator) + { + case tEQ : + constantInt = (simple1Int == constantInt); + break; + case tNE : + constantInt = (simple1Int != constantInt); + break; + case tLT : + constantInt = (simple1Int < constantInt); + break; + case tLE : + constantInt = (simple1Int <= constantInt); + break; + case tGT : + constantInt = (simple1Int > constantInt); + break; + case tGE : + constantInt = (simple1Int >= constantInt); + break; + case tIN : + /* Not yet */ + default : + error(eEXPRTYPE); + break; + } + break; + + case tREAL_CONST: + switch (operator) + { + case tEQ : + constantInt = (simple1Real == constantReal); + break; + case tNE : + constantInt = (simple1Real != constantReal); + break; + case tLT : + constantInt = (simple1Real < constantReal); + break; + case tLE : + constantInt = (simple1Real <= constantReal); + break; + case tGT : + constantInt = (simple1Real > constantReal); + break; + case tGE : + constantInt = (simple1Real >= constantReal); + break; + case tIN : + /* Not yet */ + default : + error(eEXPRTYPE); + break; + } + break; + + default : + error(eEXPRTYPE); + break; + } + + /* The type resulting from these operations becomes BOOLEAN */ + + constantToken = tBOOLEAN_CONST; + } +} + +/***************************************************************/ +/* Process Simple Expression */ + +static void constantSimpleExpression(void) +{ + int16_t unary = ' '; + int term; + int32_t termInt; + double termReal; + + TRACE(lstFile,"[constantSimpleExpression]"); + + /* FORM: [+|-] <term> [{+|-} <term> [{+|-} <term> [...]]] */ + /* get +/- unary operation */ + + if ((token == '+') || (token == '-')) + { + unary = token; + getToken(); + } + + /* Process first (non-optional) term and apply unary operation */ + + constantTerm(); + term = constantToken; + if ((unary != ' ') && !isAdditiveType(term)) + { + error(eINVSIGNEDCONST); + } + else if (unary == '-') + { + termInt = -constantInt; + termReal = -constantReal; + } + else + { + termInt = constantInt; + termReal = constantReal; + } + + /* Process subsequent (optional) terms and binary operations */ + + for (;;) + { + int operator; + + /* Check for binary operator */ + + if ((((token == '+') || (token == '-')) )&& isAdditiveType(term)) + operator = token; + else if ((token == tOR) && isLogicalType(term)) + operator = token; + else + break; + + /* Get the 2nd term */ + + getToken(); + constantTerm(); + + /* Before generating the operation, verify that the types match. + * Perform automatic type conversion from INTEGER to REAL as + * necessary. + */ + + if (term != constantToken) + { + /* Handle the case where the 1st argument is REAL and the + * second is INTEGER. */ + + if ((term == tREAL_CONST) && (constantToken == tINT_CONST)) + { + constantReal = (double)constantInt; + constantToken = tREAL_CONST; + } + + /* Handle the case where the 1st argument is Integer and the + * second is REAL. */ + + else if ((term == tINT_CONST) && (constantToken == tREAL_CONST)) + { + termReal = (double)termInt; + term = tREAL_CONST; + } + + /* Otherwise, the two terms must agree in type */ + + else + { + error(eTERMTYPE); + } + } /* end if */ + + + /* Perform the selected binary operation */ + + switch (term) + { + case tINT_CONST : + if (operator == '+') + { + termInt += constantInt; + } + else + { + termInt -= constantInt; + } + break; + + case tREAL_CONST : + if (operator == '+') + { + termReal += constantReal; + } + else + { + termReal -= constantReal; + } + break; + + case tBOOLEAN_CONST : + termInt |= constantInt; + break; + + default : + error(eEXPRTYPE); + break; + } + } + + constantToken = term; + constantInt = termInt; + constantReal = termReal; +} + +/***************************************************************/ +/* Evaluate a TERM */ + +void constantTerm(void) +{ + int operator; + int factor; + int32_t factorInt; + double factorReal; + + TRACE(lstFile,"[constantTerm]"); + + /* FORM: <factor> [<operator> <factor>[<operator><factor>[...]]] */ + + constantFactor(); + factor = constantToken; + factorInt = constantInt; + factorReal = constantReal; + for (;;) { + /* Check for binary operator */ + + if (((token == tMUL) || (token == tMOD)) && + (isMultiplicativeType(factor))) + operator = token; + else if (((token == tDIV) || (token == tSHL) || (token == tSHR)) && + (factor == tINT_CONST)) + operator = token; + else if ((token == tFDIV) && (factor == tREAL_CONST)) + operator = token; +#if 0 + else if ((token == tFDIV) && (factor == tINT_CONST)) + { + factorReal = (double)factorInt; + factor = tREAL_CONST; + operator = token; + } +#endif + else if ((token == tAND) && isLogicalType(factor)) + operator = token; + else + { + constantToken = factor; + constantInt = factorInt; + constantReal = factorReal; + break; + } + + /* Get the next factor */ + + getToken(); + constantFactor(); + + /* Before generating the operation, verify that the types match. + * Perform automatic type conversion from INTEGER to REAL as + * necessary. + */ + + if (factor != constantToken) + { + /* Handle the case where the 1st argument is REAL and the + * second is INTEGER. */ + + if ((factor == tREAL_CONST) && (constantToken == tINT_CONST)) + { + constantReal = (double)constantInt; + } + + /* Handle the case where the 1st argument is Integer and the + * second is REAL. */ + + else if ((factor == tINT_CONST) && (constantToken == tREAL_CONST)) + { + factorReal = (double)factorInt; + factor = tREAL_CONST; + } + + /* Otherwise, the two factors must agree in type */ + + else + { + error(eFACTORTYPE); + } + } /* end if */ + + /* Generate code to perform the selected binary operation */ + + switch (operator) + { + case tMUL : + if (factor == tINT_CONST) + factorInt *= constantInt; + else if (factor == tREAL_CONST) + factorReal *= constantReal; + else + error(eFACTORTYPE); + break; + + case tDIV : + if (factor == tINT_CONST) + factorInt /= constantInt; + else + error(eFACTORTYPE); + break; + + case tFDIV : + if (factor == tREAL_CONST) + factorReal /= constantReal; + else + error(eFACTORTYPE); + break; + + case tMOD : + if (factor == tINT_CONST) + factorInt %= constantInt; + else if (factor == tREAL_CONST) + factorReal = fmod(factorReal, constantReal); + else + error(eFACTORTYPE); + break; + + case tAND : + if ((factor == tINT_CONST) || (factor == tBOOLEAN_CONST)) + factorInt &= constantInt; + else + error(eFACTORTYPE); + break; + + case tSHL : + if (factor == tINT_CONST) + factorInt <<= constantInt; + else + error(eFACTORTYPE); + break; + + case tSHR : + if (factor == tINT_CONST) + factorInt >>= constantInt; + else + error(eFACTORTYPE); + break; + + } + } +} + +/***************************************************************/ +/* Process a FACTOR */ + +static void constantFactor(void) +{ + TRACE(lstFile,"[constantFactor]"); + + /* Process by token type */ + + switch (token) + { + case tINT_CONST : + case tBOOLEAN_CONST : + case tCHAR_CONST : + constantToken = token; + constantInt = tknInt; + getToken(); + break; + + case tREAL_CONST : + constantToken = token; + constantReal = tknReal; + getToken(); + break; + + case tSTRING_CONST : + constantToken = token; + constantStart = tkn_strt; + getToken(); + break; + + /* Highest Priority Operators */ + + case tNOT: + getToken(); + constantFactor(); + if ((constantToken != tINT_CONST) && (constantToken != tBOOLEAN_CONST)) + error(eFACTORTYPE); + constantInt = ~constantInt; + break; + + /* Built-in function? */ + + case tFUNC: + builtInFunctionOfConstant(); + break; + + /* Hmmm... Try the standard functions */ + + default : + error(eINVFACTOR); + break; + } +} diff --git a/misc/pascal/pascal/pcfunc.c b/misc/pascal/pascal/pcfunc.c index 4fc83d9bf1..733e85bdd7 100644 --- a/misc/pascal/pascal/pcfunc.c +++ b/misc/pascal/pascal/pcfunc.c @@ -1,339 +1,341 @@ -/***************************************************************
- * pcfunc.c
- * Standard Function operating on constant values
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************/
-
-/***************************************************************
- * Included Files
- ***************************************************************/
-
-#include <stdio.h>
-#include <math.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "podefs.h"
-#include "pfdefs.h"
-#include "pedefs.h"
-#include "pxdefs.h"
-
-#include "pas.h"
-#include "pexpr.h"
-#include "pfunc.h"
-#include "ptkn.h"
-#include "perr.h"
-
-/***************************************************************
- * Private Function Prototypes
- ***************************************************************/
-
-/* Standard Pascal Functions */
-
-static void constantAbsFunc(void); /* Integer absolute value */
-static void constantPredFunc(void);
-static void constantOrdFunc(void); /* Convert scalar to integer */
-static void constantSqrFunc(void);
-static void constantRealFunc(ubyte fpCode);
-static void constantSuccFunc(void);
-static void constantOddFunc(void);
-static void constantChrFunc(void);
-static void constantReal2IntFunc(int kind);
-static void isOrdinalConstant(void);
-
-/***************************************************************/
-/* Process a standard Pascal function call */
-
-void builtInFunctionOfConstant(void)
-{
- TRACE(lstFile,"[builtInFunctionFactor]");
-
- /* Is the token a function? */
-
- if (token == tFUNC)
- {
- /* Yes, process it procedure according to the extended token type */
-
- switch (tknSubType)
- {
- /* Functions which return the same type as their argument */
- case txABS :
- constantAbsFunc();
- break;
- case txSQR :
- constantSqrFunc();
- break;
- case txPRED :
- constantPredFunc();
- break;
- case txSUCC :
- constantSuccFunc();
- break;
-
- /* Functions returning INTEGER with REAL arguments */
-
- case txROUND :
- constantReal2IntFunc(fpROUND);
- break;
- case txTRUNC :
- constantReal2IntFunc(fpTRUNC);
- break;
-
- /* Functions returning CHARACTER with INTEGER arguments. */
-
- case txCHR :
- constantChrFunc();
- break;
-
- /* Function returning integer with scalar arguments */
-
- case txORD :
- constantOrdFunc();
- break;
-
- /* Functions returning BOOLEAN */
- case txODD :
- constantOddFunc();
- break;
-
- /* Functions returning REAL with REAL/INTEGER arguments */
-
- case txSQRT :
- constantRealFunc(fpSQRT);
- break;
- case txSIN :
- constantRealFunc(fpSIN);
- break;
- case txCOS :
- constantRealFunc(fpCOS);
- break;
- case txARCTAN :
- constantRealFunc(fpATAN);
- break;
- case txLN :
- constantRealFunc(fpLN);
- break;
- case txEXP :
- constantRealFunc(fpEXP);
- break;
-
- case txGETENV : /* Non-standard C library interfaces */
- case txEOLN :
- case txEOF :
- default :
- error(eINVALIDPROC);
- break;
- }
- }
-}
-
-/**********************************************************************/
-
-static void constantAbsFunc(void)
-{
- TRACE(lstFile,"[constantAbsFunc]");
-
- /* FORM: ABS (<simple integer/real expression>) */
-
- checkLParen();
- constantExpression();
-
- if (constantToken == tINT_CONST)
- {
- if (constantInt < 0)
- constantInt = -constantInt;
- }
- else if (constantToken == tREAL_CONST)
- {
- if (constantReal < 0)
- constantReal = -constantInt;
- }
- else
- error(eINVARG);
-
- checkRParen();
-}
-
-/**********************************************************************/
-
-static void constantOrdFunc(void)
-{
- TRACE(lstFile,"[constantOrdFunc]");
-
- /* FORM: ORD (<scalar type>) */
-
- checkLParen();
- constantExpression();
- isOrdinalConstant();
- checkRParen();
-}
-
-/**********************************************************************/
-
-static void constantPredFunc(void)
-{
- TRACE(lstFile,"[constantPredFunc]");
-
- /* FORM: PRED (<simple integer expression>) */
-
- checkLParen();
- constantExpression();
- isOrdinalConstant();
- constantInt--;
- checkRParen();
-}
-
-/**********************************************************************/
-
-static void constantSqrFunc(void)
-{
- TRACE(lstFile,"[constantSqrFunc]");
-
- /* FORM: SQR (<simple integer OR real expression>) */
-
- checkLParen();
- constantExpression();
- if (constantToken == tINT_CONST)
- {
- constantInt *= constantInt;
- }
- else if (constantToken == tREAL_CONST)
- {
- constantReal *= constantReal;
- }
- else
- {
- error(eINVARG);
- }
-
- checkRParen();
-}
-
-/**********************************************************************/
-
-static void constantRealFunc(ubyte fpOpCode)
-{
- TRACE(lstFile,"[constantRealFunc]");
-
- /* FORM: <function identifier> (<real/integer expression>) */
-
- checkLParen();
- constantExpression();
- if (constantToken == tINT_CONST)
- constantReal = (float64)constantInt;
- else
- error(eINVARG);
-
- checkRParen();
-}
-
-/**********************************************************************/
-
-static void constantSuccFunc(void)
-{
- TRACE(lstFile,"[constantSuccFunc]");
-
- /* FORM: SUCC (<simple integer expression>) */
-
- checkLParen();
- constantExpression();
- isOrdinalConstant();
- constantInt++;
- checkRParen();
-}
-
-/***********************************************************************/
-
-static void constantOddFunc(void)
-{
- TRACE(lstFile,"[constantOddFunc]");
-
- /* FORM: ODD (<simple integer expression>) */
-
- checkLParen();
- constantExpression();
- isOrdinalConstant();
- constantInt &= 1;
- expression(exprAnyOrdinal, NULL);
- checkRParen();
-}
-
-/***********************************************************************/
-/* Process the standard chr function */
-
-static void constantChrFunc(void)
-{
- TRACE(lstFile,"[constantCharFunc]");
-
- /* Form: chr(integer expression).
- *
- * char(val) is only defined if there exists a character ch such
- * that ord(ch) = val. If this is not the case, we will simply
- * let the returned value exceed the range of type char. */
-
- checkLParen();
- constantExpression();
- if (constantToken == tINT_CONST)
- {
- constantToken = tCHAR_CONST;
- }
- else
- {
- error(eINVARG);
- }
-
- checkRParen();
-}
-
-/***********************************************************************/
-
-static void constantReal2IntFunc(int kind)
-{
- error(eNOTYET);
-}
-
-/***********************************************************************/
-
-static void isOrdinalConstant(void)
-{
- if ((constantToken == tINT_CONST) || /* integer value */
- (constantToken == tCHAR_CONST) || /* character value */
- (constantToken == tBOOLEAN_CONST))
- return;
- else
- error(eINVARG);
-}
-
-/***********************************************************************/
-
+/*************************************************************** + * pcfunc.c + * Standard Function operating on constant values + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************/ + +/*************************************************************** + * Included Files + ***************************************************************/ + +#include <sys/types.h> +#include <stdint.h> +#include <stdio.h> +#include <math.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "podefs.h" +#include "pfdefs.h" +#include "pedefs.h" +#include "pxdefs.h" + +#include "pas.h" +#include "pexpr.h" +#include "pfunc.h" +#include "ptkn.h" +#include "perr.h" + +/*************************************************************** + * Private Function Prototypes + ***************************************************************/ + +/* Standard Pascal Functions */ + +static void constantAbsFunc(void); /* Integer absolute value */ +static void constantPredFunc(void); +static void constantOrdFunc(void); /* Convert scalar to integer */ +static void constantSqrFunc(void); +static void constantRealFunc(uint8_t fpCode); +static void constantSuccFunc(void); +static void constantOddFunc(void); +static void constantChrFunc(void); +static void constantReal2IntFunc(int kind); +static void isOrdinalConstant(void); + +/***************************************************************/ +/* Process a standard Pascal function call */ + +void builtInFunctionOfConstant(void) +{ + TRACE(lstFile,"[builtInFunctionFactor]"); + + /* Is the token a function? */ + + if (token == tFUNC) + { + /* Yes, process it procedure according to the extended token type */ + + switch (tknSubType) + { + /* Functions which return the same type as their argument */ + case txABS : + constantAbsFunc(); + break; + case txSQR : + constantSqrFunc(); + break; + case txPRED : + constantPredFunc(); + break; + case txSUCC : + constantSuccFunc(); + break; + + /* Functions returning INTEGER with REAL arguments */ + + case txROUND : + constantReal2IntFunc(fpROUND); + break; + case txTRUNC : + constantReal2IntFunc(fpTRUNC); + break; + + /* Functions returning CHARACTER with INTEGER arguments. */ + + case txCHR : + constantChrFunc(); + break; + + /* Function returning integer with scalar arguments */ + + case txORD : + constantOrdFunc(); + break; + + /* Functions returning BOOLEAN */ + case txODD : + constantOddFunc(); + break; + + /* Functions returning REAL with REAL/INTEGER arguments */ + + case txSQRT : + constantRealFunc(fpSQRT); + break; + case txSIN : + constantRealFunc(fpSIN); + break; + case txCOS : + constantRealFunc(fpCOS); + break; + case txARCTAN : + constantRealFunc(fpATAN); + break; + case txLN : + constantRealFunc(fpLN); + break; + case txEXP : + constantRealFunc(fpEXP); + break; + + case txGETENV : /* Non-standard C library interfaces */ + case txEOLN : + case txEOF : + default : + error(eINVALIDPROC); + break; + } + } +} + +/**********************************************************************/ + +static void constantAbsFunc(void) +{ + TRACE(lstFile,"[constantAbsFunc]"); + + /* FORM: ABS (<simple integer/real expression>) */ + + checkLParen(); + constantExpression(); + + if (constantToken == tINT_CONST) + { + if (constantInt < 0) + constantInt = -constantInt; + } + else if (constantToken == tREAL_CONST) + { + if (constantReal < 0) + constantReal = -constantInt; + } + else + error(eINVARG); + + checkRParen(); +} + +/**********************************************************************/ + +static void constantOrdFunc(void) +{ + TRACE(lstFile,"[constantOrdFunc]"); + + /* FORM: ORD (<scalar type>) */ + + checkLParen(); + constantExpression(); + isOrdinalConstant(); + checkRParen(); +} + +/**********************************************************************/ + +static void constantPredFunc(void) +{ + TRACE(lstFile,"[constantPredFunc]"); + + /* FORM: PRED (<simple integer expression>) */ + + checkLParen(); + constantExpression(); + isOrdinalConstant(); + constantInt--; + checkRParen(); +} + +/**********************************************************************/ + +static void constantSqrFunc(void) +{ + TRACE(lstFile,"[constantSqrFunc]"); + + /* FORM: SQR (<simple integer OR real expression>) */ + + checkLParen(); + constantExpression(); + if (constantToken == tINT_CONST) + { + constantInt *= constantInt; + } + else if (constantToken == tREAL_CONST) + { + constantReal *= constantReal; + } + else + { + error(eINVARG); + } + + checkRParen(); +} + +/**********************************************************************/ + +static void constantRealFunc(uint8_t fpOpCode) +{ + TRACE(lstFile,"[constantRealFunc]"); + + /* FORM: <function identifier> (<real/integer expression>) */ + + checkLParen(); + constantExpression(); + if (constantToken == tINT_CONST) + constantReal = (double)constantInt; + else + error(eINVARG); + + checkRParen(); +} + +/**********************************************************************/ + +static void constantSuccFunc(void) +{ + TRACE(lstFile,"[constantSuccFunc]"); + + /* FORM: SUCC (<simple integer expression>) */ + + checkLParen(); + constantExpression(); + isOrdinalConstant(); + constantInt++; + checkRParen(); +} + +/***********************************************************************/ + +static void constantOddFunc(void) +{ + TRACE(lstFile,"[constantOddFunc]"); + + /* FORM: ODD (<simple integer expression>) */ + + checkLParen(); + constantExpression(); + isOrdinalConstant(); + constantInt &= 1; + expression(exprAnyOrdinal, NULL); + checkRParen(); +} + +/***********************************************************************/ +/* Process the standard chr function */ + +static void constantChrFunc(void) +{ + TRACE(lstFile,"[constantCharFunc]"); + + /* Form: chr(integer expression). + * + * char(val) is only defined if there exists a character ch such + * that ord(ch) = val. If this is not the case, we will simply + * let the returned value exceed the range of type char. */ + + checkLParen(); + constantExpression(); + if (constantToken == tINT_CONST) + { + constantToken = tCHAR_CONST; + } + else + { + error(eINVARG); + } + + checkRParen(); +} + +/***********************************************************************/ + +static void constantReal2IntFunc(int kind) +{ + error(eNOTYET); +} + +/***********************************************************************/ + +static void isOrdinalConstant(void) +{ + if ((constantToken == tINT_CONST) || /* integer value */ + (constantToken == tCHAR_CONST) || /* character value */ + (constantToken == tBOOLEAN_CONST)) + return; + else + error(eINVARG); +} + +/***********************************************************************/ + diff --git a/misc/pascal/pascal/perr.c b/misc/pascal/pascal/perr.c index b09afd675f..3737b25887 100644 --- a/misc/pascal/pascal/perr.c +++ b/misc/pascal/pascal/perr.c @@ -1,190 +1,191 @@ -/**********************************************************************
- * perr.c
- * Error Handlers
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- **********************************************************************/
-
-/**********************************************************************
- * Included Files
- **********************************************************************/
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdarg.h>
-
-#include "config.h"
-#include "keywords.h"
-#include "pasdefs.h"
-#include "pedefs.h"
-
-#include "pas.h"
-#include "ptkn.h"
-#include "perr.h"
-#if CONFIG_DEBUG
-# include "ptbl.h"
-#endif
-
-/**********************************************************************
- * Definitions
- **********************************************************************/
-
-#if CONFIG_DEBUG
-#define DUMPTABLES dumpTables()
-#else
-#define DUMPTABLES
-#endif
-
-/**********************************************************************
- * Private Variables
- **********************************************************************/
-
-static const char fmtErrNoToken[] =
- "Line %d:%04ld Error %02x Token %02x\n";
-static const char fmtErrWithToken[] =
- "Line %d:%04ld Error %02x Token %02x (%s)\n";
-static const char fmtErrAbort[] =
- "Fatal Error %d -- Compilation aborted\n";
-
-/**********************************************************************
- * Private Function Prototypes
- **********************************************************************/
-
-static void printError(uint16 errcode);
-
-/***********************************************************************/
-
-void errmsg(char *fmt, ...)
-{
- char buffer[1024];
- va_list ap;
-
- /* Get the full string */
-
- va_start(ap, fmt);
- (void)vsprintf(buffer, fmt, ap);
-
- /* Then output the string to stderr, the err file, and the list file */
-
- fputs(buffer, stderr);
- fputs(buffer, errFile);
- fputs(buffer, lstFile);
-
- va_end(ap);
-}
-
-/***********************************************************************/
-
-void warn(uint16 errcode)
-{
- TRACE(lstFile,"[warn:%04x]", errcode);
-
- /* Write error record to the error and list files */
-
- printError(errcode);
-
- /* Increment the count of warning */
-
- warn_count++;
-} /* end warn */
-
-/***********************************************************************/
-
-void error(uint16 errcode)
-{
- TRACE(lstFile,"[error:%04x]", errcode);
-
-#if CONFIG_DEBUG
- fatal(errcode);
-#else
- /* Write error record to the error and list files */
-
- printError(errcode);
-
- /* Check if err_count has been execeeded the max allowable */
-
- if ((++err_count) > MAX_ERRORS)
- {
- fatal(eCOUNT);
- }
-#endif
-
-} /* end error */
-
-/***********************************************************************/
-
-void fatal(uint16 errcode)
-{
- TRACE(lstFile,"[fatal:%04x]", errcode);
-
- /* Write error record to the error and list files */
-
- printError( errcode );
-
- /* Dump the tables (if CONFIG_DEBUG) */
-
- DUMPTABLES;
-
- /* And say goodbye */
-
- printf(fmtErrAbort, errcode);
- fprintf(lstFile, fmtErrAbort, errcode);
-
- exit(1);
-
-} /* end fatal */
-
-/***********************************************************************/
-
-static void printError(uint16 errcode)
-{
- /* Write error record to the error and list files */
-
- if ((tkn_strt) && (tkn_strt < stringSP))
- {
- fprintf (errFile, fmtErrWithToken,
- FP->include, FP->line, errcode, token, tkn_strt);
- fprintf (lstFile, fmtErrWithToken,
- FP->include, FP->line, errcode, token, tkn_strt);
- stringSP = tkn_strt; /* Clean up string stack */
- } /* end if */
- else
- {
- fprintf (errFile, fmtErrNoToken,
- FP->include, FP->line, errcode, token);
- fprintf (lstFile, fmtErrNoToken,
- FP->include, FP->line, errcode, token);
- } /* end else */
-} /* end printError */
-
-/***********************************************************************/
-
+/********************************************************************** + * perr.c + * Error Handlers + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + **********************************************************************/ + +/********************************************************************** + * Included Files + **********************************************************************/ + +#include <stdint.h> +#include <stdio.h> +#include <stdlib.h> +#include <stdarg.h> + +#include "config.h" +#include "keywords.h" +#include "pasdefs.h" +#include "pedefs.h" + +#include "pas.h" +#include "ptkn.h" +#include "perr.h" +#if CONFIG_DEBUG +# include "ptbl.h" +#endif + +/********************************************************************** + * Pre-processor Definitions + **********************************************************************/ + +#if CONFIG_DEBUG +#define DUMPTABLES dumpTables() +#else +#define DUMPTABLES +#endif + +/********************************************************************** + * Private Variables + **********************************************************************/ + +static const char fmtErrNoToken[] = + "Line %d:%04ld Error %02x Token %02x\n"; +static const char fmtErrWithToken[] = + "Line %d:%04ld Error %02x Token %02x (%s)\n"; +static const char fmtErrAbort[] = + "Fatal Error %d -- Compilation aborted\n"; + +/********************************************************************** + * Private Function Prototypes + **********************************************************************/ + +static void printError(uint16_t errcode); + +/***********************************************************************/ + +void errmsg(char *fmt, ...) +{ + char buffer[1024]; + va_list ap; + + /* Get the full string */ + + va_start(ap, fmt); + (void)vsprintf(buffer, fmt, ap); + + /* Then output the string to stderr, the err file, and the list file */ + + fputs(buffer, stderr); + fputs(buffer, errFile); + fputs(buffer, lstFile); + + va_end(ap); +} + +/***********************************************************************/ + +void warn(uint16_t errcode) +{ + TRACE(lstFile,"[warn:%04x]", errcode); + + /* Write error record to the error and list files */ + + printError(errcode); + + /* Increment the count of warning */ + + warn_count++; +} /* end warn */ + +/***********************************************************************/ + +void error(uint16_t errcode) +{ + TRACE(lstFile,"[error:%04x]", errcode); + +#if CONFIG_DEBUG + fatal(errcode); +#else + /* Write error record to the error and list files */ + + printError(errcode); + + /* Check if err_count has been execeeded the max allowable */ + + if ((++err_count) > MAX_ERRORS) + { + fatal(eCOUNT); + } +#endif + +} /* end error */ + +/***********************************************************************/ + +void fatal(uint16_t errcode) +{ + TRACE(lstFile,"[fatal:%04x]", errcode); + + /* Write error record to the error and list files */ + + printError( errcode ); + + /* Dump the tables (if CONFIG_DEBUG) */ + + DUMPTABLES; + + /* And say goodbye */ + + printf(fmtErrAbort, errcode); + fprintf(lstFile, fmtErrAbort, errcode); + + exit(1); + +} /* end fatal */ + +/***********************************************************************/ + +static void printError(uint16_t errcode) +{ + /* Write error record to the error and list files */ + + if ((tkn_strt) && (tkn_strt < stringSP)) + { + fprintf (errFile, fmtErrWithToken, + FP->include, FP->line, errcode, token, tkn_strt); + fprintf (lstFile, fmtErrWithToken, + FP->include, FP->line, errcode, token, tkn_strt); + stringSP = tkn_strt; /* Clean up string stack */ + } /* end if */ + else + { + fprintf (errFile, fmtErrNoToken, + FP->include, FP->line, errcode, token); + fprintf (lstFile, fmtErrNoToken, + FP->include, FP->line, errcode, token); + } /* end else */ +} /* end printError */ + +/***********************************************************************/ + diff --git a/misc/pascal/pascal/pexpr.c b/misc/pascal/pascal/pexpr.c index 188eb67e80..faa179b903 100644 --- a/misc/pascal/pascal/pexpr.c +++ b/misc/pascal/pascal/pexpr.c @@ -1,2735 +1,2737 @@ -/***************************************************************
- * pexpr.c
- * Integer Expression
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************/
-
-/***************************************************************
- * Included Files
- ***************************************************************/
-
-#include <stdio.h>
-#include <string.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "podefs.h" /* general operation codes */
-#include "pfdefs.h" /* floating point operations */
-#include "pxdefs.h" /* library operations */
-#include "pedefs.h"
-
-#include "keywords.h"
-#include "pas.h"
-#include "pstm.h"
-#include "pexpr.h"
-#include "pproc.h" /* for actualParameterList */
-#include "pfunc.h"
-#include "pgen.h" /* for pas_Generate*() */
-#include "ptkn.h"
-#include "pinsn.h"
-#include "perr.h"
-
-/***************************************************************
- * Private Definitions
- ***************************************************************/
-
-#define ADDRESS_DEREFERENCE 0x01
-#define ADDRESS_FACTOR 0x02
-#define INDEXED_FACTOR 0x04
-#define VAR_PARM_FACTOR 0x08
-
-#define intTrunc(x) ((x) & (~(sINT_SIZE)))
-
-/***************************************************************
- * Private Type Declarations
- ***************************************************************/
-
-typedef struct {
- ubyte setType;
- boolean typeFound;
- sint16 minValue;
- sint16 maxValue;
- STYPE *typePtr;
-} setTypeStruct;
-
-/***************************************************************
- * Private Function Prototypes
- ***************************************************************/
-
-static exprType simpleExpression (exprType findExprType);
-static exprType term (exprType findExprType);
-static exprType factor (exprType findExprType);
-static exprType complexFactor (void);
-static exprType simpleFactor (STYPE *varPtr, ubyte factorFlags);
-static exprType ptrFactor (void);
-static exprType complexPtrFactor (void);
-static exprType simplePtrFactor (STYPE *varPtr, ubyte factorFlags);
-static exprType functionDesignator(void);
-static void setAbstractType (STYPE *sType);
-static void getSetFactor (void);
-static void getSetElement (setTypeStruct *s);
-static boolean isOrdinalType (exprType testExprType);
-static boolean isAnyStringType (exprType testExprType);
-static boolean isStringReference (exprType testExprType);
-
-/***************************************************************
- * Private Variables
- ***************************************************************/
-
- /* The abstract types - SETs, RECORDS, etc - require an exact */
- /* match in type. This variable points to the symbol table */
- /* sTYPE entry associated with the expression. */
-
- static STYPE *abstractType;
-
-/***************************************************************/
-/* Evaluate (boolean) Expression */
-
-exprType expression(exprType findExprType, STYPE *typePtr)
-{
- ubyte operation;
- uint16 intOpCode;
- uint16 fpOpCode;
- uint16 strOpCode;
- exprType simple1Type;
- exprType simple2Type;
-
- TRACE(lstFile,"[expression]");
-
- /* The abstract types - SETs, RECORDS, etc - require an exact */
- /* match in type. Save the symbol table sTYPE entry associated */
- /* with the expression. */
-
- if ((typePtr) && (typePtr->sKind != sTYPE)) error(eINVTYPE);
- abstractType = typePtr;
-
- /* FORM <simple expression> [<relational operator> <simple expression>] */
- /* Get the first <simple expression> */
-
- simple1Type = simpleExpression(findExprType);
-
- /* Get the optional <relational operator> which may follow */
-
- operation = token;
- switch (operation)
- {
- case tEQ :
- intOpCode = opEQU;
- fpOpCode = fpEQU;
- strOpCode = opEQUZ;
- break;
- case tNE :
- intOpCode = opNEQ;
- fpOpCode = fpNEQ;
- strOpCode = opNEQZ;
- break;
- case tLT :
- intOpCode = opLT;
- fpOpCode = fpLT;
- strOpCode = opLTZ;
- break;
- case tLE :
- intOpCode = opLTE;
- fpOpCode = fpLTE;
- strOpCode = opLTEZ;
- break;
- case tGT :
- intOpCode = opGT;
- fpOpCode = fpGT;
- strOpCode = opGTZ;
- break;
- case tGE :
- intOpCode = opGTE;
- fpOpCode = fpGTE;
- strOpCode = opGTEZ;
- break;
- case tIN :
- if ((!abstractType) ||
- ((abstractType->sParm.t.type != sSCALAR) &&
- (abstractType->sParm.t.type != sSUBRANGE)))
- error(eEXPRTYPE);
- else if (abstractType->sParm.t.minValue)
- {
- pas_GenerateDataOperation(opPUSH, abstractType->sParm.t.minValue);
- pas_GenerateSimple(opSUB);
- } /* end else if */
- intOpCode = opBIT;
- fpOpCode = fpINVLD;
- strOpCode = opNOP;
- break;
- default :
- intOpCode = opNOP;
- fpOpCode = fpINVLD;
- strOpCode = opNOP;
- break;
- } /* end switch */
-
- /* Check if there is a 2nd simple expression needed */
-
- if (intOpCode != opNOP)
- {
- /* Get the second simple expression */
-
- getToken();
- simple2Type = simpleExpression(findExprType);
-
- /* Perform automatic type conversion from INTEGER to REAL
- * for integer vs. real comparisons.
- */
-
- if (simple1Type != simple2Type)
- {
- /* Handle the case where the 1st argument is REAL and the
- * second is INTEGER. */
-
- if ((simple1Type == exprReal) &&
- (simple2Type == exprInteger) &&
- (fpOpCode != fpINVLD))
- {
- fpOpCode |= fpARG2;
- simple2Type = exprReal;
- } /* end if */
-
- /* Handle the case where the 1st argument is Integer and the
- * second is REAL. */
-
- else if ((simple1Type == exprInteger) &&
- (simple2Type == exprReal) &&
- (fpOpCode != fpINVLD))
- {
- fpOpCode |= fpARG1;
- simple1Type = exprReal;
- } /* end else if */
-
- /* Allow the case of <scalar type> IN <set type> */
- /* Otherwise, the two terms must agree in type */
-
- else if ((operation != tIN) || (simple2Type != exprSet))
- {
- error(eEXPRTYPE);
- }
- } /* end if */
-
- /* Generate the comparison */
-
- if (simple1Type == exprReal)
- {
- if (fpOpCode == fpINVLD)
- error(eEXPRTYPE);
- else
- pas_GenerateFpOperation(fpOpCode);
- } /* end if */
- else if ((simple1Type == exprString) || (simple1Type == exprString))
- {
- if (strOpCode != opNOP)
- {
- pas_BuiltInFunctionCall(lbSTRCMP);
- pas_GenerateSimple(strOpCode);
- }
- else
- {
- error(eEXPRTYPE);
- }
- }
- else
- {
- pas_GenerateSimple(intOpCode);
- }
-
- /* The type resulting from these operations becomes BOOLEAN */
-
- simple1Type = exprBoolean;
-
- } /* end if */
-
- /* Verify that the expression is of the requested type.
- * The following are okay:
- *
- * 1. We were told to find any kind of expression
- *
- * 2. We were told to find a specific kind of expression and
- * we found just that type.
- *
- * 3. We were told to find any kind of ordinal expression and
- * we found a ordinal expression. This is what is needed, for
- * example, as an argument to ord(), pred(), succ(), or odd().
- * This is the kind of expression we need in a CASE statement
- * as well.
- *
- * 4. We were told to find any kind of string expression and
- * we found a string expression. This is a hack to handle
- * calls to system functions that return exprCString pointers
- * that must be converted to exprString records upon assignment.
- *
- * 5. We have a hack in the name space. You use a bogus name
- * to represent a string reference that has string stack
- * allocated with it. For expression processing purposes,
- * exprString and exprStkString are the same thing. The
- * difference is that we have to clean up the string stack
- * for the latter.
- *
- * Special case:
- *
- * We will perform automatic conversions to real from integer
- * if the requested type is a real expression.
- */
-
- if ((findExprType != exprUnknown) && /* 1)NOT Any expression */
-
- (findExprType != simple1Type) && /* 2)NOT Matched expression */
-
- ((findExprType != exprAnyOrdinal) || /* 3)NOT any ordinal type */
- (!isOrdinalType(simple1Type))) && /* OR type is not ordinal */
-
- ((findExprType != exprAnyString) || /* 4)NOT any string type */
- (!isAnyStringType(simple1Type))) && /* OR type is not string */
-
- ((findExprType != exprString) || /* 5)Not looking for string ref */
- (!isStringReference(simple1Type)))) /* OR type is not string ref */
- {
- /* Automatic conversions from INTEGER to REAL will be performed */
-
- if ((findExprType == exprReal) && (simple1Type == exprInteger))
- {
- pas_GenerateFpOperation(fpFLOAT);
- simple1Type = exprReal;
- }
-
- /* Any other type mismatch is an error */
-
- else
- {
- error(eEXPRTYPE);
- }
- } /* end if */
-
- return simple1Type;
-
-} /* end expression */
-
-/***************************************************************/
-/* Provide VAR parameter assignments */
-
-exprType varParm (exprType varExprType, STYPE *typePtr)
-{
- exprType factorType;
-
- /* The abstract types - SETs, RECORDS, etc - require an exact
- * match in type. Save the symbol table sTYPE entry associated
- * with the expression.
- */
-
- if ((typePtr) && (typePtr->sKind != sTYPE)) error(eINVTYPE);
- abstractType = typePtr;
-
- /* This function is really just an interface to the
- * static function ptrFactor with some extra error
- * checking.
- */
-
- factorType = ptrFactor();
- if ((varExprType != exprUnknown) && (factorType != varExprType))
- error(eINVVARPARM);
-
- return factorType;
-
-} /* end varParm */
-
-/**********************************************************************/
-/* Process Array Index */
-void arrayIndex (sint32 size)
-{
- TRACE(lstFile,"[arrayIndex]");
-
- /* FORM: [<integer expression>] */
- getToken();
- if (token != '[') error (eLBRACKET);
- else {
-
- /* Evaluate index expression */
- /* FIX ME: Need to allow any scalar type */
- getToken();
- expression(exprInteger, NULL);
-
- /* Correct for size of array element */
- if (size > 1) {
- pas_GenerateDataOperation(opPUSH, size);
- pas_GenerateSimple(opMUL);
- } /* end if */
-
- /* Verify right bracket */
- if (token != ']') error (eRBRACKET);
- else getToken();
-
- } /* end else */
-
-} /* end arrayIndex */
-
-/*************************************************************************/
-/* Determine the expression type associated with a pointer to a type */
-/* symbol */
-
-exprType getExprType(STYPE *sType)
-{
- exprType factorType = sINT;
-
- TRACE(lstFile,"[getExprType]");
-
- if ((sType) && (sType->sKind == sTYPE))
- {
- switch (sType->sParm.t.type)
- {
- case sINT :
- factorType = exprInteger;
- break;
- case sBOOLEAN :
- factorType = exprBoolean;
- break;
- case sCHAR :
- factorType = exprChar;
- break;
- case sREAL :
- factorType = exprReal;
- break;
- case sSCALAR :
- factorType = exprScalar;
- break;
- case sSTRING :
- case sRSTRING :
- factorType = exprString;
- break;
- case sSUBRANGE :
- switch (sType->sParm.t.subType)
- {
- case sINT :
- factorType = exprInteger;
- break;
- case sCHAR :
- factorType = exprChar;
- break;
- case sSCALAR :
- factorType = exprScalar;
- break;
- default :
- error(eSUBRANGETYPE);
- break;
- } /* end switch */
- break;
- case sPOINTER :
- sType = sType->sParm.t.parent;
- if (sType)
- {
- switch (sType->sKind)
- {
- case sINT :
- factorType = exprIntegerPtr;
- break;
- case sBOOLEAN :
- factorType = exprBooleanPtr;
- break;
- case sCHAR :
- factorType = exprCharPtr;
- break;
- case sREAL :
- factorType = exprRealPtr;
- break;
- case sSCALAR :
- factorType = exprScalarPtr;
- break;
- default :
- error(eINVTYPE);
- break;
- } /* end switch */
- } /* end if */
- break;
- default :
- error(eINVTYPE);
- break;
- } /* end switch */
- } /* end if */
-
- return factorType;
-
-} /* end getExprType */
-
-/***************************************************************/
-/* Process Simple Expression */
-
-static exprType simpleExpression(exprType findExprType)
-{
- sint16 operation = '+';
- uint16 arg8FpBits;
- exprType term1Type;
- exprType term2Type;
-
- TRACE(lstFile,"[simpleExpression]");
-
- /* FORM: [+|-] <term> [{+|-} <term> [{+|-} <term> [...]]] */
- /* get +/- unary operation */
-
- if ((token == '+') || (token == '-'))
- {
- operation = token;
- getToken();
- } /* end if */
-
- /* Process first (non-optional) term and apply unary operation */
-
- term1Type = term(findExprType);
- if (operation == '-')
- {
- if (term1Type == exprInteger)
- pas_GenerateSimple(opNEG);
- else if (term1Type == exprReal)
- pas_GenerateFpOperation(fpNEG);
- else
- error(eTERMTYPE);
- } /* end if */
-
- /* Process subsequent (optional) terms and binary operations */
-
- for (;;)
- {
- /* Check for binary operator */
-
- if ((token == '+') || (token == '-') || (token == tOR))
- operation = token;
- else
- break;
-
- /* Special case for string types. So far, we have parsed
- * '<string> +' At this point, it is safe to assume we
- * going to modified string. So, if the string has not
- * been copied to the string stack, we will have to do that
- * now.
- */
-
- if ((term1Type == exprString) && (operation == '+'))
- {
- /* Duplicate the string on the string stack. And
- * change the expression type to reflect this.
- */
-
- pas_BuiltInFunctionCall(lbMKSTKSTR);
- term1Type = exprStkString;
- }
-
- /* If we are going to add something to a char, then the
- * result must be a string. We will similarly have to
- * convert the character to a string.
- */
-
- else if ((term1Type == exprChar) && (operation == '+'))
- {
- /* Duplicate the string on the string stack. And
- * change the expression type to reflect this.
- */
-
- pas_BuiltInFunctionCall(lbMKSTKC);
- term1Type = exprStkString;
- }
-
- /* Get the 2nd term */
-
- getToken();
- term2Type = term(findExprType);
-
- /* Before generating the operation, verify that the types match.
- * Perform automatic type conversion from INTEGER to REAL as
- * necessary.
- */
-
- arg8FpBits = 0;
-
- /* Skip over string types. These will be handled below */
-
- if (!isStringReference(term1Type))
- {
- /* Handle the case where the type of the terms differ. */
-
- if (term1Type != term2Type)
- {
- /* Handle the case where the 1st argument is REAL and the
- * second is INTEGER. */
-
- if ((term1Type == exprReal) && (term2Type == exprInteger))
- {
- arg8FpBits = fpARG2;
- term2Type = exprReal;
- } /* end if */
-
- /* Handle the case where the 1st argument is Integer and the
- * second is REAL. */
-
- else if ((term1Type == exprInteger) && (term2Type == exprReal))
- {
- arg8FpBits = fpARG1;
- term1Type = exprReal;
- } /* end if */
-
- /* Otherwise, the two terms must agree in type */
-
- else
- {
- error(eTERMTYPE);
- }
- } /* end if */
-
- /* We do not perform conversions for the cases where the two
- * terms agree in type. There is only one interesting case:
- * When the expected expression is real and both arguments are
- * integer. Since addition an subtraction are exact, it would,
- * in general, be more efficient to perform the conversion
- * AFTER the operation (at the the risk of possible overflow
- * conditions due to the limited range of integers).
- */
- }
-
- /* Generate code to perform the selected binary operation */
-
- switch (operation)
- {
- case '+' :
- switch (term1Type)
- {
- /* Integer addition */
-
- case exprInteger :
- pas_GenerateSimple(opADD);
- break;
-
- /* Floating point addition */
-
- case exprReal :
- pas_GenerateFpOperation(fpADD | arg8FpBits);
- break;
-
- /* Set 'addition' */
-
- case exprSet :
- pas_GenerateSimple(opOR);
- break;
-
- /* Handle the special cases where '+' indicates that we are
- * concatenating a string or a character to the end of a
- * string. Note that these operations can only be performed
- * on stack copies of the strings. Logic above should have
- * made the conversion for the case of exprString.
- */
-
- case exprStkString :
- if ((term2Type == exprString) || (term2Type == exprStkString))
- {
- /* We are concatenating one string with another.*/
-
- pas_BuiltInFunctionCall(lbSTRCAT);
- }
- else if (term2Type == exprChar)
- {
- /* We are concatenating a character to the end of a string */
-
- pas_BuiltInFunctionCall(lbSTRCATC);
- }
- else
- {
- error(eTERMTYPE);
- }
- break;
-
- /* Otherwise, the '+' operation is not permitted */
-
- default :
- error(eTERMTYPE);
- break;
- }
- break;
-
- case '-' :
- /* Integer subtraction */
-
- if (term1Type == exprInteger)
- pas_GenerateSimple(opSUB);
-
- /* Floating point subtraction */
-
- else if (term1Type == exprReal)
- pas_GenerateFpOperation(fpSUB | arg8FpBits);
-
- /* Set 'subtraction' */
-
- else if (term1Type == exprSet)
- {
- pas_GenerateSimple(opNOT);
- pas_GenerateSimple(opAND);
- } /* end else if */
-
- /* Otherwise, the '-' operation is not permitted */
-
- else
- error(eTERMTYPE);
- break;
-
- case tOR :
- /* Integer/boolean 'OR' */
-
- if ((term1Type == exprInteger) || (term1Type == exprBoolean))
- pas_GenerateSimple(opOR);
-
- /* Otherwise, the 'OR' operation is not permitted */
-
- else
- error(eTERMTYPE);
- break;
-
- } /* end switch */
- } /* end for */
-
- return term1Type;
-
-} /* end simpleExpression */
-
-/***************************************************************/
-/* Evaluate a TERM */
-
-static exprType term(exprType findExprType)
-{
- ubyte operation;
- uint16 arg8FpBits;
- exprType factor1Type;
- exprType factor2Type;
-
- TRACE(lstFile,"[term]");
-
- /* FORM: <factor> [<operator> <factor>[<operator><factor>[...]]] */
-
- factor1Type = factor(findExprType);
- for (;;) {
-
- /* Check for binary operator */
-
- if ((token == tMUL) || (token == tDIV) ||
- (token == tFDIV) || (token == tMOD) ||
- (token == tAND) || (token == tSHL) ||
- (token == tSHR))
- operation = token;
- else
- break;
-
- /* Get the next factor */
-
- getToken();
- factor2Type = factor(findExprType);
-
- /* Before generating the operation, verify that the types match.
- * Perform automatic type conversion from INTEGER to REAL as
- * necessary.
- */
-
- arg8FpBits = 0;
-
- /* Handle the case where the type of the terms differ. */
-
- if (factor1Type != factor2Type)
- {
- /* Handle the case where the 1st argument is REAL and the
- * second is INTEGER. */
-
- if ((factor1Type == exprReal) && (factor2Type == exprInteger))
- {
- arg8FpBits = fpARG2;
- } /* end if */
-
- /* Handle the case where the 1st argument is Integer and the
- * second is REAL. */
-
- else if ((factor1Type == exprInteger) && (factor2Type == exprReal))
- {
- arg8FpBits = fpARG1;
- factor1Type = exprReal;
- } /* end if */
-
- /* Otherwise, the two factors must agree in type */
-
- else
- {
- error(eFACTORTYPE);
- }
- } /* end if */
-
- /* Handle the cases for conversions when the two string
- * type are the same type.
- */
-
- else
- {
- /* There is only one interesting case: When the
- * expected expression is real and both arguments are
- * integer. In this case, for example, 1/2 must yield
- * 0.5, not 0.
- */
-
- if ((factor1Type == exprInteger) && (findExprType == exprReal))
- {
- /* However, we will perform this conversin only for the
- * arithmetic operations: tMUL, tDIV/tFDIV, and tMOD.
- * The logical operations must be performed on integer
- * types with the result converted to a real type afterward.
- */
-
- if ((operation == tMUL) || (operation == tDIV) ||
- (operation == tFDIV) || (operation == tMOD))
- {
- /* Perform the conversion of both terms */
-
- arg8FpBits = fpARG1 | fpARG2;
- factor1Type = exprReal;
-
- /* We will also have to switch the operation in
- * the case of tDIV: We'll have to used tFDIV.
- */
-
- if (operation == tDIV) operation = tFDIV;
- }
- }
- }
-
- /* Generate code to perform the selected binary operation */
-
- switch (operation)
- {
- case tMUL :
- if (factor1Type == exprInteger)
- pas_GenerateSimple(opMUL);
- else if (factor1Type == exprReal)
- pas_GenerateFpOperation(fpMUL | arg8FpBits);
- else if (factor1Type == exprSet)
- pas_GenerateSimple(opAND);
- else
- error(eFACTORTYPE);
- break;
-
- case tDIV :
- if (factor1Type == exprInteger)
- pas_GenerateSimple(opDIV);
- else
- error(eFACTORTYPE);
- break;
-
- case tFDIV :
- if (factor1Type == exprReal)
- pas_GenerateFpOperation(fpDIV | arg8FpBits);
- else
- error(eFACTORTYPE);
- break;
-
- case tMOD :
- if (factor1Type == exprInteger)
- pas_GenerateSimple(opMOD);
- else if (factor1Type == exprReal)
- pas_GenerateFpOperation(fpMOD | arg8FpBits);
- else
- error(eFACTORTYPE);
- break;
-
- case tAND :
- if ((factor1Type == exprInteger) || (factor1Type == exprBoolean))
- pas_GenerateSimple(opAND);
- else
- error(eFACTORTYPE);
- break;
-
- case tSHL :
- if (factor1Type == exprInteger)
- pas_GenerateSimple(opSLL);
- else
- error(eFACTORTYPE);
- break;
-
- case tSHR :
- if (factor1Type == exprInteger)
- pas_GenerateSimple(opSRA);
- else
- error(eFACTORTYPE);
- break;
-
- } /* end switch */
- } /* end for */
-
- return factor1Type;
-
-} /* end term */
-
-/***************************************************************/
-/* Process a FACTOR */
-
-static exprType factor(exprType findExprType)
-{
- exprType factorType = exprUnknown;
-
- TRACE(lstFile,"[factor]");
-
- /* Process by token type */
-
- switch (token)
- {
- /* User defined tokens */
-
- case tIDENT :
- error(eUNDEFSYM);
- stringSP = tkn_strt;
- factorType = exprUnknown;
- break;
-
- /* Constant factors */
-
- case tINT_CONST :
- pas_GenerateDataOperation(opPUSH, tknInt);
- getToken();
- factorType = exprInteger;
- break;
-
- case tBOOLEAN_CONST :
- pas_GenerateDataOperation(opPUSH, tknInt);
- getToken();
- factorType = exprBoolean;
- break;
-
- case tCHAR_CONST :
- pas_GenerateDataOperation(opPUSH, tknInt);
- getToken();
- factorType = exprChar;
- break;
-
- case tREAL_CONST :
- pas_GenerateDataOperation(opPUSH, (sint32)*(((uint16*)&tknReal)+0));
- pas_GenerateDataOperation(opPUSH, (sint32)*(((uint16*)&tknReal)+1));
- pas_GenerateDataOperation(opPUSH, (sint32)*(((uint16*)&tknReal)+2));
- pas_GenerateDataOperation(opPUSH, (sint32)*(((uint16*)&tknReal)+3));
- getToken();
- factorType = exprReal;
- break;
-
- case sSCALAR_OBJECT :
- if (abstractType)
- {
- if (tknPtr->sParm.c.parent != abstractType) error(eSCALARTYPE);
- } /* end if */
- else
- abstractType = tknPtr->sParm.c.parent;
-
- pas_GenerateDataOperation(opPUSH, tknPtr->sParm.c.val.i);
- getToken();
- factorType = exprScalar;
- break;
-
- /* Simple Factors */
-
- case sINT :
- pas_GenerateStackReference(opLDS, tknPtr);
- getToken();
- factorType = exprInteger;
- break;
-
- case sBOOLEAN :
- pas_GenerateStackReference(opLDS, tknPtr);
- getToken();
- factorType = exprBoolean;
- break;
-
- case sCHAR :
- pas_GenerateStackReference(opLDSB, tknPtr);
- getToken();
- factorType = exprChar;
- break;
-
- case sREAL :
- pas_GenerateDataSize(sREAL_SIZE);
- pas_GenerateStackReference(opLDSM, tknPtr);
- getToken();
- factorType = exprReal;
- break;
-
- /* Strings -- constant and variable */
-
- case tSTRING_CONST :
- {
- /* Final stack representation is:
- * TOS(0) : size in bytes
- * TOS(1) : pointer to string
- *
- * Add the string to the RO data section of the output
- * and get the offset to the string location.
- */
-
- uint32 offset = poffAddRoDataString(poffHandle, tkn_strt);
-
- /* Get the offset then size of the string on the stack */
-
- pas_GenerateDataOperation(opLAC, offset);
- pas_GenerateDataOperation(opPUSH, strlen(tkn_strt));
-
- /* Release the tokenized string */
-
- stringSP = tkn_strt;
- getToken();
- factorType = exprString;
- }
- break;
-
- case sSTRING_CONST :
- /* Final stack representation is:
- * TOS(0) : size in bytes
- * TOS(1) : pointer to string
- */
-
- pas_GenerateDataOperation(opLAC, tknPtr->sParm.s.offset);
- pas_GenerateDataOperation(opPUSH, tknPtr->sParm.s.size);
- getToken();
- factorType = exprString;
- break;
-
- case sSTRING :
- /* Final stack representation is:
- * TOS(0) = size in bytes
- * TOS(1) = pointer to string data
- */
-
- pas_GenerateDataOperation(opPUSH, sSTRING_HDR_SIZE);
- pas_GenerateStackReference(opLASX, tknPtr);
- pas_GenerateStackReference(opLDSH, tknPtr);
-
- getToken();
- factorType = exprString;
- break;
-
- case sRSTRING :
- /* Final stack representation is:
- * TOS(0) : size in bytes
- * TOS(1) : pointer to string data
- *
- * We get that by just cloning the reference on the top of the stack
- */
- pas_GenerateDataSize(tknPtr->sParm.v.size);
- pas_GenerateStackReference(opLDSM, tknPtr);
- getToken();
- factorType = exprString;
- break;
-
- case sSCALAR :
- if (abstractType)
- {
- if (tknPtr->sParm.v.parent != abstractType) error(eSCALARTYPE);
- } /* end if */
- else
- abstractType = tknPtr->sParm.v.parent;
-
- pas_GenerateStackReference(opLDS, tknPtr);
- getToken();
- factorType = exprScalar;
- break;
-
- case sSET_OF :
- /* If an abstractType is specified then it should either be the */
- /* same SET OF <object> -OR- the same <object> */
-
- if (abstractType)
- {
- if ((tknPtr->sParm.v.parent != abstractType) &&
- (tknPtr->sParm.v.parent->sParm.t.parent != abstractType))
- error(eSET);
- } /* end if */
- else
- abstractType = tknPtr->sParm.v.parent;
-
- pas_GenerateStackReference(opLDS, tknPtr);
- getToken();
- factorType = exprSet;
- break;
-
- /* SET factors */
-
- case '[' : /* Set constant */
- getToken();
- getSetFactor();
- if (token != ']') error(eRBRACKET);
- else getToken();
- factorType = exprSet;
- break;
-
- /* Complex factors */
-
- case sSUBRANGE :
- case sRECORD :
- case sRECORD_OBJECT :
- case sVAR_PARM :
- case sPOINTER :
- case sARRAY :
- factorType = complexFactor();
- break;
-
- /* Functions */
-
- case sFUNC :
- factorType = functionDesignator();
- break;
-
- /* Nested Expression */
-
- case '(' :
- getToken();
- factorType = expression(exprUnknown, abstractType);
- if (token == ')') getToken();
- else error (eRPAREN);
- break;
-
- /* Address references */
-
- case '^' :
- getToken();
- factorType = ptrFactor();
- break;
-
- /* Highest Priority Operators */
-
- case tNOT:
- getToken();
- factorType = factor(findExprType);
- if ((factorType != exprInteger) && (factorType != exprBoolean))
- error(eFACTORTYPE);
- pas_GenerateSimple(opNOT);
- break;
-
- /* Built-in function? */
-
- case tFUNC:
- factorType = builtInFunction();
- break;
-
- /* Hmmm... Try the standard functions */
-
- default :
- error(eINVFACTOR);
- break;
-
- } /* end switch */
-
- return factorType;
-
-} /* end factor */
-
-/***********************************************************************/
-/* Process a complex factor */
-
-static exprType complexFactor(void)
-{
- STYPE symbolSave;
-
- TRACE(lstFile,"[complexFactor]");
-
- /* First, make a copy of the symbol table entry because the call to */
- /* simpleFactor() will modify it. */
-
- symbolSave = *tknPtr;
- getToken();
-
- /* Then process the complex factor until it is reduced to a simple */
- /* factor (like int, char, etc.) */
-
- return simpleFactor(&symbolSave, 0);
-
-} /* end complexFactor */
-
-/***********************************************************************/
-/* Process a complex factor (recursively) until it becomes a */
-/* simple factor */
-
-static exprType simpleFactor(STYPE *varPtr, ubyte factorFlags)
-{
- STYPE *typePtr;
- exprType factorType;
-
- TRACE(lstFile,"[simpleFactor]");
-
- /* Process according to the current variable sKind */
-
- typePtr = varPtr->sParm.v.parent;
- switch (varPtr->sKind)
- {
- /* Check if we have reduced the complex factor to a simple factor */
-
- case sINT :
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_GenerateSimple(opLDI);
- factorType = exprInteger;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprIntegerPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprInteger;
- } /* end else */
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateSimple(opLDI);
- factorType = exprInteger;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprIntegerPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprInteger;
- } /* end else */
- } /* end else */
- break;
- case sCHAR :
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_GenerateSimple(opLDIB);
- factorType = exprChar;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprCharPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDSXB, varPtr);
- factorType = exprChar;
- } /* end else */
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateSimple(opLDIB);
- factorType = exprChar;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprCharPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDSB, varPtr);
- factorType = exprChar;
- } /* end else */
- } /* end else */
- break;
- case sBOOLEAN :
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_GenerateSimple(opLDI);
- factorType = exprBoolean;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprBooleanPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprBoolean;
- } /* end else */
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateSimple(opLDI);
- factorType = exprBoolean;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprBooleanPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprBoolean;
- } /* end else */
- } /* end else */
- break;
- case sREAL :
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_GenerateDataSize(varPtr->sParm.v.size);
- pas_GenerateSimple(opLDIM);
- factorType = exprReal;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprRealPtr;
- } /* end else if */
- else
- {
- pas_GenerateDataSize(varPtr->sParm.v.size);
- pas_GenerateStackReference(opLDSXM, varPtr);
- factorType = exprReal;
- } /* end else */
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateDataSize(varPtr->sParm.v.size);
- pas_GenerateSimple(opLDIM);
- factorType = exprReal;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprRealPtr;
- } /* end else if */
- else
- {
- pas_GenerateDataSize(varPtr->sParm.v.size);
- pas_GenerateStackReference(opLDSM, varPtr);
- factorType = exprReal;
- } /* end else */
- } /* end else */
- break;
- case sSCALAR :
- if (!abstractType)
- abstractType = typePtr;
- else if (typePtr != abstractType)
- error(eSCALARTYPE);
-
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_GenerateSimple(opLDI);
- factorType = exprScalar;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprScalarPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprScalar;
- } /* end else */
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateSimple(opLDI);
- factorType = exprScalar;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprScalarPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprScalar;
- } /* end else */
- } /* end else */
- break;
- case sSET_OF :
- if (!abstractType)
- abstractType = typePtr;
- else if ((typePtr != abstractType) &&
- (typePtr->sParm.v.parent != abstractType))
- error(eSCALARTYPE);
-
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_GenerateSimple(opLDI);
- factorType = exprSet;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprSetPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- factorType = exprSet;
- } /* end else */
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateSimple(opLDI);
- factorType = exprSet;
- } /* end if */
- else if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprSetPtr;
- } /* end else if */
- else
- {
- pas_GenerateStackReference(opLDS, varPtr);
- factorType = exprSet;
- } /* end else */
- } /* end else */
- break;
-
- /* NOPE... recurse until it becomes a simple factor */
-
- case sSUBRANGE :
- if (!abstractType) abstractType = typePtr;
- varPtr->sKind = typePtr->sParm.t.subType;
- factorType = simpleFactor(varPtr, factorFlags);
- break;
-
- case sRECORD :
- /* Check if this is a pointer to a record */
-
- if ((factorFlags & ADDRESS_FACTOR) != 0)
- {
- if (token == '.') error(ePOINTERTYPE);
-
- if ((factorFlags & INDEXED_FACTOR) != 0)
- pas_GenerateStackReference(opLDSX, varPtr);
- else
- pas_GenerateStackReference(opLDS, varPtr);
-
- factorType = exprRecordPtr;
- } /* end if */
-
- /* Verify that a period separates the RECORD identifier from the */
- /* record field identifier */
-
- else if (token == '.')
- {
- if (((factorFlags & ADDRESS_DEREFERENCE) != 0) &&
- ((factorFlags & VAR_PARM_FACTOR) == 0))
- error(ePOINTERTYPE);
-
- /* Skip over the period. */
-
- getToken();
-
- /* Verify that a field identifier associated with this record */
- /* follows the period. */
-
- if ((token != sRECORD_OBJECT) ||
- (tknPtr->sParm.r.record != typePtr))
- {
- error(eRECORDOBJECT);
- factorType = exprInteger;
- } /* end if */
- else
- {
- /* Modify the variable so that it has the characteristics of the */
- /* the field but with level and offset associated with the record */
-
- typePtr = tknPtr->sParm.r.parent;
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sParm.v.parent = typePtr;
-
- /* Special case: The record is a VAR parameter. */
-
- if (factorFlags == (INDEXED_FACTOR | ADDRESS_DEREFERENCE | VAR_PARM_FACTOR))
- {
- pas_GenerateDataOperation(opPUSH, tknPtr->sParm.r.offset);
- pas_GenerateSimple(opADD);
- } /* end if */
- else
- varPtr->sParm.v.offset += tknPtr->sParm.r.offset;
-
- getToken();
- factorType = simpleFactor(varPtr, factorFlags);
- } /* end else */
- } /* end else if */
-
- /* A RECORD name name be a valid factor -- as the input */
- /* parameter of a function or in an assignment */
-
- else if (abstractType == typePtr)
- {
- /* Special case: The record is a VAR parameter. */
-
- if (factorFlags == (INDEXED_FACTOR | ADDRESS_DEREFERENCE | VAR_PARM_FACTOR))
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateSimple(opADD);
- pas_GenerateDataSize(varPtr->sParm.v.size);
- pas_GenerateSimple(opLDIM);
- } /* end if */
- else
- {
- pas_GenerateDataSize(varPtr->sParm.v.size);
- pas_GenerateStackReference(opLDSM, varPtr);
- } /* end else */
-
- factorType = exprRecord;
- } /* end else if */
- else error(ePERIOD);
- break;
-
- case sRECORD_OBJECT :
- /* NOTE: This must have been preceeded with a WITH statement */
- /* defining the RECORD type */
-
- if (!withRecord.parent)
- error(eINVTYPE);
- else if ((factorFlags && (ADDRESS_DEREFERENCE | ADDRESS_FACTOR)) != 0)
- error(ePOINTERTYPE);
- else if ((factorFlags && INDEXED_FACTOR) != 0)
- error(eARRAYTYPE);
-
- /* Verify that a field identifier is associated with the RECORD */
- /* specified by the WITH statement. */
-
- else if (varPtr->sParm.r.record != withRecord.parent)
- error(eRECORDOBJECT);
- else
- {
- sint16 tempOffset;
-
- /* Now there are two cases to consider: (1) the withRecord is a */
- /* pointer to a RECORD, or (2) the withRecord is the RECOR itself */
-
- if (withRecord.pointer)
- {
- /* If the pointer is really a VAR parameter, then other syntax */
- /* rules will apply */
-
- if (withRecord.varParm)
- factorFlags |= (INDEXED_FACTOR | ADDRESS_DEREFERENCE | VAR_PARM_FACTOR);
- else
- factorFlags |= (INDEXED_FACTOR | ADDRESS_DEREFERENCE);
-
- pas_GenerateDataOperation(opPUSH, (varPtr->sParm.r.offset + withRecord.index));
- tempOffset = withRecord.offset;
- } /* end if */
- else
- {
- tempOffset = varPtr->sParm.r.offset + withRecord.offset;
- } /* end else */
-
- /* Modify the variable so that it has the characteristics of the */
- /* the field but with level and offset associated with the record */
- /* NOTE: We have to be careful here because the structure */
- /* associated with sRECORD_OBJECT is not the same as for */
- /* variables! */
-
- typePtr = varPtr->sParm.r.parent;
- tempOffset = varPtr->sParm.r.offset;
-
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sLevel = withRecord.level;
- varPtr->sParm.v.size = typePtr->sParm.t.asize;
- varPtr->sParm.v.offset = tempOffset + withRecord.offset;
- varPtr->sParm.v.parent = typePtr;
-
- factorType = simpleFactor(varPtr, factorFlags);
- } /* end else */
- break;
-
- case sPOINTER :
- if (token == '^')
- {
- getToken();
- factorFlags |= ADDRESS_DEREFERENCE;
- } /* end if */
- else
- factorFlags |= ADDRESS_FACTOR;
-
- varPtr->sKind = typePtr->sParm.t.type;
- factorType = simpleFactor(varPtr, factorFlags);
- break;
-
- case sVAR_PARM :
- if (factorFlags != 0) error(eVARPARMTYPE);
- factorFlags |= (ADDRESS_DEREFERENCE | VAR_PARM_FACTOR);
-
- varPtr->sKind = typePtr->sParm.t.type;
- factorType = simpleFactor(varPtr, factorFlags);
- break;
-
- case sARRAY :
- if (factorFlags != 0) error(eARRAYTYPE);
-
- if (token == '[')
- {
- factorFlags |= INDEXED_FACTOR;
- arrayIndex(typePtr->sParm.t.asize);
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sParm.v.size = typePtr->sParm.t.asize;
- factorType = simpleFactor(varPtr, factorFlags);
- } /* end if */
-
- /* An ARRAY name name be a valid factor -- only as the input */
- /* parameter of a function */
-
- else if (abstractType == varPtr)
- {
- pas_GenerateDataSize(varPtr->sParm.v.size);
- pas_GenerateStackReference(opLDSM, varPtr);
- factorType = exprArray;
- } /* end else if */
- else error(eLBRACKET);
- break;
-
- default :
- error(eINVTYPE);
- factorType = exprInteger;
- break;
- } /* end switch */
-
- return factorType;
-
-} /* end simpleFactor */
-
-/**********************************************************************/
-/* Process a factor of the for ^variable OR a VAR parameter (where the
- * ^ is implicit. */
-
-static exprType ptrFactor(void)
-{
- exprType factorType;
-
- TRACE(lstFile,"[ptrFactor]");
-
- /* Process by token type */
-
- switch (token) {
-
- /* Pointers to simple types */
-
- case sINT :
- pas_GenerateStackReference(opLAS, tknPtr);
- getToken();
- factorType = exprIntegerPtr;
- break;
- case sBOOLEAN :
- pas_GenerateStackReference(opLAS, tknPtr);
- getToken();
- factorType = exprBooleanPtr;
- break;
- case sCHAR :
- pas_GenerateStackReference(opLAS, tknPtr);
- getToken();
- factorType = exprCharPtr;
- break;
- case sREAL :
- pas_GenerateStackReference(opLAS, tknPtr);
- getToken();
- factorType = exprRealPtr;
- break;
- case sSCALAR :
- if (abstractType)
- {
- if (tknPtr->sParm.v.parent != abstractType) error(eSCALARTYPE);
- } /* end if */
- else
- abstractType = tknPtr->sParm.v.parent;
-
- pas_GenerateStackReference(opLAS, tknPtr);
- getToken();
- factorType = exprScalarPtr;
- break;
- case sSET_OF :
- /* If an abstractType is specified then it should either be the */
- /* same SET OF <object> -OR- the same <object> */
-
- if (abstractType) {
- if ((tknPtr->sParm.v.parent != abstractType)
- && (tknPtr->sParm.v.parent->sParm.t.parent != abstractType))
- error(eSET);
- } /* end if */
- else
- abstractType = tknPtr->sParm.v.parent;
- pas_GenerateStackReference(opLAS, tknPtr);
- getToken();
- factorType = exprSetPtr;
- break;
-
- /* Complex factors */
-
- case sSUBRANGE :
- case sRECORD :
- case sRECORD_OBJECT :
- case sVAR_PARM :
- case sPOINTER :
- case sARRAY :
- factorType = complexPtrFactor();
- break;
-
- /* References to address of a pointer */
-
- case '^' :
- error(eNOTYET);
- getToken();
- factorType = ptrFactor();
- break;
-
- case '(' :
- getToken();
- factorType = ptrFactor();
- if (token != ')') error (eRPAREN);
- else getToken();
- break;
-
- default :
- error(ePTRADR);
- break;
-
- } /* end switch */
-
- return factorType;
-
-} /* end ptrFactor */
-
-/***********************************************************************/
-/* Process a complex factor */
-
-static exprType complexPtrFactor(void)
-{
- STYPE symbolSave;
-
- TRACE(lstFile,"[complexPtrFactor]");
-
- /* First, make a copy of the symbol table entry because the call to */
- /* simplePtrFactor() will modify it. */
-
- symbolSave = *tknPtr;
- getToken();
-
- /* Then process the complex factor until it is reduced to a simple */
- /* factor (like int, char, etc.) */
-
- return simplePtrFactor(&symbolSave, 0);
-
-} /* end complexPtrFactor */
-
-/***********************************************************************/
-/* Process a complex factor (recursively) until it becomes a */
-/* simple simple */
-
-static exprType simplePtrFactor(STYPE *varPtr, ubyte factorFlags)
-{
- STYPE *typePtr;
- exprType factorType;
-
- TRACE(lstFile,"[simplePtrFactor]");
-
- /* Process according to the current variable sKind */
-
- typePtr = varPtr->sParm.v.parent;
- switch (varPtr->sKind)
- {
- /* Check if we have reduced the complex factor to a simple factor */
- case sINT :
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLASX, varPtr);
- } /* end else */
- factorType = exprIntegerPtr;
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLAS, varPtr);
- } /* end else */
- factorType = exprIntegerPtr;
- } /* end else */
- break;
- case sCHAR :
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLASX, varPtr);
- } /* end else */
- factorType = exprCharPtr;
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLAS, varPtr);
- } /* end else */
- factorType = exprCharPtr;
- } /* end else */
- break;
- case sBOOLEAN :
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLASX, varPtr);
- } /* end else */
- factorType = exprBooleanPtr;
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLAS, varPtr);
- } /* end else */
- factorType = exprBooleanPtr;
- } /* end else */
- break;
- case sREAL :
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLASX, varPtr);
- } /* end else */
- factorType = exprRealPtr;
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLAS, varPtr);
- } /* end else */
- factorType = exprRealPtr;
- } /* end else */
- break;
- case sSCALAR :
- if (!abstractType)
- abstractType = typePtr;
- else if (typePtr != abstractType)
- error(eSCALARTYPE);
-
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLASX, varPtr);
- } /* end else */
- factorType = exprScalarPtr;
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLAS, varPtr);
- } /* end else */
- factorType = exprScalarPtr;
- } /* end else */
- break;
- case sSET_OF :
- if (!abstractType)
- abstractType = typePtr;
- else if ((typePtr != abstractType) &&
- (typePtr->sParm.v.parent != abstractType))
- error(eSCALARTYPE);
-
- if ((factorFlags & INDEXED_FACTOR) != 0)
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLASX, varPtr);
- } /* end else */
- factorType = exprSetPtr;
- } /* end if */
- else
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLAS, varPtr);
- } /* end else */
- factorType = exprSetPtr;
- } /* end else */
- break;
-
- /* NOPE... recurse until it becomes a simple factor */
-
- case sSUBRANGE :
- if (!abstractType) abstractType = typePtr;
- varPtr->sKind = typePtr->sParm.t.subType;
- factorType = simplePtrFactor(varPtr, factorFlags);
- break;
-
- case sRECORD :
- /* Check if this is a pointer to a record */
-
- if (token != '.')
- {
- if ((factorFlags & ADDRESS_DEREFERENCE) != 0)
- error(ePOINTERTYPE);
-
- if ((factorFlags & INDEXED_FACTOR) != 0)
- pas_GenerateStackReference(opLASX, varPtr);
- else
- pas_GenerateStackReference(opLAS, varPtr);
-
- factorType = exprRecordPtr;
- } /* end if */
- else
- {
- /* Verify that a period separates the RECORD identifier from the
- * record field identifier
- */
-
- if (token != '.') error(ePERIOD);
- else getToken();
-
- /* Verify that a field identifier associated with this record
- * follows the period.
- */
-
- if ((token != sRECORD_OBJECT) ||
- (tknPtr->sParm.r.record != typePtr))
- {
- error(eRECORDOBJECT);
- factorType = exprInteger;
- } /* end if */
- else
- {
- /* Modify the variable so that it has the characteristics
- * of the field but with level and offset associated with
- * the record
- */
-
- typePtr = tknPtr->sParm.r.parent;
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sParm.v.offset += tknPtr->sParm.r.offset;
- varPtr->sParm.v.parent = typePtr;
-
- getToken();
- factorType = simplePtrFactor(varPtr, factorFlags);
-
- } /* end else */
- } /* end else */
- break;
-
- case sRECORD_OBJECT :
- /* NOTE: This must have been preceeded with a WITH statement
- * defining the RECORD type
- */
-
- if (!withRecord.parent)
- error(eINVTYPE);
- else if ((factorFlags && ADDRESS_DEREFERENCE) != 0)
- error(ePOINTERTYPE);
- else if ((factorFlags && INDEXED_FACTOR) != 0)
- error(eARRAYTYPE);
-
- /* Verify that a field identifier is associated with the RECORD
- * specified by the WITH statement.
- */
-
- else if (varPtr->sParm.r.record != withRecord.parent)
- error(eRECORDOBJECT);
- else
- {
- sint16 tempOffset;
-
- /* Now there are two cases to consider: (1) the withRecord is a
- * pointer to a RECORD, or (2) the withRecord is the RECOR itself
- */
-
- if (withRecord.pointer)
- {
- pas_GenerateDataOperation(opPUSH, (varPtr->sParm.r.offset + withRecord.index));
- factorFlags |= (INDEXED_FACTOR | ADDRESS_DEREFERENCE);
- tempOffset = withRecord.offset;
- } /* end if */
- else
- {
- tempOffset = varPtr->sParm.r.offset + withRecord.offset;
- } /* end else */
-
- /* Modify the variable so that it has the characteristics of the
- * the field but with level and offset associated with the record
- * NOTE: We have to be careful here because the structure
- * associated with sRECORD_OBJECT is not the same as for
- * variables!
- */
-
- typePtr = varPtr->sParm.r.parent;
- tempOffset = varPtr->sParm.r.offset;
-
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sLevel = withRecord.level;
- varPtr->sParm.v.size = typePtr->sParm.t.asize;
- varPtr->sParm.v.offset = tempOffset + withRecord.offset;
- varPtr->sParm.v.parent = typePtr;
-
- factorType = simplePtrFactor(varPtr, factorFlags);
- } /* end else */
- break;
-
- case sPOINTER :
- if (token == '^') error(ePTRADR);
- else getToken();
-
- factorFlags |= ADDRESS_DEREFERENCE;
- varPtr->sKind = typePtr->sParm.t.type;
- factorType = simplePtrFactor(varPtr, factorFlags);
- break;
-
- case sVAR_PARM :
- if (factorFlags != 0) error(eVARPARMTYPE);
- factorFlags |= ADDRESS_DEREFERENCE;
-
- varPtr->sKind = typePtr->sParm.t.type;
- factorType = simplePtrFactor(varPtr, factorFlags);
- break;
-
- case sARRAY :
- if (factorFlags != 0) error(eARRAYTYPE);
- if (token == '[')
- {
- factorFlags |= INDEXED_FACTOR;
-
- arrayIndex(typePtr->sParm.t.asize);
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sParm.v.size = typePtr->sParm.t.asize;
- factorType = simplePtrFactor(varPtr, factorFlags);
- } /* end if */
- else
- {
- pas_GenerateStackReference(opLAS, varPtr);
- factorType = exprArrayPtr;
- } /* end else */
- break;
-
- default :
- error(eINVTYPE);
- factorType = exprInteger;
- break;
-
- } /* end switch */
-
- return factorType;
-
-} /* end simplePtrFactor */
-
-/***********************************************************************/
-
-static exprType functionDesignator(void)
-{
- STYPE *funcPtr = tknPtr;
- STYPE *typePtr = funcPtr->sParm.p.parent;
- exprType factorType;
- int size = 0;
-
- TRACE(lstFile,"[functionDesignator]");
-
- /* FORM: function-designator =
- * function-identifier [ actual-parameter-list ]
- */
-
- /* Allocate stack space for a reference instance of the type
- * returned by the function. This is an uninitalized "container"
- * that will catch the valued returned by the function.
- *
- * Check for the special case of a string value. In this case,
- * the container cannot be empty. Rather, it must refer to an
- * empty string allocated on the string strack
- */
-
- if (typePtr->sParm.t.rtype == sRSTRING)
- {
- /* Create and empty string reference */
-
- pas_BuiltInFunctionCall(lbMKSTK);
- }
- else
- {
- /* Okay, create the empty container */
-
- pas_GenerateDataOperation(opINDS, typePtr->sParm.t.rsize);
- }
-
- /* Get the type of the function */
-
- factorType = getExprType(typePtr);
- setAbstractType(typePtr);
-
- /* Skip over the function-identifier */
-
- getToken();
-
- /* Get the actual parameters (if any) associated with the procedure
- * call. This will lie in the stack "above" the function return
- * value container.
- */
-
- size = actualParameterList(funcPtr);
-
- /* Generate function call and stack adjustment (if required) */
-
- pas_GenerateProcedureCall(funcPtr);
-
- /* Release the actual parameter list (if any). */
-
- if (size)
- {
- pas_GenerateDataOperation(opINDS, -size);
- }
-
- return factorType;
-
-} /* end functionDesignator */
-
-/*************************************************************************/
-/* Determine the expression type associated with a pointer to a type */
-/* symbol */
-
-static void setAbstractType(STYPE *sType)
-{
- TRACE(lstFile,"[setAbstractType]");
-
- if ((sType) && (sType->sKind == sTYPE)
- && (sType->sParm.t.type == sPOINTER))
- sType = sType->sParm.t.parent;
-
- if ((sType) && (sType->sKind == sTYPE)) {
- switch (sType->sParm.t.type) {
- case sSCALAR :
- if (abstractType) {
- if (sType != abstractType) error(eSCALARTYPE);
- } /* end if */
- else
- abstractType = sType;
- break;
- case sSUBRANGE :
- if (!abstractType)
- abstractType = sType;
- else if ((abstractType->sParm.t.type != sSUBRANGE)
- || (abstractType->sParm.t.subType != sType->sParm.t.subType))
- error(eSUBRANGETYPE);
- switch (sType->sParm.t.subType) {
- case sINT :
- case sCHAR :
- break;
- case sSCALAR :
- if (abstractType != sType) error(eSUBRANGETYPE);
- break;
- default :
- error(eSUBRANGETYPE);
- break;
- } /* end switch */
- break;
- } /* end switch */
- } /* end if */
- else error(eINVTYPE);
-
-} /* end setAbstractType */
-
-/***************************************************************/
-static void getSetFactor(void)
-{
- setTypeStruct s;
-
- TRACE(lstFile,"[getSetFactor]");
-
- /* FORM: [[<constant>[,<constant>[, ...]]]] */
- /* ASSUMPTION: The first '[' has already been processed */
-
- /* First, verify that a scalar expression type has been specified */
- /* If the abstractType is a SET, then we will need to get the TYPE */
- /* that it is a SET OF */
-
- if (abstractType) {
- if (abstractType->sParm.t.type == sSET_OF)
- s.typePtr = abstractType->sParm.t.parent;
- else
- s.typePtr = abstractType;
- } /* end if */
- else
- s.typePtr = NULL;
-
- /* Now, get the associated type and MIN/MAX values */
-
- if ((s.typePtr) && (s.typePtr->sParm.t.type == sSCALAR)) {
- s.typeFound = TRUE;
- s.setType = sSCALAR;
- s.minValue = s.typePtr->sParm.t.minValue;
- s.maxValue = s.typePtr->sParm.t.maxValue;
- } /* end else if */
- else if ((s.typePtr) && (s.typePtr->sParm.t.type == sSUBRANGE)) {
- s.typeFound = TRUE;
- s.setType = s.typePtr->sParm.t.subType;
- s.minValue = s.typePtr->sParm.t.minValue;
- s.maxValue = s.typePtr->sParm.t.maxValue;
- } /* end else if */
- else {
- error(eSET);
- s.typeFound = FALSE;
- s.typePtr = NULL;
- s.minValue = 0;
- s.maxValue = BITS_IN_INTEGER-1;
- } /* end else */
-
- /* Get the first element of the set */
-
- getSetElement(&s);
-
- /* Incorporate each additional element into the set */
- /* NOTE: The optimizer will combine sets of constant elements into a */
- /* single PUSH! */
-
- while (token == ',') {
-
- /* Get the next element of the set */
- getToken();
- getSetElement(&s);
-
- /* OR it with the previous element */
- pas_GenerateSimple(opOR);
-
- } /* end while */
-
-} /* end getSetFactor */
-
-/***************************************************************/
-static void getSetElement(setTypeStruct *s)
-{
- uint16 setValue;
- sint16 firstValue;
- sint16 lastValue;
- STYPE *setPtr;
-
- TRACE(lstFile,"[getSetElement]");
-
- switch (token) {
- case sSCALAR_OBJECT : /* A scalar or scalar subrange constant */
- firstValue = tknPtr->sParm.c.val.i;
- if (!s->typeFound) {
- s->typeFound = TRUE;
- s->typePtr = tknPtr->sParm.c.parent;
- s->setType = sSCALAR;
- s->minValue = s->typePtr->sParm.t.minValue;
- s->maxValue = s->typePtr->sParm.t.maxValue;
- } /* end if */
- else if ((s->setType != sSCALAR)
- || (s->typePtr != tknPtr->sParm.c.parent))
- error(eSET);
- goto addBit;
-
- case tINT_CONST : /* An integer subrange constant ? */
- firstValue = tknInt;
- if (!s->typeFound) {
- s->typeFound = TRUE;
- s->setType = sINT;
- } /* end if */
- else if (s->setType != sINT)
- error(eSET);
- goto addBit;
-
- case tCHAR_CONST : /* A character subrange constant */
- firstValue = tknInt;
- if (!s->typeFound) {
- s->typeFound = TRUE;
- s->setType = sCHAR;
- } /* end if */
- else if (s->setType != sCHAR)
- error(eSET);
-
- addBit:
- /* Check if the constant set element is the first value in a */
- /* subrange of values */
-
- getToken();
- if (token != tSUBRANGE) {
-
- /* Verify that the new value is in range */
-
- if ((firstValue < s->minValue) || (firstValue > s->maxValue)) {
- error(eSETRANGE);
- setValue = 0;
- } /* end if */
- else
- setValue = (1 << (firstValue - s->minValue));
-
- /* Now, generate P-Code to push the set value onto the stack */
-
- pas_GenerateDataOperation(opPUSH, setValue);
-
- } /* end if */
- else {
- if (!s->typeFound) error(eSUBRANGETYPE);
-
- /* Skip over the tSUBRANGE token */
-
- getToken();
-
- /* TYPE check */
-
- switch (token) {
- case sSCALAR_OBJECT : /* A scalar or scalar subrange constant */
- lastValue = tknPtr->sParm.c.val.i;
- if ((s->setType != sSCALAR)
- || (s->typePtr != tknPtr->sParm.c.parent))
- error(eSET);
- goto addLottaBits;
-
- case tINT_CONST : /* An integer subrange constant ? */
- lastValue = tknInt;
- if (s->setType != sINT) error(eSET);
- goto addLottaBits;
-
- case tCHAR_CONST : /* A character subrange constant */
- lastValue = tknInt;
- if (s->setType != sCHAR) error(eSET);
-
- addLottaBits :
- /* Verify that the first value is in range */
- if (firstValue < s->minValue) {
- error(eSETRANGE);
- firstValue = s->minValue;
- } /* end if */
- else if (firstValue > s->maxValue) {
- error(eSETRANGE);
- firstValue = s->maxValue;
- } /* end else if */
-
- /* Verify that the last value is in range */
- if (lastValue < firstValue) {
- error(eSETRANGE);
- lastValue = firstValue;
- } /* end if */
- else if (lastValue > s->maxValue) {
- error(eSETRANGE);
- lastValue = s->maxValue;
- } /* end else if */
-
- /* Set all bits from firstValue through lastValue */
-
- setValue = (0xffff << (firstValue - s->minValue));
- setValue &= (0xffff >> ((BITS_IN_INTEGER-1) - (lastValue - s->minValue)));
-
- /* Now, generate P-Code to push the set value onto the stack */
-
- pas_GenerateDataOperation(opPUSH, setValue);
- break;
-
- case sSCALAR :
- if ((!s->typePtr)
- || (s->typePtr != tknPtr->sParm.v.parent)) {
- error(eSET);
-
- if (!s->typePtr) {
- s->typeFound = TRUE;
- s->typePtr = tknPtr->sParm.v.parent;
- s->setType = sSCALAR;
- s->minValue = s->typePtr->sParm.t.minValue;
- s->maxValue = s->typePtr->sParm.t.maxValue;
- } /* end if */
- } /* end if */
- goto addVarToBits;
-
- case sINT : /* An integer subrange variable ? */
- case sCHAR : /* A character subrange variable? */
- if (s->setType != token) error(eSET);
- goto addVarToBits;
-
- case sSUBRANGE :
- if ((!s->typePtr)
- || (s->typePtr != tknPtr->sParm.v.parent)) {
-
- if ((tknPtr->sParm.v.parent->sParm.t.subType == sSCALAR)
- || (tknPtr->sParm.v.parent->sParm.t.subType != s->setType))
- error(eSET);
-
- if (!s->typePtr) {
- s->typeFound = TRUE;
- s->typePtr = tknPtr->sParm.v.parent;
- s->setType = s->typePtr->sParm.t.subType;
- s->minValue = s->typePtr->sParm.t.minValue;
- s->maxValue = s->typePtr->sParm.t.maxValue;
- } /* end if */
- } /* end if */
-
- addVarToBits:
- /* Verify that the first value is in range */
-
- if (firstValue < s->minValue) {
- error(eSETRANGE);
- firstValue = s->minValue;
- } /* end if */
- else if (firstValue > s->maxValue) {
- error(eSETRANGE);
- firstValue = s->maxValue;
- } /* end else if */
-
- /* Set all bits from firstValue through maxValue */
-
- setValue = (0xffff >> ((BITS_IN_INTEGER-1) - (s->maxValue - s->minValue)));
- setValue &= (0xffff << (firstValue - s->minValue));
-
- /* Generate run-time logic to get all bits from firstValue */
- /* through last value, i.e., need to generate logic to get: */
- /* 0xffff >> ((BITS_IN_INTEGER-1)-(lastValue-minValue)) */
-
- pas_GenerateDataOperation(opPUSH, 0xffff);
- pas_GenerateDataOperation(opPUSH, ((BITS_IN_INTEGER-1) + s->minValue));
- pas_GenerateStackReference(opLDS, tknPtr);
- pas_GenerateSimple(opSUB);
- pas_GenerateSimple(opSRL);
-
- /* Then AND this with the setValue */
-
- if (setValue != 0xffff) {
- pas_GenerateDataOperation(opPUSH, setValue);
- pas_GenerateSimple(opAND);
- } /* end if */
-
- getToken();
- break;
-
- default :
- error(eSET);
- pas_GenerateDataOperation(opPUSH, 0);
- break;
-
- } /* end switch */
- } /* end else */
- break;
-
- case sSCALAR :
- if (s->typeFound) {
- if ((!s->typePtr) || (s->typePtr != tknPtr->sParm.v.parent))
- error(eSET);
- } /* end if */
- else {
- s->typeFound = TRUE;
- s->typePtr = tknPtr->sParm.v.parent;
- s->setType = sSCALAR;
- s->minValue = s->typePtr->sParm.t.minValue;
- s->maxValue = s->typePtr->sParm.t.maxValue;
- } /* end if */
- goto addVar;
-
- case sINT : /* An integer subrange variable ? */
- case sCHAR : /* A character subrange variable? */
- if (!s->typeFound) {
- s->typeFound = TRUE;
- s->setType = token;
- } /* end if */
- else if (s->setType != token)
- error(eSET);
- goto addVar;
-
- case sSUBRANGE :
- if (s->typeFound) {
- if ((!s->typePtr) || (s->typePtr != tknPtr->sParm.v.parent))
- error(eSET);
- } /* end if */
- else {
- s->typeFound = TRUE;
- s->typePtr = tknPtr->sParm.v.parent;
- s->setType = s->typePtr->sParm.t.subType;
- s->minValue = s->typePtr->sParm.t.minValue;
- s->maxValue = s->typePtr->sParm.t.maxValue;
- } /* end if */
-
- addVar:
- /* Check if the variable set element is the first value in a */
- /* subrange of values */
-
- setPtr = tknPtr;
- getToken();
- if (token != tSUBRANGE) {
-
- /* Generate P-Code to push the set value onto the stack */
- /* FORM: 1 << (firstValue - minValue) */
-
- pas_GenerateDataOperation(opPUSH, 1);
- pas_GenerateStackReference(opLDS, setPtr);
- pas_GenerateDataOperation(opPUSH, s->minValue);
- pas_GenerateSimple(opSUB);
- pas_GenerateSimple(opSLL);
-
- } /* end if */
- else {
- if (!s->typeFound) error(eSUBRANGETYPE);
-
- /* Skip over the tSUBRANGE token */
-
- getToken();
-
- /* TYPE check */
-
- switch (token) {
- case sSCALAR_OBJECT : /* A scalar or scalar subrange constant */
- lastValue = tknPtr->sParm.c.val.i;
- if ((s->setType != sSCALAR)
- || (s->typePtr != tknPtr->sParm.c.parent))
- error(eSET);
- goto addBitsToVar;
-
- case tINT_CONST : /* An integer subrange constant ? */
- lastValue = tknInt;
- if (s->setType != sINT) error(eSET);
- goto addBitsToVar;
-
- case tCHAR_CONST : /* A character subrange constant */
- lastValue = tknInt;
- if (s->setType != sCHAR) error(eSET);
-
- addBitsToVar :
- /* Verify that the last value is in range */
-
- if (lastValue < s->minValue) {
- error(eSETRANGE);
- lastValue = s->minValue;
- } /* end if */
- else if (lastValue > s->maxValue) {
- error(eSETRANGE);
- lastValue = s->maxValue;
- } /* end else if */
-
- /* Set all bits from minValue through lastValue */
-
- setValue = (0xffff >> ((BITS_IN_INTEGER-1) - (lastValue - s->minValue)));
-
- /* Now, generate P-Code to push the set value onto the stack */
- /* First generate: 0xffff << (firstValue-minValue) */
-
- pas_GenerateDataOperation(opPUSH, 0xffff);
- pas_GenerateStackReference(opLDS, setPtr);
- if (s->minValue) {
- pas_GenerateDataOperation(opPUSH, s->minValue);
- pas_GenerateSimple(opSUB);
- } /* end if */
- pas_GenerateSimple(opSLL);
-
- /* Then and this with the pre-computed constant set value */
-
- if (setValue != 0xffff) {
- pas_GenerateDataOperation(opPUSH, setValue);
- pas_GenerateSimple(opAND);
- } /* end if */
-
- getToken();
- break;
-
- case sINT : /* An integer subrange variable ? */
- case sCHAR : /* A character subrange variable? */
- if (s->setType != token) error(eSET);
- goto addVarToVar;
-
- case sSCALAR :
- if (s->typePtr != tknPtr->sParm.v.parent) error(eSET);
- goto addVarToVar;
-
- case sSUBRANGE :
- if ((s->typePtr != tknPtr->sParm.v.parent)
- && ((tknPtr->sParm.v.parent->sParm.t.subType == sSCALAR)
- || (tknPtr->sParm.v.parent->sParm.t.subType != s->setType)))
- error(eSET);
-
- addVarToVar:
-
- /* Generate run-time logic to get all bits from firstValue */
- /* through lastValue */
- /* First generate: 0xffff << (firstValue-minValue) */
-
- pas_GenerateDataOperation(opPUSH, 0xffff);
- pas_GenerateStackReference(opLDS, setPtr);
- if (s->minValue) {
- pas_GenerateDataOperation(opPUSH, s->minValue);
- pas_GenerateSimple(opSUB);
- } /* end if */
- pas_GenerateSimple(opSLL);
-
- /* Generate logic to get: */
- /* 0xffff >> ((BITS_IN_INTEGER-1)-(lastValue-minValue)) */
-
- pas_GenerateDataOperation(opPUSH, 0xffff);
- pas_GenerateDataOperation(opPUSH, ((BITS_IN_INTEGER-1) + s->minValue));
- pas_GenerateStackReference(opLDS, tknPtr);
- pas_GenerateSimple(opSUB);
- pas_GenerateSimple(opSRL);
-
- /* Then AND the two values */
-
- pas_GenerateSimple(opAND);
-
- getToken();
- break;
-
- default :
- error(eSET);
- pas_GenerateDataOperation(opPUSH, 0);
- break;
-
- } /* end switch */
- } /* end else */
- break;
-
- default :
- error(eSET);
- pas_GenerateDataOperation(opPUSH, 0);
- break;
-
- } /* end switch */
-
-} /* end getSetElement */
-
-/***************************************************************/
-
-/* Check if this is a ordinal type. This is what is needed, for
- * example, as an argument to ord(), pred(), succ(), or odd().
- * This is the kind of expression we need in a CASE statement
- * as well.
- */
-
-static boolean isOrdinalType(exprType testExprType)
-{
- if ((testExprType == exprInteger) || /* integer value */
- (testExprType == exprChar) || /* character value */
- (testExprType == exprBoolean) || /* boolean(integer) value */
- (testExprType == exprScalar)) /* scalar(integer) value */
- return TRUE;
- else
- return FALSE;
-}
-
-/***************************************************************/
-/* This is a hack to handle calls to system functions that return
- * exprCString pointers that must be converted to exprString
- * records upon assignment.
- */
-
-static boolean isAnyStringType(exprType testExprType)
-{
- if ((testExprType == exprString) ||
- (testExprType == exprStkString) ||
- (testExprType == exprCString))
- return TRUE;
- else
- return FALSE;
-}
-
-static boolean isStringReference (exprType testExprType)
-{
- if ((testExprType == exprString) ||
- (testExprType == exprStkString))
- return TRUE;
- else
- return FALSE;
-}
-
+/*************************************************************** + * pexpr.c + * Integer Expression + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************/ + +/*************************************************************** + * Included Files + ***************************************************************/ + +#include <stdint.h> +#include <stdbool.h> +#include <stdio.h> +#include <string.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "podefs.h" /* general operation codes */ +#include "pfdefs.h" /* floating point operations */ +#include "pxdefs.h" /* library operations */ +#include "pedefs.h" + +#include "keywords.h" +#include "pas.h" +#include "pstm.h" +#include "pexpr.h" +#include "pproc.h" /* for actualParameterList */ +#include "pfunc.h" +#include "pgen.h" /* for pas_Generate*() */ +#include "ptkn.h" +#include "pinsn.h" +#include "perr.h" + +/*************************************************************** + * Private Definitions + ***************************************************************/ + +#define ADDRESS_DEREFERENCE 0x01 +#define ADDRESS_FACTOR 0x02 +#define INDEXED_FACTOR 0x04 +#define VAR_PARM_FACTOR 0x08 + +#define intTrunc(x) ((x) & (~(sINT_SIZE))) + +/*************************************************************** + * Private Type Declarations + ***************************************************************/ + +typedef struct { + uint8_t setType; + bool typeFound; + int16_t minValue; + int16_t maxValue; + STYPE *typePtr; +} setTypeStruct; + +/*************************************************************** + * Private Function Prototypes + ***************************************************************/ + +static exprType simpleExpression (exprType findExprType); +static exprType term (exprType findExprType); +static exprType factor (exprType findExprType); +static exprType complexFactor (void); +static exprType simpleFactor (STYPE *varPtr, uint8_t factorFlags); +static exprType ptrFactor (void); +static exprType complexPtrFactor (void); +static exprType simplePtrFactor (STYPE *varPtr, uint8_t factorFlags); +static exprType functionDesignator(void); +static void setAbstractType (STYPE *sType); +static void getSetFactor (void); +static void getSetElement (setTypeStruct *s); +static bool isOrdinalType (exprType testExprType); +static bool isAnyStringType (exprType testExprType); +static bool isStringReference (exprType testExprType); + +/*************************************************************** + * Private Variables + ***************************************************************/ + + /* The abstract types - SETs, RECORDS, etc - require an exact */ + /* match in type. This variable points to the symbol table */ + /* sTYPE entry associated with the expression. */ + + static STYPE *abstractType; + +/***************************************************************/ +/* Evaluate (boolean) Expression */ + +exprType expression(exprType findExprType, STYPE *typePtr) +{ + uint8_t operation; + uint16_t intOpCode; + uint16_t fpOpCode; + uint16_t strOpCode; + exprType simple1Type; + exprType simple2Type; + + TRACE(lstFile,"[expression]"); + + /* The abstract types - SETs, RECORDS, etc - require an exact */ + /* match in type. Save the symbol table sTYPE entry associated */ + /* with the expression. */ + + if ((typePtr) && (typePtr->sKind != sTYPE)) error(eINVTYPE); + abstractType = typePtr; + + /* FORM <simple expression> [<relational operator> <simple expression>] */ + /* Get the first <simple expression> */ + + simple1Type = simpleExpression(findExprType); + + /* Get the optional <relational operator> which may follow */ + + operation = token; + switch (operation) + { + case tEQ : + intOpCode = opEQU; + fpOpCode = fpEQU; + strOpCode = opEQUZ; + break; + case tNE : + intOpCode = opNEQ; + fpOpCode = fpNEQ; + strOpCode = opNEQZ; + break; + case tLT : + intOpCode = opLT; + fpOpCode = fpLT; + strOpCode = opLTZ; + break; + case tLE : + intOpCode = opLTE; + fpOpCode = fpLTE; + strOpCode = opLTEZ; + break; + case tGT : + intOpCode = opGT; + fpOpCode = fpGT; + strOpCode = opGTZ; + break; + case tGE : + intOpCode = opGTE; + fpOpCode = fpGTE; + strOpCode = opGTEZ; + break; + case tIN : + if ((!abstractType) || + ((abstractType->sParm.t.type != sSCALAR) && + (abstractType->sParm.t.type != sSUBRANGE))) + error(eEXPRTYPE); + else if (abstractType->sParm.t.minValue) + { + pas_GenerateDataOperation(opPUSH, abstractType->sParm.t.minValue); + pas_GenerateSimple(opSUB); + } /* end else if */ + intOpCode = opBIT; + fpOpCode = fpINVLD; + strOpCode = opNOP; + break; + default : + intOpCode = opNOP; + fpOpCode = fpINVLD; + strOpCode = opNOP; + break; + } /* end switch */ + + /* Check if there is a 2nd simple expression needed */ + + if (intOpCode != opNOP) + { + /* Get the second simple expression */ + + getToken(); + simple2Type = simpleExpression(findExprType); + + /* Perform automatic type conversion from INTEGER to REAL + * for integer vs. real comparisons. + */ + + if (simple1Type != simple2Type) + { + /* Handle the case where the 1st argument is REAL and the + * second is INTEGER. */ + + if ((simple1Type == exprReal) && + (simple2Type == exprInteger) && + (fpOpCode != fpINVLD)) + { + fpOpCode |= fpARG2; + simple2Type = exprReal; + } /* end if */ + + /* Handle the case where the 1st argument is Integer and the + * second is REAL. */ + + else if ((simple1Type == exprInteger) && + (simple2Type == exprReal) && + (fpOpCode != fpINVLD)) + { + fpOpCode |= fpARG1; + simple1Type = exprReal; + } /* end else if */ + + /* Allow the case of <scalar type> IN <set type> */ + /* Otherwise, the two terms must agree in type */ + + else if ((operation != tIN) || (simple2Type != exprSet)) + { + error(eEXPRTYPE); + } + } /* end if */ + + /* Generate the comparison */ + + if (simple1Type == exprReal) + { + if (fpOpCode == fpINVLD) + error(eEXPRTYPE); + else + pas_GenerateFpOperation(fpOpCode); + } /* end if */ + else if ((simple1Type == exprString) || (simple1Type == exprString)) + { + if (strOpCode != opNOP) + { + pas_BuiltInFunctionCall(lbSTRCMP); + pas_GenerateSimple(strOpCode); + } + else + { + error(eEXPRTYPE); + } + } + else + { + pas_GenerateSimple(intOpCode); + } + + /* The type resulting from these operations becomes BOOLEAN */ + + simple1Type = exprBoolean; + + } /* end if */ + + /* Verify that the expression is of the requested type. + * The following are okay: + * + * 1. We were told to find any kind of expression + * + * 2. We were told to find a specific kind of expression and + * we found just that type. + * + * 3. We were told to find any kind of ordinal expression and + * we found a ordinal expression. This is what is needed, for + * example, as an argument to ord(), pred(), succ(), or odd(). + * This is the kind of expression we need in a CASE statement + * as well. + * + * 4. We were told to find any kind of string expression and + * we found a string expression. This is a hack to handle + * calls to system functions that return exprCString pointers + * that must be converted to exprString records upon assignment. + * + * 5. We have a hack in the name space. You use a bogus name + * to represent a string reference that has string stack + * allocated with it. For expression processing purposes, + * exprString and exprStkString are the same thing. The + * difference is that we have to clean up the string stack + * for the latter. + * + * Special case: + * + * We will perform automatic conversions to real from integer + * if the requested type is a real expression. + */ + + if ((findExprType != exprUnknown) && /* 1)NOT Any expression */ + + (findExprType != simple1Type) && /* 2)NOT Matched expression */ + + ((findExprType != exprAnyOrdinal) || /* 3)NOT any ordinal type */ + (!isOrdinalType(simple1Type))) && /* OR type is not ordinal */ + + ((findExprType != exprAnyString) || /* 4)NOT any string type */ + (!isAnyStringType(simple1Type))) && /* OR type is not string */ + + ((findExprType != exprString) || /* 5)Not looking for string ref */ + (!isStringReference(simple1Type)))) /* OR type is not string ref */ + { + /* Automatic conversions from INTEGER to REAL will be performed */ + + if ((findExprType == exprReal) && (simple1Type == exprInteger)) + { + pas_GenerateFpOperation(fpFLOAT); + simple1Type = exprReal; + } + + /* Any other type mismatch is an error */ + + else + { + error(eEXPRTYPE); + } + } /* end if */ + + return simple1Type; + +} /* end expression */ + +/***************************************************************/ +/* Provide VAR parameter assignments */ + +exprType varParm (exprType varExprType, STYPE *typePtr) +{ + exprType factorType; + + /* The abstract types - SETs, RECORDS, etc - require an exact + * match in type. Save the symbol table sTYPE entry associated + * with the expression. + */ + + if ((typePtr) && (typePtr->sKind != sTYPE)) error(eINVTYPE); + abstractType = typePtr; + + /* This function is really just an interface to the + * static function ptrFactor with some extra error + * checking. + */ + + factorType = ptrFactor(); + if ((varExprType != exprUnknown) && (factorType != varExprType)) + error(eINVVARPARM); + + return factorType; + +} /* end varParm */ + +/**********************************************************************/ +/* Process Array Index */ +void arrayIndex (int32_t size) +{ + TRACE(lstFile,"[arrayIndex]"); + + /* FORM: [<integer expression>] */ + getToken(); + if (token != '[') error (eLBRACKET); + else { + + /* Evaluate index expression */ + /* FIX ME: Need to allow any scalar type */ + getToken(); + expression(exprInteger, NULL); + + /* Correct for size of array element */ + if (size > 1) { + pas_GenerateDataOperation(opPUSH, size); + pas_GenerateSimple(opMUL); + } /* end if */ + + /* Verify right bracket */ + if (token != ']') error (eRBRACKET); + else getToken(); + + } /* end else */ + +} /* end arrayIndex */ + +/*************************************************************************/ +/* Determine the expression type associated with a pointer to a type */ +/* symbol */ + +exprType getExprType(STYPE *sType) +{ + exprType factorType = sINT; + + TRACE(lstFile,"[getExprType]"); + + if ((sType) && (sType->sKind == sTYPE)) + { + switch (sType->sParm.t.type) + { + case sINT : + factorType = exprInteger; + break; + case sBOOLEAN : + factorType = exprBoolean; + break; + case sCHAR : + factorType = exprChar; + break; + case sREAL : + factorType = exprReal; + break; + case sSCALAR : + factorType = exprScalar; + break; + case sSTRING : + case sRSTRING : + factorType = exprString; + break; + case sSUBRANGE : + switch (sType->sParm.t.subType) + { + case sINT : + factorType = exprInteger; + break; + case sCHAR : + factorType = exprChar; + break; + case sSCALAR : + factorType = exprScalar; + break; + default : + error(eSUBRANGETYPE); + break; + } /* end switch */ + break; + case sPOINTER : + sType = sType->sParm.t.parent; + if (sType) + { + switch (sType->sKind) + { + case sINT : + factorType = exprIntegerPtr; + break; + case sBOOLEAN : + factorType = exprBooleanPtr; + break; + case sCHAR : + factorType = exprCharPtr; + break; + case sREAL : + factorType = exprRealPtr; + break; + case sSCALAR : + factorType = exprScalarPtr; + break; + default : + error(eINVTYPE); + break; + } /* end switch */ + } /* end if */ + break; + default : + error(eINVTYPE); + break; + } /* end switch */ + } /* end if */ + + return factorType; + +} /* end getExprType */ + +/***************************************************************/ +/* Process Simple Expression */ + +static exprType simpleExpression(exprType findExprType) +{ + int16_t operation = '+'; + uint16_t arg8FpBits; + exprType term1Type; + exprType term2Type; + + TRACE(lstFile,"[simpleExpression]"); + + /* FORM: [+|-] <term> [{+|-} <term> [{+|-} <term> [...]]] */ + /* get +/- unary operation */ + + if ((token == '+') || (token == '-')) + { + operation = token; + getToken(); + } /* end if */ + + /* Process first (non-optional) term and apply unary operation */ + + term1Type = term(findExprType); + if (operation == '-') + { + if (term1Type == exprInteger) + pas_GenerateSimple(opNEG); + else if (term1Type == exprReal) + pas_GenerateFpOperation(fpNEG); + else + error(eTERMTYPE); + } /* end if */ + + /* Process subsequent (optional) terms and binary operations */ + + for (;;) + { + /* Check for binary operator */ + + if ((token == '+') || (token == '-') || (token == tOR)) + operation = token; + else + break; + + /* Special case for string types. So far, we have parsed + * '<string> +' At this point, it is safe to assume we + * going to modified string. So, if the string has not + * been copied to the string stack, we will have to do that + * now. + */ + + if ((term1Type == exprString) && (operation == '+')) + { + /* Duplicate the string on the string stack. And + * change the expression type to reflect this. + */ + + pas_BuiltInFunctionCall(lbMKSTKSTR); + term1Type = exprStkString; + } + + /* If we are going to add something to a char, then the + * result must be a string. We will similarly have to + * convert the character to a string. + */ + + else if ((term1Type == exprChar) && (operation == '+')) + { + /* Duplicate the string on the string stack. And + * change the expression type to reflect this. + */ + + pas_BuiltInFunctionCall(lbMKSTKC); + term1Type = exprStkString; + } + + /* Get the 2nd term */ + + getToken(); + term2Type = term(findExprType); + + /* Before generating the operation, verify that the types match. + * Perform automatic type conversion from INTEGER to REAL as + * necessary. + */ + + arg8FpBits = 0; + + /* Skip over string types. These will be handled below */ + + if (!isStringReference(term1Type)) + { + /* Handle the case where the type of the terms differ. */ + + if (term1Type != term2Type) + { + /* Handle the case where the 1st argument is REAL and the + * second is INTEGER. */ + + if ((term1Type == exprReal) && (term2Type == exprInteger)) + { + arg8FpBits = fpARG2; + term2Type = exprReal; + } /* end if */ + + /* Handle the case where the 1st argument is Integer and the + * second is REAL. */ + + else if ((term1Type == exprInteger) && (term2Type == exprReal)) + { + arg8FpBits = fpARG1; + term1Type = exprReal; + } /* end if */ + + /* Otherwise, the two terms must agree in type */ + + else + { + error(eTERMTYPE); + } + } /* end if */ + + /* We do not perform conversions for the cases where the two + * terms agree in type. There is only one interesting case: + * When the expected expression is real and both arguments are + * integer. Since addition an subtraction are exact, it would, + * in general, be more efficient to perform the conversion + * AFTER the operation (at the the risk of possible overflow + * conditions due to the limited range of integers). + */ + } + + /* Generate code to perform the selected binary operation */ + + switch (operation) + { + case '+' : + switch (term1Type) + { + /* Integer addition */ + + case exprInteger : + pas_GenerateSimple(opADD); + break; + + /* Floating point addition */ + + case exprReal : + pas_GenerateFpOperation(fpADD | arg8FpBits); + break; + + /* Set 'addition' */ + + case exprSet : + pas_GenerateSimple(opOR); + break; + + /* Handle the special cases where '+' indicates that we are + * concatenating a string or a character to the end of a + * string. Note that these operations can only be performed + * on stack copies of the strings. Logic above should have + * made the conversion for the case of exprString. + */ + + case exprStkString : + if ((term2Type == exprString) || (term2Type == exprStkString)) + { + /* We are concatenating one string with another.*/ + + pas_BuiltInFunctionCall(lbSTRCAT); + } + else if (term2Type == exprChar) + { + /* We are concatenating a character to the end of a string */ + + pas_BuiltInFunctionCall(lbSTRCATC); + } + else + { + error(eTERMTYPE); + } + break; + + /* Otherwise, the '+' operation is not permitted */ + + default : + error(eTERMTYPE); + break; + } + break; + + case '-' : + /* Integer subtraction */ + + if (term1Type == exprInteger) + pas_GenerateSimple(opSUB); + + /* Floating point subtraction */ + + else if (term1Type == exprReal) + pas_GenerateFpOperation(fpSUB | arg8FpBits); + + /* Set 'subtraction' */ + + else if (term1Type == exprSet) + { + pas_GenerateSimple(opNOT); + pas_GenerateSimple(opAND); + } /* end else if */ + + /* Otherwise, the '-' operation is not permitted */ + + else + error(eTERMTYPE); + break; + + case tOR : + /* Integer/boolean 'OR' */ + + if ((term1Type == exprInteger) || (term1Type == exprBoolean)) + pas_GenerateSimple(opOR); + + /* Otherwise, the 'OR' operation is not permitted */ + + else + error(eTERMTYPE); + break; + + } /* end switch */ + } /* end for */ + + return term1Type; + +} /* end simpleExpression */ + +/***************************************************************/ +/* Evaluate a TERM */ + +static exprType term(exprType findExprType) +{ + uint8_t operation; + uint16_t arg8FpBits; + exprType factor1Type; + exprType factor2Type; + + TRACE(lstFile,"[term]"); + + /* FORM: <factor> [<operator> <factor>[<operator><factor>[...]]] */ + + factor1Type = factor(findExprType); + for (;;) { + + /* Check for binary operator */ + + if ((token == tMUL) || (token == tDIV) || + (token == tFDIV) || (token == tMOD) || + (token == tAND) || (token == tSHL) || + (token == tSHR)) + operation = token; + else + break; + + /* Get the next factor */ + + getToken(); + factor2Type = factor(findExprType); + + /* Before generating the operation, verify that the types match. + * Perform automatic type conversion from INTEGER to REAL as + * necessary. + */ + + arg8FpBits = 0; + + /* Handle the case where the type of the terms differ. */ + + if (factor1Type != factor2Type) + { + /* Handle the case where the 1st argument is REAL and the + * second is INTEGER. */ + + if ((factor1Type == exprReal) && (factor2Type == exprInteger)) + { + arg8FpBits = fpARG2; + } /* end if */ + + /* Handle the case where the 1st argument is Integer and the + * second is REAL. */ + + else if ((factor1Type == exprInteger) && (factor2Type == exprReal)) + { + arg8FpBits = fpARG1; + factor1Type = exprReal; + } /* end if */ + + /* Otherwise, the two factors must agree in type */ + + else + { + error(eFACTORTYPE); + } + } /* end if */ + + /* Handle the cases for conversions when the two string + * type are the same type. + */ + + else + { + /* There is only one interesting case: When the + * expected expression is real and both arguments are + * integer. In this case, for example, 1/2 must yield + * 0.5, not 0. + */ + + if ((factor1Type == exprInteger) && (findExprType == exprReal)) + { + /* However, we will perform this conversin only for the + * arithmetic operations: tMUL, tDIV/tFDIV, and tMOD. + * The logical operations must be performed on integer + * types with the result converted to a real type afterward. + */ + + if ((operation == tMUL) || (operation == tDIV) || + (operation == tFDIV) || (operation == tMOD)) + { + /* Perform the conversion of both terms */ + + arg8FpBits = fpARG1 | fpARG2; + factor1Type = exprReal; + + /* We will also have to switch the operation in + * the case of tDIV: We'll have to used tFDIV. + */ + + if (operation == tDIV) operation = tFDIV; + } + } + } + + /* Generate code to perform the selected binary operation */ + + switch (operation) + { + case tMUL : + if (factor1Type == exprInteger) + pas_GenerateSimple(opMUL); + else if (factor1Type == exprReal) + pas_GenerateFpOperation(fpMUL | arg8FpBits); + else if (factor1Type == exprSet) + pas_GenerateSimple(opAND); + else + error(eFACTORTYPE); + break; + + case tDIV : + if (factor1Type == exprInteger) + pas_GenerateSimple(opDIV); + else + error(eFACTORTYPE); + break; + + case tFDIV : + if (factor1Type == exprReal) + pas_GenerateFpOperation(fpDIV | arg8FpBits); + else + error(eFACTORTYPE); + break; + + case tMOD : + if (factor1Type == exprInteger) + pas_GenerateSimple(opMOD); + else if (factor1Type == exprReal) + pas_GenerateFpOperation(fpMOD | arg8FpBits); + else + error(eFACTORTYPE); + break; + + case tAND : + if ((factor1Type == exprInteger) || (factor1Type == exprBoolean)) + pas_GenerateSimple(opAND); + else + error(eFACTORTYPE); + break; + + case tSHL : + if (factor1Type == exprInteger) + pas_GenerateSimple(opSLL); + else + error(eFACTORTYPE); + break; + + case tSHR : + if (factor1Type == exprInteger) + pas_GenerateSimple(opSRA); + else + error(eFACTORTYPE); + break; + + } /* end switch */ + } /* end for */ + + return factor1Type; + +} /* end term */ + +/***************************************************************/ +/* Process a FACTOR */ + +static exprType factor(exprType findExprType) +{ + exprType factorType = exprUnknown; + + TRACE(lstFile,"[factor]"); + + /* Process by token type */ + + switch (token) + { + /* User defined tokens */ + + case tIDENT : + error(eUNDEFSYM); + stringSP = tkn_strt; + factorType = exprUnknown; + break; + + /* Constant factors */ + + case tINT_CONST : + pas_GenerateDataOperation(opPUSH, tknInt); + getToken(); + factorType = exprInteger; + break; + + case tBOOLEAN_CONST : + pas_GenerateDataOperation(opPUSH, tknInt); + getToken(); + factorType = exprBoolean; + break; + + case tCHAR_CONST : + pas_GenerateDataOperation(opPUSH, tknInt); + getToken(); + factorType = exprChar; + break; + + case tREAL_CONST : + pas_GenerateDataOperation(opPUSH, (int32_t)*(((uint16_t*)&tknReal)+0)); + pas_GenerateDataOperation(opPUSH, (int32_t)*(((uint16_t*)&tknReal)+1)); + pas_GenerateDataOperation(opPUSH, (int32_t)*(((uint16_t*)&tknReal)+2)); + pas_GenerateDataOperation(opPUSH, (int32_t)*(((uint16_t*)&tknReal)+3)); + getToken(); + factorType = exprReal; + break; + + case sSCALAR_OBJECT : + if (abstractType) + { + if (tknPtr->sParm.c.parent != abstractType) error(eSCALARTYPE); + } /* end if */ + else + abstractType = tknPtr->sParm.c.parent; + + pas_GenerateDataOperation(opPUSH, tknPtr->sParm.c.val.i); + getToken(); + factorType = exprScalar; + break; + + /* Simple Factors */ + + case sINT : + pas_GenerateStackReference(opLDS, tknPtr); + getToken(); + factorType = exprInteger; + break; + + case sBOOLEAN : + pas_GenerateStackReference(opLDS, tknPtr); + getToken(); + factorType = exprBoolean; + break; + + case sCHAR : + pas_GenerateStackReference(opLDSB, tknPtr); + getToken(); + factorType = exprChar; + break; + + case sREAL : + pas_GenerateDataSize(sREAL_SIZE); + pas_GenerateStackReference(opLDSM, tknPtr); + getToken(); + factorType = exprReal; + break; + + /* Strings -- constant and variable */ + + case tSTRING_CONST : + { + /* Final stack representation is: + * TOS(0) : size in bytes + * TOS(1) : pointer to string + * + * Add the string to the RO data section of the output + * and get the offset to the string location. + */ + + uint32_t offset = poffAddRoDataString(poffHandle, tkn_strt); + + /* Get the offset then size of the string on the stack */ + + pas_GenerateDataOperation(opLAC, offset); + pas_GenerateDataOperation(opPUSH, strlen(tkn_strt)); + + /* Release the tokenized string */ + + stringSP = tkn_strt; + getToken(); + factorType = exprString; + } + break; + + case sSTRING_CONST : + /* Final stack representation is: + * TOS(0) : size in bytes + * TOS(1) : pointer to string + */ + + pas_GenerateDataOperation(opLAC, tknPtr->sParm.s.offset); + pas_GenerateDataOperation(opPUSH, tknPtr->sParm.s.size); + getToken(); + factorType = exprString; + break; + + case sSTRING : + /* Final stack representation is: + * TOS(0) = size in bytes + * TOS(1) = pointer to string data + */ + + pas_GenerateDataOperation(opPUSH, sSTRING_HDR_SIZE); + pas_GenerateStackReference(opLASX, tknPtr); + pas_GenerateStackReference(opLDSH, tknPtr); + + getToken(); + factorType = exprString; + break; + + case sRSTRING : + /* Final stack representation is: + * TOS(0) : size in bytes + * TOS(1) : pointer to string data + * + * We get that by just cloning the reference on the top of the stack + */ + pas_GenerateDataSize(tknPtr->sParm.v.size); + pas_GenerateStackReference(opLDSM, tknPtr); + getToken(); + factorType = exprString; + break; + + case sSCALAR : + if (abstractType) + { + if (tknPtr->sParm.v.parent != abstractType) error(eSCALARTYPE); + } /* end if */ + else + abstractType = tknPtr->sParm.v.parent; + + pas_GenerateStackReference(opLDS, tknPtr); + getToken(); + factorType = exprScalar; + break; + + case sSET_OF : + /* If an abstractType is specified then it should either be the */ + /* same SET OF <object> -OR- the same <object> */ + + if (abstractType) + { + if ((tknPtr->sParm.v.parent != abstractType) && + (tknPtr->sParm.v.parent->sParm.t.parent != abstractType)) + error(eSET); + } /* end if */ + else + abstractType = tknPtr->sParm.v.parent; + + pas_GenerateStackReference(opLDS, tknPtr); + getToken(); + factorType = exprSet; + break; + + /* SET factors */ + + case '[' : /* Set constant */ + getToken(); + getSetFactor(); + if (token != ']') error(eRBRACKET); + else getToken(); + factorType = exprSet; + break; + + /* Complex factors */ + + case sSUBRANGE : + case sRECORD : + case sRECORD_OBJECT : + case sVAR_PARM : + case sPOINTER : + case sARRAY : + factorType = complexFactor(); + break; + + /* Functions */ + + case sFUNC : + factorType = functionDesignator(); + break; + + /* Nested Expression */ + + case '(' : + getToken(); + factorType = expression(exprUnknown, abstractType); + if (token == ')') getToken(); + else error (eRPAREN); + break; + + /* Address references */ + + case '^' : + getToken(); + factorType = ptrFactor(); + break; + + /* Highest Priority Operators */ + + case tNOT: + getToken(); + factorType = factor(findExprType); + if ((factorType != exprInteger) && (factorType != exprBoolean)) + error(eFACTORTYPE); + pas_GenerateSimple(opNOT); + break; + + /* Built-in function? */ + + case tFUNC: + factorType = builtInFunction(); + break; + + /* Hmmm... Try the standard functions */ + + default : + error(eINVFACTOR); + break; + + } /* end switch */ + + return factorType; + +} /* end factor */ + +/***********************************************************************/ +/* Process a complex factor */ + +static exprType complexFactor(void) +{ + STYPE symbolSave; + + TRACE(lstFile,"[complexFactor]"); + + /* First, make a copy of the symbol table entry because the call to */ + /* simpleFactor() will modify it. */ + + symbolSave = *tknPtr; + getToken(); + + /* Then process the complex factor until it is reduced to a simple */ + /* factor (like int, char, etc.) */ + + return simpleFactor(&symbolSave, 0); + +} /* end complexFactor */ + +/***********************************************************************/ +/* Process a complex factor (recursively) until it becomes a */ +/* simple factor */ + +static exprType simpleFactor(STYPE *varPtr, uint8_t factorFlags) +{ + STYPE *typePtr; + exprType factorType; + + TRACE(lstFile,"[simpleFactor]"); + + /* Process according to the current variable sKind */ + + typePtr = varPtr->sParm.v.parent; + switch (varPtr->sKind) + { + /* Check if we have reduced the complex factor to a simple factor */ + + case sINT : + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_GenerateSimple(opLDI); + factorType = exprInteger; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprIntegerPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprInteger; + } /* end else */ + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateSimple(opLDI); + factorType = exprInteger; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprIntegerPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprInteger; + } /* end else */ + } /* end else */ + break; + case sCHAR : + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_GenerateSimple(opLDIB); + factorType = exprChar; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprCharPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDSXB, varPtr); + factorType = exprChar; + } /* end else */ + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateSimple(opLDIB); + factorType = exprChar; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprCharPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDSB, varPtr); + factorType = exprChar; + } /* end else */ + } /* end else */ + break; + case sBOOLEAN : + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_GenerateSimple(opLDI); + factorType = exprBoolean; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprBooleanPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprBoolean; + } /* end else */ + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateSimple(opLDI); + factorType = exprBoolean; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprBooleanPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprBoolean; + } /* end else */ + } /* end else */ + break; + case sREAL : + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_GenerateDataSize(varPtr->sParm.v.size); + pas_GenerateSimple(opLDIM); + factorType = exprReal; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprRealPtr; + } /* end else if */ + else + { + pas_GenerateDataSize(varPtr->sParm.v.size); + pas_GenerateStackReference(opLDSXM, varPtr); + factorType = exprReal; + } /* end else */ + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateDataSize(varPtr->sParm.v.size); + pas_GenerateSimple(opLDIM); + factorType = exprReal; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprRealPtr; + } /* end else if */ + else + { + pas_GenerateDataSize(varPtr->sParm.v.size); + pas_GenerateStackReference(opLDSM, varPtr); + factorType = exprReal; + } /* end else */ + } /* end else */ + break; + case sSCALAR : + if (!abstractType) + abstractType = typePtr; + else if (typePtr != abstractType) + error(eSCALARTYPE); + + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_GenerateSimple(opLDI); + factorType = exprScalar; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprScalarPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprScalar; + } /* end else */ + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateSimple(opLDI); + factorType = exprScalar; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprScalarPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprScalar; + } /* end else */ + } /* end else */ + break; + case sSET_OF : + if (!abstractType) + abstractType = typePtr; + else if ((typePtr != abstractType) && + (typePtr->sParm.v.parent != abstractType)) + error(eSCALARTYPE); + + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_GenerateSimple(opLDI); + factorType = exprSet; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprSetPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDSX, varPtr); + factorType = exprSet; + } /* end else */ + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateSimple(opLDI); + factorType = exprSet; + } /* end if */ + else if ((factorFlags & ADDRESS_FACTOR) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprSetPtr; + } /* end else if */ + else + { + pas_GenerateStackReference(opLDS, varPtr); + factorType = exprSet; + } /* end else */ + } /* end else */ + break; + + /* NOPE... recurse until it becomes a simple factor */ + + case sSUBRANGE : + if (!abstractType) abstractType = typePtr; + varPtr->sKind = typePtr->sParm.t.subType; + factorType = simpleFactor(varPtr, factorFlags); + break; + + case sRECORD : + /* Check if this is a pointer to a record */ + + if ((factorFlags & ADDRESS_FACTOR) != 0) + { + if (token == '.') error(ePOINTERTYPE); + + if ((factorFlags & INDEXED_FACTOR) != 0) + pas_GenerateStackReference(opLDSX, varPtr); + else + pas_GenerateStackReference(opLDS, varPtr); + + factorType = exprRecordPtr; + } /* end if */ + + /* Verify that a period separates the RECORD identifier from the */ + /* record field identifier */ + + else if (token == '.') + { + if (((factorFlags & ADDRESS_DEREFERENCE) != 0) && + ((factorFlags & VAR_PARM_FACTOR) == 0)) + error(ePOINTERTYPE); + + /* Skip over the period. */ + + getToken(); + + /* Verify that a field identifier associated with this record */ + /* follows the period. */ + + if ((token != sRECORD_OBJECT) || + (tknPtr->sParm.r.record != typePtr)) + { + error(eRECORDOBJECT); + factorType = exprInteger; + } /* end if */ + else + { + /* Modify the variable so that it has the characteristics of the */ + /* the field but with level and offset associated with the record */ + + typePtr = tknPtr->sParm.r.parent; + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sParm.v.parent = typePtr; + + /* Special case: The record is a VAR parameter. */ + + if (factorFlags == (INDEXED_FACTOR | ADDRESS_DEREFERENCE | VAR_PARM_FACTOR)) + { + pas_GenerateDataOperation(opPUSH, tknPtr->sParm.r.offset); + pas_GenerateSimple(opADD); + } /* end if */ + else + varPtr->sParm.v.offset += tknPtr->sParm.r.offset; + + getToken(); + factorType = simpleFactor(varPtr, factorFlags); + } /* end else */ + } /* end else if */ + + /* A RECORD name name be a valid factor -- as the input */ + /* parameter of a function or in an assignment */ + + else if (abstractType == typePtr) + { + /* Special case: The record is a VAR parameter. */ + + if (factorFlags == (INDEXED_FACTOR | ADDRESS_DEREFERENCE | VAR_PARM_FACTOR)) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateSimple(opADD); + pas_GenerateDataSize(varPtr->sParm.v.size); + pas_GenerateSimple(opLDIM); + } /* end if */ + else + { + pas_GenerateDataSize(varPtr->sParm.v.size); + pas_GenerateStackReference(opLDSM, varPtr); + } /* end else */ + + factorType = exprRecord; + } /* end else if */ + else error(ePERIOD); + break; + + case sRECORD_OBJECT : + /* NOTE: This must have been preceeded with a WITH statement */ + /* defining the RECORD type */ + + if (!withRecord.parent) + error(eINVTYPE); + else if ((factorFlags && (ADDRESS_DEREFERENCE | ADDRESS_FACTOR)) != 0) + error(ePOINTERTYPE); + else if ((factorFlags && INDEXED_FACTOR) != 0) + error(eARRAYTYPE); + + /* Verify that a field identifier is associated with the RECORD */ + /* specified by the WITH statement. */ + + else if (varPtr->sParm.r.record != withRecord.parent) + error(eRECORDOBJECT); + else + { + int16_t tempOffset; + + /* Now there are two cases to consider: (1) the withRecord is a */ + /* pointer to a RECORD, or (2) the withRecord is the RECOR itself */ + + if (withRecord.pointer) + { + /* If the pointer is really a VAR parameter, then other syntax */ + /* rules will apply */ + + if (withRecord.varParm) + factorFlags |= (INDEXED_FACTOR | ADDRESS_DEREFERENCE | VAR_PARM_FACTOR); + else + factorFlags |= (INDEXED_FACTOR | ADDRESS_DEREFERENCE); + + pas_GenerateDataOperation(opPUSH, (varPtr->sParm.r.offset + withRecord.index)); + tempOffset = withRecord.offset; + } /* end if */ + else + { + tempOffset = varPtr->sParm.r.offset + withRecord.offset; + } /* end else */ + + /* Modify the variable so that it has the characteristics of the */ + /* the field but with level and offset associated with the record */ + /* NOTE: We have to be careful here because the structure */ + /* associated with sRECORD_OBJECT is not the same as for */ + /* variables! */ + + typePtr = varPtr->sParm.r.parent; + tempOffset = varPtr->sParm.r.offset; + + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sLevel = withRecord.level; + varPtr->sParm.v.size = typePtr->sParm.t.asize; + varPtr->sParm.v.offset = tempOffset + withRecord.offset; + varPtr->sParm.v.parent = typePtr; + + factorType = simpleFactor(varPtr, factorFlags); + } /* end else */ + break; + + case sPOINTER : + if (token == '^') + { + getToken(); + factorFlags |= ADDRESS_DEREFERENCE; + } /* end if */ + else + factorFlags |= ADDRESS_FACTOR; + + varPtr->sKind = typePtr->sParm.t.type; + factorType = simpleFactor(varPtr, factorFlags); + break; + + case sVAR_PARM : + if (factorFlags != 0) error(eVARPARMTYPE); + factorFlags |= (ADDRESS_DEREFERENCE | VAR_PARM_FACTOR); + + varPtr->sKind = typePtr->sParm.t.type; + factorType = simpleFactor(varPtr, factorFlags); + break; + + case sARRAY : + if (factorFlags != 0) error(eARRAYTYPE); + + if (token == '[') + { + factorFlags |= INDEXED_FACTOR; + arrayIndex(typePtr->sParm.t.asize); + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sParm.v.size = typePtr->sParm.t.asize; + factorType = simpleFactor(varPtr, factorFlags); + } /* end if */ + + /* An ARRAY name name be a valid factor -- only as the input */ + /* parameter of a function */ + + else if (abstractType == varPtr) + { + pas_GenerateDataSize(varPtr->sParm.v.size); + pas_GenerateStackReference(opLDSM, varPtr); + factorType = exprArray; + } /* end else if */ + else error(eLBRACKET); + break; + + default : + error(eINVTYPE); + factorType = exprInteger; + break; + } /* end switch */ + + return factorType; + +} /* end simpleFactor */ + +/**********************************************************************/ +/* Process a factor of the for ^variable OR a VAR parameter (where the + * ^ is implicit. */ + +static exprType ptrFactor(void) +{ + exprType factorType; + + TRACE(lstFile,"[ptrFactor]"); + + /* Process by token type */ + + switch (token) { + + /* Pointers to simple types */ + + case sINT : + pas_GenerateStackReference(opLAS, tknPtr); + getToken(); + factorType = exprIntegerPtr; + break; + case sBOOLEAN : + pas_GenerateStackReference(opLAS, tknPtr); + getToken(); + factorType = exprBooleanPtr; + break; + case sCHAR : + pas_GenerateStackReference(opLAS, tknPtr); + getToken(); + factorType = exprCharPtr; + break; + case sREAL : + pas_GenerateStackReference(opLAS, tknPtr); + getToken(); + factorType = exprRealPtr; + break; + case sSCALAR : + if (abstractType) + { + if (tknPtr->sParm.v.parent != abstractType) error(eSCALARTYPE); + } /* end if */ + else + abstractType = tknPtr->sParm.v.parent; + + pas_GenerateStackReference(opLAS, tknPtr); + getToken(); + factorType = exprScalarPtr; + break; + case sSET_OF : + /* If an abstractType is specified then it should either be the */ + /* same SET OF <object> -OR- the same <object> */ + + if (abstractType) { + if ((tknPtr->sParm.v.parent != abstractType) + && (tknPtr->sParm.v.parent->sParm.t.parent != abstractType)) + error(eSET); + } /* end if */ + else + abstractType = tknPtr->sParm.v.parent; + pas_GenerateStackReference(opLAS, tknPtr); + getToken(); + factorType = exprSetPtr; + break; + + /* Complex factors */ + + case sSUBRANGE : + case sRECORD : + case sRECORD_OBJECT : + case sVAR_PARM : + case sPOINTER : + case sARRAY : + factorType = complexPtrFactor(); + break; + + /* References to address of a pointer */ + + case '^' : + error(eNOTYET); + getToken(); + factorType = ptrFactor(); + break; + + case '(' : + getToken(); + factorType = ptrFactor(); + if (token != ')') error (eRPAREN); + else getToken(); + break; + + default : + error(ePTRADR); + break; + + } /* end switch */ + + return factorType; + +} /* end ptrFactor */ + +/***********************************************************************/ +/* Process a complex factor */ + +static exprType complexPtrFactor(void) +{ + STYPE symbolSave; + + TRACE(lstFile,"[complexPtrFactor]"); + + /* First, make a copy of the symbol table entry because the call to */ + /* simplePtrFactor() will modify it. */ + + symbolSave = *tknPtr; + getToken(); + + /* Then process the complex factor until it is reduced to a simple */ + /* factor (like int, char, etc.) */ + + return simplePtrFactor(&symbolSave, 0); + +} /* end complexPtrFactor */ + +/***********************************************************************/ +/* Process a complex factor (recursively) until it becomes a */ +/* simple simple */ + +static exprType simplePtrFactor(STYPE *varPtr, uint8_t factorFlags) +{ + STYPE *typePtr; + exprType factorType; + + TRACE(lstFile,"[simplePtrFactor]"); + + /* Process according to the current variable sKind */ + + typePtr = varPtr->sParm.v.parent; + switch (varPtr->sKind) + { + /* Check if we have reduced the complex factor to a simple factor */ + case sINT : + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLASX, varPtr); + } /* end else */ + factorType = exprIntegerPtr; + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLAS, varPtr); + } /* end else */ + factorType = exprIntegerPtr; + } /* end else */ + break; + case sCHAR : + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLASX, varPtr); + } /* end else */ + factorType = exprCharPtr; + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLAS, varPtr); + } /* end else */ + factorType = exprCharPtr; + } /* end else */ + break; + case sBOOLEAN : + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLASX, varPtr); + } /* end else */ + factorType = exprBooleanPtr; + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLAS, varPtr); + } /* end else */ + factorType = exprBooleanPtr; + } /* end else */ + break; + case sREAL : + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLASX, varPtr); + } /* end else */ + factorType = exprRealPtr; + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLAS, varPtr); + } /* end else */ + factorType = exprRealPtr; + } /* end else */ + break; + case sSCALAR : + if (!abstractType) + abstractType = typePtr; + else if (typePtr != abstractType) + error(eSCALARTYPE); + + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLASX, varPtr); + } /* end else */ + factorType = exprScalarPtr; + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLAS, varPtr); + } /* end else */ + factorType = exprScalarPtr; + } /* end else */ + break; + case sSET_OF : + if (!abstractType) + abstractType = typePtr; + else if ((typePtr != abstractType) && + (typePtr->sParm.v.parent != abstractType)) + error(eSCALARTYPE); + + if ((factorFlags & INDEXED_FACTOR) != 0) + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLASX, varPtr); + } /* end else */ + factorType = exprSetPtr; + } /* end if */ + else + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + } /* end if */ + else + { + pas_GenerateStackReference(opLAS, varPtr); + } /* end else */ + factorType = exprSetPtr; + } /* end else */ + break; + + /* NOPE... recurse until it becomes a simple factor */ + + case sSUBRANGE : + if (!abstractType) abstractType = typePtr; + varPtr->sKind = typePtr->sParm.t.subType; + factorType = simplePtrFactor(varPtr, factorFlags); + break; + + case sRECORD : + /* Check if this is a pointer to a record */ + + if (token != '.') + { + if ((factorFlags & ADDRESS_DEREFERENCE) != 0) + error(ePOINTERTYPE); + + if ((factorFlags & INDEXED_FACTOR) != 0) + pas_GenerateStackReference(opLASX, varPtr); + else + pas_GenerateStackReference(opLAS, varPtr); + + factorType = exprRecordPtr; + } /* end if */ + else + { + /* Verify that a period separates the RECORD identifier from the + * record field identifier + */ + + if (token != '.') error(ePERIOD); + else getToken(); + + /* Verify that a field identifier associated with this record + * follows the period. + */ + + if ((token != sRECORD_OBJECT) || + (tknPtr->sParm.r.record != typePtr)) + { + error(eRECORDOBJECT); + factorType = exprInteger; + } /* end if */ + else + { + /* Modify the variable so that it has the characteristics + * of the field but with level and offset associated with + * the record + */ + + typePtr = tknPtr->sParm.r.parent; + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sParm.v.offset += tknPtr->sParm.r.offset; + varPtr->sParm.v.parent = typePtr; + + getToken(); + factorType = simplePtrFactor(varPtr, factorFlags); + + } /* end else */ + } /* end else */ + break; + + case sRECORD_OBJECT : + /* NOTE: This must have been preceeded with a WITH statement + * defining the RECORD type + */ + + if (!withRecord.parent) + error(eINVTYPE); + else if ((factorFlags && ADDRESS_DEREFERENCE) != 0) + error(ePOINTERTYPE); + else if ((factorFlags && INDEXED_FACTOR) != 0) + error(eARRAYTYPE); + + /* Verify that a field identifier is associated with the RECORD + * specified by the WITH statement. + */ + + else if (varPtr->sParm.r.record != withRecord.parent) + error(eRECORDOBJECT); + else + { + int16_t tempOffset; + + /* Now there are two cases to consider: (1) the withRecord is a + * pointer to a RECORD, or (2) the withRecord is the RECOR itself + */ + + if (withRecord.pointer) + { + pas_GenerateDataOperation(opPUSH, (varPtr->sParm.r.offset + withRecord.index)); + factorFlags |= (INDEXED_FACTOR | ADDRESS_DEREFERENCE); + tempOffset = withRecord.offset; + } /* end if */ + else + { + tempOffset = varPtr->sParm.r.offset + withRecord.offset; + } /* end else */ + + /* Modify the variable so that it has the characteristics of the + * the field but with level and offset associated with the record + * NOTE: We have to be careful here because the structure + * associated with sRECORD_OBJECT is not the same as for + * variables! + */ + + typePtr = varPtr->sParm.r.parent; + tempOffset = varPtr->sParm.r.offset; + + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sLevel = withRecord.level; + varPtr->sParm.v.size = typePtr->sParm.t.asize; + varPtr->sParm.v.offset = tempOffset + withRecord.offset; + varPtr->sParm.v.parent = typePtr; + + factorType = simplePtrFactor(varPtr, factorFlags); + } /* end else */ + break; + + case sPOINTER : + if (token == '^') error(ePTRADR); + else getToken(); + + factorFlags |= ADDRESS_DEREFERENCE; + varPtr->sKind = typePtr->sParm.t.type; + factorType = simplePtrFactor(varPtr, factorFlags); + break; + + case sVAR_PARM : + if (factorFlags != 0) error(eVARPARMTYPE); + factorFlags |= ADDRESS_DEREFERENCE; + + varPtr->sKind = typePtr->sParm.t.type; + factorType = simplePtrFactor(varPtr, factorFlags); + break; + + case sARRAY : + if (factorFlags != 0) error(eARRAYTYPE); + if (token == '[') + { + factorFlags |= INDEXED_FACTOR; + + arrayIndex(typePtr->sParm.t.asize); + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sParm.v.size = typePtr->sParm.t.asize; + factorType = simplePtrFactor(varPtr, factorFlags); + } /* end if */ + else + { + pas_GenerateStackReference(opLAS, varPtr); + factorType = exprArrayPtr; + } /* end else */ + break; + + default : + error(eINVTYPE); + factorType = exprInteger; + break; + + } /* end switch */ + + return factorType; + +} /* end simplePtrFactor */ + +/***********************************************************************/ + +static exprType functionDesignator(void) +{ + STYPE *funcPtr = tknPtr; + STYPE *typePtr = funcPtr->sParm.p.parent; + exprType factorType; + int size = 0; + + TRACE(lstFile,"[functionDesignator]"); + + /* FORM: function-designator = + * function-identifier [ actual-parameter-list ] + */ + + /* Allocate stack space for a reference instance of the type + * returned by the function. This is an uninitalized "container" + * that will catch the valued returned by the function. + * + * Check for the special case of a string value. In this case, + * the container cannot be empty. Rather, it must refer to an + * empty string allocated on the string strack + */ + + if (typePtr->sParm.t.rtype == sRSTRING) + { + /* Create and empty string reference */ + + pas_BuiltInFunctionCall(lbMKSTK); + } + else + { + /* Okay, create the empty container */ + + pas_GenerateDataOperation(opINDS, typePtr->sParm.t.rsize); + } + + /* Get the type of the function */ + + factorType = getExprType(typePtr); + setAbstractType(typePtr); + + /* Skip over the function-identifier */ + + getToken(); + + /* Get the actual parameters (if any) associated with the procedure + * call. This will lie in the stack "above" the function return + * value container. + */ + + size = actualParameterList(funcPtr); + + /* Generate function call and stack adjustment (if required) */ + + pas_GenerateProcedureCall(funcPtr); + + /* Release the actual parameter list (if any). */ + + if (size) + { + pas_GenerateDataOperation(opINDS, -size); + } + + return factorType; + +} /* end functionDesignator */ + +/*************************************************************************/ +/* Determine the expression type associated with a pointer to a type */ +/* symbol */ + +static void setAbstractType(STYPE *sType) +{ + TRACE(lstFile,"[setAbstractType]"); + + if ((sType) && (sType->sKind == sTYPE) + && (sType->sParm.t.type == sPOINTER)) + sType = sType->sParm.t.parent; + + if ((sType) && (sType->sKind == sTYPE)) { + switch (sType->sParm.t.type) { + case sSCALAR : + if (abstractType) { + if (sType != abstractType) error(eSCALARTYPE); + } /* end if */ + else + abstractType = sType; + break; + case sSUBRANGE : + if (!abstractType) + abstractType = sType; + else if ((abstractType->sParm.t.type != sSUBRANGE) + || (abstractType->sParm.t.subType != sType->sParm.t.subType)) + error(eSUBRANGETYPE); + switch (sType->sParm.t.subType) { + case sINT : + case sCHAR : + break; + case sSCALAR : + if (abstractType != sType) error(eSUBRANGETYPE); + break; + default : + error(eSUBRANGETYPE); + break; + } /* end switch */ + break; + } /* end switch */ + } /* end if */ + else error(eINVTYPE); + +} /* end setAbstractType */ + +/***************************************************************/ +static void getSetFactor(void) +{ + setTypeStruct s; + + TRACE(lstFile,"[getSetFactor]"); + + /* FORM: [[<constant>[,<constant>[, ...]]]] */ + /* ASSUMPTION: The first '[' has already been processed */ + + /* First, verify that a scalar expression type has been specified */ + /* If the abstractType is a SET, then we will need to get the TYPE */ + /* that it is a SET OF */ + + if (abstractType) { + if (abstractType->sParm.t.type == sSET_OF) + s.typePtr = abstractType->sParm.t.parent; + else + s.typePtr = abstractType; + } /* end if */ + else + s.typePtr = NULL; + + /* Now, get the associated type and MIN/MAX values */ + + if ((s.typePtr) && (s.typePtr->sParm.t.type == sSCALAR)) { + s.typeFound = true; + s.setType = sSCALAR; + s.minValue = s.typePtr->sParm.t.minValue; + s.maxValue = s.typePtr->sParm.t.maxValue; + } /* end else if */ + else if ((s.typePtr) && (s.typePtr->sParm.t.type == sSUBRANGE)) { + s.typeFound = true; + s.setType = s.typePtr->sParm.t.subType; + s.minValue = s.typePtr->sParm.t.minValue; + s.maxValue = s.typePtr->sParm.t.maxValue; + } /* end else if */ + else { + error(eSET); + s.typeFound = false; + s.typePtr = NULL; + s.minValue = 0; + s.maxValue = BITS_IN_INTEGER-1; + } /* end else */ + + /* Get the first element of the set */ + + getSetElement(&s); + + /* Incorporate each additional element into the set */ + /* NOTE: The optimizer will combine sets of constant elements into a */ + /* single PUSH! */ + + while (token == ',') { + + /* Get the next element of the set */ + getToken(); + getSetElement(&s); + + /* OR it with the previous element */ + pas_GenerateSimple(opOR); + + } /* end while */ + +} /* end getSetFactor */ + +/***************************************************************/ +static void getSetElement(setTypeStruct *s) +{ + uint16_t setValue; + int16_t firstValue; + int16_t lastValue; + STYPE *setPtr; + + TRACE(lstFile,"[getSetElement]"); + + switch (token) { + case sSCALAR_OBJECT : /* A scalar or scalar subrange constant */ + firstValue = tknPtr->sParm.c.val.i; + if (!s->typeFound) { + s->typeFound = true; + s->typePtr = tknPtr->sParm.c.parent; + s->setType = sSCALAR; + s->minValue = s->typePtr->sParm.t.minValue; + s->maxValue = s->typePtr->sParm.t.maxValue; + } /* end if */ + else if ((s->setType != sSCALAR) + || (s->typePtr != tknPtr->sParm.c.parent)) + error(eSET); + goto addBit; + + case tINT_CONST : /* An integer subrange constant ? */ + firstValue = tknInt; + if (!s->typeFound) { + s->typeFound = true; + s->setType = sINT; + } /* end if */ + else if (s->setType != sINT) + error(eSET); + goto addBit; + + case tCHAR_CONST : /* A character subrange constant */ + firstValue = tknInt; + if (!s->typeFound) { + s->typeFound = true; + s->setType = sCHAR; + } /* end if */ + else if (s->setType != sCHAR) + error(eSET); + + addBit: + /* Check if the constant set element is the first value in a */ + /* subrange of values */ + + getToken(); + if (token != tSUBRANGE) { + + /* Verify that the new value is in range */ + + if ((firstValue < s->minValue) || (firstValue > s->maxValue)) { + error(eSETRANGE); + setValue = 0; + } /* end if */ + else + setValue = (1 << (firstValue - s->minValue)); + + /* Now, generate P-Code to push the set value onto the stack */ + + pas_GenerateDataOperation(opPUSH, setValue); + + } /* end if */ + else { + if (!s->typeFound) error(eSUBRANGETYPE); + + /* Skip over the tSUBRANGE token */ + + getToken(); + + /* TYPE check */ + + switch (token) { + case sSCALAR_OBJECT : /* A scalar or scalar subrange constant */ + lastValue = tknPtr->sParm.c.val.i; + if ((s->setType != sSCALAR) + || (s->typePtr != tknPtr->sParm.c.parent)) + error(eSET); + goto addLottaBits; + + case tINT_CONST : /* An integer subrange constant ? */ + lastValue = tknInt; + if (s->setType != sINT) error(eSET); + goto addLottaBits; + + case tCHAR_CONST : /* A character subrange constant */ + lastValue = tknInt; + if (s->setType != sCHAR) error(eSET); + + addLottaBits : + /* Verify that the first value is in range */ + if (firstValue < s->minValue) { + error(eSETRANGE); + firstValue = s->minValue; + } /* end if */ + else if (firstValue > s->maxValue) { + error(eSETRANGE); + firstValue = s->maxValue; + } /* end else if */ + + /* Verify that the last value is in range */ + if (lastValue < firstValue) { + error(eSETRANGE); + lastValue = firstValue; + } /* end if */ + else if (lastValue > s->maxValue) { + error(eSETRANGE); + lastValue = s->maxValue; + } /* end else if */ + + /* Set all bits from firstValue through lastValue */ + + setValue = (0xffff << (firstValue - s->minValue)); + setValue &= (0xffff >> ((BITS_IN_INTEGER-1) - (lastValue - s->minValue))); + + /* Now, generate P-Code to push the set value onto the stack */ + + pas_GenerateDataOperation(opPUSH, setValue); + break; + + case sSCALAR : + if ((!s->typePtr) + || (s->typePtr != tknPtr->sParm.v.parent)) { + error(eSET); + + if (!s->typePtr) { + s->typeFound = true; + s->typePtr = tknPtr->sParm.v.parent; + s->setType = sSCALAR; + s->minValue = s->typePtr->sParm.t.minValue; + s->maxValue = s->typePtr->sParm.t.maxValue; + } /* end if */ + } /* end if */ + goto addVarToBits; + + case sINT : /* An integer subrange variable ? */ + case sCHAR : /* A character subrange variable? */ + if (s->setType != token) error(eSET); + goto addVarToBits; + + case sSUBRANGE : + if ((!s->typePtr) + || (s->typePtr != tknPtr->sParm.v.parent)) { + + if ((tknPtr->sParm.v.parent->sParm.t.subType == sSCALAR) + || (tknPtr->sParm.v.parent->sParm.t.subType != s->setType)) + error(eSET); + + if (!s->typePtr) { + s->typeFound = true; + s->typePtr = tknPtr->sParm.v.parent; + s->setType = s->typePtr->sParm.t.subType; + s->minValue = s->typePtr->sParm.t.minValue; + s->maxValue = s->typePtr->sParm.t.maxValue; + } /* end if */ + } /* end if */ + + addVarToBits: + /* Verify that the first value is in range */ + + if (firstValue < s->minValue) { + error(eSETRANGE); + firstValue = s->minValue; + } /* end if */ + else if (firstValue > s->maxValue) { + error(eSETRANGE); + firstValue = s->maxValue; + } /* end else if */ + + /* Set all bits from firstValue through maxValue */ + + setValue = (0xffff >> ((BITS_IN_INTEGER-1) - (s->maxValue - s->minValue))); + setValue &= (0xffff << (firstValue - s->minValue)); + + /* Generate run-time logic to get all bits from firstValue */ + /* through last value, i.e., need to generate logic to get: */ + /* 0xffff >> ((BITS_IN_INTEGER-1)-(lastValue-minValue)) */ + + pas_GenerateDataOperation(opPUSH, 0xffff); + pas_GenerateDataOperation(opPUSH, ((BITS_IN_INTEGER-1) + s->minValue)); + pas_GenerateStackReference(opLDS, tknPtr); + pas_GenerateSimple(opSUB); + pas_GenerateSimple(opSRL); + + /* Then AND this with the setValue */ + + if (setValue != 0xffff) { + pas_GenerateDataOperation(opPUSH, setValue); + pas_GenerateSimple(opAND); + } /* end if */ + + getToken(); + break; + + default : + error(eSET); + pas_GenerateDataOperation(opPUSH, 0); + break; + + } /* end switch */ + } /* end else */ + break; + + case sSCALAR : + if (s->typeFound) { + if ((!s->typePtr) || (s->typePtr != tknPtr->sParm.v.parent)) + error(eSET); + } /* end if */ + else { + s->typeFound = true; + s->typePtr = tknPtr->sParm.v.parent; + s->setType = sSCALAR; + s->minValue = s->typePtr->sParm.t.minValue; + s->maxValue = s->typePtr->sParm.t.maxValue; + } /* end if */ + goto addVar; + + case sINT : /* An integer subrange variable ? */ + case sCHAR : /* A character subrange variable? */ + if (!s->typeFound) { + s->typeFound = true; + s->setType = token; + } /* end if */ + else if (s->setType != token) + error(eSET); + goto addVar; + + case sSUBRANGE : + if (s->typeFound) { + if ((!s->typePtr) || (s->typePtr != tknPtr->sParm.v.parent)) + error(eSET); + } /* end if */ + else { + s->typeFound = true; + s->typePtr = tknPtr->sParm.v.parent; + s->setType = s->typePtr->sParm.t.subType; + s->minValue = s->typePtr->sParm.t.minValue; + s->maxValue = s->typePtr->sParm.t.maxValue; + } /* end if */ + + addVar: + /* Check if the variable set element is the first value in a */ + /* subrange of values */ + + setPtr = tknPtr; + getToken(); + if (token != tSUBRANGE) { + + /* Generate P-Code to push the set value onto the stack */ + /* FORM: 1 << (firstValue - minValue) */ + + pas_GenerateDataOperation(opPUSH, 1); + pas_GenerateStackReference(opLDS, setPtr); + pas_GenerateDataOperation(opPUSH, s->minValue); + pas_GenerateSimple(opSUB); + pas_GenerateSimple(opSLL); + + } /* end if */ + else { + if (!s->typeFound) error(eSUBRANGETYPE); + + /* Skip over the tSUBRANGE token */ + + getToken(); + + /* TYPE check */ + + switch (token) { + case sSCALAR_OBJECT : /* A scalar or scalar subrange constant */ + lastValue = tknPtr->sParm.c.val.i; + if ((s->setType != sSCALAR) + || (s->typePtr != tknPtr->sParm.c.parent)) + error(eSET); + goto addBitsToVar; + + case tINT_CONST : /* An integer subrange constant ? */ + lastValue = tknInt; + if (s->setType != sINT) error(eSET); + goto addBitsToVar; + + case tCHAR_CONST : /* A character subrange constant */ + lastValue = tknInt; + if (s->setType != sCHAR) error(eSET); + + addBitsToVar : + /* Verify that the last value is in range */ + + if (lastValue < s->minValue) { + error(eSETRANGE); + lastValue = s->minValue; + } /* end if */ + else if (lastValue > s->maxValue) { + error(eSETRANGE); + lastValue = s->maxValue; + } /* end else if */ + + /* Set all bits from minValue through lastValue */ + + setValue = (0xffff >> ((BITS_IN_INTEGER-1) - (lastValue - s->minValue))); + + /* Now, generate P-Code to push the set value onto the stack */ + /* First generate: 0xffff << (firstValue-minValue) */ + + pas_GenerateDataOperation(opPUSH, 0xffff); + pas_GenerateStackReference(opLDS, setPtr); + if (s->minValue) { + pas_GenerateDataOperation(opPUSH, s->minValue); + pas_GenerateSimple(opSUB); + } /* end if */ + pas_GenerateSimple(opSLL); + + /* Then and this with the pre-computed constant set value */ + + if (setValue != 0xffff) { + pas_GenerateDataOperation(opPUSH, setValue); + pas_GenerateSimple(opAND); + } /* end if */ + + getToken(); + break; + + case sINT : /* An integer subrange variable ? */ + case sCHAR : /* A character subrange variable? */ + if (s->setType != token) error(eSET); + goto addVarToVar; + + case sSCALAR : + if (s->typePtr != tknPtr->sParm.v.parent) error(eSET); + goto addVarToVar; + + case sSUBRANGE : + if ((s->typePtr != tknPtr->sParm.v.parent) + && ((tknPtr->sParm.v.parent->sParm.t.subType == sSCALAR) + || (tknPtr->sParm.v.parent->sParm.t.subType != s->setType))) + error(eSET); + + addVarToVar: + + /* Generate run-time logic to get all bits from firstValue */ + /* through lastValue */ + /* First generate: 0xffff << (firstValue-minValue) */ + + pas_GenerateDataOperation(opPUSH, 0xffff); + pas_GenerateStackReference(opLDS, setPtr); + if (s->minValue) { + pas_GenerateDataOperation(opPUSH, s->minValue); + pas_GenerateSimple(opSUB); + } /* end if */ + pas_GenerateSimple(opSLL); + + /* Generate logic to get: */ + /* 0xffff >> ((BITS_IN_INTEGER-1)-(lastValue-minValue)) */ + + pas_GenerateDataOperation(opPUSH, 0xffff); + pas_GenerateDataOperation(opPUSH, ((BITS_IN_INTEGER-1) + s->minValue)); + pas_GenerateStackReference(opLDS, tknPtr); + pas_GenerateSimple(opSUB); + pas_GenerateSimple(opSRL); + + /* Then AND the two values */ + + pas_GenerateSimple(opAND); + + getToken(); + break; + + default : + error(eSET); + pas_GenerateDataOperation(opPUSH, 0); + break; + + } /* end switch */ + } /* end else */ + break; + + default : + error(eSET); + pas_GenerateDataOperation(opPUSH, 0); + break; + + } /* end switch */ + +} /* end getSetElement */ + +/***************************************************************/ + +/* Check if this is a ordinal type. This is what is needed, for + * example, as an argument to ord(), pred(), succ(), or odd(). + * This is the kind of expression we need in a CASE statement + * as well. + */ + +static bool isOrdinalType(exprType testExprType) +{ + if ((testExprType == exprInteger) || /* integer value */ + (testExprType == exprChar) || /* character value */ + (testExprType == exprBoolean) || /* boolean(integer) value */ + (testExprType == exprScalar)) /* scalar(integer) value */ + return true; + else + return false; +} + +/***************************************************************/ +/* This is a hack to handle calls to system functions that return + * exprCString pointers that must be converted to exprString + * records upon assignment. + */ + +static bool isAnyStringType(exprType testExprType) +{ + if ((testExprType == exprString) || + (testExprType == exprStkString) || + (testExprType == exprCString)) + return true; + else + return false; +} + +static bool isStringReference (exprType testExprType) +{ + if ((testExprType == exprString) || + (testExprType == exprStkString)) + return true; + else + return false; +} + diff --git a/misc/pascal/pascal/pexpr.h b/misc/pascal/pascal/pexpr.h index dba1f1ee76..9375101025 100644 --- a/misc/pascal/pascal/pexpr.h +++ b/misc/pascal/pascal/pexpr.h @@ -1,92 +1,98 @@ -/***********************************************************************
- * pexpr.h
- * External Declarations associated with pexpr.c
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***********************************************************************/
-
-#ifndef __PEXPR_H
-#define __PEXPR_H
-
-/***********************************************************************
- * Type Definitions
- ***********************************************************************/
-
-typedef enum exprEnum
-{
- exprUnknown = 0, /* TOS value unknown */
- exprAnyOrdinal, /* TOS = any ordinal type */
- exprAnyString, /* TOS = any string type */
-
- exprInteger, /* TOS = integer value */
- exprReal, /* TOS = real value */
- exprChar, /* TOS = character value */
- exprBoolean, /* TOS = boolean(integer) value */
- exprScalar, /* TOS = scalar(integer) value */
- exprString, /* TOS = variable length string reference */
- exprStkString, /* TOS = reference to string on string stack */
- exprCString, /* TOS = pointer to C string */
- exprSet, /* TOS = set(integer) value */
- exprArray, /* TOS = array */
- exprRecord, /* TOS = record */
-
- exprIntegerPtr, /* TOS = pointer to integer value */
- exprRealPtr, /* TOS = pointer to a real value */
- exprCharPtr, /* TOS = pointer to a character value */
- exprBooleanPtr, /* TOS = pointer to a boolean value */
- exprScalarPtr, /* TOS = pointer to a scalar value */
- exprSetPtr, /* TOS = pointer to a set value */
- exprArrayPtr, /* TOS = pointer to an array */
- exprRecordPtr /* TOS = pointer to a record */
-} exprType;
-
-/***********************************************************************
- * Global Variables
- ***********************************************************************/
-
-extern int constantToken;
-extern sint32 constantInt;
-extern float64 constantReal;
-extern char *constantStart;
-
-/***********************************************************************
- * Global Function Protypes
- ***********************************************************************/
-
-extern exprType expression ( exprType findExprType, STYPE *typePtr );
-extern exprType varParm ( exprType varExprType, STYPE *typePtr );
-extern void arrayIndex ( sint32 size );
-extern exprType getExprType( STYPE *sType );
-
-extern void constantExpression(void);
-
-#endif /* __PEXPR_H */
+/*********************************************************************** + * pexpr.h + * External Declarations associated with pexpr.c + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***********************************************************************/ + +#ifndef __PEXPR_H +#define __PEXPR_H + +/*********************************************************************** + * Included Files + ***********************************************************************/ + +#include <stdint.h> + +/*********************************************************************** + * Type Definitions + ***********************************************************************/ + +typedef enum exprEnum +{ + exprUnknown = 0, /* TOS value unknown */ + exprAnyOrdinal, /* TOS = any ordinal type */ + exprAnyString, /* TOS = any string type */ + + exprInteger, /* TOS = integer value */ + exprReal, /* TOS = real value */ + exprChar, /* TOS = character value */ + exprBoolean, /* TOS = boolean(integer) value */ + exprScalar, /* TOS = scalar(integer) value */ + exprString, /* TOS = variable length string reference */ + exprStkString, /* TOS = reference to string on string stack */ + exprCString, /* TOS = pointer to C string */ + exprSet, /* TOS = set(integer) value */ + exprArray, /* TOS = array */ + exprRecord, /* TOS = record */ + + exprIntegerPtr, /* TOS = pointer to integer value */ + exprRealPtr, /* TOS = pointer to a real value */ + exprCharPtr, /* TOS = pointer to a character value */ + exprBooleanPtr, /* TOS = pointer to a boolean value */ + exprScalarPtr, /* TOS = pointer to a scalar value */ + exprSetPtr, /* TOS = pointer to a set value */ + exprArrayPtr, /* TOS = pointer to an array */ + exprRecordPtr /* TOS = pointer to a record */ +} exprType; + +/*********************************************************************** + * Global Variables + ***********************************************************************/ + +extern int constantToken; +extern int32_t constantInt; +extern double constantReal; +extern char *constantStart; + +/*********************************************************************** + * Global Function Protypes + ***********************************************************************/ + +extern exprType expression ( exprType findExprType, STYPE *typePtr ); +extern exprType varParm ( exprType varExprType, STYPE *typePtr ); +extern void arrayIndex ( int32_t size ); +extern exprType getExprType( STYPE *sType ); + +extern void constantExpression(void); + +#endif /* __PEXPR_H */ diff --git a/misc/pascal/pascal/pffunc.c b/misc/pascal/pascal/pffunc.c index 609944d19b..f296af0dea 100644 --- a/misc/pascal/pascal/pffunc.c +++ b/misc/pascal/pascal/pffunc.c @@ -1,451 +1,452 @@ -/***************************************************************
- * pfunc.c
- * Standard Functions
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************/
-
-/***************************************************************
- * Included Files
- ***************************************************************/
-
-#include <stdio.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "podefs.h"
-#include "pfdefs.h"
-#include "pedefs.h"
-#include "pxdefs.h"
-
-#include "pas.h"
-#include "pexpr.h"
-#include "pfunc.h"
-#include "pgen.h" /* for pas_Generate*() */
-#include "ptkn.h"
-#include "pinsn.h"
-#include "perr.h"
-
-/***************************************************************
- * Private Function Prototypes
- ***************************************************************/
-
-/* Standard Pascal Functions */
-
-static exprType absFunc (void); /* Integer absolute value */
-static exprType predFunc (void);
-static void ordFunc (void); /* Convert scalar to integer */
-static exprType sqrFunc (void);
-static void realFunc (ubyte fpCode);
-static exprType succFunc (void);
-static void oddFunc (void);
-static void chrFunc (void);
-static void fileFunc (uint16 opcode);
-
-/* Enhanced Pascal functions */
-
-/* Non-standard C-library interface functions */
-
-static exprType getenvFunc (void); /* Get environment string value */
-
-/***************************************************************
- * Public Functions
- ***************************************************************/
-
-void primeBuiltInFunctions(void)
-{
-}
-
-/***************************************************************/
-/* Process a standard Pascal function call */
-
-exprType builtInFunction(void)
-{
- exprType funcType = exprUnknown;
-
- TRACE(lstFile,"[builtInFunction]");
-
- /* Is the token a function? */
-
- if (token == tFUNC)
- {
- /* Yes, process it procedure according to the extended token type */
-
- switch (tknSubType)
- {
- /* Functions which return the same type as their argument */
- case txABS :
- funcType = absFunc();
- break;
- case txSQR :
- funcType = sqrFunc();
- break;
- case txPRED :
- funcType = predFunc();
- break;
- case txSUCC :
- funcType = succFunc();
- break;
-
- case txGETENV : /* Non-standard C library interfaces */
- funcType = getenvFunc();
- break;
-
- /* Functions returning INTEGER with REAL arguments */
-
- case txROUND :
- getToken(); /* Skip over 'round' */
- expression(exprReal, NULL);
- pas_GenerateFpOperation(fpROUND);
- funcType = exprInteger;
- break;
- case txTRUNC :
- getToken(); /* Skip over 'trunc' */
- expression(exprReal, NULL);
- pas_GenerateFpOperation(fpTRUNC);
- funcType = exprInteger;
- break;
-
- /* Functions returning CHARACTER with INTEGER arguments. */
-
- case txCHR :
- chrFunc();
- funcType = exprChar;
- break;
-
- /* Function returning integer with scalar arguments */
-
- case txORD :
- ordFunc();
- funcType = exprInteger;
- break;
-
- /* Functions returning BOOLEAN */
- case txODD :
- oddFunc();
- funcType = exprBoolean;
- break;
- case txEOF :
- fileFunc(xEOF);
- funcType = exprBoolean;
- break;
- case txEOLN :
- fileFunc(xEOLN);
- funcType = exprBoolean;
- break;
-
- /* Functions returning REAL with REAL/INTEGER arguments */
-
- case txSQRT :
- realFunc(fpSQRT);
- funcType = exprReal;
- break;
- case txSIN :
- realFunc(fpSIN);
- funcType = exprReal;
- break;
- case txCOS :
- realFunc(fpCOS);
- funcType = exprReal;
- break;
- case txARCTAN :
- realFunc(fpATAN);
- funcType = exprReal;
- break;
- case txLN :
- realFunc(fpLN);
- funcType = exprReal;
- break;
- case txEXP :
- realFunc(fpEXP);
- funcType = exprReal;
- break;
-
- default :
- error(eINVALIDPROC);
- break;
- } /* end switch */
- } /* end if */
-
- return funcType;
-
-} /* end builtInFunction */
-
-void checkLParen(void)
-{
- getToken(); /* Skip over function name */
- if (token != '(') error(eLPAREN); /* Check for '(' */
- else getToken();
-}
-
-void checkRParen(void)
-{
- if (token != ')') error(eRPAREN); /* Check for ')') */
- else getToken();
-}
-
-/***************************************************************
- * Private Functions
- ***************************************************************/
-
-static exprType absFunc(void)
-{
- exprType absType;
-
- TRACE(lstFile,"[absFunc]");
-
- /* FORM: ABS (<simple integer/real expression>) */
-
- checkLParen();
-
- absType = expression(exprUnknown, NULL);
- if (absType == exprInteger)
- pas_GenerateSimple(opABS);
- else if (absType == exprReal)
- pas_GenerateFpOperation(fpABS);
- else
- error(eINVARG);
-
- checkRParen();
- return absType;
-
-} /* end absFunc */
-
-/**********************************************************************/
-
-static void ordFunc(void)
-{
- TRACE(lstFile,"[ordFunc]");
-
- /* FORM: ORD (<scalar type>) */
-
- checkLParen();
- expression(exprAnyOrdinal, NULL); /* Get any ordinal type */
- checkRParen();
-
-} /* end ordFunc */
-
-/**********************************************************************/
-
-static exprType predFunc(void)
-{
- exprType predType;
-
- TRACE(lstFile,"[predFunc]");
-
- /* FORM: PRED (<simple integer expression>) */
-
- checkLParen();
-
- /* Process any ordinal expression */
-
- predType = expression(exprAnyOrdinal, NULL);
- checkRParen();
- pas_GenerateSimple(opDEC);
- return predType;
-
-} /* end predFunc */
-
-/**********************************************************************/
-
-static exprType sqrFunc(void)
-{
- exprType sqrType;
-
- TRACE(lstFile,"[sqrFunc]");
-
-/* FORM: SQR (<simple integer OR real expression>) */
-
- checkLParen();
-
- sqrType = expression(exprUnknown, NULL); /* Process any expression */
- if (sqrType == exprInteger) {
-
- pas_GenerateSimple(opDUP);
- pas_GenerateSimple(opMUL);
-
- } /* end if */
- else if (sqrType == exprReal)
- pas_GenerateFpOperation(fpSQR);
-
- else
- error(eINVARG);
-
- checkRParen();
- return sqrType;
-
-} /* end sqrFunc */
-
-/**********************************************************************/
-static void realFunc (ubyte fpOpCode)
-{
- exprType realType;
-
- TRACE(lstFile,"[realFunc]");
-
- /* FORM: <function identifier> (<real/integer expression>) */
-
- checkLParen();
-
- realType = expression(exprUnknown, NULL); /* Process any expression */
- if (realType == exprInteger)
- pas_GenerateFpOperation((fpOpCode | fpARG1));
- else if (realType == exprReal)
- pas_GenerateFpOperation(fpOpCode);
- else
- error(eINVARG);
-
- checkRParen();
-
-} /* end realFunc */
-
-/**********************************************************************/
-
-static exprType succFunc(void)
-{
- exprType succType;
-
- TRACE(lstFile,"[succFunc]");
-
- /* FORM: SUCC (<simple integer expression>) */
-
- checkLParen();
-
- /* Process any ordinal expression */
-
- succType = expression(exprAnyOrdinal, NULL);
-
- checkRParen();
- pas_GenerateSimple(opINC);
- return succType;
-
-} /* end succFunc */
-
-/***********************************************************************/
-
-static void oddFunc(void)
-{
- TRACE(lstFile,"[oddFunc]");
-
- /* FORM: ODD (<simple integer expression>) */
-
- checkLParen();
-
- /* Process any ordinal expression */
-
- expression(exprAnyOrdinal, NULL);
- checkRParen();
- pas_GenerateDataOperation(opPUSH, 1);
- pas_GenerateSimple(opAND);
- pas_GenerateSimple(opNEQZ);
-
-} /* end oddFunc */
-
-/***********************************************************************/
-/* Process the standard chr function */
-
-static void chrFunc(void)
-{
- TRACE(lstFile,"[charFactor]");
-
- /* Form: chr(integer expression).
- *
- * char(val) is only defined if there exists a character ch such
- * that ord(ch) = val. If this is not the case, we will simply
- * let the returned value exceed the range of type char. */
-
- checkLParen();
- expression(exprInteger, NULL);
- checkRParen();
-
-} /* end chrFunc */
-
-/****************************************************************************/
-/* EOF/EOLN function */
-
-static void fileFunc(uint16 opcode)
-{
- TRACE(lstFile,"[fileFunc]");
-
- /* FORM: EOF|EOLN (<file number>) */
-
- checkLParen();
- if (token != sFILE)
- {
- error(eFILE);
- }
- else
- {
- pas_GenerateDataOperation(opINDS, sBOOLEAN_SIZE);
- pas_GenerateIoOperation(opcode, tknPtr->sParm.fileNumber);
- getToken();
- checkRParen();
- } /* end else */
-
-} /* end fileFunc */
-
-/**********************************************************************/
-/* C library getenv interface */
-
-static exprType getenvFunc(void)
-{
- exprType stringType;
-
- TRACE(lstFile, "[getenvFunc]");
-
- /* FORM: <string_var> = getenv(<string>) */
-
- checkLParen();
-
- /* Get the string expression representing the environment variable
- * name.
- */
-
- stringType = expression(exprString, NULL);
-
- /* Two possible kinds of strings could be returned.
- * Anything else other then 'exprString' would be an error (but
- * should happen).
- */
-
- if ((stringType != exprString) && (stringType != exprStkString))
- {
- error(eINVARG);
- }
-
- pas_BuiltInFunctionCall(lbGETENV);
- checkRParen();
- return exprCString;
-}
-
-/***********************************************************************/
+/*************************************************************** + * pfunc.c + * Standard Functions + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************/ + +/*************************************************************** + * Included Files + ***************************************************************/ + +#include <stdint.h> +#include <stdio.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "podefs.h" +#include "pfdefs.h" +#include "pedefs.h" +#include "pxdefs.h" + +#include "pas.h" +#include "pexpr.h" +#include "pfunc.h" +#include "pgen.h" /* for pas_Generate*() */ +#include "ptkn.h" +#include "pinsn.h" +#include "perr.h" + +/*************************************************************** + * Private Function Prototypes + ***************************************************************/ + +/* Standard Pascal Functions */ + +static exprType absFunc (void); /* Integer absolute value */ +static exprType predFunc (void); +static void ordFunc (void); /* Convert scalar to integer */ +static exprType sqrFunc (void); +static void realFunc (uint8_t fpCode); +static exprType succFunc (void); +static void oddFunc (void); +static void chrFunc (void); +static void fileFunc (uint16_t opcode); + +/* Enhanced Pascal functions */ + +/* Non-standard C-library interface functions */ + +static exprType getenvFunc (void); /* Get environment string value */ + +/*************************************************************** + * Public Functions + ***************************************************************/ + +void primeBuiltInFunctions(void) +{ +} + +/***************************************************************/ +/* Process a standard Pascal function call */ + +exprType builtInFunction(void) +{ + exprType funcType = exprUnknown; + + TRACE(lstFile,"[builtInFunction]"); + + /* Is the token a function? */ + + if (token == tFUNC) + { + /* Yes, process it procedure according to the extended token type */ + + switch (tknSubType) + { + /* Functions which return the same type as their argument */ + case txABS : + funcType = absFunc(); + break; + case txSQR : + funcType = sqrFunc(); + break; + case txPRED : + funcType = predFunc(); + break; + case txSUCC : + funcType = succFunc(); + break; + + case txGETENV : /* Non-standard C library interfaces */ + funcType = getenvFunc(); + break; + + /* Functions returning INTEGER with REAL arguments */ + + case txROUND : + getToken(); /* Skip over 'round' */ + expression(exprReal, NULL); + pas_GenerateFpOperation(fpROUND); + funcType = exprInteger; + break; + case txTRUNC : + getToken(); /* Skip over 'trunc' */ + expression(exprReal, NULL); + pas_GenerateFpOperation(fpTRUNC); + funcType = exprInteger; + break; + + /* Functions returning CHARACTER with INTEGER arguments. */ + + case txCHR : + chrFunc(); + funcType = exprChar; + break; + + /* Function returning integer with scalar arguments */ + + case txORD : + ordFunc(); + funcType = exprInteger; + break; + + /* Functions returning BOOLEAN */ + case txODD : + oddFunc(); + funcType = exprBoolean; + break; + case txEOF : + fileFunc(xEOF); + funcType = exprBoolean; + break; + case txEOLN : + fileFunc(xEOLN); + funcType = exprBoolean; + break; + + /* Functions returning REAL with REAL/INTEGER arguments */ + + case txSQRT : + realFunc(fpSQRT); + funcType = exprReal; + break; + case txSIN : + realFunc(fpSIN); + funcType = exprReal; + break; + case txCOS : + realFunc(fpCOS); + funcType = exprReal; + break; + case txARCTAN : + realFunc(fpATAN); + funcType = exprReal; + break; + case txLN : + realFunc(fpLN); + funcType = exprReal; + break; + case txEXP : + realFunc(fpEXP); + funcType = exprReal; + break; + + default : + error(eINVALIDPROC); + break; + } /* end switch */ + } /* end if */ + + return funcType; + +} /* end builtInFunction */ + +void checkLParen(void) +{ + getToken(); /* Skip over function name */ + if (token != '(') error(eLPAREN); /* Check for '(' */ + else getToken(); +} + +void checkRParen(void) +{ + if (token != ')') error(eRPAREN); /* Check for ')') */ + else getToken(); +} + +/*************************************************************** + * Private Functions + ***************************************************************/ + +static exprType absFunc(void) +{ + exprType absType; + + TRACE(lstFile,"[absFunc]"); + + /* FORM: ABS (<simple integer/real expression>) */ + + checkLParen(); + + absType = expression(exprUnknown, NULL); + if (absType == exprInteger) + pas_GenerateSimple(opABS); + else if (absType == exprReal) + pas_GenerateFpOperation(fpABS); + else + error(eINVARG); + + checkRParen(); + return absType; + +} /* end absFunc */ + +/**********************************************************************/ + +static void ordFunc(void) +{ + TRACE(lstFile,"[ordFunc]"); + + /* FORM: ORD (<scalar type>) */ + + checkLParen(); + expression(exprAnyOrdinal, NULL); /* Get any ordinal type */ + checkRParen(); + +} /* end ordFunc */ + +/**********************************************************************/ + +static exprType predFunc(void) +{ + exprType predType; + + TRACE(lstFile,"[predFunc]"); + + /* FORM: PRED (<simple integer expression>) */ + + checkLParen(); + + /* Process any ordinal expression */ + + predType = expression(exprAnyOrdinal, NULL); + checkRParen(); + pas_GenerateSimple(opDEC); + return predType; + +} /* end predFunc */ + +/**********************************************************************/ + +static exprType sqrFunc(void) +{ + exprType sqrType; + + TRACE(lstFile,"[sqrFunc]"); + +/* FORM: SQR (<simple integer OR real expression>) */ + + checkLParen(); + + sqrType = expression(exprUnknown, NULL); /* Process any expression */ + if (sqrType == exprInteger) { + + pas_GenerateSimple(opDUP); + pas_GenerateSimple(opMUL); + + } /* end if */ + else if (sqrType == exprReal) + pas_GenerateFpOperation(fpSQR); + + else + error(eINVARG); + + checkRParen(); + return sqrType; + +} /* end sqrFunc */ + +/**********************************************************************/ +static void realFunc (uint8_t fpOpCode) +{ + exprType realType; + + TRACE(lstFile,"[realFunc]"); + + /* FORM: <function identifier> (<real/integer expression>) */ + + checkLParen(); + + realType = expression(exprUnknown, NULL); /* Process any expression */ + if (realType == exprInteger) + pas_GenerateFpOperation((fpOpCode | fpARG1)); + else if (realType == exprReal) + pas_GenerateFpOperation(fpOpCode); + else + error(eINVARG); + + checkRParen(); + +} /* end realFunc */ + +/**********************************************************************/ + +static exprType succFunc(void) +{ + exprType succType; + + TRACE(lstFile,"[succFunc]"); + + /* FORM: SUCC (<simple integer expression>) */ + + checkLParen(); + + /* Process any ordinal expression */ + + succType = expression(exprAnyOrdinal, NULL); + + checkRParen(); + pas_GenerateSimple(opINC); + return succType; + +} /* end succFunc */ + +/***********************************************************************/ + +static void oddFunc(void) +{ + TRACE(lstFile,"[oddFunc]"); + + /* FORM: ODD (<simple integer expression>) */ + + checkLParen(); + + /* Process any ordinal expression */ + + expression(exprAnyOrdinal, NULL); + checkRParen(); + pas_GenerateDataOperation(opPUSH, 1); + pas_GenerateSimple(opAND); + pas_GenerateSimple(opNEQZ); + +} /* end oddFunc */ + +/***********************************************************************/ +/* Process the standard chr function */ + +static void chrFunc(void) +{ + TRACE(lstFile,"[charFactor]"); + + /* Form: chr(integer expression). + * + * char(val) is only defined if there exists a character ch such + * that ord(ch) = val. If this is not the case, we will simply + * let the returned value exceed the range of type char. */ + + checkLParen(); + expression(exprInteger, NULL); + checkRParen(); + +} /* end chrFunc */ + +/****************************************************************************/ +/* EOF/EOLN function */ + +static void fileFunc(uint16_t opcode) +{ + TRACE(lstFile,"[fileFunc]"); + + /* FORM: EOF|EOLN (<file number>) */ + + checkLParen(); + if (token != sFILE) + { + error(eFILE); + } + else + { + pas_GenerateDataOperation(opINDS, sBOOLEAN_SIZE); + pas_GenerateIoOperation(opcode, tknPtr->sParm.fileNumber); + getToken(); + checkRParen(); + } /* end else */ + +} /* end fileFunc */ + +/**********************************************************************/ +/* C library getenv interface */ + +static exprType getenvFunc(void) +{ + exprType stringType; + + TRACE(lstFile, "[getenvFunc]"); + + /* FORM: <string_var> = getenv(<string>) */ + + checkLParen(); + + /* Get the string expression representing the environment variable + * name. + */ + + stringType = expression(exprString, NULL); + + /* Two possible kinds of strings could be returned. + * Anything else other then 'exprString' would be an error (but + * should happen). + */ + + if ((stringType != exprString) && (stringType != exprStkString)) + { + error(eINVARG); + } + + pas_BuiltInFunctionCall(lbGETENV); + checkRParen(); + return exprCString; +} + +/***********************************************************************/ diff --git a/misc/pascal/pascal/pgen.c b/misc/pascal/pascal/pgen.c index afb49cf393..fc108e3a6c 100644 --- a/misc/pascal/pascal/pgen.c +++ b/misc/pascal/pascal/pgen.c @@ -1,641 +1,641 @@ -/**********************************************************************
- * pgen.c
- * P-Code generation logic
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- **********************************************************************/
-
-/**********************************************************************
- * Included Files
- **********************************************************************/
-
-#include <stdio.h>
-#include <string.h>
-#include <errno.h>
-
-#include "config.h" /* Configuration */
-#include "keywords.h" /* Standard types */
-#include "pasdefs.h" /* Common types */
-#include "ptdefs.h" /* Token / symbol table definitions */
-#include "podefs.h" /* Logical opcode definitions */
-#include "pedefs.h" /* error code definitions */
-
-#include "pas.h" /* Global variables */
-#include "poff.h" /* For POFF file format */
-#include "pofflib.h" /* For poff*() functions*/
-#include "pinsn.h" /* (DEBUG only) */
-#include "perr.h" /* error() */
-
-#include "pproc.h" /* for actualParameterSize */
-#include "pgen.h" /* (to verify prototypes in this file) */
-
-/**********************************************************************
- * Definitions
- **********************************************************************/
-
-#define UNDEFINED_LEVEL (-1)
-#define INVALID_PCODE (-1)
-
-#define LEVEL_DEFINED(l) ((sint32)(l) >= 0)
-#define PCODE_VALID(p) ((sint32)(p) >= 0)
-
-/**********************************************************************
- * Global Variables
- **********************************************************************/
-
-/**********************************************************************
- * Private Variables
- **********************************************************************/
-
-static sint32 g_currentStackLevelReference = UNDEFINED_LEVEL;
-static uint32 g_nStackLevelReferenceChanges = 0;
-
-/***********************************************************************
- * Private Function Prototypes
- ***********************************************************************/
-
-/***********************************************************************
- * Private Functions
- ***********************************************************************/
-
-/***********************************************************************/
-/* Generate a stack reference opcode to a global variable residing at
- * static nesting level zero.
- */
-
-static void
-pas_GenerateLevel0StackReference(enum pcode_e eOpCode, STYPE *pVar)
-{
- /* Sanity checking. Double check nesting level and also since this is
- * a level zero reference, then the offset must be positive
- */
-
- if ((pVar->sLevel != 0) || (pVar->sParm.v.offset < 0))
- {
- error(eHUH);
- }
- else
- {
- /* Generate the P-code */
-
- insn_GenerateDataOperation(eOpCode, pVar->sParm.v.offset);
-
- /* If the variable is undefined, also generate a relocation
- * record.
- */
-
- if ((pVar->sParm.v.flags & SVAR_EXTERNAL) != 0)
- {
- (void)poffAddRelocation(poffHandle, RLT_LDST,
- pVar->sParm.v.symIndex, 0);
- }
- }
-}
-
-
-/***********************************************************************/
-/* There are some special P-codes for accessing stack data at static
- * nesting level 0. Check if the specified opcode is one of those. If
- * so, return the mapped opcode. Otherwise, return INVALID_PCODE.
- */
-
-static sint32
-pas_GetLevel0Opcode(enum pcode_e eOpCode)
-{
- switch (eOpCode)
- {
- case opLDS: return opLD;
- case opLDSH: return opLDH;
- case opLDSB: return opLDB;
- case opLDSM: return opLDM;
- case opSTS: return opST;
- case opSTSB: return opSTB;
- case opSTSM: return opSTM;
- case opLDSX: return opLDX;
- case opLDSXB: return opLDXB;
- case opLDSXM: return opLDXM;
- case opSTSX: return opSTX;
- case opSTSXB: return opSTXB;
- case opSTSXM: return opSTXM;
- case opLAS: return opLA;
- case opLASX: return opLAX;
- default: return INVALID_PCODE;
- }
-}
-
-/***********************************************************************/
-/* A new static nesting level has been encountered. Check if we need
- * to reset the level stack pointer (LSP) register (assuming that the
- * architecutre has one).
- */
-
-static void
-pas_SetLevelStackPointer(uint32 dwLevel)
-{
- if (dwLevel != g_currentStackLevelReference)
- {
- /* Set the level stack pointer (LSP) register */
-
- insn_SetStackLevel(dwLevel);
-
- /* Remember the setting so that we do not reset the LSP until
- * the level changes (or it is invalidated).
- */
-
- g_currentStackLevelReference = dwLevel;
- g_nStackLevelReferenceChanges++;
- }
-}
-
-/***********************************************************************
- * Public Functions
- ***********************************************************************/
-
-/***********************************************************************/
-/* Return the current setting of the level stack pointer (LSP) register
- * -- assuming that the underlying architecure may have one.
- */
-
-sint32 pas_GetCurrentStackLevel(void)
-{
- return g_currentStackLevelReference;
-}
-
-/***********************************************************************/
-/* Invalidate the current stack level register setting. This will cause
- * us to reset the LSP when the next stack level reference is encountered.
- */
-
-void pas_InvalidateCurrentStackLevel(void)
-{
- g_currentStackLevelReference = UNDEFINED_LEVEL;
- g_nStackLevelReferenceChanges++;
-}
-
-/***********************************************************************/
-/* Set the stack level pointer to known value. This is done when in
- * while and for loop processing. The value of the LSP will be that
- * as sampled at the top of the lop not necessarily the value at the
- * bottom of the loop.
- */
-
-void pas_SetCurrentStackLevel(sint32 dwLsp)
-{
- g_currentStackLevelReference = dwLsp;
- g_nStackLevelReferenceChanges++;
-}
-
-/***********************************************************************/
-/* Get the number of changes made to the level stack pointer. This is
- * useful by compiler logic to determine if the stack level pointer was
- * ever changed by any logic path.
- */
-
-uint32 pas_GetNStackLevelChanges(void)
-{
- return g_nStackLevelReferenceChanges;
-}
-
-/***********************************************************************/
-/* Generate the most simple of all P-codes */
-
-void pas_GenerateSimple(enum pcode_e eOpCode)
-{
- insn_GenerateSimple(eOpCode);
-}
-
-/***********************************************************************/
-/* Generate a P-code with a single data argument */
-
-void pas_GenerateDataOperation(enum pcode_e eOpCode, sint32 dwData)
-{
- insn_GenerateDataOperation(eOpCode, dwData);
-}
-
-/***********************************************************************/
-/* This function is called just before a multiple register operation is
- * is generated. This should generate logic to specify the size of the
- * multiple register operation (in bytes, not registers). This may translate
- * into different operations on different architectures. Typically,
- * this would generate a push of the size onto the stack or, perhaps,
- * setting of a dedicated count register.
- */
-
-void pas_GenerateDataSize(sint32 dwDataSize)
-{
- insn_GenerateDataSize(dwDataSize);
-}
-
-/***********************************************************************/
-/* Generate a floating point operation */
-
-void pas_GenerateFpOperation(ubyte fpOpcode)
-{
- insn_GenerateFpOperation(fpOpcode);
-}
-
-/***********************************************************************/
-/* Generate an IO operation */
-
-void pas_GenerateIoOperation(uint16 ioOpcode, uint16 fileNumber)
-{
- insn_GenerateIoOperation(ioOpcode, fileNumber);
-}
-
-/***********************************************************************/
-/* Generate a psuedo call to a built-in, standard pascal function */
-
-void pas_BuiltInFunctionCall(uint16 libOpcode)
-{
- insn_BuiltInFunctionCall(libOpcode);
-}
-
-/***********************************************************************/
-/* Generate a reference to data on the data stack using the specified
- * level and offset.
- */
-
-void pas_GenerateLevelReference(enum pcode_e eOpCode, uint16 wLevel,
- sint32 dwOffset)
-{
- /* Is this variable declared at level 0 (i.e., it has global scope)
- * that is being offset via a nesting level?
- */
-
- if (wLevel == 0)
- {
- sint32 level0Opcode = pas_GetLevel0Opcode(eOpCode);
- if (PCODE_VALID(level0Opcode))
- {
- insn_GenerateDataOperation(level0Opcode, dwOffset);
- return;
- }
- }
-
- /* We get here if the reference is at some static nesting level
- * other that zero OR if there is no special PCode to reference
- * data at static nesting level 0 for this operation.
- *
- * Check if we have to change the level stack pointer (LSP) register
- * (assuming that the architecture has one).
- */
-
- pas_SetLevelStackPointer(wLevel);
-
- /* Then generate the opcode passing the level in the event that the
- * architecture does not have an LSP.
- */
-
- insn_GenerateLevelReference(eOpCode, wLevel, dwOffset);
-}
-
-/***********************************************************************/
-/* Generate a stack reference opcode, handling references to undefined
- * stack offsets.
- */
-
-void pas_GenerateStackReference(enum pcode_e eOpCode, STYPE *pVar)
-{
- /* Is this variable declared at level 0 (i.e., it has global scope)
- * that is being offset via a nesting level?
- */
-
- if (pVar->sLevel == 0)
- {
- sint32 level0Opcode = pas_GetLevel0Opcode(eOpCode);
- if (PCODE_VALID(level0Opcode))
- {
- pas_GenerateLevel0StackReference(level0Opcode, pVar);
- return;
- }
- }
-
- /* We get here if the reference is at some static nesting level
- * other that zero OR if there is no special PCode to reference
- * data at static nesting level 0 for this operation.
- *
- * Check if we have to change the level stack pointer (LSP) register
- * (assuming that the architecture has one).
- */
-
- pas_SetLevelStackPointer(pVar->sLevel);
-
- /* Generate the P-Code at the defined offset and with the specified
- * static level offset (in case that the architecture does not have
- * an LSP)
- */
-
- insn_GenerateLevelReference(eOpCode, (level - pVar->sLevel),
- pVar->sParm.v.offset);
-}
-
-/***********************************************************************/
-/* Generate a procedure call and an associated relocation record if the
- * called procedure is external.
- */
-
-void
-pas_GenerateProcedureCall(STYPE *pProc)
-{
- /* sLevel is the level at which the procedure was declared. We need
- * to set the SLP to this value prior to the call (on some architectures
- * where the SLP is pushed onto the stack by the procedure
- * call).
- */
-
- pas_SetLevelStackPointer(pProc->sLevel);
-
- /* Then generate the procedure call (passing the level again for those
- * architectures that do not support the SLP.
- */
-
- insn_GenerateProcedureCall(pProc->sLevel, pProc->sParm.p.label);
-
- /* If the variable is undefined, also generate a relocation
- * record.
- */
-
-#if 0 /* Not yet */
- if ((pVar->sParm.p.flags & SVAR_EXTERNAL) != 0)
- {
- /* For now */
-# error "Don't know what last parameter should be"
- (void)poffAddRelocation(poffHandle, RLT_PCAL,
- pVar->sParm.p.symIndex,
- 0);
- }
-#endif
-
- /* Any logic after the procedure/function call return must assume
- * that the last level reference is unknown.
- */
-
- pas_InvalidateCurrentStackLevel();
-}
-
-/***********************************************************************/
-
-void pas_GenerateLineNumber(uint16 wIncludeNumber, uint32 dwLineNumber)
-{
- insn_GenerateLineNumber(wIncludeNumber, dwLineNumber);
-}
-
-/***********************************************************************/
-
-void pas_GenerateDebugInfo(STYPE *pProc, uint32 dwReturnSize)
-{
- int i;
-
- /* Allocate a container to pass the proc information to the library */
-
- uint32 nparms = pProc->sParm.p.nParms;
- poffLibDebugFuncInfo_t *pContainer = poffCreateDebugInfoContainer(nparms);
-
- /* Put the proc information into the container */
-
- pContainer->value = pProc->sParm.p.label;
- pContainer->retsize = dwReturnSize;
- pContainer->nparms = nparms;
-
- /* Add the argument information to the container */
-
- for (i = 0; i < nparms; i++)
- {
- pContainer->argsize[i] = actualParameterSize(pProc, i+1);
- }
-
- /* Add the contained information to the library */
-
- poffAddDebugFuncInfo(poffHandle, pContainer);
-
- /* Release the container */
-
- poffReleaseDebugFuncContainer(pContainer);
-}
-
-/***********************************************************************/
-/* Generate description of a level 0 stack variable that can be
- * exported by a unit.
- */
-
-void pas_GenerateStackExport(STYPE *pVar)
-{
- poffLibSymbol_t symbol;
-
-#if CONFIG_DEBUG
- /* Get the parent type of the variable */
-
- STYPE *typePtr = pVar->sParm.v.parent;
-
- /* Perform some sanity checking:
- * - Must have a parent type
- * - Must not be declared external
- * - Must be declared at static nesting level zero
- */
-
- if ((!typePtr) ||
- ((pVar->sParm.v.flags & SVAR_EXTERNAL) != 0) ||
- (pVar->sLevel != 0))
- {
- error(eSYMTABINTERNAL);
- }
-#endif
-
- /* Create the symbol structure */
-
- symbol.type = STT_DATA;
- symbol.align = STA_8BIT; /* for now */
- symbol.flags = STF_NONE;
- symbol.name = pVar->sName;
- symbol.value = pVar->sParm.v.offset;
- symbol.size = pVar->sParm.v.size;
-
- /* Add the symbol to the symbol table */
-
- (void)poffAddSymbol(poffHandle, &symbol);
-}
-
-/***********************************************************************/
-/* Generate description of a level 0 stack variable that must be
- * imported by a program or unit from a unit.
- */
-
-void pas_GenerateStackImport(STYPE *pVar)
-{
- poffLibSymbol_t symbol;
-
-#if CONFIG_DEBUG
- /* Get the parent type of the variable */
-
- STYPE *typePtr = pVar->sParm.v.parent;
-
- /* Perform some sanity checking
- * - Must have a parent type
- * - Must be declared external
- * - Must be declared at static nesting level zero
- */
-
- if ((!typePtr) ||
- ((pVar->sParm.v.flags & SVAR_EXTERNAL) == 0) ||
- (pVar->sLevel != 0))
- {
- error(eSYMTABINTERNAL);
- }
-#endif
-
- /* Create the symbol structure */
-
- symbol.type = STT_DATA;
- symbol.align = STA_8BIT; /* for now */
- symbol.flags = STF_UNDEFINED;
- symbol.name = pVar->sName;
- symbol.value = pVar->sParm.v.offset; /* for now */
- symbol.size = pVar->sParm.v.size;
-
- /* Add the symbol to the symbol table */
-
- pVar->sParm.v.symIndex = poffAddSymbol(poffHandle, &symbol);
-}
-
-/***********************************************************************/
-/* Generate description of a level 0 procedure or function that can be
- * exported by a unit.
- */
-
-void pas_GenerateProcExport(STYPE *pProc)
-{
- poffLibSymbol_t symbol;
-
-#if CONFIG_DEBUG
- /* Get the parent type of the function (assuming it is a function) */
-
- STYPE *typePtr = pProc->sParm.p.parent;
-
- /* Perform some sanity checking */
-
- /* Check for a function reference which must have a valid parent type */
-
- if ((pProc->sKind == sFUNC) && (typePtr != NULL));
-
- /* Check for a procedure reference which must not have a valid type */
-
- else if ((pProc->sKind == sPROC) && (typePtr == NULL));
-
- /* Anything else is an error */
-
- else
- error(eSYMTABINTERNAL);
-
- /* The function / procedure should NOT be declared external and
- * only procedures declared at static nesting level zero can
- * be exported.
- */
-
- if (((pProc->sParm.p.flags & SPROC_EXTERNAL) != 0) ||
- (pProc->sLevel != 0))
- error(eSYMTABINTERNAL);
-#endif
-
- /* Everthing looks okay. Create the symbol structure */
-
- if (pProc->sKind == sPROC)
- symbol.type = STT_PROC;
- else
- symbol.type = STT_FUNC;
-
- symbol.align = STA_NONE;
- symbol.flags = STF_NONE;
- symbol.name = pProc->sName;
- symbol.value = pProc->sParm.p.label;
- symbol.size = 0;
-
- /* Add the symbol to the symbol table */
-
- (void)poffAddSymbol(poffHandle, &symbol);
-}
-
-/***********************************************************************/
-/* Generate description of a level 0 procedure or function that must be
- * imported by a program or unit from a unit.
- */
-
-void pas_GenerateProcImport(STYPE *pProc)
-{
- poffLibSymbol_t symbol;
-
-#if CONFIG_DEBUG
- /* Get the parent type of the function (assuming it is a function) */
-
- STYPE *typePtr = pProc->sParm.p.parent;
-
- /* Perform some sanity checking */
-
- /* Check for a function reference which must have a valid parent type */
-
- if ((pProc->sKind == sFUNC) && (typePtr != NULL));
-
- /* Check for a procedure reference which must not have a valid type */
-
- else if ((pProc->sKind == sPROC) && (typePtr == NULL));
-
- /* Anything else is an error */
-
- else
- error(eSYMTABINTERNAL);
-
- /* The function / procedure should also be declared external and
- * only procedures declared at static nesting level zero can
- * be exported.
- */
-
- if (((pProc->sParm.p.flags & SPROC_EXTERNAL) == 0) ||
- (pProc->sLevel != 0))
- error(eSYMTABINTERNAL);
-#endif
-
- /* Everthing looks okay. Create the symbol structure */
-
- if (pProc->sKind == sPROC)
- symbol.type = STT_PROC;
- else
- symbol.type = STT_FUNC;
-
- symbol.align = STA_NONE;
- symbol.flags = STF_UNDEFINED;
- symbol.name = pProc->sName;
- symbol.value = pProc->sParm.p.label;
- symbol.size = 0;
-
- /* Add the symbol to the symbol table */
-
- pProc->sParm.p.symIndex = poffAddSymbol(poffHandle, &symbol);
-}
+/********************************************************************** + * pgen.c + * P-Code generation logic + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + **********************************************************************/ + +/********************************************************************** + * Included Files + **********************************************************************/ + +#include <stdint.h> +#include <stdio.h> +#include <string.h> +#include <errno.h> + +#include "config.h" /* Configuration */ +#include "keywords.h" /* Standard types */ +#include "pasdefs.h" /* Common types */ +#include "ptdefs.h" /* Token / symbol table definitions */ +#include "podefs.h" /* Logical opcode definitions */ +#include "pedefs.h" /* error code definitions */ + +#include "pas.h" /* Global variables */ +#include "poff.h" /* For POFF file format */ +#include "pofflib.h" /* For poff*() functions*/ +#include "pinsn.h" /* (DEBUG only) */ +#include "perr.h" /* error() */ + +#include "pproc.h" /* for actualParameterSize */ +#include "pgen.h" /* (to verify prototypes in this file) */ + +/********************************************************************** + * Pre-processor Definitions + **********************************************************************/ + +#define UNDEFINED_LEVEL (-1) +#define INVALID_PCODE (-1) + +#define LEVEL_DEFINED(l) ((int32_t)(l) >= 0) +#define PCODE_VALID(p) ((int32_t)(p) >= 0) + +/********************************************************************** + * Global Variables + **********************************************************************/ + +/********************************************************************** + * Private Variables + **********************************************************************/ + +static int32_t g_currentStackLevelReference = UNDEFINED_LEVEL; +static uint32_t g_nStackLevelReferenceChanges = 0; + +/*********************************************************************** + * Private Function Prototypes + ***********************************************************************/ + +/*********************************************************************** + * Private Functions + ***********************************************************************/ + +/***********************************************************************/ +/* Generate a stack reference opcode to a global variable residing at + * static nesting level zero. + */ + +static void +pas_GenerateLevel0StackReference(enum pcode_e eOpCode, STYPE *pVar) +{ + /* Sanity checking. Double check nesting level and also since this is + * a level zero reference, then the offset must be positive + */ + + if ((pVar->sLevel != 0) || (pVar->sParm.v.offset < 0)) + { + error(eHUH); + } + else + { + /* Generate the P-code */ + + insn_GenerateDataOperation(eOpCode, pVar->sParm.v.offset); + + /* If the variable is undefined, also generate a relocation + * record. + */ + + if ((pVar->sParm.v.flags & SVAR_EXTERNAL) != 0) + { + (void)poffAddRelocation(poffHandle, RLT_LDST, + pVar->sParm.v.symIndex, 0); + } + } +} + +/***********************************************************************/ +/* There are some special P-codes for accessing stack data at static + * nesting level 0. Check if the specified opcode is one of those. If + * so, return the mapped opcode. Otherwise, return INVALID_PCODE. + */ + +static int32_t +pas_GetLevel0Opcode(enum pcode_e eOpCode) +{ + switch (eOpCode) + { + case opLDS: return opLD; + case opLDSH: return opLDH; + case opLDSB: return opLDB; + case opLDSM: return opLDM; + case opSTS: return opST; + case opSTSB: return opSTB; + case opSTSM: return opSTM; + case opLDSX: return opLDX; + case opLDSXB: return opLDXB; + case opLDSXM: return opLDXM; + case opSTSX: return opSTX; + case opSTSXB: return opSTXB; + case opSTSXM: return opSTXM; + case opLAS: return opLA; + case opLASX: return opLAX; + default: return INVALID_PCODE; + } +} + +/***********************************************************************/ +/* A new static nesting level has been encountered. Check if we need + * to reset the level stack pointer (LSP) register (assuming that the + * architecutre has one). + */ + +static void +pas_SetLevelStackPointer(uint32_t dwLevel) +{ + if (dwLevel != g_currentStackLevelReference) + { + /* Set the level stack pointer (LSP) register */ + + insn_SetStackLevel(dwLevel); + + /* Remember the setting so that we do not reset the LSP until + * the level changes (or it is invalidated). + */ + + g_currentStackLevelReference = dwLevel; + g_nStackLevelReferenceChanges++; + } +} + +/*********************************************************************** + * Public Functions + ***********************************************************************/ + +/***********************************************************************/ +/* Return the current setting of the level stack pointer (LSP) register + * -- assuming that the underlying architecure may have one. + */ + +int32_t pas_GetCurrentStackLevel(void) +{ + return g_currentStackLevelReference; +} + +/***********************************************************************/ +/* Invalidate the current stack level register setting. This will cause + * us to reset the LSP when the next stack level reference is encountered. + */ + +void pas_InvalidateCurrentStackLevel(void) +{ + g_currentStackLevelReference = UNDEFINED_LEVEL; + g_nStackLevelReferenceChanges++; +} + +/***********************************************************************/ +/* Set the stack level pointer to known value. This is done when in + * while and for loop processing. The value of the LSP will be that + * as sampled at the top of the lop not necessarily the value at the + * bottom of the loop. + */ + +void pas_SetCurrentStackLevel(int32_t dwLsp) +{ + g_currentStackLevelReference = dwLsp; + g_nStackLevelReferenceChanges++; +} + +/***********************************************************************/ +/* Get the number of changes made to the level stack pointer. This is + * useful by compiler logic to determine if the stack level pointer was + * ever changed by any logic path. + */ + +uint32_t pas_GetNStackLevelChanges(void) +{ + return g_nStackLevelReferenceChanges; +} + +/***********************************************************************/ +/* Generate the most simple of all P-codes */ + +void pas_GenerateSimple(enum pcode_e eOpCode) +{ + insn_GenerateSimple(eOpCode); +} + +/***********************************************************************/ +/* Generate a P-code with a single data argument */ + +void pas_GenerateDataOperation(enum pcode_e eOpCode, int32_t dwData) +{ + insn_GenerateDataOperation(eOpCode, dwData); +} + +/***********************************************************************/ +/* This function is called just before a multiple register operation is + * is generated. This should generate logic to specify the size of the + * multiple register operation (in bytes, not registers). This may translate + * into different operations on different architectures. Typically, + * this would generate a push of the size onto the stack or, perhaps, + * setting of a dedicated count register. + */ + +void pas_GenerateDataSize(int32_t dwDataSize) +{ + insn_GenerateDataSize(dwDataSize); +} + +/***********************************************************************/ +/* Generate a floating point operation */ + +void pas_GenerateFpOperation(uint8_t fpOpcode) +{ + insn_GenerateFpOperation(fpOpcode); +} + +/***********************************************************************/ +/* Generate an IO operation */ + +void pas_GenerateIoOperation(uint16_t ioOpcode, uint16_t fileNumber) +{ + insn_GenerateIoOperation(ioOpcode, fileNumber); +} + +/***********************************************************************/ +/* Generate a psuedo call to a built-in, standard pascal function */ + +void pas_BuiltInFunctionCall(uint16_t libOpcode) +{ + insn_BuiltInFunctionCall(libOpcode); +} + +/***********************************************************************/ +/* Generate a reference to data on the data stack using the specified + * level and offset. + */ + +void pas_GenerateLevelReference(enum pcode_e eOpCode, uint16_t wLevel, + int32_t dwOffset) +{ + /* Is this variable declared at level 0 (i.e., it has global scope) + * that is being offset via a nesting level? + */ + + if (wLevel == 0) + { + int32_t level0Opcode = pas_GetLevel0Opcode(eOpCode); + if (PCODE_VALID(level0Opcode)) + { + insn_GenerateDataOperation(level0Opcode, dwOffset); + return; + } + } + + /* We get here if the reference is at some static nesting level + * other that zero OR if there is no special PCode to reference + * data at static nesting level 0 for this operation. + * + * Check if we have to change the level stack pointer (LSP) register + * (assuming that the architecture has one). + */ + + pas_SetLevelStackPointer(wLevel); + + /* Then generate the opcode passing the level in the event that the + * architecture does not have an LSP. + */ + + insn_GenerateLevelReference(eOpCode, wLevel, dwOffset); +} + +/***********************************************************************/ +/* Generate a stack reference opcode, handling references to undefined + * stack offsets. + */ + +void pas_GenerateStackReference(enum pcode_e eOpCode, STYPE *pVar) +{ + /* Is this variable declared at level 0 (i.e., it has global scope) + * that is being offset via a nesting level? + */ + + if (pVar->sLevel == 0) + { + int32_t level0Opcode = pas_GetLevel0Opcode(eOpCode); + if (PCODE_VALID(level0Opcode)) + { + pas_GenerateLevel0StackReference(level0Opcode, pVar); + return; + } + } + + /* We get here if the reference is at some static nesting level + * other that zero OR if there is no special PCode to reference + * data at static nesting level 0 for this operation. + * + * Check if we have to change the level stack pointer (LSP) register + * (assuming that the architecture has one). + */ + + pas_SetLevelStackPointer(pVar->sLevel); + + /* Generate the P-Code at the defined offset and with the specified + * static level offset (in case that the architecture does not have + * an LSP) + */ + + insn_GenerateLevelReference(eOpCode, (level - pVar->sLevel), + pVar->sParm.v.offset); +} + +/***********************************************************************/ +/* Generate a procedure call and an associated relocation record if the + * called procedure is external. + */ + +void +pas_GenerateProcedureCall(STYPE *pProc) +{ + /* sLevel is the level at which the procedure was declared. We need + * to set the SLP to this value prior to the call (on some architectures + * where the SLP is pushed onto the stack by the procedure + * call). + */ + + pas_SetLevelStackPointer(pProc->sLevel); + + /* Then generate the procedure call (passing the level again for those + * architectures that do not support the SLP. + */ + + insn_GenerateProcedureCall(pProc->sLevel, pProc->sParm.p.label); + + /* If the variable is undefined, also generate a relocation + * record. + */ + +#if 0 /* Not yet */ + if ((pVar->sParm.p.flags & SVAR_EXTERNAL) != 0) + { + /* For now */ +# error "Don't know what last parameter should be" + (void)poffAddRelocation(poffHandle, RLT_PCAL, + pVar->sParm.p.symIndex, + 0); + } +#endif + + /* Any logic after the procedure/function call return must assume + * that the last level reference is unknown. + */ + + pas_InvalidateCurrentStackLevel(); +} + +/***********************************************************************/ + +void pas_GenerateLineNumber(uint16_t wIncludeNumber, uint32_t dwLineNumber) +{ + insn_GenerateLineNumber(wIncludeNumber, dwLineNumber); +} + +/***********************************************************************/ + +void pas_GenerateDebugInfo(STYPE *pProc, uint32_t dwReturnSize) +{ + int i; + + /* Allocate a container to pass the proc information to the library */ + + uint32_t nparms = pProc->sParm.p.nParms; + poffLibDebugFuncInfo_t *pContainer = poffCreateDebugInfoContainer(nparms); + + /* Put the proc information into the container */ + + pContainer->value = pProc->sParm.p.label; + pContainer->retsize = dwReturnSize; + pContainer->nparms = nparms; + + /* Add the argument information to the container */ + + for (i = 0; i < nparms; i++) + { + pContainer->argsize[i] = actualParameterSize(pProc, i+1); + } + + /* Add the contained information to the library */ + + poffAddDebugFuncInfo(poffHandle, pContainer); + + /* Release the container */ + + poffReleaseDebugFuncContainer(pContainer); +} + +/***********************************************************************/ +/* Generate description of a level 0 stack variable that can be + * exported by a unit. + */ + +void pas_GenerateStackExport(STYPE *pVar) +{ + poffLibSymbol_t symbol; + +#if CONFIG_DEBUG + /* Get the parent type of the variable */ + + STYPE *typePtr = pVar->sParm.v.parent; + + /* Perform some sanity checking: + * - Must have a parent type + * - Must not be declared external + * - Must be declared at static nesting level zero + */ + + if ((!typePtr) || + ((pVar->sParm.v.flags & SVAR_EXTERNAL) != 0) || + (pVar->sLevel != 0)) + { + error(eSYMTABINTERNAL); + } +#endif + + /* Create the symbol structure */ + + symbol.type = STT_DATA; + symbol.align = STA_8BIT; /* for now */ + symbol.flags = STF_NONE; + symbol.name = pVar->sName; + symbol.value = pVar->sParm.v.offset; + symbol.size = pVar->sParm.v.size; + + /* Add the symbol to the symbol table */ + + (void)poffAddSymbol(poffHandle, &symbol); +} + +/***********************************************************************/ +/* Generate description of a level 0 stack variable that must be + * imported by a program or unit from a unit. + */ + +void pas_GenerateStackImport(STYPE *pVar) +{ + poffLibSymbol_t symbol; + +#if CONFIG_DEBUG + /* Get the parent type of the variable */ + + STYPE *typePtr = pVar->sParm.v.parent; + + /* Perform some sanity checking + * - Must have a parent type + * - Must be declared external + * - Must be declared at static nesting level zero + */ + + if ((!typePtr) || + ((pVar->sParm.v.flags & SVAR_EXTERNAL) == 0) || + (pVar->sLevel != 0)) + { + error(eSYMTABINTERNAL); + } +#endif + + /* Create the symbol structure */ + + symbol.type = STT_DATA; + symbol.align = STA_8BIT; /* for now */ + symbol.flags = STF_UNDEFINED; + symbol.name = pVar->sName; + symbol.value = pVar->sParm.v.offset; /* for now */ + symbol.size = pVar->sParm.v.size; + + /* Add the symbol to the symbol table */ + + pVar->sParm.v.symIndex = poffAddSymbol(poffHandle, &symbol); +} + +/***********************************************************************/ +/* Generate description of a level 0 procedure or function that can be + * exported by a unit. + */ + +void pas_GenerateProcExport(STYPE *pProc) +{ + poffLibSymbol_t symbol; + +#if CONFIG_DEBUG + /* Get the parent type of the function (assuming it is a function) */ + + STYPE *typePtr = pProc->sParm.p.parent; + + /* Perform some sanity checking */ + + /* Check for a function reference which must have a valid parent type */ + + if ((pProc->sKind == sFUNC) && (typePtr != NULL)); + + /* Check for a procedure reference which must not have a valid type */ + + else if ((pProc->sKind == sPROC) && (typePtr == NULL)); + + /* Anything else is an error */ + + else + error(eSYMTABINTERNAL); + + /* The function / procedure should NOT be declared external and + * only procedures declared at static nesting level zero can + * be exported. + */ + + if (((pProc->sParm.p.flags & SPROC_EXTERNAL) != 0) || + (pProc->sLevel != 0)) + error(eSYMTABINTERNAL); +#endif + + /* Everthing looks okay. Create the symbol structure */ + + if (pProc->sKind == sPROC) + symbol.type = STT_PROC; + else + symbol.type = STT_FUNC; + + symbol.align = STA_NONE; + symbol.flags = STF_NONE; + symbol.name = pProc->sName; + symbol.value = pProc->sParm.p.label; + symbol.size = 0; + + /* Add the symbol to the symbol table */ + + (void)poffAddSymbol(poffHandle, &symbol); +} + +/***********************************************************************/ +/* Generate description of a level 0 procedure or function that must be + * imported by a program or unit from a unit. + */ + +void pas_GenerateProcImport(STYPE *pProc) +{ + poffLibSymbol_t symbol; + +#if CONFIG_DEBUG + /* Get the parent type of the function (assuming it is a function) */ + + STYPE *typePtr = pProc->sParm.p.parent; + + /* Perform some sanity checking */ + + /* Check for a function reference which must have a valid parent type */ + + if ((pProc->sKind == sFUNC) && (typePtr != NULL)); + + /* Check for a procedure reference which must not have a valid type */ + + else if ((pProc->sKind == sPROC) && (typePtr == NULL)); + + /* Anything else is an error */ + + else + error(eSYMTABINTERNAL); + + /* The function / procedure should also be declared external and + * only procedures declared at static nesting level zero can + * be exported. + */ + + if (((pProc->sParm.p.flags & SPROC_EXTERNAL) == 0) || + (pProc->sLevel != 0)) + error(eSYMTABINTERNAL); +#endif + + /* Everthing looks okay. Create the symbol structure */ + + if (pProc->sKind == sPROC) + symbol.type = STT_PROC; + else + symbol.type = STT_FUNC; + + symbol.align = STA_NONE; + symbol.flags = STF_UNDEFINED; + symbol.name = pProc->sName; + symbol.value = pProc->sParm.p.label; + symbol.size = 0; + + /* Add the symbol to the symbol table */ + + pProc->sParm.p.symIndex = poffAddSymbol(poffHandle, &symbol); +} diff --git a/misc/pascal/pascal/pgen.h b/misc/pascal/pascal/pgen.h index 055e14eb3c..3a6412452e 100644 --- a/misc/pascal/pascal/pgen.h +++ b/misc/pascal/pascal/pgen.h @@ -1,92 +1,89 @@ -/***************************************************************************
- * pgen.h
- * External Declarations associated with pgen.c
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************************/
-
-#ifndef __PGEN_H
-#define __PGEN_H
-
-/***************************************************************************
- * Compilation Switches
- ***************************************************************************/
-
-/***************************************************************************
- * Included Files
- ***************************************************************************/
-
-#include "podefs.h"
-
-/***************************************************************************
- * Definitions
- ***************************************************************************/
-
-/***************************************************************************
- * Global Types
- ***************************************************************************/
-
-/***************************************************************************
- * Global Variable Prototypes
- ***************************************************************************/
-
-/***************************************************************************
- * Global Function Prototypes
- ***************************************************************************/
-
-extern sint32 pas_GetCurrentStackLevel(void);
-extern void pas_InvalidateCurrentStackLevel(void);
-extern void pas_SetCurrentStackLevel(sint32 dwLsp);
-extern uint32 pas_GetNStackLevelChanges(void);
-
-extern void pas_GenerateSimple(enum pcode_e eOpCode);
-extern void pas_GenerateDataOperation(enum pcode_e eOpCode, sint32 dwData);
-extern void pas_GenerateDataSize(sint32 dwDataSize);
-extern void pas_GenerateFpOperation(ubyte fpOpcode);
-extern void pas_GenerateIoOperation(uint16 ioOpcode, uint16 fileNumber);
-extern void pas_BuiltInFunctionCall(uint16 libOpcode);
-extern void pas_GenerateLevelReference(enum pcode_e eOpCode, uint16 wLevel,
- sint32 dwOffset);
-extern void pas_GenerateStackReference(enum pcode_e eOpCode, STYPE *pVarPtr);
-extern void pas_GenerateProcedureCall(STYPE *pProcPtr);
-extern void pas_GenerateLineNumber(uint16 wIncludeNumber,
- uint32 dwLineNumber);
-extern void pas_GenerateStackExport(STYPE *pVarPtr);
-extern void pas_GenerateStackImport(STYPE *pVarPtr);
-extern void pas_GenerateProcedureCall(STYPE *pProcPtr);
-extern void pas_GenerateDebugInfo(STYPE *pProcPtr, uint32 dwReturnSize);
-extern void pas_GenerateProcExport(STYPE *pProcPtr);
-extern void pas_GenerateProcImport(STYPE *pProcPtr);
-extern void pas_GeneratePoffOutput(void);
-
-#endif /* __PGEN_H */
-
+/*************************************************************************** + * pgen.h + * External Declarations associated with pgen.c + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************************/ + +#ifndef __PGEN_H +#define __PGEN_H + +/*************************************************************************** + * Included Files + ***************************************************************************/ + +#include <stdint.h> +#include "podefs.h" + +/*************************************************************************** + * Pre-processor Definitions + ***************************************************************************/ + +/*************************************************************************** + * Global Types + ***************************************************************************/ + +/*************************************************************************** + * Global Variable Prototypes + ***************************************************************************/ + +/*************************************************************************** + * Global Function Prototypes + ***************************************************************************/ + +extern int32_t pas_GetCurrentStackLevel(void); +extern void pas_InvalidateCurrentStackLevel(void); +extern void pas_SetCurrentStackLevel(int32_t dwLsp); +extern uint32_t pas_GetNStackLevelChanges(void); + +extern void pas_GenerateSimple(enum pcode_e eOpCode); +extern void pas_GenerateDataOperation(enum pcode_e eOpCode, int32_t dwData); +extern void pas_GenerateDataSize(int32_t dwDataSize); +extern void pas_GenerateFpOperation(uint8_t fpOpcode); +extern void pas_GenerateIoOperation(uint16_t ioOpcode, uint16_t fileNumber); +extern void pas_BuiltInFunctionCall(uint16_t libOpcode); +extern void pas_GenerateLevelReference(enum pcode_e eOpCode, uint16_t wLevel, + int32_t dwOffset); +extern void pas_GenerateStackReference(enum pcode_e eOpCode, STYPE *pVarPtr); +extern void pas_GenerateProcedureCall(STYPE *pProcPtr); +extern void pas_GenerateLineNumber(uint16_t wIncludeNumber, + uint32_t dwLineNumber); +extern void pas_GenerateStackExport(STYPE *pVarPtr); +extern void pas_GenerateStackImport(STYPE *pVarPtr); +extern void pas_GenerateProcedureCall(STYPE *pProcPtr); +extern void pas_GenerateDebugInfo(STYPE *pProcPtr, uint32_t dwReturnSize); +extern void pas_GenerateProcExport(STYPE *pProcPtr); +extern void pas_GenerateProcImport(STYPE *pProcPtr); +extern void pas_GeneratePoffOutput(void); + +#endif /* __PGEN_H */ + diff --git a/misc/pascal/pascal/pprgm.c b/misc/pascal/pascal/pprgm.c index d56ba7b097..e822e18a17 100644 --- a/misc/pascal/pascal/pprgm.c +++ b/misc/pascal/pascal/pprgm.c @@ -1,264 +1,265 @@ -/**********************************************************************
- * pas.c
- * main - process PROGRAM
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- **********************************************************************/
-
-/**********************************************************************
- * Included Files
- **********************************************************************/
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <ctype.h>
-#include <string.h>
-#include <errno.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "podefs.h"
-#include "pedefs.h"
-#include "poff.h" /* FHT_ definitions */
-
-#include "pas.h" /* for globals + openNestedFile */
-#include "pblck.h" /* for block() */
-#include "pgen.h" /* for pas_Generate*() */
-#include "ptkn.h" /* for getToken() */
-#include "ptbl.h" /* for addFile() */
-#include "pofflib.h" /* For poff*() functions*/
-#include "paslib.h" /* for extension() */
-#include "perr.h" /* for error() */
-#include "punit.h" /* for unit() */
-#include "pprgm.h"
-
-/**********************************************************************
- * Definitions
- **********************************************************************/
-
-/**********************************************************************
- * Global Variables
- **********************************************************************/
-
-/**********************************************************************
- * Private Variables
- **********************************************************************/
-
-/***********************************************************************
- * Private Function Prototypes
- ***********************************************************************/
-
-/***********************************************************************
- * Private Functions
- ***********************************************************************/
-
-/***********************************************************************
- * Public Functions
- ***********************************************************************/
-
-void program(void)
-{
- char *pgmname = NULL;
-
- TRACE(lstFile, "[program]");
-
- /* FORM: program = program-heading ';' [uses-section ] block '.'
- * FORM: program-heading = 'program' identifier [ '(' identifier-list ')' ]
- *
- * On entry, 'program' has already been identified and token refers to
- * the next token after 'program'
- */
-
- if (token != tIDENT) error(eIDENT); /* Verify <program name> */
- else
- {
- pgmname = tkn_strt; /* Save program name */
- getToken();
- } /* end else */
-
- /* Process optional file list (allow re-declaration of INPUT & OUTPUT) */
-
- if (token == '(')
- {
- do
- {
- getToken();
- if (token == tIDENT)
- {
- if ((++nfiles) > MAX_FILES) fatal(eOVF);
- (void)addFile(tkn_strt, nfiles);
- stringSP = tkn_strt;
- getToken();
- } /* end if */
- else if ((token == sFILE) && !(tknPtr->sParm.fileNumber))
- getToken();
- else
- error(eIDENT);
- }
- while (token == ',');
- if (token != ')') error(eRPAREN);
- else getToken();
- } /* End if */
-
- /* Make sure that a semicolon follows the program-heading */
-
- if (token != ';') error(eSEMICOLON);
- else getToken();
-
- /* Set the POFF file header type */
-
- poffSetFileType(poffHandle, FHT_PROGRAM, nfiles, pgmname);
- poffSetArchitecture(poffHandle, FHA_PCODE);
-
- /* Discard the program name string */
-
- stringSP = pgmname;
-
- /* Process the optional 'uses-section'
- * FORM: uses-section = 'uses' [ uses-unit-list ] ';'
- */
-
- if (token == tUSES)
- {
- getToken();
- usesSection();
- }
-
- /* Process the block */
-
- block();
- if (token != '.') error(ePERIOD);
- pas_GenerateSimple(opEND);
-} /* end program */
-
-/***********************************************************************/
-
-void usesSection(void)
-{
- uint16 saveToken;
- char defaultUnitFileName[FNAME_SIZE + 1];
- char *unitFileName = NULL;
- char *saveTknStrt;
- char *unitName;
-
- TRACE(lstFile, "[usesSection]");
-
- /* FORM: uses-section = 'uses' [ uses-unit-list ] ';'
- * FORM: uses-unit-list = unit-import {';' uses-unit-list }
- * FORM: unit-import = identifier ['in' non-empty-string ]
- *
- * On entry, token will point to the token just after
- * the 'uses' reservers word.
- */
-
- while (token == tIDENT)
- {
- /* Save the unit name identifier and skip over the identifier */
-
- unitName = tkn_strt;
- getToken();
-
- /* Check for the optional 'in' */
-
- saveTknStrt = tkn_strt;
- if (token == tIN)
- {
- /* Skip over 'in' and verify that a string constant representing
- * the file name follows.
- */
-
- getToken();
- if (token != tSTRING_CONST) error(eSTRING);
- else
- {
- /* Save the unit file name and skip to the
- * next token.
- */
-
- unitFileName = tkn_strt;
- saveTknStrt = tkn_strt;
- getToken();
- }
- }
-
- /* In any event, make sure that we have a non-NULL unit
- * file name.
- */
-
- if (!unitFileName)
- {
- /* Create a default filename */
-
- (void)extension(unitName, ".pas", defaultUnitFileName, 1);
- unitFileName = defaultUnitFileName;
- }
-
- /* Open the unit file */
-
- saveToken = token;
- openNestedFile(unitFileName);
- FP->kind = eIsUnit;
- FP->section = eIsOtherSection;
-
- /* Verify that this is a unit file */
-
- if (token != tUNIT) error(eUNIT);
- else getToken();
-
- /* Release the file name from the string stack */
-
- stringSP = saveTknStrt;
-
- /* Verify that the file provides the unit that we are looking
- * for (only one unit per file is supported)
- */
-
- if (token != tIDENT) error(eIDENT);
- else if (strcmp(unitName, tkn_strt) != 0) error(eUNITNAME);
-
- /* Parse the interface from the unit file (token must refer
- * to the unit name on entry into unit().
- */
-
- unitInterface();
- closeNestedFile();
-
- /* Verify the terminating semicolon */
-
- token = saveToken;
- if (token != ';') error(eSEMICOLON);
- else getToken();
- }
-}
-
-/***********************************************************************/
+/********************************************************************** + * pas.c + * main - process PROGRAM + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + **********************************************************************/ + +/********************************************************************** + * Included Files + **********************************************************************/ + +#include <stdint.h> +#include <stdio.h> +#include <stdlib.h> +#include <ctype.h> +#include <string.h> +#include <errno.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "podefs.h" +#include "pedefs.h" +#include "poff.h" /* FHT_ definitions */ + +#include "pas.h" /* for globals + openNestedFile */ +#include "pblck.h" /* for block() */ +#include "pgen.h" /* for pas_Generate*() */ +#include "ptkn.h" /* for getToken() */ +#include "ptbl.h" /* for addFile() */ +#include "pofflib.h" /* For poff*() functions*/ +#include "paslib.h" /* for extension() */ +#include "perr.h" /* for error() */ +#include "punit.h" /* for unit() */ +#include "pprgm.h" + +/********************************************************************** + * Pre-processor Definitions + **********************************************************************/ + +/********************************************************************** + * Global Variables + **********************************************************************/ + +/********************************************************************** + * Private Variables + **********************************************************************/ + +/*********************************************************************** + * Private Function Prototypes + ***********************************************************************/ + +/*********************************************************************** + * Private Functions + ***********************************************************************/ + +/*********************************************************************** + * Public Functions + ***********************************************************************/ + +void program(void) +{ + char *pgmname = NULL; + + TRACE(lstFile, "[program]"); + + /* FORM: program = program-heading ';' [uses-section ] block '.' + * FORM: program-heading = 'program' identifier [ '(' identifier-list ')' ] + * + * On entry, 'program' has already been identified and token refers to + * the next token after 'program' + */ + + if (token != tIDENT) error(eIDENT); /* Verify <program name> */ + else + { + pgmname = tkn_strt; /* Save program name */ + getToken(); + } /* end else */ + + /* Process optional file list (allow re-declaration of INPUT & OUTPUT) */ + + if (token == '(') + { + do + { + getToken(); + if (token == tIDENT) + { + if ((++nfiles) > MAX_FILES) fatal(eOVF); + (void)addFile(tkn_strt, nfiles); + stringSP = tkn_strt; + getToken(); + } /* end if */ + else if ((token == sFILE) && !(tknPtr->sParm.fileNumber)) + getToken(); + else + error(eIDENT); + } + while (token == ','); + if (token != ')') error(eRPAREN); + else getToken(); + } /* End if */ + + /* Make sure that a semicolon follows the program-heading */ + + if (token != ';') error(eSEMICOLON); + else getToken(); + + /* Set the POFF file header type */ + + poffSetFileType(poffHandle, FHT_PROGRAM, nfiles, pgmname); + poffSetArchitecture(poffHandle, FHA_PCODE); + + /* Discard the program name string */ + + stringSP = pgmname; + + /* Process the optional 'uses-section' + * FORM: uses-section = 'uses' [ uses-unit-list ] ';' + */ + + if (token == tUSES) + { + getToken(); + usesSection(); + } + + /* Process the block */ + + block(); + if (token != '.') error(ePERIOD); + pas_GenerateSimple(opEND); +} /* end program */ + +/***********************************************************************/ + +void usesSection(void) +{ + uint16_t saveToken; + char defaultUnitFileName[FNAME_SIZE + 1]; + char *unitFileName = NULL; + char *saveTknStrt; + char *unitName; + + TRACE(lstFile, "[usesSection]"); + + /* FORM: uses-section = 'uses' [ uses-unit-list ] ';' + * FORM: uses-unit-list = unit-import {';' uses-unit-list } + * FORM: unit-import = identifier ['in' non-empty-string ] + * + * On entry, token will point to the token just after + * the 'uses' reservers word. + */ + + while (token == tIDENT) + { + /* Save the unit name identifier and skip over the identifier */ + + unitName = tkn_strt; + getToken(); + + /* Check for the optional 'in' */ + + saveTknStrt = tkn_strt; + if (token == tIN) + { + /* Skip over 'in' and verify that a string constant representing + * the file name follows. + */ + + getToken(); + if (token != tSTRING_CONST) error(eSTRING); + else + { + /* Save the unit file name and skip to the + * next token. + */ + + unitFileName = tkn_strt; + saveTknStrt = tkn_strt; + getToken(); + } + } + + /* In any event, make sure that we have a non-NULL unit + * file name. + */ + + if (!unitFileName) + { + /* Create a default filename */ + + (void)extension(unitName, ".pas", defaultUnitFileName, 1); + unitFileName = defaultUnitFileName; + } + + /* Open the unit file */ + + saveToken = token; + openNestedFile(unitFileName); + FP->kind = eIsUnit; + FP->section = eIsOtherSection; + + /* Verify that this is a unit file */ + + if (token != tUNIT) error(eUNIT); + else getToken(); + + /* Release the file name from the string stack */ + + stringSP = saveTknStrt; + + /* Verify that the file provides the unit that we are looking + * for (only one unit per file is supported) + */ + + if (token != tIDENT) error(eIDENT); + else if (strcmp(unitName, tkn_strt) != 0) error(eUNITNAME); + + /* Parse the interface from the unit file (token must refer + * to the unit name on entry into unit(). + */ + + unitInterface(); + closeNestedFile(); + + /* Verify the terminating semicolon */ + + token = saveToken; + if (token != ';') error(eSEMICOLON); + else getToken(); + } +} + +/***********************************************************************/ diff --git a/misc/pascal/pascal/pproc.c b/misc/pascal/pascal/pproc.c index fcba0cc869..e4e0e02725 100644 --- a/misc/pascal/pascal/pproc.c +++ b/misc/pascal/pascal/pproc.c @@ -1,734 +1,736 @@ -/****************************************************************************
- * pproc.c
- * Standard procedures (all called in pstm.c)
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ****************************************************************************/
-
-/****************************************************************************
- * Included Files
- ****************************************************************************/
-
-#include <stdio.h>
-#include <string.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "podefs.h"
-#include "pedefs.h"
-#include "pxdefs.h"
-
-#include "pas.h"
-#include "pexpr.h"
-#include "pproc.h"
-#include "pgen.h" /* for pas_Generate*() */
-#include "ptkn.h"
-#include "ptbl.h" /* For parent symbol references */
-#include "perr.h"
-
-/****************************************************************************
- * Private Function Prototypes
- ****************************************************************************/
-
-/* Helpers for standard procedures */
-
-static sint16 readProc (void); /* READ procedure */
-static void readText (uint16 fileNumber); /* READ text file */
-static void readlnProc (void); /* READLN procedure */
-static void fileProc (uint16 opcode); /* RESET/REWRITE/PAGE procedure */
-static sint16 writeProc (void); /* WRITE procedure */
-static void writeText (uint16 fileNumber); /* WRITE text file */
-static void writelnProc (void); /* WRITELN procedure */
-
-/* Helpers for less-than-standard procedures */
-
-static void valProc (void); /* VAL procedure */
-
-/****************************************************************************
- * Private Data
- ****************************************************************************/
-
-/* procedure val(const S : string; var V; var Code : word); */
-
-static STYPE valSymbol[4];
-
-/****************************************************************************/
-
-void primeBuiltInProcedures(void)
-{
- /* procedure val(const S : string; var V; var Code : word); */
-
- valSymbol[0].sParm.p.nParms = 3;
- valSymbol[1].sKind = sSTRING;
- valSymbol[1].sParm.p.parent = parentString;
- valSymbol[2].sKind = sVAR_PARM;
- valSymbol[2].sParm.p.parent = parentInteger;
- valSymbol[3].sKind = sVAR_PARM;
- valSymbol[3].sParm.p.parent = parentInteger;
-}
-
-/***********************************************************************/
-
-void builtInProcedure(void)
-{
- TRACE(lstFile, "[builtInProcedure]");
-
- /* Is the token a procedure? */
-
-
- if (token == tPROC)
- {
- /* Yes, process it procedure according to the extended token type */
-
- switch (tknSubType)
- {
- /* Standard Procedures & Functions */
-
- case txPAGE :
- fileProc(xWRITE_PAGE);
- break;
-
- case txREAD :
- getToken();
- (void)readProc();
- break;
-
- case txREADLN :
- readlnProc();
- break;
-
- case txRESET :
- fileProc(xRESET);
- break;
-
- case txREWRITE :
- fileProc(xREWRITE);
- break;
-
- case txWRITE :
- getToken();
- (void)writeProc();
- break;
-
- case txWRITELN :
- writelnProc();
- break;
-
- case txGET :
- case txNEW :
- case txPACK :
- case txPUT :
- case txUNPACK :
- error(eNOTYET);
- getToken();
- break;
-
- /* less-than-standard procedures */
- case txVAL :
- valProc();
- break;
-
- /* Its not a recognized procedure */
-
- default :
- error(eINVALIDPROC);
- break;
-
- } /* end switch */
- } /* end if */
-} /* end builtInProcedure */
-
-/***********************************************************************/
-
-int actualParameterSize(STYPE *procPtr, int parmNo)
-{
- /* These sizes must agree with the sizes used in actualParameterListg()
- * below.
- */
-
- STYPE *typePtr = procPtr[parmNo].sParm.v.parent;
- switch (typePtr->sKind)
- {
- case sINT :
- case sSUBRANGE :
- case sSCALAR :
- case sSET_OF :
- default:
- return sINT_SIZE;
- break;
- case sCHAR :
- return sCHAR_SIZE;
- break;
- case sREAL :
- return sREAL_SIZE;
- break;
- case sSTRING :
- case sRSTRING :
- return sRSTRING_SIZE;
- break;
- case sARRAY :
- case sRECORD :
- return typePtr->sParm.t.asize;
- break;
- case sVAR_PARM :
- return sPTR_SIZE;
- break;
- }
-}
-
-/***********************************************************************/
-
-int actualParameterList(STYPE *procPtr)
-{
- STYPE *typePtr;
- register int nParms = 0;
- int size = 0;
-
- TRACE(lstFile,"[actualParameterList]");
-
- /* Processes the (optional) actual-parameter-list associated with
- * a function or procedure call:
- *
- * FORM: procedure-method-statement =
- * procedure-method-specifier [ actual-parameter-list ]
- * FORM: function-designator = function-identifier [ actual-parameter-list ]
- *
- *
- * On entry, 'token' refers to the token just AFTER the procedure
- * function identifier.
- *
- * FORM: actual-parameter-list =
- * '(' actual-parameter { ',' actual-parameter } ')'
- * FORM: actual-parameter =
- * expression | variable-access |
- * procedure-identifier | function-identifier
- */
-
- /* If this procedure requires parameters, get them and make sure that
- * they match in type and number
- */
-
- if (procPtr->sParm.p.nParms)
- {
- /* If it requires parameters, then the actual-parameter-list must
- * be present and must begin with '('
- */
-
- if (token != '(') error (eLPAREN);
- else getToken();
-
- /* Loop to process the expected number of parameters. The formal
- * argument descriptions follow the procedure/function description
- * as an array of variable declarations. (These sizes below must
- * agree with actualParameterSize() above);
- */
-
- for (nParms = 1; nParms <= procPtr->sParm.p.nParms; nParms++)
- {
- typePtr = procPtr[nParms].sParm.v.parent;
- switch (procPtr[nParms].sKind)
- {
- case sINT :
- expression(exprInteger, typePtr);
- size += sINT_SIZE;
- break;
- case sCHAR :
- expression(exprChar, typePtr);
- size += sCHAR_SIZE;
- break;
- case sREAL :
- expression(exprReal, typePtr);
- size += sREAL_SIZE;
- break;
- case sSTRING :
- case sRSTRING :
- expression(exprString, typePtr);
- size += sRSTRING_SIZE;
- break;
- case sSUBRANGE :
- expression(exprInteger, typePtr);
- size += sINT_SIZE;
- break;
- case sSCALAR :
- expression(exprScalar, typePtr);
- size += sINT_SIZE;
- break;
- case sSET_OF :
- expression(exprSet, typePtr);
- size += sINT_SIZE;
- break;
- case sARRAY :
- expression(exprArray, typePtr);
- size += typePtr->sParm.t.asize;
- break;
- case sRECORD :
- expression(exprRecord, typePtr);
- size += typePtr->sParm.t.asize;
- break;
- case sVAR_PARM :
- if (typePtr)
- {
- switch (typePtr->sParm.t.type)
- {
- case sINT :
- varParm(exprIntegerPtr, typePtr);
- size += sPTR_SIZE;
- break;
- case sBOOLEAN :
- varParm(exprBooleanPtr, typePtr);
- size += sPTR_SIZE;
- break;
- case sCHAR :
- varParm(exprCharPtr, typePtr);
- size += sPTR_SIZE;
- break;
- case sREAL :
- varParm(exprRealPtr, typePtr);
- size += sPTR_SIZE;
- break;
- case sARRAY :
- varParm(exprArrayPtr, typePtr);
- size += sPTR_SIZE;
- break;
- case sRECORD :
- varParm(exprRecordPtr, typePtr);
- size += sPTR_SIZE;
- break;
- default :
- error(eVARPARMTYPE);
- break;
- } /* end switch */
- } /* end if */
- else
- error(eVARPARMTYPE);
- break;
- default :
- error (eNPARMS);
- } /* end switch */
-
- if (nParms < procPtr->sParm.p.nParms)
- {
- if (token != ',') error (eCOMMA);
- else getToken();
- } /* end if */
- } /* end for */
-
- if (token != ')') error (eRPAREN);
- else getToken();
-
- } /* end if */
-
- return size;
-
-} /* end actualParameterList */
-
-/***********************************************************************/
-
-static sint16 readProc(void)
-{
- uint16 fileNumber = 0;
-
- TRACE(lstFile, "[readProc]");
-
- /* FORM:
- * (1) Binary READ: read '(' file-variable ')'
- * (2) Test READ: read read-parameter-list
- * FORM: read-parameter-list =
- * '(' [ file-variable ',' ] variable-access { ',' variable-access } ')'
- */
-
- if (token != '(') error (eLPAREN); /* Skip over '(' */
- else getToken();
-
- /* Get file number */
-
- if (token == sFILE)
- {
- fileNumber = tknPtr->sParm.fileNumber;
- getToken();
- } /* end if */
- if (token == ',') getToken();
-
- /* Determine if this is a text or binary file */
-
- if (!(files [fileNumber].defined)) error (eUNDEFILE);
- else if (files [fileNumber].ftype == sCHAR)
- {
- readText (fileNumber);
- }
- else
- {
- pas_GenerateLevelReference(opLAS, files[fileNumber].flevel, files [fileNumber].faddr);
- pas_GenerateDataOperation(opPUSH, files[fileNumber].fsize);
- pas_GenerateIoOperation(xREAD_BINARY, fileNumber);
- } /* end else */
-
- if (token != ')') error (eRPAREN);
- else getToken();
-
- return (fileNumber);
-} /* end readProc */
-
-/***********************************************************************/
-
-static void readText (uint16 fileNumber)
-{
- STYPE *rPtr;
-
- TRACE(lstFile, "[readText]");
-
- /* The general form is <VAR parm>, <VAR parm>,... */
-
- for (;;)
- {
- switch (token)
- {
- /* SPECIAL CASE: Array of type CHAR without indexing */
-
- case sARRAY :
- rPtr = tknPtr->sParm.v.parent;
- if (((rPtr) && (rPtr->sKind == sTYPE)) &&
- (rPtr->sParm.t.type == sCHAR) &&
- (getNextCharacter(TRUE) != '['))
- {
- pas_GenerateStackReference(opLAS, rPtr);
- pas_GenerateDataOperation(opPUSH, rPtr->sParm.v.size);
- pas_GenerateIoOperation(xREAD_STRING, fileNumber);
- pas_GenerateDataOperation(opINDS, -(sPTR_SIZE+sINT_SIZE));
- } /* end if */
-
- /* Otherwise, we fall through to process the ARRAY like any */
- /* expression */
-
- default :
-
- switch (varParm(exprUnknown, NULL))
- {
- case exprIntegerPtr :
- pas_GenerateIoOperation(xREAD_INT, fileNumber);
- pas_GenerateDataOperation(opINDS, -sPTR_SIZE);
- break;
-
- case exprCharPtr :
- pas_GenerateIoOperation(xREAD_CHAR, fileNumber);
- pas_GenerateDataOperation(opINDS, -sPTR_SIZE);
- break;
-
- case exprRealPtr :
- pas_GenerateIoOperation(xREAD_REAL, fileNumber);
- pas_GenerateDataOperation(opINDS, -sPTR_SIZE);
- break;
-
- default :
- error(eINVARG);
- break;
- } /* end switch */
- break;
-
- } /* end switch */
-
- if (token == ',') getToken();
- else return;
-
- } /* end for */
-
-} /* end readText */
-
-/****************************************************************************/
-
-static void readlnProc(void) /* READLN procedure */
-{
- sint32 fileNumber;
-
- TRACE(lstFile, "[readlnProc]");
-
- /* FORM: Just like READ */
-
- getToken();
- if (token == '(')
- fileNumber = readProc();
-
- /* skip to end-of-line mark in the file (NOTE: No check is made,
- * but this is meaningful only for a test file).
- */
-
- pas_GenerateIoOperation(xREADLN, fileNumber);
-
-} /* end readlnProc */
-
-/****************************************************************************/
-/* REWRITE/RESET/PAGE procedure call -- REWRITE sets the file pointer to the
- * beginning of the file and prepares the file for write access; RESET is
- * similar except that it prepares the file for read access; PAGE simply
- * writes a form-feed to the file (no check is made, but is meaningful only
- * for a text file). */
-
-static void fileProc (uint16 opcode)
-{
- TRACE(lstFile, "[fileProc]");
-
- /* FORM: RESET|REWRITE(<file number>) */
-
- getToken();
- if (token != '(') error(eLPAREN);
- else getToken();
- if (token != sFILE) error(eFILE);
- else {
- pas_GenerateIoOperation(opcode, tknPtr->sParm.fileNumber);
- getToken();
- if (token != ')') error(eRPAREN);
- else getToken();
- } /* end else */
-
-} /* End fileProc */
-
-/***********************************************************************/
-
-static sint16 writeProc(void)
-{
- uint16 fileNumber = 0;
-
- TRACE(lstFile, "[writeProc]");
-
- /* FORM: (1) Binary WRITE: WRITE(<fileNumber>);
- * (2) Test WRITE: WRITE([<fileNumber>], arg1 [,arg2 [...]]) */
-
- if (token != '(') error(eLPAREN); /* Skip over '(' */
- else getToken();
-
- /* Get file number */
-
- if (token == sFILE) {
- fileNumber = tknPtr->sParm.fileNumber;
- getToken();
- } /* end if */
- if (token == ',') getToken();
-
- /* Determine if this is a text or binary file */
-
- if (!(files [fileNumber].defined)) error(eUNDEFILE);
- else if (files [fileNumber].ftype == sCHAR)
- writeText(fileNumber);
- else {
- pas_GenerateLevelReference(opLAS, files[fileNumber].flevel, files [fileNumber].faddr);
- pas_GenerateDataOperation(opPUSH, files[fileNumber].fsize);
- pas_GenerateIoOperation(xWRITE_BINARY, fileNumber);
- } /* end else */
-
- if (token != ')') error(eRPAREN);
- else getToken();
- return(fileNumber);
-} /* end writeProc */
-
-/***********************************************************************/
-
-static void writeText (uint16 fileNumber)
-{
- exprType writeType;
- STYPE *wPtr;
-
- TRACE(lstFile, "[writeText]");
-
- for (;;)
- {
- /* The general form is <expression>, <expression>, ... However,
- * there are a few unique things that must be handled as special
- * cases
- */
-
- switch (token)
- {
- /* const strings -- either literal constants (tSTRING_CONST)
- * or defined string constant symbols (sSTRING_CONST)
- */
-
- case tSTRING_CONST :
- {
- /* Add the literal string constant to the RO data section
- * and receive the offset to the data.
- */
-
- uint32 offset = poffAddRoDataString(poffHandle, tkn_strt);
-
- /* Set the offset and size on the stack (order is important) */
-
- pas_GenerateDataOperation(opLAC, (uint16)offset);
- pas_GenerateDataOperation(opPUSH, strlen(tkn_strt));
-
- pas_GenerateIoOperation(xWRITE_STRING, fileNumber);
- pas_GenerateDataOperation(opINDS, -(sPTR_SIZE + sINT_SIZE));
- stringSP = tkn_strt;
- getToken();
- }
- break;
-
- case sSTRING_CONST :
- pas_GenerateDataOperation(opLAC, (uint16)tknPtr->sParm.s.offset);
- pas_GenerateDataOperation(opPUSH, (uint16)tknPtr->sParm.s.size);
- pas_GenerateIoOperation(xWRITE_STRING, fileNumber);
- pas_GenerateDataOperation(opINDS, -(sPTR_SIZE + sINT_SIZE));
- getToken();
- break;
-
- /* Array of type CHAR without indexing */
-
- case sARRAY :
- wPtr = tknPtr->sParm.v.parent;
- if (((wPtr) && (wPtr->sKind == sTYPE)) &&
- (wPtr->sParm.t.type == sCHAR) &&
- (getNextCharacter(TRUE) != '['))
- {
- pas_GenerateStackReference(opLAS, wPtr);
- pas_GenerateDataOperation(opPUSH, wPtr->sParm.v.size);
- pas_GenerateIoOperation(xWRITE_STRING, fileNumber);
- pas_GenerateDataOperation(opINDS, -(sPTR_SIZE + sINT_SIZE));
- break;
- } /* end if */
-
- /* Otherwise, we fall through to process the ARRAY like any */
- /* expression */
-
- default :
- writeType = expression(exprUnknown, NULL);
- switch (writeType)
- {
- case exprInteger :
- pas_GenerateIoOperation(xWRITE_INT, fileNumber);
- pas_GenerateDataOperation(opINDS, -sINT_SIZE);
- break;
-
- case exprBoolean :
- error(eNOTYET);
- break;
-
- case exprChar :
- pas_GenerateIoOperation(xWRITE_CHAR, fileNumber);
- pas_GenerateDataOperation(opINDS, -sINT_SIZE);
- break;
-
- case exprReal :
- pas_GenerateIoOperation(xWRITE_REAL, fileNumber);
- pas_GenerateDataOperation(opINDS, -sREAL_SIZE);
- break;
-
- case exprString :
- case exprStkString :
- pas_GenerateIoOperation(xWRITE_STRING, fileNumber);
- pas_GenerateDataOperation(opINDS, -sRSTRING_SIZE);
- break;
-
- default :
- error(eWRITEPARM);
- break;
-
- } /* end switch */
- break;
-
- } /* end switch */
-
- if (token == ',') getToken();
- else return;
-
- } /* end for */
-
-} /* end writeText */
-
-/****************************************************************************/
-
-static void writelnProc(void) /* WRITELN procedure */
-{
- sint32 fileNumber = 0;
-
- TRACE(lstFile, "[writelnProc]");
-
- /* FORM: Just like WRITE */
-
- getToken();
- if (token == '(')
- {
- fileNumber = writeProc();
- }
-
- /* Skip to past end-of-line mark in the file (NOTE: No check is made, but
- * this is meaningful only for a test file).
- */
-
- pas_GenerateIoOperation(xWRITELN, fileNumber);
-
-} /* end writelnProc */
-
-/****************************************************************************/
-
-static void valProc(void) /* VAL procedure */
-{
- int size;
-
- TRACE(lstFile, "[valProc]");
-
- /* Declaration:
- * procedure val(const S : string; var V; var Code : word);
- *
- * Description:
- * val() converts the value represented in the string S to a numerical
- * value, and stores this value in the variable V, which can be of type
- * Longint, Real and Byte. If the conversion isn��t succesfull, then the
- * parameter Code contains the index of the character in S which
- * prevented the conversion. The string S is allowed to contain spaces
- * in the beginning.
- *
- * The string S can contain a number in decimal, hexadecimal, binary or
- * octal format, as described in the language reference.
- *
- * Errors:
- * If the conversion doesn��t succeed, the value of Code indicates the
- * position where the conversion went wrong.
- */
-
- /* Skip over the 'val' identifer */
-
- getToken();
-
- /* Setup the actual-parameter-list */
-
- size = actualParameterList(valSymbol);
-
- /* Generate the built-in procedure call. NOTE the procedure call
- * logic will release the parameters from the stack saving us from
- * having to generate the INDS here.
- */
-
- pas_BuiltInFunctionCall(lbVAL);
-
-} /* end writelnProc */
-
-/***********************************************************************/
+/**************************************************************************** + * pproc.c + * Standard procedures (all called in pstm.c) + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ****************************************************************************/ + +/**************************************************************************** + * Included Files + ****************************************************************************/ + +#include <stdint.h> +#include <stdbool.h> +#include <stdio.h> +#include <string.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "podefs.h" +#include "pedefs.h" +#include "pxdefs.h" + +#include "pas.h" +#include "pexpr.h" +#include "pproc.h" +#include "pgen.h" /* for pas_Generate*() */ +#include "ptkn.h" +#include "ptbl.h" /* For parent symbol references */ +#include "perr.h" + +/**************************************************************************** + * Private Function Prototypes + ****************************************************************************/ + +/* Helpers for standard procedures */ + +static int16_t readProc (void); /* READ procedure */ +static void readText (uint16_t fileNumber); /* READ text file */ +static void readlnProc (void); /* READLN procedure */ +static void fileProc (uint16_t opcode); /* RESET/REWRITE/PAGE procedure */ +static int16_t writeProc (void); /* WRITE procedure */ +static void writeText (uint16_t fileNumber); /* WRITE text file */ +static void writelnProc (void); /* WRITELN procedure */ + +/* Helpers for less-than-standard procedures */ + +static void valProc (void); /* VAL procedure */ + +/**************************************************************************** + * Private Data + ****************************************************************************/ + +/* procedure val(const S : string; var V; var Code : word); */ + +static STYPE valSymbol[4]; + +/****************************************************************************/ + +void primeBuiltInProcedures(void) +{ + /* procedure val(const S : string; var V; var Code : word); */ + + valSymbol[0].sParm.p.nParms = 3; + valSymbol[1].sKind = sSTRING; + valSymbol[1].sParm.p.parent = parentString; + valSymbol[2].sKind = sVAR_PARM; + valSymbol[2].sParm.p.parent = parentInteger; + valSymbol[3].sKind = sVAR_PARM; + valSymbol[3].sParm.p.parent = parentInteger; +} + +/***********************************************************************/ + +void builtInProcedure(void) +{ + TRACE(lstFile, "[builtInProcedure]"); + + /* Is the token a procedure? */ + + + if (token == tPROC) + { + /* Yes, process it procedure according to the extended token type */ + + switch (tknSubType) + { + /* Standard Procedures & Functions */ + + case txPAGE : + fileProc(xWRITE_PAGE); + break; + + case txREAD : + getToken(); + (void)readProc(); + break; + + case txREADLN : + readlnProc(); + break; + + case txRESET : + fileProc(xRESET); + break; + + case txREWRITE : + fileProc(xREWRITE); + break; + + case txWRITE : + getToken(); + (void)writeProc(); + break; + + case txWRITELN : + writelnProc(); + break; + + case txGET : + case txNEW : + case txPACK : + case txPUT : + case txUNPACK : + error(eNOTYET); + getToken(); + break; + + /* less-than-standard procedures */ + case txVAL : + valProc(); + break; + + /* Its not a recognized procedure */ + + default : + error(eINVALIDPROC); + break; + + } /* end switch */ + } /* end if */ +} /* end builtInProcedure */ + +/***********************************************************************/ + +int actualParameterSize(STYPE *procPtr, int parmNo) +{ + /* These sizes must agree with the sizes used in actualParameterListg() + * below. + */ + + STYPE *typePtr = procPtr[parmNo].sParm.v.parent; + switch (typePtr->sKind) + { + case sINT : + case sSUBRANGE : + case sSCALAR : + case sSET_OF : + default: + return sINT_SIZE; + break; + case sCHAR : + return sCHAR_SIZE; + break; + case sREAL : + return sREAL_SIZE; + break; + case sSTRING : + case sRSTRING : + return sRSTRING_SIZE; + break; + case sARRAY : + case sRECORD : + return typePtr->sParm.t.asize; + break; + case sVAR_PARM : + return sPTR_SIZE; + break; + } +} + +/***********************************************************************/ + +int actualParameterList(STYPE *procPtr) +{ + STYPE *typePtr; + register int nParms = 0; + int size = 0; + + TRACE(lstFile,"[actualParameterList]"); + + /* Processes the (optional) actual-parameter-list associated with + * a function or procedure call: + * + * FORM: procedure-method-statement = + * procedure-method-specifier [ actual-parameter-list ] + * FORM: function-designator = function-identifier [ actual-parameter-list ] + * + * + * On entry, 'token' refers to the token just AFTER the procedure + * function identifier. + * + * FORM: actual-parameter-list = + * '(' actual-parameter { ',' actual-parameter } ')' + * FORM: actual-parameter = + * expression | variable-access | + * procedure-identifier | function-identifier + */ + + /* If this procedure requires parameters, get them and make sure that + * they match in type and number + */ + + if (procPtr->sParm.p.nParms) + { + /* If it requires parameters, then the actual-parameter-list must + * be present and must begin with '(' + */ + + if (token != '(') error (eLPAREN); + else getToken(); + + /* Loop to process the expected number of parameters. The formal + * argument descriptions follow the procedure/function description + * as an array of variable declarations. (These sizes below must + * agree with actualParameterSize() above); + */ + + for (nParms = 1; nParms <= procPtr->sParm.p.nParms; nParms++) + { + typePtr = procPtr[nParms].sParm.v.parent; + switch (procPtr[nParms].sKind) + { + case sINT : + expression(exprInteger, typePtr); + size += sINT_SIZE; + break; + case sCHAR : + expression(exprChar, typePtr); + size += sCHAR_SIZE; + break; + case sREAL : + expression(exprReal, typePtr); + size += sREAL_SIZE; + break; + case sSTRING : + case sRSTRING : + expression(exprString, typePtr); + size += sRSTRING_SIZE; + break; + case sSUBRANGE : + expression(exprInteger, typePtr); + size += sINT_SIZE; + break; + case sSCALAR : + expression(exprScalar, typePtr); + size += sINT_SIZE; + break; + case sSET_OF : + expression(exprSet, typePtr); + size += sINT_SIZE; + break; + case sARRAY : + expression(exprArray, typePtr); + size += typePtr->sParm.t.asize; + break; + case sRECORD : + expression(exprRecord, typePtr); + size += typePtr->sParm.t.asize; + break; + case sVAR_PARM : + if (typePtr) + { + switch (typePtr->sParm.t.type) + { + case sINT : + varParm(exprIntegerPtr, typePtr); + size += sPTR_SIZE; + break; + case sBOOLEAN : + varParm(exprBooleanPtr, typePtr); + size += sPTR_SIZE; + break; + case sCHAR : + varParm(exprCharPtr, typePtr); + size += sPTR_SIZE; + break; + case sREAL : + varParm(exprRealPtr, typePtr); + size += sPTR_SIZE; + break; + case sARRAY : + varParm(exprArrayPtr, typePtr); + size += sPTR_SIZE; + break; + case sRECORD : + varParm(exprRecordPtr, typePtr); + size += sPTR_SIZE; + break; + default : + error(eVARPARMTYPE); + break; + } /* end switch */ + } /* end if */ + else + error(eVARPARMTYPE); + break; + default : + error (eNPARMS); + } /* end switch */ + + if (nParms < procPtr->sParm.p.nParms) + { + if (token != ',') error (eCOMMA); + else getToken(); + } /* end if */ + } /* end for */ + + if (token != ')') error (eRPAREN); + else getToken(); + + } /* end if */ + + return size; + +} /* end actualParameterList */ + +/***********************************************************************/ + +static int16_t readProc(void) +{ + uint16_t fileNumber = 0; + + TRACE(lstFile, "[readProc]"); + + /* FORM: + * (1) Binary READ: read '(' file-variable ')' + * (2) Test READ: read read-parameter-list + * FORM: read-parameter-list = + * '(' [ file-variable ',' ] variable-access { ',' variable-access } ')' + */ + + if (token != '(') error (eLPAREN); /* Skip over '(' */ + else getToken(); + + /* Get file number */ + + if (token == sFILE) + { + fileNumber = tknPtr->sParm.fileNumber; + getToken(); + } /* end if */ + if (token == ',') getToken(); + + /* Determine if this is a text or binary file */ + + if (!(files [fileNumber].defined)) error (eUNDEFILE); + else if (files [fileNumber].ftype == sCHAR) + { + readText (fileNumber); + } + else + { + pas_GenerateLevelReference(opLAS, files[fileNumber].flevel, files [fileNumber].faddr); + pas_GenerateDataOperation(opPUSH, files[fileNumber].fsize); + pas_GenerateIoOperation(xREAD_BINARY, fileNumber); + } /* end else */ + + if (token != ')') error (eRPAREN); + else getToken(); + + return (fileNumber); +} /* end readProc */ + +/***********************************************************************/ + +static void readText (uint16_t fileNumber) +{ + STYPE *rPtr; + + TRACE(lstFile, "[readText]"); + + /* The general form is <VAR parm>, <VAR parm>,... */ + + for (;;) + { + switch (token) + { + /* SPECIAL CASE: Array of type CHAR without indexing */ + + case sARRAY : + rPtr = tknPtr->sParm.v.parent; + if (((rPtr) && (rPtr->sKind == sTYPE)) && + (rPtr->sParm.t.type == sCHAR) && + (getNextCharacter(true) != '[')) + { + pas_GenerateStackReference(opLAS, rPtr); + pas_GenerateDataOperation(opPUSH, rPtr->sParm.v.size); + pas_GenerateIoOperation(xREAD_STRING, fileNumber); + pas_GenerateDataOperation(opINDS, -(sPTR_SIZE+sINT_SIZE)); + } /* end if */ + + /* Otherwise, we fall through to process the ARRAY like any */ + /* expression */ + + default : + + switch (varParm(exprUnknown, NULL)) + { + case exprIntegerPtr : + pas_GenerateIoOperation(xREAD_INT, fileNumber); + pas_GenerateDataOperation(opINDS, -sPTR_SIZE); + break; + + case exprCharPtr : + pas_GenerateIoOperation(xREAD_CHAR, fileNumber); + pas_GenerateDataOperation(opINDS, -sPTR_SIZE); + break; + + case exprRealPtr : + pas_GenerateIoOperation(xREAD_REAL, fileNumber); + pas_GenerateDataOperation(opINDS, -sPTR_SIZE); + break; + + default : + error(eINVARG); + break; + } /* end switch */ + break; + + } /* end switch */ + + if (token == ',') getToken(); + else return; + + } /* end for */ + +} /* end readText */ + +/****************************************************************************/ + +static void readlnProc(void) /* READLN procedure */ +{ + int32_t fileNumber; + + TRACE(lstFile, "[readlnProc]"); + + /* FORM: Just like READ */ + + getToken(); + if (token == '(') + fileNumber = readProc(); + + /* skip to end-of-line mark in the file (NOTE: No check is made, + * but this is meaningful only for a test file). + */ + + pas_GenerateIoOperation(xREADLN, fileNumber); + +} /* end readlnProc */ + +/****************************************************************************/ +/* REWRITE/RESET/PAGE procedure call -- REWRITE sets the file pointer to the + * beginning of the file and prepares the file for write access; RESET is + * similar except that it prepares the file for read access; PAGE simply + * writes a form-feed to the file (no check is made, but is meaningful only + * for a text file). */ + +static void fileProc (uint16_t opcode) +{ + TRACE(lstFile, "[fileProc]"); + + /* FORM: RESET|REWRITE(<file number>) */ + + getToken(); + if (token != '(') error(eLPAREN); + else getToken(); + if (token != sFILE) error(eFILE); + else { + pas_GenerateIoOperation(opcode, tknPtr->sParm.fileNumber); + getToken(); + if (token != ')') error(eRPAREN); + else getToken(); + } /* end else */ + +} /* End fileProc */ + +/***********************************************************************/ + +static int16_t writeProc(void) +{ + uint16_t fileNumber = 0; + + TRACE(lstFile, "[writeProc]"); + + /* FORM: (1) Binary WRITE: WRITE(<fileNumber>); + * (2) Test WRITE: WRITE([<fileNumber>], arg1 [,arg2 [...]]) */ + + if (token != '(') error(eLPAREN); /* Skip over '(' */ + else getToken(); + + /* Get file number */ + + if (token == sFILE) { + fileNumber = tknPtr->sParm.fileNumber; + getToken(); + } /* end if */ + if (token == ',') getToken(); + + /* Determine if this is a text or binary file */ + + if (!(files [fileNumber].defined)) error(eUNDEFILE); + else if (files [fileNumber].ftype == sCHAR) + writeText(fileNumber); + else { + pas_GenerateLevelReference(opLAS, files[fileNumber].flevel, files [fileNumber].faddr); + pas_GenerateDataOperation(opPUSH, files[fileNumber].fsize); + pas_GenerateIoOperation(xWRITE_BINARY, fileNumber); + } /* end else */ + + if (token != ')') error(eRPAREN); + else getToken(); + return(fileNumber); +} /* end writeProc */ + +/***********************************************************************/ + +static void writeText (uint16_t fileNumber) +{ + exprType writeType; + STYPE *wPtr; + + TRACE(lstFile, "[writeText]"); + + for (;;) + { + /* The general form is <expression>, <expression>, ... However, + * there are a few unique things that must be handled as special + * cases + */ + + switch (token) + { + /* const strings -- either literal constants (tSTRING_CONST) + * or defined string constant symbols (sSTRING_CONST) + */ + + case tSTRING_CONST : + { + /* Add the literal string constant to the RO data section + * and receive the offset to the data. + */ + + uint32_t offset = poffAddRoDataString(poffHandle, tkn_strt); + + /* Set the offset and size on the stack (order is important) */ + + pas_GenerateDataOperation(opLAC, (uint16_t)offset); + pas_GenerateDataOperation(opPUSH, strlen(tkn_strt)); + + pas_GenerateIoOperation(xWRITE_STRING, fileNumber); + pas_GenerateDataOperation(opINDS, -(sPTR_SIZE + sINT_SIZE)); + stringSP = tkn_strt; + getToken(); + } + break; + + case sSTRING_CONST : + pas_GenerateDataOperation(opLAC, (uint16_t)tknPtr->sParm.s.offset); + pas_GenerateDataOperation(opPUSH, (uint16_t)tknPtr->sParm.s.size); + pas_GenerateIoOperation(xWRITE_STRING, fileNumber); + pas_GenerateDataOperation(opINDS, -(sPTR_SIZE + sINT_SIZE)); + getToken(); + break; + + /* Array of type CHAR without indexing */ + + case sARRAY : + wPtr = tknPtr->sParm.v.parent; + if (((wPtr) && (wPtr->sKind == sTYPE)) && + (wPtr->sParm.t.type == sCHAR) && + (getNextCharacter(true) != '[')) + { + pas_GenerateStackReference(opLAS, wPtr); + pas_GenerateDataOperation(opPUSH, wPtr->sParm.v.size); + pas_GenerateIoOperation(xWRITE_STRING, fileNumber); + pas_GenerateDataOperation(opINDS, -(sPTR_SIZE + sINT_SIZE)); + break; + } /* end if */ + + /* Otherwise, we fall through to process the ARRAY like any */ + /* expression */ + + default : + writeType = expression(exprUnknown, NULL); + switch (writeType) + { + case exprInteger : + pas_GenerateIoOperation(xWRITE_INT, fileNumber); + pas_GenerateDataOperation(opINDS, -sINT_SIZE); + break; + + case exprBoolean : + error(eNOTYET); + break; + + case exprChar : + pas_GenerateIoOperation(xWRITE_CHAR, fileNumber); + pas_GenerateDataOperation(opINDS, -sINT_SIZE); + break; + + case exprReal : + pas_GenerateIoOperation(xWRITE_REAL, fileNumber); + pas_GenerateDataOperation(opINDS, -sREAL_SIZE); + break; + + case exprString : + case exprStkString : + pas_GenerateIoOperation(xWRITE_STRING, fileNumber); + pas_GenerateDataOperation(opINDS, -sRSTRING_SIZE); + break; + + default : + error(eWRITEPARM); + break; + + } /* end switch */ + break; + + } /* end switch */ + + if (token == ',') getToken(); + else return; + + } /* end for */ + +} /* end writeText */ + +/****************************************************************************/ + +static void writelnProc(void) /* WRITELN procedure */ +{ + int32_t fileNumber = 0; + + TRACE(lstFile, "[writelnProc]"); + + /* FORM: Just like WRITE */ + + getToken(); + if (token == '(') + { + fileNumber = writeProc(); + } + + /* Skip to past end-of-line mark in the file (NOTE: No check is made, but + * this is meaningful only for a test file). + */ + + pas_GenerateIoOperation(xWRITELN, fileNumber); + +} /* end writelnProc */ + +/****************************************************************************/ + +static void valProc(void) /* VAL procedure */ +{ + int size; + + TRACE(lstFile, "[valProc]"); + + /* Declaration: + * procedure val(const S : string; var V; var Code : word); + * + * Description: + * val() converts the value represented in the string S to a numerical + * value, and stores this value in the variable V, which can be of type + * Longint, Real and Byte. If the conversion isn��t succesfull, then the + * parameter Code contains the index of the character in S which + * prevented the conversion. The string S is allowed to contain spaces + * in the beginning. + * + * The string S can contain a number in decimal, hexadecimal, binary or + * octal format, as described in the language reference. + * + * Errors: + * If the conversion doesn��t succeed, the value of Code indicates the + * position where the conversion went wrong. + */ + + /* Skip over the 'val' identifer */ + + getToken(); + + /* Setup the actual-parameter-list */ + + size = actualParameterList(valSymbol); + + /* Generate the built-in procedure call. NOTE the procedure call + * logic will release the parameters from the stack saving us from + * having to generate the INDS here. + */ + + pas_BuiltInFunctionCall(lbVAL); + +} /* end writelnProc */ + +/***********************************************************************/ diff --git a/misc/pascal/pascal/pstm.c b/misc/pascal/pascal/pstm.c index ad6236839e..3d6e49fa55 100644 --- a/misc/pascal/pascal/pstm.c +++ b/misc/pascal/pascal/pstm.c @@ -1,1681 +1,1683 @@ -/****************************************************************************
- * pstm.c
- * Pascal Statements
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ****************************************************************************/
-
-/****************************************************************************
- * Included Files
- ****************************************************************************/
-
-#include <stdio.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "podefs.h"
-#include "pedefs.h"
-#include "pxdefs.h"
-
-#include "pas.h"
-#include "pstm.h"
-#include "pproc.h"
-#include "pexpr.h"
-#include "pgen.h"
-#include "ptkn.h"
-#include "ptbl.h"
-#include "pinsn.h"
-#include "perr.h"
-
-/****************************************************************************
- * Private Definitions
- ****************************************************************************/
-
-#define ADDRESS_DEREFERENCE 0x01
-#define ADDRESS_ASSIGNMENT 0x02
-#define INDEXED_ASSIGNMENT 0x04
-#define VAR_PARM_ASSIGNMENT 0x08
-
-#define isConstant(x) \
- ( ((x) == tINT_CONST) \
- || ((x) == tBOOLEAN_CONST) \
- || ((x) == tCHAR_CONST) \
- || ((x) == tREAL_CONST) \
- || ((x) == sSCALAR_OBJECT))
-
-/****************************************************************************
- * Private Function Prototypes
- ****************************************************************************/
-
-/* Assignment Statements */
-
-static void pas_ComplexAssignment(void);
-static void pas_SimpleAssignment (STYPE *varPtr, ubyte assignFlags);
-static void pas_Assignment (uint16 storeOp, exprType assignType, STYPE *varPtr, STYPE *typePtr);
-static void pas_StringAssignment (STYPE *varPtr, STYPE *typePtr);
-static void pas_LargeAssignment (uint16 storeOp, exprType assignType, STYPE *varPtr, STYPE *typePtr);
-
-/* Other Statements */
-
-static void pas_GotoStatement (void); /* GOTO statement */
-static void pas_LabelStatement (void); /* Label statement */
-static void pas_ProcStatement (void); /* Procedure method statement */
-static void pas_IfStatement (void); /* IF-THEN[-ELSE] statement */
-static void pas_CaseStatement (void); /* Case statement */
-static void pas_RepeatStatement (void); /* Repeat statement */
-static void pas_WhileStatement (void); /* While statement */
-static void pas_ForStatement (void); /* For statement */
-static void pas_WithStatement (void); /* With statement */
-
-/****************************************************************************/
-
-void statement(void)
-{
- STYPE *symPtr; /* Save Symbol Table pointer to token */
-
- TRACE(lstFile,"[statement");
-
- /* Generate file/line number pseudo-operation to facilitate P-Code testing */
-
- pas_GenerateLineNumber(FP->include, FP->line);
-
- /* We will push the string stack pointer at the beginning of each
- * statement and pop the string stack pointer at the end of each
- * statement. Subsequent optimization logic will scan the generated
- * pcode to ascertain if the push and pops were necessary. They
- * would be necessary if expression parsing generated temporary usage
- * of string stack storage. In this case, the push will save the
- * value before the temporary usage and the pop will release the
- * temporaray storage.
- */
-
- pas_GenerateSimple(opPUSHS);
-
- /* Process the statement according to the type of the leading token */
-
- switch (token)
- {
- /* Simple assignment statements */
-
- case sINT :
- symPtr = tknPtr;
- getToken();
- pas_Assignment(opSTS, exprInteger, symPtr, symPtr->sParm.v.parent);
- break;
- case sCHAR :
- symPtr = tknPtr;
- getToken();
- pas_Assignment(opSTSB, exprChar, symPtr, symPtr->sParm.v.parent);
- break;
- case sBOOLEAN :
- symPtr = tknPtr;
- getToken();
- pas_Assignment(opSTSB, exprBoolean, symPtr, NULL);
- break;
- case sREAL :
- symPtr = tknPtr;
- getToken();
- pas_LargeAssignment(opSTSM, exprReal, symPtr, symPtr->sParm.v.parent);
- break;
- case sSCALAR :
- symPtr = tknPtr;
- getToken();
- pas_Assignment(opSTS, exprScalar, symPtr, symPtr->sParm.v.parent);
- break;
- case sSET_OF :
- symPtr = tknPtr;
- getToken();
- pas_Assignment(opSTS, exprSet, symPtr, symPtr->sParm.v.parent);
- break;
- case sSTRING :
- case sRSTRING :
- symPtr = tknPtr;
- getToken();
- pas_StringAssignment(symPtr, symPtr->sParm.v.parent);
- break;
-
- /* Complex assignments statements */
-
- case sSUBRANGE :
- case sRECORD :
- case sRECORD_OBJECT :
- case sPOINTER :
- case sVAR_PARM :
- case sARRAY :
- pas_ComplexAssignment();
- break;
-
- /* Branch, Call and Label statements */
-
- case sPROC : pas_ProcStatement(); break;
- case tGOTO : pas_GotoStatement(); break;
- case tINT_CONST : pas_LabelStatement(); break;
-
- /* Conditional Statements */
-
- case tIF : pas_IfStatement(); break;
- case tCASE : pas_CaseStatement(); break;
-
- /* Loop Statements */
-
- case tREPEAT : pas_RepeatStatement(); break;
- case tWHILE : pas_WhileStatement(); break;
- case tFOR : pas_ForStatement(); break;
-
- /* Other Statements */
-
- case tBEGIN : compoundStatement(); break;
- case tWITH : pas_WithStatement(); break;
-
- /* None of the above, try standard procedures */
- default : builtInProcedure(); break;
-
- } /* end switch */
-
- /* Generate the POPS that matches the PUSHS generated at the begining
- * of this function (see comments above).
- */
-
- pas_GenerateSimple(opPOPS);
-
- TRACE(lstFile,"]");
-
-} /* end statement */
-
-/***********************************************************************/
-/* Process a complex assignment statement */
-
-static void pas_ComplexAssignment(void)
-{
- STYPE symbolSave;
- TRACE(lstFile,"[pas_ComplexAssignment]");
-
- /* FORM: <variable OR function identifer> := <expression>
- * First, make a copy of the symbol table entry because the call to
- * pas_SimpleAssignment() will modify it.
- */
-
- symbolSave = *tknPtr;
- getToken();
-
- /* Then process the complex assignment until it is reduced to a simple
- * assignment (like int, char, etc.)
- */
-
- pas_SimpleAssignment(&symbolSave, 0);
-}
-
-/***********************************************************************/
-/* Process a complex assignment (recursively) until it becomes a
- * simple assignment statement
- */
-
-static void pas_SimpleAssignment(STYPE *varPtr, ubyte assignFlags)
-{
- STYPE *typePtr;
- TRACE(lstFile,"[pas_SimpleAssignment]");
-
- /* FORM: <variable OR function identifer> := <expression> */
-
- typePtr = varPtr->sParm.v.parent;
- switch (varPtr->sKind)
- {
- /* Check if we have reduce the complex assignment to a simple
- * assignment yet
- */
-
- case sINT :
- if ((assignFlags & INDEXED_ASSIGNMENT) != 0)
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_Assignment(opSTI, exprInteger, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTSX, exprIntegerPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTSX, exprInteger, varPtr, typePtr);
- } /* end if */
- else
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_Assignment(opSTI, exprInteger, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTS, exprIntegerPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTS, exprInteger, varPtr, typePtr);
- } /* end else */
- break;
- case sCHAR :
- if ((assignFlags & INDEXED_ASSIGNMENT) != 0)
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_Assignment(opSTIB, exprChar, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTSX, exprCharPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTSXB, exprChar, varPtr, typePtr);
- } /* end if */
- else
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_Assignment(opSTIB, exprChar, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTS, exprCharPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTSB, exprChar, varPtr, typePtr);
- } /* end else */
- break;
- case sBOOLEAN :
- if ((assignFlags & INDEXED_ASSIGNMENT) != 0)
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_Assignment(opSTI, exprBoolean, varPtr, NULL);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTSX, exprBooleanPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTSX, exprBoolean, varPtr, NULL);
- } /* end if */
- else
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_Assignment(opSTI, exprBoolean, varPtr, NULL);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTS, exprBooleanPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTS, exprBoolean, varPtr, NULL);
- } /* end else */
- break;
- case sREAL :
- if ((assignFlags & INDEXED_ASSIGNMENT) != 0)
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_LargeAssignment(opSTIM, exprReal, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTSX, exprRealPtr, varPtr, typePtr);
- else
- pas_LargeAssignment(opSTSXM, exprReal, varPtr, typePtr);
- } /* end if */
- else
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_LargeAssignment(opSTIM, exprReal, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTS, exprRealPtr, varPtr, typePtr);
- else
- pas_LargeAssignment(opSTSM, exprReal, varPtr, typePtr);
- } /* end else */
- break;
- case sSCALAR :
- if ((assignFlags & INDEXED_ASSIGNMENT) != 0)
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_Assignment(opSTI, exprScalar, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTSX, exprScalarPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTSX, exprScalar, varPtr, typePtr);
- } /* end if */
- else
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_Assignment(opSTI, exprScalar, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTS, exprScalarPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTS, exprScalar, varPtr, typePtr);
- } /* end else */
- break;
- case sSET_OF :
- if ((assignFlags & INDEXED_ASSIGNMENT) != 0)
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDSX, varPtr);
- pas_Assignment(opSTI, exprSet, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTSX, exprSetPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTSX, exprSet, varPtr, typePtr);
- } /* end if */
- else
- {
- if ((assignFlags & ADDRESS_DEREFERENCE) != 0)
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_Assignment(opSTI, exprSet, varPtr, typePtr);
- } /* end if */
- else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- pas_Assignment(opSTS, exprSetPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTS, exprSet, varPtr, typePtr);
- } /* end else */
- break;
-
- /* NOPE... recurse until it becomes a simple assignment */
-
- case sSUBRANGE :
- varPtr->sKind = typePtr->sParm.t.subType;
- pas_SimpleAssignment(varPtr, assignFlags);
- break;
-
- case sRECORD :
- /* FORM: <record identifier>.<field> := <expression>
- * OR: <record pointer identifier> := <pointer expression>
- */
-
- /* Check if this is a pointer to a record */
-
- if ((assignFlags & ADDRESS_ASSIGNMENT) != 0)
- {
- if (token == '.') error(ePOINTERTYPE);
-
- if ((assignFlags & INDEXED_ASSIGNMENT) != 0)
- pas_Assignment(opSTSX, exprRecordPtr, varPtr, typePtr);
- else
- pas_Assignment(opSTS, exprRecordPtr, varPtr, typePtr);
- } /* end if */
- else if (((assignFlags & ADDRESS_DEREFERENCE) != 0) &&
- ((assignFlags & VAR_PARM_ASSIGNMENT) == 0))
- error(ePOINTERTYPE);
-
- /* Check if a period separates the RECORD identifier from the
- * record field identifier
- */
-
- else if (token == '.')
- {
- /* Skip over the period */
-
- getToken();
-
- /* Verify that a field identifier associated with this record
- * follows the period.
- */
-
- if ((token != sRECORD_OBJECT) ||
- (tknPtr->sParm.r.record != typePtr))
- error(eRECORDOBJECT);
- else
- {
- /* Modify the variable so that it has the characteristics of the
- * the field but with level and offset associated with the record
- */
-
- typePtr = tknPtr->sParm.r.parent;
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sParm.v.parent = typePtr;
-
- /* Special case: The record is a VAR parameter. */
-
- if (assignFlags == (INDEXED_ASSIGNMENT | ADDRESS_DEREFERENCE | VAR_PARM_ASSIGNMENT))
- {
- pas_GenerateDataOperation(opPUSH, tknPtr->sParm.r.offset);
- pas_GenerateSimple(opADD);
- } /* end if */
- else
- varPtr->sParm.v.offset += tknPtr->sParm.r.offset;
-
- getToken();
- pas_SimpleAssignment(varPtr, assignFlags);
-
- } /* end else if */
- } /* end else */
-
- /* It must be a RECORD assignment */
-
- else
- {
- /* Special case: The record is a VAR parameter. */
-
- if (assignFlags == (INDEXED_ASSIGNMENT | ADDRESS_DEREFERENCE | VAR_PARM_ASSIGNMENT))
- {
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateSimple(opADD);
- pas_LargeAssignment(opSTIM, exprRecord, varPtr, typePtr);
- } /* end if */
- else
- pas_LargeAssignment(opSTSM, exprRecord, varPtr, typePtr);
- } /* end else */
- break;
-
- case sRECORD_OBJECT :
- /* FORM: <field> := <expression>
- * NOTE: This must have been preceeded with a WITH statement
- * defining the RECORD type
- */
-
- if (!withRecord.parent)
- error(eINVTYPE);
- else if ((assignFlags && (ADDRESS_DEREFERENCE | ADDRESS_ASSIGNMENT)) != 0)
- error(ePOINTERTYPE);
- else if ((assignFlags && INDEXED_ASSIGNMENT) != 0)
- error(eARRAYTYPE);
-
- /* Verify that a field identifier is associated with the RECORD
- * specified by the WITH statement.
- */
-
- else if (varPtr->sParm.r.record != withRecord.parent)
- error(eRECORDOBJECT);
-
- else
- {
- sint16 tempOffset;
-
- /* Now there are two cases to consider: (1) the withRecord is a
- * pointer to a RECORD, or (2) the withRecord is the RECORD itself
- */
-
- if (withRecord.pointer)
- {
- /* If the pointer is really a VAR parameter, then other syntax
- * rules will apply
- */
-
- if (withRecord.varParm)
- assignFlags |= (INDEXED_ASSIGNMENT | ADDRESS_DEREFERENCE | VAR_PARM_ASSIGNMENT);
- else
- assignFlags |= (INDEXED_ASSIGNMENT | ADDRESS_DEREFERENCE);
-
- pas_GenerateDataOperation(opPUSH, (varPtr->sParm.r.offset + withRecord.index));
- tempOffset = withRecord.offset;
- } /* end if */
- else
- {
- tempOffset = varPtr->sParm.r.offset + withRecord.offset;
- } /* end else */
-
- /* Modify the variable so that it has the characteristics of the
- * the field but with level and offset associated with the record
- * NOTE: We have to be careful here because the structure
- * associated with sRECORD_OBJECT is not the same as for
- * variables!
- */
-
- typePtr = varPtr->sParm.r.parent;
-
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sLevel = withRecord.level;
- varPtr->sParm.v.size = typePtr->sParm.t.asize;
- varPtr->sParm.v.offset = tempOffset;
- varPtr->sParm.v.parent = typePtr;
-
- pas_SimpleAssignment(varPtr, assignFlags);
-
- } /* end else */
- break;
-
- case sPOINTER :
- /* FORM: <pointer identifier>^ := <expression>
- * OR: <pointer identifier> := <pointer expression>
- */
-
- if (token == '^') /* value assignment? */
- {
- getToken();
- assignFlags |= ADDRESS_DEREFERENCE;
- } /* end if */
- else
- assignFlags |= ADDRESS_ASSIGNMENT;
-
- varPtr->sKind = typePtr->sParm.t.type;
- pas_SimpleAssignment(varPtr, assignFlags);
- break;
-
- case sVAR_PARM :
- if (assignFlags != 0) error(eVARPARMTYPE);
- assignFlags |= (ADDRESS_DEREFERENCE | VAR_PARM_ASSIGNMENT);
-
- varPtr->sKind = typePtr->sParm.t.type;
- pas_SimpleAssignment(varPtr, assignFlags);
- break;
-
- case sARRAY :
- /* FORM: <array identifier> := <expression>
- * OR: <pointer array identifier>[<index>]^ := <expression>
- * OR: <pointer array identifier>[<index>] := <pointer expression>
- * OR: <record array identifier>[<index>].<field identifier> := <expression>
- * OR: etc., etc., etc.
- */
-
- if (assignFlags != 0) error(eARRAYTYPE);
- assignFlags |= INDEXED_ASSIGNMENT;
-
- arrayIndex(typePtr->sParm.t.asize);
- varPtr->sKind = typePtr->sParm.t.type;
- varPtr->sParm.v.size = typePtr->sParm.t.asize;
- pas_SimpleAssignment(varPtr, assignFlags);
- break;
-
- default :
- error(eINVTYPE);
- break;
-
- }
-}
-
-/***********************************************************************/
-/* Process simple assignment statement */
-
-static void pas_Assignment(uint16 storeOp, exprType assignType,
- STYPE *varPtr, STYPE *typePtr)
-{
- TRACE(lstFile,"[pas_Assignment]");
-
- /* FORM: <variable OR function identifer> := <expression> */
-
- if (token != tASSIGN) error (eASSIGN);
- else getToken();
-
- expression(assignType, typePtr);
- pas_GenerateStackReference(storeOp, varPtr);
-}
-
-/***********************************************************************/
-/* Process the assignment to a variable length string record */
-
-static void pas_StringAssignment(STYPE *varPtr, STYPE *typePtr)
-{
- exprType stringKind;
-
- TRACE(lstFile,"[pas_StringAssignment]");
-
- /* FORM: <variable OR function identifer> := <expression> */
-
- /* Verify that the assignment token follows the indentifier */
-
- if (token != tASSIGN) error (eASSIGN);
- else getToken();
-
- /* Get the expression after assignment token. We'll take any kind
- * of string expression. This is a hack to handle calls to system
- * functions that return exprCString pointers that must be converted
- * to exprString records upon assignment.
- */
-
- stringKind = expression(exprAnyString, typePtr);
-
- /* Place the address of the destination string structure instance on the
- * stack.
- */
-
- pas_GenerateStackReference(opLAS, varPtr);
-
- /* Check if this is an assignment to a global allocated string, or
- * to a stack reference to an allocated string.
- */
-
- if (varPtr->sKind == sRSTRING)
- {
- /* It is an assignment to a string reference --
- * Generate a runtime library call to copy the destination
- * string string into the pascal string instance. The particular
- * runtime call will account for any necesary string type conversion.
- */
-
- if ((stringKind == exprString) || (stringKind == exprStkString))
- {
- /* It is a pascal string type. Current stack representation is:
- *
- * TOS(0)=address of dest string reference
- * TOS(1)=length of source string
- * TOS(2)=pointer to source string
- */
-
- pas_BuiltInFunctionCall(lbSTR2RSTR);
- }
- else if (stringKind == exprCString)
- {
- /* It is a 32-bit C string point. Current stack representation is:
- *
- * TOS(0)=address of dest string reference
- * TOS(1)=MS 16-bits of 32-bit C source string pointer
- * TOS(2)=LS 16-bits of 32-bit C source string pointer
- */
-
- pas_BuiltInFunctionCall(lbCSTR2RSTR);
- }
- }
- else
- {
- /* It is an assignment to a allocated Pascal string --
- * Generate a runtime library call to copy the destination
- * string string into the pascal string instance. The particular
- * runtime call will account for any necesary string type conversion.
- */
-
- if ((stringKind == exprString) || (stringKind == exprStkString))
- {
- /* It is a pascal string type. Current stack representation is:
- *
- * TOS(0)=address of dest string hdr
- * TOS(1)=length of source string
- * TOS(2)=pointer to source string
- */
-
- pas_BuiltInFunctionCall(lbSTR2STR);
- }
- else if (stringKind == exprCString)
- {
- /* It is a 32-bit C string point. Current stack representation is:
- *
- * TOS(0)=address of dest string hdr
- * TOS(1)=MS 16-bits of 32-bit C source string pointer
- * TOS(2)=LS 16-bits of 32-bit C source string pointer
- */
-
- pas_BuiltInFunctionCall(lbCSTR2STR);
- }
- }
-
- /* else ... type mismatch error already reported by expression() */
-}
-
-/***********************************************************************/
-/* Process a multiple word assignment statement */
-
-static void pas_LargeAssignment(uint16 storeOp, exprType assignType,
- STYPE *varPtr, STYPE *typePtr)
-{
- TRACE(lstFile,"[pas_LargeAssignment]");
-
- /* FORM: <variable OR function identifer> := <expression> */
-
- if (token != tASSIGN) error (eASSIGN);
- else getToken();
-
- expression(assignType, typePtr);
- pas_GenerateDataSize(varPtr->sParm.v.size);
- pas_GenerateStackReference(storeOp, varPtr);
-}
-
-/***********************************************************************/
-
-static void pas_GotoStatement(void)
-{
- char labelname [8]; /* Label symbol table name */
- STYPE *label_ptr; /* Pointer to Label Symbol */
-
- TRACE(lstFile,"[pas_GotoStatement]");
-
- /* FORM: GOTO <integer> */
-
- /* Get the token after the goto reserved word. It should be an <integer> */
-
- getToken();
- if (token != tINT_CONST)
- {
- /* Token following the goto is not an integer */
-
- error(eINVLABEL);
- }
- else
- {
- /* The integer label must be non-negative */
-
- if (tknInt < 0)
- {
- error(eINVLABEL);
- }
- else
- {
- /* Find and verify the symbol associated with the label */
-
- (void)sprintf (labelname, "%ld", tknInt);
- if (!(label_ptr = findSymbol(labelname)))
- {
- error(eUNDECLABEL);
- }
- else if (label_ptr->sKind != sLABEL)
- {
- error(eINVLABEL);
- }
- else
- {
- /* Generate the branch to the label */
-
- pas_GenerateDataOperation(opJMP, label_ptr->sParm.l.label);
- }
- }
-
- /* Get the token after the <integer> value */
-
- getToken();
- }
-}
-
-/***********************************************************************/
-
-static void pas_LabelStatement(void)
-{
- char labelName [8]; /* Label symbol table name */
- STYPE *labelPtr; /* Pointer to Label Symbol */
-
- TRACE(lstFile,"[pas_LabelStatement]");
-
- /* FORM: <integer> : */
-
- /* Verify that the integer is a label name */
-
- (void)sprintf (labelName, "%ld", tknInt);
- if (!(labelPtr = findSymbol(labelName)))
- {
- error(eUNDECLABEL);
- }
- else if(labelPtr->sKind != sLABEL)
- {
- error(eINVLABEL);
- }
-
- /* And also verify that the label symbol has not been previously
- * defined.
- */
-
- else if(!(labelPtr->sParm.l.unDefined))
- {
- error(eMULTLABEL);
- }
- else
- {
- /* Generate the label and indicate that it has been defined */
-
- pas_GenerateDataOperation(opLABEL, labelPtr->sParm.l.label);
- labelPtr->sParm.l.unDefined = FALSE;
-
- /* We have to assume that we got here via a goto statement.
- * We don't have logic in place to track changes to the level
- * stack pointer (LSP) register, so we have no choice but to
- * invalidate that register now.
- */
-
- pas_InvalidateCurrentStackLevel();
- }
-
- /* Skip over the label integer */
-
- getToken();
-
- /* Make sure that the label is followed by a colon */
-
- if (token != ':') error (eCOLON);
- else getToken();
-}
-
-/***********************************************************************/
-
-static void pas_ProcStatement(void)
-{
- STYPE *procPtr = tknPtr;
- int size = 0;
-
- TRACE(lstFile,"[pas_ProcStatement]");
-
- /* FORM: procedure-method-statement =
- * procedure-method-specifier [ actual-parameter-list ]
- *
- * Skip over the procedure-method-statement
- */
-
- getToken();
-
- /* Get the actual parameters (if any) associated with the procedure
- * call.
- */
-
- size = actualParameterList(procPtr);
-
- /* Generate procedure call and stack adjustment (if required)
- * Upon return from the procedure, the level stack pointer (LSP)
- * may also be invalid. However, we rely on level level logic in
- * pgen.c to manage this case (as well as the function call case).
- */
-
- pas_GenerateProcedureCall(procPtr);
- if (size)
- {
- pas_GenerateDataOperation(opINDS, -size);
- }
-}
-
-/***********************************************************************/
-
-static void pas_IfStatement(void)
-{
- uint16 else_label = ++label;
- uint16 endif_label = else_label;
- sint32 thenLSP;
- sint32 elseLSP;
-
- TRACE(lstFile,"[pas_IfStatement]");
-
- /* FORM: IF <expression> THEN <statement> [ELSE <statement>] */
-
- /* Skip over the IF token */
-
- getToken();
-
- /* Evaluate the boolean expression */
-
- expression(exprBoolean, NULL);
-
- /* Make sure that the boolean expression is followed by the THEN token */
-
- if (token != tTHEN)
- error (eTHEN);
- else
- {
- /* Skip over the THEN token */
-
- getToken();
-
- /* Generate a conditional branch to the "else_label." This will be a
- * branch to either the ENDIF or to the ELSE location (if present).
- */
-
- pas_GenerateDataOperation(opJEQUZ, else_label);
-
- /* Save the value of the Level Stack Pointer (LSP) here. This will be
- * the value of the LSP at the ENDIF label if there is no ELSE <statement>
- * presentl. We will compare the elseLSP to the thenLSP at that point.
- */
-
- elseLSP = pas_GetCurrentStackLevel();
-
- /* Parse the <statment> following the THEN token */
-
- statement();
-
- /* Save the LSP after generating the THEN <statement>. We will compare the
- * elseLSP to the thenLSP below.
- */
-
- thenLSP = pas_GetCurrentStackLevel();
-
- /* Check for optional ELSE <statement> */
-
- if (token == tELSE)
- {
- /* Change the ENDIF label. Now instead of branching to
- * the ENDIF, the logic above will branch to the ELSE
- * logic generated here.
- */
-
- endif_label = ++label;
-
- /* Skip over the ELSE token */
-
- getToken();
-
- /* Generate Jump to ENDIF label after the THEN <statement> */
-
- pas_GenerateDataOperation(opJMP, endif_label);
-
- /* Generate the ELSE label here. This is where we will go if
- * the IF <expression> evaluates to FALSE.
- */
-
- pas_GenerateDataOperation(opLABEL, else_label);
-
- /* Generate the ELSE <statement> then fall through to the
- * ENDIF label.
- */
-
- statement();
-
- /* Save the LSP after generating the ELSE <statement>. We will
- * compare elseLSP to the thenLSP below.
- */
-
- elseLSP = pas_GetCurrentStackLevel();
- }
-
- /* Generate the ENDIF label here. Note that if no ELSE <statement>
- * is present, this will be the same as the else_label.
- */
-
- pas_GenerateDataOperation(opLABEL, endif_label);
-
- /* We can get to this location through two of three pathes: (1) through the
- * THEN <statement>, (2) from the IF <expression> if no ELSE <statement>
- * is present, or (3) from the ELSE <statement>. If the LSP is different
- * through these two pathes, then we will have to invalidate it.
- */
-
- if (thenLSP != elseLSP)
- {
- pas_InvalidateCurrentStackLevel();
- }
- }
-}
-
-/***********************************************************************/
-
-void compoundStatement(void)
-{
- TRACE(lstFile,"[compoundStatement]");
-
- /* Process statements until END encountered */
- do
- {
- getToken();
- statement();
- }
- while (token == ';');
-
- /* Verify that it really was END */
-
- if (token != tEND) error (eEND);
- else getToken();
-}
-
-/***********************************************************************/
-
-void pas_RepeatStatement ()
-{
- uint16 rpt_label = ++label;
-
- TRACE(lstFile,"[pas_RepeatStatement]");
-
- /* REPEAT <statement[;statement[statement...]]> UNTIL <expression> */
-
- /* Generate top of loop label */
-
- pas_GenerateDataOperation(opLABEL, rpt_label);
- do
- {
- getToken();
-
- /* Process <statement> */
-
- statement();
- }
- while (token == ';');
-
- /* Verify UNTIL follows */
-
- if (token != tUNTIL) error (eUNTIL);
- else getToken();
-
- /* Generate UNTIL <expression> */
-
- expression(exprBoolean, NULL);
-
- /* Generate conditional branch to the top of loop */
-
- pas_GenerateDataOperation(opJEQUZ, rpt_label);
-
- /* NOTE: The current LSP setting will be correct after the repeat
- * loop because we fall through from the bottom of the loop after
- * executing the body at least once.
- */
-}
-
-/***********************************************************************/
-
-static void pas_WhileStatement(void)
-{
- uint16 while_label = ++label; /* Top of loop label */
- uint16 endwhile_label = ++label; /* End of loop label */
- uint32 nLspChanges;
- sint32 topOfLoopLSP;
- boolean bCheckLSP = FALSE;
-
- TRACE(lstFile,"[pas_WhileStatement]");
-
- /* Generate WHILE <expression> DO <statement> */
-
- /* Skip over WHILE token */
-
- getToken();
-
- /* Set top of loop label */
-
- pas_GenerateDataOperation(opLABEL, while_label);
-
- /* Evaluate the WHILE <expression> */
-
- nLspChanges = pas_GetNStackLevelChanges();
- expression(exprBoolean, NULL);
-
- /* Generate a conditional jump to the end of the loop */
-
- pas_GenerateDataOperation(opJEQUZ, endwhile_label);
-
- /* Save the level stack pointer (LSP) at the top of the
- * loop. When first executed, this value will depend on
- * logic prior to the loop or on values set in the
- * WHILE <expression>. On subsequent loops, this value
- * may be determined by logic within the loop body or
- * have to restore this value when the loop terminates.
- */
-
- topOfLoopLSP = pas_GetCurrentStackLevel();
-
- /* Does the WHILE <expression> logic set the LSP? */
-
- if (nLspChanges == pas_GetNStackLevelChanges())
- {
- /* Yes, then the value set in the WHILE <expression>
- * is the one that will be in effect at the end_while
- * label.
- */
-
- bCheckLSP = TRUE;
- }
-
- /* Verify that the DO token follows the expression */
-
- if (token != tDO) error(eDO);
- else getToken();
-
- /* Generate the <statement> following the DO token */
-
- statement();
-
- /* Generate a branch to the top of the loop */
-
- pas_GenerateDataOperation(opJMP, while_label);
-
- /* Set the bottom of loop label */
-
- pas_GenerateDataOperation(opLABEL, endwhile_label);
-
- /* We always get here from the check at the top of the loop.
- * Normally this will be from the branch from the bottom of
- * the loop to the top of the loop. Then from the conditional
- * branch at the top of the loop to here.
- *
- * But, we need to allow for the special case when the body
- * of the while loop never executed. The flag bCheckLSP is
- * set TRUE if the conditional expression evaluation does not
- * set the LSP. In the case, the current LSP will be either
- * the LSP at the top of the loop (if he body was never executed)
- * or the current LSP (the body executes at least once).
- */
-
- if (bCheckLSP)
- {
- if (topOfLoopLSP != pas_GetCurrentStackLevel())
- {
- /* In thise case, there is uncertainty in the value of the
- * LSP and we must invalidate it. It will be reset to the
- * correct the next time that a level stack reference is
- * performed.
- */
-
- pas_InvalidateCurrentStackLevel();
- }
- }
- else
- {
- /* Otherwise, make sure that the code generation logic knows
- * the correct value of the LSP at this point.
- */
-
- pas_SetCurrentStackLevel(topOfLoopLSP);
- }
-}
-
-/***********************************************************************/
-/* This is helper function for pas_CaseStatement */
-
-static boolean pas_CheckInvalidateLSP(sint32 *pTerminalLSP)
-{
- /* Check the LSP after evaluating the case <statement>. */
-
- sint32 caseLSP = pas_GetCurrentStackLevel();
- if (caseLSP < 0)
- {
- /* If the LSP is invalid after any case <statement>, then it could
- * be invalid at the end_case label as well.
- */
-
- return TRUE;
- }
- else if (*pTerminalLSP < 0)
- {
- /* The value of the LSP at the end_case label has not
- * yet been determined. It must be the value at the
- * end of this case <statement> (or else it is invalid)
- */
-
- *pTerminalLSP = caseLSP;
- }
- else if (*pTerminalLSP != caseLSP)
- {
- /* The value of the LSP at the end of this case <statement> is
- * different from the value of the LSP at the end of some other
- * case <statement>. The value of the LSP at the end_case label
- * will be indeterminate and must be invalidated.
- */
-
- return TRUE;
- }
- /* So far so good */
-
- return FALSE;
-}
-
-static void pas_CaseStatement(void)
-{
- uint16 this_case;
- uint16 next_case = ++label;
- uint16 end_case = ++label;
- sint32 terminalLSP = -1;
- boolean bInvalidateLSP = FALSE;
-
- TRACE(lstFile,"[pas_CaseStatement]");
-
- /* Process "CASE <expression> OF" */
-
- /* Skip over the CASE token */
-
- getToken();
-
- /* Evaluate the CASE <expression> */
-
- expression(exprAnyOrdinal, NULL);
-
- /* Verify that CASE <expression> is followed with the OF token */
-
- if (token != tOF) error (eOF);
- else getToken();
-
- /* Loop to process each case until END encountered */
-
- for (;;)
- {
- this_case = next_case;
- next_case = ++label;
-
- /* Process NON-STANDARD ELSE <statement> END */
-
- if (token == tELSE)
- {
- getToken();
-
- /* Set ELSE statement label */
-
- pas_GenerateDataOperation(opLABEL, this_case);
-
- /* Evaluate ELSE statement */
-
- statement();
-
- /* Check the LSP after evaluating the ELSE <statement>. */
-
- if (pas_CheckInvalidateLSP(&terminalLSP))
- {
- /* The LSP will be invalid at the end case label. Set
- * a flag so that we can handle invalidation of the LSP when
- * we get to the end case label.
- */
-
- bInvalidateLSP = TRUE;
- }
-
- /* Verify that END follows the ELSE <statement> */
-
- if (token != tEND) error(eEND);
- else getToken();
-
- /* Terminate FOR loop */
-
- break;
- }
-
- /* Process "<constant>[,<constant>[,...]] : <statement>"
- * NOTE: We accept any kind of constant for the case selector; there
- * really should be some check to assure that the constant is of the
- * same type as the expression!
- */
-
- else
- {
- /* Loop for each <constant> in the case list */
-
- for(;;)
- {
- /* Verify that we have a constant */
-
- if (!isConstant(token))
- {
- error(eINTCONST);
- break;
- }
-
- /* Generate a comparison of the CASE expression and the constant.
- *
- * First duplicate the value to be compared (from the CASE <expression>)
- * and push the comparison value (from the <constant>:)
- */
-
- pas_GenerateSimple(opDUP);
- pas_GenerateDataOperation(opPUSH, tknInt);
-
- /* The kind of comparison we generate depends on if we have to
- * jump over other case selector comparsions to the statement
- * or if we can just fall through to the statement
- */
-
- /* Skip over the constant */
-
- getToken();
-
- /* If there are multiple constants, they will be separated with
- * commas.
- */
-
- if (token == ',')
- {
- /* Generate jump to <statement> */
-
- pas_GenerateDataOperation(opJEQUZ, this_case);
-
- /* Skip over comma */
-
- getToken();
- }
- else
- {
- /* else jump to the next case */
-
- pas_GenerateDataOperation(opJNEQZ, next_case);
- break;
- }
- }
-
- /* Then process ... : <statement> */
-
- /* Verify colon presence */
-
- if (token != ':') error(eCOLON);
- else getToken();
-
- /* Set CASE label */
-
- pas_GenerateDataOperation(opLABEL, this_case);
-
- /* Evaluate <statement> */
-
- statement();
-
- /* Jump to exit CASE */
-
- pas_GenerateDataOperation(opJMP, end_case);
-
- /* Check the LSP after evaluating the case <statement>. */
-
- if (pas_CheckInvalidateLSP(&terminalLSP))
- {
- /* If the LSP will be invalid at the end case label. Set
- * a flag so that we can handle invalidation of the LSP when
- * we get to the end case label.
- */
-
- bInvalidateLSP = TRUE;
- }
- }
-
- /* Check if there are more statements. If not, verify END present */
-
- if (token == ';')
- {
- getToken();
- }
- else if (token == tEND)
- {
- getToken();
- break;
- }
- else
- {
- error (eEND);
- break;
- }
- }
-
- /* Generate ENDCASE label and Pop CASE <expression> from stack */
-
- pas_GenerateDataOperation(opLABEL, end_case);
- pas_GenerateDataOperation(opINDS, -sINT_SIZE);
-
- /* We may have gotten to this point from many different case <statements>.
- * The flag bInvalidateLSP will be set if the LSP is not the same for
- * each of these pathes. Invalidating the LSP will force it to be reloaded
- * when the next level stack access is done.
- */
-
- if (bInvalidateLSP)
- {
- pas_InvalidateCurrentStackLevel();
- }
-}
-
-/***********************************************************************/
-static void pas_ForStatement(void)
-{
- STYPE *varPtr;
- uint16 forLabel = ++label;
- uint16 endForLabel = ++label;
- uint16 jmpOp;
- uint16 modOp;
- sint32 topOfLoopLSP;
-
- TRACE(lstFile,"[pas_ForStatement]");
-
- /* FOR <assigment statement> <TO, DOWNTO> <expression> DO <statement> */
-
- /* Skip over the FOR token */
-
- getToken();
-
- /* Get and verify the left side of the assignment. */
- if ((token != sINT) && (token != sSUBRANGE))
- error(eINTVAR);
- else
- {
- /* Save the token associated with the left side of the assignment
- * and evaluate the integer assignment.
- */
-
- varPtr = tknPtr;
- getToken();
-
- /* Generate the assignment to the integer variable */
-
- pas_Assignment(opSTS, exprInteger, tknPtr, tknPtr->sParm.v.parent);
-
- /* Determine if this is a TO or a DOWNTO loop and set up the opCodes
- * to generate appropriately.
- */
-
- if (token == tDOWNTO)
- {
- jmpOp = opJGT;
- modOp = opDEC;
- getToken();
- }
- else if (token == tTO)
- {
- jmpOp = opJLT;
- modOp = opINC;
- getToken();
- }
- else
- error (eTOorDOWNTO);
-
- /* Evaluate <expression> DO */
-
- expression(exprInteger, varPtr->sParm.v.parent);
-
- /* Verify that the <expression> is followed by the DO token */
-
- if (token != tDO) error (eDO);
- else getToken();
-
- /* Generate top of loop label */
-
- pas_GenerateDataOperation(opLABEL, forLabel);
-
- /* Generate the top of loop comparison. Duplicate the end of loop
- * value, push the current value, and perform the comparison.
- */
-
- pas_GenerateSimple(opDUP);
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateDataOperation(jmpOp, endForLabel);
-
- /* Save the level stack pointer (LSP) at the top of the FOR
- * loop. When first executed, this value will depend on
- * logic prior to the loop body. On subsequent loops, this
- * value may be determined by logic within the loop body.
- */
-
- topOfLoopLSP = pas_GetCurrentStackLevel();
-
- /* Evaluate the for statement <statement> */
-
- statement();
-
- /* Generate end of loop logic: Load the variable, modify the
- * variable, store the variable, and jump unconditionally to the
- * top of the loop.
- */
-
- pas_GenerateStackReference(opLDS, varPtr);
- pas_GenerateSimple(modOp);
- pas_GenerateStackReference(opSTS, varPtr);
- pas_GenerateDataOperation(opJMP, forLabel);
-
- /* Generate the end of loop label. This is where the conditional
- * branch at the top of the loop will come to.
- */
-
- pas_GenerateDataOperation(opLABEL, endForLabel);
- pas_GenerateDataOperation(opINDS, -sINT_SIZE);
-
- /* We always get here from the check at the top of the loop.
- * Normally this will be from the branch from the bottom of
- * the loop to the top of the loop. Then from the conditional
- * branch at the top of the loop to here.
- *
- * But, we need to allow for the special case when the body
- * of the for loop never executed. In this case, the LSP at
- * the first time into the loop may differ from the LSP at
- * subsequent times into the loop. If this is the case, then
- * will will have to invalidate the LSP.
- */
-
- if (topOfLoopLSP != pas_GetCurrentStackLevel())
- {
- /* In thise case, there is uncertainty in the value of the
- * LSP and we must invalidate it. It will be reset to the
- * correct the next time that a level stack reference is
- * performed.
- */
-
- pas_InvalidateCurrentStackLevel();
- }
- }
-}
-
-/***********************************************************************/
-static void pas_WithStatement(void)
-{
- WTYPE saveWithRecord;
-
- TRACE(lstFile,"[pas_WithStatement]");
-
- /* Generate WITH <variable[,variable[...]] DO <statement> */
-
- /* Save the current WITH pointer. Only one WITH can be active at
- * any given time.
- */
-
- saveWithRecord = withRecord;
-
- /* Process each RECORD or RECORD OBJECT in the <variable> list */
-
- getToken();
- for(;;)
- {
- /* A RECORD type variable may be used in the WITH statement only if
- * there is no other WITH active
- */
-
- if ((token == sRECORD) && (!withRecord.parent))
- {
- /* Save the RECORD variable as the new withRecord */
-
- withRecord.level = tknPtr->sLevel;
- withRecord.pointer = FALSE;
- withRecord.varParm = FALSE;
- withRecord.offset = tknPtr->sParm.v.offset;
- withRecord.parent = tknPtr->sParm.v.parent;
-
- /* Skip over the RECORD variable */
-
- getToken();
- }
-
- /* A RECORD VAR parameter may also be used in the WITH statement
- * (again only if there is no other WITH active)
- */
-
- else if ((token == sVAR_PARM) &&
- (!withRecord.parent) &&
- (tknPtr->sParm.v.parent->sParm.t.type == sRECORD))
- {
- /* Save the RECORD VAR parameter as the new withRecord */
-
- withRecord.level = tknPtr->sLevel;
- withRecord.pointer = TRUE;
- withRecord.varParm = TRUE;
- withRecord.offset = tknPtr->sParm.v.offset;
- withRecord.parent = tknPtr->sParm.v.parent;
-
- /* Skip over the RECORD VAR parameter */
-
- getToken();
- }
-
- /* A pointer to a RECORD may also be used in the WITH statement
- * (again only if there is no other WITH active)
- */
-
- else if ((token == sPOINTER) &&
- (!withRecord.parent) &&
- (tknPtr->sParm.v.parent->sParm.t.type == sRECORD))
- {
- /* Save the RECORD pointer as the new withRecord */
-
- withRecord.level = tknPtr->sLevel;
- withRecord.pointer = TRUE;
- withRecord.pointer = FALSE;
- withRecord.offset = tknPtr->sParm.v.offset;
- withRecord.parent = tknPtr->sParm.v.parent;
-
- /* Skip over the RECORD pointer */
-
- getToken();
-
- /* Verify that deferencing is specified! */
-
- if (token != '^') error(eRECORDVAR);
- else getToken();
- }
-
- /* A RECORD_OBJECT may be used in the WITH statement if the field
- * is from the same sRECORD type and is itself of type RECORD.
- */
-
- else if ((token == sRECORD_OBJECT) &&
- (tknPtr->sParm.r.record == withRecord.parent) &&
- (tknPtr->sParm.r.parent->sParm.t.type == sRECORD))
- {
- /* Okay, update the withRecord to use this record field */
-
- if (withRecord.pointer)
- withRecord.index += tknPtr->sParm.r.offset;
- else
- withRecord.offset += tknPtr->sParm.r.offset;
-
- withRecord.parent = tknPtr->sParm.r.parent;
-
- /* Skip over the sRECORD_OBJECT */
-
- getToken();
- }
-
- /* Anything else is an error */
-
- else
- {
- error(eRECORDVAR);
- break;
- }
-
-
- /* Check if there are multiple variables in the WITH statement */
-
- if (token == ',') getToken();
- else break;
- }
-
- /* Verify that the RECORD list is terminated with DO */
-
- if (token != tDO) error (eDO);
- else getToken();
-
- /* Then process the statement following the WITH */
-
- statement();
-
- /* Restore the previous value of the withRecord */
-
- withRecord = saveWithRecord;
-}
-
-/***********************************************************************/
-
+/**************************************************************************** + * pstm.c + * Pascal Statements + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ****************************************************************************/ + +/**************************************************************************** + * Included Files + ****************************************************************************/ + +#include <stdint.h> +#include <stdbool.h> +#include <stdio.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "podefs.h" +#include "pedefs.h" +#include "pxdefs.h" + +#include "pas.h" +#include "pstm.h" +#include "pproc.h" +#include "pexpr.h" +#include "pgen.h" +#include "ptkn.h" +#include "ptbl.h" +#include "pinsn.h" +#include "perr.h" + +/**************************************************************************** + * Private Definitions + ****************************************************************************/ + +#define ADDRESS_DEREFERENCE 0x01 +#define ADDRESS_ASSIGNMENT 0x02 +#define INDEXED_ASSIGNMENT 0x04 +#define VAR_PARM_ASSIGNMENT 0x08 + +#define isConstant(x) \ + ( ((x) == tINT_CONST) \ + || ((x) == tBOOLEAN_CONST) \ + || ((x) == tCHAR_CONST) \ + || ((x) == tREAL_CONST) \ + || ((x) == sSCALAR_OBJECT)) + +/**************************************************************************** + * Private Function Prototypes + ****************************************************************************/ + +/* Assignment Statements */ + +static void pas_ComplexAssignment(void); +static void pas_SimpleAssignment (STYPE *varPtr, uint8_t assignFlags); +static void pas_Assignment (uint16_t storeOp, exprType assignType, STYPE *varPtr, STYPE *typePtr); +static void pas_StringAssignment (STYPE *varPtr, STYPE *typePtr); +static void pas_LargeAssignment (uint16_t storeOp, exprType assignType, STYPE *varPtr, STYPE *typePtr); + +/* Other Statements */ + +static void pas_GotoStatement (void); /* GOTO statement */ +static void pas_LabelStatement (void); /* Label statement */ +static void pas_ProcStatement (void); /* Procedure method statement */ +static void pas_IfStatement (void); /* IF-THEN[-ELSE] statement */ +static void pas_CaseStatement (void); /* Case statement */ +static void pas_RepeatStatement (void); /* Repeat statement */ +static void pas_WhileStatement (void); /* While statement */ +static void pas_ForStatement (void); /* For statement */ +static void pas_WithStatement (void); /* With statement */ + +/****************************************************************************/ + +void statement(void) +{ + STYPE *symPtr; /* Save Symbol Table pointer to token */ + + TRACE(lstFile,"[statement"); + + /* Generate file/line number pseudo-operation to facilitate P-Code testing */ + + pas_GenerateLineNumber(FP->include, FP->line); + + /* We will push the string stack pointer at the beginning of each + * statement and pop the string stack pointer at the end of each + * statement. Subsequent optimization logic will scan the generated + * pcode to ascertain if the push and pops were necessary. They + * would be necessary if expression parsing generated temporary usage + * of string stack storage. In this case, the push will save the + * value before the temporary usage and the pop will release the + * temporaray storage. + */ + + pas_GenerateSimple(opPUSHS); + + /* Process the statement according to the type of the leading token */ + + switch (token) + { + /* Simple assignment statements */ + + case sINT : + symPtr = tknPtr; + getToken(); + pas_Assignment(opSTS, exprInteger, symPtr, symPtr->sParm.v.parent); + break; + case sCHAR : + symPtr = tknPtr; + getToken(); + pas_Assignment(opSTSB, exprChar, symPtr, symPtr->sParm.v.parent); + break; + case sBOOLEAN : + symPtr = tknPtr; + getToken(); + pas_Assignment(opSTSB, exprBoolean, symPtr, NULL); + break; + case sREAL : + symPtr = tknPtr; + getToken(); + pas_LargeAssignment(opSTSM, exprReal, symPtr, symPtr->sParm.v.parent); + break; + case sSCALAR : + symPtr = tknPtr; + getToken(); + pas_Assignment(opSTS, exprScalar, symPtr, symPtr->sParm.v.parent); + break; + case sSET_OF : + symPtr = tknPtr; + getToken(); + pas_Assignment(opSTS, exprSet, symPtr, symPtr->sParm.v.parent); + break; + case sSTRING : + case sRSTRING : + symPtr = tknPtr; + getToken(); + pas_StringAssignment(symPtr, symPtr->sParm.v.parent); + break; + + /* Complex assignments statements */ + + case sSUBRANGE : + case sRECORD : + case sRECORD_OBJECT : + case sPOINTER : + case sVAR_PARM : + case sARRAY : + pas_ComplexAssignment(); + break; + + /* Branch, Call and Label statements */ + + case sPROC : pas_ProcStatement(); break; + case tGOTO : pas_GotoStatement(); break; + case tINT_CONST : pas_LabelStatement(); break; + + /* Conditional Statements */ + + case tIF : pas_IfStatement(); break; + case tCASE : pas_CaseStatement(); break; + + /* Loop Statements */ + + case tREPEAT : pas_RepeatStatement(); break; + case tWHILE : pas_WhileStatement(); break; + case tFOR : pas_ForStatement(); break; + + /* Other Statements */ + + case tBEGIN : compoundStatement(); break; + case tWITH : pas_WithStatement(); break; + + /* None of the above, try standard procedures */ + default : builtInProcedure(); break; + + } /* end switch */ + + /* Generate the POPS that matches the PUSHS generated at the begining + * of this function (see comments above). + */ + + pas_GenerateSimple(opPOPS); + + TRACE(lstFile,"]"); + +} /* end statement */ + +/***********************************************************************/ +/* Process a complex assignment statement */ + +static void pas_ComplexAssignment(void) +{ + STYPE symbolSave; + TRACE(lstFile,"[pas_ComplexAssignment]"); + + /* FORM: <variable OR function identifer> := <expression> + * First, make a copy of the symbol table entry because the call to + * pas_SimpleAssignment() will modify it. + */ + + symbolSave = *tknPtr; + getToken(); + + /* Then process the complex assignment until it is reduced to a simple + * assignment (like int, char, etc.) + */ + + pas_SimpleAssignment(&symbolSave, 0); +} + +/***********************************************************************/ +/* Process a complex assignment (recursively) until it becomes a + * simple assignment statement + */ + +static void pas_SimpleAssignment(STYPE *varPtr, uint8_t assignFlags) +{ + STYPE *typePtr; + TRACE(lstFile,"[pas_SimpleAssignment]"); + + /* FORM: <variable OR function identifer> := <expression> */ + + typePtr = varPtr->sParm.v.parent; + switch (varPtr->sKind) + { + /* Check if we have reduce the complex assignment to a simple + * assignment yet + */ + + case sINT : + if ((assignFlags & INDEXED_ASSIGNMENT) != 0) + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_Assignment(opSTI, exprInteger, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTSX, exprIntegerPtr, varPtr, typePtr); + else + pas_Assignment(opSTSX, exprInteger, varPtr, typePtr); + } /* end if */ + else + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_Assignment(opSTI, exprInteger, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTS, exprIntegerPtr, varPtr, typePtr); + else + pas_Assignment(opSTS, exprInteger, varPtr, typePtr); + } /* end else */ + break; + case sCHAR : + if ((assignFlags & INDEXED_ASSIGNMENT) != 0) + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_Assignment(opSTIB, exprChar, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTSX, exprCharPtr, varPtr, typePtr); + else + pas_Assignment(opSTSXB, exprChar, varPtr, typePtr); + } /* end if */ + else + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_Assignment(opSTIB, exprChar, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTS, exprCharPtr, varPtr, typePtr); + else + pas_Assignment(opSTSB, exprChar, varPtr, typePtr); + } /* end else */ + break; + case sBOOLEAN : + if ((assignFlags & INDEXED_ASSIGNMENT) != 0) + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_Assignment(opSTI, exprBoolean, varPtr, NULL); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTSX, exprBooleanPtr, varPtr, typePtr); + else + pas_Assignment(opSTSX, exprBoolean, varPtr, NULL); + } /* end if */ + else + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_Assignment(opSTI, exprBoolean, varPtr, NULL); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTS, exprBooleanPtr, varPtr, typePtr); + else + pas_Assignment(opSTS, exprBoolean, varPtr, NULL); + } /* end else */ + break; + case sREAL : + if ((assignFlags & INDEXED_ASSIGNMENT) != 0) + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_LargeAssignment(opSTIM, exprReal, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTSX, exprRealPtr, varPtr, typePtr); + else + pas_LargeAssignment(opSTSXM, exprReal, varPtr, typePtr); + } /* end if */ + else + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_LargeAssignment(opSTIM, exprReal, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTS, exprRealPtr, varPtr, typePtr); + else + pas_LargeAssignment(opSTSM, exprReal, varPtr, typePtr); + } /* end else */ + break; + case sSCALAR : + if ((assignFlags & INDEXED_ASSIGNMENT) != 0) + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_Assignment(opSTI, exprScalar, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTSX, exprScalarPtr, varPtr, typePtr); + else + pas_Assignment(opSTSX, exprScalar, varPtr, typePtr); + } /* end if */ + else + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_Assignment(opSTI, exprScalar, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTS, exprScalarPtr, varPtr, typePtr); + else + pas_Assignment(opSTS, exprScalar, varPtr, typePtr); + } /* end else */ + break; + case sSET_OF : + if ((assignFlags & INDEXED_ASSIGNMENT) != 0) + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDSX, varPtr); + pas_Assignment(opSTI, exprSet, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTSX, exprSetPtr, varPtr, typePtr); + else + pas_Assignment(opSTSX, exprSet, varPtr, typePtr); + } /* end if */ + else + { + if ((assignFlags & ADDRESS_DEREFERENCE) != 0) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_Assignment(opSTI, exprSet, varPtr, typePtr); + } /* end if */ + else if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + pas_Assignment(opSTS, exprSetPtr, varPtr, typePtr); + else + pas_Assignment(opSTS, exprSet, varPtr, typePtr); + } /* end else */ + break; + + /* NOPE... recurse until it becomes a simple assignment */ + + case sSUBRANGE : + varPtr->sKind = typePtr->sParm.t.subType; + pas_SimpleAssignment(varPtr, assignFlags); + break; + + case sRECORD : + /* FORM: <record identifier>.<field> := <expression> + * OR: <record pointer identifier> := <pointer expression> + */ + + /* Check if this is a pointer to a record */ + + if ((assignFlags & ADDRESS_ASSIGNMENT) != 0) + { + if (token == '.') error(ePOINTERTYPE); + + if ((assignFlags & INDEXED_ASSIGNMENT) != 0) + pas_Assignment(opSTSX, exprRecordPtr, varPtr, typePtr); + else + pas_Assignment(opSTS, exprRecordPtr, varPtr, typePtr); + } /* end if */ + else if (((assignFlags & ADDRESS_DEREFERENCE) != 0) && + ((assignFlags & VAR_PARM_ASSIGNMENT) == 0)) + error(ePOINTERTYPE); + + /* Check if a period separates the RECORD identifier from the + * record field identifier + */ + + else if (token == '.') + { + /* Skip over the period */ + + getToken(); + + /* Verify that a field identifier associated with this record + * follows the period. + */ + + if ((token != sRECORD_OBJECT) || + (tknPtr->sParm.r.record != typePtr)) + error(eRECORDOBJECT); + else + { + /* Modify the variable so that it has the characteristics of the + * the field but with level and offset associated with the record + */ + + typePtr = tknPtr->sParm.r.parent; + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sParm.v.parent = typePtr; + + /* Special case: The record is a VAR parameter. */ + + if (assignFlags == (INDEXED_ASSIGNMENT | ADDRESS_DEREFERENCE | VAR_PARM_ASSIGNMENT)) + { + pas_GenerateDataOperation(opPUSH, tknPtr->sParm.r.offset); + pas_GenerateSimple(opADD); + } /* end if */ + else + varPtr->sParm.v.offset += tknPtr->sParm.r.offset; + + getToken(); + pas_SimpleAssignment(varPtr, assignFlags); + + } /* end else if */ + } /* end else */ + + /* It must be a RECORD assignment */ + + else + { + /* Special case: The record is a VAR parameter. */ + + if (assignFlags == (INDEXED_ASSIGNMENT | ADDRESS_DEREFERENCE | VAR_PARM_ASSIGNMENT)) + { + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateSimple(opADD); + pas_LargeAssignment(opSTIM, exprRecord, varPtr, typePtr); + } /* end if */ + else + pas_LargeAssignment(opSTSM, exprRecord, varPtr, typePtr); + } /* end else */ + break; + + case sRECORD_OBJECT : + /* FORM: <field> := <expression> + * NOTE: This must have been preceeded with a WITH statement + * defining the RECORD type + */ + + if (!withRecord.parent) + error(eINVTYPE); + else if ((assignFlags && (ADDRESS_DEREFERENCE | ADDRESS_ASSIGNMENT)) != 0) + error(ePOINTERTYPE); + else if ((assignFlags && INDEXED_ASSIGNMENT) != 0) + error(eARRAYTYPE); + + /* Verify that a field identifier is associated with the RECORD + * specified by the WITH statement. + */ + + else if (varPtr->sParm.r.record != withRecord.parent) + error(eRECORDOBJECT); + + else + { + int16_t tempOffset; + + /* Now there are two cases to consider: (1) the withRecord is a + * pointer to a RECORD, or (2) the withRecord is the RECORD itself + */ + + if (withRecord.pointer) + { + /* If the pointer is really a VAR parameter, then other syntax + * rules will apply + */ + + if (withRecord.varParm) + assignFlags |= (INDEXED_ASSIGNMENT | ADDRESS_DEREFERENCE | VAR_PARM_ASSIGNMENT); + else + assignFlags |= (INDEXED_ASSIGNMENT | ADDRESS_DEREFERENCE); + + pas_GenerateDataOperation(opPUSH, (varPtr->sParm.r.offset + withRecord.index)); + tempOffset = withRecord.offset; + } /* end if */ + else + { + tempOffset = varPtr->sParm.r.offset + withRecord.offset; + } /* end else */ + + /* Modify the variable so that it has the characteristics of the + * the field but with level and offset associated with the record + * NOTE: We have to be careful here because the structure + * associated with sRECORD_OBJECT is not the same as for + * variables! + */ + + typePtr = varPtr->sParm.r.parent; + + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sLevel = withRecord.level; + varPtr->sParm.v.size = typePtr->sParm.t.asize; + varPtr->sParm.v.offset = tempOffset; + varPtr->sParm.v.parent = typePtr; + + pas_SimpleAssignment(varPtr, assignFlags); + + } /* end else */ + break; + + case sPOINTER : + /* FORM: <pointer identifier>^ := <expression> + * OR: <pointer identifier> := <pointer expression> + */ + + if (token == '^') /* value assignment? */ + { + getToken(); + assignFlags |= ADDRESS_DEREFERENCE; + } /* end if */ + else + assignFlags |= ADDRESS_ASSIGNMENT; + + varPtr->sKind = typePtr->sParm.t.type; + pas_SimpleAssignment(varPtr, assignFlags); + break; + + case sVAR_PARM : + if (assignFlags != 0) error(eVARPARMTYPE); + assignFlags |= (ADDRESS_DEREFERENCE | VAR_PARM_ASSIGNMENT); + + varPtr->sKind = typePtr->sParm.t.type; + pas_SimpleAssignment(varPtr, assignFlags); + break; + + case sARRAY : + /* FORM: <array identifier> := <expression> + * OR: <pointer array identifier>[<index>]^ := <expression> + * OR: <pointer array identifier>[<index>] := <pointer expression> + * OR: <record array identifier>[<index>].<field identifier> := <expression> + * OR: etc., etc., etc. + */ + + if (assignFlags != 0) error(eARRAYTYPE); + assignFlags |= INDEXED_ASSIGNMENT; + + arrayIndex(typePtr->sParm.t.asize); + varPtr->sKind = typePtr->sParm.t.type; + varPtr->sParm.v.size = typePtr->sParm.t.asize; + pas_SimpleAssignment(varPtr, assignFlags); + break; + + default : + error(eINVTYPE); + break; + + } +} + +/***********************************************************************/ +/* Process simple assignment statement */ + +static void pas_Assignment(uint16_t storeOp, exprType assignType, + STYPE *varPtr, STYPE *typePtr) +{ + TRACE(lstFile,"[pas_Assignment]"); + + /* FORM: <variable OR function identifer> := <expression> */ + + if (token != tASSIGN) error (eASSIGN); + else getToken(); + + expression(assignType, typePtr); + pas_GenerateStackReference(storeOp, varPtr); +} + +/***********************************************************************/ +/* Process the assignment to a variable length string record */ + +static void pas_StringAssignment(STYPE *varPtr, STYPE *typePtr) +{ + exprType stringKind; + + TRACE(lstFile,"[pas_StringAssignment]"); + + /* FORM: <variable OR function identifer> := <expression> */ + + /* Verify that the assignment token follows the indentifier */ + + if (token != tASSIGN) error (eASSIGN); + else getToken(); + + /* Get the expression after assignment token. We'll take any kind + * of string expression. This is a hack to handle calls to system + * functions that return exprCString pointers that must be converted + * to exprString records upon assignment. + */ + + stringKind = expression(exprAnyString, typePtr); + + /* Place the address of the destination string structure instance on the + * stack. + */ + + pas_GenerateStackReference(opLAS, varPtr); + + /* Check if this is an assignment to a global allocated string, or + * to a stack reference to an allocated string. + */ + + if (varPtr->sKind == sRSTRING) + { + /* It is an assignment to a string reference -- + * Generate a runtime library call to copy the destination + * string string into the pascal string instance. The particular + * runtime call will account for any necesary string type conversion. + */ + + if ((stringKind == exprString) || (stringKind == exprStkString)) + { + /* It is a pascal string type. Current stack representation is: + * + * TOS(0)=address of dest string reference + * TOS(1)=length of source string + * TOS(2)=pointer to source string + */ + + pas_BuiltInFunctionCall(lbSTR2RSTR); + } + else if (stringKind == exprCString) + { + /* It is a 32-bit C string point. Current stack representation is: + * + * TOS(0)=address of dest string reference + * TOS(1)=MS 16-bits of 32-bit C source string pointer + * TOS(2)=LS 16-bits of 32-bit C source string pointer + */ + + pas_BuiltInFunctionCall(lbCSTR2RSTR); + } + } + else + { + /* It is an assignment to a allocated Pascal string -- + * Generate a runtime library call to copy the destination + * string string into the pascal string instance. The particular + * runtime call will account for any necesary string type conversion. + */ + + if ((stringKind == exprString) || (stringKind == exprStkString)) + { + /* It is a pascal string type. Current stack representation is: + * + * TOS(0)=address of dest string hdr + * TOS(1)=length of source string + * TOS(2)=pointer to source string + */ + + pas_BuiltInFunctionCall(lbSTR2STR); + } + else if (stringKind == exprCString) + { + /* It is a 32-bit C string point. Current stack representation is: + * + * TOS(0)=address of dest string hdr + * TOS(1)=MS 16-bits of 32-bit C source string pointer + * TOS(2)=LS 16-bits of 32-bit C source string pointer + */ + + pas_BuiltInFunctionCall(lbCSTR2STR); + } + } + + /* else ... type mismatch error already reported by expression() */ +} + +/***********************************************************************/ +/* Process a multiple word assignment statement */ + +static void pas_LargeAssignment(uint16_t storeOp, exprType assignType, + STYPE *varPtr, STYPE *typePtr) +{ + TRACE(lstFile,"[pas_LargeAssignment]"); + + /* FORM: <variable OR function identifer> := <expression> */ + + if (token != tASSIGN) error (eASSIGN); + else getToken(); + + expression(assignType, typePtr); + pas_GenerateDataSize(varPtr->sParm.v.size); + pas_GenerateStackReference(storeOp, varPtr); +} + +/***********************************************************************/ + +static void pas_GotoStatement(void) +{ + char labelname [8]; /* Label symbol table name */ + STYPE *label_ptr; /* Pointer to Label Symbol */ + + TRACE(lstFile,"[pas_GotoStatement]"); + + /* FORM: GOTO <integer> */ + + /* Get the token after the goto reserved word. It should be an <integer> */ + + getToken(); + if (token != tINT_CONST) + { + /* Token following the goto is not an integer */ + + error(eINVLABEL); + } + else + { + /* The integer label must be non-negative */ + + if (tknInt < 0) + { + error(eINVLABEL); + } + else + { + /* Find and verify the symbol associated with the label */ + + (void)sprintf (labelname, "%ld", tknInt); + if (!(label_ptr = findSymbol(labelname))) + { + error(eUNDECLABEL); + } + else if (label_ptr->sKind != sLABEL) + { + error(eINVLABEL); + } + else + { + /* Generate the branch to the label */ + + pas_GenerateDataOperation(opJMP, label_ptr->sParm.l.label); + } + } + + /* Get the token after the <integer> value */ + + getToken(); + } +} + +/***********************************************************************/ + +static void pas_LabelStatement(void) +{ + char labelName [8]; /* Label symbol table name */ + STYPE *labelPtr; /* Pointer to Label Symbol */ + + TRACE(lstFile,"[pas_LabelStatement]"); + + /* FORM: <integer> : */ + + /* Verify that the integer is a label name */ + + (void)sprintf (labelName, "%ld", tknInt); + if (!(labelPtr = findSymbol(labelName))) + { + error(eUNDECLABEL); + } + else if(labelPtr->sKind != sLABEL) + { + error(eINVLABEL); + } + + /* And also verify that the label symbol has not been previously + * defined. + */ + + else if(!(labelPtr->sParm.l.unDefined)) + { + error(eMULTLABEL); + } + else + { + /* Generate the label and indicate that it has been defined */ + + pas_GenerateDataOperation(opLABEL, labelPtr->sParm.l.label); + labelPtr->sParm.l.unDefined = false; + + /* We have to assume that we got here via a goto statement. + * We don't have logic in place to track changes to the level + * stack pointer (LSP) register, so we have no choice but to + * invalidate that register now. + */ + + pas_InvalidateCurrentStackLevel(); + } + + /* Skip over the label integer */ + + getToken(); + + /* Make sure that the label is followed by a colon */ + + if (token != ':') error (eCOLON); + else getToken(); +} + +/***********************************************************************/ + +static void pas_ProcStatement(void) +{ + STYPE *procPtr = tknPtr; + int size = 0; + + TRACE(lstFile,"[pas_ProcStatement]"); + + /* FORM: procedure-method-statement = + * procedure-method-specifier [ actual-parameter-list ] + * + * Skip over the procedure-method-statement + */ + + getToken(); + + /* Get the actual parameters (if any) associated with the procedure + * call. + */ + + size = actualParameterList(procPtr); + + /* Generate procedure call and stack adjustment (if required) + * Upon return from the procedure, the level stack pointer (LSP) + * may also be invalid. However, we rely on level level logic in + * pgen.c to manage this case (as well as the function call case). + */ + + pas_GenerateProcedureCall(procPtr); + if (size) + { + pas_GenerateDataOperation(opINDS, -size); + } +} + +/***********************************************************************/ + +static void pas_IfStatement(void) +{ + uint16_t else_label = ++label; + uint16_t endif_label = else_label; + int32_t thenLSP; + int32_t elseLSP; + + TRACE(lstFile,"[pas_IfStatement]"); + + /* FORM: IF <expression> THEN <statement> [ELSE <statement>] */ + + /* Skip over the IF token */ + + getToken(); + + /* Evaluate the boolean expression */ + + expression(exprBoolean, NULL); + + /* Make sure that the boolean expression is followed by the THEN token */ + + if (token != tTHEN) + error (eTHEN); + else + { + /* Skip over the THEN token */ + + getToken(); + + /* Generate a conditional branch to the "else_label." This will be a + * branch to either the ENDIF or to the ELSE location (if present). + */ + + pas_GenerateDataOperation(opJEQUZ, else_label); + + /* Save the value of the Level Stack Pointer (LSP) here. This will be + * the value of the LSP at the ENDIF label if there is no ELSE <statement> + * presentl. We will compare the elseLSP to the thenLSP at that point. + */ + + elseLSP = pas_GetCurrentStackLevel(); + + /* Parse the <statment> following the THEN token */ + + statement(); + + /* Save the LSP after generating the THEN <statement>. We will compare the + * elseLSP to the thenLSP below. + */ + + thenLSP = pas_GetCurrentStackLevel(); + + /* Check for optional ELSE <statement> */ + + if (token == tELSE) + { + /* Change the ENDIF label. Now instead of branching to + * the ENDIF, the logic above will branch to the ELSE + * logic generated here. + */ + + endif_label = ++label; + + /* Skip over the ELSE token */ + + getToken(); + + /* Generate Jump to ENDIF label after the THEN <statement> */ + + pas_GenerateDataOperation(opJMP, endif_label); + + /* Generate the ELSE label here. This is where we will go if + * the IF <expression> evaluates to false. + */ + + pas_GenerateDataOperation(opLABEL, else_label); + + /* Generate the ELSE <statement> then fall through to the + * ENDIF label. + */ + + statement(); + + /* Save the LSP after generating the ELSE <statement>. We will + * compare elseLSP to the thenLSP below. + */ + + elseLSP = pas_GetCurrentStackLevel(); + } + + /* Generate the ENDIF label here. Note that if no ELSE <statement> + * is present, this will be the same as the else_label. + */ + + pas_GenerateDataOperation(opLABEL, endif_label); + + /* We can get to this location through two of three pathes: (1) through the + * THEN <statement>, (2) from the IF <expression> if no ELSE <statement> + * is present, or (3) from the ELSE <statement>. If the LSP is different + * through these two pathes, then we will have to invalidate it. + */ + + if (thenLSP != elseLSP) + { + pas_InvalidateCurrentStackLevel(); + } + } +} + +/***********************************************************************/ + +void compoundStatement(void) +{ + TRACE(lstFile,"[compoundStatement]"); + + /* Process statements until END encountered */ + do + { + getToken(); + statement(); + } + while (token == ';'); + + /* Verify that it really was END */ + + if (token != tEND) error (eEND); + else getToken(); +} + +/***********************************************************************/ + +void pas_RepeatStatement () +{ + uint16_t rpt_label = ++label; + + TRACE(lstFile,"[pas_RepeatStatement]"); + + /* REPEAT <statement[;statement[statement...]]> UNTIL <expression> */ + + /* Generate top of loop label */ + + pas_GenerateDataOperation(opLABEL, rpt_label); + do + { + getToken(); + + /* Process <statement> */ + + statement(); + } + while (token == ';'); + + /* Verify UNTIL follows */ + + if (token != tUNTIL) error (eUNTIL); + else getToken(); + + /* Generate UNTIL <expression> */ + + expression(exprBoolean, NULL); + + /* Generate conditional branch to the top of loop */ + + pas_GenerateDataOperation(opJEQUZ, rpt_label); + + /* NOTE: The current LSP setting will be correct after the repeat + * loop because we fall through from the bottom of the loop after + * executing the body at least once. + */ +} + +/***********************************************************************/ + +static void pas_WhileStatement(void) +{ + uint16_t while_label = ++label; /* Top of loop label */ + uint16_t endwhile_label = ++label; /* End of loop label */ + uint32_t nLspChanges; + int32_t topOfLoopLSP; + bool bCheckLSP = false; + + TRACE(lstFile,"[pas_WhileStatement]"); + + /* Generate WHILE <expression> DO <statement> */ + + /* Skip over WHILE token */ + + getToken(); + + /* Set top of loop label */ + + pas_GenerateDataOperation(opLABEL, while_label); + + /* Evaluate the WHILE <expression> */ + + nLspChanges = pas_GetNStackLevelChanges(); + expression(exprBoolean, NULL); + + /* Generate a conditional jump to the end of the loop */ + + pas_GenerateDataOperation(opJEQUZ, endwhile_label); + + /* Save the level stack pointer (LSP) at the top of the + * loop. When first executed, this value will depend on + * logic prior to the loop or on values set in the + * WHILE <expression>. On subsequent loops, this value + * may be determined by logic within the loop body or + * have to restore this value when the loop terminates. + */ + + topOfLoopLSP = pas_GetCurrentStackLevel(); + + /* Does the WHILE <expression> logic set the LSP? */ + + if (nLspChanges == pas_GetNStackLevelChanges()) + { + /* Yes, then the value set in the WHILE <expression> + * is the one that will be in effect at the end_while + * label. + */ + + bCheckLSP = true; + } + + /* Verify that the DO token follows the expression */ + + if (token != tDO) error(eDO); + else getToken(); + + /* Generate the <statement> following the DO token */ + + statement(); + + /* Generate a branch to the top of the loop */ + + pas_GenerateDataOperation(opJMP, while_label); + + /* Set the bottom of loop label */ + + pas_GenerateDataOperation(opLABEL, endwhile_label); + + /* We always get here from the check at the top of the loop. + * Normally this will be from the branch from the bottom of + * the loop to the top of the loop. Then from the conditional + * branch at the top of the loop to here. + * + * But, we need to allow for the special case when the body + * of the while loop never executed. The flag bCheckLSP is + * set true if the conditional expression evaluation does not + * set the LSP. In the case, the current LSP will be either + * the LSP at the top of the loop (if he body was never executed) + * or the current LSP (the body executes at least once). + */ + + if (bCheckLSP) + { + if (topOfLoopLSP != pas_GetCurrentStackLevel()) + { + /* In thise case, there is uncertainty in the value of the + * LSP and we must invalidate it. It will be reset to the + * correct the next time that a level stack reference is + * performed. + */ + + pas_InvalidateCurrentStackLevel(); + } + } + else + { + /* Otherwise, make sure that the code generation logic knows + * the correct value of the LSP at this point. + */ + + pas_SetCurrentStackLevel(topOfLoopLSP); + } +} + +/***********************************************************************/ +/* This is helper function for pas_CaseStatement */ + +static bool pas_CheckInvalidateLSP(int32_t *pTerminalLSP) +{ + /* Check the LSP after evaluating the case <statement>. */ + + int32_t caseLSP = pas_GetCurrentStackLevel(); + if (caseLSP < 0) + { + /* If the LSP is invalid after any case <statement>, then it could + * be invalid at the end_case label as well. + */ + + return true; + } + else if (*pTerminalLSP < 0) + { + /* The value of the LSP at the end_case label has not + * yet been determined. It must be the value at the + * end of this case <statement> (or else it is invalid) + */ + + *pTerminalLSP = caseLSP; + } + else if (*pTerminalLSP != caseLSP) + { + /* The value of the LSP at the end of this case <statement> is + * different from the value of the LSP at the end of some other + * case <statement>. The value of the LSP at the end_case label + * will be indeterminate and must be invalidated. + */ + + return true; + } + /* So far so good */ + + return false; +} + +static void pas_CaseStatement(void) +{ + uint16_t this_case; + uint16_t next_case = ++label; + uint16_t end_case = ++label; + int32_t terminalLSP = -1; + bool bInvalidateLSP = false; + + TRACE(lstFile,"[pas_CaseStatement]"); + + /* Process "CASE <expression> OF" */ + + /* Skip over the CASE token */ + + getToken(); + + /* Evaluate the CASE <expression> */ + + expression(exprAnyOrdinal, NULL); + + /* Verify that CASE <expression> is followed with the OF token */ + + if (token != tOF) error (eOF); + else getToken(); + + /* Loop to process each case until END encountered */ + + for (;;) + { + this_case = next_case; + next_case = ++label; + + /* Process NON-STANDARD ELSE <statement> END */ + + if (token == tELSE) + { + getToken(); + + /* Set ELSE statement label */ + + pas_GenerateDataOperation(opLABEL, this_case); + + /* Evaluate ELSE statement */ + + statement(); + + /* Check the LSP after evaluating the ELSE <statement>. */ + + if (pas_CheckInvalidateLSP(&terminalLSP)) + { + /* The LSP will be invalid at the end case label. Set + * a flag so that we can handle invalidation of the LSP when + * we get to the end case label. + */ + + bInvalidateLSP = true; + } + + /* Verify that END follows the ELSE <statement> */ + + if (token != tEND) error(eEND); + else getToken(); + + /* Terminate FOR loop */ + + break; + } + + /* Process "<constant>[,<constant>[,...]] : <statement>" + * NOTE: We accept any kind of constant for the case selector; there + * really should be some check to assure that the constant is of the + * same type as the expression! + */ + + else + { + /* Loop for each <constant> in the case list */ + + for(;;) + { + /* Verify that we have a constant */ + + if (!isConstant(token)) + { + error(eINTCONST); + break; + } + + /* Generate a comparison of the CASE expression and the constant. + * + * First duplicate the value to be compared (from the CASE <expression>) + * and push the comparison value (from the <constant>:) + */ + + pas_GenerateSimple(opDUP); + pas_GenerateDataOperation(opPUSH, tknInt); + + /* The kind of comparison we generate depends on if we have to + * jump over other case selector comparsions to the statement + * or if we can just fall through to the statement + */ + + /* Skip over the constant */ + + getToken(); + + /* If there are multiple constants, they will be separated with + * commas. + */ + + if (token == ',') + { + /* Generate jump to <statement> */ + + pas_GenerateDataOperation(opJEQUZ, this_case); + + /* Skip over comma */ + + getToken(); + } + else + { + /* else jump to the next case */ + + pas_GenerateDataOperation(opJNEQZ, next_case); + break; + } + } + + /* Then process ... : <statement> */ + + /* Verify colon presence */ + + if (token != ':') error(eCOLON); + else getToken(); + + /* Set CASE label */ + + pas_GenerateDataOperation(opLABEL, this_case); + + /* Evaluate <statement> */ + + statement(); + + /* Jump to exit CASE */ + + pas_GenerateDataOperation(opJMP, end_case); + + /* Check the LSP after evaluating the case <statement>. */ + + if (pas_CheckInvalidateLSP(&terminalLSP)) + { + /* If the LSP will be invalid at the end case label. Set + * a flag so that we can handle invalidation of the LSP when + * we get to the end case label. + */ + + bInvalidateLSP = true; + } + } + + /* Check if there are more statements. If not, verify END present */ + + if (token == ';') + { + getToken(); + } + else if (token == tEND) + { + getToken(); + break; + } + else + { + error (eEND); + break; + } + } + + /* Generate ENDCASE label and Pop CASE <expression> from stack */ + + pas_GenerateDataOperation(opLABEL, end_case); + pas_GenerateDataOperation(opINDS, -sINT_SIZE); + + /* We may have gotten to this point from many different case <statements>. + * The flag bInvalidateLSP will be set if the LSP is not the same for + * each of these pathes. Invalidating the LSP will force it to be reloaded + * when the next level stack access is done. + */ + + if (bInvalidateLSP) + { + pas_InvalidateCurrentStackLevel(); + } +} + +/***********************************************************************/ +static void pas_ForStatement(void) +{ + STYPE *varPtr; + uint16_t forLabel = ++label; + uint16_t endForLabel = ++label; + uint16_t jmpOp; + uint16_t modOp; + int32_t topOfLoopLSP; + + TRACE(lstFile,"[pas_ForStatement]"); + + /* FOR <assigment statement> <TO, DOWNTO> <expression> DO <statement> */ + + /* Skip over the FOR token */ + + getToken(); + + /* Get and verify the left side of the assignment. */ + if ((token != sINT) && (token != sSUBRANGE)) + error(eINTVAR); + else + { + /* Save the token associated with the left side of the assignment + * and evaluate the integer assignment. + */ + + varPtr = tknPtr; + getToken(); + + /* Generate the assignment to the integer variable */ + + pas_Assignment(opSTS, exprInteger, tknPtr, tknPtr->sParm.v.parent); + + /* Determine if this is a TO or a DOWNTO loop and set up the opCodes + * to generate appropriately. + */ + + if (token == tDOWNTO) + { + jmpOp = opJGT; + modOp = opDEC; + getToken(); + } + else if (token == tTO) + { + jmpOp = opJLT; + modOp = opINC; + getToken(); + } + else + error (eTOorDOWNTO); + + /* Evaluate <expression> DO */ + + expression(exprInteger, varPtr->sParm.v.parent); + + /* Verify that the <expression> is followed by the DO token */ + + if (token != tDO) error (eDO); + else getToken(); + + /* Generate top of loop label */ + + pas_GenerateDataOperation(opLABEL, forLabel); + + /* Generate the top of loop comparison. Duplicate the end of loop + * value, push the current value, and perform the comparison. + */ + + pas_GenerateSimple(opDUP); + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateDataOperation(jmpOp, endForLabel); + + /* Save the level stack pointer (LSP) at the top of the FOR + * loop. When first executed, this value will depend on + * logic prior to the loop body. On subsequent loops, this + * value may be determined by logic within the loop body. + */ + + topOfLoopLSP = pas_GetCurrentStackLevel(); + + /* Evaluate the for statement <statement> */ + + statement(); + + /* Generate end of loop logic: Load the variable, modify the + * variable, store the variable, and jump unconditionally to the + * top of the loop. + */ + + pas_GenerateStackReference(opLDS, varPtr); + pas_GenerateSimple(modOp); + pas_GenerateStackReference(opSTS, varPtr); + pas_GenerateDataOperation(opJMP, forLabel); + + /* Generate the end of loop label. This is where the conditional + * branch at the top of the loop will come to. + */ + + pas_GenerateDataOperation(opLABEL, endForLabel); + pas_GenerateDataOperation(opINDS, -sINT_SIZE); + + /* We always get here from the check at the top of the loop. + * Normally this will be from the branch from the bottom of + * the loop to the top of the loop. Then from the conditional + * branch at the top of the loop to here. + * + * But, we need to allow for the special case when the body + * of the for loop never executed. In this case, the LSP at + * the first time into the loop may differ from the LSP at + * subsequent times into the loop. If this is the case, then + * will will have to invalidate the LSP. + */ + + if (topOfLoopLSP != pas_GetCurrentStackLevel()) + { + /* In thise case, there is uncertainty in the value of the + * LSP and we must invalidate it. It will be reset to the + * correct the next time that a level stack reference is + * performed. + */ + + pas_InvalidateCurrentStackLevel(); + } + } +} + +/***********************************************************************/ +static void pas_WithStatement(void) +{ + WTYPE saveWithRecord; + + TRACE(lstFile,"[pas_WithStatement]"); + + /* Generate WITH <variable[,variable[...]] DO <statement> */ + + /* Save the current WITH pointer. Only one WITH can be active at + * any given time. + */ + + saveWithRecord = withRecord; + + /* Process each RECORD or RECORD OBJECT in the <variable> list */ + + getToken(); + for(;;) + { + /* A RECORD type variable may be used in the WITH statement only if + * there is no other WITH active + */ + + if ((token == sRECORD) && (!withRecord.parent)) + { + /* Save the RECORD variable as the new withRecord */ + + withRecord.level = tknPtr->sLevel; + withRecord.pointer = false; + withRecord.varParm = false; + withRecord.offset = tknPtr->sParm.v.offset; + withRecord.parent = tknPtr->sParm.v.parent; + + /* Skip over the RECORD variable */ + + getToken(); + } + + /* A RECORD VAR parameter may also be used in the WITH statement + * (again only if there is no other WITH active) + */ + + else if ((token == sVAR_PARM) && + (!withRecord.parent) && + (tknPtr->sParm.v.parent->sParm.t.type == sRECORD)) + { + /* Save the RECORD VAR parameter as the new withRecord */ + + withRecord.level = tknPtr->sLevel; + withRecord.pointer = true; + withRecord.varParm = true; + withRecord.offset = tknPtr->sParm.v.offset; + withRecord.parent = tknPtr->sParm.v.parent; + + /* Skip over the RECORD VAR parameter */ + + getToken(); + } + + /* A pointer to a RECORD may also be used in the WITH statement + * (again only if there is no other WITH active) + */ + + else if ((token == sPOINTER) && + (!withRecord.parent) && + (tknPtr->sParm.v.parent->sParm.t.type == sRECORD)) + { + /* Save the RECORD pointer as the new withRecord */ + + withRecord.level = tknPtr->sLevel; + withRecord.pointer = true; + withRecord.pointer = false; + withRecord.offset = tknPtr->sParm.v.offset; + withRecord.parent = tknPtr->sParm.v.parent; + + /* Skip over the RECORD pointer */ + + getToken(); + + /* Verify that deferencing is specified! */ + + if (token != '^') error(eRECORDVAR); + else getToken(); + } + + /* A RECORD_OBJECT may be used in the WITH statement if the field + * is from the same sRECORD type and is itself of type RECORD. + */ + + else if ((token == sRECORD_OBJECT) && + (tknPtr->sParm.r.record == withRecord.parent) && + (tknPtr->sParm.r.parent->sParm.t.type == sRECORD)) + { + /* Okay, update the withRecord to use this record field */ + + if (withRecord.pointer) + withRecord.index += tknPtr->sParm.r.offset; + else + withRecord.offset += tknPtr->sParm.r.offset; + + withRecord.parent = tknPtr->sParm.r.parent; + + /* Skip over the sRECORD_OBJECT */ + + getToken(); + } + + /* Anything else is an error */ + + else + { + error(eRECORDVAR); + break; + } + + + /* Check if there are multiple variables in the WITH statement */ + + if (token == ',') getToken(); + else break; + } + + /* Verify that the RECORD list is terminated with DO */ + + if (token != tDO) error (eDO); + else getToken(); + + /* Then process the statement following the WITH */ + + statement(); + + /* Restore the previous value of the withRecord */ + + withRecord = saveWithRecord; +} + +/***********************************************************************/ + diff --git a/misc/pascal/pascal/ptbl.c b/misc/pascal/pascal/ptbl.c index 528c5482f5..dea2bcfd38 100644 --- a/misc/pascal/pascal/ptbl.c +++ b/misc/pascal/pascal/ptbl.c @@ -1,690 +1,692 @@ -/***************************************************************
- * ptbl.c
- * Table Management Package
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************/
-
-/***************************************************************
- * Included Files
- ***************************************************************/
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-#include "config.h"
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "pedefs.h"
-
-#include "pas.h"
-#include "ptbl.h"
-#include "perr.h"
-
-/***************************************************************
- * Private Function Prototypes
- ***************************************************************/
-
-static STYPE *addSymbol(char *name, sint16 type);
-
-/***************************************************************
- * Public Variables
- ***************************************************************/
-
-STYPE *parentInteger = NULL;
-STYPE *parentString = NULL;
-
-/***************************************************************
- * Private Variables
- ***************************************************************/
-/* NOTES in the following:
- * (1) Standard Pascal reserved word
- * (2) Standard Pascal Function
- * (3) Standard Pascal Procedure
- * (4) Extended (or non-standard) Pascal reserved word
- * (5) Extended (or non-standard) Pascal function
- * (6) Extended (or non-standard) Pascal procedure
- */
-
-static const RTYPE rsw[] = /* Reserved word list */
-{
- {"ABS", tFUNC, txABS}, /* (2) */
- {"AND", tAND, txNONE}, /* (1) */
- {"ARCTAN", tFUNC, txARCTAN}, /* (2) */
- {"ARRAY", tARRAY, txNONE}, /* (1) */
- {"BEGIN", tBEGIN, txNONE}, /* (1) */
- {"CASE", tCASE, txNONE}, /* (1) */
- {"CHR", tFUNC, txCHR}, /* (2) */
- {"CONST", tCONST, txNONE}, /* (1) */
- {"COS", tFUNC, txCOS}, /* (2) */
- {"DIV", tDIV, txNONE}, /* (1) */
- {"DO", tDO, txNONE}, /* (1) */
- {"DOWNTO", tDOWNTO, txNONE}, /* (1) */
- {"ELSE", tELSE, txNONE}, /* (1) */
- {"END", tEND, txNONE}, /* (1) */
- {"EOF", tFUNC, txEOF}, /* (2) */
- {"EOLN", tFUNC, txEOLN}, /* (2) */
- {"EXP", tFUNC, txEXP}, /* (2) */
- {"FILE", tFILE, txNONE}, /* (1) */
- {"FOR", tFOR, txNONE}, /* (1) */
- {"FUNCTION", tFUNCTION, txNONE}, /* (1) */
- {"GET", tPROC, txGET}, /* (3) */
- {"GETENV", tFUNC, txGETENV}, /* (5) */
- {"GOTO", tGOTO, txNONE}, /* (1) */
- {"IF", tIF, txNONE}, /* (1) */
- {"IMPLEMENTATION", tIMPLEMENTATION, txNONE}, /* (4) */
- {"IN", tIN, txNONE}, /* (1) */
- {"INTERFACE", tINTERFACE, txNONE}, /* (4) */
- {"LABEL", tLABEL, txNONE}, /* (1) */
- {"LN", tFUNC, txLN}, /* (2) */
- {"MOD", tMOD, txNONE}, /* (1) */
- {"NEW", tPROC, txNEW}, /* (3) */
- {"NOT", tNOT, txNONE}, /* (1) */
- {"ODD", tFUNC, txODD}, /* (2) */
- {"OF", tOF, txNONE}, /* (1) */
- {"OR", tOR, txNONE}, /* (1) */
- {"ORD", tFUNC, txORD}, /* (2) */
- {"PACK", tPROC, txPACK}, /* (3) */
- {"PACKED", tPACKED, txNONE}, /* (1) */
- {"PAGE", tPROC, txPAGE}, /* (3) */
- {"PRED", tFUNC, txPRED}, /* (2) */
- {"PROCEDURE", tPROCEDURE, txNONE}, /* (1) */
- {"PROGRAM", tPROGRAM, txNONE}, /* (1) */
- {"PUT", tPROC, txPUT}, /* (3) */
- {"READ", tPROC, txREAD}, /* (3) */
- {"READLN", tPROC, txREADLN}, /* (3) */
- {"RECORD", tRECORD, txNONE}, /* (1) */
- {"REPEAT", tREPEAT, txNONE}, /* (1) */
- {"RESET", tPROC, txRESET}, /* (3) */
- {"REWRITE", tPROC, txREWRITE}, /* (3) */
- {"ROUND", tFUNC, txROUND}, /* (2) */
- {"SET", tSET, txNONE}, /* (1) */
- {"SHL", tSHL, txNONE}, /* (4) */
- {"SHR", tSHR, txNONE}, /* (4) */
- {"SIN", tFUNC, txSIN}, /* (2) */
- {"SQR", tFUNC, txSQR}, /* (2) */
- {"SQRT", tFUNC, txSQRT}, /* (2) */
- {"SUCC", tFUNC, txSUCC}, /* (2) */
- {"THEN", tTHEN, txNONE}, /* (1) */
- {"TO", tTO, txNONE}, /* (1) */
- {"TRUNC", tFUNC, txTRUNC}, /* (2) */
- {"TYPE", tTYPE, txNONE}, /* (1) */
- {"UNIT", tUNIT, txNONE}, /* (4) */
- {"UNPACK", tPROC, txUNPACK}, /* (3) */
- {"UNTIL", tUNTIL, txNONE}, /* (1) */
- {"USES", tUSES, txNONE}, /* (4) */
- {"VAL", tPROC, txVAL}, /* (6) */
- {"VAR", tVAR, txNONE}, /* (1) */
- {"WHILE", tWHILE, txNONE}, /* (1) */
- {"WITH", tWITH, txNONE}, /* (1) */
- {"WRITE", tPROC, txWRITE}, /* (3) */
- {"WRITELN", tPROC, txWRITELN}, /* (3) */
- {NULL, 0, txNONE} /* List terminator */
-};
-
-static STYPE *symbolTable; /* Symbol Table */
-
-/**************************************************************/
-
-const RTYPE *findReservedWord (char *name)
-{
- register const RTYPE *ptr; /* Point into reserved word list */
- register sint16 cmp; /* 0=equal; >0=past it */
-
- for (ptr = rsw; (ptr->rname); ptr++) /* Try each each reserved word */
- {
- cmp = strcmp(ptr->rname, name); /* Check if names match */
- if (!cmp) /* Check if names match */
- return ptr; /* Return pointer to entry if match */
- else if (cmp > 0) /* Exit early if we are past it */
- break;
- } /* end for */
-
- return (RTYPE*)NULL; /* return NULL pointer if no match */
-
-} /* fnd findReservedWord */
-
-/***************************************************************/
-
-STYPE *findSymbol (char *inName)
-{
- register sint16 i; /* loop index */
-
- for (i=nsym-1; i>=sym_strt; i--)
- if (symbolTable[i].sName)
- if (!strcmp(symbolTable[i].sName, inName))
- return &symbolTable[i];
- return (STYPE*)NULL;
-
-} /* end findSymbol */
-
-/***************************************************************/
-
-static STYPE *addSymbol(char *name, sint16 type)
-{
- TRACE(lstFile,"[addSymbol]");
-
- /* Check for Symbol Table overflow */
- if (nsym >= MAX_SYM) {
-
- fatal(eOVF);
- return (STYPE *)NULL;
-
- } /* end if */
- else {
-
- /* Clear all elements of the symbol table entry */
- memset(&symbolTable[nsym], 0, sizeof(STYPE));
-
- /* Set the elements which are independent of sKind */
- symbolTable[nsym].sName = name;
- symbolTable[nsym].sKind = type;
- symbolTable[nsym].sLevel = level;
-
- return &symbolTable[nsym++];
-
- } /* end else */
-
-} /* end addSymbol */
-
-/***************************************************************/
-
-STYPE *addTypeDefine(char *name, ubyte type, uint16 size, STYPE *parent)
-{
- STYPE *typePtr;
-
- TRACE(lstFile,"[addTypeDefine]");
-
- /* Get a slot in the symbol table */
-
- typePtr = addSymbol(name, sTYPE);
- if (typePtr)
- {
- /* Add the type definition to the symbol table
- * NOTES:
- * 1. The minValue and maxValue fields (for scalar and subrange)
- * types must be set external to this function
- * 2. For most variables, allocated size/type (rsize/rtype) and
- * the clone size/type are the same. If this is not the case,
- * external logic will need to clarify this as well.
- * 3. We assume that there are no special flags associated with
- * the type.
- */
-
- typePtr->sParm.t.type = type;
- typePtr->sParm.t.rtype = type;
- typePtr->sParm.t.flags = 0;
- typePtr->sParm.t.asize = size;
- typePtr->sParm.t.rsize = size;
- typePtr->sParm.t.parent = parent;
-
- } /* end if */
-
- /* Return a pointer to the new constant symbol */
-
- return typePtr;
-
-} /* end addTypeDefine */
-
-/***************************************************************/
-
-STYPE *addConstant(char *name, ubyte type, sint32 *value, STYPE *parent)
-{
- STYPE *constPtr;
-
- TRACE(lstFile,"[addConstant]");
-
- /* Get a slot in the symbol table */
- constPtr = addSymbol(name, type);
- if (constPtr) {
-
- /* Add the value of the constant to the symbol table */
- if (type == tREAL_CONST)
- constPtr->sParm.c.val.f = *((float64 *) value);
- else
- constPtr->sParm.c.val.i = *value;
- constPtr->sParm.c.parent = parent;
-
- } /* end if */
-
- /* Return a pointer to the new constant symbol */
-
- return constPtr;
-
-} /* end addConstant */
-
-/***************************************************************/
-
-STYPE *addStringConst(char *name, uint32 offset, uint32 size)
-{
- STYPE *stringPtr;
-
- TRACE(lstFile,"[addStringConst]");
-
- /* Get a slot in the symbol table */
-
- stringPtr = addSymbol(name, sSTRING_CONST);
- if (stringPtr)
- {
- /* Add the value of the constant to the symbol table */
-
- stringPtr->sParm.s.offset = offset;
- stringPtr->sParm.s.size = size;
- } /* end if */
-
- /* Return a pointer to the new string symbol */
-
- return stringPtr;
-
-} /* end addString */
-
-/***************************************************************/
-
-STYPE *addFile(char *name, uint16 fileNumber)
-{
- STYPE *filePtr;
-
- TRACE(lstFile,"[addFile]");
-
- /* Get a slot in the symbol table */
- filePtr = addSymbol(name, sFILE);
- if (filePtr) {
-
- /* Add the fileNumber to the symbol table */
- filePtr->sParm.fileNumber = fileNumber;
-
- } /* end if */
-
- /* Return a pointer to the new file symbol */
-
- return filePtr;
-
-} /* end addFile */
-
-/***************************************************************/
-
-STYPE *addProcedure(char *name, ubyte type, uint16 label,
- uint16 nParms, STYPE *parent)
-{
- STYPE *procPtr;
-
- TRACE(lstFile,"[addProcedure]");
-
- /* Get a slot in the symbol table */
- procPtr = addSymbol(name, type);
- if (procPtr)
- {
- /* Add the procedure/function definition to the symbol table */
-
- procPtr->sParm.p.label = label;
- procPtr->sParm.p.nParms = nParms;
- procPtr->sParm.p.flags = 0;
- procPtr->sParm.p.symIndex = 0;
- procPtr->sParm.p.parent = parent;
- } /* end if */
-
- /* Return a pointer to the new procedure/function symbol */
-
- return procPtr;
-
-} /* end addProcedure */
-
-/***************************************************************/
-
-STYPE *addVariable(char *name, ubyte type, uint16 offset,
- uint16 size, STYPE *parent)
-{
- STYPE *varPtr;
-
- TRACE(lstFile,"[addVariable]");
-
- /* Get a slot in the symbol table */
-
- varPtr = addSymbol(name, type);
- if (varPtr)
- {
- /* Add the variable to the symbol table */
-
- varPtr->sParm.v.offset = offset;
- varPtr->sParm.v.size = size;
- varPtr->sParm.v.flags = 0;
- varPtr->sParm.v.symIndex = 0;
- varPtr->sParm.v.parent = parent;
- } /* end if */
-
- /* Return a pointer to the new variable symbol */
-
- return varPtr;
-
-} /* end addFile */
-
-/***************************************************************/
-
-STYPE *addLabel(char *name, uint16 label)
-{
- STYPE *labelPtr;
-
- TRACE(lstFile,"[addLabel]");
-
- /* Get a slot in the symbol table */
-
- labelPtr = addSymbol(name, sLABEL);
- if (labelPtr)
- {
- /* Add the label to the symbol table */
-
- labelPtr->sParm.l.label = label;
- labelPtr->sParm.l.unDefined = TRUE;
- } /* end if */
-
- /* Return a pointer to the new label symbol */
-
- return labelPtr;
-
-} /* end addFile */
-
-/***************************************************************/
-
-STYPE *addField(char *name, STYPE *record)
-{
- STYPE *fieldPtr;
-
- TRACE(lstFile,"[addField]");
-
- /* Get a slot in the symbol table */
- fieldPtr = addSymbol(name, sRECORD_OBJECT);
- if (fieldPtr) {
-
- /* Add the field to the symbol table */
- fieldPtr->sParm.r.record = record;
-
- } /* end if */
-
- /* Return a pointer to the new variable symbol */
-
- return fieldPtr;
-
-} /* end addField */
-
-/***************************************************************/
-
-void primeSymbolTable(unsigned long symbolTableSize)
-{
- sint32 trueValue = -1;
- sint32 falseValue = 0;
- sint32 maxintValue = MAXINT;
- STYPE *typePtr;
- register sint16 i;
-
- TRACE(lstFile,"[primeSymbolTable]");
-
- /* Allocate and initialize symbol table */
-
- symbolTable = malloc(symbolTableSize * sizeof(STYPE));
- if (!symbolTable)
- {
- fatal(eNOMEMORY);
- }
-
- nsym = 0;
-
- /* Add the standard constants to the symbol table */
-
- (void)addConstant("TRUE", tBOOLEAN_CONST, &trueValue, NULL);
- (void)addConstant("FALSE", tBOOLEAN_CONST, &falseValue, NULL);
- (void)addConstant("MAXINT", tINT_CONST, &maxintValue, NULL);
- (void)addConstant("NIL", tNIL, &falseValue, NULL);
-
- /* Add the standard types to the symbol table */
-
- typePtr = addTypeDefine("INTEGER", sINT, sINT_SIZE, NULL);
- if (typePtr)
- {
- parentInteger = typePtr;
- typePtr->sParm.t.minValue = MININT;
- typePtr->sParm.t.maxValue = MAXINT;
- } /* end if */
-
- typePtr = addTypeDefine("BOOLEAN", sBOOLEAN, sBOOLEAN_SIZE, NULL);
- if (typePtr)
- {
- typePtr->sParm.t.minValue = falseValue;
- typePtr->sParm.t.maxValue = trueValue;
- } /* end if */
-
- typePtr = addTypeDefine("REAL", sREAL, sREAL_SIZE, NULL);
-
- typePtr = addTypeDefine("CHAR", sCHAR, sCHAR_SIZE, NULL);
- if (typePtr)
- {
- typePtr->sParm.t.minValue = MINCHAR;
- typePtr->sParm.t.maxValue = MAXCHAR;
- } /* end if */
-
- typePtr = addTypeDefine("TEXT", sFILE_OF, sCHAR_SIZE, NULL);
- if (typePtr)
- {
- typePtr->sParm.t.subType = sCHAR;
- typePtr->sParm.t.minValue = MINCHAR;
- typePtr->sParm.t.maxValue = MAXCHAR;
- } /* end if */
-
- /* Add some enhanced Pascal standard" types to the symbol table
- *
- * string is represent by a 256 byte memory regions consisting of
- * one byte for the valid string length plus 255 bytes for string
- * storage
- */
-
- typePtr = addTypeDefine("STRING", sSTRING, sSTRING_SIZE, NULL);
- if (typePtr)
- {
- parentString = typePtr;
- typePtr->sParm.t.rtype = sRSTRING;
- typePtr->sParm.t.subType = sCHAR;
- typePtr->sParm.t.rsize = sRSTRING_SIZE;
- typePtr->sParm.t.flags = STYPE_VARSIZE;
- typePtr->sParm.t.minValue = MINCHAR;
- typePtr->sParm.t.maxValue = MAXCHAR;
- } /* end if */
-
- /* Add the standard files to the symbol table */
-
- (void)addFile("INPUT", 0);
- (void)addFile("OUTPUT", 0);
-
- /* Initialize files table */
-
- for (i = 0; i <= MAX_FILES; i++)
- {
- files [i].defined = 0;
- files [i].flevel = 0;
- files [i].ftype = 0;
- files [i].faddr = 0;
- files [i].fsize = 0;
- } /* end for */
-} /* end primeSymbolTable */
-
-/***************************************************************/
-
-void verifyLabels(sint32 symIndex)
-{
- register sint16 i; /* loop index */
-
- for (i=symIndex; i < nsym; i++)
- if ((symbolTable[i].sKind == sLABEL)
- && (symbolTable[i].sParm.l.unDefined))
- error (eUNDEFLABEL);
-} /* end verifyLabels */
-
-/***************************************************************/
-
-#if CONFIG_DEBUG
-const char noName[] = "********";
-void dumpTables(void)
-{
- register sint16 i;
-
- fprintf(lstFile,"\nSYMBOL TABLE:\n");
- fprintf(lstFile,"[ Addr ] NAME KIND LEVL\n");
-
- for (i = 0; i < nsym; i++)
- {
- fprintf(lstFile,"[%08lx] ", (uint32)&symbolTable[i]);
-
- if (symbolTable[i].sName)
- fprintf(lstFile, "%8s", symbolTable[i].sName);
- else
- fprintf(lstFile, "%8s", noName);
-
- fprintf(lstFile," %04x %04x ",
- symbolTable[i].sKind,
- symbolTable[i].sLevel);
-
- switch (symbolTable[i].sKind)
- {
- /* Constants */
-
- case tINT_CONST :
- case tCHAR_CONST :
- case tBOOLEAN_CONST :
- case tNIL :
- case sSCALAR :
- fprintf(lstFile, "val=%ld parent=[%08lx]\n",
- symbolTable[i].sParm.c.val.i,
- (unsigned long)symbolTable[i].sParm.c.parent);
- break;
- case tREAL_CONST :
- fprintf(lstFile, "val=%f parent=[%08lx]\n",
- symbolTable[i].sParm.c.val.f,
- (unsigned long)symbolTable[i].sParm.c.parent);
- break;
-
- /* Types */
-
- case sTYPE :
- fprintf(lstFile,
- "type=%02x rtype=%02x subType=%02x flags=%02x "
- "asize=%ld rsize=%ld minValue=%ld maxValue=%ld "
- "parent=[%08lx]\n",
- symbolTable[i].sParm.t.type,
- symbolTable[i].sParm.t.rtype,
- symbolTable[i].sParm.t.subType,
- symbolTable[i].sParm.t.flags,
- symbolTable[i].sParm.t.asize,
- symbolTable[i].sParm.t.rsize,
- symbolTable[i].sParm.t.minValue,
- symbolTable[i].sParm.t.maxValue,
- (unsigned long)symbolTable[i].sParm.t.parent);
- break;
-
- /* Procedures/Functions */
-
- /* Procedures and Functions */
-
- case sPROC :
- case sFUNC :
- fprintf(lstFile,
- "label=L%04x nParms=%d flags=%02x parent=[%08lx]\n",
- symbolTable[i].sParm.p.label,
- symbolTable[i].sParm.p.nParms,
- symbolTable[i].sParm.p.flags,
- (unsigned long)symbolTable[i].sParm.p.parent);
- break;
-
- /* Labels */
-
- case sLABEL :
- fprintf(lstFile, "label=L%04x unDefined=%d\n",
- symbolTable[i].sParm.l.label,
- symbolTable[i].sParm.l.unDefined);
- break;
-
- /* Files */
-
- case sFILE :
- fprintf(lstFile, "fileNumber=%d\n",
- symbolTable[i].sParm.fileNumber);
- break;
-
- /* Variables */
-
- case sINT :
- case sBOOLEAN :
- case sCHAR :
- case sREAL :
- case sTEXT :
- case sARRAY :
- case sPOINTER :
- case sVAR_PARM :
- case sRECORD :
- case sFILE_OF :
- fprintf(lstFile, "offset=%ld size=%ld flags=%02x parent=[%08lx]\n",
- symbolTable[i].sParm.v.offset,
- symbolTable[i].sParm.v.size,
- symbolTable[i].sParm.v.flags,
- (unsigned long)symbolTable[i].sParm.v.parent);
- break;
-
- /* Record objects */
-
- case sRECORD_OBJECT :
- fprintf(lstFile,
- "offset=%ld size=%ld record=[%08lx] parent=[%08lx]\n",
- symbolTable[i].sParm.r.offset,
- symbolTable[i].sParm.r.size,
- (unsigned long)symbolTable[i].sParm.r.record,
- (unsigned long)symbolTable[i].sParm.r.parent);
- break;
-
- /* Constant strings */
-
- case sSTRING_CONST :
- fprintf(lstFile, "offset=%04lx size=%ld\n",
- symbolTable[i].sParm.s.offset,
- symbolTable[i].sParm.s.size);
- break;
-
- default :
- fprintf(lstFile, "Unknown sKind\n");
- break;
-
- } /* end switch */
- } /* end for */
-
-} /* end dumpTables */
-#endif
-
-/***************************************************************/
-
+/*************************************************************** + * ptbl.c + * Table Management Package + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************/ + +/*************************************************************** + * Included Files + ***************************************************************/ + +#include <sys/types.h> +#include <stdbool.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +#include "config.h" +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "pedefs.h" + +#include "pas.h" +#include "ptbl.h" +#include "perr.h" + +/*************************************************************** + * Private Function Prototypes + ***************************************************************/ + +static STYPE *addSymbol(char *name, int16_t type); + +/*************************************************************** + * Public Variables + ***************************************************************/ + +STYPE *parentInteger = NULL; +STYPE *parentString = NULL; + +/*************************************************************** + * Private Variables + ***************************************************************/ +/* NOTES in the following: + * (1) Standard Pascal reserved word + * (2) Standard Pascal Function + * (3) Standard Pascal Procedure + * (4) Extended (or non-standard) Pascal reserved word + * (5) Extended (or non-standard) Pascal function + * (6) Extended (or non-standard) Pascal procedure + */ + +static const RTYPE rsw[] = /* Reserved word list */ +{ + {"ABS", tFUNC, txABS}, /* (2) */ + {"AND", tAND, txNONE}, /* (1) */ + {"ARCTAN", tFUNC, txARCTAN}, /* (2) */ + {"ARRAY", tARRAY, txNONE}, /* (1) */ + {"BEGIN", tBEGIN, txNONE}, /* (1) */ + {"CASE", tCASE, txNONE}, /* (1) */ + {"CHR", tFUNC, txCHR}, /* (2) */ + {"CONST", tCONST, txNONE}, /* (1) */ + {"COS", tFUNC, txCOS}, /* (2) */ + {"DIV", tDIV, txNONE}, /* (1) */ + {"DO", tDO, txNONE}, /* (1) */ + {"DOWNTO", tDOWNTO, txNONE}, /* (1) */ + {"ELSE", tELSE, txNONE}, /* (1) */ + {"END", tEND, txNONE}, /* (1) */ + {"EOF", tFUNC, txEOF}, /* (2) */ + {"EOLN", tFUNC, txEOLN}, /* (2) */ + {"EXP", tFUNC, txEXP}, /* (2) */ + {"FILE", tFILE, txNONE}, /* (1) */ + {"FOR", tFOR, txNONE}, /* (1) */ + {"FUNCTION", tFUNCTION, txNONE}, /* (1) */ + {"GET", tPROC, txGET}, /* (3) */ + {"GETENV", tFUNC, txGETENV}, /* (5) */ + {"GOTO", tGOTO, txNONE}, /* (1) */ + {"IF", tIF, txNONE}, /* (1) */ + {"IMPLEMENTATION", tIMPLEMENTATION, txNONE}, /* (4) */ + {"IN", tIN, txNONE}, /* (1) */ + {"INTERFACE", tINTERFACE, txNONE}, /* (4) */ + {"LABEL", tLABEL, txNONE}, /* (1) */ + {"LN", tFUNC, txLN}, /* (2) */ + {"MOD", tMOD, txNONE}, /* (1) */ + {"NEW", tPROC, txNEW}, /* (3) */ + {"NOT", tNOT, txNONE}, /* (1) */ + {"ODD", tFUNC, txODD}, /* (2) */ + {"OF", tOF, txNONE}, /* (1) */ + {"OR", tOR, txNONE}, /* (1) */ + {"ORD", tFUNC, txORD}, /* (2) */ + {"PACK", tPROC, txPACK}, /* (3) */ + {"PACKED", tPACKED, txNONE}, /* (1) */ + {"PAGE", tPROC, txPAGE}, /* (3) */ + {"PRED", tFUNC, txPRED}, /* (2) */ + {"PROCEDURE", tPROCEDURE, txNONE}, /* (1) */ + {"PROGRAM", tPROGRAM, txNONE}, /* (1) */ + {"PUT", tPROC, txPUT}, /* (3) */ + {"READ", tPROC, txREAD}, /* (3) */ + {"READLN", tPROC, txREADLN}, /* (3) */ + {"RECORD", tRECORD, txNONE}, /* (1) */ + {"REPEAT", tREPEAT, txNONE}, /* (1) */ + {"RESET", tPROC, txRESET}, /* (3) */ + {"REWRITE", tPROC, txREWRITE}, /* (3) */ + {"ROUND", tFUNC, txROUND}, /* (2) */ + {"SET", tSET, txNONE}, /* (1) */ + {"SHL", tSHL, txNONE}, /* (4) */ + {"SHR", tSHR, txNONE}, /* (4) */ + {"SIN", tFUNC, txSIN}, /* (2) */ + {"SQR", tFUNC, txSQR}, /* (2) */ + {"SQRT", tFUNC, txSQRT}, /* (2) */ + {"SUCC", tFUNC, txSUCC}, /* (2) */ + {"THEN", tTHEN, txNONE}, /* (1) */ + {"TO", tTO, txNONE}, /* (1) */ + {"TRUNC", tFUNC, txTRUNC}, /* (2) */ + {"TYPE", tTYPE, txNONE}, /* (1) */ + {"UNIT", tUNIT, txNONE}, /* (4) */ + {"UNPACK", tPROC, txUNPACK}, /* (3) */ + {"UNTIL", tUNTIL, txNONE}, /* (1) */ + {"USES", tUSES, txNONE}, /* (4) */ + {"VAL", tPROC, txVAL}, /* (6) */ + {"VAR", tVAR, txNONE}, /* (1) */ + {"WHILE", tWHILE, txNONE}, /* (1) */ + {"WITH", tWITH, txNONE}, /* (1) */ + {"WRITE", tPROC, txWRITE}, /* (3) */ + {"WRITELN", tPROC, txWRITELN}, /* (3) */ + {NULL, 0, txNONE} /* List terminator */ +}; + +static STYPE *symbolTable; /* Symbol Table */ + +/**************************************************************/ + +const RTYPE *findReservedWord (char *name) +{ + register const RTYPE *ptr; /* Point into reserved word list */ + register int16_t cmp; /* 0=equal; >0=past it */ + + for (ptr = rsw; (ptr->rname); ptr++) /* Try each each reserved word */ + { + cmp = strcmp(ptr->rname, name); /* Check if names match */ + if (!cmp) /* Check if names match */ + return ptr; /* Return pointer to entry if match */ + else if (cmp > 0) /* Exit early if we are past it */ + break; + } /* end for */ + + return (RTYPE*)NULL; /* return NULL pointer if no match */ + +} /* fnd findReservedWord */ + +/***************************************************************/ + +STYPE *findSymbol (char *inName) +{ + register int16_t i; /* loop index */ + + for (i=nsym-1; i>=sym_strt; i--) + if (symbolTable[i].sName) + if (!strcmp(symbolTable[i].sName, inName)) + return &symbolTable[i]; + return (STYPE*)NULL; + +} /* end findSymbol */ + +/***************************************************************/ + +static STYPE *addSymbol(char *name, int16_t type) +{ + TRACE(lstFile,"[addSymbol]"); + + /* Check for Symbol Table overflow */ + if (nsym >= MAX_SYM) { + + fatal(eOVF); + return (STYPE *)NULL; + + } /* end if */ + else { + + /* Clear all elements of the symbol table entry */ + memset(&symbolTable[nsym], 0, sizeof(STYPE)); + + /* Set the elements which are independent of sKind */ + symbolTable[nsym].sName = name; + symbolTable[nsym].sKind = type; + symbolTable[nsym].sLevel = level; + + return &symbolTable[nsym++]; + + } /* end else */ + +} /* end addSymbol */ + +/***************************************************************/ + +STYPE *addTypeDefine(char *name, uint8_t type, uint16_t size, STYPE *parent) +{ + STYPE *typePtr; + + TRACE(lstFile,"[addTypeDefine]"); + + /* Get a slot in the symbol table */ + + typePtr = addSymbol(name, sTYPE); + if (typePtr) + { + /* Add the type definition to the symbol table + * NOTES: + * 1. The minValue and maxValue fields (for scalar and subrange) + * types must be set external to this function + * 2. For most variables, allocated size/type (rsize/rtype) and + * the clone size/type are the same. If this is not the case, + * external logic will need to clarify this as well. + * 3. We assume that there are no special flags associated with + * the type. + */ + + typePtr->sParm.t.type = type; + typePtr->sParm.t.rtype = type; + typePtr->sParm.t.flags = 0; + typePtr->sParm.t.asize = size; + typePtr->sParm.t.rsize = size; + typePtr->sParm.t.parent = parent; + + } /* end if */ + + /* Return a pointer to the new constant symbol */ + + return typePtr; + +} /* end addTypeDefine */ + +/***************************************************************/ + +STYPE *addConstant(char *name, uint8_t type, int32_t *value, STYPE *parent) +{ + STYPE *constPtr; + + TRACE(lstFile,"[addConstant]"); + + /* Get a slot in the symbol table */ + constPtr = addSymbol(name, type); + if (constPtr) { + + /* Add the value of the constant to the symbol table */ + if (type == tREAL_CONST) + constPtr->sParm.c.val.f = *((double*) value); + else + constPtr->sParm.c.val.i = *value; + constPtr->sParm.c.parent = parent; + + } /* end if */ + + /* Return a pointer to the new constant symbol */ + + return constPtr; + +} /* end addConstant */ + +/***************************************************************/ + +STYPE *addStringConst(char *name, uint32_t offset, uint32_t size) +{ + STYPE *stringPtr; + + TRACE(lstFile,"[addStringConst]"); + + /* Get a slot in the symbol table */ + + stringPtr = addSymbol(name, sSTRING_CONST); + if (stringPtr) + { + /* Add the value of the constant to the symbol table */ + + stringPtr->sParm.s.offset = offset; + stringPtr->sParm.s.size = size; + } /* end if */ + + /* Return a pointer to the new string symbol */ + + return stringPtr; + +} /* end addString */ + +/***************************************************************/ + +STYPE *addFile(char *name, uint16_t fileNumber) +{ + STYPE *filePtr; + + TRACE(lstFile,"[addFile]"); + + /* Get a slot in the symbol table */ + filePtr = addSymbol(name, sFILE); + if (filePtr) { + + /* Add the fileNumber to the symbol table */ + filePtr->sParm.fileNumber = fileNumber; + + } /* end if */ + + /* Return a pointer to the new file symbol */ + + return filePtr; + +} /* end addFile */ + +/***************************************************************/ + +STYPE *addProcedure(char *name, uint8_t type, uint16_t label, + uint16_t nParms, STYPE *parent) +{ + STYPE *procPtr; + + TRACE(lstFile,"[addProcedure]"); + + /* Get a slot in the symbol table */ + procPtr = addSymbol(name, type); + if (procPtr) + { + /* Add the procedure/function definition to the symbol table */ + + procPtr->sParm.p.label = label; + procPtr->sParm.p.nParms = nParms; + procPtr->sParm.p.flags = 0; + procPtr->sParm.p.symIndex = 0; + procPtr->sParm.p.parent = parent; + } /* end if */ + + /* Return a pointer to the new procedure/function symbol */ + + return procPtr; + +} /* end addProcedure */ + +/***************************************************************/ + +STYPE *addVariable(char *name, uint8_t type, uint16_t offset, + uint16_t size, STYPE *parent) +{ + STYPE *varPtr; + + TRACE(lstFile,"[addVariable]"); + + /* Get a slot in the symbol table */ + + varPtr = addSymbol(name, type); + if (varPtr) + { + /* Add the variable to the symbol table */ + + varPtr->sParm.v.offset = offset; + varPtr->sParm.v.size = size; + varPtr->sParm.v.flags = 0; + varPtr->sParm.v.symIndex = 0; + varPtr->sParm.v.parent = parent; + } /* end if */ + + /* Return a pointer to the new variable symbol */ + + return varPtr; + +} /* end addFile */ + +/***************************************************************/ + +STYPE *addLabel(char *name, uint16_t label) +{ + STYPE *labelPtr; + + TRACE(lstFile,"[addLabel]"); + + /* Get a slot in the symbol table */ + + labelPtr = addSymbol(name, sLABEL); + if (labelPtr) + { + /* Add the label to the symbol table */ + + labelPtr->sParm.l.label = label; + labelPtr->sParm.l.unDefined = true; + } /* end if */ + + /* Return a pointer to the new label symbol */ + + return labelPtr; + +} /* end addFile */ + +/***************************************************************/ + +STYPE *addField(char *name, STYPE *record) +{ + STYPE *fieldPtr; + + TRACE(lstFile,"[addField]"); + + /* Get a slot in the symbol table */ + fieldPtr = addSymbol(name, sRECORD_OBJECT); + if (fieldPtr) { + + /* Add the field to the symbol table */ + fieldPtr->sParm.r.record = record; + + } /* end if */ + + /* Return a pointer to the new variable symbol */ + + return fieldPtr; + +} /* end addField */ + +/***************************************************************/ + +void primeSymbolTable(unsigned long symbolTableSize) +{ + int32_t trueValue = -1; + int32_t falseValue = 0; + int32_t maxintValue = MAXINT; + STYPE *typePtr; + register int16_t i; + + TRACE(lstFile,"[primeSymbolTable]"); + + /* Allocate and initialize symbol table */ + + symbolTable = malloc(symbolTableSize * sizeof(STYPE)); + if (!symbolTable) + { + fatal(eNOMEMORY); + } + + nsym = 0; + + /* Add the standard constants to the symbol table */ + + (void)addConstant("TRUE", tBOOLEAN_CONST, &trueValue, NULL); + (void)addConstant("FALSE", tBOOLEAN_CONST, &falseValue, NULL); + (void)addConstant("MAXINT", tINT_CONST, &maxintValue, NULL); + (void)addConstant("NIL", tNIL, &falseValue, NULL); + + /* Add the standard types to the symbol table */ + + typePtr = addTypeDefine("INTEGER", sINT, sINT_SIZE, NULL); + if (typePtr) + { + parentInteger = typePtr; + typePtr->sParm.t.minValue = MININT; + typePtr->sParm.t.maxValue = MAXINT; + } /* end if */ + + typePtr = addTypeDefine("BOOLEAN", sBOOLEAN, sBOOLEAN_SIZE, NULL); + if (typePtr) + { + typePtr->sParm.t.minValue = falseValue; + typePtr->sParm.t.maxValue = trueValue; + } /* end if */ + + typePtr = addTypeDefine("REAL", sREAL, sREAL_SIZE, NULL); + + typePtr = addTypeDefine("CHAR", sCHAR, sCHAR_SIZE, NULL); + if (typePtr) + { + typePtr->sParm.t.minValue = MINCHAR; + typePtr->sParm.t.maxValue = MAXCHAR; + } /* end if */ + + typePtr = addTypeDefine("TEXT", sFILE_OF, sCHAR_SIZE, NULL); + if (typePtr) + { + typePtr->sParm.t.subType = sCHAR; + typePtr->sParm.t.minValue = MINCHAR; + typePtr->sParm.t.maxValue = MAXCHAR; + } /* end if */ + + /* Add some enhanced Pascal standard" types to the symbol table + * + * string is represent by a 256 byte memory regions consisting of + * one byte for the valid string length plus 255 bytes for string + * storage + */ + + typePtr = addTypeDefine("STRING", sSTRING, sSTRING_SIZE, NULL); + if (typePtr) + { + parentString = typePtr; + typePtr->sParm.t.rtype = sRSTRING; + typePtr->sParm.t.subType = sCHAR; + typePtr->sParm.t.rsize = sRSTRING_SIZE; + typePtr->sParm.t.flags = STYPE_VARSIZE; + typePtr->sParm.t.minValue = MINCHAR; + typePtr->sParm.t.maxValue = MAXCHAR; + } /* end if */ + + /* Add the standard files to the symbol table */ + + (void)addFile("INPUT", 0); + (void)addFile("OUTPUT", 0); + + /* Initialize files table */ + + for (i = 0; i <= MAX_FILES; i++) + { + files [i].defined = 0; + files [i].flevel = 0; + files [i].ftype = 0; + files [i].faddr = 0; + files [i].fsize = 0; + } /* end for */ +} /* end primeSymbolTable */ + +/***************************************************************/ + +void verifyLabels(int32_t symIndex) +{ + register int16_t i; /* loop index */ + + for (i=symIndex; i < nsym; i++) + if ((symbolTable[i].sKind == sLABEL) + && (symbolTable[i].sParm.l.unDefined)) + error (eUNDEFLABEL); +} /* end verifyLabels */ + +/***************************************************************/ + +#if CONFIG_DEBUG +const char noName[] = "********"; +void dumpTables(void) +{ + register int16_t i; + + fprintf(lstFile,"\nSYMBOL TABLE:\n"); + fprintf(lstFile,"[ Addr ] NAME KIND LEVL\n"); + + for (i = 0; i < nsym; i++) + { + fprintf(lstFile,"[%08lx] ", (uint32_t)&symbolTable[i]); + + if (symbolTable[i].sName) + fprintf(lstFile, "%8s", symbolTable[i].sName); + else + fprintf(lstFile, "%8s", noName); + + fprintf(lstFile," %04x %04x ", + symbolTable[i].sKind, + symbolTable[i].sLevel); + + switch (symbolTable[i].sKind) + { + /* Constants */ + + case tINT_CONST : + case tCHAR_CONST : + case tBOOLEAN_CONST : + case tNIL : + case sSCALAR : + fprintf(lstFile, "val=%ld parent=[%08lx]\n", + symbolTable[i].sParm.c.val.i, + (unsigned long)symbolTable[i].sParm.c.parent); + break; + case tREAL_CONST : + fprintf(lstFile, "val=%f parent=[%08lx]\n", + symbolTable[i].sParm.c.val.f, + (unsigned long)symbolTable[i].sParm.c.parent); + break; + + /* Types */ + + case sTYPE : + fprintf(lstFile, + "type=%02x rtype=%02x subType=%02x flags=%02x " + "asize=%ld rsize=%ld minValue=%ld maxValue=%ld " + "parent=[%08lx]\n", + symbolTable[i].sParm.t.type, + symbolTable[i].sParm.t.rtype, + symbolTable[i].sParm.t.subType, + symbolTable[i].sParm.t.flags, + symbolTable[i].sParm.t.asize, + symbolTable[i].sParm.t.rsize, + symbolTable[i].sParm.t.minValue, + symbolTable[i].sParm.t.maxValue, + (unsigned long)symbolTable[i].sParm.t.parent); + break; + + /* Procedures/Functions */ + + /* Procedures and Functions */ + + case sPROC : + case sFUNC : + fprintf(lstFile, + "label=L%04x nParms=%d flags=%02x parent=[%08lx]\n", + symbolTable[i].sParm.p.label, + symbolTable[i].sParm.p.nParms, + symbolTable[i].sParm.p.flags, + (unsigned long)symbolTable[i].sParm.p.parent); + break; + + /* Labels */ + + case sLABEL : + fprintf(lstFile, "label=L%04x unDefined=%d\n", + symbolTable[i].sParm.l.label, + symbolTable[i].sParm.l.unDefined); + break; + + /* Files */ + + case sFILE : + fprintf(lstFile, "fileNumber=%d\n", + symbolTable[i].sParm.fileNumber); + break; + + /* Variables */ + + case sINT : + case sBOOLEAN : + case sCHAR : + case sREAL : + case sTEXT : + case sARRAY : + case sPOINTER : + case sVAR_PARM : + case sRECORD : + case sFILE_OF : + fprintf(lstFile, "offset=%ld size=%ld flags=%02x parent=[%08lx]\n", + symbolTable[i].sParm.v.offset, + symbolTable[i].sParm.v.size, + symbolTable[i].sParm.v.flags, + (unsigned long)symbolTable[i].sParm.v.parent); + break; + + /* Record objects */ + + case sRECORD_OBJECT : + fprintf(lstFile, + "offset=%ld size=%ld record=[%08lx] parent=[%08lx]\n", + symbolTable[i].sParm.r.offset, + symbolTable[i].sParm.r.size, + (unsigned long)symbolTable[i].sParm.r.record, + (unsigned long)symbolTable[i].sParm.r.parent); + break; + + /* Constant strings */ + + case sSTRING_CONST : + fprintf(lstFile, "offset=%04lx size=%ld\n", + symbolTable[i].sParm.s.offset, + symbolTable[i].sParm.s.size); + break; + + default : + fprintf(lstFile, "Unknown sKind\n"); + break; + + } /* end switch */ + } /* end for */ + +} /* end dumpTables */ +#endif + +/***************************************************************/ + diff --git a/misc/pascal/pascal/ptbl.h b/misc/pascal/pascal/ptbl.h index 70d3188465..14e368e1bc 100644 --- a/misc/pascal/pascal/ptbl.h +++ b/misc/pascal/pascal/ptbl.h @@ -1,78 +1,79 @@ -/***************************************************************************
- * ptbl.h
- * External Declarations associated with ptbl.c
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************************/
-
-#ifndef __PTBL_H
-#define __PTBL_H
-
-/***************************************************************************
- * Included Files
- ***************************************************************************/
-
-#include "config.h"
-
-/***************************************************************************
- * Global Variables
- ***************************************************************************/
-
-extern STYPE *parentInteger;
-extern STYPE *parentString;
-
-/***************************************************************************
- * Global Function Prototypes
- ***************************************************************************/
-
-extern const RTYPE *findReservedWord (char *name);
-extern STYPE *findSymbol (char *inName);
-extern STYPE *addTypeDefine (char *name, ubyte type, uint16 size,
- STYPE *parent);
-extern STYPE *addConstant (char *name, ubyte type, sint32 *value,
- STYPE *parent);
-extern STYPE *addStringConst (char *name, uint32 offset, uint32 size);
-extern STYPE *addFile (char *name, uint16 fileNumber);
-extern STYPE *addLabel (char *name, uint16 label);
-extern STYPE *addProcedure (char *name, ubyte type, uint16 label,
- uint16 nParms, STYPE *parent);
-extern STYPE *addVariable (char *name, ubyte type, uint16 offset,
- uint16 size, STYPE *parent);
-extern STYPE *addField (char *name, STYPE *record);
-extern void primeSymbolTable (unsigned long symbolTableSize);
-extern void verifyLabels (sint32 symIndex);
-
-#if CONFIG_DEBUG
-extern void dumpTables (void);
-#endif
-
-#endif /* __PTBL_H */
+/*************************************************************************** + * ptbl.h + * External Declarations associated with ptbl.c + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************************/ + +#ifndef __PTBL_H +#define __PTBL_H + +/*************************************************************************** + * Included Files + ***************************************************************************/ + +#include <stdint.h> +#include "config.h" + +/*************************************************************************** + * Global Variables + ***************************************************************************/ + +extern STYPE *parentInteger; +extern STYPE *parentString; + +/*************************************************************************** + * Global Function Prototypes + ***************************************************************************/ + +extern const RTYPE *findReservedWord (char *name); +extern STYPE *findSymbol (char *inName); +extern STYPE *addTypeDefine (char *name, uint8_t type, uint16_t size, + STYPE *parent); +extern STYPE *addConstant (char *name, uint8_t type, int32_t *value, + STYPE *parent); +extern STYPE *addStringConst (char *name, uint32_t offset, uint32_t size); +extern STYPE *addFile (char *name, uint16_t fileNumber); +extern STYPE *addLabel (char *name, uint16_t label); +extern STYPE *addProcedure (char *name, uint8_t type, uint16_t label, + uint16_t nParms, STYPE *parent); +extern STYPE *addVariable (char *name, uint8_t type, uint16_t offset, + uint16_t size, STYPE *parent); +extern STYPE *addField (char *name, STYPE *record); +extern void primeSymbolTable (unsigned long symbolTableSize); +extern void verifyLabels (int32_t symIndex); + +#if CONFIG_DEBUG +extern void dumpTables (void); +#endif + +#endif /* __PTBL_H */ diff --git a/misc/pascal/pascal/ptkn.c b/misc/pascal/pascal/ptkn.c index bad5bac28b..615fcc3a9e 100644 --- a/misc/pascal/pascal/ptkn.c +++ b/misc/pascal/pascal/ptkn.c @@ -1,899 +1,899 @@ -/***************************************************************
- * ptkn.c
- * Tokenization Package
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************/
-
-/***************************************************************
- * Included Functions
- ***************************************************************/
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <ctype.h>
-
-#include "keywords.h"
-#include "pasdefs.h"
-#include "ptdefs.h"
-#include "pedefs.h"
-
-#include "pas.h"
-#include "ptkn.h"
-#include "ptbl.h"
-#include "perr.h"
-
-/***************************************************************
- * Private Function Prototypes
- ***************************************************************/
-
-static void getCharacter (void);
-static void skipLine (void);
-static boolean getLine (void);
-static void identifier (void);
-static void string (void);
-static void unsignedNumber (void);
-static void unsignedRealNumber (void);
-static void unsignedExponent (void);
-static void unsignedHexadecimal (void);
-static void unsignedBinary (void);
-
-/***************************************************************
- * Private Variables
- ***************************************************************/
-
-static char *strStack; /* String Stack */
-static uint16 inChar; /* last gotten character */
-
-/***************************************************************
- * Public Variables
- ***************************************************************/
-
-char *tkn_strt; /* Start of token in string stack */
-char *stringSP; /* Top of string stack */
-
-/***************************************************************
- * Public Functions
- ***************************************************************/
-
-sint16 primeTokenizer(unsigned long stringStackSize)
-{
- TRACE(lstFile,"[primeTokenizer]");
-
- /* Allocate and initialize the string stack and stack pointers */
-
- strStack = malloc(stringStackSize);
- if (!strStack)
- {
- fatal(eNOMEMORY);
- }
-
- /* Initially, everything points to the bottom of the
- * string stack.
- */
-
- tkn_strt = strStack;
- stringSP = strStack;
-
- /* Set up for input at the initial level of file parsing */
-
- rePrimeTokenizer();
- return 0;
-}
-
-/***************************************************************/
-
-sint16 rePrimeTokenizer(void)
-{
- TRACE(lstFile,"[rePrimeTokenizer]");
-
- /* (Re-)set the char pointer to the beginning of the line */
-
- FP->cp = FP->buffer;
-
- /* Read the next line from the input stream */
-
- if (!fgets(FP->cp, LINE_SIZE, FP->stream))
- {
- /* EOF.. close file */
-
- return 1;
- }
-
- /* Initialize the line nubmer */
-
- FP->line = 1;
-
- /* Get the first character from the new file */
-
- getCharacter();
- return 0;
-}
-
-/***************************************************************/
-/* Tell 'em what what the next character will be (if they should
- * choose to get it). This is similar to getCharacter(), except that
- * the character pointer is not incremented past the character. The
- * next time that getCharacter() is called, it will get the character
- * again.
- */
-
-char getNextCharacter(boolean skipWhiteSpace)
-{
- /* Get the next character from the line buffer. */
-
- inChar = *(FP->cp);
-
- /* If it is the EOL then read the next line from the input file */
-
- if (!inChar)
- {
- /* We have used all of the characters on this line. Read the next
- * line of data
- */
-
- if (getLine())
- {
- /* Uh-oh, we are out of data! Just return some bogus value. */
- inChar = '?';
-
- } /* end if */
- else
- {
- /* Otherwise, recurse to try again. */
-
- return getNextCharacter(skipWhiteSpace);
-
- } /* end else */
- } /* end if */
-
- /* If it is a space and we have been told to skip spaces then consume
- * the input line until a non-space or the EOL is encountered.
- */
-
- else if (skipWhiteSpace)
- {
- while ((isspace(inChar)) && (inChar))
- {
- /* Skip over the space */
-
- (FP->cp)++;
-
- /* A get the character after the space */
-
- inChar = *(FP->cp);
-
- } /* end while */
-
- /* If we hit the EOL while searching for the next non-space, then
- * recurse to try again on the next line
- */
-
- if (!inChar)
- {
- return getNextCharacter(skipWhiteSpace);
- }
- } /* end else if */
-
- return inChar;
-
-} /* end getNextCharacter */
-
-/***************************************************************/
-
-void getToken(void)
-{
- /* Skip over leading spaces and comments */
-
- while (isspace(inChar)) getCharacter();
-
- /* Point to the beginning of the next token */
-
- tkn_strt = stringSP;
-
- /* Process Identifier, Symbol, or Reserved Word */
-
- if ((isalpha(inChar)) || (inChar == '_'))
- identifier();
-
- /* Process Numeric */
-
- else if (isdigit(inChar))
- unsignedNumber();
-
- /* Process string */
-
- else if (inChar == SQUOTE)
- string(); /* process string type */
-
- /* Process ':' or assignment */
-
- else if (inChar == ':')
- {
- getCharacter();
- if (inChar == '=') {token = tASSIGN; getCharacter();}
- else token = ':';
- } /* end else if */
-
- /* Process '.' or subrange or real-number */
-
- else if (inChar == '.')
- {
- /* Get the character after the '.' */
-
- getCharacter();
-
- /* ".." indicates a subrange */
-
- if (inChar == '.')
- {
- token = tSUBRANGE;
- getCharacter();
- }
-
- /* '.' digit is a real number */
-
- else if (isdigit(inChar))
- unsignedRealNumber();
-
- /* Otherwise, it is just a '.' */
-
- else token = '.';
- } /* end else if */
-
- /* Process '<' or '<=' or '<>' or '<<' */
-
- else if (inChar == '<')
- {
- getCharacter();
- if (inChar == '>') {token = tNE; getCharacter();}
- else if (inChar == '=') {token = tLE; getCharacter();}
- else if (inChar == '<') {token = tSHL; getCharacter();}
- else token = tLT;
- } /* end else if */
-
- /* Process '>' or '>=' or '><' or '>>' */
-
- else if (inChar == '>')
- {
- getCharacter();
- if (inChar == '<') {token = tNE; getCharacter();}
- else if (inChar == '=') {token = tGE; getCharacter();}
- else if (inChar == '>') {token = tSHR; getCharacter();}
- else token = tGT;
- } /* end else if */
-
- /* Get Comment -- form { .. } */
-
- else if (inChar == '{')
- {
- do getCharacter(); /* get the next character */
- while (inChar != '}'); /* loop until end of comment */
- getCharacter(); /* skip over end of comment */
- getToken(); /* get the next real token */
- } /* end else if */
-
- /* Get comment -- form (* .. *) */
-
- else if (inChar == '(')
- {
- getCharacter(); /* skip over comment character */
- if (inChar != '*') /* is this a comment? */
- {
- token = '('; /* No return '(' leaving the
- * unprocessed char in inChar */
- }
- else
- {
- uint16 lastChar = ' '; /* YES... prime the look behind */
- for (;;) /* look for end of comment */
- {
- getCharacter(); /* get the next character */
- if ((lastChar == '*') && /* Is it '*)' ? */
- (inChar == ')'))
- {
- break; /* Yes... break out */
- }
- lastChar = inChar; /* save the last character */
- } /* end for */
-
- getCharacter(); /* skip over the comment end char */
- getToken(); /* and get the next real token */
- } /* end else */
- } /* end else if */
-
- /* NONSTANDARD: All C/C++-style comments */
-
- else if (inChar == '/')
- {
- getCharacter(); /* skip over comment character */
- if (inChar == '/') /* C++ style comment? */
- {
- skipLine(); /* Yes, skip rest of line */
- getToken(); /* and get the next real token */
- }
- else if (inChar != '*') /* is this a C-style comment? */
- {
- token = '/'; /* No return '/' leaving the
- * unprocessed char in inChar */
- }
- else
- {
- uint16 lastChar = ' '; /* YES... prime the look behind */
- for (;;) /* look for end of comment */
- {
- getCharacter(); /* get the next character */
- if ((lastChar == '*') && /* Is it '*)' ? */
- (inChar == '/'))
- {
- break; /* Yes... break out */
- }
- lastChar = inChar; /* save the last character */
- } /* end for */
-
- getCharacter(); /* skip over the comment end char */
- getToken(); /* and get the next real token */
- } /* end else */
- } /* end else if */
-
- /* Check for $XXXX (hex) */
-
- else if (inChar == '%')
- unsignedHexadecimal();
-
- /* Check for $BBBB (binary) */
-
- else if (inChar == '%')
- unsignedBinary();
-
- /* if inChar is an ASCII character then return token = character */
-
- else if (isascii(inChar))
- {
- token = inChar;
- getCharacter();
- } /* end else if */
-
- /* Otherwise, discard the character and try again */
-
- else
- {
- getCharacter();
- getToken();
- } /* end else */
-
- DEBUG(lstFile,"[%02x]", token);
-
-} /* End getToken */
-
-/***************************************************************
- * Private Functions
- ***************************************************************/
-
-static void identifier(void)
-{
- const RTYPE *rptr; /* Pointer to reserved word */
-
- tknSubType = txNONE; /* Initialize */
-
- /* Concatenate identifier */
-
- do
- {
- *stringSP++ = toupper(inChar); /* concatenate char */
- getCharacter(); /* get next character */
- }
- while ((isalnum(inChar)) || (inChar == '_'));
- *stringSP++ = '\0'; /* make ASCIIZ string */
-
- /* Check if the identifier is a reserved word */
-
- rptr = findReservedWord(tkn_strt);
- if (rptr)
- {
- token = rptr->rtype; /* get type from rsw table */
- tknSubType = rptr->subtype; /* get subtype from rsw table */
- stringSP = tkn_strt; /* pop token from stack */
- } /* End if */
-
- /* Check if the identifier is a symbol */
-
- else
- {
- tknPtr = findSymbol(tkn_strt);
- if (tknPtr)
- {
- token = tknPtr->sKind; /* get type from symbol table */
- stringSP = tkn_strt; /* pop token from stack */
-
- /* The following assignments only apply to constants. However it
- * is simpler just to make the assignments than it is to determine
- * if is appropriate to do so
- */
-
- if (token == tREAL_CONST)
- tknReal = tknPtr->sParm.c.val.f;
- else
- tknInt = tknPtr->sParm.c.val.i;
- } /* End if */
-
- /* Otherwise, the token is an identifier */
- else
- token = tIDENT;
-
- } /* end else */
-
-} /* End identifier */
-
-/***************************************************************/
-/* Process string */
-
-static void string(void)
-{
- register sint16 count = 0; /* # chars in string */
-
- token = tSTRING_CONST; /* indicate string constant type */
- getCharacter(); /* skip over 1st single quote */
-
- while (inChar != SQUOTE) /* loop until next single quote */
- {
- if (inChar == '\n') /* check for EOL in string */
- {
- error(eNOSQUOTE); /* ERROR, terminate string */
- break;
- } /* end if */
- else
- {
- *stringSP++ = inChar; /* concatenate character */
- count++; /* bump count of chars */
- } /* end else */
- getCharacter(); /* get the next character */
- } /* end while */
- *stringSP++ = '\0'; /* terminate ASCIIZ string */
-
- getCharacter(); /* skip over last single quote */
- if (count == 1) /* Check for char constant */
- {
- token = tCHAR_CONST; /* indicate char constant type */
- tknInt = *tkn_strt; /* (integer) value = single char */
- stringSP = tkn_strt; /* "pop" from string stack */
- } /* end if */
-} /* end string */
-
-/***************************************************************/
-
-static void getCharacter(void)
-{
- /* Get the next character from the line buffer. If EOL, get next line */
-
- inChar = *(FP->cp)++;
- if (!inChar)
- {
- /* We have used all of the characters on this line. Read the next
- * line of data
- */
-
- skipLine();
- }
-}
-
-/***************************************************************/
-
-static void skipLine(void)
-{
- if (getLine())
- {
- /* Uh-oh, we are out of data! Just return some bogus value. */
-
- inChar = '?';
- } /* end if */
- else
- {
- /* Otherwise, get the first character from the line */
-
- getCharacter();
- }
-}
-
-/***************************************************************/
-
-static boolean getLine(void)
-{
- boolean endOfFile = FALSE;
-
- /* Reset the character pointer to the start of the new line */
-
- FP->cp = FP->buffer;
-
- /* Read the next line from the currently active file */
-
- if (!fgets(FP->cp, LINE_SIZE, FP->stream))
- {
- /* We are at an EOF for this file. Check if we are processing an
- * included file
- */
-
- if (includeIndex > 0)
- {
- /* Yes. Close the file */
-
- closeNestedFile();
-
- /* Indicate that there is no data on the input line. NOTE:
- * that FP now refers to the previous file at the next lower
- * level of nesting.
- */
-
- FP->buffer[0] = '\0';
- } /* end if */
- else
- {
- /* No. We are completely out of data. Return TRUE in this case. */
-
- endOfFile = TRUE;
- } /* end else */
- } /* end if */
- else
- {
- /* We have a new line of data. Increment the line number, then echo
- * the new line to the list file.
- */
-
- (FP->line)++;
- fprintf(lstFile, "%d:%04ld %s", FP->include, FP->line, FP->buffer);
- } /* end else */
-
- return endOfFile;
-
-} /* end getLine */
-
-/***************************************************************/
-
-static void unsignedNumber(void)
-{
- /* This logic (along with with unsignedRealNumber, and
- * unsignedRealExponent) handles:
- *
- * FORM: integer-number = decimal-integer | hexadecimal-integer |
- * binary-integer
- * FORM: decimal-integer = digit-sequence
- * FORM: real-number =
- * digit-sequence '.' [digit-sequence] [ exponent scale-factor ] |
- * '.' digit-sequence [ exponent scale-factor ] |
- * digit-sequence exponent scale-factor
- * FORM: exponent = 'e' | 'E'
- *
- * When called, inChar is equal to the leading digit of a
- * digit-sequence. NOTE that the real-number form beginning with
- * '.' does not use this logic.
- */
-
- /* Assume an integer type (might be real) */
-
- token = tINT_CONST;
-
- /* Concatenate all digits until an non-digit is found */
-
- do
- {
- *stringSP++ = inChar;
- getCharacter();
- }
- while (isdigit(inChar));
-
- /* If it is a digit-sequence followed by 'e' (or 'E'), then
- * continue processing this token as a real number.
- */
-
- if ((inChar == 'e') || (inChar == 'E'))
- {
- unsignedExponent();
- }
-
- /* If the digit-sequence is followed by '.' but not by ".." (i.e.,
- * this is not a subrange), then switch we are parsing a real time.
- * Otherwise, convert the integer string to binary.
- */
-
- else if ((inChar != '.') || (getNextCharacter(FALSE) == '.'))
- {
- /* Terminate the integer string and convert it using sscanf */
-
- *stringSP++ = '\0';
- (void)sscanf(tkn_strt, "%ld", &tknInt);
-
- /* Remove the integer string from the character identifer stack */
-
- stringSP = tkn_strt;
- } /* end if */
- else
- {
- /* Its a real value! Now really get the next character and
- * after the decimal point (this will work whether or not
- * getNextCharacter() was called). Then process the real number.
- */
-
- getCharacter();
- unsignedRealNumber();
- } /* end if */
-}
-
-/***************************************************************/
-
-static void unsignedRealNumber(void)
-{
- /* This logic (along with with unsignedNumber and unsignedExponent)
- * handles:
- *
- * FORM: real-number =
- * digit-sequence '.' [digit-sequence] [ exponent scale-factor ] |
- * '.' digit-sequence [ exponent scale-factor ] |
- * digit-sequence exponent scale-factor
- * FORM: exponent = 'e' | 'E'
- *
- * When called:
- * - inChar is the character AFTER the '.'.
- * - Any leading digit-sequence is already in the character stack
- * - the '.' is not in the character stack.
- */
-
- /* Its a real constant */
-
- token = tREAL_CONST;
-
- /* Save the decimal point (inChar points to the character after
- * the decimal point).
- */
-
- *stringSP++ = '.';
-
- /* Now, loop to process the optional digit-sequence after the
- * decimal point.
- */
-
- while (isdigit(inChar))
- {
- *stringSP++ = inChar;
- getCharacter();
- }
-
- /* If it is a digit-sequence followed by 'e' (or 'E'), then
- * continue processing this token as a real number.
- */
-
- if ((inChar == 'e') || (inChar == 'E'))
- {
- unsignedExponent();
- }
- else
- {
- /* There is no exponent...
- * Terminate the real number string and convert it to binay
- * using sscanf.
- */
-
- *stringSP++ = '\0';
- (void) sscanf(tkn_strt, "%lf", &tknReal);
- } /* end if */
-
- /* Remove the number string from the character identifer stack */
-
- stringSP = tkn_strt;
-}
-
-/***************************************************************/
-
-static void unsignedExponent(void)
-{
- /* This logic (along with with unsignedNumber and unsignedRealNumber)
- * handles:
- *
- * FORM: real-number =
- * digit-sequence '.' [digit-sequence] [ exponent scale-factor ] |
- * '.' digit-sequence [ exponent scale-factor ] |
- * digit-sequence exponent scale-factor
- * FORM: exponent = 'e'
- * FORM: scale-factor = [ sign ] digit-sequence
- *
- * When called:
- * - inChar holds the 'E' (or 'e') exponent
- * - Any leading digit-sequences or decimal points are already in the
- * character stack
- * - the 'E' (or 'e') is not in the character stack.
- */
-
- /* Its a real constant */
-
- token = tREAL_CONST;
-
- /* Save the decimal point (inChar points to the character after
- * the decimal point).
- */
-
- *stringSP++ = inChar;
- getCharacter();
-
- /* Check for an optional sign before the exponent value */
-
- if ((inChar == '-') || (inChar == '+'))
- {
- /* Add the sign to the stack */
-
- *stringSP++ = inChar;
- getCharacter();
- }
- else
- {
- /* Add a '+' sign to the stack */
-
- *stringSP++ = '+';
- }
-
- /* A digit sequence must appear after the exponent and optional
- * sign.
- */
-
- if (!isdigit(inChar))
- {
- error(eEXPONENT);
- tknReal = 0.0;
- }
- else
- {
- /* Now, loop to process the required digit-sequence */
-
- do
- {
- *stringSP++ = inChar;
- getCharacter();
- }
- while (isdigit(inChar));
-
- /* Terminate the real number string and convert it to binay
- * using sscanf.
- */
-
- *stringSP++ = '\0';
- (void) sscanf(tkn_strt, "%lf", &tknReal);
- }
-
- /* Remove the number string from the character identifer stack */
-
- stringSP = tkn_strt;
-}
-
-/***************************************************************/
-
-static void unsignedHexadecimal(void)
-{
- /* FORM: integer-number = decimal-integer | hexadecimal-integer |
- * binary-integer
- * FORM: hexadecimal-integer = '$' hex-digit-sequence
- * FORM: hex-digit-sequence = hex-digit { hex-digit }
- * FORM: hex-digit = digit | 'a' | 'b' | 'c' | 'd' | 'e' | 'f'
- *
- * On entry, inChar is '$'
- */
-
- /* This is another representation for an integer */
-
- token = tINT_CONST;
-
- /* Loop to process each hex 'digit' */
-
- for (;;)
- {
- /* Get the next character */
-
- getCharacter();
-
- /* Is it a decimal digit? */
-
- if (isdigit(inChar))
- *stringSP++ = inChar;
-
- /* Is it a hex 'digit'? */
-
- else if ((inChar >= 'A') && (inChar <= 'F'))
- *stringSP++ = inChar;
-
- else if ((inChar >= 'a') && (inChar <= 'f'))
- *stringSP++ = _toupper(inChar);
-
- /* Otherwise, that must be the end of the hex value */
-
- else break;
- }
-
- /* Terminate the hex string and convert to binary using sscanf */
-
- *stringSP++ = '\0';
- (void)sscanf(tkn_strt, "%lx", &tknInt);
-
- /* Remove the hex string from the character identifer stack */
-
- stringSP = tkn_strt;
-}
-
-/***************************************************************/
-
-static void unsignedBinary(void)
-{
- uint32 value;
-
- /* FORM: integer-number = decimal-integer | hexadecimal-integer |
- * binary-integer
- * FORM: binary-integer = '%' binary-digit-sequence
- * FORM: binary-digit-sequence = binary-digit { binary-digit }
- * FORM: binary-digit = '0' | '1'
- *
- * On entry, inChar is '%'
- */
-
- /* This is another representation for an integer */
-
- token = tINT_CONST;
-
- /* Loop to process each hex 'digit' */
-
- value = 0;
-
- for (;;)
- {
- /* Get the next character */
-
- getCharacter();
-
- /* Is it a binary 'digit'? */
-
- if (inChar == '0')
- value <<= 1;
-
- else if (inChar == '1')
- {
- value <<= 1;
- value |= 1;
- }
-
- /* Otherwise, that must be the end of the binary value */
-
- else break;
- }
-
- /* I don't there there is an sscanf conversion for binary, that's
- * why we did it above.
- */
-
- tknInt = (sint32)value;
-}
-
-/***************************************************************/
+/*************************************************************** + * ptkn.c + * Tokenization Package + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************/ + +/*************************************************************** + * Included Functions + ***************************************************************/ + +#include <stdio.h> +#include <stdlib.h> +#include <ctype.h> + +#include "keywords.h" +#include "pasdefs.h" +#include "ptdefs.h" +#include "pedefs.h" + +#include "pas.h" +#include "ptkn.h" +#include "ptbl.h" +#include "perr.h" + +/*************************************************************** + * Private Function Prototypes + ***************************************************************/ + +static void getCharacter (void); +static void skipLine (void); +static bool getLine (void); +static void identifier (void); +static void string (void); +static void unsignedNumber (void); +static void unsignedRealNumber (void); +static void unsignedExponent (void); +static void unsignedHexadecimal (void); +static void unsignedBinary (void); + +/*************************************************************** + * Private Variables + ***************************************************************/ + +static char *strStack; /* String Stack */ +static uint16_t inChar; /* last gotten character */ + +/*************************************************************** + * Public Variables + ***************************************************************/ + +char *tkn_strt; /* Start of token in string stack */ +char *stringSP; /* Top of string stack */ + +/*************************************************************** + * Public Functions + ***************************************************************/ + +int16_t primeTokenizer(unsigned long stringStackSize) +{ + TRACE(lstFile,"[primeTokenizer]"); + + /* Allocate and initialize the string stack and stack pointers */ + + strStack = malloc(stringStackSize); + if (!strStack) + { + fatal(eNOMEMORY); + } + + /* Initially, everything points to the bottom of the + * string stack. + */ + + tkn_strt = strStack; + stringSP = strStack; + + /* Set up for input at the initial level of file parsing */ + + rePrimeTokenizer(); + return 0; +} + +/***************************************************************/ + +int16_t rePrimeTokenizer(void) +{ + TRACE(lstFile,"[rePrimeTokenizer]"); + + /* (Re-)set the char pointer to the beginning of the line */ + + FP->cp = FP->buffer; + + /* Read the next line from the input stream */ + + if (!fgets(FP->cp, LINE_SIZE, FP->stream)) + { + /* EOF.. close file */ + + return 1; + } + + /* Initialize the line nubmer */ + + FP->line = 1; + + /* Get the first character from the new file */ + + getCharacter(); + return 0; +} + +/***************************************************************/ +/* Tell 'em what what the next character will be (if they should + * choose to get it). This is similar to getCharacter(), except that + * the character pointer is not incremented past the character. The + * next time that getCharacter() is called, it will get the character + * again. + */ + +char getNextCharacter(bool skipWhiteSpace) +{ + /* Get the next character from the line buffer. */ + + inChar = *(FP->cp); + + /* If it is the EOL then read the next line from the input file */ + + if (!inChar) + { + /* We have used all of the characters on this line. Read the next + * line of data + */ + + if (getLine()) + { + /* Uh-oh, we are out of data! Just return some bogus value. */ + inChar = '?'; + + } /* end if */ + else + { + /* Otherwise, recurse to try again. */ + + return getNextCharacter(skipWhiteSpace); + + } /* end else */ + } /* end if */ + + /* If it is a space and we have been told to skip spaces then consume + * the input line until a non-space or the EOL is encountered. + */ + + else if (skipWhiteSpace) + { + while ((isspace(inChar)) && (inChar)) + { + /* Skip over the space */ + + (FP->cp)++; + + /* A get the character after the space */ + + inChar = *(FP->cp); + + } /* end while */ + + /* If we hit the EOL while searching for the next non-space, then + * recurse to try again on the next line + */ + + if (!inChar) + { + return getNextCharacter(skipWhiteSpace); + } + } /* end else if */ + + return inChar; + +} /* end getNextCharacter */ + +/***************************************************************/ + +void getToken(void) +{ + /* Skip over leading spaces and comments */ + + while (isspace(inChar)) getCharacter(); + + /* Point to the beginning of the next token */ + + tkn_strt = stringSP; + + /* Process Identifier, Symbol, or Reserved Word */ + + if ((isalpha(inChar)) || (inChar == '_')) + identifier(); + + /* Process Numeric */ + + else if (isdigit(inChar)) + unsignedNumber(); + + /* Process string */ + + else if (inChar == SQUOTE) + string(); /* process string type */ + + /* Process ':' or assignment */ + + else if (inChar == ':') + { + getCharacter(); + if (inChar == '=') {token = tASSIGN; getCharacter();} + else token = ':'; + } /* end else if */ + + /* Process '.' or subrange or real-number */ + + else if (inChar == '.') + { + /* Get the character after the '.' */ + + getCharacter(); + + /* ".." indicates a subrange */ + + if (inChar == '.') + { + token = tSUBRANGE; + getCharacter(); + } + + /* '.' digit is a real number */ + + else if (isdigit(inChar)) + unsignedRealNumber(); + + /* Otherwise, it is just a '.' */ + + else token = '.'; + } /* end else if */ + + /* Process '<' or '<=' or '<>' or '<<' */ + + else if (inChar == '<') + { + getCharacter(); + if (inChar == '>') {token = tNE; getCharacter();} + else if (inChar == '=') {token = tLE; getCharacter();} + else if (inChar == '<') {token = tSHL; getCharacter();} + else token = tLT; + } /* end else if */ + + /* Process '>' or '>=' or '><' or '>>' */ + + else if (inChar == '>') + { + getCharacter(); + if (inChar == '<') {token = tNE; getCharacter();} + else if (inChar == '=') {token = tGE; getCharacter();} + else if (inChar == '>') {token = tSHR; getCharacter();} + else token = tGT; + } /* end else if */ + + /* Get Comment -- form { .. } */ + + else if (inChar == '{') + { + do getCharacter(); /* get the next character */ + while (inChar != '}'); /* loop until end of comment */ + getCharacter(); /* skip over end of comment */ + getToken(); /* get the next real token */ + } /* end else if */ + + /* Get comment -- form (* .. *) */ + + else if (inChar == '(') + { + getCharacter(); /* skip over comment character */ + if (inChar != '*') /* is this a comment? */ + { + token = '('; /* No return '(' leaving the + * unprocessed char in inChar */ + } + else + { + uint16_t lastChar = ' '; /* YES... prime the look behind */ + for (;;) /* look for end of comment */ + { + getCharacter(); /* get the next character */ + if ((lastChar == '*') && /* Is it '*)' ? */ + (inChar == ')')) + { + break; /* Yes... break out */ + } + lastChar = inChar; /* save the last character */ + } /* end for */ + + getCharacter(); /* skip over the comment end char */ + getToken(); /* and get the next real token */ + } /* end else */ + } /* end else if */ + + /* NONSTANDARD: All C/C++-style comments */ + + else if (inChar == '/') + { + getCharacter(); /* skip over comment character */ + if (inChar == '/') /* C++ style comment? */ + { + skipLine(); /* Yes, skip rest of line */ + getToken(); /* and get the next real token */ + } + else if (inChar != '*') /* is this a C-style comment? */ + { + token = '/'; /* No return '/' leaving the + * unprocessed char in inChar */ + } + else + { + uint16_t lastChar = ' '; /* YES... prime the look behind */ + for (;;) /* look for end of comment */ + { + getCharacter(); /* get the next character */ + if ((lastChar == '*') && /* Is it '*)' ? */ + (inChar == '/')) + { + break; /* Yes... break out */ + } + lastChar = inChar; /* save the last character */ + } /* end for */ + + getCharacter(); /* skip over the comment end char */ + getToken(); /* and get the next real token */ + } /* end else */ + } /* end else if */ + + /* Check for $XXXX (hex) */ + + else if (inChar == '%') + unsignedHexadecimal(); + + /* Check for $BBBB (binary) */ + + else if (inChar == '%') + unsignedBinary(); + + /* if inChar is an ASCII character then return token = character */ + + else if (isascii(inChar)) + { + token = inChar; + getCharacter(); + } /* end else if */ + + /* Otherwise, discard the character and try again */ + + else + { + getCharacter(); + getToken(); + } /* end else */ + + DEBUG(lstFile,"[%02x]", token); + +} /* End getToken */ + +/*************************************************************** + * Private Functions + ***************************************************************/ + +static void identifier(void) +{ + const RTYPE *rptr; /* Pointer to reserved word */ + + tknSubType = txNONE; /* Initialize */ + + /* Concatenate identifier */ + + do + { + *stringSP++ = toupper(inChar); /* concatenate char */ + getCharacter(); /* get next character */ + } + while ((isalnum(inChar)) || (inChar == '_')); + *stringSP++ = '\0'; /* make ASCIIZ string */ + + /* Check if the identifier is a reserved word */ + + rptr = findReservedWord(tkn_strt); + if (rptr) + { + token = rptr->rtype; /* get type from rsw table */ + tknSubType = rptr->subtype; /* get subtype from rsw table */ + stringSP = tkn_strt; /* pop token from stack */ + } /* End if */ + + /* Check if the identifier is a symbol */ + + else + { + tknPtr = findSymbol(tkn_strt); + if (tknPtr) + { + token = tknPtr->sKind; /* get type from symbol table */ + stringSP = tkn_strt; /* pop token from stack */ + + /* The following assignments only apply to constants. However it + * is simpler just to make the assignments than it is to determine + * if is appropriate to do so + */ + + if (token == tREAL_CONST) + tknReal = tknPtr->sParm.c.val.f; + else + tknInt = tknPtr->sParm.c.val.i; + } /* End if */ + + /* Otherwise, the token is an identifier */ + else + token = tIDENT; + + } /* end else */ + +} /* End identifier */ + +/***************************************************************/ +/* Process string */ + +static void string(void) +{ + register int16_t count = 0; /* # chars in string */ + + token = tSTRING_CONST; /* indicate string constant type */ + getCharacter(); /* skip over 1st single quote */ + + while (inChar != SQUOTE) /* loop until next single quote */ + { + if (inChar == '\n') /* check for EOL in string */ + { + error(eNOSQUOTE); /* ERROR, terminate string */ + break; + } /* end if */ + else + { + *stringSP++ = inChar; /* concatenate character */ + count++; /* bump count of chars */ + } /* end else */ + getCharacter(); /* get the next character */ + } /* end while */ + *stringSP++ = '\0'; /* terminate ASCIIZ string */ + + getCharacter(); /* skip over last single quote */ + if (count == 1) /* Check for char constant */ + { + token = tCHAR_CONST; /* indicate char constant type */ + tknInt = *tkn_strt; /* (integer) value = single char */ + stringSP = tkn_strt; /* "pop" from string stack */ + } /* end if */ +} /* end string */ + +/***************************************************************/ + +static void getCharacter(void) +{ + /* Get the next character from the line buffer. If EOL, get next line */ + + inChar = *(FP->cp)++; + if (!inChar) + { + /* We have used all of the characters on this line. Read the next + * line of data + */ + + skipLine(); + } +} + +/***************************************************************/ + +static void skipLine(void) +{ + if (getLine()) + { + /* Uh-oh, we are out of data! Just return some bogus value. */ + + inChar = '?'; + } /* end if */ + else + { + /* Otherwise, get the first character from the line */ + + getCharacter(); + } +} + +/***************************************************************/ + +static bool getLine(void) +{ + bool endOfFile = false; + + /* Reset the character pointer to the start of the new line */ + + FP->cp = FP->buffer; + + /* Read the next line from the currently active file */ + + if (!fgets(FP->cp, LINE_SIZE, FP->stream)) + { + /* We are at an EOF for this file. Check if we are processing an + * included file + */ + + if (includeIndex > 0) + { + /* Yes. Close the file */ + + closeNestedFile(); + + /* Indicate that there is no data on the input line. NOTE: + * that FP now refers to the previous file at the next lower + * level of nesting. + */ + + FP->buffer[0] = '\0'; + } /* end if */ + else + { + /* No. We are completely out of data. Return true in this case. */ + + endOfFile = true; + } /* end else */ + } /* end if */ + else + { + /* We have a new line of data. Increment the line number, then echo + * the new line to the list file. + */ + + (FP->line)++; + fprintf(lstFile, "%d:%04ld %s", FP->include, FP->line, FP->buffer); + } /* end else */ + + return endOfFile; + +} /* end getLine */ + +/***************************************************************/ + +static void unsignedNumber(void) +{ + /* This logic (along with with unsignedRealNumber, and + * unsignedRealExponent) handles: + * + * FORM: integer-number = decimal-integer | hexadecimal-integer | + * binary-integer + * FORM: decimal-integer = digit-sequence + * FORM: real-number = + * digit-sequence '.' [digit-sequence] [ exponent scale-factor ] | + * '.' digit-sequence [ exponent scale-factor ] | + * digit-sequence exponent scale-factor + * FORM: exponent = 'e' | 'E' + * + * When called, inChar is equal to the leading digit of a + * digit-sequence. NOTE that the real-number form beginning with + * '.' does not use this logic. + */ + + /* Assume an integer type (might be real) */ + + token = tINT_CONST; + + /* Concatenate all digits until an non-digit is found */ + + do + { + *stringSP++ = inChar; + getCharacter(); + } + while (isdigit(inChar)); + + /* If it is a digit-sequence followed by 'e' (or 'E'), then + * continue processing this token as a real number. + */ + + if ((inChar == 'e') || (inChar == 'E')) + { + unsignedExponent(); + } + + /* If the digit-sequence is followed by '.' but not by ".." (i.e., + * this is not a subrange), then switch we are parsing a real time. + * Otherwise, convert the integer string to binary. + */ + + else if ((inChar != '.') || (getNextCharacter(false) == '.')) + { + /* Terminate the integer string and convert it using sscanf */ + + *stringSP++ = '\0'; + (void)sscanf(tkn_strt, "%ld", &tknInt); + + /* Remove the integer string from the character identifer stack */ + + stringSP = tkn_strt; + } /* end if */ + else + { + /* Its a real value! Now really get the next character and + * after the decimal point (this will work whether or not + * getNextCharacter() was called). Then process the real number. + */ + + getCharacter(); + unsignedRealNumber(); + } /* end if */ +} + +/***************************************************************/ + +static void unsignedRealNumber(void) +{ + /* This logic (along with with unsignedNumber and unsignedExponent) + * handles: + * + * FORM: real-number = + * digit-sequence '.' [digit-sequence] [ exponent scale-factor ] | + * '.' digit-sequence [ exponent scale-factor ] | + * digit-sequence exponent scale-factor + * FORM: exponent = 'e' | 'E' + * + * When called: + * - inChar is the character AFTER the '.'. + * - Any leading digit-sequence is already in the character stack + * - the '.' is not in the character stack. + */ + + /* Its a real constant */ + + token = tREAL_CONST; + + /* Save the decimal point (inChar points to the character after + * the decimal point). + */ + + *stringSP++ = '.'; + + /* Now, loop to process the optional digit-sequence after the + * decimal point. + */ + + while (isdigit(inChar)) + { + *stringSP++ = inChar; + getCharacter(); + } + + /* If it is a digit-sequence followed by 'e' (or 'E'), then + * continue processing this token as a real number. + */ + + if ((inChar == 'e') || (inChar == 'E')) + { + unsignedExponent(); + } + else + { + /* There is no exponent... + * Terminate the real number string and convert it to binay + * using sscanf. + */ + + *stringSP++ = '\0'; + (void) sscanf(tkn_strt, "%lf", &tknReal); + } /* end if */ + + /* Remove the number string from the character identifer stack */ + + stringSP = tkn_strt; +} + +/***************************************************************/ + +static void unsignedExponent(void) +{ + /* This logic (along with with unsignedNumber and unsignedRealNumber) + * handles: + * + * FORM: real-number = + * digit-sequence '.' [digit-sequence] [ exponent scale-factor ] | + * '.' digit-sequence [ exponent scale-factor ] | + * digit-sequence exponent scale-factor + * FORM: exponent = 'e' + * FORM: scale-factor = [ sign ] digit-sequence + * + * When called: + * - inChar holds the 'E' (or 'e') exponent + * - Any leading digit-sequences or decimal points are already in the + * character stack + * - the 'E' (or 'e') is not in the character stack. + */ + + /* Its a real constant */ + + token = tREAL_CONST; + + /* Save the decimal point (inChar points to the character after + * the decimal point). + */ + + *stringSP++ = inChar; + getCharacter(); + + /* Check for an optional sign before the exponent value */ + + if ((inChar == '-') || (inChar == '+')) + { + /* Add the sign to the stack */ + + *stringSP++ = inChar; + getCharacter(); + } + else + { + /* Add a '+' sign to the stack */ + + *stringSP++ = '+'; + } + + /* A digit sequence must appear after the exponent and optional + * sign. + */ + + if (!isdigit(inChar)) + { + error(eEXPONENT); + tknReal = 0.0; + } + else + { + /* Now, loop to process the required digit-sequence */ + + do + { + *stringSP++ = inChar; + getCharacter(); + } + while (isdigit(inChar)); + + /* Terminate the real number string and convert it to binay + * using sscanf. + */ + + *stringSP++ = '\0'; + (void) sscanf(tkn_strt, "%lf", &tknReal); + } + + /* Remove the number string from the character identifer stack */ + + stringSP = tkn_strt; +} + +/***************************************************************/ + +static void unsignedHexadecimal(void) +{ + /* FORM: integer-number = decimal-integer | hexadecimal-integer | + * binary-integer + * FORM: hexadecimal-integer = '$' hex-digit-sequence + * FORM: hex-digit-sequence = hex-digit { hex-digit } + * FORM: hex-digit = digit | 'a' | 'b' | 'c' | 'd' | 'e' | 'f' + * + * On entry, inChar is '$' + */ + + /* This is another representation for an integer */ + + token = tINT_CONST; + + /* Loop to process each hex 'digit' */ + + for (;;) + { + /* Get the next character */ + + getCharacter(); + + /* Is it a decimal digit? */ + + if (isdigit(inChar)) + *stringSP++ = inChar; + + /* Is it a hex 'digit'? */ + + else if ((inChar >= 'A') && (inChar <= 'F')) + *stringSP++ = inChar; + + else if ((inChar >= 'a') && (inChar <= 'f')) + *stringSP++ = _toupper(inChar); + + /* Otherwise, that must be the end of the hex value */ + + else break; + } + + /* Terminate the hex string and convert to binary using sscanf */ + + *stringSP++ = '\0'; + (void)sscanf(tkn_strt, "%lx", &tknInt); + + /* Remove the hex string from the character identifer stack */ + + stringSP = tkn_strt; +} + +/***************************************************************/ + +static void unsignedBinary(void) +{ + uint32_t value; + + /* FORM: integer-number = decimal-integer | hexadecimal-integer | + * binary-integer + * FORM: binary-integer = '%' binary-digit-sequence + * FORM: binary-digit-sequence = binary-digit { binary-digit } + * FORM: binary-digit = '0' | '1' + * + * On entry, inChar is '%' + */ + + /* This is another representation for an integer */ + + token = tINT_CONST; + + /* Loop to process each hex 'digit' */ + + value = 0; + + for (;;) + { + /* Get the next character */ + + getCharacter(); + + /* Is it a binary 'digit'? */ + + if (inChar == '0') + value <<= 1; + + else if (inChar == '1') + { + value <<= 1; + value |= 1; + } + + /* Otherwise, that must be the end of the binary value */ + + else break; + } + + /* I don't there there is an sscanf conversion for binary, that's + * why we did it above. + */ + + tknInt = (int32_t)value; +} + +/***************************************************************/ diff --git a/misc/pascal/pascal/ptkn.h b/misc/pascal/pascal/ptkn.h index d30333e0c9..da64250471 100644 --- a/misc/pascal/pascal/ptkn.h +++ b/misc/pascal/pascal/ptkn.h @@ -1,58 +1,65 @@ -/***************************************************************************
- * ptkn.h
- * External Declarations associated with ptkn.c
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************************/
-
-#ifndef __PTKN_H
-#define __PTKN_H
-
-/***************************************************************************
- * Public Variables
- ***************************************************************************/
-
-/* String stack access variables */
-
-extern char *tkn_strt; /* Start of token in string stack */
-extern char *stringSP; /* Top of string stack */
-
-/***************************************************************************
- * Public Function Prototypes
- ***************************************************************************/
-
-extern void getToken (void);
-extern char getNextCharacter (boolean skipWhiteSpace);
-extern sint16 primeTokenizer (unsigned long stringStackSize);
-extern sint16 rePrimeTokenizer (void);
-
-#endif /* __PTKN_H */
+/*************************************************************************** + * ptkn.h + * External Declarations associated with ptkn.c + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************************/ + +#ifndef __PTKN_H +#define __PTKN_H + +/*************************************************************************** + * Included Files + ***************************************************************************/ + +#include <stdint.h> +#include <stdbool.h> + +/*************************************************************************** + * Public Variables + ***************************************************************************/ + +/* String stack access variables */ + +extern char *tkn_strt; /* Start of token in string stack */ +extern char *stringSP; /* Top of string stack */ + +/*************************************************************************** + * Public Function Prototypes + ***************************************************************************/ + +extern void getToken (void); +extern char getNextCharacter (boolean skipWhiteSpace); +extern int16_t primeTokenizer (unsigned long stringStackSize); +extern int16_t rePrimeTokenizer (void); + +#endif /* __PTKN_H */ diff --git a/misc/pascal/pascal/punit.c b/misc/pascal/pascal/punit.c index b24ba45c64..00a21d9ea2 100644 --- a/misc/pascal/pascal/punit.c +++ b/misc/pascal/pascal/punit.c @@ -2,7 +2,7 @@ * punit.c * Parse a pascal unit file * - * Copyright (C) 2008 Gregory Nutt. All rights reserved. + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. * Author: Gregory Nutt <spudmonkey@racsa.co.cr> * * Redistribution and use in source and binary forms, with or without @@ -38,6 +38,7 @@ * Included Files **********************************************************************/ +#include <stdint.h> #include <stdio.h> #include <stdlib.h> #include <ctype.h> @@ -62,7 +63,7 @@ #include "punit.h" /*********************************************************************** - * Definitions + * Pre-processor Definitions ***********************************************************************/ #define intAlign(x) (((x) + (sINT_SIZE-1)) & (~(sINT_SIZE-1))) @@ -196,7 +197,7 @@ void unitImplementation(void) void unitInterface(void) { - sint32 savedDStack = dstack; + int32_t savedDStack = dstack; TRACE(lstFile, "[unitInterface]"); /* FORM: unit = @@ -258,8 +259,8 @@ void unitInterface(void) static void interfaceSection(void) { - sint16 saveNSym = nsym; /* Save top of symbol table */ - sint16 saveNConst = nconst; /* Save top of constant table */ + int16_t saveNSym = nsym; /* Save top of symbol table */ + int16_t saveNConst = nconst; /* Save top of constant table */ TRACE(lstFile, "[interfaceSection]"); @@ -304,8 +305,8 @@ static void interfaceSection(void) const_strt = 0; /* Process constant-definition. - * FORM: constant-definition = identifier '=' constant - */ + * FORM: constant-definition = identifier '=' constant + */ constantDefinitionGroup(); @@ -325,8 +326,8 @@ static void interfaceSection(void) sym_strt = 0; /* Process the type-definitions in the type-definition-group - * FORM: type-definition = identifier '=' type-denoter - */ + * FORM: type-definition = identifier '=' type-denoter + */ typeDefinitionGroup(); } /* end if */ @@ -345,9 +346,9 @@ static void interfaceSection(void) sym_strt = 0; /* Process the variable declarations - * FORM: variable-declaration = identifier-list ':' type-denoter - * FORM: identifier-list = identifier { ',' identifier } - */ + * FORM: variable-declaration = identifier-list ':' type-denoter + * FORM: identifier-list = identifier { ',' identifier } + */ variableDeclarationGroup(); } /* end if */ @@ -362,39 +363,39 @@ static void interfaceSection(void) for (;;) { /* FORM: function-heading = - * 'function' function-identifier [ formal-parameter-list ] - * ':' result-type - */ + * 'function' function-identifier [ formal-parameter-list ] + * ':' result-type + */ if (token == tFUNCTION) - { - const_strt = saveNConst; /* Limit search to present level */ - sym_strt = saveNSym; - getToken(); /* Get identifier */ - const_strt = 0; - sym_strt = 0; + { + const_strt = saveNConst; /* Limit search to present level */ + sym_strt = saveNSym; + getToken(); /* Get identifier */ + const_strt = 0; + sym_strt = 0; - /* Process the interface declaration */ + /* Process the interface declaration */ - exportedFunctionHeading(); - } /* end if */ + exportedFunctionHeading(); + } /* end if */ /* FORM: procedure-heading = - * 'procedure' procedure-identifier [ formal-parameter-list ] - */ + * 'procedure' procedure-identifier [ formal-parameter-list ] + */ else if (token == tPROCEDURE) - { - const_strt = saveNConst; /* Limit search to present level */ - sym_strt = saveNSym; - getToken(); /* Get identifier */ - const_strt = 0; - sym_strt = 0; + { + const_strt = saveNConst; /* Limit search to present level */ + sym_strt = saveNSym; + getToken(); /* Get identifier */ + const_strt = 0; + sym_strt = 0; - /* Process the interface declaration */ + /* Process the interface declaration */ - exportedProcedureHeading(); - } /* end else if */ + exportedProcedureHeading(); + } /* end else if */ else break; } /* end for */ @@ -407,7 +408,7 @@ static void interfaceSection(void) static void exportedProcedureHeading(void) { - uint16 procLabel = ++label; + uint16_t procLabel = ++label; char *saveChSp; STYPE *procPtr; register int i; @@ -487,8 +488,8 @@ static void exportedProcedureHeading(void) static void exportedFunctionHeading(void) { - uint16 funcLabel = ++label; - sint16 parameterOffset; + uint16_t funcLabel = ++label; + int16_t parameterOffset; char *saveChSp; STYPE *funcPtr; register int i; @@ -547,9 +548,9 @@ static void exportedFunctionHeading(void) if (token == sTYPE) { /* The offset to the return value is the offset to the last - * parameter minus the size of the return value (aligned to - * multiples of size of INTEGER). - */ + * parameter minus the size of the return value (aligned to + * multiples of size of INTEGER). + */ parameterOffset -= tknPtr->sParm.t.rsize; parameterOffset = intAlign(parameterOffset); diff --git a/misc/pascal/plink/plink.c b/misc/pascal/plink/plink.c index 22b5af45d0..d304c49ad9 100644 --- a/misc/pascal/plink/plink.c +++ b/misc/pascal/plink/plink.c @@ -1,549 +1,551 @@ -/**********************************************************************
- * plink.c
- * P-Code Linker
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- **********************************************************************/
-
-/**********************************************************************
- * Included Files
- **********************************************************************/
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <errno.h>
-
-#include "keywords.h"
-#include "pdefs.h"
-#include "podefs.h"
-#include "pedefs.h"
-
-#include "paslib.h"
-#include "perr.h"
-#include "plsym.h"
-#include "plreloc.h"
-#include "pinsn.h"
-#include "plink.h"
-
-/**********************************************************************
- * Definitions
- **********************************************************************/
-
-#define MAX_POFF_FILES 8
-
-/**********************************************************************
- * Private Type Definitions
- **********************************************************************/
-
-/**********************************************************************
- * Private Constant Data
- **********************************************************************/
-
-/**********************************************************************
- * Private Data
- **********************************************************************/
-
-static const char *outFileName;
-static const char *inFileName[MAX_POFF_FILES];
-static int nPoffFiles = 0;
-
-/**********************************************************************
- * Private Function Prototypes
- **********************************************************************/
-
-static void showUsage (const char *progname);
-static void parseArgs (int argc, char **argv);
-static void loadInputFiles (poffHandle_t outHandle);
-static void checkFileHeader (poffHandle_t inHandle, poffHandle_t outHandle,
- uint32 pcOffset,boolean *progFound);
-static uint32 mergeRoData (poffHandle_t inHandle, poffHandle_t outHandle);
-static uint32 mergeProgramData (poffHandle_t inHandle, poffHandle_t outHandle,
- uint32 pcOffset, uint32 roOffset);
-static uint32 mergeFileNames (poffHandle_t inHandle, poffHandle_t outHandle);
-static uint32 mergeLineNumbers (poffHandle_t inHandle, poffHandle_t outHandle,
- uint32 pcOffset, uint32 fnOffset);
-static void writeOutputFile (poffHandle_t outHandle);
-
-/**********************************************************************
- * Global Variables
- **********************************************************************/
-
-/**********************************************************************
- * Private Variables
- **********************************************************************/
-
-/**********************************************************************
- * Public Functions
- **********************************************************************/
-
-int main(int argc, char *argv[], char *envp[])
-{
- poffHandle_t outHandle;
-
- /* Parse the command line arguments */
-
- parseArgs(argc, argv);
-
- /* Create a handle to hold the output file data */
-
- outHandle = poffCreateHandle();
- if (outHandle == NULL) fatal(eNOMEMORY);
-
- /* Load the POFF files specified on the command line */
-
- loadInputFiles(outHandle);
-
- /* Verify that all symbols were processed correctly */
-
- verifySymbols();
-
- /* Apply the relocation data to the program data */
-
- applyRelocations(outHandle);
-
- /* Write the symbol table information to the output file */
-
- writeSymbols(outHandle);
-
- /* Write the output file */
-
- writeOutputFile(outHandle);
-
- /* Release bufferred symbol/relocation informtion */
-
- releaseSymbols();
- releaseRelocations();
-
- /* Release the input file data */
-
- poffDestroyHandle(outHandle);
-
- return 0;
-
-} /* end main */
-
-/**********************************************************************
- * Private Functions
- **********************************************************************/
-
-static void showUsage(const char *progname)
-{
- fprintf(stderr, "Usage:\n");
- fprintf(stderr, " %s <in-file-name> {<in-file-name>} <out-file-name>\n",
- progname);
-}
-
-/***********************************************************************/
-
-static void parseArgs(int argc, char **argv)
-{
- int i;
-
- /* Check for existence of filename argument */
-
- if (argc < 3)
- {
- fprintf(stderr,
- "ERROR: <in-file-name> and one <out-file-name> required\n");
- showUsage(argv[0]);
- } /* end if */
-
- /* Get the name of the p-code file(s) from the last argument(s) */
-
- for (i = 1; i < argc-1; i++)
- {
- inFileName[nPoffFiles] = argv[i];
- nPoffFiles++;
- }
-
- /* The last thing on the command line is the output file name */
-
- outFileName = argv[argc-1];
-}
-
-/***********************************************************************/
-/* This function loads each POFF file specified on the command line,
- * merges the input POFF data, and generates intermediate structures
- * to be used in the final link.
- */
-
-static void loadInputFiles(poffHandle_t outHandle)
-{
- poffHandle_t inHandle;
- FILE *instream;
- char fileName[FNAME_SIZE+1]; /* Object file name */
- uint32 pcOffset = 0;
- uint32 fnOffset = 0;
- uint32 symOffset = 0;
- uint32 roOffset = 0;
- uint32 pcEnd = 0;
- uint32 fnEnd = 0;
- uint32 symEnd = 0;
- uint16 errCode;
- boolean progFound = FALSE;
- int i;
-
- /* Load the POFF files specified on the command line */
-
- for (i = 0; i < nPoffFiles; i++)
- {
- /* Create a handle to hold the input file data */
-
- inHandle = poffCreateHandle();
- if (inHandle == NULL) fatal(eNOMEMORY);
-
- /* Use .o or command line extension, if supplied, to get the
- * input file name.
- */
-
- (void)extension(inFileName[i], "o", fileName, 0);
-
- /* Open the input file */
-
- instream = fopen(fileName, "rb");
- if (instream == NULL)
- {
- fprintf(stderr, "ERROR: Could not open %s: %s\n",
- fileName, strerror(errno));
- exit(1);
- }
-
- /* Load the POFF file */
-
- errCode = poffReadFile(inHandle, instream);
- if (errCode != eNOERROR)
- {
- fprintf(stderr, "ERROR: Could not read %s (%d)\n",
- fileName, errCode);
- exit(1);
- }
-
- /* Check file header for critical settings */
-
- checkFileHeader(inHandle, outHandle, pcOffset, &progFound);
-
- /* Merge the read-only data sections */
-
- roOffset = mergeRoData(inHandle, outHandle);
-
- /* Merge program section data from the new input file into the
- * output file container.
- */
-
- pcEnd = mergeProgramData(inHandle, outHandle, pcOffset, roOffset);
-
- /* Merge the file name data from the new input file into the
- * output file container.
- */
-
- fnEnd = mergeFileNames(inHandle, outHandle);
-
- /* Merge the line number data from the new input file into the
- * output file container.
- */
-
- (void)mergeLineNumbers(inHandle, outHandle, pcOffset, fnOffset);
-
- /* On this pass, we just want to collect all symbol table in a
- * local list where we can resolve all undefined symbols (later)
- */
-
- symEnd = mergeSymbols(inHandle, pcOffset, symOffset);
-
- /* On this pass, we will also want to buffer all relocation data,
- * adjusting only the program section offset and sym table
- * offsets.
- */
-
- mergeRelocations(inHandle, pcOffset, symOffset);
-
- /* Release the input file data */
-
- insn_ResetOpCodeRead(inHandle);
- poffDestroyHandle(inHandle);
-
- /* Close the input file */
-
- fclose(instream);
-
- /* Set the offsest to be used for the next file equal
- * to the end values found from processing this file
- */
-
- pcOffset = pcEnd;
- fnOffset = fnEnd;
- symOffset = symEnd;
- }
-
- /* Did we find exactly one program file? */
-
- if (!progFound)
- {
- /* No! We have to have a program file to generate an executable */
-
- fprintf(stderr, "ERROR: No program file found in input files\n");
- exit(1);
- }
-
-} /* end loadInputFiles */
-
-/***********************************************************************/
-
-static void checkFileHeader(poffHandle_t inHandle, poffHandle_t outHandle,
- uint32 pcOffset, boolean *progFound)
-{
- ubyte fileType;
-
- /* What kind of file are we processing? */
-
- fileType = poffGetFileType(inHandle);
- if (fileType == FHT_PROGRAM)
- {
- /* We can handle only one pascal program file */
-
- if (*progFound)
- {
- fprintf(stderr,
- "ERROR: Only one compiled pascal program file "
- "may appear in input file list\n");
- exit(1);
- }
- else
- {
- /* Get the entry point from the pascal file, apply any
- * necessary offsets, and store the entry point in the
- * linked output file's file header.
- */
-
- poffSetEntryPoint(outHandle,
- poffGetEntryPoint(inHandle) + pcOffset);
-
- /* Copy the program name from the pascal file to the linked
- * output file's file header and mark the output file as
- * a pascal executable.
- */
-
- poffSetFileType(outHandle, FHT_EXEC, 0,
- poffGetFileHdrName(inHandle));
-
- /* Indicate that we have found the program file */
-
- *progFound = TRUE;
- }
- }
- else if (fileType != FHT_UNIT)
- {
- /* It is something other than a compiled pascal program or unit
- * file.
- */
-
- fprintf(stderr,
- "ERROR: Only compiled pascal program and unit files "
- "may appear in input file list\n");
- exit(1);
- }
-}
-
-/***********************************************************************/
-
-static uint32 mergeRoData(poffHandle_t inHandle, poffHandle_t outHandle)
-{
- ubyte *newRoData;
- uint32 oldRoDataSize;
- uint32 newRoDataSize;
-
- /* Get the size of the read-only data section before we add the
- * new data. This is the offset that must be applied to any
- * references to the new data.
- */
-
- oldRoDataSize = poffGetRoDataSize(outHandle);
-
- /* Remove the read-only data from new input file */
-
- newRoDataSize = poffExtractRoData(inHandle, &newRoData);
-
- /* And append the new read-only data to output file */
-
- poffAppendRoData(outHandle, newRoData, newRoDataSize);
-
- return oldRoDataSize;
-}
-
-/***********************************************************************/
-/* This function merges the program data section of a new file into the
- * program data section of the output file, relocating simple program
- * section references as they are encountered.
- */
-
-static uint32 mergeProgramData(poffHandle_t inHandle,
- poffHandle_t outHandle,
- uint32 pcOffset, uint32 roOffset)
-{
- OPTYPE op;
- uint32 pc;
- uint32 opSize;
- int endOp;
-
- /* Read each opcode from the input file, add pcOffset to each program
- * section address, and add each opcode to the output file.
- */
-
- pc = pcOffset;
- do
- {
- /* Read the next opcode (with its size) */
-
- opSize = insn_GetOpCode(inHandle, &op);
-
- /* Perform any necessary relocations */
-
- endOp = insn_Relocate(&op, pcOffset, roOffset);
-
- /* Save the potentially modified opcode in the temporary
- * program data container.
- */
-
- insn_AddOpCode(outHandle, &op);
- pc += opSize;
- }
- while (endOp == 0);
-
- return pc;
-}
-
-/***********************************************************************/
-/* This function merges the file name section of a new file into the
- * file name section of the output file, relocating simple program
- * section references as they are encountered.
- */
-
-static uint32 mergeFileNames(poffHandle_t inHandle,
- poffHandle_t outHandle)
-{
- sint32 inOffset;
- uint32 outOffset;
- const char *fname;
-
- do
- {
- /* Read each file name from the input File */
-
- inOffset = poffGetFileName(inHandle, &fname);
- if (inOffset >= 0)
- {
- /* And write it to the output file */
-
- outOffset = poffAddFileName(outHandle, fname);
- }
- }
- while (inOffset >= 0);
-
- /* Return the offset to the last file name written to the
- * output file
- */
-
- return outOffset;
-}
-
-/***********************************************************************/
-/* This function merges the line number section of a new file into the
- * line number section of the output file, relocating simple program
- * section references as they are encountered.
- */
-
-static uint32 mergeLineNumbers(poffHandle_t inHandle,
- poffHandle_t outHandle,
- uint32 pcOffset,
- uint32 fnOffset)
-{
- poffLineNumber_t lineno;
- sint32 inOffset;
- uint32 outOffset;
-
- do
- {
- /* Read each line number from the input File */
-
- inOffset = poffGetRawLineNumber(inHandle, &lineno);
- if (inOffset >= 0)
- {
- /* And write it to the output file */
-
- outOffset = poffAddLineNumber(outHandle, lineno.ln_lineno,
- lineno.ln_fileno + fnOffset,
- lineno.ln_poffset + pcOffset);
- }
- }
- while (inOffset >= 0);
-
- /* Return the offset to the last line number written to the
- * output file
- */
-
- return outOffset;
-}
-
-/***********************************************************************/
-
-static void writeOutputFile(poffHandle_t outHandle)
-{
- FILE *outstream;
- char fileName[FNAME_SIZE+1]; /* Output file name */
-
- /* Use .pex or command line extension, if supplied, to get the
- * input file name.
- */
-
- (void)extension(outFileName, "pex", fileName, 0);
-
- /* Open the output file */
-
- outstream = fopen(fileName, "wb");
- if (outstream == NULL)
- {
- fprintf(stderr, "ERROR: Could not open %s: %s\n",
- fileName, strerror(errno));
- exit(1);
- }
-
- /* Write the POFF file */
-
- (void)poffWriteFile(outHandle, outstream);
-
- /* Close the output file */
-
- fclose(outstream);
-}
-
-/***********************************************************************/
+/********************************************************************** + * plink.c + * P-Code Linker + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + **********************************************************************/ + +/********************************************************************** + * Included Files + **********************************************************************/ + +#include <stdint.h> +#include <stdbool.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <errno.h> + +#include "keywords.h" +#include "pdefs.h" +#include "podefs.h" +#include "pedefs.h" + +#include "paslib.h" +#include "perr.h" +#include "plsym.h" +#include "plreloc.h" +#include "pinsn.h" +#include "plink.h" + +/********************************************************************** + * Definitions + **********************************************************************/ + +#define MAX_POFF_FILES 8 + +/********************************************************************** + * Private Type Definitions + **********************************************************************/ + +/********************************************************************** + * Private Constant Data + **********************************************************************/ + +/********************************************************************** + * Private Data + **********************************************************************/ + +static const char *outFileName; +static const char *inFileName[MAX_POFF_FILES]; +static int nPoffFiles = 0; + +/********************************************************************** + * Private Function Prototypes + **********************************************************************/ + +static void showUsage (const char *progname); +static void parseArgs (int argc, char **argv); +static void loadInputFiles (poffHandle_t outHandle); +static void checkFileHeader (poffHandle_t inHandle, poffHandle_t outHandle, + uint32_t pcOffset, bool *progFound); +static uint32_t mergeRoData (poffHandle_t inHandle, poffHandle_t outHandle); +static uint32_t mergeProgramData (poffHandle_t inHandle, poffHandle_t outHandle, + uint32_t pcOffset, uint32_t roOffset); +static uint32_t mergeFileNames (poffHandle_t inHandle, poffHandle_t outHandle); +static uint32_t mergeLineNumbers (poffHandle_t inHandle, poffHandle_t outHandle, + uint32_t pcOffset, uint32_t fnOffset); +static void writeOutputFile (poffHandle_t outHandle); + +/********************************************************************** + * Global Variables + **********************************************************************/ + +/********************************************************************** + * Private Variables + **********************************************************************/ + +/********************************************************************** + * Public Functions + **********************************************************************/ + +int main(int argc, char *argv[], char *envp[]) +{ + poffHandle_t outHandle; + + /* Parse the command line arguments */ + + parseArgs(argc, argv); + + /* Create a handle to hold the output file data */ + + outHandle = poffCreateHandle(); + if (outHandle == NULL) fatal(eNOMEMORY); + + /* Load the POFF files specified on the command line */ + + loadInputFiles(outHandle); + + /* Verify that all symbols were processed correctly */ + + verifySymbols(); + + /* Apply the relocation data to the program data */ + + applyRelocations(outHandle); + + /* Write the symbol table information to the output file */ + + writeSymbols(outHandle); + + /* Write the output file */ + + writeOutputFile(outHandle); + + /* Release bufferred symbol/relocation informtion */ + + releaseSymbols(); + releaseRelocations(); + + /* Release the input file data */ + + poffDestroyHandle(outHandle); + + return 0; + +} /* end main */ + +/********************************************************************** + * Private Functions + **********************************************************************/ + +static void showUsage(const char *progname) +{ + fprintf(stderr, "Usage:\n"); + fprintf(stderr, " %s <in-file-name> {<in-file-name>} <out-file-name>\n", + progname); +} + +/***********************************************************************/ + +static void parseArgs(int argc, char **argv) +{ + int i; + + /* Check for existence of filename argument */ + + if (argc < 3) + { + fprintf(stderr, + "ERROR: <in-file-name> and one <out-file-name> required\n"); + showUsage(argv[0]); + } /* end if */ + + /* Get the name of the p-code file(s) from the last argument(s) */ + + for (i = 1; i < argc-1; i++) + { + inFileName[nPoffFiles] = argv[i]; + nPoffFiles++; + } + + /* The last thing on the command line is the output file name */ + + outFileName = argv[argc-1]; +} + +/***********************************************************************/ +/* This function loads each POFF file specified on the command line, + * merges the input POFF data, and generates intermediate structures + * to be used in the final link. + */ + +static void loadInputFiles(poffHandle_t outHandle) +{ + poffHandle_t inHandle; + FILE *instream; + char fileName[FNAME_SIZE+1]; /* Object file name */ + uint32_t pcOffset = 0; + uint32_t fnOffset = 0; + uint32_t symOffset = 0; + uint32_t roOffset = 0; + uint32_t pcEnd = 0; + uint32_t fnEnd = 0; + uint32_t symEnd = 0; + uint16_t errCode; + bool progFound = false; + int i; + + /* Load the POFF files specified on the command line */ + + for (i = 0; i < nPoffFiles; i++) + { + /* Create a handle to hold the input file data */ + + inHandle = poffCreateHandle(); + if (inHandle == NULL) fatal(eNOMEMORY); + + /* Use .o or command line extension, if supplied, to get the + * input file name. + */ + + (void)extension(inFileName[i], "o", fileName, 0); + + /* Open the input file */ + + instream = fopen(fileName, "rb"); + if (instream == NULL) + { + fprintf(stderr, "ERROR: Could not open %s: %s\n", + fileName, strerror(errno)); + exit(1); + } + + /* Load the POFF file */ + + errCode = poffReadFile(inHandle, instream); + if (errCode != eNOERROR) + { + fprintf(stderr, "ERROR: Could not read %s (%d)\n", + fileName, errCode); + exit(1); + } + + /* Check file header for critical settings */ + + checkFileHeader(inHandle, outHandle, pcOffset, &progFound); + + /* Merge the read-only data sections */ + + roOffset = mergeRoData(inHandle, outHandle); + + /* Merge program section data from the new input file into the + * output file container. + */ + + pcEnd = mergeProgramData(inHandle, outHandle, pcOffset, roOffset); + + /* Merge the file name data from the new input file into the + * output file container. + */ + + fnEnd = mergeFileNames(inHandle, outHandle); + + /* Merge the line number data from the new input file into the + * output file container. + */ + + (void)mergeLineNumbers(inHandle, outHandle, pcOffset, fnOffset); + + /* On this pass, we just want to collect all symbol table in a + * local list where we can resolve all undefined symbols (later) + */ + + symEnd = mergeSymbols(inHandle, pcOffset, symOffset); + + /* On this pass, we will also want to buffer all relocation data, + * adjusting only the program section offset and sym table + * offsets. + */ + + mergeRelocations(inHandle, pcOffset, symOffset); + + /* Release the input file data */ + + insn_ResetOpCodeRead(inHandle); + poffDestroyHandle(inHandle); + + /* Close the input file */ + + fclose(instream); + + /* Set the offsest to be used for the next file equal + * to the end values found from processing this file + */ + + pcOffset = pcEnd; + fnOffset = fnEnd; + symOffset = symEnd; + } + + /* Did we find exactly one program file? */ + + if (!progFound) + { + /* No! We have to have a program file to generate an executable */ + + fprintf(stderr, "ERROR: No program file found in input files\n"); + exit(1); + } + +} /* end loadInputFiles */ + +/***********************************************************************/ + +static void checkFileHeader(poffHandle_t inHandle, poffHandle_t outHandle, + uint32_t pcOffset, bool *progFound) +{ + uint8_t fileType; + + /* What kind of file are we processing? */ + + fileType = poffGetFileType(inHandle); + if (fileType == FHT_PROGRAM) + { + /* We can handle only one pascal program file */ + + if (*progFound) + { + fprintf(stderr, + "ERROR: Only one compiled pascal program file " + "may appear in input file list\n"); + exit(1); + } + else + { + /* Get the entry point from the pascal file, apply any + * necessary offsets, and store the entry point in the + * linked output file's file header. + */ + + poffSetEntryPoint(outHandle, + poffGetEntryPoint(inHandle) + pcOffset); + + /* Copy the program name from the pascal file to the linked + * output file's file header and mark the output file as + * a pascal executable. + */ + + poffSetFileType(outHandle, FHT_EXEC, 0, + poffGetFileHdrName(inHandle)); + + /* Indicate that we have found the program file */ + + *progFound = true; + } + } + else if (fileType != FHT_UNIT) + { + /* It is something other than a compiled pascal program or unit + * file. + */ + + fprintf(stderr, + "ERROR: Only compiled pascal program and unit files " + "may appear in input file list\n"); + exit(1); + } +} + +/***********************************************************************/ + +static uint32_t mergeRoData(poffHandle_t inHandle, poffHandle_t outHandle) +{ + uint8_t *newRoData; + uint32_t oldRoDataSize; + uint32_t newRoDataSize; + + /* Get the size of the read-only data section before we add the + * new data. This is the offset that must be applied to any + * references to the new data. + */ + + oldRoDataSize = poffGetRoDataSize(outHandle); + + /* Remove the read-only data from new input file */ + + newRoDataSize = poffExtractRoData(inHandle, &newRoData); + + /* And append the new read-only data to output file */ + + poffAppendRoData(outHandle, newRoData, newRoDataSize); + + return oldRoDataSize; +} + +/***********************************************************************/ +/* This function merges the program data section of a new file into the + * program data section of the output file, relocating simple program + * section references as they are encountered. + */ + +static uint32_t mergeProgramData(poffHandle_t inHandle, + poffHandle_t outHandle, + uint32_t pcOffset, uint32_t roOffset) +{ + OPTYPE op; + uint32_t pc; + uint32_t opSize; + int endOp; + + /* Read each opcode from the input file, add pcOffset to each program + * section address, and add each opcode to the output file. + */ + + pc = pcOffset; + do + { + /* Read the next opcode (with its size) */ + + opSize = insn_GetOpCode(inHandle, &op); + + /* Perform any necessary relocations */ + + endOp = insn_Relocate(&op, pcOffset, roOffset); + + /* Save the potentially modified opcode in the temporary + * program data container. + */ + + insn_AddOpCode(outHandle, &op); + pc += opSize; + } + while (endOp == 0); + + return pc; +} + +/***********************************************************************/ +/* This function merges the file name section of a new file into the + * file name section of the output file, relocating simple program + * section references as they are encountered. + */ + +static uint32_t mergeFileNames(poffHandle_t inHandle, + poffHandle_t outHandle) +{ + int32_t inOffset; + uint32_t outOffset; + const char *fname; + + do + { + /* Read each file name from the input File */ + + inOffset = poffGetFileName(inHandle, &fname); + if (inOffset >= 0) + { + /* And write it to the output file */ + + outOffset = poffAddFileName(outHandle, fname); + } + } + while (inOffset >= 0); + + /* Return the offset to the last file name written to the + * output file + */ + + return outOffset; +} + +/***********************************************************************/ +/* This function merges the line number section of a new file into the + * line number section of the output file, relocating simple program + * section references as they are encountered. + */ + +static uint32_t mergeLineNumbers(poffHandle_t inHandle, + poffHandle_t outHandle, + uint32_t pcOffset, + uint32_t fnOffset) +{ + poffLineNumber_t lineno; + int32_t inOffset; + uint32_t outOffset; + + do + { + /* Read each line number from the input File */ + + inOffset = poffGetRawLineNumber(inHandle, &lineno); + if (inOffset >= 0) + { + /* And write it to the output file */ + + outOffset = poffAddLineNumber(outHandle, lineno.ln_lineno, + lineno.ln_fileno + fnOffset, + lineno.ln_poffset + pcOffset); + } + } + while (inOffset >= 0); + + /* Return the offset to the last line number written to the + * output file + */ + + return outOffset; +} + +/***********************************************************************/ + +static void writeOutputFile(poffHandle_t outHandle) +{ + FILE *outstream; + char fileName[FNAME_SIZE+1]; /* Output file name */ + + /* Use .pex or command line extension, if supplied, to get the + * input file name. + */ + + (void)extension(outFileName, "pex", fileName, 0); + + /* Open the output file */ + + outstream = fopen(fileName, "wb"); + if (outstream == NULL) + { + fprintf(stderr, "ERROR: Could not open %s: %s\n", + fileName, strerror(errno)); + exit(1); + } + + /* Write the POFF file */ + + (void)poffWriteFile(outHandle, outstream); + + /* Close the output file */ + + fclose(outstream); +} + +/***********************************************************************/ diff --git a/misc/pascal/plink/plreloc.c b/misc/pascal/plink/plreloc.c index 32911570cc..0faf0715c8 100644 --- a/misc/pascal/plink/plreloc.c +++ b/misc/pascal/plink/plreloc.c @@ -2,7 +2,7 @@ * plreloc.c * Relocation management for the P-Code Linker * - * Copyright (C) 2008 Gregory Nutt. All rights reserved. + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. * Author: Gregory Nutt <spudmonkey@racsa.co.cr> * * Redistribution and use in source and binary forms, with or without @@ -38,6 +38,7 @@ * Included Files **********************************************************************/ +#include <stdint.h> #include <stdio.h> #include <stdlib.h> #include <string.h> @@ -56,7 +57,7 @@ #include "plreloc.h" /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ #define INITIAL_RELOC_LIST_SIZE (1024*sizeof(poffRelocation_t*)) @@ -71,8 +72,8 @@ **********************************************************************/ static poffRelocation_t *relocList = NULL; -static uint32 relocListAlloc = 0; -static uint32 nRelocs = 0; +static uint32_t relocListAlloc = 0; +static uint32_t nRelocs = 0; /********************************************************************** * Private Function Prototypes @@ -80,7 +81,7 @@ static uint32 nRelocs = 0; **********************************************************************/ static void offsetRelocation(poffRelocation_t *reloc, - uint32 pcOffset, uint32 symOffset); + uint32_t pcOffset, uint32_t symOffset); static void addRelocToList(poffRelocation_t *reloc); /********************************************************************** @@ -88,10 +89,10 @@ static void addRelocToList(poffRelocation_t *reloc); **********************************************************************/ void mergeRelocations(poffHandle_t inHandle, - uint32 pcOffset, uint32 symOffset) + uint32_t pcOffset, uint32_t symOffset) { poffRelocation_t reloc; - sint32 index; + int32_t index; do { @@ -99,18 +100,18 @@ void mergeRelocations(poffHandle_t inHandle, index = poffGetRawRelocation(inHandle, &reloc); if (index >= 0) - { - /* If the rellocation carries a "payload" that is a program - * section offset, then apply the pcOffset value to - * that "payload" - */ + { + /* If the rellocation carries a "payload" that is a program + * section offset, then apply the pcOffset value to + * that "payload" + */ - offsetRelocation(&reloc, pcOffset, symOffset); + offsetRelocation(&reloc, pcOffset, symOffset); - /* Add the relocation to the in-memory relocation list */ + /* Add the relocation to the in-memory relocation list */ - addRelocToList(&reloc); - } + addRelocToList(&reloc); + } } while (index >= 0); } @@ -119,8 +120,8 @@ void mergeRelocations(poffHandle_t inHandle, void applyRelocations(poffHandle_t outHandle) { - ubyte *progData; - uint32 progSize; + uint8_t *progData; + uint32_t progSize; int i; /* Take ownership of the program data image for a little while */ @@ -132,39 +133,39 @@ void applyRelocations(poffHandle_t outHandle) for (i = 0; i < nRelocs; i++) { poffRelocation_t *reloc = &relocList[i]; - uint32 symIndex = RLI_SYM(reloc->rl_info); - uint32 relType = RLI_TYPE(reloc->rl_info); + uint32_t symIndex = RLI_SYM(reloc->rl_info); + uint32_t relType = RLI_TYPE(reloc->rl_info); poffLibSymbol_t *sym; - uint32 progIndex; + uint32_t progIndex; switch (relType) - { - case RLT_PCAL: - /* Get the symbol referenced by the relocation. At this - * point, we assume that the system has already verified - * that there are no undefined symbols. - */ + { + case RLT_PCAL: + /* Get the symbol referenced by the relocation. At this + * point, we assume that the system has already verified + * that there are no undefined symbols. + */ - sym = getSymbolByIndex(symIndex); + sym = getSymbolByIndex(symIndex); - /* Get the index to the oPCAL instruction */ + /* Get the index to the oPCAL instruction */ - progIndex = reloc->rl_offset; + progIndex = reloc->rl_offset; - /* Sanity checking */ + /* Sanity checking */ - if (((sym->flags & STF_UNDEFINED) != 0) || - (progIndex > progSize-4)) - fatal(ePOFFCONFUSION); + if (((sym->flags & STF_UNDEFINED) != 0) || + (progIndex > progSize-4)) + fatal(ePOFFCONFUSION); - /* Perform the relocation */ + /* Perform the relocation */ - insn_FixupProcedureCall(&progData[progIndex], sym->value); - break; + insn_FixupProcedureCall(&progData[progIndex], sym->value); + break; - default: - break; - } + default: + break; + } } @@ -186,10 +187,10 @@ void releaseRelocations(void) **********************************************************************/ static void offsetRelocation(poffRelocation_t *reloc, - uint32 pcOffset, uint32 symOffset) + uint32_t pcOffset, uint32_t symOffset) { - uint32 symIndex = RLI_SYM(reloc->rl_info); - uint32 relType = RLI_TYPE(reloc->rl_info); + uint32_t symIndex = RLI_SYM(reloc->rl_info); + uint32_t relType = RLI_TYPE(reloc->rl_info); switch (relType) { @@ -217,9 +218,9 @@ static void addRelocToList(poffRelocation_t *reloc) relocList = (poffRelocation_t*)malloc(INITIAL_RELOC_LIST_SIZE); if (!relocList) - { - fatal(eNOMEMORY); - } + { + fatal(eNOMEMORY); + } relocListAlloc = INITIAL_RELOC_LIST_SIZE; } @@ -227,16 +228,16 @@ static void addRelocToList(poffRelocation_t *reloc) if ((nRelocs + 1) * sizeof(poffRelocation_t) > relocListAlloc) { - uint32 newAlloc = relocListAlloc + RELOC_LIST_INCREMENT; + uint32_t newAlloc = relocListAlloc + RELOC_LIST_INCREMENT; poffRelocation_t *tmp; /* Reallocate the file name buffer */ tmp = (poffRelocation_t*)realloc(relocList, newAlloc); if (!tmp) - { - fatal(eNOMEMORY); - } + { + fatal(eNOMEMORY); + } /* And set the new size */ diff --git a/misc/pascal/plink/plreloc.h b/misc/pascal/plink/plreloc.h index 1998361b92..d8dd894761 100644 --- a/misc/pascal/plink/plreloc.h +++ b/misc/pascal/plink/plreloc.h @@ -1,59 +1,60 @@ -/***************************************************************************
- * plreloc.h
- * External Declarations associated with plreloc.c
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************************/
-
-#ifndef __PLRELOC_H
-#define __PLRELOC_H
-
-/***************************************************************************
- * Included Files
- ***************************************************************************/
-
-#include "pofflib.h"
-
-/***************************************************************************
- * Global Variables
- ***************************************************************************/
-
-/***************************************************************************
- * Global Function Prototypes
- ***************************************************************************/
-
-extern void mergeRelocations(poffHandle_t inHandle,
- uint32 pcOffset, uint32 symOffset);
-extern void applyRelocations(poffHandle_t outHandle);
-extern void releaseRelocations(void);
-
-#endif /* __PLRELOC_H */
+/*************************************************************************** + * plreloc.h + * External Declarations associated with plreloc.c + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************************/ + +#ifndef __PLRELOC_H +#define __PLRELOC_H + +/*************************************************************************** + * Included Files + ***************************************************************************/ + +#include <stdint.h> +#include "pofflib.h" + +/*************************************************************************** + * Global Variables + ***************************************************************************/ + +/*************************************************************************** + * Global Function Prototypes + ***************************************************************************/ + +extern void mergeRelocations(poffHandle_t inHandle, + uint32_t pcOffset, uint32_t symOffset); +extern void applyRelocations(poffHandle_t outHandle); +extern void releaseRelocations(void); + +#endif /* __PLRELOC_H */ diff --git a/misc/pascal/plink/plsym.c b/misc/pascal/plink/plsym.c index 1ef40461ae..ceeb0c4f7e 100644 --- a/misc/pascal/plink/plsym.c +++ b/misc/pascal/plink/plsym.c @@ -2,7 +2,7 @@ * plsym.c * Symbol management for the P-Code Linker * - * Copyright (C) 2008 Gregory Nutt. All rights reserved. + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. * Author: Gregory Nutt <spudmonkey@racsa.co.cr> * * Redistribution and use in source and binary forms, with or without @@ -38,6 +38,7 @@ * Included Files **********************************************************************/ +#include <stdint.h> #include <stdio.h> #include <stdlib.h> #include <string.h> @@ -54,7 +55,7 @@ #include "plsym.h" /********************************************************************** - * Definitions + * Pre-processor Definitions **********************************************************************/ #define INITIAL_SYMBOL_LIST_SIZE (1024*sizeof(symContainer_t*)) @@ -81,7 +82,7 @@ typedef struct symContainer_s symContainer_t; static symContainer_t *symHead = NULL; static symContainer_t *symTail = NULL; static symContainer_t **symList = NULL; -static uint32 symListAlloc = 0; +static uint32_t symListAlloc = 0; static int nUndefined = 0; static int nMultiplyDefined = 0; @@ -92,21 +93,21 @@ static int nMultiplyDefined = 0; **********************************************************************/ static void offsetSymbolValue(poffLibSymbol_t *sym, - uint32 pcOffset); + uint32_t pcOffset); static symContainer_t *insertSymbol(poffLibSymbol_t *sym); static void addSymbolToList(symContainer_t *symbol, - uint32 index); + uint32_t index); /********************************************************************** * Public Functions **********************************************************************/ -uint32 mergeSymbols(poffHandle_t inHandle, uint32 pcOffset, uint32 symOffset) +uint32_t mergeSymbols(poffHandle_t inHandle, uint32_t pcOffset, uint32_t symOffset) { poffLibSymbol_t symbol; symContainer_t *container; - sint32 inIndex; - uint32 outIndex; + int32_t inIndex; + uint32_t outIndex; do { @@ -114,23 +115,23 @@ uint32 mergeSymbols(poffHandle_t inHandle, uint32 pcOffset, uint32 symOffset) inIndex = poffGetSymbol(inHandle, &symbol); if (inIndex >= 0) - { - /* If the symbol carries a "payload" that is a program - * section offset, then apply the pcOffset value to - * that "payload" - */ + { + /* If the symbol carries a "payload" that is a program + * section offset, then apply the pcOffset value to + * that "payload" + */ - offsetSymbolValue(&symbol, pcOffset); + offsetSymbolValue(&symbol, pcOffset); - /* Create a container for the symbol information */ + /* Create a container for the symbol information */ - container = insertSymbol(&symbol); + container = insertSymbol(&symbol); - /* Add the symbol to the linearly indexed list */ + /* Add the symbol to the linearly indexed list */ - outIndex = inIndex + symOffset; - addSymbolToList(container, outIndex); - } + outIndex = inIndex + symOffset; + addSymbolToList(container, outIndex); + } } while (inIndex >= 0); @@ -154,11 +155,11 @@ void verifySymbols(void) for (sym = symHead; (sym); sym = sym->next) { if ((sym->s.flags & STF_UNDEFINED) != 0) - { - fprintf(stderr, "ERROR: Undefined symbol '%s'\n", - sym->s.name); - nUndefined++; - } + { + fprintf(stderr, "ERROR: Undefined symbol '%s'\n", + sym->s.name); + nUndefined++; + } } if (nUndefined) fatal(eUNDEFINEDSYMBOL); @@ -181,7 +182,7 @@ void writeSymbols(poffHandle_t outHandle) /***********************************************************************/ -poffLibSymbol_t *getSymbolByIndex(uint32 symIndex) +poffLibSymbol_t *getSymbolByIndex(uint32_t symIndex) { if (symIndex * sizeof(symContainer_t*) >= symListAlloc) fatal(ePOFFCONFUSION); @@ -223,7 +224,7 @@ void releaseSymbols(void) /**********************************************************************/ -static void offsetSymbolValue(poffLibSymbol_t *sym, uint32 pcOffset) +static void offsetSymbolValue(poffLibSymbol_t *sym, uint32_t pcOffset) { /* Don't do anything with undefined symbols. By definition, these * cannot cannot any meaning values. @@ -232,15 +233,15 @@ static void offsetSymbolValue(poffLibSymbol_t *sym, uint32 pcOffset) if ((sym->flags & STF_UNDEFINED) == 0) { switch (sym->type) - { - case STT_PROC: - case STT_FUNC: - sym->value += pcOffset; - break; - - default: - break; - } + { + case STT_PROC: + case STT_FUNC: + sym->value += pcOffset; + break; + + default: + break; + } } } @@ -297,30 +298,30 @@ static symContainer_t *insertSymbol(poffLibSymbol_t *sym) */ if (compare > 0) - { - /* Break out... curr refers to a symbol AFTER the position - * where we want to put the new symbol. - */ + { + /* Break out... curr refers to a symbol AFTER the position + * where we want to put the new symbol. + */ - break; - } + break; + } else if (compare == 0) - { - /* The symbols are the same. break out only if the types - * are the same or this is where we need to insert the new - * symbol (same name different type) - */ - - if (curr->s.type > sym->type) - { - compare = 1; - break; - } - else if (curr->s.type == sym->type) - { - break; - } - } + { + /* The symbols are the same. break out only if the types + * are the same or this is where we need to insert the new + * symbol (same name different type) + */ + + if (curr->s.type > sym->type) + { + compare = 1; + break; + } + else if (curr->s.type == sym->type) + { + break; + } + } } /* We get here if: @@ -343,9 +344,9 @@ static symContainer_t *insertSymbol(poffLibSymbol_t *sym) symTail = newsym; if (prev) - prev->next = newsym; + prev->next = newsym; else - symHead = newsym; + symHead = newsym; } else if (compare == 0) { @@ -355,48 +356,48 @@ static symContainer_t *insertSymbol(poffLibSymbol_t *sym) */ if ((curr->s.flags & STF_UNDEFINED) != 0) - { - /* The symbol in the table is undefined */ - - if ((sym->flags & STF_UNDEFINED) != 0) - { - /* Both symbols are undefined. Just ignore the new one */ - } - else - { - /* The symbol in the table is undefined, but the new - * one is defined. Replace the one in the table (retaining - * the allocated symbol name). - */ - const char *save = curr->s.name; - curr->s = *sym; - curr->s.name = save; - } - } + { + /* The symbol in the table is undefined */ + + if ((sym->flags & STF_UNDEFINED) != 0) + { + /* Both symbols are undefined. Just ignore the new one */ + } + else + { + /* The symbol in the table is undefined, but the new + * one is defined. Replace the one in the table (retaining + * the allocated symbol name). + */ + const char *save = curr->s.name; + curr->s = *sym; + curr->s.name = save; + } + } else - { - /* The symbol in the table is defined */ - - if ((sym->flags & STF_UNDEFINED) != 0) - { - /* But the new symbol is undefined. Just ignore the - * new symbol - */ - } - else - { - /* OOPS! both symbols are defined */ - - fprintf(stderr, - "ERROR: Multiply defined symbol: '%s'\n", - sym->name); - nMultiplyDefined++; - } - - /* In any case, return the pointer to the old container */ - - newsym = curr; - } + { + /* The symbol in the table is defined */ + + if ((sym->flags & STF_UNDEFINED) != 0) + { + /* But the new symbol is undefined. Just ignore the + * new symbol + */ + } + else + { + /* OOPS! both symbols are defined */ + + fprintf(stderr, + "ERROR: Multiply defined symbol: '%s'\n", + sym->name); + nMultiplyDefined++; + } + + /* In any case, return the pointer to the old container */ + + newsym = curr; + } } else { @@ -407,9 +408,9 @@ static symContainer_t *insertSymbol(poffLibSymbol_t *sym) newsym->prev = prev; if (prev) - prev->next = newsym; + prev->next = newsym; else - symHead = newsym; + symHead = newsym; } return newsym; @@ -422,7 +423,7 @@ static symContainer_t *insertSymbol(poffLibSymbol_t *sym) * deterimed by insertSymbol(). */ -static void addSymbolToList(symContainer_t *symbol, uint32 index) +static void addSymbolToList(symContainer_t *symbol, uint32_t index) { /* Check if we have allocated a symbol table buffer yet */ @@ -432,9 +433,9 @@ static void addSymbolToList(symContainer_t *symbol, uint32 index) symList = (symContainer_t**)malloc(INITIAL_SYMBOL_LIST_SIZE); if (!symList) - { - fatal(eNOMEMORY); - } + { + fatal(eNOMEMORY); + } symListAlloc = INITIAL_SYMBOL_LIST_SIZE; } @@ -442,16 +443,16 @@ static void addSymbolToList(symContainer_t *symbol, uint32 index) if ((index + 1) * sizeof(symContainer_t*) > symListAlloc) { - uint32 newAlloc = symListAlloc + SYMBOL_LIST_INCREMENT; + uint32_t newAlloc = symListAlloc + SYMBOL_LIST_INCREMENT; symContainer_t **tmp; /* Reallocate the file name buffer */ tmp = (symContainer_t**)realloc(symList, newAlloc); if (!tmp) - { - fatal(eNOMEMORY); - } + { + fatal(eNOMEMORY); + } /* And set the new size */ diff --git a/misc/pascal/plink/plsym.h b/misc/pascal/plink/plsym.h index 96f5201485..69218830fd 100644 --- a/misc/pascal/plink/plsym.h +++ b/misc/pascal/plink/plsym.h @@ -1,61 +1,62 @@ -/***************************************************************************
- * plsym.h
- * External Declarations associated with plsym.c
- *
- * Copyright (C) 2008 Gregory Nutt. All rights reserved.
- * Author: Gregory Nutt <spudmonkey@racsa.co.cr>
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in
- * the documentation and/or other materials provided with the
- * distribution.
- * 3. Neither the name NuttX nor the names of its contributors may be
- * used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- *
- ***************************************************************************/
-
-#ifndef __PLSYM_H
-#define __PLSYM_H
-
-/***************************************************************************
- * Included Files
- ***************************************************************************/
-
-#include "pofflib.h"
-
-/***************************************************************************
- * Global Variables
- ***************************************************************************/
-
-/***************************************************************************
- * Global Function Prototypes
- ***************************************************************************/
-
-extern uint32 mergeSymbols(poffHandle_t inHandle,
- uint32 pcOffset, uint32 symOffset);
-extern void verifySymbols(void);
-extern void writeSymbols(poffHandle_t outHandle);
-extern poffLibSymbol_t *getSymbolByIndex(uint32 symIndex);
-extern void releaseSymbols(void);
-
-#endif /* __PLSYM_H */
+/*************************************************************************** + * plsym.h + * External Declarations associated with plsym.c + * + * Copyright (C) 2008-2009 Gregory Nutt. All rights reserved. + * Author: Gregory Nutt <spudmonkey@racsa.co.cr> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. Neither the name NuttX nor the names of its contributors may be + * used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + * + ***************************************************************************/ + +#ifndef __PLSYM_H +#define __PLSYM_H + +/*************************************************************************** + * Included Files + ***************************************************************************/ + +#include <stdint.h> +#include "pofflib.h" + +/*************************************************************************** + * Global Variables + ***************************************************************************/ + +/*************************************************************************** + * Global Function Prototypes + ***************************************************************************/ + +extern uint32_t mergeSymbols(poffHandle_t inHandle, + uint32_t pcOffset, uint32_t symOffset); +extern void verifySymbols(void); +extern void writeSymbols(poffHandle_t outHandle); +extern poffLibSymbol_t *getSymbolByIndex(uint32_t symIndex); +extern void releaseSymbols(void); + +#endif /* __PLSYM_H */ |