diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

support for quasi quotations, requires more integration with SWI code.

Browse Source
This commit is contained in:
Vítor Santos Costa 2013-11-18 12:57:09 +00:00
parent b167e62bc7
commit b76be1b33f
18 changed files with 1709 additions and 164 deletions

226
C/iopreds.c

@ -85,6 +85,7 @@ static char SccsId[] = "%W% %G%";
#endif
#endif
#include "iopreds.h"
#include "pl-read.h"
static Int p_set_read_error_handler( USES_REGS1 );
static Int p_get_read_error_handler( USES_REGS1 );
@ -376,12 +377,12 @@ syntax_error (TokEntry * tokptr, IOSTREAM *st, Term *outp)
}
static void
GenerateSyntaxError(Term *tp, TokEntry *tokstart, IOSTREAM *sno USES_REGS)
GenerateSyntaxError(Term *tp, TokEntry *tokstart, IOSTREAM *sno, Term msg USES_REGS)
{
if (tp) {
Term et[2];
Term t = MkVarTerm();
et[1] = MkPairTerm(syntax_error(tokstart, sno, &t), TermNil);
et[1] = MkPairTerm(syntax_error(tokstart, sno, &t), msg);
t = MkAtomTerm(AtomSyntaxError);
et[0] = Yap_MkApplTerm(FunctorShortSyntaxError,1,&t);
*tp = Yap_MkApplTerm(FunctorError, 2, et);
@ -420,7 +421,7 @@ Yap_StringToTerm(char *s,Term *tp)
t = Yap_Parse();
TR = TR_before_parse;
if (!t || LOCAL_ErrorMessage) {
GenerateSyntaxError(tp, tokstart, sno PASS_REGS);
GenerateSyntaxError(tp, tokstart, sno, MkAtomTerm(Yap_LookupAtom(LOCAL_ErrorMessage)) PASS_REGS);
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
Sclose(sno);
return FALSE;
@ -501,44 +502,212 @@ p_get_read_error_handler( USES_REGS1 )
}
int
Yap_readTerm(void *st0, Term *tp, Term *varnames, Term *terror, Term *tpos)
Yap_read_term(term_t t0, IOSTREAM *inp_stream, struct read_data_t *rd)
{
CACHE_REGS
TokEntry *tokstart;
Term pt;
IOSTREAM *st = (IOSTREAM *)st0;
Term t, v;
Term OCurrentModule = CurrentModule, tmod, tpos;
int store_comments = rd->comments;
if (st == NULL) {
if (inp_stream == NULL) {
return FALSE;
}
tokstart = LOCAL_tokptr = LOCAL_toktide = Yap_tokenizer(st, FALSE, tpos);
if (LOCAL_ErrorMessage)
{
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
if (terror)
*terror = MkAtomTerm(Yap_LookupAtom(LOCAL_ErrorMessage));
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
return FALSE;
CurrentModule = tmod = MkAtomTerm(rd->module->AtomOfME);
LOCAL_Error_TYPE = YAP_NO_ERROR;
while (TRUE) {
CELL *old_H;
int64_t cpos = 0;
int seekable = inp_stream->functions->seek != NULL;
/* two cases where we can seek: memory and console */
if (seekable) {
cpos = inp_stream->posbuf.byteno;
}
pt = Yap_Parse();
if (LOCAL_ErrorMessage || pt == (CELL)0) {
GenerateSyntaxError(terror, tokstart, st PASS_REGS);
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
return FALSE;
}
if (varnames) {
*varnames = Yap_VarNames(LOCAL_VarTable, TermNil);
if (!*varnames) {
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
return FALSE;
/* Scans the term using stack space */
while (TRUE) {
old_H = H;
LOCAL_Comments = TermNil;
LOCAL_CommentsNextChar = LOCAL_CommentsTail = NULL;
tokstart = LOCAL_tokptr = LOCAL_toktide = Yap_tokenizer(inp_stream, store_comments, &tpos);
if (LOCAL_Error_TYPE != YAP_NO_ERROR && seekable) {
H = old_H;
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
if (seekable) {
Sseek64(inp_stream, cpos, SIO_SEEK_SET);
}
if (LOCAL_Error_TYPE == OUT_OF_TRAIL_ERROR) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growtrail (sizeof(CELL) * K16, FALSE)) {
return FALSE;
}
} else if (LOCAL_Error_TYPE == OUT_OF_AUXSPACE_ERROR) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
return FALSE;
}
} else if (LOCAL_Error_TYPE == OUT_OF_HEAP_ERROR) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growheap(FALSE, 0, NULL)) {
return FALSE;
}
} else if (LOCAL_Error_TYPE == OUT_OF_STACK_ERROR) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_dogc( 0, NULL PASS_REGS )) {
return FALSE;
}
}
} else {
/* done with this */
break;
}
}
LOCAL_Error_TYPE = YAP_NO_ERROR;
/* preserve value of H after scanning: otherwise we may lose strings
and floats */
old_H = H;
if (tokstart != NULL && tokstart->Tok == Ord (eot_tok)) {
/* did we get the end of file from an abort? */
if (LOCAL_ErrorMessage &&
!strcmp(LOCAL_ErrorMessage,"Abort")) {
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
return FALSE;
} else {
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
rd->varnames = 0;
return Yap_unify_constant( Yap_GetFromSlot( t0 PASS_REGS), MkAtomTerm (AtomEof));
}
}
repeat_cycle:
CurrentModule = tmod;
if (LOCAL_ErrorMessage || (t = Yap_Parse()) == 0) {
CurrentModule = OCurrentModule;
if (LOCAL_ErrorMessage) {
int res;
if (!strcmp(LOCAL_ErrorMessage,"Stack Overflow") ||
!strcmp(LOCAL_ErrorMessage,"Trail Overflow") ||
!strcmp(LOCAL_ErrorMessage,"Heap Overflow")) {
/* ignore term we just built */
tr_fr_ptr old_TR = TR;
H = old_H;
TR = (tr_fr_ptr)LOCAL_ScannerStack;
if (!strcmp(LOCAL_ErrorMessage,"Stack Overflow"))
res = Yap_growstack_in_parser(&old_TR, &tokstart, &LOCAL_VarTable);
else if (!strcmp(LOCAL_ErrorMessage,"Heap Overflow"))
res = Yap_growheap_in_parser(&old_TR, &tokstart, &LOCAL_VarTable);
else
res = Yap_growtrail_in_parser(&old_TR, &tokstart, &LOCAL_VarTable);
if (res) {
LOCAL_ScannerStack = (char *)TR;
TR = old_TR;
old_H = H;
LOCAL_tokptr = LOCAL_toktide = tokstart;
LOCAL_ErrorMessage = NULL;
goto repeat_cycle;
}
LOCAL_ScannerStack = (char *)TR;
TR = old_TR;
}
}
{
Term terror;
GenerateSyntaxError(&terror, tokstart, inp_stream, MkAtomTerm(Yap_LookupAtom(LOCAL_ErrorMessage)) PASS_REGS);
if (LOCAL_ErrorMessage == NULL)
LOCAL_ErrorMessage = "SYNTAX ERROR";
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
rd->has_exception = TRUE;
rd->exception = Yap_InitSlot(terror PASS_REGS);
return FALSE;
}
} else {
CurrentModule = OCurrentModule;
/* parsing succeeded */
break;
}
}
*tp = pt;
if (!pt)
if (!Yap_unify(t, Yap_GetFromSlot( t0 PASS_REGS)))
return FALSE;
if (store_comments && !Yap_unify(LOCAL_Comments, Yap_GetFromSlot( rd->comments PASS_REGS)))
return FALSE;
if (rd->varnames) {
while (TRUE) {
CELL *old_H = H;
if (setjmp(LOCAL_IOBotch) == 0) {
v = Yap_VarNames(LOCAL_VarTable, TermNil);
break;
} else {
tr_fr_ptr old_TR;
restore_machine_regs();
old_TR = TR;
/* restart global */
H = old_H;
TR = (tr_fr_ptr)LOCAL_ScannerStack;
Yap_growstack_in_parser(&old_TR, &tokstart, &LOCAL_VarTable);
LOCAL_ScannerStack = (char *)TR;
TR = old_TR;
}
}
if (!Yap_unify(v, Yap_GetFromSlot( rd->varnames PASS_REGS)))
return FALSE;
}
if (rd->variables) {
while (TRUE) {
CELL *old_H = H;
if (setjmp(LOCAL_IOBotch) == 0) {
v = Yap_Variables(LOCAL_VarTable, TermNil);
break;
} else {
tr_fr_ptr old_TR;
restore_machine_regs();
old_TR = TR;
/* restart global */
H = old_H;
TR = (tr_fr_ptr)LOCAL_ScannerStack;
Yap_growstack_in_parser(&old_TR, &tokstart, &LOCAL_VarTable);
LOCAL_ScannerStack = (char *)TR;
TR = old_TR;
}
}
if (!Yap_unify(v, Yap_GetFromSlot( rd->variables PASS_REGS)))
return FALSE;
}
if (rd->singles) {
while (TRUE) {
CELL *old_H = H;
if (setjmp(LOCAL_IOBotch) == 0) {
v = Yap_Singletons(LOCAL_VarTable, TermNil);
break;
} else {
tr_fr_ptr old_TR;
restore_machine_regs();
old_TR = TR;
/* restart global */
H = old_H;
TR = (tr_fr_ptr)LOCAL_ScannerStack;
Yap_growstack_in_parser(&old_TR, &tokstart, &LOCAL_VarTable);
LOCAL_ScannerStack = (char *)TR;
TR = old_TR;
}
}
if (!Yap_unify(v, Yap_GetFromSlot( rd->singles PASS_REGS)))
return FALSE;
}
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
return TRUE;
}
/*
Assumes
Flag: ARG1
@ -555,7 +724,6 @@ static Int
Term t, v;
TokEntry *tokstart;
Term tmod = Deref(ARG3), OCurrentModule = CurrentModule, tpos;
extern void Yap_setCurrentSourceLocation(IOSTREAM **s);
Term tcomms = Deref(ARG7);
int store_comments = IsVarTerm(tcomms);

62
C/parser.c

@ -139,6 +139,7 @@ Yap_LookupVar(char *var) /* lookup variable in variables table */
if (hv == hpv) {
Int scmp;
if ((scmp = strcmp(var, p->VarRep)) == 0) {
p->refs++;
return(p);
} else if (scmp < 0) {
op = &(p->VarLeft);
@ -159,6 +160,7 @@ Yap_LookupVar(char *var) /* lookup variable in variables table */
*op = p;
p->VarLeft = p->VarRight = NULL;
p->hv = hv;
p->refs = 1L;
strcpy(p->VarRep, var);
} else {
/* anon var */
@ -166,7 +168,8 @@ Yap_LookupVar(char *var) /* lookup variable in variables table */
p->VarLeft = LOCAL_AnonVarTable;
LOCAL_AnonVarTable = p;
p->VarRight = NULL;
p->hv = 0L;
p->refs = 0L;
p->hv = 1L;
p->VarRep[0] = '_';
p->VarRep[1] = '\0';
}
@ -207,6 +210,63 @@ Yap_VarNames(VarEntry *p,Term l)
return VarNames(p,l PASS_REGS);
}
static Term
Singletons(VarEntry *p,Term l USES_REGS)
{
if (p != NULL) {
if (strcmp(p->VarRep, "_") != 0 && p->refs == 1) {
Term t[2];
Term o;
t[0] = MkAtomTerm(Yap_LookupAtom(p->VarRep));
t[1] = p->VarAdr;
o = Yap_MkApplTerm(FunctorEq, 2, t);
o = MkPairTerm(o, Singletons(p->VarRight,
Singletons(p->VarLeft,l PASS_REGS) PASS_REGS));
if (H > ASP-4096) {
save_machine_regs();
siglongjmp(LOCAL_IOBotch,1);
}
return(o);
} else {
return Singletons(p->VarRight,Singletons(p->VarLeft,l PASS_REGS) PASS_REGS);
}
} else {
return (l);
}
}
Term
Yap_Singletons(VarEntry *p,Term l)
{
CACHE_REGS
return Singletons(p,l PASS_REGS);
}
static Term
Variables(VarEntry *p,Term l USES_REGS)
{
if (p != NULL) {
Term o;
o = MkPairTerm(p->VarAdr, Variables(p->VarRight,Variables(p->VarLeft,l PASS_REGS) PASS_REGS));
if (H > ASP-4096) {
save_machine_regs();
siglongjmp(LOCAL_IOBotch,1);
}
return(o);
} else {
return (l);
}
}
Term
Yap_Variables(VarEntry *p,Term l)
{
CACHE_REGS
return Variables(p,l PASS_REGS);
}
static int
IsPrefixOp(Atom op,int *pptr, int *rpptr USES_REGS)
{

8
C/pl-yap.c

@ -1075,10 +1075,11 @@ X_API int PL_put_atom__LD(term_t t, atom_t a ARG_LD)
return TRUE;
}
void PL_put_term__LD(term_t d, term_t s ARG_LD)
int PL_put_term__LD(term_t d, term_t s ARG_LD)
{
REGS_FROM_LD
Yap_PutInSlot(d,Yap_GetFromSlot(s PASS_REGS) PASS_REGS);
return 1;
}
term_t PL_new_term_ref__LD(ARG1_LD)
@ -1156,6 +1157,11 @@ X_API int PL_unify_int64__LD(term_t t, int64_t n ARG_LD)
}
Procedure
resolveProcedure(functor_t f, Module module)
{ return RepPredProp(PredPropByFunc((Functor)f, MkAtomTerm(module->AtomOfME)));
}
#ifdef _WIN32

1
H/ScannerTypes.h

@ -23,6 +23,7 @@ typedef struct TOKEN {
typedef struct VARSTRUCT {
Term VarAdr;
CELL hv;
UInt refs;
struct VARSTRUCT *VarLeft, *VarRight;
char VarRep[1];
} VarEntry;

1
H/Yapproto.h

@ -280,7 +280,6 @@ void *Yap_GetOutputStream(Atom at);
extern void Yap_DebugPlWrite (Term t);
extern void Yap_DebugErrorPutc (int n);
#endif
int Yap_readTerm(void *, Term *, Term *, Term *, Term *);
void Yap_PlWriteToStream(Term, int, int);
/* depth_lim.c */
void Yap_InitItDeepenPreds(void);

12
H/Yatom.h

@ -637,7 +637,11 @@ IsValProperty (int flags)
return (PropFlags) ((flags == ValProperty));
}
#if SIZEOF_INT_P==4
#define EXTRA_FLAG_BASE 0
#else
#define EXTRA_FLAG_BASE 32
#endif
/* predicate property entry structure */
/* AsmPreds are things like var, nonvar, atom ...which are implemented
@ -649,6 +653,7 @@ IsValProperty (int flags)
*/
typedef enum
{
QuasiQuotationPredFlag = ((UInt)0x80000000 << EXTRA_FLAG_BASE), /* SWI-like quasi quotations */
MegaClausePredFlag = 0x80000000L, /* predicate is implemented as a mega-clause */
ThreadLocalPredFlag = 0x40000000L, /* local to a thread */
MultiFileFlag = 0x20000000L, /* is multi-file */
@ -710,7 +715,12 @@ typedef struct pred_entry
PropFlags KindOfPE; /* kind of property */
struct yami *CodeOfPred;
OPCODE OpcodeOfPred; /* undefcode, indexcode, spycode, .... */
#if SIZEOF_INT_P==4
CELL PredFlags, ExtraPredFlags;
#else
CELL PredFlags;
#define ExtraPredFlags PredFlags;
#endif
UInt ArityOfPE; /* arity of property */
union
{

4
H/pl-global.h

@ -104,9 +104,7 @@ typedef struct exception_frame /* PL_throw exception environments */
typedef struct
{ atom_t file; /* current source file */
int line; /* current line */
int linepos; /* position in the line */
int64_t character; /* current character location */
IOPOS position; /* Line, line pos, char and byte */
} source_location;
typedef struct

14
H/pl-incl.h

@ -42,6 +42,9 @@
/* PL internal magic */
typedef word * Word;
/* SWI internal name for a predicate */
typedef struct pred_entry * Procedure; /* predicate */
/* try not to pollute the SWI space */
#ifdef P
#undef P
@ -108,10 +111,11 @@ typedef int Char; /* char that can pass EOF */
#define Sdin Suser_input /* not used for now */
#define Sdout Suser_output
#define source_line_no (LD->read_source.line)
#define source_file_name (LD->read_source.file)
#define source_line_pos (LD->read_source.linepos)
#define source_char_no (LD->read_source.character)
#define source_file_name (LD->read_source.file)
#define source_line_no (LD->read_source.position.lineno)
#define source_line_pos (LD->read_source.position.linepos)
#define source_char_no (LD->read_source.position.charno)
#define source_byte_no (LD->read_source.position.byteno)
#define debugstatus (LD->_debugstatus)
@ -813,7 +817,7 @@ COMMON(int) PL_is_atom__LD(term_t t ARG_LD);
COMMON(int) PL_is_variable__LD(term_t t ARG_LD);
COMMON(term_t) PL_new_term_ref__LD(ARG1_LD);
COMMON(int) PL_put_atom__LD(term_t t, atom_t a ARG_LD);
COMMON(void) PL_put_term__LD(term_t t1, term_t t2 ARG_LD);
COMMON(int) PL_put_term__LD(term_t t1, term_t t2 ARG_LD);
COMMON(int) PL_unify__LD(term_t t1, term_t t2 ARG_LD);
COMMON(int) PL_unify_atom__LD(term_t t, atom_t a ARG_LD);
COMMON(int) PL_unify_int64__LD(term_t t1, int64_t ARG_LD);

100
H/pl-read.h Normal file

@ -0,0 +1,100 @@
typedef unsigned char * ucharp;
typedef const unsigned char * cucharp;
#define utf8_get_uchar(s, chr) (ucharp)utf8_get_char((char *)(s), chr)
#define FASTBUFFERSIZE 256 /* read quickly upto this size */
struct read_buffer
{ int size; /* current size of read buffer */
unsigned char *base; /* base of read buffer */
unsigned char *here; /* current position in read buffer */
unsigned char *end; /* end of the valid buffer */
IOSTREAM *stream; /* stream we are reading from */
unsigned char fast[FASTBUFFERSIZE]; /* Quick internal buffer */
};
#define RD_MAGIC 0xefebe128
typedef struct read_data_t
{ unsigned char *here; /* current character */
unsigned char *base; /* base of clause */
unsigned char *end; /* end of the clause */
unsigned char *token_start; /* start of most recent read token */
int magic; /* RD_MAGIC */
IOPOS position; /* Line, line pos, char and byte */
unsigned char *posp; /* position pointer */
size_t posi; /* position number */
term_t subtpos; /* Report Subterm positions */
bool cycles; /* Re-establish cycles */
source_location start_of_term; /* Position of start of term */
module_t module; /* Current source module */
unsigned int flags; /* Module syntax flags */
int styleCheck; /* style-checking mask */
bool backquoted_string; /* Read `hello` as string */
int *char_conversion_table; /* active conversion table */
atom_t on_error; /* Handling of syntax errors */
int has_exception; /* exception is raised */
term_t exception; /* raised exception */
term_t variables; /* report variables */
term_t singles; /* Report singleton variables */
term_t varnames; /* Report variables+names */
int strictness; /* Strictness level */
#ifdef O_QUASIQUOTATIONS
term_t quasi_quotations; /* User option quasi_quotations(QQ) */
term_t qq; /* Quasi quoted list */
term_t qq_tail; /* Tail of the quoted stuff */
#endif
term_t comments; /* Report comments */
struct read_buffer _rb; /* keep read characters here */
} read_data, *ReadData;
#define rdhere (_PL_rd->here)
#define rdbase (_PL_rd->base)
#define rdend (_PL_rd->end)
#define last_token_start (_PL_rd->token_start)
#define rb (_PL_rd->_rb)
#define DO_CHARESCAPE true(_PL_rd, CHARESCAPE)
extern IOFUNCTIONS Sstringfunctions;
#ifndef NULL_ATOM
#define NULL_ATOM 0
#endif
static void
setCurrentSourceLocation(ReadData _PL_rd ARG_LD)
{ atom_t a;
IOSTREAM *s = rb.stream;
if ( (a = fileNameStream(s)) )
_PL_rd->start_of_term.file = a;
else
_PL_rd->start_of_term.file = NULL_ATOM;
if ( s->position )
{ _PL_rd->start_of_term.position.lineno = s->position->lineno;
_PL_rd->start_of_term.position.linepos = s->position->linepos - 1;
_PL_rd->start_of_term.position.charno = s->position->charno - 1;
/* byteno maintained get getchr__() */
} else
{ _PL_rd->start_of_term.position.lineno = -1;
_PL_rd->start_of_term.position.linepos = -1;
_PL_rd->start_of_term.position.charno = 0;
_PL_rd->start_of_term.position.byteno = 0;
}
LD->read_source = _PL_rd->start_of_term;
}
extern int Yap_read_term(term_t t, IOSTREAM *st, struct read_data_t *rdt);

4
H/pl-yap.h

@ -31,7 +31,6 @@ typedef Term (*Func)(term_t); /* foreign functions */
extern const char *Yap_GetCurrentPredName(void);
extern Int Yap_GetCurrentPredArity(void);
extern int Yap_read_term(term_t t, IOSTREAM *st, term_t *exc, term_t vs);
extern term_t Yap_fetch_module_for_format(term_t args, Term *modp);
extern IOENC Yap_DefaultEncoding(void);
extern void Yap_SetDefaultEncoding(IOENC);
@ -149,7 +148,6 @@ atomName(Atom atom)
#define nameOfAtom(atom) nameOfAtom(atom)
#define atomBlobType(at) YAP_find_blob_type(at)
#define argTermP(w,i) ((Word)((YAP_ArgsOfTerm(w)+(i))))
#define deRef(t) while (IsVarTerm(*(t)) && !IsUnboundVar(t)) { t = (CELL *)(*(t)); }
@ -158,6 +156,8 @@ atomName(Atom atom)
#define predicateHasClauses(pe) ((pe)->cs.p_code.NOfClauses != 0)
#define lookupModule(A) Yap_GetModuleEntry(MkAtomTerm(YAP_AtomFromSWIAtom(A)))
Procedure resolveProcedure(functor_t f, Module module);
#define charEscapeWriteOption(A) FALSE // VSC: to implement
#define wordToTermRef(A) Yap_InitSlot(*(A) PASS_REGS)
#define isTaggedInt(A) IsIntegerTerm(A)

2
H/yapio.h

@ -236,6 +236,8 @@ chtype(Int ch)
/* routines in parser.c */
VarEntry *Yap_LookupVar(char *);
Term Yap_VarNames(VarEntry *,Term);
Term Yap_Variables(VarEntry *,Term);
Term Yap_Singletons(VarEntry *,Term);
/* routines in scanner.c */
TokEntry *Yap_tokenizer(struct io_stream *, int, Term *);

35
library/dialect/swi/fli/swi.c

@ -2999,41 +2999,6 @@ Yap_swi_install(void)
Yap_install_blobs();
}
int Yap_read_term(term_t t, IOSTREAM *st, term_t *excep, term_t vs);
int
Yap_read_term(term_t t, IOSTREAM *st, term_t *excep, term_t vs)
{
CACHE_REGS
Term varnames, out, tpos;
Term error, *vp;
if (vs) {
vp = & varnames;
} else {
vp = NULL;
}
if (!Yap_readTerm(st, &out, vp, &error, &tpos)) {
if (excep) {
*excep = Yap_InitSlot(error PASS_REGS);
}
return FALSE;
}
if (!out) {
if (excep) {
*excep = Yap_InitSlot(error PASS_REGS);
}
return FALSE;
}
if (!Yap_unify(out, Yap_GetFromSlot(t PASS_REGS))) {
return FALSE;
}
if (vp &&
!Yap_unify(varnames, Yap_GetFromSlot(vs PASS_REGS))) {
return FALSE;
}
return TRUE;
}
extern atom_t fileNameStream(IOSTREAM *s);
extern Atom Yap_FileName(IOSTREAM *s);

12
os/pl-error.c

@ -90,12 +90,22 @@ int
PL_get_intptr_ex(term_t t, intptr_t *i)
{
#if SIZEOF_LONG != SIZEOF_VOIDP && SIZEOF_VOIDP == 8
return PL_get_int64_ex(t, i);
return PL_get_int64_ex(t, (int64_t *)i);
#else
return PL_get_long_ex(t, (long*)i);
#endif
}
int
PL_get_pointer_ex(term_t t, void **i)
{
#if SIZEOF_LONG != SIZEOF_VOIDP && SIZEOF_VOIDP == 8
return PL_get_int64_ex(t, (int64_t *)i);
#else
return PL_get_long_ex(t, (long *)i);
#endif
}
int
PL_get_size_ex(term_t t, size_t *i)

441
os/pl-read.c

@ -5,58 +5,9 @@
#include "pl-dtoa.h"
#include "pl-umap.c" /* Unicode map */
typedef unsigned char * ucharp;
typedef const unsigned char * cucharp;
#define utf8_get_uchar(s, chr) (ucharp)utf8_get_char((char *)(s), chr)
#define FASTBUFFERSIZE 256 /* read quickly upto this size */
struct read_buffer
{ int size; /* current size of read buffer */
unsigned char *base; /* base of read buffer */
unsigned char *here; /* current position in read buffer */
unsigned char *end; /* end of the valid buffer */
IOSTREAM *stream; /* stream we are reading from */
unsigned char fast[FASTBUFFERSIZE]; /* Quick internal buffer */
};
#include "pl-read.h" /* read structure */
typedef struct
{ unsigned char *here; /* current character */
unsigned char *base; /* base of clause */
unsigned char *end; /* end of the clause */
unsigned char *token_start; /* start of most recent read token */
int has_exception; /* exception is raised */
unsigned char *posp; /* position pointer */
size_t posi; /* position number */
unsigned int flags; /* Module syntax flags */
int styleCheck; /* style-checking mask */
bool backquoted_string; /* Read `hello` as string */
int *char_conversion_table; /* active conversion table */
term_t exception; /* raised exception */
term_t varnames; /* Report variables+names */
int strictness; /* Strictness level */
term_t comments; /* Report comments */
struct read_buffer _rb; /* keep read characters here */
} read_data, *ReadData;
#define rdhere (_PL_rd->here)
#define rdbase (_PL_rd->base)
#define rdend (_PL_rd->end)
#define last_token_start (_PL_rd->token_start)
#define rb (_PL_rd->_rb)
#define DO_CHARESCAPE true(_PL_rd, CHARESCAPE)
extern IOFUNCTIONS Sstringfunctions;
static bool
isStringStream(IOSTREAM *s)
@ -67,9 +18,12 @@ isStringStream(IOSTREAM *s)
static void
init_read_data(ReadData _PL_rd, IOSTREAM *in ARG_LD)
{ memset(_PL_rd, 0, sizeof(*_PL_rd)); /* optimise! */
{ CACHE_REGS
memset(_PL_rd, 0, sizeof(*_PL_rd)); /* optimise! */
_PL_rd->magic = RD_MAGIC;
_PL_rd->varnames = 0;
_PL_rd->module = Yap_GetModuleEntry(CurrentModule);
rb.stream = in;
_PL_rd->has_exception = 0;
_PL_rd->exception = 0;
@ -80,19 +34,50 @@ free_read_data(ReadData _PL_rd)
{
}
static void
ptr_to_location(const unsigned char *here, source_location *pos, ReadData _PL_rd)
{ unsigned char const *s, *ll = NULL;
int c;
*pos = _PL_rd->start_of_term;
/* update line number */
for(s=rdbase; s<here; s = utf8_get_uchar(s, &c))
{ pos->position.charno++;
if ( c == '\n' )
{ pos->position.lineno++;
ll = s+1;
}
}
/* update line position */
if ( ll )
{ s = ll;
pos->position.linepos = 0;
} else
{ s = rdbase;
}
for(; s<here; s++)
{ switch(*s)
{ case '\b':
if ( pos->position.linepos > 0 )
pos->position.linepos--;
break;
case '\t':
pos->position.linepos |= 7; /* TBD: set tab distance */
default:
pos->position.linepos++;
}
}
pos->position.byteno = 0; /* we do not know */
}
static int
read_term(term_t t, ReadData _PL_rd ARG_LD)
{
int rval;
term_t except;
if (!(rval = Yap_read_term(t, rb.stream, &except, _PL_rd->varnames))) {
if (except) {
_PL_rd->has_exception = TRUE;
_PL_rd->exception = except;
}
}
return rval;
return Yap_read_term(t, rb.stream, _PL_rd);
}
@ -156,6 +141,26 @@ unicode_separator(pl_wchar_t c)
{ return PlBlankW(c);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
FALSE return false
TRUE redo
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static int
reportReadError(ReadData rd)
{ if ( rd->on_error == ATOM_error )
return PL_raise_exception(rd->exception);
if ( rd->on_error != ATOM_quiet )
printMessage(ATOM_error, PL_TERM, rd->exception);
PL_clear_exception();
if ( rd->on_error == ATOM_dec10 )
return TRUE;
return FALSE;
}
/********************************
* RAW READING *
*********************************/
@ -343,33 +348,17 @@ addToBuffer(int c, ReadData _PL_rd)
}
static void
setCurrentSourceLocation(IOSTREAM *s ARG_LD)
{ atom_t a;
if ( s->position )
{ source_line_no = s->position->lineno;
source_line_pos = s->position->linepos - 1; /* char just read! */
source_char_no = s->position->charno - 1; /* char just read! */
} else
{ source_line_no = -1;
source_line_pos = -1;
source_char_no = 0;
}
if ( (a = fileNameStream(s)) )
source_file_name = a;
else
source_file_name = NULL_ATOM;
}
#if __YAP_PROLOG__
void
Yap_setCurrentSourceLocation(IOSTREAM **s)
Yap_setCurrentSourceLocation(IOSTREAM ** rd)
{
GET_LD
if (*s)
setCurrentSourceLocation(*s PASS_LD);
if (*rd) {
read_data rdt;
rdt._rb.stream = *rd;
setCurrentSourceLocation(&rdt PASS_LD);
}
}
#endif
@ -393,11 +382,155 @@ getchr__(ReadData _PL_rd)
addToBuffer(c, _PL_rd); \
}
#define set_start_line { if ( !something_read ) \
{ setCurrentSourceLocation(rb.stream PASS_LD); \
{ setCurrentSourceLocation(_PL_rd PASS_LD); \
something_read++; \
} \
}
#ifdef O_QUASIQUOTATIONS
/** '$qq_open'(+QQRange, -Stream) is det.
Opens a quasi-quoted memory range.
@arg QQRange is a term '$quasi_quotation'(ReadData, Start, Length)
@arg Stream is a UTF-8 encoded string, whose position indication
reflects the location in the real file.
*/
static
PRED_IMPL("$qq_open", 2, qq_open, 0)
{ PRED_LD
if ( PL_is_functor(A1, FUNCTOR_dquasi_quotation3) )
{ void *ptr;
size_t start, len;
term_t arg = PL_new_term_ref();
if ( PL_get_arg(1, A1, arg) && PL_get_pointer_ex(arg, &ptr) &&
PL_get_arg(2, A1, arg) && PL_get_size_ex(arg, &start) &&
PL_get_arg(3, A1, arg) && PL_get_size_ex(arg, &len) )
{ ReadData _PL_rd = ptr;
if ( _PL_rd->magic == RD_MAGIC )
{ char *s_start = (char*)rdbase+start;
IOSTREAM *s;
if ( (s=Sopenmem(&s_start, &len, "r")) )
{ source_location pos;
s->encoding = ENC_UTF8;
ptr_to_location((unsigned char*)s_start, &pos, _PL_rd);
if ( pos.file )
setFileNameStream(s, pos.file);
if ( pos.position.lineno > 0 )
{ s->position = &s->posbuf;
*s->position = pos.position;
}
return PL_unify_stream(A2, s);
}
} else
PL_existence_error("read_context", A1);
}
} else
PL_type_error("read_context", A1);
return FALSE;
}
static int
parse_quasi_quotations(ReadData _PL_rd ARG_LD)
{ if ( _PL_rd->qq_tail )
{ term_t av;
int rc;
if ( !PL_unify_nil(_PL_rd->qq_tail) )
return FALSE;
if ( !_PL_rd->quasi_quotations )
{ if ( (av = PL_new_term_refs(2)) &&
PL_put_term(av+0, _PL_rd->qq) &&
#if __YAP_PROLOG__
PL_put_atom(av+1, YAP_SWIAtomFromAtom(_PL_rd->module->AtomOfME)) &&
#else
PL_put_atom(av+1, _PL_rd->module->name) &&
#endif
PL_cons_functor_v(av, FUNCTOR_dparse_quasi_quotations2, av) )
{ term_t ex;
rc = callProlog(MODULE_system, av+0, PL_Q_CATCH_EXCEPTION, &ex);
if ( rc )
return TRUE;
_PL_rd->exception = ex;
_PL_rd->has_exception = TRUE;
}
return FALSE;
} else
return TRUE;
} else if ( _PL_rd->quasi_quotations ) /* user option, but no quotes */
{ return PL_unify_nil(_PL_rd->quasi_quotations);
} else
return TRUE;
}
static int
is_quasi_quotation_syntax(term_t type, ReadData _PL_rd)
{ GET_LD
term_t plain = PL_new_term_ref();
term_t ex;
Module m = _PL_rd->module;
atom_t name;
int arity;
PL_strip_module(type, &m, plain);
if ( PL_get_name_arity(plain, &name, &arity) )
{ if ( _PL_rd->quasi_quotations )
{ return TRUE;
} else
{ Procedure proc;
if ( (proc=resolveProcedure(PL_new_functor(name, 4), m)) &&
#if __YAP_PROLOG__
proc->PredFlags & QuasiQuotationPredFlag
#else
true(proc->definition, P_QUASI_QUOTATION_SYNTAX)
#endif
)
return TRUE;
if ( (ex = PL_new_term_ref()) &&
PL_unify_term(ex,
PL_FUNCTOR_CHARS, "unknown_quasi_quotation_syntax", 2,
PL_TERM, type,
#if __YAP_PROLOG__
PL_ATOM, YAP_SWIAtomFromAtom(m->AtomOfME)
#else
PL_ATOM, m->name
#endif
) )
return errorWarning(NULL, ex, _PL_rd);
}
} else
{ if ( (ex = PL_new_term_ref()) &&
PL_unify_term(ex, PL_FUNCTOR_CHARS, "invalid_quasi_quotation_syntax", 1,
PL_TERM, type) )
return errorWarning(NULL, ex, _PL_rd);
}
return FALSE;
}
#endif /*O_QUASIQUOTATIONS*/
#define rawSyntaxError(what) { addToBuffer(EOS, _PL_rd); \
rdbase = rb.base, last_token_start = rb.here-1; \
syntaxError(what, _PL_rd); \
@ -1002,12 +1135,147 @@ out:
}
static int
unify_read_term_position(term_t tpos ARG_LD)
{ if ( tpos && source_line_no > 0 )
{ return PL_unify_term(tpos,
PL_FUNCTOR, FUNCTOR_stream_position4,
PL_INT64, source_char_no,
PL_INT, source_line_no,
PL_INT, source_line_pos,
PL_INT64, source_byte_no);
} else
{ return TRUE;
}
}
word
pl_raw_read(term_t term)
{ return pl_raw_read2(0, term);
}
static const opt_spec read_term_options[] =
{ { ATOM_variable_names, OPT_TERM },
{ ATOM_variables, OPT_TERM },
{ ATOM_singletons, OPT_TERM },
{ ATOM_term_position, OPT_TERM },
{ ATOM_subterm_positions, OPT_TERM },
{ ATOM_character_escapes, OPT_BOOL },
{ ATOM_double_quotes, OPT_ATOM },
{ ATOM_module, OPT_ATOM },
{ ATOM_syntax_errors, OPT_ATOM },
{ ATOM_backquoted_string, OPT_BOOL },
{ ATOM_comments, OPT_TERM },
#ifdef O_QUASIQUOTATIONS
{ ATOM_quasi_quotations, OPT_TERM },
#endif
{ ATOM_cycles, OPT_BOOL },
{ NULL_ATOM, 0 }
};
static foreign_t
read_term_from_stream(IOSTREAM *s, term_t term, term_t options ARG_LD)
{ term_t tpos = 0;
term_t tcomments = 0;
int rval;
atom_t w;
read_data rd;
bool charescapes = -1;
atom_t dq = NULL_ATOM;
atom_t mname = NULL_ATOM;
fid_t fid = PL_open_foreign_frame();
retry:
init_read_data(&rd, s PASS_LD);
if ( !scan_options(options, 0, ATOM_read_option, read_term_options,
&rd.varnames,
&rd.variables,
&rd.singles,
&tpos,
&rd.subtpos,
&charescapes,
&dq,
&mname,
&rd.on_error,
&rd.backquoted_string,
&tcomments,
#ifdef O_QUASIQUOTATIONS
&rd.quasi_quotations,
#endif
&rd.cycles) ) {
return FALSE;
}
if ( mname )
{ rd.module = lookupModule(mname);
rd.flags = rd.module->flags;
}
if ( charescapes != -1 )
{ if ( charescapes )
set(&rd, M_CHARESCAPE);
else
clear(&rd, M_CHARESCAPE);
}
if ( dq )
{ if ( !setDoubleQuotes(dq, &rd.flags) )
return FALSE;
}
if ( rd.singles && PL_get_atom(rd.singles, &w) && w == ATOM_warning )
rd.singles = TRUE;
if ( tcomments )
rd.comments = PL_copy_term_ref(tcomments);
rval = read_term(term, &rd PASS_LD);
if ( Sferror(s) )
return FALSE;
if ( rval )
{ if ( tpos )
rval = unify_read_term_position(tpos PASS_LD);
if ( rval && tcomments )
{ if ( !PL_unify_nil(rd.comments) )
rval = FALSE;
}
} else
{ if ( rd.has_exception && reportReadError(&rd) )
{ PL_rewind_foreign_frame(fid);
free_read_data(&rd);
goto retry;
}
}
free_read_data(&rd);
return rval;
}
/** read_term(-Term, +Options) is det.
*/
static
PRED_IMPL("read_term", 2, read_term, PL_FA_ISO)
{ PRED_LD
IOSTREAM *s;
if ( getTextInputStream(0, &s) )
{ if ( read_term_from_stream(s, A1, A2 PASS_LD) )
return PL_release_stream(s);
if ( Sferror(s) )
return streamStatus(s);
PL_release_stream(s);
return FALSE;
}
return FALSE;
}
/*******************************
* TERM <->ATOM *
*******************************/
@ -1108,6 +1376,11 @@ PL_chars_to_term(const char *s, term_t t)
*******************************/
BeginPredDefs(read)
PRED_DEF("swi_read_term", 3, read_term, PL_FA_ISO)
PRED_DEF("swi_read_term", 2, read_term, PL_FA_ISO)
PRED_DEF("atom_to_term", 3, atom_to_term, 0)
PRED_DEF("term_to_atom", 2, term_to_atom, 0)
#ifdef O_QUASIQUOTATIONS
PRED_DEF("$qq_open", 2, qq_open, 0)
#endif
EndPredDefs

6
swi/library/Makefile.in

@ -46,6 +46,8 @@ PROGRAMS= \
$(srcdir)/prolog_colour.pl \
$(srcdir)/prolog_source.pl \
$(srcdir)/prolog_xref.pl \
$(srcdir)/pure_input.pl \
$(srcdir)/quasi_quotations.pl \
$(srcdir)/quintus.pl \
$(srcdir)/readutil.pl \
$(srcdir)/record.pl \
@ -55,10 +57,12 @@ PROGRAMS= \
$(srcdir)/url.pl \
$(srcdir)/utf8.pl \
$(srcdir)/win_menu.pl \
$(srcdir)/www_browser.pl
$(srcdir)/www_browser.pl\
$(srcdir)/dcg/basics.pl
install: $(PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
mkdir -p $(DESTDIR)$(SHAREDIR)/dcg
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done

416
swi/library/dcg/basics.pl Normal file

@ -0,0 +1,416 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2002-2013, University of Amsterdam
VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(dcg_basics,
[ white//0, % <white inside line>
whites//0, % <white inside line>*
blank//0, % <blank>
blanks//0, % <blank>*
nonblank//1, % <nonblank>
nonblanks//1, % <nonblank>* --> chars (long)
blanks_to_nl//0, % [space,tab,ret]*nl
string//1, % <any>* -->chars (short)
string_without//2, % Exclude, -->chars (long)
% Characters
alpha_to_lower//1, % Get lower|upper, return lower
% Decimal numbers
digits//1, % [0-9]* -->chars
digit//1, % [0-9] --> char
integer//1, % [+-][0-9]+ --> integer
float//1, % [+-]?[0-9]+(.[0-9]*)?(e[+-]?[0-9]+)? --> float
number//1, % integer | float
% Hexadecimal numbers
xdigits//1, % [0-9a-f]* --> 0-15*
xdigit//1, % [0-9a-f] --> 0-15
xinteger//1, % [0-9a-f]+ --> integer
prolog_var_name//1, % Read a Prolog variable name
eos//0, % Test end of input.
% generation (TBD)
atom//1 % generate atom
]).
:- use_module(library(lists)).
/** <module> Various general DCG utilities
This library provides various commonly used DCG primitives acting on
list of character *codes*. Character classification is based on
code_type/2.
This module started its life as library(http/dcg_basics) to support the
HTTP protocol. Since then, it was increasingly used in code that has no
relation to HTTP and therefore this library was moved to the core
library.
@tbd This is just a starting point. We need a comprehensive set of
generally useful DCG primitives.
*/
%% string_without(+End, -Codes)// is det.
%
% Take as many tokens from the input until the next character code
% appears in the list End. The terminating code itself is left on
% the input. Typical use is to read upto a defined delimiter such
% as a newline or other reserved character. For example:
%
% ==
% ...,
% string_without("\n", RestOfLine)
% ==
%
% @arg End is a list of character codes.
% @see string//1.
string_without(End, Codes) -->
{ string(End), !,
string_codes(End, EndCodes)
},
list_string_without(EndCodes, Codes).
string_without(End, Codes) -->
list_string_without(End, Codes).
list_string_without(Not, [C|T]) -->
[C],
{ \+ memberchk(C, Not)
}, !,
list_string_without(Not, T).
list_string_without(_, []) -->
[].
%% string(-Codes)// is nondet.
%
% Take as few as possible tokens from the input, taking one more
% each time on backtracking. This code is normally followed by a
% test for a delimiter. For example:
%
% ==
% upto_colon(Atom) -->
% string(Codes), ":", !,
% { atom_codes(Atom, Codes) }.
% ==
%
% @see string_without//2.
string([]) -->
[].
string([H|T]) -->
[H],
string(T).
%% blanks// is det.
%
% Skip zero or more white-space characters.
blanks -->
blank, !,
blanks.
blanks -->
[].
%% blank// is semidet.
%
% Take next =space= character from input. Space characters include
% newline.
%
% @see white//0
blank -->
[C],
{ nonvar(C),
code_type(C, space)
}.
%% nonblanks(-Codes)// is det.
%
% Take all =graph= characters
nonblanks([H|T]) -->
[H],
{ code_type(H, graph)
}, !,
nonblanks(T).
nonblanks([]) -->
[].
%% nonblank(-Code)// is semidet.
%
% Code is the next non-blank (=graph=) character.
nonblank(H) -->
[H],
{ code_type(H, graph)
}.
%% blanks_to_nl// is semidet.
%
% Take a sequence of blank//0 codes if banks are followed by a
% newline or end of the input.
blanks_to_nl -->
"\n", !.
blanks_to_nl -->
blank, !,
blanks_to_nl.
blanks_to_nl -->
eos.
%% whites// is det.
%
% Skip white space _inside_ a line.
%
% @see blanks//0 also skips newlines.
whites -->
white, !,
whites.
whites -->
[].
%% white// is semidet.
%
% Take next =white= character from input. White characters do
% _not_ include newline.
white -->
[C],
{ nonvar(C),
code_type(C, white)
}.
/*******************************
* CHARACTER STUFF *
*******************************/
%% alpha_to_lower(+C)// is det.
%% alpha_to_lower(-C)// is semidet.
%
% Read a letter (class =alpha=) and return it as a lowercase
% letter. In output mode this simply emits the character.
alpha_to_lower(L) -->
{ integer(L) }, !,
[L].
alpha_to_lower(L) -->
[C],
{ code_type(C, alpha),
code_type(C, to_upper(L))
}.
/*******************************
* NUMBERS *
*******************************/
%% digits(?Chars)// is det.
%% digit(?Char)// is det.
%% integer(?Integer)// is det.
%
% Number processing. The predicate digits//1 matches a posibly
% empty set of digits, digit//1 processes a single digit and
% integer processes an optional sign followed by a non-empty
% sequence of digits into an integer.
digits([H|T]) -->
digit(H), !,
digits(T).
digits([]) -->
[].
digit(C) -->
[C],
{ code_type(C, digit)
}.
integer(I, Head, Tail) :-
integer(I), !,
format(codes(Head, Tail), '~w', [I]).
integer(I) -->
int_codes(Codes),
{ number_codes(I, Codes)
}.
int_codes([C,D0|D]) -->
sign(C), !,
digit(D0),
digits(D).
int_codes([D0|D]) -->
digit(D0),
digits(D).
%% float(?Float)// is det.
%
% Process a floating point number. The actual conversion is
% controlled by number_codes/2.
float(F, Head, Tail) :-
float(F), !,
with_output_to(codes(Head, Tail), write(F)).
float(F) -->
number(F),
{ float(F) }.
%% number(+Number)// is det.
%% number(-Number)// is semidet.
%
% Generate extract a number. Handles both integers and floating
% point numbers.
number(N, Head, Tail) :-
number(N), !,
format(codes(Head, Tail), '~w', N).
number(N) -->
int_codes(I),
( dot,
digit(DF0),
digits(DF)
-> {F = [0'., DF0|DF]}
; {F = ""}
),
( exp
-> int_codes(DI),
{E=[0'e|DI]}
; {E = ""}
),
{ append([I, F, E], Codes),
number_codes(N, Codes)
}.
sign(0'-) --> "-".
sign(0'+) --> "+".
dot --> ".".
exp --> "e".
exp --> "E".
/*******************************
* HEX NUMBERS *
*******************************/
%% xinteger(+Integer)// is det.
%% xinteger(-Integer)// is semidet.
%
% Generate or extract an integer from a sequence of hexadecimal
% digits.
xinteger(Val, Head, Tail) :-
integer(Val),
format(codes(Head, Tail), '~16r', [Val]).
xinteger(Val) -->
xdigit(D0),
xdigits(D),
{ mkval([D0|D], 16, Val)
}.
%% xdigit(-Weight)// is semidet.
%
% True if the next code is a hexdecimal digit with Weight. Weight
% is between 0 and 15.
xdigit(D) -->
[C],
{ code_type(C, xdigit(D))
}.
%% xdigits(-WeightList)// is det.
%
% List of weights of a sequence of hexadecimal codes. WeightList
% may be empty.
xdigits([D0|D]) -->
xdigit(D0), !,
xdigits(D).
xdigits([]) -->
[].
mkval([W0|Weights], Base, Val) :-
mkval(Weights, Base, W0, Val).
mkval([], _, W, W).
mkval([H|T], Base, W0, W) :-
W1 is W0*Base+H,
mkval(T, Base, W1, W).
/*******************************
* END-OF-STRING *
*******************************/
%% eos//
%
% Matches end-of-input. The implementation behaves as the
% following portable implementation:
%
% ==
% eos --> call(eos_).
% eos_([], []).
% ==
%
% @tbd This is a difficult concept and violates the _context free_
% property of DCGs. Explain the exact problems.
eos([], []).
/*******************************
* PROLOG SYNTAX *
*******************************/
%% prolog_var_name(-Name:atom)// is semidet.
%
% Matches a Prolog variable name. Primarily intended to deal with
% quasi quotations that embed Prolog variables.
prolog_var_name(Name) -->
[C0], { code_type(C0, prolog_var_start) }, !,
prolog_id_cont(CL),
{ atom_codes(Name, [C0|CL]) }.
prolog_id_cont([H|T]) -->
[H], { code_type(H, prolog_identifier_continue) }, !,
prolog_id_cont(T).
prolog_id_cont([]) --> "".
/*******************************
* GENERATION *
*******************************/
%% atom(+Atom)// is det.
%
% Generate codes of Atom. Current implementation uses write/1,
% dealing with any Prolog term.
atom(Atom, Head, Tail) :-
format(codes(Head, Tail), '~w', [Atom]).

246
swi/library/pure_input.pl Normal file

@ -0,0 +1,246 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2008-2013, University of Amsterdam
VU University Amsterdam
Vienna University of Technology
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(pure_input,
[ phrase_from_file/2, % :Grammar, +File
phrase_from_file/3, % :Grammar, +File, +Options
syntax_error//1, % +ErrorTerm
% Low level interface
lazy_list_location//1, % -Location
lazy_list_character_count//1, % -CharacterCount
phrase_from_stream/2, % :Grammar, +Stream
stream_to_lazy_list/2 % :Stream -List
]).
:- use_module(library(option)).
:- use_module(library(error)).
/** <module> Pure Input from files
This module is part of pio.pl, dealing with _pure_ _input_: processing
input streams from the outside world using pure predicates, notably
grammar rules (DCG). Using pure predicates makes non-deterministic
processing of input much simpler.
Pure input uses coroutining (freeze/2) to read input from the external
source into a list _|on demand|_. The overhead of lazy reading is more
than compensated for by using block reads based on read_pending_input/3.
@tbd Provide support for alternative input readers, e.g. reading
terms, tokens, etc.
@tbd Support non-repositioning streams, such as sockets and pipes.
@author Ulrich Neumerkel
@author Jan Wielemaker
*/
:- predicate_options(phrase_from_file/3, 3,
[ buffer_size(positive_integer),
pass_to(system:open/4, 4)
]).
%% phrase_from_file(:Grammar, +File) is nondet.
%
% Process the content of File using the DCG rule Grammar. The
% space usage of this mechanism depends on the length of the not
% committed part of Grammar. Committed parts of the temporary list
% are reclaimed by the garbage collector, while the list is
% extended on demand. Here is a very simple definition for
% searching a string in a file:
%
% ==
% ... --> []|[_],... .
%
% file_contains(File, Pattern) :-
% phrase_from_file((..., Pattern, ...), File).
%
% match_count(File, Pattern, Count) :-
% findall(x, file_contains(File, Pattern), Xs),
% length(Xs, Count).
% ==
%
% This can be called as (note that the pattern must be a string
% (code list)):
%
% ==
% ?- match_count('pure_input.pl', "file", Count).
% ==
:- meta_predicate
phrase_from_file(//, +),
phrase_from_file(//, +, +),
phrase_from_stream(//, +).
phrase_from_file(Grammar, File) :-
phrase_from_file(Grammar, File, []).
%% phrase_from_file(:Grammar, +File, +Options) is nondet.
%
% As phrase_from_file/2, providing additional Options. Options are
% passed to open/4, except for =buffer_size=, which is passed to
% set_stream/2. If not specified, the default buffer size is 512
% bytes. Of particular importance are the open/4 options =type=
% and =encoding=.
phrase_from_file(Grammar, File, Options) :-
( select_option(buffer_size(BS), Options, OpenOptions)
-> true
; BS=512,
OpenOptions = Options
),
setup_call_cleanup(
open(File, read, In, OpenOptions),
phrase_stream(Grammar, In, BS),
close(In)).
phrase_stream(Grammar, In, BuffserSize) :-
set_stream(In, buffer_size(BuffserSize)),
phrase_from_stream(Grammar, In).
%% phrase_from_stream(:Grammer, +Stream)
%
% Helper for phrase_from_file/3. This predicate cooperates with
% syntax_error//1 to generate syntax error locations for grammars.
phrase_from_stream(Grammar, In) :-
stream_to_lazy_list(In, List),
phrase(Grammar, List).
%% syntax_error(+Error)//
%
% Throw the syntax error Error at the current location of the
% input. This predicate is designed to be called from the handler
% of phrase_from_file/3.
%
% @throws error(syntax_error(Error), Location)
syntax_error(Error) -->
lazy_list_location(Location),
{ throw(error(syntax_error(Error), Location))
}.
%% lazy_list_location(-Location)// is det.
%
% True when Location is an (error) location term that represents
% the current location in the DCG list.
%
% @arg Location is a term file(Name, Line, LinePos, CharNo) or
% stream(Stream, Line, LinePos, CharNo) if no file is
% associated to the stream RestLazyList. Finally, if the
% Lazy list is fully materialized (ends in =|[]|=), Location
% is unified with `end_of_file-CharCount`.
% @see lazy_list_character_count//1 only provides the character
% count.
lazy_list_location(Location, Here, Here) :-
lazy_list_location(Here, Location).
lazy_list_location(Here, Location) :-
'$skip_list'(Skipped, Here, Tail),
( attvar(Tail)
-> frozen(Tail,
pure_input:read_to_input_stream(Stream, PrevPos, Pos, _List)),
Details = [Line, LinePos, CharNo],
( stream_property(Stream, file_name(File))
-> PosParts = [file, File|Details]
; PosParts = [stream, Stream|Details]
),
Location =.. PosParts,
stream_position_data(char_count, Pos, EndRecordCharNo),
CharNo is EndRecordCharNo - Skipped,
set_stream_position(Stream, PrevPos),
stream_position_data(char_count, PrevPos, StartRecordCharNo),
Skip is CharNo-StartRecordCharNo,
forall(between(1, Skip, _), get_code(Stream, _)),
stream_property(Stream, position(ErrorPos)),
stream_position_data(line_count, ErrorPos, Line),
stream_position_data(line_position, ErrorPos, LinePos)
; Tail == []
-> Location = end_of_file-Skipped
; type_error(lazy_list, Here)
).
%% lazy_list_character_count(-CharCount)//
%
% True when CharCount is the current character count in the Lazy
% list. The character count is computed by finding the distance to
% the next frozen tail of the lazy list. CharCount is one of:
%
% - An integer
% - A term end_of_file-Count
%
% @see lazy_list_location//1 provides full details of the location
% for error reporting.
lazy_list_character_count(Location, Here, Here) :-
lazy_list_character_count(Here, Location).
lazy_list_character_count(Here, CharNo) :-
'$skip_list'(Skipped, Here, Tail),
( attvar(Tail)
-> frozen(Tail,
pure_input:read_to_input_stream(_Stream, _PrevPos, Pos, _List)),
stream_position_data(char_count, Pos, EndRecordCharNo),
CharNo is EndRecordCharNo - Skipped
; Tail == []
-> CharNo = end_of_file-Skipped
; type_error(lazy_list, Here)
).
%% stream_to_lazy_list(+Stream, -List) is det.
%
% Create a lazy list representing the character codes in Stream.
% It must be possible to reposition Stream. List is a list that
% ends in a delayed goal. List can be unified completely
% transparent to a (partial) list and processed transparently
% using DCGs, but please be aware that a lazy list is not the same
% as a materialized list in all respects.
%
% Typically, this predicate is used as a building block for more
% high level safe predicates such as phrase_from_file/2.
%
% @tbd Enhance of lazy list throughout the system.
stream_to_lazy_list(Stream, List) :-
stream_to_lazy_list(Stream, -, List).
stream_to_lazy_list(Stream, PrevPos, List) :-
stream_property(Stream, position(Pos)),
freeze(List, read_to_input_stream(Stream, PrevPos, Pos, List)).
read_to_input_stream(Stream, _PrevPos, Pos, List) :-
set_stream_position(Stream, Pos),
( at_end_of_stream(Stream)
-> List = []
; read_pending_input(Stream, List, Tail),
stream_to_lazy_list(Stream, Pos, Tail)
).

283
swi/library/quasi_quotations.pl Normal file

@ -0,0 +1,283 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2013, VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(quasi_quotations,
[ with_quasi_quotation_input/3, % +Content, -Stream, :Goal
phrase_from_quasi_quotation/2, % :Grammar, +Content
quasi_quotation_syntax_error/1, % +Error
quasi_quotation_syntax/1 % :Syntax
]).
:- use_module(library(error)).
:- use_module(library(pure_input)).
/** <module> Define Quasi Quotation syntax
Inspired by
[Haskell](http://www.haskell.org/haskellwiki/Quasiquotation), SWI-Prolog
support _quasi quotation_. Quasi quotation allows for embedding (long)
strings using the syntax of an external language (e.g., HTML, SQL) in
Prolog text and syntax-aware embedding of Prolog variables in this
syntax. At the same time, quasi quotation provides an alternative to
represent long strings and atoms in Prolog.
The basic form of a quasi quotation is defined below. Here, `Syntax` is
an arbitrary Prolog term that must parse into a _callable_ (atom or
compound) term and Quotation is an arbitrary sequence of characters, not
including the sequence =||}|=. If this sequence needs to be embedded, it
must be escaped according to the rules of the target language or the
`quoter' must provide an escaping mechanism.
==
{|Syntax||Quotation|}
==
While reading a Prolog term, and if the Prolog flag =quasi_quotes= is
set to =true= (which is the case if this library is loaded), the parser
collects quasi quotations. After reading the final full stop, the parser
makes the call below. Here, `SyntaxName` is the functor name of `Syntax`
above and `SyntaxArgs` is a list holding the arguments, i.e., `Syntax
=.. [SyntaxName|SyntaxArgs]`. Splitting the syntax into its name and
arguments is done to make the quasi quotation parser a predicate with a
consistent arity 4, regardless of the number of additional arguments.
==
call(+SyntaxName, +Content, +SyntaxArgs, +VariableNames, -Result)
==
The arguments are defined as
- `SyntaxName` is the principal functor of the quasi quotation syntax.
This must be declared using quasi_quotation_syntax/1 and there must be
a predicate SyntaxName/4.
- `Content` is an opaque term that carries the content of the quasi
quoted material and position information about the source code. It is
passed to with_quasi_quote_input/3.
- `SyntaxArgs` carries the additional arguments of the `Syntax`. These are
commonly used to make the parameter passing between the clause and the
quasi quotation explicit. For example:
==
...,
{|html(Name, Address)||
<tr><td>Name<td>Address</tr>
|}
==
- `VariableNames` is the complete variable dictionary of the clause as
it is made available throug read_term/3 with the option
=variable_names=. It is a list of terms `Name = Var`.
- `Result` is a variable that must be unified to resulting term.
Typically, this term is structured Prolog tree that carries a
(partial) representation of the abstract syntax tree with embedded
variables that pass the Prolog parameters. This term is normally
either passed to a predicate that serializes the abstract syntax tree,
or a predicate that processes the result in Prolog. For example, HTML
is commonly embedded for writing HTML documents (see
library(http/html_write)). Examples of languages that may be embedded
for processing in Prolog are SPARQL, RuleML or regular expressions.
The file library(http/http_quasiquotations) provides the, suprisingly
simple, quasi quotation parser for HTML.
@author Jan Wielemaker. Introduction of Quasi Quotation was suggested
by Michael Hendricks.
@see [Why it's nice to be quoted: quasiquoting for
haskell](http://www.eecs.harvard.edu/~mainland/ghc-quasiquoting/mainland07quasiquoting.pdf)
*/
:- meta_predicate
with_quasi_quotation_input(+, -, 0),
quasi_quotation_syntax(4),
phrase_from_quasi_quotation(//, +).
:- set_prolog_flag(quasi_quotations, true).
%% with_quasi_quotation_input(+Content, -Stream, :Goal) is det.
%
% Process the quasi-quoted Content using Stream parsed by Goal.
% Stream is a temporary stream with the following properties:
%
% - Its initial _position_ represents the position of the
% start of the quoted material.
% - It is a text stream, using =utf8= _encoding_.
% - It allows for repositioning
% - It will be closed after Goal completes.
%
% @arg Goal is executed as once(Goal). Goal must succeed.
% Failure or exceptions from Goal are interpreted as
% syntax errors.
% @see phrase_from_quasi_quotation/2 can be used to process a
% quatation using a grammar.
with_quasi_quotation_input(Content, Stream, Goal) :-
functor(Content, '$quasi_quotation', 3), !,
setup_call_cleanup(
'$qq_open'(Content, Stream),
( call(Goal)
-> true
; quasi_quotation_syntax_error(
quasi_quotation_parser_failed,
Stream)
),
close(Stream)).
%% phrase_from_quasi_quotation(:Grammar, +Content) is det.
%
% Process the quasi quotation using the DCG Grammar. Failure of
% the grammer is interpreted as a syntax error.
%
% @see with_quasi_quotation_input/3 for processing quotations from
% stream.
phrase_from_quasi_quotation(Grammar, Content) :-
functor(Content, '$quasi_quotation', 3), !,
setup_call_cleanup(
'$qq_open'(Content, Stream),
phrase_quasi_quotation(Grammar, Stream),
close(Stream)).
phrase_quasi_quotation(Grammar, Stream) :-
set_stream(Stream, buffer_size(512)),
stream_to_lazy_list(Stream, List),
phrase(Grammar, List), !.
phrase_quasi_quotation(_, Stream) :-
quasi_quotation_syntax_error(
quasi_quotation_parser_failed,
Stream).
%% quasi_quotation_syntax(:SyntaxName) is det.
%
% Declare the predicate SyntaxName/4 to implement the the quasi
% quote syntax SyntaxName. Normally used as a directive.
quasi_quotation_syntax(M:Syntax) :-
must_be(atom, Syntax),
'$set_predicate_attribute'(M:Syntax/4, quasi_quotation_syntax, 1).
%% quasi_quotation_syntax_error(+Error)
%
% Report syntax_error(Error) using the current location in the
% quasi quoted input parser.
%
% @throws error(syntax_error(Error), Position)
quasi_quotation_syntax_error(Error) :-
quasi_quotation_input(Stream),
quasi_quotation_syntax_error(Error, Stream).
quasi_quotation_syntax_error(Error, Stream) :-
stream_syntax_error_context(Stream, Context),
throw(error(syntax_error(Error), Context)).
quasi_quotation_input(Stream) :-
'$input_context'(Stack),
memberchk(input(quasi_quoted, _File, _Line, StreamVar), Stack),
Stream = StreamVar.
%% stream_syntax_error_context(+Stream, -Position) is det.
%
% Provide syntax error location for the current position of
% Stream.
stream_syntax_error_context(Stream, file(File, LineNo, LinePos, CharNo)) :-
stream_property(Stream, file_name(File)),
position_context(Stream, LineNo, LinePos, CharNo), !.
stream_syntax_error_context(Stream, stream(Stream, LineNo, LinePos, CharNo)) :-
position_context(Stream, LineNo, LinePos, CharNo), !.
stream_syntax_error_context(_, _).
position_context(Stream, LineNo, LinePos, CharNo) :-
stream_property(Stream, position(Pos)), !,
stream_position_data(line_count, Pos, LineNo),
stream_position_data(line_position, Pos, LinePos),
stream_position_data(char_count, Pos, CharNo).
/*******************************
* SYSTEM HOOK *
*******************************/
% system:'$parse_quasi_quotations'(+Quotations:list, +Module) is
% det.
%
% @arg Quotations is a list of terms
%
% quasi_quotation(Syntax, Quotation, VarNames, Result)
:- public
system:'$parse_quasi_quotes'/2.
system:'$parse_quasi_quotations'([], _).
system:'$parse_quasi_quotations'([H|T], M) :-
qq_call(H, M),
system:'$parse_quasi_quotations'(T, M).
qq_call(quasi_quotation(Syntax, Content, VariableNames, Result), M) :-
current_prolog_flag(sandboxed_load, false),
Syntax =.. [SyntaxName|SyntaxArgs],
setup_call_cleanup(
'$push_input_context'(quasi_quoted),
call(M:SyntaxName, Content, SyntaxArgs, VariableNames, Result),
'$pop_input_context'), !.
qq_call(quasi_quotation(Syntax, Content, VariableNames, Result), M) :-
current_prolog_flag(sandboxed_load, true),
Syntax =.. [SyntaxName|SyntaxArgs],
Expand =.. [SyntaxName, Content, SyntaxArgs, VariableNames, Result],
QExpand = M:Expand,
'$expand':allowed_expansion(QExpand),
setup_call_cleanup(
'$push_input_context'(quasi_quoted),
call(QExpand),
'$pop_input_context'), !.
qq_call(quasi_quotation(_Syntax, Content, _VariableNames, _Result), _M) :-
setup_call_cleanup(
'$push_input_context'(quasi_quoted),
with_quasi_quotation_input(
Content, Stream,
quasi_quotation_syntax_error(quasi_quote_parser_failed, Stream)),
'$pop_input_context'), !.
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:error_message//1.
prolog:error_message(syntax_error(unknown_quasi_quotation_syntax(Syntax, M))) -->
{ functor(Syntax, Name, _) },
[ 'Quasi quotation syntax ~q:~q is not defined'-[M, Name] ].
prolog:error_message(syntax_error(invalid_quasi_quotation_syntax(Syntax))) -->
[ 'Quasi quotation syntax must be a callable term. Found ~q'-[Syntax] ].