bjoli/goof-loop
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Made all mutating accumulators visible in the body

Browse source 
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...
This commit is contained in:
Linus 2021-05-12 12:54:29 +02:00
parent 5d07594f53
commit cccc324ecd
2 changed files with 65 additions and 88 deletions
Download patch file Download diff file Expand all files Collapse all files

71
goof/iterators.scm
View file

@ -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!)

82
tests.scm
View file

@ -1,82 +1,5 @@
;; This testrunner is shamelessly stolen from rednosehacker.com
;; and is copyrighted as
;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2019 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2019 Jérémy Korwin-Zmijowski <jeremy@korwin-zmijowski.fr>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
;;
;; 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")