shithub: sl

Info  •  Files  •  Log  •  Branches

system.sl: expose sort to the world, lsd minor fixes

--- a/boot/sl.boot

+++ b/boot/sl.boot

@@ -316,21 +316,16 @@

                                                             print) print-val)

   #fn("n370A3U0FEl23N071A72151523A0A182ML237023@4024751K~512602765:" #(princ >= 1- " >" "  " hex5

                                                                        ":  " " ") print-inst)

- " ") print-inst)

-  #fn(length) #fn(table-foldl) #fn("n382;J@041AF<Gl2;34040:") Instructions #fn("n1702161:" #(princ

-  "\t")) #fn(memq) (loadv.l loadg.l setg.l) ref-s32-LE (loadv loadg setg)

-  (loada seta loadc call tcall list + - * / < = vec argc vargc loadi8 apply tapply closure box

-   shift aref) princ #fn(num->str) aref (loada.l seta.l loadc.l argc.l vargc.l call.l tcall.l box.l)

-  (optargs keyargs) keyargs " " brbound (jmp brne brnn brn) "@" hex5 ref-s16-LE (jmp.l brne.l

-                                                                                       brnn.l brn.l)) fn-disasm)

+ " ") print-inst)

+  #fn(length) #fn(table-foldl) #fn("n382;J@041AF<Gl2;34040:") Instructions #fn("n1702161:" #(princ

+  "\t")) #fn(memq) (loadv.l loadg.l setg.l) ref-s32-LE (loadv loadg setg)

+  (loada seta loadc call tcall list + - * / < = vec argc vargc loadi8 apply tapply closure box

 l) foldl) foldr

--vars #fn("n170A<05161:" #(delete-duplicates) #(#2=(#fn("n10H340q:0<20Cd00=B3^00TR;37040Te1;JM040TB;3E0471051R;3:0471051e1:0<22C?07324A<0=52}2:q:" #(def

-  caadr begin nconc #fn(map)) #(#2#)))))

-            get-syntax #fn("n120710q63:" #(#fn(get)

-                                           *syntax-environment*) get-syntax)

-            getprop #fn("\x8720003000W2000J60q?2420711q5387;3<04208708253;J50482:" #(#fn(get)

-                                                                                     *properties*) getprop)

-            help-print-header #fn("n213?020210>1152@<0720514735047360:" #(#fn(for-each)

+.l

+                                                                                       brnn.l brn.l)) fn-disasm)

+            foldl #fn("n382J401:700082<15282=63:" #(foldl) foldl) foldr

+            #fn("n382J401:082<700182=5362:" #(foldr) foldr) get-defined-vars #fn("n170A<05161:" #(delete-duplicates) #(#2=(#fn("n10H340q:0<20Cd00=B3^00TR;37040Te1;JM040TB;3E0471051R;3:0471051e1:0<22C?07324A<0=52}2:q:" #(def

+  caadr begin nconc #fn(map)) #(#2#)))))

 ewline) help-print-header)

             hex5 #fn("n170210r@52r52263:" #(str-lpad #fn(num->str) #\0) hex5) identity

             #fn("n10:" #() identity) in-env? #fn("n21B;3F042001<52;J:047101=62:" #(#fn(assq)

@@ -406,6 +401,9 @@

 94<0=61:92:" #(caar

   cdar)))) #fn(length)) make-perfect-hash-table)

             make-system-image #fn("n1Ib520852185>1_51422023242554267778Dw74Dw84298889>22:878586>32;8:>1{8:504:" #(#0#

+2205151162:" #(mod0 abs #fn(hash)) $hash-keyword)

+  #fn("n120r20i2q52Ib68621A085F86>5_486<^19261:" #(#fn(vec-alloc)

+                                                   #fn("n10B3p070051r2A<85F52i29286G3;093<FKM61:928685p49286KM71051p494<0=61:92:" #(caar

 " #(#0#

   #fn("n10S;J6040=S3400:0<7021850>222A85>262:" #(call-with-values #fn("n07021A>1F=62:" #(partition

   #fn("n10AL2:"))) #fn("n220A<051Fe1A<15163:" #(#fn(nconc)))) sort)

--- a/src/plan9/lsd.sl

+++ b/src/plan9/lsd.sl

@@ -207,10 +207,7 @@

 (def ctrace (get tracers (os-getenv "objtype")))

-(def (_stk)

-  (reverse!

-    (map (λ (f) (frame-locals f (reverse! (frame-locals f))) f)

-      (ctrace))))

+(def (_stk) (reverse! (ctrace)))

 (def (curPC) (and (>= pid 0) (readreg PC)))

@@ -260,13 +257,17 @@

     (go)))

 (def (over)

-  "Step one line of source code, going over a function call, not in"

+  "Step one line of source code, going over a function call, not in.

+

+   BUGS

+       Stepping over a function call will remain on the same line

+       whenever there is an assignment of the return value. You

+       will have to step twice in that case."

   (let ((f (car (_stk))))

     (line)

     (if (equal? f (car (_stk)))

         (curPC)

-        (begin (func)

-               (line)))))

+        (func))))

 (def (asmlist (n 5) (addr (curPC)))

   "Return a list of the next `n` disassembled instructions starting at `addr`.

@@ -298,7 +299,7 @@

 (def (src (addr (curPC)))

   "Return a string of the filename and line number corresponding

    to the instruction address."

-  (lsd-fileline addr))

+  (when addr (lsd-fileline addr)))

 (def (Bsrc (addr (curPC)))

   "Send a plumb message of the filename and line number

--- a/src/system.sl

+++ b/src/system.sl

@@ -1338,16 +1338,17 @@

   (princ *linefeed*))

+(def (sort l cmp (:key identity))

+  (if (or (not l) (not (cdr l)))

+      l

+      (let ((piv (car l)))

+        (receive (less grtr)

+                 (partition (λ (x) (cmp (key x) (key piv))) (cdr l))

+                 (nconc (sort less cmp :key key)

+                        (list piv)

+                        (sort grtr cmp :key key))))))

+

 (def (make-system-image fname)

-  (def (sort l)

-    (if (or (not l) (not (cdr l)))

-        l

-        (let ((piv (car l)))

-          (receive (less grtr)

-                   (partition (λ (x) (< x piv)) (cdr l))

-                   (nconc (sort less)

-                          (list piv)

-                          (sort grtr))))))

   (let ((f (file fname :write :create :truncate))

         (excludes '(*linefeed* *directory-separator* *argv* that *exit-hooks*

                     *print-pretty* *print-width* *print-readably*

@@ -1364,7 +1365,7 @@

                                               (str (top-level-value s)))))

                              (not (memq s excludes))

                              (not (io? (top-level-value s)))))

-                      (sort (environment))))

+                      (sort (environment) #.<)))

              (data (apply nconc (map list syms (map top-level-value syms)))))

         (write data f)

         (io-write f *linefeed*))