suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues4 Pull Requests1 Actions Packages Projects Releases Wiki Activity

Bug fixes concerning handling of rest elements when removing parts of code.

Browse Source
This commit is contained in:
Georges Dupéron 2017-05-15 22:52:06 +02:00
parent 35871c47c9
commit 4e19426d90
1 changed files with 64 additions and 52 deletions

116
diff1.rkt
View File

@ -39,31 +39,6 @@
#:style (style "dim" #:style (style "dim"
(list (css-addition the-css-addition))))) (list (css-addition the-css-addition)))))
(define-for-syntax (show-stx e)
(define (r e)
(cond
([syntax? e]
(display "#'")
(r (syntax-e e)))
[(pair? e)
(display "(")
(let loop ([e e])
(if (pair? e)
(begin (r (car e))
(display " ")
(loop (cdr e)))
(if (null? e)
(display ")")
(begin
(display ". ")
(r e)
(display ")")))))]
[else
(print (syntax->datum (datum->syntax #f e)))]))
(r e)
(newline)
(newline))
(define-syntax (hlite stx) (define-syntax (hlite stx)
(syntax-case stx () (syntax-case stx ()
[(self name guide1 . body) [(self name guide1 . body)
@ -203,6 +178,10 @@
(update-source-location body #:span 0)))] (update-source-location body #:span 0)))]
['() ['()
body]))) body])))
(define (stx-null? e)
(or (null? e)
(and (syntax? e)
(null? (syntax-e e)))))
(define new-executable-code (define new-executable-code
(let loop ([mode '=] (let loop ([mode '=]
[guide simplified-guide] [guide simplified-guide]
@ -211,52 +190,86 @@
[(cons (and new-mode (or '/ '= '- '+)) rest-guide) [(cons (and new-mode (or '/ '= '- '+)) rest-guide)
(loop new-mode rest-guide body)] (loop new-mode rest-guide body)]
[(cons car-guide rest-guide) [(cons car-guide rest-guide)
(define (do-append-last-acc last-acc acc)
;; When nothing is later added to acc, we can
;; simply put r as the last element of the
;; reversed acc. This allows r to be an
;; improper list.
;; do-append-last-acc is called when elements follow
;; the current value of last-acc.
(unless (syntax->list (datum->syntax #f last-acc))
(raise-syntax-error
'hlite
(format
(string-append
"the removal of elements caused a list with a"
"dotted tail to be spliced in a non-final position: ~a")
(syntax->datum (datum->syntax #f last-acc)))
stx))
(append (reverse (syntax->list (datum->syntax #f last-acc)))
acc))
(define loop2-result (define loop2-result
(let loop2 ([first-iteration? #t] (let loop2 ([first-iteration? #t]
[guide guide] [guide guide]
[body (if (syntax? body) (syntax-e body) body)] [body (if (syntax? body) (syntax-e body) body)]
[acc '()]) [acc '()]
[last-acc '()])
(cond (cond
[(and (pair? guide) [(and (pair? guide)
(memq (car guide) '(/ = - +))) (memq (car guide) '(/ = - +)))
(if first-iteration? (if (or first-iteration?
(eq? (car guide) mode))
(loop (car guide) (cdr guide) body) (loop (car guide) (cdr guide) body)
;; produce: (let ([r (loop (car guide) (cdr guide) body)])
;; (accumulated ... . rest) (if (stx-null? r)
(let ([r-acc (reverse acc)]) ;; produce: (accumulated ... . last-acc)
(append (append (reverse acc) last-acc)
r-acc ;; produce: (accumulated ... last-acc ... . rest)
(loop (car guide) (cdr guide) body))))] (let ([r-acc (reverse (do-append-last-acc
last-acc
acc))])
(append r-acc r)))))]
[(and (pair? guide) (pair? body)) [(and (pair? guide) (pair? body))
;; accumulate the first element of body, if mode is not '- ;; accumulate the first element of body, if mode is not '-
;; which means that the element should be removed. ;; which means that the element should be removed.
(loop2 #f (cond
(cdr guide) [(and (eq? mode '-)
(cdr body) (or (pair? (car body))
(cond (and (syntax? (car body))
[(and (eq? mode '-) (pair? (syntax-e (car body))))))
(or (pair? (car body)) (let ([r (loop mode (car guide) (car body))])
(and (syntax (car body)) (loop2 #f
(pair? (syntax-e (car body)))))) (cdr guide)
(let ([r (loop mode (car guide) (car body))]) (cdr body)
(append (if (syntax? r) (syntax->list r) r) (do-append-last-acc last-acc acc)
acc))] r))]
[(eq? mode '-) [(eq? mode '-)
acc] (loop2 #f
[else (cdr guide)
(cons (loop mode (car guide) (car body)) acc)]))] (cdr body)
acc
last-acc)]
[else
(loop2 #f
(cdr guide)
(cdr body)
(do-append-last-acc last-acc acc)
(list (loop mode (car guide) (car body))))])]
;; If body is not a pair, then we will treat it as an ;; If body is not a pair, then we will treat it as an
;; "improper tail" element, unless it is null? ;; "improper tail" element, unless it is null?
[(null? body) [(null? body)
;; produce: ;; produce:
;; ((accumulated ...)) ;; ((accumulated ...))
(let* ([r-acc (reverse acc)]) (let* ([r-acc (append (reverse acc) last-acc)])
r-acc)] r-acc)]
[else [else
;; produce: ;; produce:
;; (accumulated ... . improper-tail) ;; (accumulated ... . improper-tail)
(let* ([new-body (loop mode guide body)] (let* ([new-body (loop mode guide body)]
[r-acc+tail (append (reverse acc) new-body)]) [r-acc+tail (append
(reverse
(do-append-last-acc last-acc acc))
new-body)])
r-acc+tail)]))) r-acc+tail)])))
(if (syntax? body) (if (syntax? body)
(datum->syntax body loop2-result body body) (datum->syntax body loop2-result body body)
@ -266,7 +279,6 @@
['() ['()
body]))) body])))
;(show-stx #'body) ;(show-stx #'body)
(displayln new-body)
#`(begin #`(begin
#,(datum->syntax #,(datum->syntax
stx stx
@ -275,6 +287,6 @@
,#'name ,#'name
. ,(syntax-e new-body)) . ,(syntax-e new-body))
stx) stx)
(chunk #:save-as dommy name (chunk #:save-as dummy name
. #,new-executable-code)))])) . #,new-executable-code)))]))