History

if: make the else a list of forms with implicit begin

Sigrid Solveig Haflínudóttir committed 1 year ago

Commit 235b9081 parent 69965463 files · +128 −129Browse files

Showing the changes to src (2 of 3 files). Show all

Unified · Split

2 files
  1. src/compiler.sl +88 −91
  2. src/system.sl +28 −27
src/compiler.sl+88−91
@@ -23,9 +23,9 @@ · 22 unmodified lines
23 (nconst (bcode:nconst b)))23 (nconst (bcode:nconst b)))
24 (if (has? const-to-idx v)24 (if (has? const-to-idx v)
25 (get const-to-idx v)25 (get const-to-idx v)
26 (begin (put! const-to-idx v nconst)26 (put! const-to-idx v nconst)
27 (prog1 nconst27 (prog1 nconst
28 (aset! b 2 (+ nconst 1)))))))28 (aset! b 2 (+ nconst 1))))))
29 29
30(def (emit e inst . args)30(def (emit e inst . args)
31 (def (load? i)31 (def (load? i)
@@ -39,37 +39,36 @@ · 7 unmodified lines
39 (aset! e 0 (cdr bc)))39 (aset! e 0 (cdr bc)))
40 (else40 (else
41 (aset! e 0 (cons inst bc)))))41 (aset! e 0 (cons inst bc)))))
42 (begin42 (when (memq inst '(loadv loadg setg))
43 (when (memq inst '(loadv loadg setg))43 (set! args (list (bcode:indexfor e (car args)))))
44 (set! args (list (bcode:indexfor e (car args)))))44 (let ((longform
45 (let ((longform45 (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
46 (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)46 (loada loada.l) (seta seta.l) (box box.l)))))
47 (loada loada.l) (seta seta.l) (box box.l)))))47 (when (and longform (> (car args) 255))
48 (when (and longform (> (car args) 255))48 (set! inst (cadr longform))))
49 (set! inst (cadr longform))))49 (let ((longform
50 (let ((longform50 (assq inst '((loadc loadc.l)))))
51 (assq inst '((loadc loadc.l)))))51 (when (and longform (> (car args) 255))
52 (when (and longform (> (car args) 255))52 (set! inst (cadr longform))))
53 (set! inst (cadr longform))))53 (if (eq? inst 'loada)
54 (if (eq? inst 'loada)54 (cond ((equal? args '(0))
55 (set! inst 'loada0 args NIL))
56 ((equal? args '(1))
57 (set! inst 'loada1 args NIL)))
58 (when (eq? inst 'loadc)
55 (cond ((equal? args '(0))59 (cond ((equal? args '(0))
56 (set! inst 'loada0 args NIL))60 (set! inst 'loadc0 args NIL))
57 ((equal? args '(1))61 ((equal? args '(1))
58 (set! inst 'loada1 args NIL)))62 (set! inst 'loadc1 args NIL)))))
59 (when (eq? inst 'loadc)63 (let ((lasti (car bc)))
60 (cond ((equal? args '(0))64 (cond ((and (eq? inst 'brn)
61 (set! inst 'loadc0 args NIL))65 (cond ((eq? lasti 'not)
62 ((equal? args '(1))66 (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
63 (set! inst 'loadc1 args NIL)))))67 ((eq? lasti 'eq?)
64 (let ((lasti (car bc)))68 (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
65 (cond ((and (eq? inst 'brn)69 (else NIL))))
66 (cond ((eq? lasti 'not)70 (else
67 (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))71 (aset! e 0 (nreconc (cons inst args) bc))))))
68 ((eq? lasti 'eq?)
69 (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
70 (else NIL))))
71 (else
72 (aset! e 0 (nreconc (cons inst args) bc)))))))
73 e))72 e))
74 73
75(defmacro (make-label e) `(gensym))74(defmacro (make-label e) `(gensym))
@@ -97,47 +96,46 @@ · 21 unmodified lines
97 (if (eq? vi 'label)96 (if (eq? vi 'label)
98 (begin (put! label-to-loc (aref v (+ i 1)) (size-of bcode))97 (begin (put! label-to-loc (aref v (+ i 1)) (size-of bcode))
99 (set! i (+ i 2)))98 (set! i (+ i 2)))
100 (begin99 (io-write bcode
101 (io-write bcode100 (get Instructions
102 (get Instructions101 (if long?
103 (if long?102 (case vi
104 (case vi103 (jmp 'jmp.l)
105 (jmp 'jmp.l)104 (brne 'brne.l)
106 (brne 'brne.l)105 (brnn 'brnn.l)
107 (brnn 'brnn.l)106 (brn 'brn.l)
108 (brn 'brn.l)107 (else vi))
109 (else vi))108 vi)))
110 vi)))109 (set! i (+ i 1)
111 (set! i (+ i 1)110 nxt (and (< i n) (aref v i)))
112 nxt (and (< i n) (aref v i)))111 (cond ((memq vi '(jmp brne brnn brn))
113 (cond ((memq vi '(jmp brne brnn brn))112 (put! fixup-to-label (size-of bcode) nxt)
114 (put! fixup-to-label (size-of bcode) nxt)113 (io-write bcode ((if long? s32 s16) 0))
115 (io-write bcode ((if long? s32 s16) 0))114 (set! i (+ i 1)))
116 (set! i (+ i 1)))115 ((eq? vi 'bounda)
117 ((eq? vi 'bounda)116 (io-write bcode (s32 nxt) :little-endian)
118 (io-write bcode (s32 nxt) :little-endian)117 (set! i (+ i 1)))
119 (set! i (+ i 1)))118 ((num? nxt)
120 ((num? nxt)119 (case vi
121 (case vi120 ((loadv.l loadg.l setg.l loada.l seta.l
122 ((loadv.l loadg.l setg.l loada.l seta.l121 argc.l vargc.l call.l tcall.l loadc.l box.l)
123 argc.l vargc.l call.l tcall.l loadc.l box.l)122 (io-write bcode (s32 nxt) :little-endian)
124 (io-write bcode (s32 nxt) :little-endian)123 (set! i (+ i 1)))
125 (set! i (+ i 1)))124
126 125 ((optargs keyargs) ; 2 s32 args
127 ((optargs keyargs) ; 2 s32 args126 (io-write bcode (s32 nxt) :little-endian)
128 (io-write bcode (s32 nxt) :little-endian)127 (set! i (+ i 1))
129 (set! i (+ i 1))128 (io-write bcode (s32 (aref v i)) :little-endian)
129 (set! i (+ i 1))
130 (when (eq? vi 'keyargs)
130 (io-write bcode (s32 (aref v i)) :little-endian)131 (io-write bcode (s32 (aref v i)) :little-endian)
131 (set! i (+ i 1))132 (set! i (+ i 1))))
132 (when (eq? vi 'keyargs)
133 (io-write bcode (s32 (aref v i)) :little-endian)
134 (set! i (+ i 1))))
135 133
136 (else134 (else
137 ; other number arguments are always u8135 ; other number arguments are always u8
138 (io-write bcode (u8 nxt))136 (io-write bcode (u8 nxt))
139 (set! i (+ i 1)))))137 (set! i (+ i 1)))))
140 (else NIL)))))138 (else NIL))))
141 139
142 (for-each140 (for-each
143 (λ (addr labl)141 (λ (addr labl)
@@ -242,9 +240,9 @@ · 98 unmodified lines
242 (compile-in g env NIL rhs)240 (compile-in g env NIL rhs)
243 (bcode:stack g -1)241 (bcode:stack g -1)
244 (emit g 'set-car!))242 (emit g 'set-car!))
245 (begin (compile-in g env NIL rhs)243 (compile-in g env NIL rhs)
246 (unless arg? (error (str "internal error: misallocated var " s)))244 (unless arg? (error (str "internal error: misallocated var " s)))
247 (emit g 'seta idx)))))))245 (emit g 'seta idx))))))
248 246
249(def (box-vars g env)247(def (box-vars g env)
250 (let loop ((e env))248 (let loop ((e env))
@@ -457,19 +455,19 @@ · 206 unmodified lines
457 (begin (let {[nargs (compile-arglist g env (cdr x))]}455 (begin (let {[nargs (compile-arglist g env (cdr x))]}
458 (bcode:stack g (- nargs))456 (bcode:stack g (- nargs))
459 (compile-builtin-call g env tail? x head b nargs)))457 (compile-builtin-call g env tail? x head b nargs)))
460 (begin (compile-in g env NIL head)458 (compile-in g env NIL head)
461 (bcode:stack g 1)459 (bcode:stack g 1)
462 (let* {[nargs (compile-arglist g env (cdr x))]460 (let* {[nargs (compile-arglist g env (cdr x))]
463 [loc (and (sym? head) (lookup-sym head env 0))]461 [loc (and (sym? head) (lookup-sym head env 0))]
464 [fn (and (eq? loc 'global) (bound? head) (top-level-value head))]462 [fn (and (eq? loc 'global) (bound? head) (top-level-value head))]
465 [code (and (closure? fn) (fn-code fn))]463 [code (and (closure? fn) (fn-code fn))]
466 [argc? (and code (= (aref code 0) (get Instructions 'argc)))]464 [argc? (and code (= (aref code 0) (get Instructions 'argc)))]
467 [argc (and argc? (aref code 1))]}465 [argc (and argc? (aref code 1))]}
468 (unless (or (not argc) (= argc nargs))466 (unless (or (not argc) (= argc nargs))
469 (compile-error "arity error: expected " argc ", got " nargs))467 (compile-error "arity error: expected " argc ", got " nargs))
470 (bcode:stack g (- nargs))468 (bcode:stack g (- nargs))
471 (bcode:stack g -1)469 (bcode:stack g -1)
472 (emit g (if tail? 'tcall 'call) nargs))))))))470 (emit g (if tail? 'tcall 'call) nargs)))))))
473 471
474;; lambda, main compilation loop472;; lambda, main compilation loop
475 473
@@ -738,10 +736,9 @@ · 262 unmodified lines
738 (if (not kwa)736 (if (not kwa)
739 (emit g 'optargs nreq737 (emit g 'optargs nreq
740 (if atail (- nargs) nargs))738 (if atail (- nargs) nargs))
741 (begin739 (bcode:indexfor g (map 'vec car kwa))
742 (bcode:indexfor g (map 'vec car kwa))740 (emit g 'keyargs nreq nkwa
743 (emit g 'keyargs nreq nkwa741 (if atail (- nargs) nargs))))
744 (if atail (- nargs) nargs)))))
745 742
746 (cond ((> nargs 255) (emit g (if atail 'vargc.l 'argc.l) nargs))743 (cond ((> nargs 255) (emit g (if atail 'vargc.l 'argc.l) nargs))
747 (atail (emit g 'vargc nargs))744 (atail (emit g 'vargc nargs))
src/system.sl+28−27
@@ -170,14 +170,13 @@ · 169 unmodified lines
170 (print-type term)170 (print-type term)
171 (newline))171 (newline))
172 sigs)172 sigs)
173 (begin173 (princ lpad)
174 (princ lpad)174 (if kind
175 (if kind175 (begin (princ (caddr term))
176 (begin (princ (caddr term))176 (print-type "doc group"))
177 (print-type "doc group"))177 (print term)
178 (begin (print term)178 (print-type term))
179 (print-type term)))179 (newline))
180 (newline)))
181 (newline))180 (newline))
182 181
183(defmacro (help topic (:print-header help-print-header) . rest)182(defmacro (help topic (:print-header help-print-header) . rest)
@@ -234,9 +233,9 @@ · 50 unmodified lines
234 (princ lpad)233 (princ lpad)
235 (princ (cons term sig)))234 (princ (cons term sig)))
236 sigs)235 sigs)
237 (begin (newline)236 (newline)
238 (princ lpad)237 (princ lpad)
239 (princ term))))238 (princ term)))
240 (def (first-line s)239 (def (first-line s)
241 (str-sub s 0 (str-find s "\n")))240 (str-sub s 0 (str-find s "\n")))
242 (def (doc-group? k)241 (def (doc-group? k)
@@ -1325,9 +1324,8 @@ · 1082 unmodified lines
1325 (reverse! acc)1324 (reverse! acc)
1326 (if (has? ta (car l))1325 (if (has? ta (car l))
1327 (loop (cdr l) acc)1326 (loop (cdr l) acc)
1328 (begin1327 (put! ta (car l) T)
1329 (put! ta (car l) T)1328 (loop (cdr l) (cons (car l) acc)))))))
1330 (loop (cdr l) (cons (car l) acc))))))))
1331 1329
1332(def (find-if pred lst (:key identity)1330(def (find-if pred lst (:key identity)
1333 (:start 0)1331 (:start 0)
@@ -1793,16 +1791,16 @@ · 459 unmodified lines
1793 (newline)1791 (newline)
1794 'ignored1792 'ignored
1795 'done)1793 'done)
1796 (begin (print 0)1794 (print 0)
1797 (newline)1795 (newline)
1798 'else))1796 'else)
1799 ; ‼ 11797 ; ‼ 1
1800 ; ↳ done»1798 ; ↳ done»
1801 :doc-group syntax1799 :doc-group syntax
1802 :doc-see prog11800 :doc-see prog1
1803 (cons '$begin body))1801 (cons '$begin body))
1804 1802
1805(defmacro (if cond then else)1803(defmacro (if cond then . else)
1806 «Return the result of `then` if `cond` evaluated as "true", `else`1804 «Return the result of `then` if `cond` evaluated as "true", `else`
1807 otherwise.1805 otherwise.
1808 1806
@@ -1813,14 +1811,18 @@ · 4 unmodified lines
1813 Examples:1811 Examples:
1814 1812
1815 (def x '(1))1813 (def x '(1))
1816 (if x 'yes 0)1814 (if x (begin (print "yep!") (newline) 'yes) 0)
1815 ; ‼ yep!
1817 ; ↳ yes1816 ; ↳ yes
1818 (if (str? x) 1 'no)1817 (if (str? x) 1 (print "nope!") (newline) 'no)
1818 ; ‼ nope!
1819 ; ↳ no»1819 ; ↳ no»
1820 :doc-group syntax1820 :doc-group syntax
1821 :doc-see when1821 :doc-see when
1822 :doc-see unless1822 :doc-see unless
1823 (list '$if cond then else))1823 (unless else
1824 (arg-error "if without an else branch"))
1825 (list '$if cond then (cons 'begin else)))
1824 1826
1825(defmacro (when cond . body)1827(defmacro (when cond . body)
1826 «Shorthand for `(if cond body NIL)`.1828 «Shorthand for `(if cond body NIL)`.
@@ -2010,9 +2012,8 @@ · 183 unmodified lines
2010 (if ,test-expr2012 (if ,test-expr
2011 (begin2013 (begin
2012 ,@(cdr test-spec))2014 ,@(cdr test-spec))
2013 (begin2015 ,@commands
2014 ,@commands2016 (loop# ,.steps)))))
2015 (loop# ,.steps))))))
2016 (loop# ,.inits))))2017 (loop# ,.inits))))
2017 2018
2018; SRFI 82019; SRFI 8
@@ -3073,9 +3074,9 @@ · 1054 unmodified lines
3073 (when (void? v)3074 (when (void? v)
3074 (*prompt*)3075 (*prompt*)
3075 (io-flush *io-out*))3076 (io-flush *io-out*))
3076 (begin (print V)3077 (print V)
3077 (set! that V)3078 (set! that V)
3078 (newline)))3079 (newline))
3079 #.(void)))))3080 #.(void)))))
3080 (def (reploop)3081 (def (reploop)
3081 (when (trycatch (prompt)3082 (when (trycatch (prompt)

Keyboard shortcuts

General

Show keyboard shortcuts
?
Focus the current search
/

Issues and pull requests

Open filters
f

Issues, pull requests and Inbox

Select next item
j↓
Select previous item
k↑
Open selected item
Enter
Dismiss filters or clear selection
Esc

Repository code

Go to file
t