All parameters that are bound to variables now have proper names.

E.g., pretty-width now prints as #<procedure pretty-width>.
This commit is contained in:
Abdulaziz Ghuloum 2008-06-19 01:58:59 -07:00
parent 4bb7e170b5
commit e65b39d95d
4 changed files with 59 additions and 16 deletions

Binary file not shown.

View File

@ -229,10 +229,25 @@
(define (make-global-set! lhs rhs) (define (make-global-set! lhs rhs)
(make-funcall (make-primref '$init-symbol-value!) (make-funcall (make-primref '$init-symbol-value!)
(list (make-constant lhs) rhs))) (list (make-constant lhs) rhs)))
(define-syntax equal-case
(lambda (x)
(syntax-case x ()
[(_ val clause* ...)
(with-syntax ([body
(let f ([clause* #'(clause* ...)])
(syntax-case clause* (else)
[([else e e* ...])
#'(begin e e* ...)]
[([(datum* ...) e e* ...] . rest)
(with-syntax ([rest (f #'rest)])
#'(if (member t '(datum* ...))
(begin e e* ...)
rest))]))])
#'(let ([t val]) body))])))
(define (E x ctxt) (define (E x ctxt)
(cond (cond
[(pair? x) [(pair? x)
(case (car x) (equal-case (car x)
[(quote) (make-constant (cadr x))] [(quote) (make-constant (cadr x))]
[(if) [(if)
(make-conditional (make-conditional
@ -316,6 +331,43 @@
[(primitive) [(primitive)
(let ([var (cadr x)]) (let ([var (cadr x)])
(make-primref var))] (make-primref var))]
[((primitive make-parameter))
(case (length x)
[(2)
(let ([val-expr (cadr x)]
[t (gensym 't)]
[x (gensym 'x)])
(E `((lambda (,t)
(case-lambda
[() ,t]
[(,x) (set! ,t ,x)]))
,val-expr)
ctxt))]
[(3)
(let ([val-expr (cadr x)]
[guard-expr (caddr x)]
[f (gensym 'f)]
[t (gensym 't)]
[x (gensym 'x)])
(E `((case-lambda
[(,t ,f)
(if ((primitive procedure?) ,f)
(begin
(set! ,t (,f ,t))
(case-lambda
[() ,t]
[(,x) (set! ,t (,f ,x))]))
((primitive die)
'make-parameter
'"not a procedure"
,f))])
,val-expr
,guard-expr)
ctxt))]
[else
(make-funcall
(make-primref 'make-parameter)
(map (lambda (x) (E x #f)) (cdr x)))])]
[else [else
(let ([names (get-fmls (car x) (cdr x))]) (let ([names (get-fmls (car x) (cdr x))])
(make-funcall (make-funcall

View File

@ -13,24 +13,15 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus system parameters) (library (ikarus system parameters)
(export make-parameter) (export make-parameter)
(import (except (ikarus) make-parameter)) (import (except (ikarus) make-parameter))
(define make-parameter (define make-parameter
(case-lambda (let ()
[(x) (import (ikarus))
(case-lambda (case-lambda
[() x] [(x guard) (make-parameter x guard)]
[(v) (set! x v)])] [(x) (make-parameter x)]))))
[(x guard)
(unless (procedure? guard)
(die 'make-parameter "not a procedure" guard))
(set! x (guard x))
(case-lambda
[() x]
[(v) (set! x (guard v))])])))
(library (ikarus system handlers) (library (ikarus system handlers)
(export (export

View File

@ -1 +1 @@
1518 1519