Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-24 04:25:06 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Cleaner flattening now that code generation has been fixed

Browse source
This commit is contained in:
Justin Ethier 2018-11-01 13:20:20 -04:00
parent 61d265c512
commit 5868cd448c
2 changed files with 22 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
flatten-seq.scm
View file

@ -3,37 +3,38 @@
(define sexp (define sexp
'(Cyc-seq '(Cyc-seq
(set! b '(#f . #f)) (set! b '(#f . #f))
((Cyc-seq (Cyc-seq
(set-car! a 1) (set-car! a 1)
((Cyc-seq (Cyc-seq
(set-cdr! a '(2)))))))) (set-cdr! a '(2))
((fnc a1 a2 a3))))))
;; Flatten a list containing subcalls of a given symbol. ;; Flatten a list containing subcalls of a given symbol.
;; For example, the expression: ;; For example, the expression:
;; ;;
;; '(Cyc-seq ;; '(Cyc-seq
;; (set! b '(#f . #f)) ;; (set! b '(#f . #f))
;; ((Cyc-seq ;; (Cyc-seq
;; (set-car! a 1) ;; (set-car! a 1)
;; ((Cyc-seq ;; (Cyc-seq
;; (set-cdr! a '(2))))))) ;; (set-cdr! a '(2))
;; ((fnc a1 a2 a3)))))
;; ;;
;; becomes: ;; becomes:
;; ;;
;; '(Cyc-seq ;; '(Cyc-seq
;; (set! b '(#f . #f)) ;; (set! b '(#f . #f))
;; (set-car! a 1) ;; (set-car! a 1)
;; (set-cdr! a '(2))) ;; (set-cdr! a '(2))
;; ((fnc a1 a2 a3)))
;; ;;
(define (flatten-subcalls sexp sym) (define (flatten-subcalls sexp sym)
(define (flat sexp acc) (define (flat sexp acc)
(cond (cond
((not (pair? sexp)) ((not (pair? sexp))
acc) acc)
((and (app? (car sexp)) ((and (tagged-list? sym (car sexp)))
(app? (caar sexp)) (flat (cdar sexp) acc))
(tagged-list? sym (caar sexp)))
(flat (cdaar sexp) acc))
(else ;;(pair? sexp) (else ;;(pair? sexp)
(flat (cdr sexp) (cons (car sexp) acc)))) (flat (cdr sexp) (cons (car sexp) acc))))
) )

16
scheme/cyclone/transforms.sld
View file

@ -814,27 +814,27 @@
;; ;;
;; '(Cyc-seq ;; '(Cyc-seq
;; (set! b '(#f . #f)) ;; (set! b '(#f . #f))
;; ((Cyc-seq ;; (Cyc-seq
;; (set-car! a 1) ;; (set-car! a 1)
;; ((Cyc-seq ;; (Cyc-seq
;; (set-cdr! a '(2))))))) ;; (set-cdr! a '(2))
;; ((fnc a1 a2 a3)))))
;; ;;
;; becomes: ;; becomes:
;; ;;
;; '(Cyc-seq ;; '(Cyc-seq
;; (set! b '(#f . #f)) ;; (set! b '(#f . #f))
;; (set-car! a 1) ;; (set-car! a 1)
;; (set-cdr! a '(2))) ;; (set-cdr! a '(2))
;; ((fnc a1 a2 a3)))
;; ;;
(define (flatten-subcalls sexp sym) (define (flatten-subcalls sexp sym)
(define (flat sexp acc) (define (flat sexp acc)
(cond (cond
((not (pair? sexp)) ((not (pair? sexp))
acc) acc)
((and (app? (car sexp)) ((and (tagged-list? sym (car sexp)))
(app? (caar sexp)) (flat (cdar sexp) acc))
(tagged-list? sym (caar sexp)))
(flat (cdaar sexp) acc))
(else ;;(pair? sexp) (else ;;(pair? sexp)
(flat (cdr sexp) (cons (car sexp) acc)))) (flat (cdr sexp) (cons (car sexp) acc))))
) )