TOOL_COMPILER = $(TOOL_MIT_SCHEME) $(TOOL_COMPILER_BAND) $(TOOL_OPTIONS) \
$(TOOL_COMPILER_LOAD) --eval '(begin $(TOOL_COMPILER_SETTINGS))'
-TOOL_SYNTAXER = $(TOOL_MIT_SCHEME) $(TOOL_SYNTAXER_BAND) $(TOOL_OPTIONS) \
- $(TOOL_SYNTAXER_LOAD) --eval '(begin $(TOOL_SYNTAXER_SETTINGS))'
+TOOL_SYNTAXER = $(TOOL_MIT_SCHEME) $(TOOL_SYNTAXER_BAND) $(TOOL_SYNTAXER_LOAD) \
+ $(TOOL_OPTIONS) --eval '(begin $(TOOL_SYNTAXER_SETTINGS))'
TOOL_RUNTIME_ONLY = $(TOOL_MIT_SCHEME) $(TOOL_RUNTIME_ONLY_BAND) \
$(TOOL_OPTIONS)
(object-type? (ucode-type big-flonum) object))
(define (flo:normalize x)
- (let ((r ((ucode-primitive flonum-normalize 1) x)))
+ (let ((r (%flo:normalize x)))
(values (car r) (cdr r))))
+(define-integrable (%flo:normalize x)
+ ((ucode-primitive flonum-normalize 1) x))
+
(define-integrable flo:->integer
flo:truncate->exact)
(else (flo:->rational x)))))
(define (flo:->rational x)
- (with-values (lambda () (flo:normalize x))
- (lambda (f e-p)
+;;; Don't use multiple-values here because this gets called before they are
+;;; defined.
+ (let ((p (%flo:normalize x)))
+ (let ((f (car p))
+ (e-p (cdr p)))
(let ((p flo:significand-digits-base-2))
(rat:* (flo:->integer (flo:denormalize f p))
(rat:expt 2 (int:- e-p p)))))))
;(guarantee thunk? thunk 'make-unforced-promise)
(make-cell (make-cell (system-pair-cons (ucode-type delayed) #f thunk))))
-(define-integrable (%promise-parts promise)
+;;; Don't use multiple-values here because this gets called before they are
+;;; defined.
+(define-integrable (%promise-parts promise k)
(let ((p (cell-contents (cell-contents promise))))
- (values (system-pair-car p)
- (system-pair-cdr p))))
+ (k (system-pair-car p)
+ (system-pair-cdr p))))
(define (promise-forced? promise)
(guarantee promise? promise 'promise-forced?)
(define (promise-value promise)
(guarantee promise? promise 'promise-value)
- (receive (forced? value) (%promise-parts promise)
- (if (not forced?)
- (error "Promise not yet forced:" promise))
- value))
+ (%promise-parts promise
+ (lambda (forced? value)
+ (if (not forced?)
+ (error "Promise not yet forced:" promise))
+ value)))
(define (force promise)
(guarantee promise? promise 'force)
(%force promise))
(define (%force promise)
- (receive (forced? value) (%promise-parts promise)
- (if forced?
- value
- (let ((promise* (value)))
- (guarantee promise? promise* 'force)
- (if (eq? promise* promise)
- (error "Infinite recursion in promise:" promise))
- (without-interrupts
- (lambda ()
- (let ((q (cell-contents promise)))
- (if (not (system-pair-car (cell-contents q)))
- (let ((q* (cell-contents promise*)))
- ;; Reduce the chain of indirections by one link so
- ;; that we don't accumulate space.
- (set-cell-contents! q (cell-contents q*))
- ;; Point promise* at the same chain of
- ;; indirections as promise so that forcing
- ;; promise* will yield the same result.
- (set-cell-contents! promise* q))))))
- (%force promise)))))
+ (%promise-parts promise
+ (lambda (forced? value)
+ (if forced?
+ value
+ (let ((promise* (value)))
+ (guarantee promise? promise* 'force)
+ (if (eq? promise* promise)
+ (error "Infinite recursion in promise:" promise))
+ (without-interrupts
+ (lambda ()
+ (let ((q (cell-contents promise)))
+ (if (not (system-pair-car (cell-contents q)))
+ (let ((q* (cell-contents promise*)))
+ ;; Reduce the chain of indirections by one link so
+ ;; that we don't accumulate space.
+ (set-cell-contents! q (cell-contents q*))
+ ;; Point promise* at the same chain of
+ ;; indirections as promise so that forcing
+ ;; promise* will yield the same result.
+ (set-cell-contents! promise* q))))))
+ (%force promise))))))
(define-print-method promise?
(standard-print-method 'promise
'cref/object-root
#!default))
+
+(let ((env (->environment '(scode-optimizer expansion))))
+
+ (define (remove-at-index! index items setter)
+ (if (= index 0)
+ (setter (cdr items))
+ (remove-at-index! (- index 1)
+ (cdr items)
+ (pair-setter items))))
+
+ (define (pair-setter pair)
+ (lambda (tail)
+ (set-cdr! pair tail)))
+
+ (define (env-getter env name)
+ (lambda ()
+ (environment-lookup env name)))
+
+ (define (env-setter env name)
+ (lambda (tail)
+ (environment-assign! env name tail)))
+
+ (let ((get-names (env-getter env 'usual-integrations/expansion-names))
+ (set-names! (env-setter env 'usual-integrations/expansion-names))
+ (get-vals (env-getter env 'usual-integrations/expansion-values))
+ (set-vals! (env-setter env 'usual-integrations/expansion-values)))
+
+ (define (remove-one name)
+ (let ((names (get-names)))
+ (let ((i
+ (list-index (lambda (name*) (eq? name* name))
+ names)))
+ (remove-at-index! i names set-names!)
+ (remove-at-index! i (get-vals) set-vals!))))
+
+ (remove-one 'call-with-values)
+ (remove-one 'with-values)
+ (remove-one 'values)
+
+ (environment-assign! env
+ 'usual-integrations/expansion-alist
+ (map cons
+ (get-names)
+ (get-vals)))))
+
unspecific
\ No newline at end of file
((null? rest) (constant/make (and expr (object/scode expr)) '()))
(else (error "Improper list."))))
\f
-(define (values-expansion expr operands block)
- (let ((block (block/make block #t '())))
- (let ((variables
- (map (lambda (position)
- (variable/make&bind!
- block
- (string->uninterned-symbol
- (string-append "value-" (number->string position)))))
- (iota (length operands)))))
- (combination/make
- expr
- block
- (procedure/make
- #f
- block scode-lambda-name:let variables '() #f
- (let ((block (block/make block #t '())))
- (let ((variable (variable/make&bind! block 'receiver)))
- (procedure/make
- #f block scode-lambda-name:unnamed (list variable) '() #f
- (declaration/make
- #f
- ;; The receiver is used only once, and all its operand
- ;; expressions are effect-free, so integrating here is
- ;; safe.
- (declarations/parse block '((integrate-operator receiver)))
- (combination/make #f
- block
- (reference/make #f block variable)
- (map (lambda (variable)
- (reference/make #f block variable))
- variables)))))))
- operands))))
-
-(define (call-with-values-expansion expr operands block)
- (if (and (pair? operands)
- (pair? (cdr operands))
- (null? (cddr operands)))
- (combination/make expr
- block
- (combination/make #f block (car operands) '())
- (cdr operands))
- #f))
-
-\f
;;;; General CAR/CDR Encodings
(define (call-to-car? expression)
cadddr
caddr
cadr
- call-with-values
car
cdaaar
cdaadr
string->symbol
symbol?
third
- values
weak-pair?
- with-values
zero?)
(map car global-primitives)))
\f
cadddr-expansion
caddr-expansion
cadr-expansion
- call-with-values-expansion
car-expansion
cdaaar-expansion
cdaadr-expansion
string->symbol-expansion
symbol?-expansion
third-expansion
- values-expansion
weak-pair?-expansion
- call-with-values-expansion
zero?-expansion)
(map (lambda (p)
(make-primitive-expander
projects / mit-scheme.git / commitdiff