diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ce8dc7f38..08a3e5216 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,13 @@ Sat Mar 1 15:24:39 1997 Mikael Djurfeldt + * boot-9.scm: Removed the old printer code. + + * r4rs.scm (apply, call-with-current-continuation): Added comment + explaining why apply and call/cc need to be closures. + + * boot-9.scm (apply, call-with-current-continuation): Bugfix: + Removed. These definitions are already present in r4rs.scm. + * debug.scm (trace-entry, trace-exit): Check that we're on a repl stack before printing traced frames; Re-enable trace flag at end of handlers. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index abe9bc32d..0fecb6b59 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -70,18 +70,6 @@ (newline) (car (last-pair stuff))))) - -;;; {apply and call-with-current-continuation} -;;; -;;; These turn syntax, @apply and @call-with-current-continuation, -;;; into procedures. -;;; - -(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args)))) -(define (call-with-current-continuation proc) - (@call-with-current-continuation proc)) - - ;;; {Trivial Functions} ;;; @@ -309,111 +297,6 @@ (let ((rem (member kw args))) (and rem (pair? (cdr rem)) (cadr rem)))) - -;;; {Print} -;;; MDJ 960919 : This code will probably be -;;; removed before the first release of Guile. Later releases may -;;; contain more fancy printing code. - -(define (print obj . args) - (let ((default-args (list (current-output-port) 0 0 default-print-style #f))) - (apply-to-args (append args (list-cdr-ref default-args (length args))) - (lambda (port depth length style table) - (cond - ((and table (print-table-ref table obj)) - ((print-style-tag-hook style 'eq-val) - obj port depth length style table)) - (else - (and table (print-table-add! table obj)) - (cond - ((print-style-max-depth? style depth) - ((print-style-excess-depth-hook style))) - ((print-style-max-length? style length) - ((print-style-excess-length-hook style))) - (else - ((print-style-hook style obj) - obj port depth length style table))))))))) - -(define (make-print-style) (make-vector 59 '())) - -(define (extend-print-style! style utag printer) - (hashq-set! style utag printer)) - -(define (print-style-hook style obj) - (let ((type-tag (tag obj))) - (or (hashq-ref style type-tag) - (hashq-ref style (logand type-tag 255)) - print-obj))) - -(define (print-style-tag-hook style type-tag) - (or (hashq-ref style type-tag) - print-obj)) - -(define (print-style-max-depth? style d) #f) -(define (print-style-max-length? style l) #f) -(define (print-style-excess-length-hook style) - (hashq-ref style 'excess-length-hook)) -(define (print-style-excess-depth-hook style) - (hashq-ref style 'excess-depth-hook)) - -(define (make-print-table) (make-vector 59 '())) -(define (print-table-ref table obj) (hashq-ref table obj)) -(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref))) - -(define (print-obj obj port depth length style table) (write obj port)) - -(define (print-pair pair port depth length style table) - (if (= 0 length) - (display #\( port)) - - (print (car pair) port (+ 1 depth) 0 style table) - - (cond - ((and (pair? (cdr pair)) - (or (not table) - (not (print-table-ref table (cdr pair))))) - - (display #\space port) - (print (cdr pair) port depth (+ 1 length) style table)) - - ((null? (cdr pair)) (display #\) port)) - - (else (display " . " port) - (print (cdr pair) port (+ 1 depth) 0 - style table) - (display #\) port)))) - -(define (print-vector obj port depth length style table) - (if (= 0 length) - (cond - ((weak-key-hash-table? obj) (display "#wh(" port)) - ((weak-value-hash-table? obj) (display "#whv(" port)) - ((doubly-weak-hash-table? obj) (display "#whd(" port)) - (else (display "#(" port)))) - - (if (< length (vector-length obj)) - (print (vector-ref obj length) port (+ 1 depth) 0 style table)) - - (cond - ((>= (+ 1 length) (vector-length obj)) (display #\) port)) - (else (display #\space port) - (print obj port depth - (+ 1 length) - style table)))) - -(define default-print-style (make-print-style)) - -(extend-print-style! default-print-style utag_vector print-vector) -(extend-print-style! default-print-style utag_wvect print-vector) -(extend-print-style! default-print-style utag_pair print-pair) -(extend-print-style! default-print-style 'eq-val - (lambda (obj port depth length style table) - (if (symbol? obj) - (display obj) - (begin - (display "##" port) - (display (print-table-ref table obj)))))) - ;;; {Records} ;;; diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm index 696ba4059..019968660 100644 --- a/ice-9/r4rs.scm +++ b/ice-9/r4rs.scm @@ -20,9 +20,9 @@ ;;;; apply and call-with-current-continuation -;;; These turn syntax, @apply and @call-with-current-continuation, -;;; into procedures. If someone knows why they have to be syntax to -;;; begin with, please fix this comment. +;;; We want these to be tail-recursive, so instead of using primitive +;;; procedures, we define them as closures in terms of the primitive +;;; macros @apply and @call-with-current-continuation. (set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args)))) (define (call-with-current-continuation proc) (@call-with-current-continuation proc))