You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
331 lines
11 KiB
Scheme
331 lines
11 KiB
Scheme
27 years ago
|
;; prefs.ss - loads preferences
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
||
|
|
;
|
||
|
|
; This program is free software; you can redistribute it and/or
|
||
|
|
; modify it under the terms of the GNU General Public License
|
||
|
|
; version 2 as published by the Free Software Foundation.
|
||
|
|
;
|
||
|
|
; This program 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 this program; if not, write to the Free Software
|
||
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define parameter-radio-boxes
|
||
|
|
(lambda (name param sym p major-dim direction)
|
||
|
|
(mred:set-preference-default sym (param)
|
||
|
|
(lambda (x)
|
||
|
|
(with-handlers ((exn? (lambda (exn) #f)))
|
||
|
|
(param x)
|
||
|
|
#t)))
|
||
|
|
(param (mred:get-preference sym))
|
||
|
|
(let* ([o
|
||
|
|
(make-object
|
||
|
|
mred:radio-box% p
|
||
|
|
(lambda (bx event)
|
||
|
|
;;(printf "~s~n" (param '?))
|
||
|
|
(match
|
||
|
|
(list-ref (param '?)
|
||
|
|
(send event get-command-int))
|
||
|
|
[(tag . _)
|
||
|
|
(param tag)
|
||
|
|
(mred:set-preference sym tag)]))
|
||
|
|
name
|
||
|
|
-1 -1 -1 -1
|
||
|
|
(map cadr (param '?))
|
||
|
|
major-dim
|
||
|
|
direction)]
|
||
|
|
[pairs
|
||
|
|
(map
|
||
|
|
(match-lambda [(tag name . _) (cons name tag)])
|
||
|
|
(param '?))]
|
||
|
|
[default-ndx
|
||
|
|
(recur loop ([n 0][pairs pairs])
|
||
|
|
(cond
|
||
|
|
[(null? pairs)
|
||
|
|
(error 'make-parameter-menu
|
||
|
|
"Can't find para in pairs ~s" (param))]
|
||
|
|
[(equal? (param) (cdar pairs)) n]
|
||
|
|
[else (loop (add1 n) (cdr pairs))]))])
|
||
|
|
(send o stretchable-in-x #t)
|
||
|
|
(send o set-selection default-ndx)
|
||
|
|
o
|
||
|
|
)))
|
||
|
|
|
||
|
|
(define parameter-check-box
|
||
|
|
(lambda (name param sym p)
|
||
|
|
(mred:set-preference-default sym (param)
|
||
|
|
(lambda (x)
|
||
|
|
(with-handlers ((exn? (lambda (exn) #f)))
|
||
|
|
(param x)
|
||
|
|
#t)))
|
||
|
|
(param (mred:get-preference sym))
|
||
|
|
(let* ( [hp (make-object mred:horizontal-panel% p)]
|
||
|
|
[o
|
||
|
|
(make-object
|
||
|
|
mred:check-box% hp
|
||
|
|
(lambda (bx event)
|
||
|
|
;;(printf "~s~n" (param '?))
|
||
|
|
(match
|
||
|
|
(list-ref (param '?)
|
||
|
|
(send event get-command-int))
|
||
|
|
[(tag . _)
|
||
|
|
(param tag)
|
||
|
|
(mred:set-preference sym tag)]))
|
||
|
|
name
|
||
|
|
-1 -1 -1 -1)]
|
||
|
|
[_ (make-object mred:horizontal-panel% hp)])
|
||
|
|
(send o set-value (param))
|
||
|
|
o
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
;; MrSpidey Type Display
|
||
|
|
|
||
|
|
(define callbacks-sdl-alg-changed '())
|
||
|
|
|
||
|
|
(define (add-callback-sdl-alg-changed! fn)
|
||
|
|
(set! callbacks-sdl-alg-changed (cons fn callbacks-sdl-alg-changed)))
|
||
|
|
|
||
|
|
(define (remq-callback-sdl-alg-changed! fn)
|
||
|
|
(set! callbacks-sdl-alg-changed (remq fn callbacks-sdl-alg-changed)))
|
||
|
|
|
||
|
|
(define (sdl-alg-changed)
|
||
|
|
(for-each
|
||
|
|
(lambda (f) (f))
|
||
|
|
callbacks-sdl-alg-changed))
|
||
|
|
|
||
|
|
(define (param-ctrls-sdl-alg param)
|
||
|
|
(lambda args
|
||
|
|
(sdl-alg-changed)
|
||
|
|
(apply param args)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(mred:set-preference-default 'st:const-merge-size (st:const-merge-size)
|
||
|
|
(lambda (x)
|
||
|
|
(with-handlers ((exn? (lambda (exn) #f)))
|
||
|
|
(st:const-merge-size x)
|
||
|
|
#t)))
|
||
|
|
(st:const-merge-size (mred:get-preference 'st:const-merge-size))
|
||
|
|
|
||
|
|
(define mrspidey-mk-analysis-pref-panel
|
||
|
|
(lambda (panel)
|
||
|
|
(let*
|
||
|
|
( [p (make-object mred:vertical-panel% panel)]
|
||
|
|
|
||
|
|
[vp (make-object mred:vertical-panel% p -1 -1 -1 -1)]
|
||
|
|
[_ (parameter-check-box
|
||
|
|
"Accurate constant types"
|
||
|
|
st:constants 'st:constants
|
||
|
|
vp)]
|
||
|
|
[g (make-object mred:slider% vp
|
||
|
|
(lambda (slider event)
|
||
|
|
(st:const-merge-size (send event get-command-int))
|
||
|
|
(mred:set-preference 'st:const-merge-size
|
||
|
|
(send event get-command-int)))
|
||
|
|
"Constant merge size"
|
||
|
|
(st:const-merge-size)
|
||
|
|
1 100
|
||
|
|
100)]
|
||
|
|
[_ (send g enable #t)]
|
||
|
|
[_ (parameter-check-box
|
||
|
|
"If splitting"
|
||
|
|
st:if-split 'st:if-split
|
||
|
|
vp)]
|
||
|
|
[_ (parameter-check-box
|
||
|
|
"Flow sensitivity"
|
||
|
|
st:flow-sensitive 'st:flow-sensitive
|
||
|
|
vp)]
|
||
|
|
[_ (parameter-check-box
|
||
|
|
"Accurate analysis of numeric operations"
|
||
|
|
st:numops 'st:numops
|
||
|
|
vp)]
|
||
|
|
[_2 (parameter-radio-boxes
|
||
|
|
"Polymorphism:"
|
||
|
|
st:polymorphism
|
||
|
|
'st:polymorphism
|
||
|
|
p 0 wx:const-horizontal)]
|
||
|
|
|
||
|
|
[vp (make-object mred:vertical-panel% p -1 -1 -1 -1)]
|
||
|
|
[vphp (make-object mred:horizontal-panel% vp)]
|
||
|
|
[_0 (make-object mred:message% vphp
|
||
|
|
"Polymorphism simplification algorithms:")]
|
||
|
|
[vphphp (make-object mred:horizontal-panel% vphp)]
|
||
|
|
[_1 (parameter-radio-boxes
|
||
|
|
" "
|
||
|
|
st:constraint-simplification-poly
|
||
|
|
'st:constraint-simplification-poly
|
||
|
|
vp 0 wx:const-vertical)]
|
||
|
|
|
||
|
|
[_ (parameter-radio-boxes
|
||
|
|
"Save .za files in:"
|
||
|
|
st:save-za-in
|
||
|
|
'st:save-za-in
|
||
|
|
p
|
||
|
|
0 wx:const-horizontal)]
|
||
|
|
)
|
||
|
|
|
||
|
|
p)))
|
||
|
|
|
||
|
|
(mred:add-preference-panel
|
||
|
|
"MrSpidey Analysis"
|
||
|
|
mrspidey-mk-analysis-pref-panel)
|
||
|
|
|
||
|
|
(mrspidey-mk-analysis-pref-panel
|
||
|
|
(make-object mred:horizontal-panel%
|
||
|
|
(make-object mred:frame% '() "dummy")))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
;(mred:set-preference-default 'st:sdl-size-k (st:sdl-size-k))
|
||
|
|
;(st:sdl-size-k (mred:get-preference 'st:sdl-size-k))
|
||
|
|
|
||
|
|
(define (indented-vertical-radio-box p name param sym)
|
||
|
|
(let*
|
||
|
|
( [vp (make-object mred:vertical-panel% p -1 -1 -1 -1)]
|
||
|
|
[vphp1 (make-object mred:horizontal-panel% vp)]
|
||
|
|
[_0 (make-object mred:message% vphp1 name)]
|
||
|
|
[vphp2 (make-object mred:horizontal-panel% vp)]
|
||
|
|
[spc (make-object mred:horizontal-panel% vphp2)]
|
||
|
|
[_ (send spc user-min-width 20)]
|
||
|
|
[_ (send spc stretchable-in-x #f)]
|
||
|
|
[radio-box
|
||
|
|
(parameter-radio-boxes
|
||
|
|
'()
|
||
|
|
param sym
|
||
|
|
vphp2 0 wx:const-vertical)]
|
||
|
|
[_ (send radio-box stretchable-in-x #t)]
|
||
|
|
[_ (make-object mred:horizontal-panel% vphp2)])
|
||
|
|
(void)))
|
||
|
|
|
||
|
|
(define mrspidey-mk-type-display-prefs-panel
|
||
|
|
(lambda (panel)
|
||
|
|
(let*
|
||
|
|
( [p (make-object mred:vertical-panel% panel )])
|
||
|
|
|
||
|
|
(let*
|
||
|
|
(
|
||
|
|
[sdl-fo-container-panel
|
||
|
|
(make-object mred:horizontal-panel% p)]
|
||
|
|
[sdl-fo-sub-panel
|
||
|
|
(make-object mred:horizontal-panel% p)]
|
||
|
|
[spc (make-object mred:horizontal-panel% sdl-fo-sub-panel)]
|
||
|
|
[_ (send spc user-min-width 20)]
|
||
|
|
[_ (send spc stretchable-in-x #f)]
|
||
|
|
[sdl-fo-sub-sub-panel
|
||
|
|
(make-object mred:vertical-panel% sdl-fo-sub-panel)]
|
||
|
|
[see-ivars-panel
|
||
|
|
(parameter-check-box
|
||
|
|
"Show instance variables"
|
||
|
|
(param-ctrls-sdl-alg st:sdl-fo-ivars)
|
||
|
|
'st:sdl-fo-ivars
|
||
|
|
sdl-fo-sub-sub-panel)]
|
||
|
|
[see-struct-fields-panel
|
||
|
|
(parameter-check-box
|
||
|
|
"Show structure fields"
|
||
|
|
(param-ctrls-sdl-alg st:sdl-fo-struct-fields)
|
||
|
|
'st:sdl-fo-struct-fields
|
||
|
|
sdl-fo-sub-sub-panel)]
|
||
|
|
[_ (parameter-radio-boxes
|
||
|
|
"Show types as:"
|
||
|
|
(match-lambda*
|
||
|
|
[('?) (st:sdl-fo '?)]
|
||
|
|
[() (st:sdl-fo)]
|
||
|
|
[(x)
|
||
|
|
(sdl-alg-changed)
|
||
|
|
(let ([enable-sub-controls (eq? x 'basic-types)])
|
||
|
|
(for-each
|
||
|
|
(lambda (control)
|
||
|
|
(send control enable enable-sub-controls))
|
||
|
|
(list
|
||
|
|
see-ivars-panel
|
||
|
|
see-struct-fields-panel)))
|
||
|
|
(st:sdl-fo x)])
|
||
|
|
'st:sdl-fo
|
||
|
|
sdl-fo-container-panel
|
||
|
|
0 wx:const-horizontal)])
|
||
|
|
(void))
|
||
|
|
|
||
|
|
(indented-vertical-radio-box p
|
||
|
|
"Constraint simplification algorithms:"
|
||
|
|
(param-ctrls-sdl-alg st:sdl-constraint-simplification)
|
||
|
|
'st:sdl-constraint-simplification)
|
||
|
|
|
||
|
|
(parameter-radio-boxes
|
||
|
|
"Type naming:"
|
||
|
|
(param-ctrls-sdl-alg st:naming-strategy)
|
||
|
|
'st:naming-strategy
|
||
|
|
p 0 wx:const-horizontal)
|
||
|
|
(parameter-radio-boxes
|
||
|
|
"Primitive types:"
|
||
|
|
(param-ctrls-sdl-alg st:primitive-types)
|
||
|
|
'st:primitive-types
|
||
|
|
p 0 wx:const-horizontal)
|
||
|
|
|
||
|
|
(let*
|
||
|
|
(
|
||
|
|
[st:expand-output-type-container-panel
|
||
|
|
(make-object mred:horizontal-panel% p)]
|
||
|
|
[st:expand-output-type-sub-panel
|
||
|
|
(make-object mred:horizontal-panel% p)]
|
||
|
|
[spc (make-object mred:horizontal-panel%
|
||
|
|
st:expand-output-type-sub-panel)]
|
||
|
|
[_ (send spc user-min-width 20)]
|
||
|
|
[_ (send spc stretchable-in-x #f)]
|
||
|
|
[sdl-tidy-object
|
||
|
|
(parameter-check-box
|
||
|
|
"Uses equivalences that make types tidy"
|
||
|
|
(param-ctrls-sdl-alg st:sdl-tidy)
|
||
|
|
'st:sdl-tidy
|
||
|
|
st:expand-output-type-sub-panel)]
|
||
|
|
[_ (parameter-check-box
|
||
|
|
"Use equivalences to simplify types"
|
||
|
|
(match-lambda*
|
||
|
|
[('?) (st:expand-output-type '?)]
|
||
|
|
[() (st:expand-output-type)]
|
||
|
|
[(x)
|
||
|
|
(sdl-alg-changed)
|
||
|
|
(send sdl-tidy-object enable x)
|
||
|
|
(st:expand-output-type x)])
|
||
|
|
'st:expand-output-type
|
||
|
|
st:expand-output-type-container-panel)])
|
||
|
|
(void))
|
||
|
|
|
||
|
|
p)))
|
||
|
|
|
||
|
|
(mred:add-preference-panel
|
||
|
|
"MrSpidey Type Display"
|
||
|
|
mrspidey-mk-type-display-prefs-panel)
|
||
|
|
|
||
|
|
(mrspidey-mk-type-display-prefs-panel
|
||
|
|
(make-object mred:horizontal-panel%
|
||
|
|
(make-object mred:frame% '() "dummy")))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
'(define (make-parameter-menu parameter)
|
||
|
|
(let* ([pairs
|
||
|
|
(map
|
||
|
|
(match-lambda [(tag name . _) (cons name tag)])
|
||
|
|
(parameter '?))]
|
||
|
|
[default-ndx
|
||
|
|
(recur loop ([n 0][pairs pairs])
|
||
|
|
(cond
|
||
|
|
[(null? pairs)
|
||
|
|
(error 'make-parameter-menu "Can't find para in pairs")]
|
||
|
|
[(equal? (parameter) (cdar pairs)) n]
|
||
|
|
[else (loop (add1 n) (cdr pairs))]))])
|
||
|
|
(let ([menu (make-object mred:menu%)])
|
||
|
|
(send menu append-check-set pairs parameter default-ndx)
|
||
|
|
;;(parameter (cdar pairs))
|
||
|
|
menu)))
|
||
|
|
|
||
|
|
|
||
|
|
|