fix for making it work under guile-2.2

parent 2bac8b6c
......@@ -15,22 +15,22 @@ SOURCES = \
syntax/parse/src/kws.scm \
syntax/parse/src/rep-attrs.scm \
syntax/parse/src/runtime-progress.scm \
syntax/parse/src/with.scm \
syntax/parse/src/lib.scm \
syntax/parse/src/rep-data.scm \
syntax/parse/src/runtime.scm \
syntax/parse/src/runtime-reflect.scm \
syntax/parse/src/runtime-report.scm \
syntax/parse/src/litconv.scm \
syntax/parse/src/rep-patterns.scm \
syntax/parse/src/runtime.scm \
syntax/parse/src/parse.scm \
syntax/parse/src/rep.scm \
syntax/parse/src/sc.scm \
syntax/parse/debug.scm \
syntax/parse/kw-syntax-class.scm \
syntax/parse.scm \
syntax/parse/src/lib.scm \
syntax/parse/src/litconv.scm \
syntax/parse/src/with.scm \
syntax/parse/src/rep.scm \
syntax/parse_.scm \
compat/racket/lambda.scm \
syntax/parse.scm \
syntax/parse/debug.scm \
syntax/parse/kw-syntax-class.scm \
compat/racket/match/match.scm \
compat/racket/match/ext.scm \
compat/racket/match/lib.scm \
......
......@@ -216,7 +216,7 @@ AC_DEFUN([GUILE_PROGS],
fi
_guile_major_version=`$GUILE -c "(display (major-version))"`
_guile_minor_version=`$GUILE -c "(display (minor-version))"`
_guile_minor_version=`$GUILE -c "(display (+ 1 (string->number (minor-version))))"`
_guile_micro_version=`$GUILE -c "(display (micro-version))"`
_guile_prog_version="$_guile_major_version.$_guile_minor_version.$_guile_micro_version"
......
......@@ -21,22 +21,22 @@
(syntax-parse stx
((_ ((~or x:id k:kwt (xo:id vo)) ... . rest)
code ...)
(cond
(cond
((and (stx-pair? #'(k ...)) (stx-pair? #'(xo ...)))
#'(lambda* (x ...
#:optional (xo vo) ...
#:key (k.key-name k.kv) ... . rest)
(let ((k.i k.key-name) ...)
code ...)))
(let ((k.i k.key-name) ...)
code ...)))
((and (stx-pair? #'(k ...)) (stx-null? #'(xo ...)))
#'(lambda* (x ... #:key (k.key-name k.kv) ... . rest)
(let ((k.i k.key-name) ...)
code ...)))
(let ((k.i k.key-name) ...)
code ...)))
((and (stx-null? #'(k ...)) (stx-pair? #'(xo ...)))
#'(lambda* (x ... #:optional (xo vo) ... . rest)
code ...))
code ...))
(else
#'(lambda (x ... . rest) code ...)))))))
......@@ -210,18 +210,41 @@
((aif (it) p x)
(let ((it p)) (if it x)))))
(define (syntax-module x)
(if (syntax? x)
(let ((dir (cdr (vector-ref x 3))))
(resolve-module dir))
#f))
(cond-expand
(guile-2.0
(define (syntax-module x)
(if (syntax? x)
(let ((dir (cdr (vector-ref x 3))))
(resolve-module dir))
#f)))
(guile-2.2
(define syntax-module (@ (system syntax internal) syntax-module))))
(cond-expand
(guile-2.0
(define (syntax? x)
(and (vector? x) (eq? (vector-ref x 0) 'syntax-object))))
(guile-2.2
(define (syntax? x)
(or (and (vector? x)
(> (vector-length x) 0)
(eq? 'syntax-object (vector-ref x 0)))
((@ (system syntax internal) syntax?) x)))))
(define (syntax? x)
(and (vector? x) (eq? (vector-ref x 0) 'syntax-object)))
(cond-expand
(guile-2.0
(define syntax-expression (lambda (x) (vector-ref x 1))))
(guile-2.2
(define (syntax-expression x)
(if (and (vector? x)
(> (vector-length x) 0)
(eq? 'syntax-object (vector-ref x 0)))
(vector-ref x 1)
((@ (system syntax internal) syntax-expression) x)))))
(define (syntax-e x)
(if (syntax? x)
(vector-ref x 1)
(syntax-expression x)
x))
(define (keyword<? x y)
......@@ -312,7 +335,7 @@
(let loop ((r (lp x)))
(if (and (pair? r) (eq? (car r) 'macro))
(let ((r (cdr r)))
(if (rename-transformer? r)
(if (rename-transformer? r)
(loop (lp (r #t)))
r))
(if failure (failure) #f)))))
......@@ -357,7 +380,7 @@
[(_ f v code)
#'(let ((sym (gensym "x")))
(set-symbol-property! sym 'a v)
(with-syntax ((s sym))
(with-syntax ((s (datum->syntax #'f sym)))
#`(let-syntax ((f (make-syntax-mapping
(symbol-property 's 'a)
#f)))
......@@ -807,7 +830,7 @@
(define (pku x . l)
(apply pp (let loop ((x x))
(if (syntax? x)
`(syntax ,(loop (vector-ref x 1)))
`(syntax ,(loop (syntax-e x)))
(if (pair? x)
(cons (loop (car x)) (loop (cdr x)))
x)))
......@@ -848,35 +871,62 @@
l)
(apply string-append l))
(define (s-sharp x)
(let ((q (if (syntax? x) (syntax->datum x) x)))
(if (struct? q)
(let ((nm (struct-vtable-name (struct-vtable q)))
(l (struct->list q)))
`(,nm ,@l))
x)))
(define (s-sharp x)
(let ((q (if (syntax? x) (syntax->datum x) x)))
(if (struct? q)
(let ((nm (struct-vtable-name (struct-vtable q)))
(l (struct->list q)))
`(,nm ,@l))
x)))
(define (fix-mark x)
(define (unshift x)
(match x
(('shift . l)
(unshift l))
((a . l)
(let ((w (unshift l)))
(if (eq? w l)
x
(cons a w))))
(() '())))
(match x
[#(x y ((#f . top) . l) z)
(vector x y `(,top ,@(unshift l)) z)]
[#(a b (c . l) m)
(let ((w (unshift l)))
(if (eq? w l)
x
(vector a b (cons c w) m)))]))
(cond-expand
(guile-2.0
(define (fix-mark x)
(define (unshift x)
(match x
(('shift . l)
(unshift l))
((a . l)
(let ((w (unshift l)))
(if (eq? w l)
x
(cons a w))))
(() '())))
(match x
[#(x y ((#f . top) . l) z)
(vector x y `(,top ,@(unshift l)) z)]
[#(a b (c . l) m)
(let ((w (unshift l)))
(if (eq? w l)
x
(vector a b (cons c w) m)))])))
(guile-2.2
(define (fix-mark x)
(define (unshift x)
(match x
(('shift . l)
(unshift l))
((a . l)
(let ((w (unshift l)))
(if (eq? w l)
x
(cons a w))))
(() '())))
(let ((y ((@ (system syntax internal) syntax-expression) x))
(z ((@ (system syntax internal) syntax-wrap ) x))
(w ((@ (system syntax internal) syntax-module ) x)))
(match z
[((#f . top) . l)
((@ (system syntax internal) make-syntax)
y `(,top ,@(unshift l)) w)]
[(c . l)
(let ((w (unshift l)))
(if (eq? w l)
x
(((@ (system syntax internal) make-syntax)
y (cons c w) w))))])))))
(define (syntax-local-phase-level) 0)
......@@ -1145,6 +1195,16 @@
'v2.0)
((string-match "^2.1" v)
'v2.1)
((string-match "^2.2" v)
'v2.2)
((string-match "^2.3" v)
'v2.3)
((string-match "^2.4" v)
'v2.4)
((string-match "^2.5" v)
'v2.5)
((string-match "^3.0" v)
'v3.0)
(else #f)))))
(cond-expand
......
......@@ -138,8 +138,8 @@
(define (fp i) (f (car i) (cdr i)))
(apply append
(hash-map->list
(lambda (k v) (map fp v))
d)))
(lambda (k v) (map fp v))
d)))
(list-out
......@@ -169,8 +169,7 @@
bd
make-weak-key-hash-table)
(define (free-identifier->symbol id)
(syntax-e id))
(define (free-identifier->symbol id) (syntax-e id))
(make-code weak-free-id-table
free-identifier->symbol
......
......@@ -62,7 +62,7 @@
(define dens (map car den+defs-list))
(define defs (apply append (map cdr den+defs-list)))
(with-syntax (((rx ...) rxs)
(with-syntax (((rx ...) rxs)
(get-parsers
(datum->syntax stx (gensym "get-parsers")))
((def ...) defs)
......
......@@ -426,10 +426,10 @@ Conventions:
(values (syntax->pair x) x)
(values x cx))])
(if (pair? datum)
(let ([hx (car datum)]
(let ([hx (car datum)]
[hcx (car datum)]
[hpr (ps-add-car pr)]
[tx (cdr datum)]
[tx (cdr datum)]
[tpr (ps-add-cdr pr)])
(parse:S hx hcx head hpr es
(parse:S tx cx tail tpr es k)))
......
(define-module (syntax parse src runtime)
#:use-module (compat racket misc)
#:use-module (syntax parse src runtime-progress)
#:use-module (syntax parse src runtime-failure)
#:use-module (syntax parse src rep-data)
#:use-module (syntax parse src rep-attrs)
#:use-module (system syntax)
#:use-module ((system syntax) #:select (syntax-local-binding))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
......
......@@ -85,7 +85,7 @@
(list 'attrs ...)
(case (ver)
((v2.0) (datum->syntax #'name 'parser))
((v2.1) #'parser))
((v2.1 v2.2 v2.3 v2.4 v3.0) #'parser))
'splicing
'options
integrate))))
......@@ -101,7 +101,7 @@
(datum->syntax #'name 'parser)
(case (ver)
((v2.0) (datum->syntax #'name 'parser))
((v2.1) #'parser))
((v2.1 v2.2 v2.3 v2.4 v3.0) #'parser))
'splicing
'options
integrate))))))
......
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