From 3d2b30f5c8bfb4363eeb676257c738dd596e6191 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 27 Jul 2020 01:07:50 +0200 Subject: Merge mod!:s functionality into set! --- module/datetime.scm | 4 +-- module/output/terminal.scm | 4 +-- module/text/flow.scm | 4 +-- module/util.scm | 63 ++++++++++++++++------------------------------ module/vulgar/termios.scm | 1 + tests/recurrence.scm | 5 ++-- tests/termios.scm | 4 +-- tests/util.scm | 7 +++++- 8 files changed, 38 insertions(+), 54 deletions(-) diff --git a/module/datetime.scm b/module/datetime.scm index f20a6b8f..0a37f8df 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -1016,7 +1016,7 @@ (let ((sum 0)) (let ((time (fold (lambda (next done) (let* ((next-time rem (time+% done next))) - (mod! sum = (+ rem)) + (set! sum = (+ rem)) next-time)) base rest))) (values time sum)))) @@ -1066,7 +1066,7 @@ (let ((sum 0)) (let ((time (fold (lambda (next done) (let* ((next-time rem (time-% done next))) - (mod! sum = (+ rem)) + (set! sum = (+ rem)) next-time)) base rest))) (values time sum)))) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index 9092d01b..52d34331 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -142,9 +142,9 @@ (set! date (current-date) cur-event 0)) ((#\j #\J) (unless (= cur-event (1- (length events))) - (mod! cur-event 1+))) + (set! cur-event = (+ 1)))) ((#\k #\K) (unless (= cur-event 0) - (mod! cur-event 1-))) + (set! cur-event = (- 1)))) ((#\g) (set! cur-event 0)) ((#\G) (set! cur-event (1- (length events))))) diff --git a/module/text/flow.scm b/module/text/flow.scm index 3d97bed6..75ef5ccf 100644 --- a/module/text/flow.scm +++ b/module/text/flow.scm @@ -20,7 +20,7 @@ (string-concatenate/shared (merge words (map (lambda (n) (make-string n #\space)) space-list) - (let ((f #t)) (lambda _ (mod/r! f not))))))) + (let ((f #t)) (lambda _ (set/r! f = not))))))) @@ -32,7 +32,7 @@ (let* ((head tail (span (let ((w 0)) (lambda (word) ; Take words until we are above the limit. - (< (mod/r! w = (+ 1 (true-string-length word))) + (< (set/r! w = (+ 1 (true-string-length word))) width))) lst))) (cond ((null? tail) (list (unwords head))) ; Don't justify last line. diff --git a/module/util.scm b/module/util.scm index 62523167..04d13220 100644 --- a/module/util.scm +++ b/module/util.scm @@ -5,8 +5,8 @@ #:use-module ((sxml fold) #:select (fold-values)) #:use-module ((srfi srfi-9 gnu) #:select (set-fields)) #:re-export (define*-public fold-values) - #:export (for mod! sort* sort*! - mod/r! set/r! + #:export (for sort* sort*! + set/r! catch-multiple quote? re-export-modules @@ -190,50 +190,30 @@ ;; @end example ;; Still requires all variables to be defined beforehand. (define-syntax set! - (syntax-rules () + (syntax-rules (=) + ((_ field = (op args ...) rest ...) + (set! field (op field args ...) + rest ...)) + ((_ field = proc rest ...) + (set! field (proc field) + rest ...)) ((_ field val) ((@ (guile) set!) field val)) ((_ field val rest ...) (begin ((@ (guile) set!) field val) (set! rest ...))))) -(define-syntax modf% - (syntax-rules (=) - ((_ field = (op args ...)) - (set! field (op field args ...))) - ((_ field proc) - (set! field (proc field)))) ) - - -;; Like set!, but applies a transformer on the already present value. -(define-syntax mod! - (syntax-rules (=) - ((_) *unspecified*) - ((_ field = proc) - (modf% field = proc)) - - ((_ field = proc rest ...) - (begin (modf% field = proc) (mod! rest ...))) - - ((_ field proc) - (modf% field proc)) - - ((_ field proc rest ...) - (begin (modf% field proc) (mod! rest ...))))) - -(define-syntax-rule (set/r! args ... final) - (let ((val final)) - (set! args ... val) - val)) - -(define-syntax mod/r! - (syntax-rules (=) - ((_ args ... field = (proc pargs ...)) - (begin (mod! args ...) - (set/r! field (proc field pargs ...)))) - ((_ args ... ffield fproc) - (begin (mod! args ...) - (set/r! ffield (fproc ffield)))))) +;; only evaluates the final form once +(define-syntax set/r! + (syntax-rules () + ((_ args ... v = something) + (begin + (set! args ... v = something) + v)) + ((_ args ... final) + (let ((val final)) + (set! args ... val) + val)))) (define-syntax define-many @@ -481,8 +461,7 @@ (->> (func obj) rest ...)))) ;; Non-destructive set, syntax extension from set-fields from (srfi -;; srfi-9 gnu). Also doubles as a non-destructive mod!, if the `=' -;; operator is used. +;; srfi-9 gnu). (define-syntax set (syntax-rules (=) [(set (acc obj) value) diff --git a/module/vulgar/termios.scm b/module/vulgar/termios.scm index e3bbb99d..2e260e21 100644 --- a/module/vulgar/termios.scm +++ b/module/vulgar/termios.scm @@ -86,6 +86,7 @@ ((B115200) 115200) ((B230400) 230400))) + ;; TODO bit fields should display what their fields mean ((@ (srfi srfi-9 gnu) set-record-type-printer!) diff --git a/tests/recurrence.scm b/tests/recurrence.scm index a3720ce8..e73aa836 100644 --- a/tests/recurrence.scm +++ b/tests/recurrence.scm @@ -12,8 +12,7 @@ ((vcomponent base) make-vcomponent prop prop* extract) ((datetime) parse-ics-datetime datetime time date datetime->string) - ((util) -> mod!) - ((guile) set!) + ((util) -> set!) ((srfi srfi-41) stream->list) ((srfi srfi-88) keyword->string)) @@ -51,7 +50,7 @@ [else (cadr rem)])) ;; hack for multi valued fields (when (eq? symb 'EXDATE) - (mod! (prop* v symb) list))) + (set! (prop* v symb) = list))) (loop (cddr rem)))) v) diff --git a/tests/termios.scm b/tests/termios.scm index f07d20a0..3fed5da3 100755 --- a/tests/termios.scm +++ b/tests/termios.scm @@ -7,7 +7,7 @@ ;;; Code: -(((util) mod!) +(((util) set!) ((vulgar termios) make-termios copy-termios lflag @@ -22,7 +22,7 @@ (define tty (open-input-file "/dev/tty")) (define-syntax-rule (&= lvalue val) - (mod! lvalue (lambda (v) (& v val)))) + (set! lvalue = ((lambda (v) (& v val))))) (define t (make-termios)) diff --git a/tests/util.scm b/tests/util.scm index 33ebdcf6..6ad58a24 100644 --- a/tests/util.scm +++ b/tests/util.scm @@ -1,5 +1,10 @@ -(((util) filter-sorted)) +(((util) filter-sorted set/r!)) (test-equal "Filter sorted" '(3 4 5) (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10))) + +(test-equal "set/r! single" + #f + (let ((x #t)) + (set/r! x = not))) -- cgit v1.2.3