From a545c1cbd7f59bc152af190407dde2b0ce4fab50 Mon Sep 17 00:00:00 2001 From: Linus Date: Tue, 9 Feb 2021 22:02:40 +0100 Subject: [PATCH] Fix a bug where simple loops did not bind let bindings correctly add check whether a loop clause exists to avoid the ultra-shit errors that happen if you accidentally write (up-form ...) --- goof-impl.scm | 12 ++++---- goof.scm | 83 +++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 87 insertions(+), 8 deletions(-) diff --git a/goof-impl.scm b/goof-impl.scm index 2db65cc..ae64b82 100644 --- a/goof-impl.scm +++ b/goof-impl.scm @@ -138,11 +138,11 @@ ;; For clause with a sequence creator. ((_ orig name l a v c r f ff ul uw ub uf ((:for id ids ... (iterator source ...)) clauses ...) . body) - (iterator ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff ul uw ub uf (clauses ...) . body)) + (valid-clause? iterator ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff ul uw ub uf (clauses ...) . body)) ;; accumulator clause ((_ orig name l a v c r f ff ul uw ub uf ((:acc id ids ... (accumulator source ...)) clauses ...) . body) - (accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff ul uw ub uf (clauses ...) . body)) + (valid-clause? accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff ul uw ub uf (clauses ...) . body)) ;; ERROR HANDLING? ((_ orig name l a v c r f ff ul uw ub uf (clause . rest) . body) @@ -464,10 +464,10 @@ (forify* o n (s ... :final expr) (clauses ...) . body)) ((_ o n (s ...) (:subloop clauses ...) . body) (forify* o n (s ... :subloop) (clauses ...) . body)) - ((_ o n (s ...) ((:let id id* ... expr) clauses ...) . body) - (forify* o n (s ... (:let id id* ... expr)) (clauses ...) . body)) - ((_ o n (s ...) ((:let* id id* ... expr) clauses ...) . body) - (forify* o n (s ... (:let* id id* ... expr)) (clauses ...) . body)) + ((_ o n (s ...) (:let (id id* ... expr) clauses ...) . body) + (forify* o n (s ... :let (id id* ... expr)) (clauses ...) . body)) + ((_ o n (s ...) (:let* (id id* ... expr) clauses ...) . body) + (forify* o n (s ... :let* (id id* ... expr)) (clauses ...) . body)) ((_ o n (s ...) ((%acc c-rest ...) clauses ...) . body) (forify* o n (s ... (:acc c-rest ...)) (clauses ...) . body)) ((_ o n (s ...) ((:acc c-rest ...) clauses ...) . body) diff --git a/goof.scm b/goof.scm index 01fd622..f1b22a9 100644 --- a/goof.scm +++ b/goof.scm @@ -32,10 +32,10 @@ (define-module (goof) #:use-module (goof helpers) #:use-module (goof ref-let) - #:use-module ((srfi srfi-1) #:select (circular-list)) + #:use-module (rnrs io simple) + #:use-module ((srfi srfi-1) #:select (circular-list find)) #:use-module ((srfi srfi-43) #:select (vector-copy vector-copy!)) #:use-module (srfi srfi-71) - #:use-module (rnrs io simple) #:use-module (ice-9 futures) #:export (loop @@ -75,13 +75,92 @@ hashing vectoring + ;; generator clauses in-cycle in-indexed + + ;; Syntax for adding clauses + register-loop-clause )) + ;; This contains the portable parts of goof-loop. (include "goof-impl.scm") +;; This part is only for an auxilary macro that checks whether the :for or :acc clause is +;; actually defined. The reason I use parameters here is because guile modules are immutable by +;; default and I had to wrap it in something. Paremeters are available in the default environment +;; boxer are not. +(define valid-for-clauses (make-parameter (list #'in #'in-list #'in-lists + #'in-vector #'in-reverse-vector + #'in-string #'in-reverse-string + #'in-hash + #'in-port + #'in-file + #'in-generator + #'up-from + #'down-from + ;; generator clauses + #'in-cycle + #'in-indexed + ))) +(define valid-acc-clauses (make-parameter (list #'folding + #'listing + #'listing-reverse + #'appending + #'appending-reverse + #'summing + #'multiplying + #'hashing + #'hashving + #'hashqing + #'vectoring + ))) + +(define (add-clause type form) + (cond ((eq? type 'for) + (valid-for-clauses (cons form (valid-for-clauses)))) + ((eq? type 'acc) + (valid-acc-clauses (cons form (valid-acc-clauses)))) + (else + (error "The argument type should be either 'acc or 'for")))) + +(define-syntax register-loop-clause + (syntax-rules () + ((_ type form) + (eval-when (expand load eval) + (add-clause type form))))) + + +;; Syntax (valid-clause? form rest ...) validates that it's first form is an already registered iterator +;; or accumulator. In guile we can do this by offloading all hard book-keeping to the hygienic +;; macro system. We simple store the syntax object of the iterator/accumulator and use +;; free-identifier=? to see if whatever iterator/accumulator used is actually defined. +(define-syntax valid-clause? + (lambda (stx) + (define (clause-defined? type binding) + (define searchee + (cond ((eq? 'for type) (valid-for-clauses)) + ((eq? 'acc type) (valid-acc-clauses)))) + (define (pred x) (free-identifier=? x binding)) + (find pred searchee)) + (syntax-case stx (:acc) + ((_ accumulator :acc one two original-syntax . rest) + (if (clause-defined? 'acc #'accumulator) + #'(accumulator :acc one two original-syntax . rest) + (syntax-violation (syntax->datum #'accumulator) + "Unknown accumulator in loop: " + #'original-syntax + #'accumulator))) + ((_ iterator one two original-syntax . rest) + (if (clause-defined? 'for #'iterator) + #'(iterator one two original-syntax . rest) + (syntax-violation (syntax->datum #'iterator) + "Unknown iterator in loop: " + #'original-syntax + #'iterator)))))) + + ;; Helper procedures for let-kw-form (define (syntax= s1 s2) (equal? (syntax->datum s1) (syntax->datum s2)))