artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mes: Support map and for-each with lists of unequal length.

Browse source 
* mes/module/mes/base.mes (map): Support lists of unequal length.
* mes/module/mes/scm.mes (for-each): Likewise.
* module/mescc/compile.scm (expr->register): Fix compile warning.
* tests/scm.test ("map 1,2", "map 2,1", "for-each 1,2", "for-each
2,1": Test it.
This commit is contained in:
Jan Nieuwenhuizen 2019-03-02 14:33:58 +01:00
parent 757d603e4c
commit 90b384def3
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
4 changed files with 30 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
mes/module/mes/base.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -126,7 +126,9 @@
(#t #f)))
(define (map f h . t)
(if (null? h) '()
(if (or (null? h)
(and (pair? t) (null? (car t)))
(and (pair? t) (pair? (cdr t)) (null? (cadr t)))) '()
(if (null? t) (cons (f (car h)) (map f (cdr h)))
(if (null? (cdr t))
(cons (f (car h) (caar t)) (map f (cdr h) (cdar t)))

11
mes/module/mes/scm.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -56,9 +56,12 @@
,@body
(loop ,@(cddar init)))))
(define (for-each f l . r)
(if (pair? l) (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
(if (null? (cdr r)) (begin (f (car l) (caar r)) (for-each f (cdr l) (cdar r)))))))
(define (for-each f l . xr)
(if (and (pair? l)
(or (null? xr)
(pair? (car xr))))
(if (null? xr) (begin (f (car l)) (for-each f (cdr l)))
(if (null? (cdr xr)) (begin (f (car l) (caar xr)) (for-each f (cdr l) (cdar xr)))))))
(define core:error error)

3
module/mescc/compile.scm
View file

@ -1,5 +1,5 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -911,6 +911,7 @@
((p-expr (fixed ,value))
(let* ((value (cstring->int value))
(reg-size (->size "*" info))
(info (allocate-register info))
(info (append-text info (wrap-as (as info 'value->r value)))))
(if (or #t (> value 0) (= reg-size 4)) info

18
tests/scm.test
View file

@ -9,7 +9,7 @@ exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -46,7 +46,23 @@ exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot
(pass-if "map" (sequal? (map identity '(1 2 3 4)) '(1 2 3 4)))
(pass-if "map 2 " (sequal? (map (lambda (i a) (cons i a)) '(1 2 3 4) '(a b c d))
'((1 . a) (2 . b) (3 . c) (4 . d))))
(pass-if-equal "map 1,2"
'((0 . a))
(map (lambda (x y) (cons x y)) '(0) '(a b)))
(pass-if-equal "map 2,1"
'((0 . a))
(map (lambda (x y) (cons x y)) '(0 1) '(a)))
(pass-if "for-each" (sequal? (let ((acc '())) (for-each (lambda (x) (set! acc (cons x acc))) '(1 2 3 4)) acc) '(4 3 2 1)))
(pass-if "for-each 1,2"
(for-each (lambda (x y) (cons x y)) '(0) '(a b)))
(pass-if "for-each 2,1"
(for-each (lambda (x y) (cons x y)) '(0 1) '(a)))
(define xxxa 0)
(pass-if "set! " (seq? (begin (set! xxxa 1) xxxa) 1))
(pass-if "set! 2" (seq? (let ((a 0)) (set! a 1) a) 1))