suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Honu

Browse Source 
tool.ss
- Added comments and contracts to all functions/methods
- Moved all definitions inside Honu language class
- Simplified some functions
- Removed Honu "configuration" option
format.ss
- Started new module for text formatting of Honu values

svn: r1964
This commit is contained in:
Carl Eastlund 2006-01-25 18:33:24 +00:00
parent 252304b43c
commit f1b37e9793
2 changed files with 372 additions and 297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
collects/honu/format.ss Normal file
View File

@ -0,0 +1,75 @@
(module format mzscheme
(require (lib "contract.ss")
(lib "list.ss")
(lib "class.ss")
(lib "plt-match.ss")
(only "base.ss" null%)
"ast.ss"
)
(provide/contract
[honu-value->string (any/c . -> . string?)]
[honu-type->string (ast:type? . -> . string?)]
)
(define (string-append-delimited pre mid post strings)
(string-append
pre
(if (null? strings)
""
(foldl (lambda (str prefix)
(string-append prefix mid str))
(car strings)
(cdr strings)))
post))
(define (honu-value->string value)
(cond
[(number? value) (format "~a" value)]
[(char? value) (format "'~a'" value)]
[(string? value) (format "~s" value)]
[(boolean? value) (if value "true" "false")]
[(procedure? value) "procedure"]
[(null? value) "()"]
[(list? value) ; Always non-empty
(honu-tuple->string value)]
[(is-a? value null%) "null"]
[(object? value) ; Always non-null
(honu-object->string value)]
[else (error 'honu-value->string "Unknown value ~s" value)]))
(define (honu-tuple->string tuple)
(string-append-delimited "(" ", " ")" (map honu-value->string tuple)))
(define (honu-object->string value)
(send value format-class-name))
(define (honu-type->string t)
(match t
[(struct ast:type:top (_))
"(top type / any value)"]
[(struct ast:type:bot (_))
"(bottom type / no value)"]
[(struct ast:type:primitive (_ name))
(symbol->string name)]
[(struct ast:type:tuple (_ args))
(string-append-delimited "tuple(" ", " ")" (map honu-type->string args))]
[(struct ast:type:partial/tuple (_ slot type))
(format "tuple of size >= ~a where the type in position ~a is ~a"
slot slot (honu-type->string type))]
[(struct ast:type:function (_ arg ret))
(if (ast:type:function? arg)
(string-append "(" (honu-type->string arg) ") -> " (honu-type->string ret))
(string-append (honu-type->string arg) " -> " (honu-type->string ret)))]
[(struct ast:type:method (_ disp arg ret))
(string-append "[" (honu-type->string disp) "] "
(honu-type->string arg) " -> " (honu-type->string ret))]
[(struct ast:type:object:iface (_ name))
(symbol->string (syntax-e name))]
[(struct ast:type:object:any (_))
"Any"]
[(struct ast:type:object:null (_))
"null"]))
)

556
collects/honu/tool.ss
View File

@ -6,341 +6,341 @@
(lib "etc.ss") (lib "etc.ss")
(lib "class.ss") (lib "class.ss")
(lib "list.ss" "srfi" "1") (lib "list.ss" "srfi" "1")
(lib "match.ss")
"parsers/lex.ss" "parsers/lex.ss"
"parsers/parse.ss" "parsers/parse.ss"
"private/typechecker/type-utils.ss" "private/typechecker/type-utils.ss"
(only "base.ss" null%) (only "base.ss" null%)
"tenv.ss" "tenv.ss"
"compile.ss" "compile.ss"
"format.ss"
(lib "string-constant.ss" "string-constants")) (lib "string-constant.ss" "string-constants"))
(provide tool@) (provide tool@)
;; tool@ : Unit/Sig[drscheme:tool^ -> drscheme:tool-exports^]
;; Implements Honu as a DrScheme language
(define tool@ (define tool@
(unit/sig drscheme:tool-exports^ (unit/sig drscheme:tool-exports^
(import drscheme:tool^) (import drscheme:tool^)
;; phase1 : -> Void
;; Performs general language extensions to DrScheme for Honu.
;; Currently none exist.
(define (phase1) (void)) (define (phase1) (void))
;; phase2 : -> Void
;; Adds the Honu language to DrScheme.
(define (phase2) (define (phase2)
(drscheme:language-configuration:add-language (define honu (new ((drscheme:language:get-default-mixin) honu-lang%)))
(make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'normal))))) (drscheme:language-configuration:add-language honu)
(send honu pre-initialize))
(define-struct honu-settings (display-style) #f) ;; honu-lang% : Class[drscheme:language:language<%>]
;; Honu implementation as a class.
(define (honu-lang-mixin level) (define honu-lang%
(class* object% (drscheme:language:language<%>) (class* object% (drscheme:language:language<%>)
(define/public (first-opened) (void))
;; tenv : TypeEnvironment
;; The current type environment for evaluation.
(define tenv #f)
;; lenv : LexicalEnvironment
;; The current lexical environment for evaluation.
(define lenv #f)
;; pre-initialize : -> Void
;; Hooks Honu up to DrScheme after being added as a language.
(define/public (pre-initialize)
(drscheme:modes:add-mode "Honu mode" mode-surrogate repl-submit matches-language)
(color-prefs:add-to-preferences-panel "Honu" extend-preferences-panel)
(for-each register-color-pref color-prefs-table))
;; first-opened : -> Void
;; Sets Honu state to initial values.
(define/public (first-opened)
(reset-evaluation!))
;; get-comment-character : -> String Character
;; Provides prefix and filler character for comments
;; for use in "Insert Large Letters"
(define/public (get-comment-character) (values "//" #\*)) (define/public (get-comment-character) (values "//" #\*))
(define/public (default-settings) ;; default-settings : -> HonuSetting
(make-honu-settings 'field)) ;; Provides default global Honu configuration
(define/public (default-settings? s) (define/public (default-settings) #f)
(equal? s (default-settings)))
(define/public (marshall-settings s)
(list (list (honu-settings-display-style s))))
(define/public (unmarshall-settings s)
(if (and (pair? s) (= (length s) 1)
(pair? (car s)) (= (length (car s)) 1))
(make-honu-settings (caar s))
#f))
(define/public (config-panel _parent) ;; default-settings? : HonuSetting -> Boolean
(letrec ([parent (instantiate vertical-panel% () ;; Reports whether Honu configuration is set to defaults
(parent _parent) (define/public (default-settings? s) #t)
(alignment '(center center))
(stretchable-height #f)
(stretchable-width #f))]
[output-panel (instantiate group-box-panel% () ;; marshall-settings : HonuSetting -> Writable
(label "Display Preferences") ;; Converts a Honu configuration to a value which can be
(parent parent) ;; written to a port.
(alignment '(left center)))] (define/public (marshall-settings s) s)
[display-style (make-object radio-box%
"Display style"
(list "Class" "Class+Fields" )
output-panel
(lambda (x y) (update-ps)))]
[update-ps (lambda () (void))]) ;; unmarshall-settings : Writable -> HonuSetting
;; Converts the result of a previous marshall-settings to
;; a Honu configuration.
(define/public (unmarshall-settings s) s)
;; config-panel : panel% -> [Case (-> HonuSetting) (HonuSetting -> Void)]
;; Assembles a language configuration dialog for Honu
;; and produces a get/set function for the displayed configuration.
(define/public (config-panel parent)
(letrec ([output-panel (new group-box-panel%
[label "Honu Preferences (Currently Empty)"]
[parent parent]
[alignment '(left center)])])
(case-lambda (case-lambda
[() [() (default-settings)]
(make-honu-settings (case (send display-style get-selection) [(settings) (void)])))
[(0) 'class]
[(1) 'field]))]
[(settings)
(send display-style set-selection
(case (honu-settings-display-style settings)
((class) 0)
((field) 1)))])))
(define tenv (empty-tenv)) ;; front-end/complete-program :
(define lenv (get-builtin-lenv)) ;; InputPort HonuSetting TeachpackCache -> (-> (Union Syntax EOF))
(define level-parser ;; Produces a thunk which compiles and returns a Honu definition when one
(case level ;; is available on the input port, or EOF when none are left.
[(normal) parse-port]))
(define/public (front-end/complete-program port settings teachpack-cache) (define/public (front-end/complete-program port settings teachpack-cache)
(set! tenv (empty-tenv)) (reset-evaluation!)
(set! lenv (get-builtin-lenv)) (lambda ()
(let ([name (object-name port)]) (if (eof-object? (peek-char-or-special port))
(lambda () eof
(if (eof-object? (peek-char-or-special port)) (let*-values
eof ([(syntax-annotation compiled-defns)
(let* ([parsed (level-parser port name)]) (compile/defns tenv lenv (parse-port port (object-name port)))])
(let-values ;; This particular syntax construction is compatible with Check Syntax
([(cruft-for-stx compiled-defns) (compile/defns tenv lenv parsed)]) ;; and can be distinguished from compiled Interactions.
;; if we wrap this in something special for the syntax-case below, then (datum->syntax-object
;; Check Syntax breaks (unsurprisingly), so we'll just do special #f
;; wrappers for the interaction stuff. (list 'begin
(datum->syntax-object syntax-annotation
#f (datum->syntax-object
(list 'begin cruft-for-stx #f
(datum->syntax-object #f (cons 'begin compiled-defns) #f)) (cons 'begin compiled-defns)
#f))))))) #f))
#f)))))
;; front-end/interaction :
;; InputPort HonuSetting TeachpackCache -> (-> (Union Syntax EOF))
;; Produces a thunk which compiles and returns a Honu expression or definition
;; when one is available on the input port, or EOF when none are left.
(define/public (front-end/interaction port settings teachpack-cache) (define/public (front-end/interaction port settings teachpack-cache)
(let ([name (object-name port)]) (lambda ()
(lambda () (if (eof-object? (peek-char-or-special port))
(if (eof-object? (peek-char-or-special port)) eof
eof (let*-values ([(compiled-expr type)
(let ([parsed (parse-interaction port name)]) (compile/interaction
(let-values ([(compiled-expr type) (compile/interaction tenv lenv parsed)]) tenv lenv
(if type (parse-interaction port (object-name port)))])
(datum->syntax-object #f `(compiled-expression ,compiled-expr ,type) #f) (datum->syntax-object
(datum->syntax-object #f `(compiled-binding ,compiled-expr) #f)))))))) #f
(if type
`(compiled-expression ,compiled-expr ,type)
`(compiled-binding ,compiled-expr))
#f)))))
;; get-style-delta : -> #f
;; Reports that the name Honu has no specific text style.
(define/public (get-style-delta) #f) (define/public (get-style-delta) #f)
;; order-manuals : [Listof ByteString] -> (values [Listof ByteString] Boolean)
;; Reports which manuals from the input contain Honu documentation
;; and whether to search doc.txt files for Honu documentation.
;; Currently lists no manuals, but includes doc.txt.
(define/public (order-manuals manuals)
(values '() #t))
;; get-language-name : -> String
;; Produces Honu's name.
(define/public (get-language-name) "Honu")
;; get-language-url : -> (Union String #f)
;; Reports that Honu has no URL.
(define/public (get-language-url) #f)
;; get-language-position : -> [NonEmptyListof String]
;; Reports Honu's place in the language hierarchy.
(define/public (get-language-position) (define/public (get-language-position)
(list (string-constant experimental-languages) (list (string-constant experimental-languages)
"Honu")) "Honu"))
(define/public (order-manuals x)
(values ;; get-language-numbers : -> [NonEmptyListof String]
(list #"drscheme" #"tour" #"help") ;; Reports Honu's sort order in the language hierarchy.
#f)) (define/public (get-language-numbers) (list 1000 10))
(define/public (get-language-name)
(case level ;; get-one-line-summary : -> String
[(normal) "Honu"])) ;; Produces a short description of Honu.
(define/public (get-language-url) #f) (define/public (get-one-line-summary) "Honu (not a Scheme dialect)")
(define/public (get-language-numbers)
(case level ;; on-execute : HonuSetting ((-> Void) -> Void) -> Void
[(normal) (list 1000 10)])) ;; Sets parameters for Honu execution.
(define/public (get-teachpack-names) null)
(define/private (syntax-as-top s)
(if (syntax? s) (namespace-syntax-introduce s) s))
(define/public (on-execute settings run-in-user-thread) (define/public (on-execute settings run-in-user-thread)
(dynamic-require '(lib "base.ss" "honu") #f) (dynamic-require '(lib "base.ss" "honu") #f)
(let ([path ((current-module-name-resolver) '(lib "base.ss" "honu") #f #f)] (let ([path ((current-module-name-resolver) '(lib "base.ss" "honu") #f #f)]
[n (current-namespace)]) [namespace (current-namespace)])
(run-in-user-thread (run-in-user-thread
(lambda () (lambda ()
(define base-eval (drscheme:debug:make-debug-eval-handler (current-eval)))
(define (eval stx)
(syntax-case stx (compiled-binding compiled-expression)
[(compiled-binding BINDING)
(base-eval (namespace-syntax-introduce #'BINDING))]
[(compiled-expression EXPR TYPE)
(cons (base-eval (namespace-syntax-introduce #'EXPR))
(syntax-e #'TYPE))]
[(_ ANNOTATION PROGRAM)
(base-eval (namespace-syntax-introduce #'PROGRAM))]))
(current-eval eval)
(error-display-handler (error-display-handler
(drscheme:debug:make-debug-error-display-handler (error-display-handler))) (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
(let ([old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))]) (namespace-attach-module namespace path)
(current-eval
(lambda (exp)
(syntax-case exp (compiled-binding compiled-expression)
[(compiled-binding binding)
(old-current-eval (syntax-as-top #'binding))]
[(compiled-expression ex type)
(cons (old-current-eval (syntax-as-top #'ex))
(syntax-e #'type))]
;; if it wasn't either of those, this must have been from the definitions
;; window, so just eval it.
;;
;; well, remove the cruft I added to get Check Syntax to work first.
[(_ type-cruft real-stx)
(old-current-eval (syntax-as-top #'real-stx))]))))
(namespace-attach-module n path)
(namespace-require path))))) (namespace-require path)))))
;; render-value : Value HonuSetting OutputPort -> Void
;; Writes value to port as a single line with no newline.
(define/public (render-value value settings port) (define/public (render-value value settings port)
(display (format-honu value settings) port)) (display (format-honu value settings) port))
;; render-value/format : Value HonuSetting OutputPort (Union Integer #f) -> Void
;; Writes value to port as lines of length no greater than width.
;; Terminates all lines with newline.
;; Currently fails to actually account for width.
(define/public (render-value/format value settings port width) (define/public (render-value/format value settings port width)
(render-value value settings port) (render-value value settings port)
(if (not (null? (car value))) (newline port))) (newline port))
;; create-executable : HonuSetting (Union Dialog Frame) String TeachpackCache -> Void
;; Raises an error reporting that Honu programs cannot be made into executables.
(define/public (create-executable settings parent src-file teachpacks) (define/public (create-executable settings parent src-file teachpacks)
(message-box "Unsupported" (message-box "Unsupported"
"Sorry - executables are not supported for Honu at this time" "Sorry - executables are not supported for Honu at this time"
parent)) parent))
(define/public (get-one-line-summary)
(case level
[(normal) "Honu (also not Scheme at all!)"]))
(super-instantiate ()))) ;; Finish the class instantiation
(super-new)
;; The following copies the Java mode to make one for Honu, but it's better right now than ;; ------------------------------------------------------------
;; using the Scheme mode. Ugh. ;; BEGIN PRIVATE FUNCTIONS
;; matches-language : (union #f (listof string)) -> boolean ;; reset-evaluation! : -> Void
(define (matches-language l) ;; Restore Honu state to initial values.
(and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "Honu"))) (define (reset-evaluation!)
(set! tenv (empty-tenv))
(set! lenv (get-builtin-lenv)))
(define (format-honu result settings) ;; format-honu : (cons Value Ast:Type) HonuSetting -> String
(cond ;; Formats the result of Honu evaluation for printing.
;; if we have a pair, then we evaluated an expression (the car) (define (format-honu result settings)
;; and we also have its type (the cdr). (format "~a : ~a"
[(pair? result) (honu-value->string (car result))
(if (null? (car result)) (honu-type->string (cdr result))))
;; Don't print out anything for void values.
""
(format "~a : ~a"
(format-honu-value (car result) settings 0)
(printable-type (cdr result))))]
;; If we got here, then who knows what we got -- just print it out.
[else (format "~a" result)]))
(define (format-honu-value value settings indent) ;; matches-language : [NonEmptyListof String] -> Boolean
(cond ;; Reports whether a language dialog choice matches Honu.
[(number? value) (format "~a" value)] (define (matches-language l)
[(char? value) (format "'~a'" value)] (equal? l (get-language-position)))
[(string? value) (format "~v" value)]
[(boolean? value) (if value "true" "false")]
[(procedure? value) "procedure"]
;; tuples -- first the zero tuple, then the non-empty tuples
;;
;; if you want void values to be printed out, uncomment
;; the following:
;; [(null? value) "()"]
[(null? value)
;; the following makes it so that nothing is printed out
;; for a void value, but if a zero-tuple is part of a tuple
;; or structure, then it is printed out.
(if (= indent 0) "" "()")]
[(list? value)
(if (and (eqv? (honu-settings-display-style settings) 'field)
(any (lambda (v)
;; checking to see if it's a non-null object
(and (object? v) (not (is-a? v null%))))
value))
(string-append "("
(fold (lambda (v s)
;; if there are objects in the list, then we'll
;; print each value on its own line.
(string-append s ",\n" (make-string (+ indent 1) #\space)
(format-honu-value v settings (+ indent 1))))
(format-honu-value (car value) settings (+ indent 1))
(cdr value))
")")
(string-append "("
(fold (lambda (v s)
;; if there are no objects, then we'll just print out
;; the list on the same line.
(string-append s ", "
(format-honu-value v settings (+ indent 1))))
(format-honu-value (car value) settings (+ indent 1))
(cdr value))
")"))]
[(is-a? value null%) "null"]
[(object? value) (if (eqv? (honu-settings-display-style settings) 'field)
(send value format-class
(lambda (value at-top?)
(format-honu-value value settings at-top?))
indent)
(send value format-class-name))]
[else (format "~a" value)]))
;Set the Honu editing colors ;; register-color-pref : (list Symbol Color String) -> Void
(define color-prefs-table ;; Registers a single color preference setting in the correct menu.
`((keyword ,(make-object color% "black") "keyword") (define (register-color-pref pref)
(parenthesis ,(make-object color% 132 60 36) "parenthesis") (let ([sym (car pref)]
(string ,(make-object color% "forestgreen") "string") [color (cadr pref)])
(literal ,(make-object color% "forestgreen") "literal") (color-prefs:register-color-pref (short-sym->pref-name sym)
(comment ,(make-object color% 194 116 31) "comment") (short-sym->style-name sym)
(error ,(make-object color% "red") "error") color)))
(identifier ,(make-object color% 38 38 128) "identifer")
(default ,(make-object color% "black") "default")))
;; short-sym->pref-name : symbol -> symbol ;; color-prefs-table : [Listof (list Symbol Color String)]
;; returns the preference name for the color prefs ;; Lists the Honu color preference entries
(define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym))) (define color-prefs-table
`((keyword ,(make-object color% "black") "keyword")
(parenthesis ,(make-object color% 132 60 36) "parenthesis")
(string ,(make-object color% "forestgreen") "string")
(literal ,(make-object color% "forestgreen") "literal")
(comment ,(make-object color% 194 116 31) "comment")
(error ,(make-object color% "red") "error")
(identifier ,(make-object color% 38 38 128) "identifer")
(default ,(make-object color% "black") "default")))
;; short-sym->style-name : symbol->string ;; short-sym->pref-name : symbol -> symbol
;; converts the short name (from the table above) into a name in the editor list ;; returns the preference name for the color prefs
;; (they are added in by `color-prefs:register-color-pref', called below) (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
(define (short-sym->style-name sym) (format "honu:syntax-coloring:scheme:~a" sym))
;; extend-preferences-panel : vertical-panel -> void ;; short-sym->style-name : symbol->string
;; adds in the configuration for the Honu colors to the prefs panel ;; converts the short name (from the table above) into a name in the editor list
(define (extend-preferences-panel parent) ;; (they are added in by `color-prefs:register-color-pref', called below)
(for-each (define (short-sym->style-name sym) (format "honu:syntax-coloring:scheme:~a" sym))
(lambda (line)
(let ([sym (car line)])
(color-prefs:build-color-selection-panel
parent
(short-sym->pref-name sym)
(short-sym->style-name sym)
(format "~a" sym))))
color-prefs-table))
;Create the Honu editing mode ;; extend-preferences-panel : vertical-panel -> void
(define mode-surrogate ;; adds in the configuration for the Honu colors to the prefs panel
(new color:text-mode% (define (extend-preferences-panel parent)
(matches (list (list '|{| '|}|) (for-each
(list '|(| '|)|) (lambda (line)
(list '|[| '|]|))) (let ([sym (car line)])
(get-token get-syntax-token) (color-prefs:build-color-selection-panel
(token-sym->style short-sym->style-name))) parent
(short-sym->pref-name sym)
(short-sym->style-name sym)
(format "~a" sym))))
color-prefs-table))
;repl-submit: text int -> bool ;; mode-surrogate : TextMode
;Determines if the reple should submit or not ;; Create the Honu editing mode
(define (repl-submit text prompt-position) (define mode-surrogate
(let ((is-empty? #t) (new color:text-mode%
(is-string? #f) (matches (list (list '|{| '|}|)
(open-parens 0) (list '|(| '|)|)
(open-braces 0) (list '|[| '|]|)))
(open-curlies 0)) (get-token get-syntax-token)
(let loop ((index 1) (char (send text get-character prompt-position))) (token-sym->style short-sym->style-name)))
(unless (eq? char #\nul)
(cond
((eq? char #\()
(set! is-empty? #f)
(unless is-string? (set! open-parens (add1 open-parens)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\))
(set! is-empty? #f)
(unless is-string? (set! open-parens (sub1 open-parens)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\{)
(set! is-empty? #f)
(unless is-string? (set! open-curlies (add1 open-curlies)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\})
(set! is-empty? #f)
(unless is-string? (set! open-curlies (sub1 open-curlies)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\[)
(set! is-empty? #f)
(unless is-string? (set! open-braces (add1 open-braces)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\])
(set! is-empty? #f)
(unless is-string? (set! open-braces (sub1 open-braces)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
;beginning of string
((eq? char #\")
(set! is-empty? #f)
(set! is-string? (not is-string?))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((char-whitespace? char)
(loop (add1 index) (send text get-character (+ index prompt-position))))
(else
(set! is-empty? #f)
(loop (add1 index) (send text get-character (+ index prompt-position)))))))
(not (or (not (= open-parens 0))
(not (= open-braces 0))
(not (= open-curlies 0))
is-empty?))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; repl-submit: text int -> bool
;; ;; Determines if the reple should submit or not
;; Wire up to DrScheme (define (repl-submit text prompt-position)
;; (let ((is-empty? #t)
(is-string? #f)
(drscheme:modes:add-mode "Honu mode" mode-surrogate repl-submit matches-language) (open-parens 0)
(color-prefs:add-to-preferences-panel "Honu" extend-preferences-panel) (open-braces 0)
(open-curlies 0))
(for-each (lambda (line) (let loop ((index 1) (char (send text get-character prompt-position)))
(let ([sym (car line)] (unless (eq? char #\nul)
[color (cadr line)]) (cond
(color-prefs:register-color-pref (short-sym->pref-name sym) ((eq? char #\()
(short-sym->style-name sym) (set! is-empty? #f)
color))) (unless is-string? (set! open-parens (add1 open-parens)))
color-prefs-table) (loop (add1 index) (send text get-character (+ index prompt-position))))
))) ((eq? char #\))
(set! is-empty? #f)
(unless is-string? (set! open-parens (sub1 open-parens)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\{)
(set! is-empty? #f)
(unless is-string? (set! open-curlies (add1 open-curlies)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\})
(set! is-empty? #f)
(unless is-string? (set! open-curlies (sub1 open-curlies)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\[)
(set! is-empty? #f)
(unless is-string? (set! open-braces (add1 open-braces)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((eq? char #\])
(set! is-empty? #f)
(unless is-string? (set! open-braces (sub1 open-braces)))
(loop (add1 index) (send text get-character (+ index prompt-position))))
;; beginning of string
((eq? char #\")
(set! is-empty? #f)
(set! is-string? (not is-string?))
(loop (add1 index) (send text get-character (+ index prompt-position))))
((char-whitespace? char)
(loop (add1 index) (send text get-character (+ index prompt-position))))
(else
(set! is-empty? #f)
(loop (add1 index) (send text get-character (+ index prompt-position)))))))
(not (or (not (= open-parens 0))
(not (= open-braces 0))
(not (= open-curlies 0))
is-empty?))))
)))))