path: root/misc/pascal/pascal/pffunc.c

/***************************************************************
 * pfunc.c
 * Standard Functions
 *
 *   Copyright (C) 2008-2009 Gregory Nutt. All rights reserved.
 *   Author: Gregory Nutt <gnutt@nuttx.org>
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in
 *    the documentation and/or other materials provided with the
 *    distribution.
 * 3. Neither the name NuttX nor the names of its contributors may be
 *    used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
 * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
 * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
 * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *
 ***************************************************************/

/***************************************************************
 * Included Files
 ***************************************************************/

#include <stdint.h>
#include <stdio.h>

#include "keywords.h"
#include "pasdefs.h"
#include "ptdefs.h"
#include "podefs.h"
#include "pfdefs.h"
#include "pedefs.h"
#include "pxdefs.h"

#include "pas.h"
#include "pexpr.h"
#include "pfunc.h"
#include "pgen.h"  /* for pas_Generate*() */
#include "ptkn.h"
#include "pinsn.h"
#include "perr.h"

/***************************************************************
 * Private Function Prototypes
 ***************************************************************/

/* Standard Pascal Functions */

static exprType absFunc    (void);    /* Integer absolute value */
static exprType predFunc   (void);
static void     ordFunc    (void);    /* Convert scalar to integer */
static exprType sqrFunc    (void);
static void     realFunc   (uint8_t fpCode);
static exprType succFunc   (void);
static void     oddFunc    (void);
static void     chrFunc    (void);
static void     fileFunc   (uint16_t opcode);

/* Enhanced Pascal functions */

/* Non-standard C-library interface functions */

static exprType getenvFunc (void);    /* Get environment string value */

/***************************************************************
 * Public Functions
 ***************************************************************/

void primeBuiltInFunctions(void)
{
}

/***************************************************************/
/* Process a standard Pascal function call */

exprType builtInFunction(void)
{
  exprType funcType = exprUnknown;

  TRACE(lstFile,"[builtInFunction]");

  /* Is the token a function? */

  if (token == tFUNC)
    {
      /* Yes, process it procedure according to the extended token type */

      switch (tknSubType)
        {
          /* Functions which return the same type as their argument */
        case txABS :
          funcType = absFunc();
          break;
        case txSQR :
          funcType = sqrFunc();
          break;
        case txPRED :
          funcType = predFunc();
          break;
        case txSUCC :
          funcType = succFunc();
          break;

        case txGETENV : /* Non-standard C library interfaces */
          funcType = getenvFunc();
          break;

          /* Functions returning INTEGER with REAL arguments */

        case txROUND :
          getToken();                          /* Skip over 'round' */
          expression(exprReal, NULL);
          pas_GenerateFpOperation(fpROUND);
          funcType = exprInteger;
          break;
        case txTRUNC :
          getToken();                          /* Skip over 'trunc' */
          expression(exprReal, NULL);
          pas_GenerateFpOperation(fpTRUNC);
          funcType = exprInteger;
          break;

          /* Functions returning CHARACTER with INTEGER arguments. */

        case txCHR :
          chrFunc();
          funcType = exprChar;
          break;

          /* Function returning integer with scalar arguments */

        case txORD :
          ordFunc();
          funcType = exprInteger;
          break;

          /* Functions returning BOOLEAN */
        case txODD :
          oddFunc();
          funcType = exprBoolean;
          break;
        case txEOF :
          fileFunc(xEOF);
          funcType = exprBoolean;
          break;
        case txEOLN :
          fileFunc(xEOLN);
          funcType = exprBoolean;
          break;

          /* Functions returning REAL with REAL/INTEGER arguments */

        case txSQRT :
          realFunc(fpSQRT);
          funcType = exprReal;
          break;
        case txSIN :
          realFunc(fpSIN);
          funcType = exprReal;
          break;
        case txCOS :
          realFunc(fpCOS);
          funcType = exprReal;
          break;
        case txARCTAN :
          realFunc(fpATAN);
          funcType = exprReal;
          break;
        case txLN :
          realFunc(fpLN);
          funcType = exprReal;
          break;
        case txEXP :
          realFunc(fpEXP);
          funcType = exprReal;
          break;

        default :
          error(eINVALIDPROC);
          break;
        } /* end switch */
    } /* end if */

  return funcType;

} /* end builtInFunction */

void checkLParen(void)
{
   getToken();                          /* Skip over function name */
   if (token != '(') error(eLPAREN);    /* Check for '(' */
   else getToken();
}

void checkRParen(void)
{
   if (token != ')') error(eRPAREN);    /* Check for ')') */
   else getToken();
}

/***************************************************************
 * Private Functions
 ***************************************************************/

static exprType absFunc(void)
{
   exprType absType;

   TRACE(lstFile,"[absFunc]");

   /* FORM:  ABS (<simple integer/real expression>) */

   checkLParen();

   absType = expression(exprUnknown, NULL);
   if (absType == exprInteger)
      pas_GenerateSimple(opABS);
   else if (absType == exprReal)
      pas_GenerateFpOperation(fpABS);
   else
      error(eINVARG);

   checkRParen();
   return absType;

} /* end absFunc */

/**********************************************************************/

static void ordFunc(void)
{
   TRACE(lstFile,"[ordFunc]");

   /* FORM:  ORD (<scalar type>) */

   checkLParen();
   expression(exprAnyOrdinal, NULL);     /* Get any ordinal type */
   checkRParen();

} /* end ordFunc */

/**********************************************************************/

static exprType predFunc(void)
{
   exprType predType;

   TRACE(lstFile,"[predFunc]");

   /* FORM:  PRED (<simple integer expression>) */

   checkLParen();

   /* Process any ordinal expression */

   predType = expression(exprAnyOrdinal, NULL);
   checkRParen();
   pas_GenerateSimple(opDEC);
   return predType;

} /* end predFunc */

/**********************************************************************/

static exprType sqrFunc(void)
{
   exprType sqrType;

   TRACE(lstFile,"[sqrFunc]");

/* FORM:  SQR (<simple integer OR real expression>) */

   checkLParen();

   sqrType = expression(exprUnknown, NULL); /* Process any expression */
   if (sqrType == exprInteger) {

     pas_GenerateSimple(opDUP);
     pas_GenerateSimple(opMUL);

   } /* end if */
   else if (sqrType == exprReal)
     pas_GenerateFpOperation(fpSQR);

   else
     error(eINVARG);

   checkRParen();
   return sqrType;

} /* end sqrFunc */

/**********************************************************************/
static void realFunc (uint8_t fpOpCode)
{
   exprType realType;

   TRACE(lstFile,"[realFunc]");

   /* FORM:  <function identifier> (<real/integer expression>) */

   checkLParen();

   realType = expression(exprUnknown, NULL); /* Process any expression */
   if (realType == exprInteger)
     pas_GenerateFpOperation((fpOpCode | fpARG1));
   else if (realType == exprReal)
     pas_GenerateFpOperation(fpOpCode);
   else
     error(eINVARG);

   checkRParen();

} /* end realFunc */

/**********************************************************************/

static exprType succFunc(void)
{
   exprType succType;

   TRACE(lstFile,"[succFunc]");

   /* FORM:  SUCC (<simple integer expression>) */

   checkLParen();

   /* Process any ordinal expression */

   succType = expression(exprAnyOrdinal, NULL);

   checkRParen();
   pas_GenerateSimple(opINC);
   return succType;

} /* end succFunc */

/***********************************************************************/

static void oddFunc(void)
{
   TRACE(lstFile,"[oddFunc]");

   /* FORM:  ODD (<simple integer expression>) */

   checkLParen();

   /* Process any ordinal expression */

   expression(exprAnyOrdinal, NULL);
   checkRParen();
   pas_GenerateDataOperation(opPUSH, 1);
   pas_GenerateSimple(opAND);
   pas_GenerateSimple(opNEQZ);

} /* end oddFunc */

/***********************************************************************/
/* Process the standard chr function */

static void chrFunc(void)
{
   TRACE(lstFile,"[charFactor]");

   /* Form:  chr(integer expression).
    *
    * char(val) is only defined if there exists a character ch such
    * that ord(ch) = val.  If this is not the case, we will simply
    * let the returned value exceed the range of type char. */

   checkLParen();
   expression(exprInteger, NULL);
   checkRParen();

} /* end chrFunc */

/****************************************************************************/
/* EOF/EOLN function */

static void fileFunc(uint16_t opcode)
{
   TRACE(lstFile,"[fileFunc]");

   /* FORM: EOF|EOLN (<file number>) */

   checkLParen();
   if (token !=  sFILE)
     {
       error(eFILE);
     }
   else
     {
       pas_GenerateDataOperation(opINDS, sBOOLEAN_SIZE);
       pas_GenerateIoOperation(opcode, tknPtr->sParm.fileNumber);
       getToken();
       checkRParen();
     } /* end else */

} /* end fileFunc */

/**********************************************************************/
/* C library getenv interface */

static exprType getenvFunc(void)
{
  exprType stringType;

  TRACE(lstFile, "[getenvFunc]");

  /* FORM:  <string_var> = getenv(<string>) */

  checkLParen();

  /* Get the string expression representing the environment variable
   * name.
   */

  stringType = expression(exprString, NULL);

  /* Two possible kinds of strings could be returned.
   * Anything else other then 'exprString' would be an error (but
   * should happen).
   */

  if ((stringType != exprString) && (stringType != exprStkString))
    {
      error(eINVARG);
    }

  pas_BuiltInFunctionCall(lbGETENV);
  checkRParen();
  return exprCString;
}

/***********************************************************************/