blob: 75baeee3a87e74f0b2d8bdae1103808e13acf441 (
plain)
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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
;; -*- lisp -*-
;; file test1.melt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defprimitive == (a b) :long "((" a ") == (" b "))")
;; boolean not
(defprimitive not (:long i) :long "(!(" i "))")
(defprimitive is_closure (clo) :long
" (melt_magic_discr((" clo ")) == OBMAG_CLOSURE)")
;;;;; PAIR primitives
;; test
(defprimitive is_pair (pa) :long
"(melt_magic_discr((" pa ")) == OBMAG_PAIR)")
;; head
(defprimitive pair_head (pa) :value
"(melt_pair_head((" pa ")))")
;; tail
(defprimitive pair_tail (pa) :value
"(melt_pair_tail((" pa ")))")
(defprimitive make_multiple (discr :long ln) :value
"(meltgc_new_multiple((" discr "), (" ln ")))")
;; primitive to get the nth in a multiple
;(defprimitive multiple_nth (mul :long n) :value
; "(melt_multiple_nth((" mul "), (" n ")))")
;; primitive to get the length of a multiple
;(defprimitive multiple_length (v) :long
; "(melt_multiple_length((" v ")))")
(defprimitive multiple_put_nth (mul :long n :value v) :void
" meltgc_multiple_put_nth((" mul "), (" n "), (" v "))")
(defprimitive +i (:long a b) :long "((" a ") + (" b "))")
;(defprimitive -i (:long a b) :long "((" a ") - (" b "))")
;(defprimitive *i (:long a b) :long "((" a ") * (" b "))")
;;; translate a pairlist to a tuple - with each element transformed by a function f (default the identity)
(defun testandsetq (x y)
(if (and (is_pair x)
(== x y))
(setq x y)))
(defun tlamb_t2 (f_cl)
(lambda (y_arg)
(f_cl y_arg)))
(defprimitive tup1_pr2 (di t1) :value "meltgc_new_mult1((" di "), (" t1 "))")
(defprimitive mkint_t2 (:long a) :value "meltgc_new_int(MELT_PREDEF(DISCR_INTEGER),(" a "))")
(defclass my_class_root
:predef CLASS_ROOT
:fields (root_f1 root_f2))
(definstance ii my_class_root
:root_f1 (mkint_t2 1001))
(defun l2_t2 (x)
(let ( (y1
(tup1_pr2 x
(mkint_t2 3)))
(y2
(tup1_pr2 x y1)) )
(tup1_pr2 y1 y2)))
(defun coloopeven_t2 (x)
(if
(tup1_pr2 x :somekeyword)
(coloopodd_t2 x)
x))
(defun coloopodd_t2 (y)
(if
(tup1_pr2 y y)
(coloopeven_t2 y)
'qqq))
(defun tlet_t2 (u v)
(let ( (w (tup1_pr2 u u)) )
(tup1_pr2 w
(lambda (x)
(if (tup1_pr2 x w) x)))))
(defun and_t2 (x y z) (and x y z))
(defun ff_t2 (t u)
(tup1_pr2 t
(tup1_pr2 u u)))
(defun tif_t2 (x y)
(if (tup1_pr2 x y)
(let ( (z (ff_t2 x x)) )
(tup1_pr2 y z))
y)
)
(defun ifl2_t2 (x) (if x (l2_t2 x)))
(defun lam_t2 (x) (if (mkint_t2 x) (lambda (y) (l2_t2 (tup1_pr2 x y)))))
(defun ll_t2 (y) (lambda (x) (ff_t2 x y)))
(mkint_t2 1)
(l2_t2 (mkint_t2 2))
(defclass my_class_sub
:super my_class_root
:fields (sub_f3))
(definstance mysub_instance my_class_sub
:root_f1 and_t2
:sub_f3 (mkint_t2 3)
:obj_num 2345
)
(defun multiret_t2 (x)
(return x my_class_root my_class_sub))
(defun mi_t2 (v)
(make_instance my_class_root :root_f1 v))
(defun l2mi_t2 (v)
(l2_t2
(make_instance my_class_root :root_f1 v :root_f2 'quotedf2)))
(defun mi2_t2 (v)
(if (tup1_pr2 v my_class_root)
(make_instance my_class_root :root_f1 v)))
(defun fii_t2 (v) (if (tup1_pr2 v ii) v))
(let ((kk (mkint_t2 5))) (if (tup1_pr2 kk my_class_root) (mkint_t2 0)))
(defun n1234_t2 (f) (f 1234))
(defun xn23456_t2 (f x) (f x x 23456))
(defun tl_t2 (v) (let ((x3 (mkint_t2 3))) (tup1_pr2 v x3)))
(defun ts_t2 (v) (mkint_t2 1) (mkint_t2 2))
(defun mm_t2 (p)
(let ( (w (gg_t2 (gg_t2 p))) )
(if w (tup1_pr2 w p) p)))
(defun kk_t2 (u)
(forever
lo
(mkint_t2 u)
(exit lo u)
)
(tup1_pr2 u u)
)
(defun mc_t2 (z) (multicall (rv :long ri)
(ff_t2 z (tl_t2 z))
(tup1_pr2 rv (mkint_t2 ri))))
(defun gg_t2 (z) (setq z (if z gg_t2)) (ff_t2 z z))
(definstance t2inst my_class_root
:root_f1 gg_t2)
(definstance t2i1 my_class_root
:root_f1 (mkint_t2 1))
(definstance t2i2 my_class_root
:root_f1 (mkint_t2 1))
(definstance t2i3 my_class_root
:root_f1 (mkint_t2 3))
(defun ti_tk3 (x) (if (tup1_pr2 x t2i1) (if (tup1_pr2 x t2i2) (if (tup1_pr2 x t2i3) x))))
(defun ti_clo2 (x y z) (lambda (u) (lambda (v) (lambda (w) (w x y z)))))
(defun ti_t2 (z) (tup1_pr2 t2inst z))
(defun tj_t2 (u) (tup1_pr2 u my_class_root))
(defun testquotedsym () 'somesymbol)
(defun testquotedkeyword () ':akeyword)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#| ; SKIPPING
; SKIPPED |#
;; eof
|
