diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
6cc04e235b
yap-6.3/C/scanner.c
vsc 71c18ef912 new predicates atom_concat and list_concat 
prolog_flag(version,X).
0'\ escape sequences
first try at profiling early reset (garbage collector is broken now).


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@9 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2001-04-17 21:07:41 +00:00

1561 lines
35 KiB
C
Raw Blame History

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: %W% %G% *
* Last rev: *
* mods: *
* comments: Prolog's scanner *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "@(#)scanner.c 1.2";
#endif
/*
* Description:
*
* This module produces a list of tokens for use by the parser. The calling
* program should supply a routine int nextch(charpos) int *charpos; which,
* when called should produce the next char or -1 if none availlable. The
* scanner will stop producing tokens when it either finds an end of file
* (-1) or a token consisting of just '.' followed by a blank or control
* char. Scanner errors will be signalled by the scanner exiting with a non-
* zero ErrorMsg and ErrorPos. Note that, even in this case, the scanner
* will try to find the end of the term. A function char
* *AllocScannerMemory(nbytes) should be supplied for allocating (temporary)
* space for strings and for the table of prolog variables occurring in the
* term.
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#include "alloc.h"
#include "eval.h"
#if HAVE_STRING_H
#include <string.h>
#endif
/* You just can't trust some machines */
#define my_isxdigit(C,SU,SL) (chtype[C] == NU || (C >= 'A' && \
C <= (SU)) || (C >= 'a' && C <= (SL)))
#define my_isupper(C) ( C >= 'A' && C <= 'Z' )
#ifndef INFINITY
#define INFINITY (1.0/0.0)
#endif
#ifndef NAN
#define NAN (0.0/0.0)
#endif
STATIC_PROTO(void my_ungetch, (void));
STATIC_PROTO(int my_getch, (void));
STATIC_PROTO(Term float_send, (char *));
STATIC_PROTO(Term get_num, (void));
STATIC_PROTO(enum TokenKinds token, (void));
/* token table with some help from Richard O'Keefe's PD scanner */
static char chtype0[NUMBER_OF_CHARS+1] =
{
EF,
/* nul soh stx etx eot enq ack bel bs ht nl vt np cr so si */
BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS,
/* dle dc1 dc2 dc3 dc4 nak syn etb can em sub esc fs gs rs us */
BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS,
/* sp ! " # $ % & ' ( ) * + , - . / */
BS, SL, DC, SY, LC, CC, SY, QT, BK, BK, SY, SY, BK, SY, SY, SY,
/* 0 1 2 3 4 5 6 7 8 9 : ; < = > ? */
NU, NU, NU, NU, NU, NU, NU, NU, NU, NU, SY, SL, SY, SY, SY, SY,
/* @ A B C D E F G H I J K L M N O */
SY, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC,
/* P Q R S T U V W X Y Z [ \ ] ^ _ */
UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, BK, SY, BK, SY, UL,
/* ` a b c d e f g h i j k l m n o */
SY, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC,
/* p q r s t u v w x y z { | } ~ del */
LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, BK, BK, BK, SY, BS,
/* 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 */
BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS,
/* 144 145 <20> 147 148 149 150 151 152 153 154 155 156 157 158 159 */
BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS, BS,
/* <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> */
BS, SY, SY, SY, SY, SY, SY, SY, SY, SY, LC, SY, SY, SY, SY, SY,
/* <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> */
SY, SY, LC, LC, SY, SY, SY, SY, SY, LC, LC, SY, SY, SY, SY, SY,
/* <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> */
UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC,
/* <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> */
#ifdef vms
UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, LC,
#else
UC, UC, UC, UC, UC, UC, UC, SY, UC, UC, UC, UC, UC, UC, UC, LC,
#endif
/* <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> */
LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC,
/* <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> */
#ifdef vms
LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC
#else
LC, LC, LC, LC, LC, LC, LC, SY, LC, LC, LC, LC, LC, LC, LC, LC
#endif
};
char *chtype = chtype0+1;
int eot_before_eof = FALSE;
static int ch, chbuff, o_ch;
static char *TokImage;
static int BUF = FALSE;
static Int TokenPos;
static CELL TokenInfo;
static int (*Nextch) (int);
static int (*QuotedNextch) (int);
char *
AllocScannerMemory(unsigned int size)
{
char *AuxSpScan;
AuxSpScan = (char *)TR;
size = AdjustSize(size);
TR = (tr_fr_ptr)(AuxSpScan+size);
#if !OS_HANDLES_TR_OVERFLOW
if (Unsigned(TrailTop) == Unsigned(TR)) {
if(!growtrail (sizeof(CELL) * 16 * 1024L)) {
return(NULL);
}
}
#endif
return (AuxSpScan);
}
inline static void
my_ungetch(void)
{
chbuff = ch;
ch = o_ch;
BUF = TRUE;
}
inline static int
my_getch(void)
{
o_ch = ch;
if (BUF) {
BUF = FALSE;
ch = chbuff;
}
else {
ch = (*Nextch) (c_input_stream);
}
#ifdef DEBUG
if (Option[1])
YP_fprintf(YP_stderr, "[getch %c]", ch);
#endif
return(ch);
}
inline static int
my_get_quoted_ch(void)
{
o_ch = ch;
if (BUF) {
BUF = FALSE;
ch = chbuff;
}
else {
ch = (*QuotedNextch) (c_input_stream);
}
#ifdef DEBUG
if (Option[1])
YP_fprintf(YP_stderr, "[getch %c]",ch);
#endif
return (ch);
}
extern double atof(const char *);
static Term
float_send(char *s)
{
Float f = (Float)atof(s);
#if HAVE_FINITE
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
if (!finite(f)) {
ErrorMessage = "Float overflow while scanning";
return(MkEvalFl(0.0));
}
}
#endif
return (MkEvalFl(f));
}
/* we have an overflow at s */
static Term
read_int_overflow(const char *s, Int base)
{
#ifdef USE_GMP
/* try to scan it as a bignum */
MP_INT *new = PreAllocBigNum();
mpz_init_set_str (new, s, base);
return(MkBigIntTerm(new));
#else
/* try to scan it as a float */
return(float_send((char *)s));
#endif
}
/* reads a number, either integer or float */
static Term
get_num(void)
{
char *s = (char *)TR, *sp = s;
Int val = 0, base = ch - '0';
int might_be_float = TRUE, has_overflow = FALSE;
*sp++ = ch;
my_getch();
/*
* because of things like 00'2, 03'2 and even better 12'2, I need to
* do this (have mercy)
*/
if (chtype[ch] == NU) {
*sp++ = ch;
base = 10 * base + ch - '0';
my_getch();
}
if (ch == '\'') {
if (base > 36) {
ErrorMessage = "Admissible bases are 0..36";
return (TermNil);
}
might_be_float = FALSE;
*sp++ = ch;
my_getch();
if (base == 0) {
Int ascii = ch;
if (ch == '\\' &&
yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) {
/* escape sequence */
ch = my_get_quoted_ch();
switch (ch) {
case 'a':
ascii = '\a';
break;
case 'b':
ascii = '\b';
break;
case 'r':
ascii = '\r';
break;
case 'f':
ascii = '\f';
break;
case 't':
ascii = '\t';
break;
case 'n':
ascii = '\n';
break;
case 'v':
ascii = '\v';
break;
case '\\':
ascii = '\\';
break;
case '\'':
ascii = '\'';
break;
case '"':
ascii = '"';
break;
case '`':
ascii = '`';
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
/* character in octal: maximum of 3 digits, terminates with \ */
{
unsigned char so_far = ch-'0';
my_get_quoted_ch();
if (ch >= '0' && ch < '8') {/* octal */
so_far = so_far*8+(ch-'0');
my_get_quoted_ch();
if (ch >= '0' && ch < '8') { /* octal */
ascii = so_far*8+(ch-'0');
my_get_quoted_ch();
if (ch != '\\') {
ErrorMessage = "invalid octal escape sequence";
}
} else if (ch == '\\') {
ascii = so_far;
} else {
ErrorMessage = "invalid octal escape sequence";
}
} else if (ch == '\\') {
ascii = so_far;
} else {
ErrorMessage = "invalid octal escape sequence";
}
}
break;
case 'x':
/* hexadecimal character (YAP allows empty hexadecimal */
{
unsigned char so_far = 0;
my_get_quoted_ch();
if (my_isxdigit(ch,'f','F')) {/* hexa */
so_far = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
my_get_quoted_ch();
if (my_isxdigit(ch,'f','F')) { /* hexa */
ascii = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
my_get_quoted_ch();
if (ch != '\\') {
ErrorMessage = "invalid hexadecimal escape sequence";
}
} else if (ch == '\\') {
ascii = so_far;
} else {
ErrorMessage = "invalid hexadecimal escape sequence";
}
} else if (ch == '\\') {
ascii = so_far;
my_get_quoted_ch();
}
}
break;
default:
/* accept sequence. Note that the ISO standard does not
consider this sequence legal, whereas SICStus would
eat up the escape sequence. */
ErrorMessage = "invalid escape sequence";
}
}
/* a quick way to represent ASCII */
my_getch();
return (MkIntTerm(ascii));
}
else if (base >= 10 && base <= 36) {
int upper_case = 'A' - 11 + base;
int lower_case = 'a' - 11 + base;
while (my_isxdigit(ch, upper_case, lower_case)) {
Int oval = val;
*sp++ = ch;
val = val * base + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
if (oval >= val && oval != 0) /* overflow */
has_overflow = (has_overflow || TRUE);
my_getch();
}
}
}
else if ((ch == 'x' || ch == 'X') && base == 0) {
might_be_float = FALSE;
*sp++ = ch;
my_getch();
while (my_isxdigit(ch, 'F', 'f')) {
Int oval = val;
*sp++ = ch;
val = val * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
if (oval >= val && oval != 0) /* overflow */
has_overflow = (has_overflow || TRUE);
my_getch();
}
}
else if ((ch == 'o') && base == 0) {
might_be_float = FALSE;
base = 8;
*sp++ = ch;
my_getch();
}
else {
val = base;
base = 10;
}
while (chtype[ch] == NU) {
Int oval = val;
*sp++ = ch;
if (ch - '0' >= base)
return (MkIntegerTerm(val));
val = val * base + ch - '0';
if (oval >= val && oval != 0) /* overflow */
has_overflow = (has_overflow || TRUE);
my_getch();
}
if (might_be_float && (ch == '.' || ch == 'e' || ch == 'E')) {
if (ch == '.') {
*sp++ = '.';
if (chtype[my_getch()] != NU) {
my_ungetch();
*--sp = '\0';
if (has_overflow)
return(read_int_overflow(s,base));
return (MkIntegerTerm(val));
}
do
*sp++ = ch;
while (chtype[my_getch()] == NU);
}
if (ch == 'e' || ch == 'E') {
*sp++ = 'e';
my_getch();
if (ch == '-') {
*sp++ = ch;
my_getch();
}
else if (ch == '+')
my_getch();
if (chtype[ch] != NU) {
my_ungetch();
*--sp = '\0';
return (float_send(s));
}
do
*sp++ = ch;
while (chtype[my_getch()] == NU);
}
*sp = '\0';
return (float_send(s));
} else if (has_overflow) {
*sp = '\0';
/* skip base */
if (s[0] == '0' && (s[1] == 'x' || s[1] == 'X'))
return(read_int_overflow(s+2,16));
if (s[1] == '\'')
return(read_int_overflow(s+2,base));
if (s[2] == '\'')
return(read_int_overflow(s+3,base));
return(read_int_overflow(s,base));
} else
return (MkIntegerTerm(val));
}
/* given a function Nxtch scan until we either find the number
or end of file */
Term
scan_num(int (*Nxtch) (int))
{
Term out;
int sign = 1;
Nextch = Nxtch;
ErrorMessage = NULL;
ch = Nextch(c_input_stream);
if (ch == '-') {
sign = -1;
ch = Nextch(c_input_stream);
} else if (ch == '+') {
ch = Nextch(c_input_stream);
}
if (chtype[ch] != NU) {
return(TermNil);
}
out = get_num();
if (sign == -1) {
if (IsIntegerTerm(out))
out = MkIntegerTerm(-IntegerOfTerm(out));
else if (IsFloatTerm(out))
out = MkFloatTerm(-FloatOfTerm(out));
}
if (ErrorMessage != NULL || ch != -1)
return(TermNil);
return(out);
}
/* gets a token */
static enum TokenKinds
token(void)
{
int och, quote, isvar;
char *charp, *mp;
unsigned int len;
TokImage = ((AtomEntry *) ( PreAllocCodeSpace()))->StrOfAE;
charp = TokImage;
while (chtype[ch] == BS)
my_getch();
#ifdef EMACS
TokenPos = GetCurInpPos();
#endif
switch (chtype[ch]) {
case CC:
while (my_getch() != 10 && chtype[ch] != EF);
if (chtype[ch] != EF) {
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (token());
} else {
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (eot_tok);
}
case UC:
case UL:
case LC:
isvar = (chtype[ch] != LC);
*charp++ = ch;
for (my_getch(); chtype[ch] <= NU; my_getch())
*charp++ = ch;
*charp++ = '\0';
if (!isvar) {
/* don't do this in iso */
TokenInfo = Unsigned(LookupAtom(TokImage));
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (Name_tok);
}
else {
TokenInfo = Unsigned(LookupVar(TokImage));
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (Var_tok);
}
case NU:
TokenInfo = get_num();
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (Number_tok);
case QT:
case DC:
quote = ch;
len = 0;
my_get_quoted_ch();
while (1) {
if (charp + 1024 > (char *)AuxSp) {
ErrorMessage = "Heap Overflow While Scanning: please increase heap";
break;
}
if (ch == quote) {
my_get_quoted_ch();
if (ch != quote)
break;
*charp++ = ch;
my_get_quoted_ch();
} else if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) {
/* escape sequence */
ch = my_get_quoted_ch();
switch (ch) {
case 'a':
*charp++ = '\a';
my_get_quoted_ch();
break;
case 'b':
*charp++ = '\b';
my_get_quoted_ch();
break;
case 'r':
*charp++ = '\r';
my_get_quoted_ch();
break;
case 'f':
*charp++ = '\f';
my_get_quoted_ch();
break;
case 't':
*charp++ = '\t';
my_get_quoted_ch();
break;
case 'n':
*charp++ = '\n';
my_get_quoted_ch();
break;
case 'v':
*charp++ = '\v';
my_get_quoted_ch();
break;
case '\\':
*charp++ = '\\';
my_get_quoted_ch();
break;
case '\'':
*charp++ = '\'';
my_get_quoted_ch();
break;
case '"':
*charp++ = '"';
my_get_quoted_ch();
break;
case '`':
*charp++ = '`';
my_get_quoted_ch();
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
/* character in octal: maximum of 3 digits, terminates with \ */
{
unsigned char so_far = ch-'0';
my_get_quoted_ch();
if (ch >= '0' && ch < '8') {/* octal */
so_far = so_far*8+(ch-'0');
my_get_quoted_ch();
if (ch >= '0' && ch < '8') { /* octal */
*charp++ = so_far*8+(ch-'0');
my_get_quoted_ch();
if (ch != '\\') {
ErrorMessage = "invalid octal escape sequence";
} else {
my_get_quoted_ch();
}
} else if (ch == '\\') {
*charp++ = so_far;
my_get_quoted_ch();
} else {
ErrorMessage = "invalid octal escape sequence";
}
} else if (ch == '\\') {
*charp++ = so_far;
my_get_quoted_ch();
} else {
ErrorMessage = "invalid octal escape sequence";
}
}
break;
case 'x':
/* hexadecimal character (YAP allows empty hexadecimal */
{
unsigned char so_far = 0;
my_get_quoted_ch();
if (my_isxdigit(ch,'f','F')) {/* hexa */
so_far = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
my_get_quoted_ch();
if (my_isxdigit(ch,'f','F')) { /* hexa */
*charp++ = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
my_get_quoted_ch();
if (ch != '\\') {
ErrorMessage = "invalid hexadecimal escape sequence";
} else {
my_get_quoted_ch();
}
} else if (ch == '\\') {
*charp++ = so_far;
my_get_quoted_ch();
} else {
ErrorMessage = "invalid hexadecimal escape sequence";
}
} else if (ch == '\\') {
*charp++ = so_far;
my_get_quoted_ch();
} else {
ErrorMessage = "invalid hexadecimal escape sequence";
}
}
break;
default:
/* accept sequence. Note that the ISO standard does not
consider this sequence legal, whereas SICStus would
eat up the escape sequence. */
ErrorMessage = "invalid escape sequence";
}
} else {
*charp++ = ch;
my_get_quoted_ch();
}
++len;
if (charp > (char *)AuxSp - 1024) {
/* Not enough space to read in the string. */
ErrorMessage = "not enough heap space to read in string or quoted atom";
/* serious error now */
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return(eot_tok);
}
}
*charp = '\0';
if (quote == '"') {
mp = AllocScannerMemory(len + 1);
if (mp == NULL) {
ErrorMessage = "not enough stack space to read in string or quoted atom";
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return(eot_tok);
}
strcpy(mp, TokImage);
TokenInfo = Unsigned(mp);
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (String_tok);
}
else {
TokenInfo = Unsigned(LookupAtom(TokImage));
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (Name_tok);
}
case SY:
och = ch;
my_getch();
if (och == '/' && ch == '*') {
while ((och != '*' || ch != '/') && chtype[ch] != EF) {
och = ch;
my_getch();
}
if (chtype[ch] == EF) {
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (eot_tok);
}
my_getch();
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (token());
}
if (och == '.' && (chtype[ch] == BS || chtype[ch] == EF
|| chtype[ch] == CC)) {
eot_before_eof = TRUE;
if (chtype[ch] == CC)
while (my_getch() != 10 && chtype[ch] != EF);
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (eot_tok);
}
else {
*charp++ = och;
for (; chtype[ch] == SY; my_getch())
*charp++ = ch;
*charp = '\0';
TokenInfo = Unsigned(LookupAtom(TokImage));
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (Name_tok);
}
case SL:
*charp++ = ch;
*charp++ = '\0';
my_getch();
TokenInfo = Unsigned(LookupAtom(TokImage));
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (Name_tok);
case BK:
och = ch;
do {
my_getch();
} while (chtype[ch] == BS);
if (och == '[' && ch == ']') {
TokenInfo = Unsigned(AtomNil);
my_getch();
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (Name_tok);
}
else {
TokenInfo = och;
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (Ponctuation_tok);
}
case EF:
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (eot_tok);
#ifdef DEBUG
default:
YP_fprintf(YP_stderr, "\n++++ token: wrong char type %c %d\n", ch, chtype[ch]);
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (eot_tok);
#else
default:
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return (eot_tok); /* Just to make lint happy */
#endif
}
}
TokEntry *
tokenizer(int (*Nxtch) (int), int (*QuotedNxtch) (int))
{
TokEntry *t, *l, *p;
enum TokenKinds kind;
int solo_flag = TRUE;
ErrorMessage = NULL;
VarTable = NULL;
AnonVarTable = NULL;
Nextch = Nxtch;
QuotedNextch = QuotedNxtch;
eot_before_eof = FALSE;
l = NIL;
p = NIL; /* Just to make lint happy */
ch = ' ';
my_getch();
while (chtype[ch] == BS)
my_getch();
FirstLineInParse();
do {
t = (TokEntry *) AllocScannerMemory(sizeof(TokEntry));
if (t == NULL) {
ErrorMessage = "not enough stack space to read in term";
if (p != NIL)
p->TokInfo = eot_tok;
/* serious error now */
return(l);
}
if (l == NIL)
l = t;
else
p->TokNext = t;
p = t;
if ((kind = token()) == Name_tok && ch == '(')
solo_flag = FALSE;
else if (kind == Ponctuation_tok && TokenInfo == '(' && !solo_flag) {
TokenInfo = 'l';
solo_flag = TRUE;
}
t->Tok = Ord(kind);
#ifdef DEBUG
if(Option[2]) YP_fprintf(YP_stderr,"[Token %d %ld]",Ord(kind),(unsigned long int)TokenInfo);
#endif
t->TokInfo = (Term) TokenInfo;
t->TokPos = TokenPos;
t->TokNext = NIL;
} while (kind != eot_tok);
return (l);
}
extern int PlFGetchar(void);
#if DEBUG
static inline int
debug_fgetch(void)
{
int ch = PlFGetchar();
if (Option[1])
YP_fprintf(YP_stderr, "[getch %c,%d]", ch,ch);
return (ch);
}
#define my_fgetch() (ch = debug_fgetch())
#else
#define my_fgetch() (ch = PlFGetchar())
#endif
TokEntry *
fast_tokenizer(void)
{
/* I hope, a compressed version of the last
* three files */
TokEntry *t, *l, *p;
enum TokenKinds kind;
register int ch, och;
int solo_flag = TRUE;
ErrorMessage = NULL;
VarTable = NULL;
AnonVarTable = NULL;
eot_before_eof = FALSE;
l = NIL;
p = NIL; /* Just to make lint happy */
my_fgetch();
while (chtype[ch] == BS)
my_fgetch();
if (chtype[ch] == EF)
return(NIL);
FirstLineInParse();
do {
t = (TokEntry *) AllocScannerMemory(sizeof(TokEntry));
if (t == NULL) {
ErrorMessage = "not enough stack space to read in term";
if (p != NIL)
p->TokInfo = eot_tok;
/* serious error now */
return(l);
}
if (l == NIL)
l = t;
else
p->TokNext = t;
p = t;
/* old code for token() */
{
int quote, isvar;
char *charp, *mp;
unsigned int len;
get_tok:
charp = TokImage = ((AtomEntry *) ( PreAllocCodeSpace()))->StrOfAE;
while (chtype[ch] == BS)
my_fgetch();
#ifdef EMACS
TokenPos = GetCurInpPos();
#endif
switch (chtype[ch]) {
case CC:
while (my_fgetch() != 10 && chtype[ch] != EF);
if (chtype[ch] != EF) {
my_fgetch();
if (t == l)
FirstLineInParse();
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
goto get_tok;
}
else
kind = eot_tok;
break;
case UC:
case UL:
case LC:
isvar = (chtype[ch] != LC);
*charp++ = ch;
inside_letters:
for (my_fgetch(); chtype[ch] <= NU; my_fgetch())
*charp++ = ch;
*charp++ = '\0';
if (!isvar) {
TokenInfo = Unsigned(LookupAtom(TokImage));
if (ch == '(')
solo_flag = FALSE;
kind = Name_tok;
}
else {
TokenInfo = Unsigned(LookupVar(TokImage));
kind = Var_tok;
}
break;
case NU:
{
char *sp = TokImage;
Int val = 0, base = ch - '0';
int might_be_float = TRUE, has_overflow = FALSE;
*sp++ = ch;
my_fgetch();
/*
* because of things like 00'2, 03'2
* and even better 12'2, I need to do
* this (have mercy)
*/
if (chtype[ch] == NU) {
*sp++ = ch;
base = 10 * base + ch - '0';
my_fgetch();
}
if (ch == '\'') {
might_be_float = FALSE;
*sp++ = ch;
my_fgetch();
if (base == 0) {
Int ascii = ch;
/*
* a quick way to
* represent ASCII
*/
if (ch == '\\' &&
yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) {
/* escape sequence */
ch = my_fgetch();
switch (ch) {
case 'a':
ascii = '\a';
break;
case 'b':
ascii = '\b';
break;
case 'r':
ascii = '\r';
break;
case 'f':
ascii = '\f';
break;
case 't':
ascii = '\t';
break;
case 'n':
ascii = '\n';
break;
case 'v':
ascii = '\v';
break;
case '\\':
ascii = '\\';
break;
case '\'':
ascii = '\'';
break;
case '"':
ascii = '"';
break;
case '`':
ascii = '`';
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
/* character in octal: maximum of 3 digits, terminates with \ */
{
unsigned char so_far = ch-'0';
my_fgetch();
if (ch >= '0' && ch < '8') {/* octal */
so_far = so_far*8+(ch-'0');
my_fgetch();
if (ch >= '0' && ch < '8') { /* octal */
ascii = so_far*8+(ch-'0');
my_fgetch();
if (ch != '\\') {
ErrorMessage = "invalid octal escape sequence";
}
} else if (ch == '\\') {
ascii = so_far;
} else {
ErrorMessage = "invalid octal escape sequence";
}
} else if (ch == '\\') {
ascii = so_far;
} else {
ErrorMessage = "invalid octal escape sequence";
}
}
break;
case 'x':
/* hexadecimal character (YAP allows empty hexadecimal */
{
unsigned char so_far = 0;
my_fgetch();
if (my_isxdigit(ch,'f','F')) {/* hexa */
so_far = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
my_fgetch();
if (my_isxdigit(ch,'f','F')) { /* hexa */
ascii = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
my_fgetch();
if (ch != '\\') {
ErrorMessage = "invalid hexadecimal escape sequence";
}
} else if (ch == '\\') {
ascii = so_far;
} else {
ErrorMessage = "invalid hexadecimal escape sequence";
}
} else if (ch == '\\') {
ascii = so_far;
my_fgetch();
} else {
ErrorMessage = "invalid hexadecimal escape sequence";
}
}
break;
default:
/* accept sequence. Note that the ISO standard does not
consider this sequence legal, whereas SICStus would
eat up the escape sequence. */
ErrorMessage = "invalid escape sequence";
}
}
my_fgetch();
TokenInfo = (CELL) MkIntTerm(ascii);
goto end_of_read_number;
}
else if (base >= 10 && base <= 36) {
int upper_case = 'A' - 11 + base;
int lower_case = 'a' - 11 + base;
while (my_isxdigit(ch, upper_case, lower_case)) {
Int oval = val;
*sp++ = ch;
val = val * base + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
if (oval >= val && oval != 0) /* overflow */
has_overflow = (has_overflow || TRUE);
my_fgetch();
}
}
}
else if ((ch == 'x' || ch == 'X') && base == 0) {
might_be_float = FALSE;
*sp++ = ch;
my_fgetch();
while (my_isxdigit(ch, 'F', 'f')) {
Int oval = val;
*sp++ = ch;
val = val * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
if (oval >= val && oval != 0) /* overflow */
has_overflow = (has_overflow || TRUE);
my_fgetch();
}
}
else {
val = base;
base = 10;
}
while (chtype[ch] == NU) {
Int oval = val;
*sp++ = ch;
if (ch - '0' >= base) {
TokenInfo = (CELL) MkIntegerTerm(val);
goto end_of_read_number;
}
val = val * base + ch - '0';
if (oval >= val && oval != 0) /* overflow */
has_overflow = (has_overflow || TRUE);
my_fgetch();
}
if (might_be_float && (ch == '.' || ch == 'e' || ch == 'E')) {
if (ch == '.') {
*sp++ = '.';
if (chtype[my_fgetch()] != NU) {
/*
* first
* process
* the new
* token
*/
t->Tok = Ord(Number_tok);
#ifdef DEBUG
/*
* if(Option[2
* ])
* YP_fprintf(YP_stderr,"[To
* ken %d
* %d]",Ord(ki
* nd),TokenIn
* fo);
*/
#endif
if (has_overflow)
t->TokInfo = read_int_overflow(TokImage,base);
else
t->TokInfo = MkIntegerTerm(val);
t->TokPos = TokenPos;
t = (TokEntry *) AllocScannerMemory(sizeof(TokEntry));
if (t == NULL) {
ErrorMessage = "not enough stack space to read in term";
if (p != NIL)
p->TokInfo = eot_tok;
/* serious error now */
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return(l);
}
if (l == NIL)
l = t;
else
p->TokNext = t;
p = t;
/*
* continue
* analysis
*/
och = '.';
goto inside_symbol;
}
do
*sp++ = ch;
while (chtype[my_fgetch()] == NU);
}
if (ch == 'e' || ch == 'E') {
*sp++ = 'e';
my_fgetch();
if (ch == '-') {
*sp++ = ch;
my_fgetch();
}
else if (ch == '+')
my_fgetch();
if (chtype[ch] != NU) {
/*
* first
* finish
* processing
*/
--sp;
och = *sp;
*sp = '\0';
/*
* first
* process
* the new
* token
*/
t->Tok = Ord(Number_tok);
t->TokPos = TokenPos;
t->TokInfo = float_send(TokImage);
t =
(TokEntry *) AllocScannerMemory(sizeof(TokEntry));
if (t == NULL) {
ErrorMessage = "not enough stack space to read in term";
if (p != NIL)
p->TokInfo = eot_tok;
/* serious error now */
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
return(l);
}
if (l == NIL)
l = t;
else
p->TokNext = t;
p = t;
/*
* now try to
* backtrack
* statically
*/
if (chtype[och] == SY)
goto inside_symbol;
else {
charp = TokImage;
isvar = (chtype[och] != LC);
*charp++ = och;
goto inside_letters;
}
}
do
*sp++ = ch;
while (chtype[my_fgetch()] == NU);
}
*sp = '\0';
TokenInfo = (CELL) float_send(TokImage);
goto end_of_read_number;
}
if (has_overflow) {
*sp = '\0';
/* skip base */
if (TokImage[0] == '0' && (TokImage[1] == 'x' || TokImage[1] == 'X'))
TokenInfo = read_int_overflow(TokImage+2,16);
else if (TokImage[1] == '\'')
TokenInfo = read_int_overflow(TokImage+2,base);
else if (TokImage[2] == '\'')
TokenInfo = read_int_overflow(TokImage+3,base);
else
TokenInfo = read_int_overflow(TokImage,base);
} else
TokenInfo = (CELL) MkIntegerTerm(val);
}
end_of_read_number:
kind = Number_tok;
break;
case QT:
case DC:
quote = ch;
len = 0;
my_fgetch();
while (1) {
if (charp + 1024 > (char *)AuxSp) {
ErrorMessage = "Heap Overflow While Scanning: please increase heap";
break;
}
if (ch == quote) {
my_fgetch();
if (ch != quote)
break;
my_fgetch();
*charp++ = ch;
} else if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) {
/* escape sequence */
ch = my_fgetch();
switch (ch) {
case 'a':
*charp++ = '\a';
my_fgetch();
break;
case 'b':
*charp++ = '\b';
my_fgetch();
break;
case 'r':
*charp++ = '\r';
my_fgetch();
break;
case 'f':
*charp++ = '\f';
my_fgetch();
break;
case 't':
*charp++ = '\t';
my_fgetch();
break;
case 'n':
*charp++ = '\n';
my_fgetch();
break;
case 'v':
*charp++ = '\v';
my_fgetch();
break;
case '\\':
*charp++ = '\\';
my_fgetch();
break;
case '\'':
*charp++ = '\'';
my_fgetch();
break;
case '"':
*charp++ = '"';
my_fgetch();
break;
case '`':
*charp++ = '`';
my_fgetch();
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
/* character in octal: maximum of 3 digits, terminates with \ */
{
unsigned char so_far = ch-'0';
my_fgetch();
if (ch >= '0' && ch < '8') {/* octal */
so_far = so_far*8+(ch-'0');
my_fgetch();
if (ch >= '0' && ch < '8') { /* octal */
*charp++ = so_far*8+(ch-'0');
my_fgetch();
if (ch != '\\') {
ErrorMessage = "invalid octal escape sequence";
} else {
my_fgetch();
}
} else if (ch == '\\') {
*charp++ = so_far;
my_fgetch();
} else {
ErrorMessage = "invalid octal escape sequence";
}
} else if (ch == '\\') {
*charp++ = so_far;
my_fgetch();
} else {
ErrorMessage = "invalid octal escape sequence";
}
}
break;
case 'x':
/* hexadecimal character (YAP allows empty hexadecimal */
{
unsigned char so_far = 0;
my_fgetch();
if (my_isxdigit(ch,'f','F')) {/* hexa */
so_far = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
my_fgetch();
if (my_isxdigit(ch,'f','F')) { /* hexa */
*charp++ = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
my_fgetch();
if (ch != '\\') {
ErrorMessage = "invalid hexadecimal escape sequence";
} else {
my_fgetch();
}
} else if (ch == '\\') {
*charp++ = so_far;
my_fgetch();
} else {
ErrorMessage = "invalid hexadecimal escape sequence";
}
} else if (ch == '\\') {
*charp++ = so_far;
my_fgetch();
} else {
ErrorMessage = "invalid hexadecimal escape sequence";
}
}
break;
default:
/* accept sequence. Note that the ISO standard does not
consider this sequence legal, whereas SICStus would
eat up the escape sequence. */
ErrorMessage = "invalid escape sequence";
}
} else {
*charp++ = ch;
my_fgetch();
}
++len;
if (charp > (char *)AuxSp - 1024) {
/* Not enough space to read in the string. */
ErrorMessage = "not enough heap space to read in string or quoted atom";
/* serious error now */
kind = eot_tok;
}
}
*charp = '\0';
if (quote == '"') {
mp = AllocScannerMemory(len + 1);
if (mp == NULL) {
ErrorMessage = "not enough stack space to read in string or quoted atom";
/* serious error now */
kind = eot_tok;
}
strcpy(mp, TokImage);
TokenInfo = Unsigned(mp);
kind = String_tok;
}
else {
TokenInfo = Unsigned(LookupAtom(TokImage));
if (ch == '(')
solo_flag = FALSE;
kind = Name_tok;
}
break;
case SY:
och = ch;
my_fgetch();
inside_symbol:
if (och == '/' && ch == '*') {
while ((ch != '/' || och != '*') && chtype[ch] != EF) {
och = ch;
my_fgetch();
}
if (chtype[ch] == EF) {
kind = eot_tok;
break;
}
my_fgetch();
if (t == l)
FirstLineInParse();
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
goto get_tok;
}
if (och == '.' && (chtype[ch] == BS || chtype[ch] == EF
|| chtype[ch] == CC)) {
eot_before_eof = TRUE;
if (chtype[ch] == CC)
while (my_fgetch() != 10 && chtype[ch] != EF);
kind = eot_tok;
}
else {
*charp++ = och;
for (; chtype[ch] == SY; my_fgetch())
*charp++ = ch;
*charp = '\0';
TokenInfo = Unsigned(LookupAtom(TokImage));
if (ch == '(')
solo_flag = FALSE;
kind = Name_tok;
}
break;
case SL:
*charp++ = ch;
*charp++ = '\0';
my_fgetch();
TokenInfo = Unsigned(LookupAtom(TokImage));
if (ch == '(')
solo_flag = FALSE;
kind = Name_tok;
break;
case BK:
och = ch;
do {
/* skip spaces to look for stuff such as [ ] */
my_fgetch();
} while (chtype[ch] == BS);
if (och == '[' && ch == ']') {
TokenInfo = Unsigned(AtomNil);
my_fgetch();
if (ch == '(')
solo_flag = FALSE;
kind = Name_tok;
}
else {
if (!solo_flag && och == '(') {
TokenInfo = 'l';
solo_flag = TRUE;
}
else
TokenInfo = och;
kind = Ponctuation_tok;
}
break;
case EF:
kind = eot_tok;
break;
#ifdef DEBUG
default:
YP_fprintf(YP_stderr, "\n++++ token: wrong char type %c %d\n", ch, chtype[ch]);
kind = eot_tok;
#else
default:
kind = eot_tok; /* Just to make lint happy */
#endif
}
}
t->Tok = Ord(kind);
#ifdef DEBUG
if(Option[2]) YP_fprintf(YP_stderr,"[Token %d %ld]\n",Ord(kind),(unsigned long int)TokenInfo);
#endif
t->TokInfo = (Term) TokenInfo;
t->TokPos = TokenPos;
t->TokNext = NIL;
ReleasePreAllocCodeSpace((CODEADDR)TokImage);
} while (kind != eot_tok);
return (l);
}
Reference in New Issue View Git Blame Copy Permalink