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