improved the parser interface and added features for scanner variables

parent 578e3c8e
......@@ -32,6 +32,7 @@
<newframe> <unwind>
<define-guile-log-rule>
<get-fixed> <cp> <lookup> <wrap>
<with-bind>
))
......@@ -1045,6 +1046,16 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(syntax-rules ()
((_ (cut s pp ccc) (_ . l))
(ccc s pp X ... . l))))))))))
(define-guile-log <with-bind>
(lambda (x)
(syntax-case x ()
((_ w ((X I) ...) code ...)
(with-syntax (((id ...) (generate-temporaries #'(X ...))))
#'(<let> w ((id I) ...)
(<syntax-parameterize> ((X (lambda x #'id)) ...)
(<and> code ...))))))))
(define-syntax-rule (<define-guile-log-rule> (f a ...) code ...)
(define-guile-log f
......
......@@ -45,6 +45,13 @@
(pretty-print (syntax->datum x)))
x)))
(define-syntax-rule (Ds f) (lambda x (apply f x)))
(define *freeze-map* (make-fluid #f))
(define (clear-tokens)
(fluid-set! *freeze-map* (make-hash-table)))
(clear-tokens)
(define (make-file-reader)
(define l '())
(define (read i)
......@@ -176,11 +183,21 @@
(apply f s p cc x xl n m u)))))))
(define-syntax-rule (setup-parser
(define-syntax-rule (setup-parser-0
<p-define> <p-lambda> <fail> <p-cc> <succeds> .. xx
X XL N M (Init ...)
X XL ((N NI) (M MI) (XX Init) ...)
s-false s-true s-mk-seq s-mk-and s-mk-or
s-seq s-and s-and! s-and!! s-or
f-read f-test f-test! pr-test f-tag f-tag! pr-tag
chtr f-id f-pk
s-seq s-and s-and! s-and!! s-and-i s-or s-or-i
f-or f-or! f-and f-and! f-seq f? f+ f* ff? ff+ ff*
f-cons f-list f-cons* mk-token p-freeze parse f-out
f-true f-false f-nl ss f< f> fn f-eof
<s-match> <s-lambda> mk-simple-token f-clear-body
f-char f-char! pr-char f-reg f-reg! pr-reg
f-ws f-ws* pr-ws+ tok-ws* tok-ws+ parse-no-clear
s-rpl f-rpl s-tr f-tr f-1-char f-1-char! pr-1-char
f-not f-not! pr-not f-seq! f-seq!!
pp)
(begin
(define f-read
......@@ -237,48 +254,6 @@
(<p-cc> c)))
(_ (<cut> <fail>)))))))
(define-syntax f-tag
(lambda (x)
(syntax-case x ()
((_ x)
(let* ((w (syntax->datum #'x))
(w (cond
((symbol? w) (string->list (symbol->string w)))
((string? w) (string->list w))
(else #f))))
(if w
(with-syntax (((ch (... ...)) w))
#'(f-seq (f-char ch) (... ...)))
(error "argument to s-tag is either string or symbol")))))))
(define-syntax f-tag!
(lambda (x)
(syntax-case x ()
((_ x)
(let* ((w (syntax->datum #'x))
(w (cond
((symbol? w) (string->list (symbol->string w)))
((string? w) (string->list w))
(else #f))))
(if w
(with-syntax (((ch (... ...)) w))
#'(f-seq (f-char! ch) (... ...)))
(error "argument to s-tag is either string or symbol")))))))
(define-syntax pr-tag
(lambda (x)
(syntax-case x ()
((_ x)
(let* ((w (syntax->datum #'x))
(w (cond
((symbol? w) (string->list (symbol->string w)))
((string? w) (string->list w))
(else #f))))
(if w
(with-syntax (((ch (... ...)) w))
#'(f-seq (pr-char ch) (... ...)))
(error "argument to s-tag is either string or symbol")))))))
(define (chtr x) ((fluid-ref *translator*) x))
......@@ -304,7 +279,7 @@
(cond
((string? x)
(let ((ws (fluid-ref *whitespace*)))
(f-seq ws (f-tag x) ws)))
(f-seq ws (s-tag x) ws)))
((procedure? x)
x)
(else
......@@ -326,7 +301,7 @@
((f g . l) (s-or (ss f) (ss g) (apply f-or l)))
(() s-false)))
(define-syntax-rule (f-or! f (... ...)) (f-and! (s-or f (... ...))))
(define (f-or! . x) (f-and! (apply f-or x)))
(define (f-out tag)
(lambda (s p cc . x)
......@@ -404,13 +379,6 @@
(let ((x (char->string x)))
(regexp-exec reg x))))))
(define *freeze-map* (make-fluid #f))
(define (clear-tokens)
(fluid-set! *freeze-map* (make-hash-table)))
(clear-tokens)
;; The idea of this function is to perform a tokenizing activity
;; utilizing this means that we loose the ability to redo and undo
;; inside the scanner part.
......@@ -445,7 +413,7 @@
(<apply> f-true val))))))
(define (f* f) (letrec ((ret (f-or (s-seq f ret) s-true))) (s-and! ret)))
(define (f+ f) (s-seq f (f* f)))
(define (f+ f) (s-seq f (f* f)))
(define f-ws (s-or (f-char #\space) f-nl (f-char #\tab)))
(define f-ws* (f* f-ws))
(define f-ws+ (f+ f-ws))
......@@ -460,8 +428,6 @@
(lambda (s cin cout) cin))
f-ws+))
(define-syntax-rule (Ds f) (lambda x (apply f x)))
(define parse
(case-lambda
((str matcher)
......@@ -471,7 +437,7 @@
(clear-tokens)
(<run> 1 (cout)
(<values> (x xl . l)
(matcher '() (make-file-reader) Init ... _))
(matcher '() (make-file-reader) NI MI Init ... _))
(<code> (print-last-line xl))
(<=> cout ,(car (reverse l)))))))
(if (string? str)
......@@ -579,14 +545,14 @@
(f-cons x (apply f-list y l)))))
(define (f* x)
(f-or! (s-seq (s-and! (ss x)) (f* x)) s-true))
(f-or! (s-seq (s-and! (ss x)) (Ds (f* x))) s-true))
(define ff*
(case-lambda
((x)
(f-or! (f-cons (f-and! (ss x)) (ff* x)) (f-out '())))
(f-or! (f-cons (f-and! (ss x)) (Ds (ff* x))) (f-out '())))
((x d)
(f-or! (f-cons (f-and! (ss x)) (ff* x d)) (f-out d)))))
(f-or! (f-cons (f-and! (ss x)) (Ds (ff* x d))) (f-out d)))))
(define (f? x)
(f-or! (ss x) s-true))
......@@ -605,6 +571,48 @@
(define (ff+ x . l)
(f-cons (ss x) (apply ff* x l)))
(define-syntax s-tag
(lambda (x)
(syntax-case x ()
((_ x)
(let* ((w (syntax->datum #'x))
(w (cond
((symbol? w) (string->list (symbol->string w)))
((string? w) (string->list w))
(else #f))))
(if w
(with-syntax (((ch (... ...)) w))
#'(f-seq (f-char ch) (... ...)))
(error "argument to s-tag is either string or symbol")))))))
(define-syntax s-tag!
(lambda (x)
(syntax-case x ()
((_ x)
(let* ((w (syntax->datum #'x))
(w (cond
((symbol? w) (string->list (symbol->string w)))
((string? w) (string->list w))
(else #f))))
(if w
(with-syntax (((ch (... ...)) w))
#'(f-seq (f-char! ch) (... ...)))
(error "argument to s-tag is either string or symbol")))))))
(define-syntax spr-tag
(lambda (x)
(syntax-case x ()
((_ x)
(let* ((w (syntax->datum #'x))
(w (cond
((symbol? w) (string->list (symbol->string w)))
((string? w) (string->list w))
(else #f))))
(if w
(with-syntax (((ch (... ...)) w))
#'(f-seq (pr-char ch) (... ...)))
(error "argument to s-tag is either string or symbol")))))))
(define (f-tag x)
(let ((l ((@ (guile) map) (lambda (x) (f-char x))
(string->list (format #f "~a" x)))))
......@@ -618,7 +626,6 @@
(string->list (format #f "~a" x)))))
(apply f-seq l)))
(define (f-or! . x) (f-and! (apply f-or x)))
(define (f-seq! . x) (f-and! (apply f-seq x)))
(define (f-seq!! . x) (apply f-seq (map (lambda (x) (f-and! x)) x)))
(define (f-and!! . x) (apply f-and (map (lambda (x) (f-and! x)) x)))
......@@ -627,8 +634,37 @@
(define f-false s-false)
))
(setup-parser
<p-define> <p-lambda> <fail> <p-cc> <succeds> .. xx
X XL N M (0 0)
s-false s-true s-mk-seq s-mk-and s-mk-or
s-seq s-and s-and! s-and!! s-or pp)
(eval-when (compile load eval)
(define names '(f-read f-test f-test! pr-test f-tag f-tag! pr-tag
chtr f-id f-pk
s-seq s-and s-and! s-and!! s-and-i s-or s-or-i
f-or f-or! f-and f-and! f-seq f? f+ f* ff? ff+ ff*
f-cons f-list f-cons* mk-token p-freeze parse f-out
f-true f-false f-nl ss f< f> fn f-eof
<s-match> <s-lambda> mk-simple-token f-clear-body
f-char f-char! pr-char f-reg f-reg! pr-reg
f-ws f-ws* pr-ws+ tok-ws* tok-ws+ parse-no-clear
s-rpl f-rpl s-tr f-tr f-1-char f-1-char! pr-1-char
f-not f-not! pr-not f-seq! f-seq!!
pp)))
(define-syntax setup-parser
(lambda (x)
(syntax-case x ()
((w <p-define> <p-lambda> <fail> <p-cc> <succeds> .. xx
X XL ((N NI) ...)
s-false s-true s-mk-seq s-mk-and s-mk-or)
(with-syntax (((nm ...) (map (lambda (x)
(datum->syntax #'w x))
names)))
#'(setup-parser-0
<p-define> <p-lambda> <fail> <p-cc> <succeds> .. xx
X XL ((N NI) ...)
s-false s-true s-mk-seq s-mk-and s-mk-or
nm ...))))))
;; Creating the standard parser
(setup-parser <p-define> <p-lambda> <fail> <p-cc> <succeds> .. xx
X XL ((N 0) (M 0))
s-false s-true s-mk-seq s-mk-and s-mk-or)
\ No newline at end of file
......@@ -617,6 +617,29 @@ void gp_sweep_handle(SCM in)
pt[-2] = SCM_BOOL_F;
pt[-3] = SCM_BOOL_F;
}
if(SCM_CONSP(*pt) &&
!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head))
{
SCM tag = SCM_CAR(*pt);
if(SCM_I_INUMP(tag))
{
if(SCM_UNPACK(tag) == gp_save_tag)
{
SCM_SETCDR(*pt, SCM_BOOL_F);
}
else
{
SCM_SETCDR(SCM_CDR(*pt), SCM_BOOL_F);
}
pt[-1] = SCM_BOOL_F;
pt[-2] = SCM_BOOL_F;
pt[-3] = SCM_BOOL_F;
}
}
pt -= 3;
}
}
......@@ -714,7 +737,7 @@ void gp_init_stacks()
SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
#define FUNC_NAME s_gp_gc
{
// return SCM_UNSPECIFIED;
//return SCM_UNSPECIFIED;
int mute = 0;
struct gp_stack *gp = get_gp();
gp_no_gc();
......@@ -783,10 +806,11 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
}
*/
if(pt1 < last_save || pt1 < last_redo)
if(pt1 <= last_save || pt1 <= last_redo)
mute = 1;
else
mute = 0;
//Sections that start with a save tag and ends with
if(!mute)
if(scm_is_false(*pt1))
......@@ -832,16 +856,12 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
scm_t_bits head = SCM_UNPACK(f[0]); \
if(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head)) \
{ \
if(mute) \
{ \
*pt2 = SCM_BOOL_F; \
} \
else \
{ \
f[1] = SCM_UNBOUND; \
pt2++; \
continue; \
} \
if(!mute) \
{ \
f[1] = SCM_UNBOUND; \
pt2++; \
continue; \
} \
} \
} \
\
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment