#| -*-Scheme-*-
-$Id: boole.scm,v 14.10 2008/01/30 20:02:28 cph Exp $
+$Id: boole.scm,v 14.11 2008/02/10 06:14:02 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
\f
-(define-primitives not (false? not))
+(define-integrable (not object)
+ ((ucode-primitive not) object))
(define false #f)
(define true #t)
#| -*-Scheme-*-
-$Id: boot.scm,v 14.29 2008/01/30 20:02:28 cph Exp $
+$Id: boot.scm,v 14.30 2008/02/10 06:14:03 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define-integrable interrupt-mask/all #xFFFF)
(define (with-absolutely-no-interrupts thunk)
- (with-interrupt-mask interrupt-mask/none
- (lambda (interrupt-mask)
- interrupt-mask
- (thunk))))
+ ((ucode-primitive with-interrupt-mask)
+ interrupt-mask/none
+ (lambda (interrupt-mask)
+ interrupt-mask
+ (thunk))))
(define (without-interrupts thunk)
(with-limited-interrupts interrupt-mask/gc-ok
(thunk))))
(define (with-limited-interrupts limit-mask procedure)
- (with-interrupt-mask (fix:and limit-mask (get-interrupt-enables))
- procedure))
+ ((ucode-primitive with-interrupt-mask)
+ (fix:and limit-mask (get-interrupt-enables))
+ procedure))
+
+(define (object-constant? object)
+ ((ucode-primitive constant?) object))
-(define-primitives
- (object-constant? constant?)
- gc-space-status)
+(define (gc-space-status)
+ ((ucode-primitive gc-space-status)))
(define (object-pure? object)
object
(eq? object (default-object)))
(define-integrable (default-object)
- (object-new-type (ucode-type constant) 7))
\ No newline at end of file
+ ((ucode-primitive object-set-type) (ucode-type constant) 7))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: char.scm,v 14.34 2008/01/30 20:02:28 cph Exp $
+$Id: char.scm,v 14.35 2008/02/10 06:14:04 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
\f
-(define-primitives
- (char? 1)
- char->integer
- integer->char)
+(define-integrable (char? object)
+ ((ucode-primitive char?) object))
+
+(define-integrable (char->integer char)
+ ((ucode-primitive char->integer) char))
+
+(define-integrable (integer->char int)
+ ((ucode-primitive integer->char) int))
(define-integrable char-code-limit #x110000)
(define-integrable char-bits-limit #x10)
#| -*-Scheme-*-
-$Id: fixart.scm,v 1.18 2008/01/30 20:02:30 cph Exp $
+$Id: fixart.scm,v 1.19 2008/02/10 06:14:05 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
\f
-(define-primitives
- (fix:fixnum? fixnum? 1)
- (fixnum? fixnum? 1)
- (index-fixnum? index-fixnum? 1)
- (fix:zero? zero-fixnum? 1)
- (fix:negative? negative-fixnum? 1)
- (fix:positive? positive-fixnum? 1)
- (fix:= equal-fixnum? 2)
- (fix:< less-than-fixnum? 2)
- (fix:> greater-than-fixnum? 2)
- (fix:1+ one-plus-fixnum 1)
- (fix:-1+ minus-one-plus-fixnum 1)
- (fix:+ plus-fixnum 2)
- (fix:- minus-fixnum 2)
- (fix:* multiply-fixnum 2)
- (fix:divide divide-fixnum 2)
- (fix:quotient fixnum-quotient 2)
- (fix:remainder fixnum-remainder 2)
- (fix:gcd gcd-fixnum 2)
- (fix:andc fixnum-andc 2)
- (fix:and fixnum-and 2)
- (fix:or fixnum-or 2)
- (fix:xor fixnum-xor 2)
- (fix:not fixnum-not 1)
- (fix:lsh fixnum-lsh 2)
-
- (int:integer? integer? 1)
- (int:zero? integer-zero? 1)
- (int:positive? integer-positive? 1)
- (int:negative? integer-negative? 1)
- (int:= integer-equal? 2)
- (int:< integer-less? 2)
- (int:> integer-greater? 2)
- (int:negate integer-negate 1)
- (int:1+ integer-add-1 1)
- (int:-1+ integer-subtract-1 1)
- (int:+ integer-add 2)
- (int:- integer-subtract 2)
- (int:* integer-multiply 2)
- (int:divide integer-divide 2)
- (int:quotient integer-quotient 2)
- (int:remainder integer-remainder 2)
-
- (flo:flonum? flonum? 1)
- (flo:zero? flonum-zero? 1)
- (flo:positive? flonum-positive? 1)
- (flo:negative? flonum-negative? 1)
- (flo:= flonum-equal? 2)
- (flo:< flonum-less? 2)
- (flo:> flonum-greater? 2)
- (flo:+ flonum-add 2)
- (flo:- flonum-subtract 2)
- (flo:* flonum-multiply 2)
- (flo:/ flonum-divide 2)
- (flo:negate flonum-negate 1)
- (flo:abs flonum-abs 1)
- (flo:exp flonum-exp 1)
- (flo:log flonum-log 1)
- (flo:sin flonum-sin 1)
- (flo:cos flonum-cos 1)
- (flo:tan flonum-tan 1)
- (flo:asin flonum-asin 1)
- (flo:acos flonum-acos 1)
- (flo:atan flonum-atan 1)
- (flo:atan2 flonum-atan2 2)
- (flo:sqrt flonum-sqrt 1)
- (flo:expt flonum-expt 2)
- (flo:floor flonum-floor 1)
- (flo:ceiling flonum-ceiling 1)
- (flo:truncate flonum-truncate 1)
- (flo:round flonum-round 1)
- (flo:floor->exact flonum-floor->exact 1)
- (flo:ceiling->exact flonum-ceiling->exact 1)
- (flo:truncate->exact flonum-truncate->exact 1)
- (flo:round->exact flonum-round->exact 1)
- (flo:vector-cons floating-vector-cons 1)
- (flo:vector-length floating-vector-length 1)
- (flo:vector-ref floating-vector-ref 2)
- (flo:vector-set! floating-vector-set! 3))
+(define-unary-primitive fix:-1+ minus-one-plus-fixnum)
+(define-unary-primitive fix:1+ one-plus-fixnum)
+(define-unary-primitive fix:fixnum? fixnum?)
+(define-unary-primitive fix:negative? negative-fixnum?)
+(define-unary-primitive fix:not fixnum-not)
+(define-unary-primitive fix:positive? positive-fixnum?)
+(define-unary-primitive fix:zero? zero-fixnum?)
+(define-unary-primitive fixnum? fixnum?)
+(define-unary-primitive index-fixnum? index-fixnum?)
+
+(define-binary-primitive fix:= equal-fixnum?)
+(define-binary-primitive fix:< less-than-fixnum?)
+(define-binary-primitive fix:> greater-than-fixnum?)
+(define-binary-primitive fix:+ plus-fixnum)
+(define-binary-primitive fix:- minus-fixnum)
+(define-binary-primitive fix:* multiply-fixnum)
+(define-binary-primitive fix:divide divide-fixnum)
+(define-binary-primitive fix:quotient fixnum-quotient)
+(define-binary-primitive fix:remainder fixnum-remainder)
+(define-binary-primitive fix:gcd gcd-fixnum)
+(define-binary-primitive fix:andc fixnum-andc)
+(define-binary-primitive fix:and fixnum-and)
+(define-binary-primitive fix:or fixnum-or)
+(define-binary-primitive fix:xor fixnum-xor)
+(define-binary-primitive fix:lsh fixnum-lsh)
+
+(define-unary-primitive int:-1+ integer-subtract-1)
+(define-unary-primitive int:1+ integer-add-1)
+(define-unary-primitive int:integer? integer?)
+(define-unary-primitive int:negate integer-negate)
+(define-unary-primitive int:negative? integer-negative?)
+(define-unary-primitive int:positive? integer-positive?)
+(define-unary-primitive int:zero? integer-zero?)
+
+(define-binary-primitive int:= integer-equal?)
+(define-binary-primitive int:< integer-less?)
+(define-binary-primitive int:> integer-greater?)
+(define-binary-primitive int:+ integer-add)
+(define-binary-primitive int:- integer-subtract)
+(define-binary-primitive int:* integer-multiply)
+(define-binary-primitive int:divide integer-divide)
+(define-binary-primitive int:quotient integer-quotient)
+(define-binary-primitive int:remainder integer-remainder)
+\f
+(define-unary-primitive flo:abs flonum-abs)
+(define-unary-primitive flo:acos flonum-acos)
+(define-unary-primitive flo:asin flonum-asin)
+(define-unary-primitive flo:atan flonum-atan)
+(define-unary-primitive flo:ceiling flonum-ceiling)
+(define-unary-primitive flo:ceiling->exact flonum-ceiling->exact)
+(define-unary-primitive flo:cos flonum-cos)
+(define-unary-primitive flo:exp flonum-exp)
+(define-unary-primitive flo:flonum? flonum?)
+(define-unary-primitive flo:floor flonum-floor)
+(define-unary-primitive flo:floor->exact flonum-floor->exact)
+(define-unary-primitive flo:log flonum-log)
+(define-unary-primitive flo:negate flonum-negate)
+(define-unary-primitive flo:negative? flonum-negative?)
+(define-unary-primitive flo:positive? flonum-positive?)
+(define-unary-primitive flo:round flonum-round)
+(define-unary-primitive flo:round->exact flonum-round->exact)
+(define-unary-primitive flo:sin flonum-sin)
+(define-unary-primitive flo:sqrt flonum-sqrt)
+(define-unary-primitive flo:tan flonum-tan)
+(define-unary-primitive flo:truncate flonum-truncate)
+(define-unary-primitive flo:truncate->exact flonum-truncate->exact)
+(define-unary-primitive flo:vector-cons floating-vector-cons)
+(define-unary-primitive flo:vector-length floating-vector-length)
+(define-unary-primitive flo:zero? flonum-zero?)
+
+(define-binary-primitive flo:= flonum-equal?)
+(define-binary-primitive flo:< flonum-less?)
+(define-binary-primitive flo:> flonum-greater?)
+(define-binary-primitive flo:+ flonum-add)
+(define-binary-primitive flo:- flonum-subtract)
+(define-binary-primitive flo:* flonum-multiply)
+(define-binary-primitive flo:/ flonum-divide)
+(define-binary-primitive flo:atan2 flonum-atan2)
+(define-binary-primitive flo:expt flonum-expt)
+(define-binary-primitive flo:vector-ref floating-vector-ref)
+
+(define-integrable (flo:vector-set! v i x)
+ ((ucode-primitive floating-vector-set!) v i x))
\f
(define-integrable (guarantee-index-fixnum object caller)
(if (not (index-fixnum? object))
#| -*-Scheme-*-
-$Id: gc.scm,v 14.27 2008/01/30 20:02:30 cph Exp $
+$Id: gc.scm,v 14.28 2008/02/10 06:14:06 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(set! constant-space-queue (list 'CONSTANT-SPACE-QUEUE))
(set! hook/gc-start default/gc-start)
(set! hook/gc-finish default/gc-finish)
- (let ((fixed-objects (get-fixed-objects-vector)))
+ (let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
(let ((interrupt-vector (vector-ref fixed-objects 1)))
(vector-set! interrupt-vector 0 condition-handler/stack-overflow)
(vector-set! interrupt-vector 2 condition-handler/gc))
#| -*-Scheme-*-
-$Id: gcdemn.scm,v 14.14 2008/01/30 20:02:30 cph Exp $
+$Id: gcdemn.scm,v 14.15 2008/02/10 06:14:07 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(set! secondary-gc-daemons (make-queue))
(set! trigger-secondary-gc-daemons! (make-trigger secondary-gc-daemons))
(set! add-secondary-gc-daemon! (make-adder secondary-gc-daemons))
- (let ((fixed-objects (get-fixed-objects-vector)))
+ (let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
(vector-set! fixed-objects #x0B trigger-primitive-gc-daemons!)
((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
#| -*-Scheme-*-
-$Id: gentag.scm,v 1.9 2008/01/30 20:02:31 cph Exp $
+$Id: gentag.scm,v 1.10 2008/02/10 06:14:08 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
\f
(define (make-dispatch-tag contents)
(let ((tag
- (object-new-type
+ ((ucode-primitive object-set-type)
(ucode-type record)
((ucode-primitive vector-cons) dispatch-tag-index-end #f))))
(%record-set! tag 0 dispatch-tag-marker)
(define-integrable dispatch-tag-index-start 2)
(define-integrable dispatch-tag-index-end 10)
-(define-integrable dispatch-tag-ref %record-ref)
-(define-integrable dispatch-tag-set! %record-set!)
+
+(define-integrable (dispatch-tag-ref t i)
+ (%record-ref t i))
+
+(define-integrable (dispatch-tag-set! t i x)
+ (%record-set! t i x))
(define (dispatch-tag-contents tag)
(guarantee-dispatch-tag tag 'DISPATCH-TAG-CONTENTS)
#| -*-Scheme-*-
-$Id: global.scm,v 14.81 2008/01/30 20:02:31 cph Exp $
+$Id: global.scm,v 14.82 2008/02/10 06:14:09 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define-primitives
error-procedure
- get-interrupt-enables set-interrupt-enables! with-interrupt-mask
+ set-interrupt-enables! with-interrupt-mask
get-fixed-objects-vector with-history-disabled
- (primitive-procedure-arity 1)
- (primitive-procedure-documentation 1)
+ primitive-procedure-arity primitive-procedure-documentation
;; Environment
lexical-reference lexical-assignment local-assignment
lexical-unassigned? lexical-unbound? lexical-unreferenceable?
;; Pointers
- (object-type 1)
- (object-datum 1)
- (object-type? 2)
- (object-new-type object-set-type 2)
+ object-datum
+ (object-new-type object-set-type)
make-non-pointer-object
- eq?
;; Cells
make-cell cell? cell-contents set-cell-contents!
- ;; System Compound Datatypes
- system-pair-cons system-pair?
- system-pair-car system-pair-set-car!
- system-pair-cdr system-pair-set-cdr!
-
- hunk3-cons
- system-hunk3-cxr0 system-hunk3-set-cxr0!
- system-hunk3-cxr1 system-hunk3-set-cxr1!
- system-hunk3-cxr2 system-hunk3-set-cxr2!
-
- (system-list->vector system-list-to-vector)
- (system-subvector->list system-subvector-to-list)
- system-vector?
- (system-vector-length system-vector-size)
- system-vector-ref
- system-vector-set!)
+ )
+
+(define-integrable (eq? x y)
+ ((ucode-primitive eq?) x y))
+
+(define-integrable (get-interrupt-enables)
+ ((ucode-primitive get-interrupt-enables)))
+
+(define-integrable (object-type object)
+ ((ucode-primitive object-type) object))
+
+(define-integrable (object-type? type object)
+ ((ucode-primitive object-type?) type object))
+
+(define-integrable (system-pair? object)
+ ((ucode-primitive system-pair?) object))
+
+(define-integrable (system-pair-cons type a b)
+ ((ucode-primitive system-pair-cons) type a b))
+
+(define-integrable (system-pair-car p)
+ ((ucode-primitive system-pair-car) p))
+
+(define-integrable (system-pair-cdr p)
+ ((ucode-primitive system-pair-cdr) p))
+
+(define-integrable (system-pair-set-car! p o)
+ ((ucode-primitive system-pair-set-car!) p o))
+
+(define-integrable (system-pair-set-cdr! p o)
+ ((ucode-primitive system-pair-set-cdr!) p o))
+\f
+(define-integrable (system-vector? object)
+ ((ucode-primitive system-vector?) object))
+
+(define-integrable (system-vector-ref v i)
+ ((ucode-primitive system-vector-ref) v i))
+
+(define-integrable (system-vector-set! v i x)
+ ((ucode-primitive system-vector-set!) v i x))
+
+(define-integrable (system-vector-length v)
+ ((ucode-primitive system-vector-size) v))
+
+(define-integrable (system-list->vector type list)
+ ((ucode-primitive system-list-to-vector) type list))
+
+(define-integrable (system-subvector->list v s e)
+ ((ucode-primitive system-subvector-to-list) v s e))
+
+(define-integrable (hunk3-cons x0 x1 x2)
+ ((ucode-primitive hunk3-cons) x0 x1 x2))
+
+(define-integrable (system-hunk3-cxr0 h3)
+ ((ucode-primitive system-hunk3-cxr0) h3))
+
+(define-integrable (system-hunk3-cxr1 h3)
+ ((ucode-primitive system-hunk3-cxr1) h3))
+
+(define-integrable (system-hunk3-cxr2 h3)
+ ((ucode-primitive system-hunk3-cxr2) h3))
+
+(define-integrable (system-hunk3-set-cxr0! h3 o)
+ ((ucode-primitive system-hunk3-set-cxr0!) h3 o))
+
+(define-integrable (system-hunk3-set-cxr1! h3 o)
+ ((ucode-primitive system-hunk3-set-cxr1!) h3 o))
+
+(define-integrable (system-hunk3-set-cxr2! h3 o)
+ ((ucode-primitive system-hunk3-set-cxr2!) h3 o))
(define (host-big-endian?)
host-big-endian?-saved)
#| -*-Scheme-*-
-$Id: list.scm,v 14.57 2008/01/30 20:02:32 cph Exp $
+$Id: list.scm,v 14.58 2008/02/10 06:14:10 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
\f
-(define-primitives
- cons pair? null? car cdr set-car! set-cdr! general-car-cdr)
+(define-integrable (cons a b)
+ ((ucode-primitive cons) a b))
+
+(define-integrable (pair? object)
+ ((ucode-primitive pair?) object))
+
+(define-integrable (null? object)
+ ((ucode-primitive null?) object))
+
+(define-integrable (car p)
+ ((ucode-primitive car) p))
+
+(define-integrable (cdr p)
+ ((ucode-primitive cdr) p))
+
+(define-integrable (set-car! p v)
+ ((ucode-primitive set-car!) p v))
+
+(define-integrable (set-cdr! p v)
+ ((ucode-primitive set-cdr!) p v))
+
+(define-integrable (general-car-cdr p i)
+ ((ucode-primitive general-car-cdr) p i))
(define (list . items)
items)
(define (xcons d a)
(cons a d))
-
+\f
(define (iota count #!optional start step)
(guarantee-index-fixnum count 'IOTA)
(let ((start
(if (fix:> count 0)
(cons value (loop (fix:- count 1) (+ value step)))
'()))))
-\f
+
(define (list? object)
(let loop ((l1 object) (l2 object))
(if (pair? l1)
#| -*-Scheme-*-
-$Id: make.scm,v 14.114 2008/02/02 18:20:59 cph Exp $
+$Id: make.scm,v 14.115 2008/02/10 06:14:11 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
\f
-(set-interrupt-enables! 0)
+((ucode-primitive set-interrupt-enables!) 0)
;; This must be defined as follows so that it is no part of a multi-define
;; itself. It must also precede any other top-level definitions in this file
;; that are not performed directly using LOCAL-ASSIGNMENT.
-(local-assignment
+((ucode-primitive local-assignment)
#f ;global environment
'DEFINE-MULTIPLE
(lambda (env names values)
(let loop ((i 0) (val unspecific))
(if (fix:< i len)
(loop (fix:+ i 1)
- (local-assignment env
- (vector-ref names i)
- (vector-ref values i)))
+ ((ucode-primitive local-assignment) env
+ (vector-ref names i)
+ (vector-ref values i)))
val)))))
(define system-global-environment #f)
;; *MAKE-ENVIRONMENT is referred to by compiled code. It must go
;; before the uses of the-environment later, and after apply above.
(define (*make-environment parent names . values)
- (let-syntax
- ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (microcode-type (cadr form))))))
- (system-list->vector
- (ucode-type environment)
- (cons (system-pair-cons (ucode-type procedure)
- (system-pair-cons (ucode-type lambda)
- unspecific
- names)
- parent)
- values))))
+ ((ucode-primitive system-list-to-vector)
+ (ucode-type environment)
+ (cons ((ucode-primitive system-pair-cons)
+ (ucode-type procedure)
+ ((ucode-primitive system-pair-cons) (ucode-type lambda)
+ unspecific
+ names)
+ parent)
+ values)))
\f
(let ((environment-for-package
(*make-environment system-global-environment
(vector lambda-tag:unnamed))))
-(define-syntax ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form)))))
-
-(define-syntax ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (microcode-type (cadr form)))))
-
(define-integrable + (ucode-primitive integer-add))
(define-integrable - (ucode-primitive integer-subtract))
(define-integrable < (ucode-primitive integer-less?))
(define (implemented-primitive-procedure? primitive)
((ucode-primitive get-primitive-address)
- (intern ((ucode-primitive get-primitive-name) (object-datum primitive)))
+ (intern ((ucode-primitive get-primitive-name)
+ ((ucode-primitive object-datum) primitive)))
#f))
(define initialize-c-compiled-block
#| -*-Scheme-*-
-$Id: packag.scm,v 14.58 2008/02/02 18:20:19 cph Exp $
+$Id: packag.scm,v 14.59 2008/02/10 06:14:12 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#f
vn)
environment))
- (object-new-type (ucode-type environment) vv)))))
+ ((ucode-primitive object-set-type) (ucode-type environment) vv)))))
(define null-environment
- (object-new-type (object-type #f)
- (fix:xor (object-datum #F) 1)))
+ ((ucode-primitive object-set-type)
+ ((ucode-primitive object-type) #f)
+ (fix:xor ((ucode-primitive object-datum) #F) 1)))
(define (find-package-environment name)
(package/environment (find-package name)))
(primitive-object-set-type (ucode-type reference-trap) 0))
(define-primitives
+ lexical-reference
lexical-unbound?
+ lexical-unreferenceable?
link-variables
local-assignment
primitive-object-set-type)
#| -*-Scheme-*-
-$Id: random.scm,v 14.41 2008/01/30 20:02:34 cph Exp $
+$Id: random.scm,v 14.42 2008/02/10 06:14:13 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define-integrable b. 4294967291. #|(exact->inexact b)|#)
(define (flo:random-element state)
- (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((mask ((ucode-primitive set-interrupt-enables!) interrupt-mask/gc-ok)))
(let ((index (random-state-index state))
(vector (random-state-vector state)))
(let ((element (flo:vector-ref vector index)))
(if (fix:= (fix:+ index 1) r)
0
(fix:+ index 1))))
- (set-interrupt-enables! mask)
+ ((ucode-primitive set-interrupt-enables!) mask)
element))))
(define-integrable (int:random-element state)
#| -*-Scheme-*-
-$Id: record.scm,v 1.60 2008/01/30 20:02:34 cph Exp $
+$Id: record.scm,v 1.61 2008/02/10 06:14:14 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
(define-primitives
- (%record? 1)
(%record -1)
- (%record-length 1)
- (%record-ref 2)
- (%record-set! 3)
(primitive-object-ref 2)
(primitive-object-set! 3)
- (primitive-object-set-type 2)
- (vector-cons 2))
+ (primitive-object-set-type 2))
+
+(define-integrable (%record? object)
+ ((ucode-primitive %record?) object))
+
+(define-integrable (%record-length record)
+ ((ucode-primitive %record-length) record))
+
+(define-integrable (%record-ref record index)
+ ((ucode-primitive %record-ref) record index))
+
+(define-integrable (%record-set! record index value)
+ ((ucode-primitive %record-set!) record index value))
+
+(define-integrable (vector-cons length object)
+ ((ucode-primitive vector-cons) length object))
(define-integrable (%make-record length object)
- (object-new-type (ucode-type record) (vector-cons length object)))
+ ((ucode-primitive object-set-type) (ucode-type record)
+ (vector-cons length object)))
(define-integrable (%record-tag record)
(%record-ref record 0))
#!optional default-inits unparser-method)
(let ((caller 'MAKE-RECORD-TYPE))
(guarantee-list-of-unique-symbols field-names caller)
- (let* ((names (list->vector field-names))
+ (let* ((names ((ucode-primitive list->vector) field-names))
(n (vector-length names))
(record-type
(%record record-type-type-tag
(guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES)
;; Can't use VECTOR->LIST here because it isn't available at cold load.
(let ((v (%record-type-field-names record-type)))
- (subvector->list v 0 (vector-length v))))
+ ((ucode-primitive subvector->list) v 0 (vector-length v))))
\f
(define (record-type-default-inits record-type)
(guarantee-record-type record-type 'RECORD-TYPE-DEFAULT-INITS)
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.643 2008/02/02 18:21:30 cph Exp $
+$Id: runtime.pkg,v 14.644 2008/02/10 06:14:15 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(files "boole")
(parent (runtime))
(export ()
+ (false? not)
boolean/and
boolean/or
boolean=?
boolean?
false
- false?
for-all?
not
there-exists?
define-guarantee)
(export (runtime)
define-primitives
+ define-unary-primitive
+ define-binary-primitive
ucode-primitive
ucode-return-address
ucode-type))
#| -*-Scheme-*-
-$Id: string.scm,v 14.67 2008/01/30 20:02:35 cph Exp $
+$Id: string.scm,v 14.68 2008/02/10 06:14:16 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
\f
;;;; Primitives
-(define-primitives
- read-byte-from-memory
- set-string-length!
- set-string-maximum-length!
- string-allocate
- string-hash-mod
- string-length
- string-maximum-length
- string-ref
- string-set!
- string?
- substring-move-left!
- substring-move-right!
- vector-8b-ref
- vector-8b-set!
- write-byte-to-memory
- )
+(define-integrable (string-allocate n)
+ ((ucode-primitive string-allocate) n))
+
+(define-integrable (string? object)
+ ((ucode-primitive string?) object))
+
+(define-integrable (string-length string)
+ ((ucode-primitive string-length) string))
+
+(define-integrable (string-maximum-length string)
+ ((ucode-primitive string-maximum-length) string))
+
+(define-integrable (set-string-length! string length)
+ ((ucode-primitive set-string-length!) string length))
+
+(define-integrable (set-string-maximum-length! string length)
+ ((ucode-primitive set-string-maximum-length!) string length))
+
+(define-integrable (string-ref string index)
+ ((ucode-primitive string-ref) string index))
+
+(define-integrable (string-set! string index char)
+ ((ucode-primitive string-set!) string index char))
+
+(define-integrable (substring-move-left! string1 start1 end1 string2 start2)
+ ((ucode-primitive substring-move-left!) string1 start1 end1 string2 start2))
+
+(define-integrable (substring-move-right! string1 start1 end1 string2 start2)
+ ((ucode-primitive substring-move-right!) string1 start1 end1 string2 start2))
+
+(define-integrable (vector-8b-ref vector-8b index)
+ ((ucode-primitive vector-8b-ref) vector-8b index))
+
+(define-integrable (vector-8b-set! vector-8b index byte)
+ ((ucode-primitive vector-8b-set!) vector-8b index byte))
(define-integrable (vector-8b-fill! string start end ascii)
(substring-fill! string start end (ascii->char ascii)))
((ucode-primitive string-hash) key)
((ucode-primitive string-hash-mod) key modulus)))
+(define (string-hash-mod key modulus)
+ ((ucode-primitive string-hash-mod) key modulus))
+
(define (string-ci-hash key #!optional modulus)
(string-hash (string-downcase key) modulus))
(define (xstring-ref xstring index)
(cond ((external-string? xstring)
(ascii->char
- (read-byte-from-memory
+ ((ucode-primitive read-byte-from-memory)
(+ (external-string-descriptor xstring) index))))
((string? xstring)
(string-ref xstring index))
(define (xstring-set! xstring index char)
(cond ((external-string? xstring)
- (write-byte-to-memory
+ ((ucode-primitive write-byte-to-memory)
(char->ascii char)
(+ (external-string-descriptor xstring) index)))
((string? xstring)
#| -*-Scheme-*-
-$Id: sysmac.scm,v 14.17 2008/01/30 20:02:36 cph Exp $
+$Id: sysmac.scm,v 14.18 2008/02/10 06:14:17 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(primitive-definition (car name) (cdr name)))))
(cdr form)))))))
+(define-syntax define-unary-primitive
+ (sc-macro-transformer
+ (lambda (form env)
+ env
+ (if (syntax-match? '(SYMBOL SYMBOL) (cdr form))
+ `(DEFINE-INTEGRABLE (,(cadr form) X)
+ ((ucode-primitive ,(caddr form)) X))
+ (ill-formed-syntax form)))))
+
+(define-syntax define-binary-primitive
+ (sc-macro-transformer
+ (lambda (form env)
+ env
+ (if (syntax-match? '(SYMBOL SYMBOL) (cdr form))
+ `(DEFINE-INTEGRABLE (,(cadr form) X Y)
+ ((ucode-primitive ,(caddr form)) X Y))
+ (ill-formed-syntax form)))))
+
(define-syntax ucode-type
(sc-macro-transformer
(lambda (form environment)
#| -*-Scheme-*-
-$Id: uproc.scm,v 1.22 2008/01/30 20:02:37 cph Exp $
+$Id: uproc.scm,v 1.23 2008/02/10 06:14:18 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define (procedure-arity procedure)
(let loop ((p procedure) (e 0))
(cond ((%primitive-procedure? p)
- (let ((arity (primitive-procedure-arity p)))
+ (let ((arity ((ucode-primitive primitive-procedure-arity) p)))
(cond ((fix:< arity 0)
(cons 0 #f))
((fix:<= e arity)
#| -*-Scheme-*-
-$Id: vector.scm,v 14.28 2008/01/30 20:02:37 cph Exp $
+$Id: vector.scm,v 14.29 2008/02/10 06:14:19 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
\f
-(define-primitives
- vector? vector-length vector-ref vector-set!
- list->vector vector subvector->list
- subvector-move-right! subvector-move-left! subvector-fill!)
+(define-integrable vector
+ (ucode-primitive vector))
+
+(define-integrable (vector? object)
+ ((ucode-primitive vector?) object))
+
+(define-integrable (vector-length v)
+ ((ucode-primitive vector-length) v))
+
+(define-integrable (vector-ref v i)
+ ((ucode-primitive vector-ref) v i))
+
+(define-integrable (vector-set! v i x)
+ ((ucode-primitive vector-set!) v i x))
+
+(define-integrable (list->vector list)
+ ((ucode-primitive list->vector) list))
+
+(define-integrable (subvector->list v s e)
+ ((ucode-primitive subvector->list) v s e))
+
+(define-integrable (subvector-fill! v s e x)
+ ((ucode-primitive subvector-fill!) v s e x))
+
+(define-integrable (subvector-move-left! v1 s1 e1 v2 s2)
+ ((ucode-primitive subvector-move-left!) v1 s1 e1 v2 s2))
+
+(define-integrable (subvector-move-right! v1 s1 e1 v2 s2)
+ ((ucode-primitive subvector-move-right!) v1 s1 e1 v2 s2))
(define-integrable (guarantee-vector object procedure)
(if (not (vector? object))
projects / mit-scheme.git / commitdiff