From cccc324ecd14325d9f2fe4c7eabd8bc217823d32 Mon Sep 17 00:00:00 2001 From: Linus Date: Wed, 12 May 2021 12:54:29 +0200 Subject: [PATCH] Made all mutating accumulators visible in the body Previously hashing and vectoring hid the resulting hash before the final-function. This is no longer the case. Also, now some of the tests work... --- goof/iterators.scm | 71 ++++++++++++++++++++++++++++++++++----- tests.scm | 82 ++-------------------------------------------- 2 files changed, 65 insertions(+), 88 deletions(-) diff --git a/goof/iterators.scm b/goof/iterators.scm index cfca749..a2f4807 100644 --- a/goof/iterators.scm +++ b/goof/iterators.scm @@ -176,8 +176,8 @@ ((ge index end)) ((var (r tmp index))) () - . rest)) - )) + . rest)))) + (define-syntax in-port (syntax-rules () @@ -257,6 +257,21 @@ (lambda () (g)))))) +(define (make-up-from-generator/bounded start limit step) + (lambda () + (if (>= start limit) + (eof-object) + (let ((res start)) + (set! start (+ start step)) + res)))) + +(define (make-up-from-generator/unbounded start step) + (lambda () + (let ((res start)) + (set! start (+ start step)) + res))) + + (define-syntax up-from (syntax-rules (:to :by) ((up-from :for (() . args) next . rest) @@ -279,7 +294,34 @@ ((up-from :for ((var) (start limit step)) next . rest) (next ((s start) (l limit) (e step)) ((var s (+ var e))) ((>= var l)) () () . rest)) ((up-from :for ((var) (start limit)) next . rest) - (up-from :for ((var) (start limit 1)) next . rest)))) + (up-from :for ((var) (start limit 1)) next . rest)) + ;; Generator clauses + ((up-from start (:to limit) (:by step)) + (make-up-from-generator/bounded start limit step)) + ((up-from start (:to limit)) + (make-up-from-generator/bounded start limit 1)) + ((up-from start (:by step)) + (make-up-from-generator/unbounded start step)) + ((up-from start) + (make-up-from-generator/unbounded start 1)) + ((up-from start limit step) + (make-up-from-generator/bounded start limit step)) + ((up-from start limit) (make-up-from-generator/bounded start limit 1)))) + + +(define (make-down-from-generator/bounded start end step) + (lambda () + (if (< start end) + (eof-object) + (let ((res start)) + (set! start (- start step)) + res)))) + +(define (make-down-from-generator/unbounded start step) + (lambda () + (let ((res start)) + (set! start (- start step)) + res))) (define-syntax down-from (syntax-rules (:to :by) @@ -302,7 +344,18 @@ ((down-from :for ((var) (start limit step)) next . rest) (next ((s start) (l limit) (e step)) ((var (- s e) (- var e))) ((< var l)) () () . rest)) ((down-from :for ((var) (start limit)) next . rest) - (down-from :for ((var) (start limit 1)) next . rest)))) + (down-from :for ((var) (start limit 1)) next . rest)) + ;;generator clauses + ((down-from start (:to limit) (:by step)) + (make-down-from-generator/bounded start limit step)) + ((down-from start (:to limit)) + (make-down-from-generator/bounded start limit 1)) + ((down-from start (:by step)) + (make-down-from-generator/unbounded start step)) + ((down-from start limit step) + (make-down-from-generator/bounded start limit step)) + ((down-from start limit) (make-down-from-generator/bounded start limit 1)) + ((down-from start) (make-down-from-generator/unbounded start 1)))) (define-syntax in-hash @@ -316,7 +369,7 @@ () . rest)) ((in-hash hash-expr) - (in-list :for (hash-map->list cons hash-expr))))) + (in-list (hash-map->list cons hash-expr))))) (define-syntax accumulating @@ -392,7 +445,7 @@ (define-syntax name (syntax-rules (:acc if initial) ((_ :acc ((var) (key value)) n . rest) - (name :acc ((var) (key value (if #t) (initial defualt-make))) n . rest)) + (name :acc ((var) (key value (if #t) (initial default-make))) n . rest)) ;; either init or if ((_ :acc ((var) (key value (if guard))) n . rest) (name :acc ((var) (key value (if guard) (initial default-make))) n . rest)) @@ -403,11 +456,11 @@ (name ((var) (key value (if guard) (initial init))) n . rest)) ((_ :acc ((var) (key value (if guard) (initial init))) n . rest) (n - ((hash init)) - ((dummy (if #f #f) (if guard (setter hash key value) (if #f #f)))) + ((var init)) + ((dummy (if #f #f) (if guard (setter var key value) (if #f #f)))) () () - ((var hash)) + ((var var)) . rest))))))) (define-hashing hashing (make-hash-table) hash-set!) diff --git a/tests.scm b/tests.scm index 4eed26c..1ca615a 100644 --- a/tests.scm +++ b/tests.scm @@ -1,82 +1,5 @@ -;; This testrunner is shamelessly stolen from rednosehacker.com -;; and is copyrighted as -;; Copyright © 2015, 2016 Mathieu Lirzin -;;; Copyright © 2019 Alex Sassmannshausen -;;; Copyright © 2019 Jérémy Korwin-Zmijowski -;;; -;;; This program is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . -;; -;; Thus, this file is under the GPL v.3 or any later version. - (use-modules (srfi srfi-64) - (goof) - (ice-9 pretty-print) - (srfi srfi-26)) - -(define* (test-display field value #:optional (port (current-output-port)) - #:key pretty?) - "Display 'FIELD: VALUE\n' on PORT." - (if pretty? - (begin - (format port "~A:~%" field) - (pretty-print value port #:per-line-prefix "+ ")) - (format port "~A: ~S~%" field value))) - -(define* (result->string symbol) - "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." - (let ((result (string-upcase (symbol->string symbol)))) - (string-append (case symbol - ((pass) "") ;green - ((xfail) "") ;light green - ((skip) "") ;blue - ((fail xpass) "") ;red - ((error) "")) ;magenta - result - ""))) - -(define* (test-runner-kata) - - (define (test-on-test-end-kata runner) - (let* ((results (test-result-alist runner)) - (result? (cut assq <> results)) - (result (cut assq-ref results <>))) - (if (equal? 'fail (result 'result-kind)) - (begin - (newline) - (format #t "~a ~A~%" - (result->string (result 'result-kind)) - (result 'test-name)) - (when (result? 'expected-value) - (test-display "expected-value" (result 'expected-value))) - (when (result? 'expected-error) - (test-display "expected-error" (result 'expected-error) #:pretty? #t)) - (when (result? 'actual-value) - (test-display "actual-value" (result 'actual-value))) - (when (result? 'actual-error) - (test-display "actual-error" (result 'actual-error) #:pretty? #t)) - (newline)) - (begin - (format #t "~a ~A~%" - (result->string (result 'result-kind)) - (result 'test-name)))))) - - (let ((runner (test-runner-null))) - (test-runner-on-test-end! runner test-on-test-end-kata) - runner)) - -(test-runner-current (test-runner-kata)) - + (goof)) (test-begin "basic workings") (test-equal @@ -193,7 +116,8 @@ (loop/list/parallel ((a (in-list '(1 2 3 4)))) (+ a 1)) '(2 3 4 5)) -(test-end "simple-forms") + +(test-end "simple forms") (test-begin ":for-clauses")