#| -*-Scheme-*-
-$Id: fixart.scm,v 1.19 2008/02/10 06:14:05 cph Exp $
+$Id: fixart.scm,v 1.20 2008/02/14 02:35: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-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))
+(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))
\f
(define-integrable (guarantee-index-fixnum object caller)
(if (not (index-fixnum? object))
#| -*-Scheme-*-
-$Id: global.scm,v 14.82 2008/02/10 06:14:09 cph Exp $
+$Id: global.scm,v 14.83 2008/02/14 02:35: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,
(define-primitives
error-procedure
- set-interrupt-enables! with-interrupt-mask
+ get-interrupt-enables set-interrupt-enables! with-interrupt-mask
get-fixed-objects-vector with-history-disabled
- primitive-procedure-arity primitive-procedure-documentation
+ (primitive-procedure-arity 1)
+ (primitive-procedure-documentation 1)
;; Environment
lexical-reference lexical-assignment local-assignment
lexical-unassigned? lexical-unbound? lexical-unreferenceable?
;; Pointers
- object-datum
- (object-new-type object-set-type)
+ (object-type 1)
+ (object-datum 1)
+ (object-type? 2)
+ (object-new-type object-set-type 2)
make-non-pointer-object
+ eq?
;; Cells
make-cell cell? cell-contents set-cell-contents!
- )
-
-(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))
+ ;; 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 (host-big-endian?)
host-big-endian?-saved)
#| -*-Scheme-*-
-$Id: sysmac.scm,v 14.18 2008/02/10 06:14:17 cph Exp $
+$Id: sysmac.scm,v 14.19 2008/02/14 02:35: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,
environment
(let ((primitive-definition
(lambda (variable-name primitive-args)
- `(DEFINE-INTEGRABLE ,variable-name
- ,(apply make-primitive-procedure primitive-args)))))
+ (let ((primitive
+ (apply make-primitive-procedure primitive-args)))
+ (let ((arity (procedure-arity primitive)))
+ (if (eqv? (procedure-arity-min arity)
+ (procedure-arity-max arity))
+ (let ((names
+ (map (lambda (n) (symbol 'a n))
+ (iota (procedure-arity-min arity) 1))))
+ `(DEFINE-INTEGRABLE (,variable-name ,@names)
+ (,primitive ,@names)))
+ `(DEFINE-INTEGRABLE ,variable-name
+ ,primitive)))))))
`(BEGIN ,@(map (lambda (name)
(cond ((not (pair? name))
(primitive-definition name (list name)))
(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)
projects / mit-scheme.git / commitdiff