Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: 0cfcac044e
Fetching contributors…

Cannot retrieve contributors at this time

376 lines (335 sloc) 9.173 kB
;;; fud.scm --- Scheme-side section of Fud -*- mode: Gimp; -*-
;; Copyright (C) 2008-2009, 2012 Niels Giesen.
;; Author: Niels Giesen <niels.giesen@gmail.com>
;; Keywords: processes, languages, multimedia, tools
;; Author: Niels Giesen <nielsforkgiesen@gmailspooncom, but please
;; replace the kitchen utensils with a dot before hitting "Send">
;; Keywords: processes, multimedia, extensions, tools, gimp, scheme
;; Homepage: http://niels.kicks-ass.org/gimpmode
;; Keywords: lisp, tools, scheme, debugging
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; FUD stands for the FU Debugger. It is developed for use
;; with gimp-mode to debug code written in the TinyScheme
;; implementation shipped with the GIMP, but its design is such that
;; it could in principle work with any scheme.
;;
;; It's basis is setting and handling break-points FUD.scm integrates
;; with fud.el, which in turn is integrated in gimp-mode.
(define (fud-prompt)
(newline)
(fud-write-string "FUD> "))
(define fud-result #f)
(define fud-recursion 0)
(define (fud-recursion++)
(set! fud-recursion
(+ 1 fud-recursion)))
(define (fud-recursion--)
(set! fud-recursion
(- fud-recursion 1)))
(define (fud-reset)
(set! fud-recursion 0))
(define (fud-write-string . strngs)
(display
(string-append
(make-string fud-recursion)
(unbreakupstr strngs ""))))
(define fud-tracing #t)
(define (fud-untrace)
(set! fud-tracing #f))
(define (fud-trace)
(set! fud-tracing #t))
(define (fud-inside-steppable? form)
(list? form))
(define-macro (fud-log . form)
"Very simple logging."
`(let ((evalled (eval (car ',form))))
(newline)
(display "FUD log on")
(display evalled)
(newline)
evalled))
(define-macro (unfud f)
;; "Remove instruction by fudify on function F"
(let
((name f))
`(begin
(if
(not
(assq ',name fudlist))
(error
(string-append
(symbol->string ',f)
" is not fudified")))
(define ,f
(eval
(cadr
(assq ',name fudlist))))
(set! fudlist
(fud-delete
(assq ',name fudlist)
fudlist))
',name)))
(define (fud-breakify sxp)
(list 'fud-break "0.0 file:nil" sxp))
(define-macro (fud-break breakpoint . form)
`(begin
(when fud-tracing
(newline))
(fud-recursion++)
(when fud-tracing
(fud-write-string
(string-append "Break I-> " ,breakpoint))
(newline)
(fud-write-string "I: ")
(write (car ',form)))
(newline)
(fud-write-string
"ENTER: step over, "
(if (fud-inside-steppable? (car ',form))
" I: step inside" "")
" Q: quit,"
" G: go"
" P: poke at environment,"
" V: use value")
(fud-prompt)
(prog1
(call/cc
(lambda (return)
(let (($ #f))
;; INPUT
(case (char-downcase (read-char))
;; Go...
((#\g)
(display "Continued... (fud-trace) to trace again")
(newline)
(return (eval (car ',form))))
;; Inside...
((#\i)
(read-char)
(if (fud-inside-steppable? (car ',form))
(set! $ (eval (fud-instruct-1 (car ',form))))))
;; Quit...
((#\q)
(fud-reset)
(*error-hook* "Quit tracing"))
;; Inspect...
((#\p)
(letrec ((handler (lambda (err)
(display err) "")))
(display "Expression (q to quit inspection): ")
(fud-prompt)
(let loop ((expr (read)))
(cond ((eqv? 'q expr))
((push-handler handler)
(fud-write-string "")
(write (eval expr))
(if (and (pair? *handlers*)
(eq? handler (car *handlers*)))
(pop-handler))
(newline)
(fud-write-string "Type expression: ")
(fud-prompt)
(loop (read)))))))
;; Use value...
((#\v)
(read-char)
(fud-write-string "Enter value: ")
(fud-prompt)
(set! $ (eval (read)))
(read-char)))
;; OUTPUT
(let (($ (or $ (eval (car ',form)))))
(when fud-tracing
(fud-write-string
(string-append "Break O<- " ,breakpoint))
(display " on ")
(write (car ',form))
(newline)
(fud-write-string "O: ")
(write $)
(newline)
(fud-write-string
"ENTER: next breakpoint, "
" Q: quit,"
" G: go (skipping breakpoints),"
" P: poke at environment,"
" V: use value")
(fud-prompt)
(case (char-downcase (read-char))
;; Go...
((#\g)
(display "Continued... (fud-trace) to trace again")
(newline)
(fud-untrace))
;; Quit...
((#\q)
(fud-reset)
(*error-hook* (make-environment)))
;; Inspect...
((#\p)
(letrec ((handler (lambda (err)
(display err) "")))
(display "Expression (q to quit inspection) current value is bound to `$': ")
(fud-prompt)
(let loop ((expr (read)))
(cond ((eqv? 'q expr))
((push-handler handler)
(fud-write-string "")
(write (eval expr))
(if (and (pair? *handlers*)
(eq? handler (car *handlers*)))
(pop-handler))
(newline)
(fud-write-string "Type expression: ")
(fud-prompt)
(loop (read)))))))
;; Use value...
((#\v)
(fud-write-string "Enter value: ")
(fud-prompt)
(return (eval (read))))
(else (return $)))
(return $))))))
(fud-recursion--)
(if (= fud-recursion 0)
(fud-trace)))))
(define (fud-instruct-1 thunk)
;; "Instruct evaluatable members of THUNK with `fud-breakify'.
;; Special forms and macros supported are if, cond, let, let*, letrec, do
;; and lambda. Forms BEGINNING with a symbol in `blacklist' are returned
;; as is.
;; For instruction of functions and macros --blacklisted here--, see
;; `fudify' and `unfud'."
(let ((in-let? #f)
(in-lambda? #f)
(in-do? #f)
(in-cond? #f)
(blacklist '(define define-macro))
(blacklisted? #f)
(num 0))
(if (eq? (car thunk) 'quote)
(cdr thunk))
(mapcar (lambda (th)
(set! num (+ 1 num))
(cond
;; IF
((and (= num 1)
(memq th '(if)))
th)
;; COND
((and (= num 1)
(memq th '(cond)))
(set! in-cond? #t)
'cond)
(in-cond?
(mapcar (lambda (clause)
(fud-breakify clause)) th))
;; LET, LET* and LETREC
((and (= num 1)
(memq th '(let let* letrec)))
(set! in-let? #t)
th)
(in-let?
(if (symbol? th) th
(begin
(set! in-let? #f)
(mapcar (lambda (th)
(list (car th)
(fud-breakify (cadr th)))) th))))
;; DO
((and (= num 1)
(memq th '(do)))
(set! in-do? 'bindings)
th)
((eq? in-do? 'bindings)
(if (symbol? th) th
(begin
(set! in-do? 'test)
(mapcar (lambda (th)
(cond ((= (length th) 2)
(list (car th)
(fud-breakify (cadr th))))
((= (length th) 3)
(list (car th)
(fud-breakify (cadr th))
(fud-breakify (caddr th))))))
th))))
((eq? in-do? 'test)
(set! in-do? #f)
(list (car th)
(fud-breakify (cadr th))))
;; LAMBDA
((and (= num 1)
(memq th '(lambda)))
(set! in-lambda? #t)
'lambda)
(in-lambda?
(set! in-lambda? #f)
th)
;; BLACKLISTED FORMS
((or blacklisted?
(and (= num 1)
(memq th blacklist)))
(set! blacklisted? #t)
th)
(else
(fud-breakify th))))
thunk)))
;; Instruction of functions:
(define (fud-delete item lst)
(let
((out
'()))
(map
(lambda
(item-in-list)
(if
(not
(equal? item item-in-list))
(set! out
(cons item-in-list out))))
lst)
(if
(pair? out)
(reverse out))))
(define fudlist
'())
(define-macro (fudify f)
;; "Instruct a function for debugging;
;; Any subsequent call to function F will cause fud-breaks to occur at
;; any immediate sublevel of F. Remove the instruction with (unfud
;; FUNTION).
;; Any redefinition will uninstruct the function. This will give you the
;; error `Function is already fudified' if after that you want to fudify
;; it again. Client agents can to some intercepting to make this
;; automatic."
(let
((name f))
`(begin
(if
(assq ',name fudlist)
(error
(string-append
(symbol->string ',f)
" is already fudified")))
(set! fudlist
(cons
(list ',name
(get-closure-code ,f))
fudlist))
(define ,f
(eval
(fud-instruct-1
(get-closure-code ,f)))))))
Jump to Line
Something went wrong with that request. Please try again.