1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
;; -*-theme-d-*-
;; Copyright (C) 2008-2013, 2021 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.
;; Expected results: translation and running OK
(define-proper-program (tests test5)
(import (standard-library core)
(standard-library console-io))
(define-param-proc my-map1 (%arg-type %result-type)
(((proc (:procedure (%arg-type) %result-type pure))
(arg-list (:uniform-list %arg-type)))
(:uniform-list %result-type)
pure)
(if (equal? arg-list null)
null
(let ((arg-list1
(cast (:nonempty-uniform-list %arg-type) arg-list)))
(cons (proc (car arg-list1))
(my-map1 proc (cdr arg-list1))))))
(declare my-member? (:procedure (<object> (:uniform-list <object>))
<boolean> pure))
(define my-member?
(lambda (((value <object>) (lst (:uniform-list <object>)))
<boolean> pure)
(if (equal? lst null)
#f
(let ((lst1 (cast (:nonempty-uniform-list <object>) lst)))
(or (equal? (car lst1) value)
(my-member? value (cdr lst1)))))))
(define-param-proc my-do-map (%arglist %result-type)
(((proc (:procedure ((splice %arglist)) %result-type pure))
(arg-lists (type-loop %argtype %arglist
(:uniform-list %argtype))))
(:uniform-list %result-type)
pure)
(if (my-member? null arg-lists)
null
(let* ((first-members0
(my-map1
(lambda (((lst (:uniform-list <object>))) <object> pure)
(let ((lst1
(cast (:nonempty-uniform-list <object>) lst)))
(car lst1)))
arg-lists))
(first-members (cast %arglist first-members0))
(new-value (apply proc first-members))
(tails0
(my-map1
(lambda (((lst (:uniform-list <object>)))
(:uniform-list <object>) pure)
(let ((lst1
(cast (:nonempty-uniform-list <object>) lst)))
(cdr lst1)))
arg-lists))
(tails (cast (type-loop %argtype %arglist
(:uniform-list %argtype))
tails0)))
(cons new-value
(my-do-map proc tails)))))
(define-param-proc my-map (%arglist %result-type)
(((proc (:procedure ((splice %arglist)) %result-type pure))
(arg-lists
(splice (type-loop %argtype %arglist
(:uniform-list %argtype)))))
(:uniform-list %result-type)
pure)
(my-do-map proc arg-lists))
(define display-list
(lambda (((lst (:uniform-list <object>))) <none> nonpure)
(console-display lst)
(console-newline)))
(define-param-proc make-my-pair (%type)
(((a %type) (b %type)) (:pair %type %type) pure)
(cons a b))
(define main
(lambda (() <integer> nonpure)
(let ((my-list1 (list 1.0 2.0 3.0 4.0 5.0))
(my-list2 (list 1.1 -3.4 12.0 4.1 6.8)))
(let ((new-list1 (my-map (param-proc-instance make-my-pair
<real>)
my-list1 my-list2))
(new-list2 (my-map (param-proc-dispatch make-my-pair
<real> <real>)
my-list1 my-list2)))
(display-list new-list1)
(display-list new-list2)))
0)))
|
