mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-04 22:40:25 +02:00
Code Activity

* boot-9.scm (record-constructor, record-accessor,

Browse source 
record-modifier, scm-style-repl): Add second arg to eval.
(read-hash-extend #\.): Ditto.  (This is actually a bugfix!)
(eval-in-module): Redefined to be eval and deprecated.
This commit is contained in:
Mikael Djurfeldt 2000-08-11 08:45:35 +00:00
parent 26795895e2
commit d7faeb2ee9
1 changed files with 40 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

68
ice-9/boot-9.scm
View file

@ -329,6 +329,21 @@
(define (struct-layout s) (define (struct-layout s)
(struct-ref (struct-vtable s) vtable-index-layout)) (struct-ref (struct-vtable s) vtable-index-layout))
;;; Environments
(define the-environment
(procedure->syntax
(lambda (x e)
e)))
(define the-root-environment (the-environment))
(define (environment-module env)
(let ((closure (and (pair? env) (car (last-pair env)))))
(and closure (procedure-property closure 'module))))
;;; {Records} ;;; {Records}
;;; ;;;
@ -405,12 +420,13 @@
(define (record-constructor rtd . opt) (define (record-constructor rtd . opt)
(let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd)))) (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
(eval `(lambda ,field-names (local-eval `(lambda ,field-names
(make-struct ',rtd 0 ,@(map (lambda (f) (make-struct ',rtd 0 ,@(map (lambda (f)
(if (memq f field-names) (if (memq f field-names)
f f
#f)) #f))
(record-type-fields rtd))))))) (record-type-fields rtd))))
the-root-environment)))
(define (record-predicate rtd) (define (record-predicate rtd)
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
@ -419,17 +435,19 @@
(let* ((pos (list-index (record-type-fields rtd) field-name))) (let* ((pos (list-index (record-type-fields rtd) field-name)))
(if (not pos) (if (not pos)
(error 'no-such-field field-name)) (error 'no-such-field field-name))
(eval `(lambda (obj) (local-eval `(lambda (obj)
(and (eq? ',rtd (record-type-descriptor obj)) (and (eq? ',rtd (record-type-descriptor obj))
(struct-ref obj ,pos)))))) (struct-ref obj ,pos)))
the-root-environment)))
(define (record-modifier rtd field-name) (define (record-modifier rtd field-name)
(let* ((pos (list-index (record-type-fields rtd) field-name))) (let* ((pos (list-index (record-type-fields rtd) field-name)))
(if (not pos) (if (not pos)
(error 'no-such-field field-name)) (error 'no-such-field field-name))
(eval `(lambda (obj val) (local-eval `(lambda (obj val)
(and (eq? ',rtd (record-type-descriptor obj)) (and (eq? ',rtd (record-type-descriptor obj))
(struct-set! obj ,pos val)))))) (struct-set! obj ,pos val)))
the-root-environment)))
(define (record? obj) (define (record? obj)
@ -883,7 +901,7 @@
(read-hash-extend #\' (lambda (c port) (read-hash-extend #\' (lambda (c port)
(read port))) (read port)))
(read-hash-extend #\. (lambda (c port) (read-hash-extend #\. (lambda (c port)
(eval (read port)))) (eval (read port) (interaction-environment))))
;;; {Command Line Options} ;;; {Command Line Options}
@ -1067,6 +1085,8 @@
;; is a (CLOSURE module symbol) which, as a last resort, can provide ;; is a (CLOSURE module symbol) which, as a last resort, can provide
;; bindings that would otherwise not be found locally in the module. ;; bindings that would otherwise not be found locally in the module.
;; ;;
;; NOTE: If you change here, you also need to change libguile/modules.h.
;;
(define module-type (define module-type
(make-record-type 'module (make-record-type 'module
'(obarray uses binder eval-closure transformer name kind '(obarray uses binder eval-closure transformer name kind
@ -1148,8 +1168,9 @@
;; to maximally one module. ;; to maximally one module.
(set-procedure-property! closure 'module module)))) (set-procedure-property! closure 'module module))))
(define (eval-in-module exp module) ;;; This procedure is depreated
(eval2 exp (module-eval-closure module))) ;;;
(define eval-in-module eval)
;;; {Observer protocol} ;;; {Observer protocol}
@ -1502,6 +1523,7 @@
(fluid-set! the-module m) (fluid-set! the-module m)
(if m (if m
(begin (begin
;; *top-level-lookup-closure* is now deprecated
(fluid-set! *top-level-lookup-closure* (fluid-set! *top-level-lookup-closure*
(module-eval-closure (fluid-ref the-module))) (module-eval-closure (fluid-ref the-module)))
(fluid-set! scm:eval-transformer (module-transformer (fluid-ref the-module)))) (fluid-set! scm:eval-transformer (module-transformer (fluid-ref the-module))))
@ -2553,7 +2575,8 @@
(-eval (lambda (sourc) (-eval (lambda (sourc)
(repl-report-start-timing) (repl-report-start-timing)
(start-stack 'repl-stack (eval sourc)))) (start-stack 'repl-stack
(eval sourc (interaction-environment)))))
(-print (let ((maybe-print (lambda (result) (-print (let ((maybe-print (lambda (result)
(if (or scm-repl-print-unspecified (if (or scm-repl-print-unspecified
@ -2637,17 +2660,6 @@
`(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings)) `(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
(lambda () ,@body))) (lambda () ,@body)))
;;; Environments
(define the-environment
(procedure->syntax
(lambda (x e)
e)))
(define (environment-module env)
(let ((closure (and (pair? env) (car (last-pair env)))))
(and closure (procedure-property closure 'module))))
;;; {Macros} ;;; {Macros}
@ -2737,7 +2749,7 @@
;; suggests we use eval here to accomodate Hobbit; it lets ;; suggests we use eval here to accomodate Hobbit; it lets
;; the interpreter handle the define-private form, which ;; the interpreter handle the define-private form, which
;; Hobbit can't digest. ;; Hobbit can't digest.
(eval '(define-private ,@ args))))))) (eval '(define-private ,@ args) (interaction-environment)))))))