ref: 55b73ae9d6016819d0f17a3b0ac4b10d0f34ee80
parent: 6b4240737bd6f0f7337a4655c827148ebba17f02
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Thu Apr 17 17:30:36 EDT 2025
system, compiler: simplify: stacktrace, list->vec, vec->list, encode-byte-code
--- a/boot/sl.boot
+++ b/boot/sl.boot
@@ -252,8 +252,8 @@
for-each)
#fn("n2A10p:")) const-to-idx-vec) copy-tree #fn("n10H3400:700<51700=51P:" #(copy-tree) copy-tree) count-82KM@408263:" #() count-)) count)
- delete-duplicates #fn("n1700rD523O02150Ib686228586>2_486<^10q62:0H3400:0<0=73858652390748661:85748651P:" #(length>+82KM@408263:" #() count-)) count)
+ delete-duplicates #fn("n1700rD523O02150Ib686228586>2_486<^10q62:0H3400:0<0=73858652390748661:85748651P:" #(length>7523A078082<52e1?2@30q42912:52893D02;82<L23:089T?1@30q^142912<52893D02;82<L23:089T?1@30q^1412=C\\0822>d3=02??14q?2@F0822@d3=02A?14q?2@30q@30q412BC\\0822>d3=02C?14q?2@F0822@d3=02D?14q?2@30q@30q488<12EQ;3b04892FCB00E82<2G88=PPp@J0892HCB00E82<2I88=PPp@30q;J@040E7J182P8852p^140:" #(#0#
#fn("n17002162:" #(member (load0 load1 loadt loadf loadnil loadvoid)) load?) car cdr cadr pop #fn(memq)(loadv loadg setg) bcode:indexfor #fn(assq) ((loadv loadv.l) (loadg loadg.l) (setg setg.l) (loada
@@ -325,7 +325,7 @@
2:" #(map-int
identity) iota)
keyword->sym #fn("n1200513K021220512386K24865153^161:0:" #(#fn(keyword?)- #fn(str-sub)
+ #fn(str-sub)
#fn(str-sub)
#fn(str-length)) keyword->sym)
keyword-arg? #fn("n10B;3904200<61:" #(#fn(keyword?)) keyword-arg?) lambda-vars@@ -411,8 +411,8 @@
0732L88<52@\xaf0872MCR0732N88<513702O@402P5147<88<51@\x880872QCB0732R5147388f2@q0872SCB0732T5147388f2@Z0872UQ;J804872VQ3;07388f2@?0732W5147<865147X60:" #(list?
#fn(io?) caar princ #fn(io-filename) ":" caddr ": " type-error "type error: expected " ", got "
#fn(type-of) print bounds-error "index " " out of bounds for " unbound-error "eval: variable " " has no value"
-bounds-error "index " " out of bounds for " unbound-error "eval: variable " " has no value"
- error "error: " load-error print-exception parse-error "parsing error: " arg-error "arguments error: "
+bounds-error "index " " out of bounds for " unbound-error "eval: variable " " has no value"
+ error "error: " load-error print-exception parse-error "parsing error: " arg-error "arguments error: "
und: " const-error #fn(keyword?)
"keywords are read-only: " "tried to modify a constant: " io-error "I/O error: " assert-failed "assertion failed: "
divide-error memory-error "*** Unhandled exception: " newline) print-exception)
@@ -512,12 +512,8 @@
#fn("n320A1063:" #(#fn(put!)))) table-invert) table-keys #fn("n12021q063:" #(#fn(table-foldl) #fn("n3082P:")) table-keys)-63:" #(#fn(table-foldl)
- #fn("n301P82P:")) table-pairs)- table-values #fn("n12021q063:" #(#fn(table-foldl)- #fn("n3182P:")) table-values)- to-proper #fn("n10J400:0H3600e1:0<700=51P:" #(to-proper) to-proper)- top-level-exception-handler #fn("n17071w042285>1230>12486>1{86504:" #(*io-out* *stderr*+63:" #(#fn(table-foldl)
+ #fn("n301P82P:")) table-pairs) #fn("n0Aw0:" #(*io-out*)) #fn("n070A51471225061:" #(print-exception print-stack-trace #fn(stacktrace))) #fn("n1A50420061:" #(#fn(raise)))) top-level-exception-handler)--- a/src/compiler.sl
+++ b/src/compiler.sl
@@ -75,74 +75,74 @@
;; convert symbolic bytecode representation to a byte array.
;; labels are fixed-up.
(def (encode-byte-code e)
- (let* ((cl (reverse! e))
- (v (list->vec cl))
- (long? (>= (+ (length v) ;; 1 byte for each entry, plus...
- ;; at most half the entries in this vector can be
- ;; instructions accepting 32-bit arguments
- (* 3 (div0 (length v) 2)))
- 65536)))
- (let ((n (length v))
- (i 0)
- (label-to-loc (table))
- (fixup-to-label (table))
- (bcode (buffer))
- (vi NIL)
- (nxt NIL))
- (while (< i n)
- (set! vi (aref v i))
- (if (eq? vi 'label)
- (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
- (set! i (+ i 2)))
- (begin
- (io-write bcode
- (get Instructions
- (if long?
- (case vi
- (jmp 'jmp.l)
- (brne 'brne.l)
- (brnn 'brnn.l)
- (brn 'brn.l)
- (else vi))
- vi)))
- (set! i (+ i 1))
- (set! nxt (and (< i n) (aref v i)))
- (cond ((memq vi '(jmp brne brnn brn))
- (put! fixup-to-label (sizeof bcode) nxt)
- (io-write bcode ((if long? s32 s16) 0))
- (set! i (+ i 1)))
- ((eq? vi 'bounda)
- (io-write bcode (s32 nxt))
- (set! i (+ i 1)))
- ((num? nxt)
- (case vi
- ((loadv.l loadg.l setg.l loada.l seta.l
- argc.l vargc.l call.l tcall.l loadc.l box.l)
- (io-write bcode (s32 nxt))
- (set! i (+ i 1)))
+ (let* {[cl (reverse! e)]+ [v (list->vec cl)]
+ [n (length v)]
+ [long? (>= (+ n ;; 1 byte for each entry, plus...
+ ;; at most half the entries in this vector can be
+ ;; instructions accepting 32-bit arguments
+ (* 3 (div0 n 2)))
+ 65536)]
+ [label-to-loc (table)]
+ [fixup-to-label (table)]
+ [bcode (buffer)]
+ [vi NIL]
+ [nxt NIL]
+ [i 0]}
+ (while (< i n)
+ (set! vi (aref v i))
+ (if (eq? vi 'label)
+ (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
+ (set! i (+ i 2)))
+ (begin
+ (io-write bcode
+ (get Instructions
+ (if long?
+ (case vi
+ (jmp 'jmp.l)
+ (brne 'brne.l)
+ (brnn 'brnn.l)
+ (brn 'brn.l)
+ (else vi))
+ vi)))
+ (set! i (+ i 1))
+ (set! nxt (and (< i n) (aref v i)))
+ (cond ((memq vi '(jmp brne brnn brn))
+ (put! fixup-to-label (sizeof bcode) nxt)
+ (io-write bcode ((if long? s32 s16) 0))
+ (set! i (+ i 1)))
+ ((eq? vi 'bounda)
+ (io-write bcode (s32 nxt))
+ (set! i (+ i 1)))
+ ((num? nxt)
+ (case vi
+ ((loadv.l loadg.l setg.l loada.l seta.l
+ argc.l vargc.l call.l tcall.l loadc.l box.l)
+ (io-write bcode (s32 nxt))
+ (set! i (+ i 1)))
- ((optargs keyargs) ; 2 s32 args
- (io-write bcode (s32 nxt))
- (set! i (+ i 1))
+ ((optargs keyargs) ; 2 s32 args
+ (io-write bcode (s32 nxt))
+ (set! i (+ i 1))
+ (io-write bcode (s32 (aref v i)))
+ (set! i (+ i 1))
+ (when (eq? vi 'keyargs)
(io-write bcode (s32 (aref v i)))
- (set! i (+ i 1))
- (when (eq? vi 'keyargs)
- (io-write bcode (s32 (aref v i)))
- (set! i (+ i 1))))
+ (set! i (+ i 1))))
- (else
- ; other number arguments are always u8
- (io-write bcode (u8 nxt))
- (set! i (+ i 1)))))
- (else NIL)))))
+ (else
+ ; other number arguments are always u8
+ (io-write bcode (u8 nxt))
+ (set! i (+ i 1)))))
+ (else NIL)))))
- (for-each
- (λ (addr labl)
- (io-seek bcode addr)
- (io-write bcode ((if long? s32 s16)
- (- (get label-to-loc labl) addr))))
- fixup-to-label)
- (io->str bcode))))
+ (for-each
+ (λ (addr labl)
+ (io-seek bcode addr)
+ (io-write bcode ((if long? s32 s16)
+ (- (get label-to-loc labl) addr))))
+ fixup-to-label)
+ (io->str bcode)))
(def (const-to-idx-vec e)
(let ((cvec (vec-alloc (bcode:nconst e))))
--- a/src/system.sl
+++ b/src/system.sl
@@ -960,24 +960,11 @@
;;; vector functions
(def (list->vec l)
- (apply vec l))
+ (map 'vec identity l))
(def (vec->list v)
- (let ((n (length v))
- (l NIL))
- (for 1 n
- (λ (i)
- (set! l (cons (aref v (- n i)) l))))
- l))
+ (map 'list identity v))
-(def (vec-map f v)
- (let* ((n (length v))
- (nv (vec-alloc n)))
- (for 0 (- n 1)
- (λ (i)
- (aset! nv i (f (aref v i)))))
- nv))
-
;;; table functions
(def (table-pairs ta)
@@ -1500,8 +1487,9 @@
(for-each
(λ (f)
(princ "(" (fname (aref f 1) e))- (for-each (λ (p) (princ " ") (print p))
- (cdr (cdr (vec->list f))))
+ (for 2 (1- (length f))
+ (λ (i) (princ " ")
+ (print (aref f i))))
(princ ")" *linefeed*)
(when (= n 0)
(fn-disasm (aref f 1) (aref f 0)))