Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Initial debugger support #157

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Initial debugger support #157

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 7 additions & 0 deletions arc.arc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -36,6 +36,13 @@ If you find others, please report them at http://arclanguage.org/forum.
(assign source-file* (table))
(assign source* (table))
(assign help* (table))
(assign original-stdin* (stdin))
(assign original-stdout* (stdout))
(assign original-stderr* (stderr))

(assign dbg (annotate 'mac
(fn ((o expr 'nil))
`(debugger (lexenv) ',expr))))

(assign remac (annotate 'mac
(fn (name parms . body)
Expand Down
162 changes: 162 additions & 0 deletions lib/colors.arc
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,162 @@

(def cat args
(apply string "" args))

(def scat args
(sym:cat args))


(= term*
(obj colors (obj
black 0
red 1
green 2
yellow 3
blue 4
magenta 5
cyan 6
white 7)
attrs (obj
off 0
reset 0
rst 0
bold 1 nobold 22
bld 1 nobld 22
ul 4 noul 24
underline 4 nounderline 24
blink 5 noblink 25
black 30 fgblack 30 bgblack 40
blk 30 fgblk 30 bgblk 40
red 31 fgred 31 bgred 41
green 32 fggreen 32 bggreen 42
grn 32 fggrn 32 bggrn 42
yellow 33 fgyellow 33 bgyellow 43
ylw 33 fgylw 33 bgylw 43
blue 34 fgblue 34 bgblue 44
blu 34 fgblu 34 bgblu 44
magenta 35 fgmagenta 35 bgmagenta 45
mag 35 fgmag 35 bgmag 45
cyan 36 fgcyan 36 bgcyan 46
cyn 36 fgcyn 36 bgcyn 46
white 37 fgwhite 37 bgwhite 47
wht 37 fgwht 37 bgwht 47)))

(def denil (xs)
(keep ~no xs))

(def windows () nil)

(def prcode (codes (o sep #\;))
(unless (windows)
(let xs (flat:list codes)
(pr (cat "\033[" (apply cat (intersperse sep denil.xs)) "m")))))


(def lerp (a b vt)
;(w/infix vt `* (b `- a) `+ a))
(+ a (* vt (- b a))))

(def rgb16 (r g b (o bg nil))
(+ 16 (* 36 (trunc:lerp 0 6 (/ r 256.0)))
(* 6 (trunc:lerp 0 6 (/ g 256.0)))
(trunc:lerp 0 6 (/ b 256.0))))

(def termval (val)
(term*!attrs val))

(def termfx fxs
(when (some [in (type _) 'int 'num] fxs)
(= fxs (list fxs)))
(each val fxs
(if (acons val)
(if (is len.val 3) (apply termrgb val)
(caris val 'fg) (apply termrgb (cdr val))
(caris val 'bg) (apply termrgb (+ (cdr val) '(t)))
(err "termfx: unknown spec" val))
(prcode (term*!attrs val)))))

(def termrgb (r g b (o bg))
(prcode (list (if bg 48 38) 5 (rgb16 r g b))))

(def prcol (col s)
(pr (cat "\033[1;" (string (+ 40 (term*!colors col))) "m"))
(pr s)
(pr "\033[1;0m")
s)

(def prfx (spec . vals)
(after
(do (apply termfx (flat:list spec))
(apply pr vals))
(termfx nil)))

(def prnfx args
(apply prfx args)
(prn))

(def mkfx args
(tostring:apply prfx args))

(mac w/fx (spec . vals)
(let f (afn (xs)
(when xs
(let x (car xs)
(cons
(if (and (acons x) (caris x 'unquote))
(cadr x)
(list 'quote x))
(self (cdr xs))))))
`(tostring (prfx ',spec (cat ,@(intersperse #\space (f vals)))))))


(mac w/colors (var . body)
`(each ,var '(blk red grn ylw blu mag cyn wht)
(let ,(scat 'bg var) (scat 'bg ,var)
,@body)))

(mac w/attrs (var . body)
`(each ,var `(() (bold) (ul) (bold ul) (bold ul blink))
,@body))

(def prstyles (x)
(w/attrs attrs
(prfx attrs x)
(prn " ")
(w/colors col
(prfx `( ,col ,@attrs) x) (pr " ")
(prfx `(,bgcol ,@attrs) x) (pr " ")
(w/colors fg
(prfx `(,bgcol ,fg ,@attrs) x) (pr " "))
(prn))
(prn)))


(def makeprs (colors)
(accum a
(each col colors
(a `(def ,(scat 'pr col) (s) (prcol ',col s)))
(a `(def ,(scat 'prn col) (s) (prcol ',col s) (prn)))
(a `(def ,(scat 'mk col) (s) (tostring:prcol ',col s))))))

(mac evaldo (code)
`(eval `(do ,@(,@code))))

(evaldo:makeprs (keys term*!colors))

(def highlight (val str)
(replace val (mkred val) str))

(mac w/highlight (val . body)
`(let str (tostring (do ,@body))
(void:pr (highlight ,val str))))

(def replace (old new str (o start 0))
(iflet i (posmatch old str start)
(let s (+ (cut str 0 i)
new
(cut str (+ i (len old))))
(replace old new s (+ i (len new))))
str))



188 changes: 188 additions & 0 deletions lib/dbg.arc
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,188 @@
(= *debug nil
*env (obj))

(def *envwipe ()
(each k (keys *env)
(wipe (*env k))))

(def tlread (prompt)
(w/stdout original-stdout*
(w/stdin original-stdin*
(disp prompt)
(flushout)
(read))))

(def tlerr (c)
(prn (details c))
c)

(def dbg-stats ()
(pp (sorted (map [list _.1 _.0] (tablist *fncounts)))))

(def dbg-wipestats ()
(each k (keys *fncounts)
(= (*fncounts k) nil)))

(def dbg-exnenv (env c)
(catch
(each x (stacktrace c)
(if (env x)
(throw (env x))))
nil))

(assign exn* nil)
(assign dbgexpr* nil)

(def dbg-restore (tbl)
(when tbl
(*envwipe)
(maptable (fn (k v) (sref *env v k)) tbl)
*env))

(def dbg-copy (tbl)
(let new (table)
(maptable (fn (k v) (sref new v k)) tbl)
new))

(def dbg-copyenv ()
(dbg-copy *env))

(def call-w/dbg (f)
(if *debug
(f)
(let prev (dbg-copyenv)
(*envwipe)
(assign *debug t)
(after
;(f)
(on-err (fn (c) (let name (*fn)
(let e (dbg-copyenv)
(w/pushnew c exn*
(dbg-restore e)
(debugger c)))))
;(if (~posmatch "cannot reference undefined identifier" (details c))
; (debugger c)
; (tlerr c)))))
f)
(do
(dbg-restore prev)
(assign *debug nil))))))

(def pprint (x)
(seval!pretty-print x)
x)

(mac w/dbg body
`(call-w/dbg (fn () ,@body)))

(def dbg-pps xs
(apply string
(intersperse #\space
(map [trim:tostring:pprint _] xs))))

(def dbg-slot (slot)
(when (>= len.slot 2)
(list slot.0 (if (is (type slot.1) 'fn)
(slot.1)
slot.1))))

(def dbg-locals (lenv)
(map dbg-slot lenv))

(def dbg-prn (lenv retexpr)
(when (> (len exn*) 0)
(tlerr (car exn*)))
;(iflet stack (stacktrace) ;(at (stacktrace) 0 (pos 'dbg-prn (stacktrace)))
; (prn "debugging at: " (dbg-pps (nthcdr (+ (pos 'debugger stack) 1) stack))))
(whenlet trace (assoc '*stacktrace lenv)
(prn "debugging at: " (dbg-pps (dbg-slot trace))))
(pr "locals:")
(each (name val) (dbg-locals lenv)
(prn)
(prblue name)
(pr " " (dbg-pps val)))
(prn)
(prn "type 'h to see this printout")
(prn "type 'c to continue")
(when retexpr
(pr "type 'v to see value of ") (prnblue (dbg-pps retexpr))))

(assign dbgenv* nil)

(def dbg-eval (e expr lenv)
(let prev (dbg-copy e)
(assign dbgenv* (dbg-copyenv))
(dbg-restore e)
(eval expr lenv)))

(def dbg-prexpr (e lenv expr (o printer) (o o (stdout)) (o i (stdin)))
(let result (w/stdout o (w/stdin i (dbg-eval e expr lenv)))
(if printer
(printer expr result)
(prnred (dbg-pps result)))
(= thatexpr expr)
(= that result)
result))

;(def dbgerr (c)
; (prn:details c)
; (map pp stacktrace.c)
; (map pp fulltrace.c)
; c)

(assign dbgerr debugger:tlerr)

(def debugger (lenv (o retexpr) (o o (stdout)) (o i (stdin)))
(w/stdin original-stdin*
(w/stdout original-stdout*
(let e (dbg-copy (or dbgenv* *env))
(dbg-restore e)
(assign dbgenv* nil)
(assign *debug nil)
(when (is (type lenv) 'exception)
;(= lenv (lexenv lenv)))
(= lenv (dbg-exnenv e lenv)))
(when (is (type lenv) 'sym)
(= lenv (e lenv)))
(when (is (type lenv) 'fn)
(= lenv (lenv)))
(dbg-prn lenv retexpr)
(let done nil
((afn ()
(on-err (fn (c)
;(dbgerr c)
(if *debug
(w/pushnew c exn*
(debugger c))
(do
(tlerr c)
(if done
nil
(self)))))
(fn ()
(let expr (tlread "> ")
(assign dbgexpr* expr)
(if (iso expr ''c)
(do (= done t)
(dbg-prexpr e lenv retexpr
(fn (expr result)
(when expr
(prnblue (dbg-pps expr))
(pr " returned ")
(prnred (dbg-pps result))))
o i))
(iso expr ''v)
(do (dbg-prexpr e lenv retexpr)
(self))
(iso expr ''h)
(do (dbg-prn lenv retexpr)
(self))
(do (prnred (dbg-pps (dbg-eval e expr lenv)))
(if (iso dbgexpr* ''c)
(do
(assign dbgexpr* nil)
(dbg-prn lenv retexpr)))
(self)))))))))))))



2 changes: 2 additions & 0 deletions libs.arc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,8 @@

(require '(
; core
lib/colors.arc
lib/dbg.arc
lib/strings.arc
lib/re.arc
lib/binary.arc
Expand Down