From 75f50f2730eca4f98620c9cad37ee1a02aed620e Mon Sep 17 00:00:00 2001 From: patacongo Date: Fri, 18 Dec 2009 17:14:06 +0000 Subject: Update to use stdint/stdbool.h git-svn-id: svn://svn.code.sf.net/p/nuttx/code/trunk@2386 42af7a65-404d-4744-a932-0658087f49c3 --- misc/pascal/ChangeLog | 6 +- misc/pascal/ReleaseNotes | 12 + misc/pascal/include/keywords.h | 7 +- misc/pascal/libpoff/pfdbgcontainer.c | 2 +- misc/pascal/libpoff/pfdbginfo.c | 2 +- misc/pascal/libpoff/pfdreloc.c | 2 +- misc/pascal/libpoff/pfdsymbol.c | 2 +- misc/pascal/libpoff/pfiprog.c | 2 +- misc/pascal/libpoff/pfirodata.c | 2 +- misc/pascal/libpoff/pflabel.c | 2 +- misc/pascal/libpoff/pflineno.c | 2 +- misc/pascal/libpoff/pfprivate.h | 6 +- misc/pascal/libpoff/pfrdbgfunc.c | 2 +- misc/pascal/libpoff/pfread.c | 2 +- misc/pascal/libpoff/pfrfname.c | 2 +- misc/pascal/libpoff/pfrhdr.c | 2 +- misc/pascal/libpoff/pfrlineno.c | 2 +- misc/pascal/libpoff/pfrrawlineno.c | 2 +- misc/pascal/libpoff/pfrrawreloc.c | 2 +- misc/pascal/libpoff/pfrseek.c | 2 +- misc/pascal/libpoff/pfrstring.c | 2 +- misc/pascal/libpoff/pfrsymbol.c | 2 +- misc/pascal/libpoff/pfswap.c | 2 +- misc/pascal/libpoff/pftprog.c | 2 +- misc/pascal/libpoff/pftsymbol.c | 2 +- misc/pascal/libpoff/pfwdbgfunc.c | 2 +- misc/pascal/libpoff/pfwfname.c | 2 +- misc/pascal/libpoff/pfwhdr.c | 2 +- misc/pascal/libpoff/pfwlineno.c | 2 +- misc/pascal/libpoff/pfwprog.c | 2 +- misc/pascal/libpoff/pfwreloc.c | 2 +- misc/pascal/libpoff/pfwrite.c | 2 +- misc/pascal/libpoff/pfwrodata.c | 2 +- misc/pascal/libpoff/pfwstring.c | 2 +- misc/pascal/libpoff/pfwsymbol.c | 2 +- misc/pascal/libpoff/pfxprog.c | 2 +- misc/pascal/libpoff/pfxrodata.c | 2 +- misc/pascal/libpoff/pofferr.c | 2 +- misc/pascal/nuttx/keywords.h | 1 - misc/pascal/pascal/pas.c | 1074 +++---- misc/pascal/pascal/pas.h | 230 +- misc/pascal/pascal/pasdefs.h | 565 ++-- misc/pascal/pascal/pblck.c | 4526 ++++++++++++++-------------- misc/pascal/pascal/pblck.h | 108 +- misc/pascal/pascal/pcexpr.c | 1150 +++---- misc/pascal/pascal/pcfunc.c | 680 ++--- misc/pascal/pascal/perr.c | 381 +-- misc/pascal/pascal/pexpr.c | 5472 +++++++++++++++++----------------- misc/pascal/pascal/pexpr.h | 190 +- misc/pascal/pascal/pffunc.c | 903 +++--- misc/pascal/pascal/pgen.c | 1282 ++++---- misc/pascal/pascal/pgen.h | 181 +- misc/pascal/pascal/pprgm.c | 529 ++-- misc/pascal/pascal/pproc.c | 1470 ++++----- misc/pascal/pascal/pstm.c | 3364 ++++++++++----------- misc/pascal/pascal/ptbl.c | 1382 ++++----- misc/pascal/pascal/ptbl.h | 157 +- misc/pascal/pascal/ptkn.c | 1798 +++++------ misc/pascal/pascal/ptkn.h | 123 +- misc/pascal/pascal/punit.c | 83 +- misc/pascal/plink/plink.c | 1100 +++---- misc/pascal/plink/plreloc.c | 101 +- misc/pascal/plink/plreloc.h | 119 +- misc/pascal/plink/plsym.c | 223 +- misc/pascal/plink/plsym.h | 123 +- 65 files changed, 13736 insertions(+), 13678 deletions(-) (limited to 'misc/pascal') diff --git a/misc/pascal/ChangeLog b/misc/pascal/ChangeLog index 9b8debd36..a5572f6d9 100644 --- a/misc/pascal/ChangeLog +++ b/misc/pascal/ChangeLog @@ -16,4 +16,8 @@ pascal-0.1.2 2008-02-10 Gregory Nutt and eliminate a compiler bug * Changes so that runtime compiles with SDCC. -pascal-0.1.3 2008-xx-xx Gregory Nutt +pascal-2.0 2009-xx-xx Gregory Nutt + + * 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 2abb1dd3c..d5c0ab333 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 aed438af8..6025524d9 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 d5eb03c27..572f1c2e6 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 5d2e889bc..41ea995cd 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 e082bee35..5e9f5bcfe 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 384d5b362..cce272616 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 5cbf1b79e..c768cb075 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 35e65268f..baaed6f7f 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 073e73292..088ad77ca 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 ed257d52d..de6e79ca1 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 afcd3da9d..76fdc867e 100644 --- a/misc/pascal/libpoff/pfprivate.h +++ b/misc/pascal/libpoff/pfprivate.h @@ -38,10 +38,6 @@ #ifndef __PFPRIVATE_H #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 052bd735c..0efce4380 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 1c03cd274..f10dd8c9a 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 68fc2fb4c..20d964a9e 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 8415c31fb..1605511a8 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 f7d76a973..8ca13c526 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 9855bc593..ec2e950c0 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 50e6e1bf8..a9f44a89e 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 e7c057780..e3dc1bcc2 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 664620cbb..2f8c7ae49 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 fe41e43b0..fe22de270 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 9c30aad8f..a33e633c3 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 3a7e71e21..a2a16aa3d 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 d30de5fb9..a8d9aed8b 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 babec18e8..f6879c088 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 dde752f5a..3d2bea32d 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 b8f9983b7..710721c27 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 ca72bc156..1b7cdab15 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 a9cb42e3a..22d47d49b 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 21abbb0cb..db2a2feba 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 5debe7ec6..916f25dc5 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 882eb94d1..7d059a547 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 b2e58c29a..9c3d854d7 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 4bfd559b3..534e7651a 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 e58090577..caa1d4864 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 b10eea642..f778ab42b 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 87fdc0265..f32db0475 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 2ebfcd8f6..762fa594e 100644 --- a/misc/pascal/nuttx/keywords.h +++ b/misc/pascal/nuttx/keywords.h @@ -42,7 +42,6 @@ #include #include -#include #include /************************************************************* diff --git a/misc/pascal/pascal/pas.c b/misc/pascal/pascal/pas.c index 8b8a03c53..23cc12b92 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 - * - * 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 -#include -#include -#include -#include -#include - -#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] \n", programName); - fprintf(stderr, "[options]\n"); - fprintf(stderr, " -I\n"); - fprintf(stderr, " Search in 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 + * + * 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 +#include +#include +#include +#include +#include +#include +#include + +#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] \n", programName); + fprintf(stderr, "[options]\n"); + fprintf(stderr, " -I\n"); + fprintf(stderr, " Search in 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 8b55187fe..5c9037ed0 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 - * - * 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 + * + * 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 +#include +#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 081c32a66..7fc05bf76 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 - * - * 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 /* for FILE */ -#include -#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 + * + * 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 +#include +#include +#include /* for FILE */ +#include +#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 f3abfb78b..19b815038 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 - * - * 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 -#include - -#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 [,[,][...]]]; */ - - 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: = - * 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 OF */ - /* OR: : */ - if (!(fileNumber)) error(eINVFILE); - else if (files [fileNumber].defined) error(eDUPFILE); - else { - - /* Skip over the */ - getToken(); - - /* Verify that a colon follows the */ - if (token != ':') error (eCOLON); - else getToken(); - - /* Make sure that the data stack is aligned to INTEGER boundaries */ - dstack = intAlign(dstack); - - /* FORM: : FILE OF */ - 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: : */ - 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: 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: 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: 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 [] 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 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 with this 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 - * 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 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 */ - - if (token != ')') - { - /* Now process the 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 - * 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 is enclosed in parentheses */ - - if (token == ')') getToken(); - else error(eRPAREN); - - /* A semicolon at this position means that another - * 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 with this as its name */ - - fieldPtr = addField(tkn_strt, recordPtr); - getToken(); - - /* Check for multiple fields of this */ - - 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 */ - /* 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: - * [,[,[...]]] : - */ - - 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 + * + * 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 +#include + +#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 [,[,][...]]]; */ + + 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: = + * 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 OF */ + /* OR: : */ + if (!(fileNumber)) error(eINVFILE); + else if (files [fileNumber].defined) error(eDUPFILE); + else { + + /* Skip over the */ + getToken(); + + /* Verify that a colon follows the */ + if (token != ':') error (eCOLON); + else getToken(); + + /* Make sure that the data stack is aligned to INTEGER boundaries */ + dstack = intAlign(dstack); + + /* FORM: : FILE OF */ + 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: : */ + 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: 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: 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: 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 [] 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 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 with this 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 + * 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 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 */ + + if (token != ')') + { + /* Now process the 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 + * 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 is enclosed in parentheses */ + + if (token == ')') getToken(); + else error(eRPAREN); + + /* A semicolon at this position means that another + * 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 with this as its name */ + + fieldPtr = addField(tkn_strt, recordPtr); + getToken(); + + /* Check for multiple fields of this */ + + 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 */ + /* 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: + * [,[,[...]]] : + */ + + 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 22b6b75b4..c44da5452 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 - * - * 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 + * + * 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 + +/*************************************************************************** + * 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 d3ccebd12..52ef49e1a 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 - * - * 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 -#include -#include - -#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 IN - * 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: [+|-] [{+|-} [{+|-} [...]]] */ - /* 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: [ [[...]]] */ - - 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 + * + * 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 +#include +#include +#include +#include + +#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 IN + * 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: [+|-] [{+|-} [{+|-} [...]]] */ + /* 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: [ [[...]]] */ + + 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 4fc83d9bf..733e85bdd 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 - * - * 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 -#include - -#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 () */ - - 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 () */ - - checkLParen(); - constantExpression(); - isOrdinalConstant(); - checkRParen(); -} - -/**********************************************************************/ - -static void constantPredFunc(void) -{ - TRACE(lstFile,"[constantPredFunc]"); - - /* FORM: PRED () */ - - checkLParen(); - constantExpression(); - isOrdinalConstant(); - constantInt--; - checkRParen(); -} - -/**********************************************************************/ - -static void constantSqrFunc(void) -{ - TRACE(lstFile,"[constantSqrFunc]"); - - /* FORM: SQR () */ - - 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: () */ - - checkLParen(); - constantExpression(); - if (constantToken == tINT_CONST) - constantReal = (float64)constantInt; - else - error(eINVARG); - - checkRParen(); -} - -/**********************************************************************/ - -static void constantSuccFunc(void) -{ - TRACE(lstFile,"[constantSuccFunc]"); - - /* FORM: SUCC () */ - - checkLParen(); - constantExpression(); - isOrdinalConstant(); - constantInt++; - checkRParen(); -} - -/***********************************************************************/ - -static void constantOddFunc(void) -{ - TRACE(lstFile,"[constantOddFunc]"); - - /* FORM: ODD () */ - - 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 + * + * 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 +#include +#include +#include + +#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 () */ + + 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 () */ + + checkLParen(); + constantExpression(); + isOrdinalConstant(); + checkRParen(); +} + +/**********************************************************************/ + +static void constantPredFunc(void) +{ + TRACE(lstFile,"[constantPredFunc]"); + + /* FORM: PRED () */ + + checkLParen(); + constantExpression(); + isOrdinalConstant(); + constantInt--; + checkRParen(); +} + +/**********************************************************************/ + +static void constantSqrFunc(void) +{ + TRACE(lstFile,"[constantSqrFunc]"); + + /* FORM: SQR () */ + + 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: () */ + + checkLParen(); + constantExpression(); + if (constantToken == tINT_CONST) + constantReal = (double)constantInt; + else + error(eINVARG); + + checkRParen(); +} + +/**********************************************************************/ + +static void constantSuccFunc(void) +{ + TRACE(lstFile,"[constantSuccFunc]"); + + /* FORM: SUCC () */ + + checkLParen(); + constantExpression(); + isOrdinalConstant(); + constantInt++; + checkRParen(); +} + +/***********************************************************************/ + +static void constantOddFunc(void) +{ + TRACE(lstFile,"[constantOddFunc]"); + + /* FORM: ODD () */ + + 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 b09afd675..3737b2588 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 - * - * 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 -#include -#include - -#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 + * + * 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 +#include +#include +#include + +#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 188eb67e8..faa179b90 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 - * - * 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 -#include - -#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 [ ] */ - /* Get the first */ - - simple1Type = simpleExpression(findExprType); - - /* Get the optional 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 IN */ - /* 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: [] */ - 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: [+|-] [{+|-} [{+|-} [...]]] */ - /* 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 - * ' +' 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: [ [[...]]] */ - - 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 -OR- the same */ - - 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 -OR- the same */ - - 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: [[[,[, ...]]]] */ - /* 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 + * + * 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 +#include +#include +#include + +#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 [ ] */ + /* Get the first */ + + simple1Type = simpleExpression(findExprType); + + /* Get the optional 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 IN */ + /* 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: [] */ + 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: [+|-] [{+|-} [{+|-} [...]]] */ + /* 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 + * ' +' 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: [ [[...]]] */ + + 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 -OR- the same */ + + 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 -OR- the same */ + + 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: [[[,[, ...]]]] */ + /* 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 dba1f1ee7..937510102 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 - * - * 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 + * + * 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 + +/*********************************************************************** + * 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 609944d19..f296af0de 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 - * - * 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 - -#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 () */ - - 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 () */ - - checkLParen(); - expression(exprAnyOrdinal, NULL); /* Get any ordinal type */ - checkRParen(); - -} /* end ordFunc */ - -/**********************************************************************/ - -static exprType predFunc(void) -{ - exprType predType; - - TRACE(lstFile,"[predFunc]"); - - /* FORM: PRED () */ - - 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 () */ - - 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: () */ - - 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 () */ - - 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 () */ - - 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 () */ - - 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: = getenv() */ - - 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 + * + * 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 +#include + +#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 () */ + + 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 () */ + + checkLParen(); + expression(exprAnyOrdinal, NULL); /* Get any ordinal type */ + checkRParen(); + +} /* end ordFunc */ + +/**********************************************************************/ + +static exprType predFunc(void) +{ + exprType predType; + + TRACE(lstFile,"[predFunc]"); + + /* FORM: PRED () */ + + 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 () */ + + 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: () */ + + 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 () */ + + 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 () */ + + 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 () */ + + 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: = getenv() */ + + 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 afb49cf39..fc108e3a6 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 - * - * 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 -#include -#include - -#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 + * + * 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 +#include +#include +#include + +#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 055e14eb3..3a6412452 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 - * - * 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 + * + * 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 +#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 d56ba7b09..e822e18a1 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 - * - * 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 -#include -#include -#include -#include - -#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 */ - 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 + * + * 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 +#include +#include +#include +#include +#include + +#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 */ + 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 fcba0cc86..e4e0e0272 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 - * - * 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 -#include - -#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 , ,... */ - - 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() */ - - 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(); - * (2) Test WRITE: WRITE([], 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 , , ... 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 + * + * 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 +#include +#include +#include + +#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 , ,... */ + + 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() */ + + 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(); + * (2) Test WRITE: WRITE([], 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 , , ... 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 ad6236839..3d6e49fa5 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 - * - * 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 - -#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: := - * 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: := */ - - 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: . := - * OR: := - */ - - /* 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: := - * 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: ^ := - * OR: := - */ - - 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: := - * OR: []^ := - * OR: [] := - * OR: []. := - * 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: := */ - - 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: := */ - - /* 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: := */ - - 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 */ - - /* Get the token after the goto reserved word. It should be an */ - - 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 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: : */ - - /* 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 THEN [ELSE ] */ - - /* 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 - * presentl. We will compare the elseLSP to the thenLSP at that point. - */ - - elseLSP = pas_GetCurrentStackLevel(); - - /* Parse the following the THEN token */ - - statement(); - - /* Save the LSP after generating the THEN . We will compare the - * elseLSP to the thenLSP below. - */ - - thenLSP = pas_GetCurrentStackLevel(); - - /* Check for optional ELSE */ - - 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 */ - - pas_GenerateDataOperation(opJMP, endif_label); - - /* Generate the ELSE label here. This is where we will go if - * the IF evaluates to FALSE. - */ - - pas_GenerateDataOperation(opLABEL, else_label); - - /* Generate the ELSE then fall through to the - * ENDIF label. - */ - - statement(); - - /* Save the LSP after generating the ELSE . We will - * compare elseLSP to the thenLSP below. - */ - - elseLSP = pas_GetCurrentStackLevel(); - } - - /* Generate the ENDIF label here. Note that if no ELSE - * 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 , (2) from the IF if no ELSE - * is present, or (3) from the ELSE . 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 UNTIL */ - - /* Generate top of loop label */ - - pas_GenerateDataOperation(opLABEL, rpt_label); - do - { - getToken(); - - /* Process */ - - statement(); - } - while (token == ';'); - - /* Verify UNTIL follows */ - - if (token != tUNTIL) error (eUNTIL); - else getToken(); - - /* Generate UNTIL */ - - 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 DO */ - - /* Skip over WHILE token */ - - getToken(); - - /* Set top of loop label */ - - pas_GenerateDataOperation(opLABEL, while_label); - - /* Evaluate the WHILE */ - - 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 . 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 logic set the LSP? */ - - if (nLspChanges == pas_GetNStackLevelChanges()) - { - /* Yes, then the value set in the WHILE - * 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 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 . */ - - sint32 caseLSP = pas_GetCurrentStackLevel(); - if (caseLSP < 0) - { - /* If the LSP is invalid after any case , 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 (or else it is invalid) - */ - - *pTerminalLSP = caseLSP; - } - else if (*pTerminalLSP != caseLSP) - { - /* The value of the LSP at the end of this case is - * different from the value of the LSP at the end of some other - * case . 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 OF" */ - - /* Skip over the CASE token */ - - getToken(); - - /* Evaluate the CASE */ - - expression(exprAnyOrdinal, NULL); - - /* Verify that CASE 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 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 . */ - - 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 */ - - if (token != tEND) error(eEND); - else getToken(); - - /* Terminate FOR loop */ - - break; - } - - /* Process "[,[,...]] : " - * 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 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 ) - * and push the comparison value (from the :) - */ - - 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 */ - - pas_GenerateDataOperation(opJEQUZ, this_case); - - /* Skip over comma */ - - getToken(); - } - else - { - /* else jump to the next case */ - - pas_GenerateDataOperation(opJNEQZ, next_case); - break; - } - } - - /* Then process ... : */ - - /* Verify colon presence */ - - if (token != ':') error(eCOLON); - else getToken(); - - /* Set CASE label */ - - pas_GenerateDataOperation(opLABEL, this_case); - - /* Evaluate */ - - statement(); - - /* Jump to exit CASE */ - - pas_GenerateDataOperation(opJMP, end_case); - - /* Check the LSP after evaluating the case . */ - - 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 from stack */ - - pas_GenerateDataOperation(opLABEL, end_case); - pas_GenerateDataOperation(opINDS, -sINT_SIZE); - - /* We may have gotten to this point from many different case . - * 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 DO */ - - /* 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 DO */ - - expression(exprInteger, varPtr->sParm.v.parent); - - /* Verify that the 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(); - - /* 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 */ - - /* 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 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 + * + * 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 +#include +#include + +#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: := + * 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: := */ + + 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: . := + * OR: := + */ + + /* 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: := + * 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: ^ := + * OR: := + */ + + 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: := + * OR: []^ := + * OR: [] := + * OR: []. := + * 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: := */ + + 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: := */ + + /* 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: := */ + + 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 */ + + /* Get the token after the goto reserved word. It should be an */ + + 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 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: : */ + + /* 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 THEN [ELSE ] */ + + /* 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 + * presentl. We will compare the elseLSP to the thenLSP at that point. + */ + + elseLSP = pas_GetCurrentStackLevel(); + + /* Parse the following the THEN token */ + + statement(); + + /* Save the LSP after generating the THEN . We will compare the + * elseLSP to the thenLSP below. + */ + + thenLSP = pas_GetCurrentStackLevel(); + + /* Check for optional ELSE */ + + 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 */ + + pas_GenerateDataOperation(opJMP, endif_label); + + /* Generate the ELSE label here. This is where we will go if + * the IF evaluates to false. + */ + + pas_GenerateDataOperation(opLABEL, else_label); + + /* Generate the ELSE then fall through to the + * ENDIF label. + */ + + statement(); + + /* Save the LSP after generating the ELSE . We will + * compare elseLSP to the thenLSP below. + */ + + elseLSP = pas_GetCurrentStackLevel(); + } + + /* Generate the ENDIF label here. Note that if no ELSE + * 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 , (2) from the IF if no ELSE + * is present, or (3) from the ELSE . 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 UNTIL */ + + /* Generate top of loop label */ + + pas_GenerateDataOperation(opLABEL, rpt_label); + do + { + getToken(); + + /* Process */ + + statement(); + } + while (token == ';'); + + /* Verify UNTIL follows */ + + if (token != tUNTIL) error (eUNTIL); + else getToken(); + + /* Generate UNTIL */ + + 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 DO */ + + /* Skip over WHILE token */ + + getToken(); + + /* Set top of loop label */ + + pas_GenerateDataOperation(opLABEL, while_label); + + /* Evaluate the WHILE */ + + 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 . 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 logic set the LSP? */ + + if (nLspChanges == pas_GetNStackLevelChanges()) + { + /* Yes, then the value set in the WHILE + * 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 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 . */ + + int32_t caseLSP = pas_GetCurrentStackLevel(); + if (caseLSP < 0) + { + /* If the LSP is invalid after any case , 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 (or else it is invalid) + */ + + *pTerminalLSP = caseLSP; + } + else if (*pTerminalLSP != caseLSP) + { + /* The value of the LSP at the end of this case is + * different from the value of the LSP at the end of some other + * case . 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 OF" */ + + /* Skip over the CASE token */ + + getToken(); + + /* Evaluate the CASE */ + + expression(exprAnyOrdinal, NULL); + + /* Verify that CASE 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 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 . */ + + 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 */ + + if (token != tEND) error(eEND); + else getToken(); + + /* Terminate FOR loop */ + + break; + } + + /* Process "[,[,...]] : " + * 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 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 ) + * and push the comparison value (from the :) + */ + + 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 */ + + pas_GenerateDataOperation(opJEQUZ, this_case); + + /* Skip over comma */ + + getToken(); + } + else + { + /* else jump to the next case */ + + pas_GenerateDataOperation(opJNEQZ, next_case); + break; + } + } + + /* Then process ... : */ + + /* Verify colon presence */ + + if (token != ':') error(eCOLON); + else getToken(); + + /* Set CASE label */ + + pas_GenerateDataOperation(opLABEL, this_case); + + /* Evaluate */ + + statement(); + + /* Jump to exit CASE */ + + pas_GenerateDataOperation(opJMP, end_case); + + /* Check the LSP after evaluating the case . */ + + 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 from stack */ + + pas_GenerateDataOperation(opLABEL, end_case); + pas_GenerateDataOperation(opINDS, -sINT_SIZE); + + /* We may have gotten to this point from many different case . + * 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 DO */ + + /* 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 DO */ + + expression(exprInteger, varPtr->sParm.v.parent); + + /* Verify that the 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(); + + /* 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 */ + + /* 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 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 528c5482f..dea2bcfd3 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 - * - * 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 -#include -#include - -#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 + * + * 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 +#include +#include +#include +#include + +#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 70d318846..14e368e1b 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 - * - * 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 + * + * 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 +#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 bad5bac28..615fcc3a9 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 - * - * 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 -#include -#include - -#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 + * + * 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 +#include +#include + +#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 d30333e0c..da6425047 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 - * - * 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 + * + * 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 +#include + +/*************************************************************************** + * 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 b24ba45c6..00a21d9ea 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 * * Redistribution and use in source and binary forms, with or without @@ -38,6 +38,7 @@ * Included Files **********************************************************************/ +#include #include #include #include @@ -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 22b5af45d..d304c49ad 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 - * - * 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 -#include -#include -#include - -#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 {} \n", - progname); -} - -/***********************************************************************/ - -static void parseArgs(int argc, char **argv) -{ - int i; - - /* Check for existence of filename argument */ - - if (argc < 3) - { - fprintf(stderr, - "ERROR: and one 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 + * + * 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 +#include +#include +#include +#include +#include + +#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 {} \n", + progname); +} + +/***********************************************************************/ + +static void parseArgs(int argc, char **argv) +{ + int i; + + /* Check for existence of filename argument */ + + if (argc < 3) + { + fprintf(stderr, + "ERROR: and one 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 32911570c..0faf0715c 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 * * Redistribution and use in source and binary forms, with or without @@ -38,6 +38,7 @@ * Included Files **********************************************************************/ +#include #include #include #include @@ -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 1998361b9..d8dd89476 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 - * - * 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 + * + * 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 +#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 1ef40461a..ceeb0c4f7 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 * * Redistribution and use in source and binary forms, with or without @@ -38,6 +38,7 @@ * Included Files **********************************************************************/ +#include #include #include #include @@ -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 96f520148..69218830f 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 - * - * 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 + * + * 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 +#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 */ -- cgit v1.2.3