From: Chris Hanson Date: Thu, 14 Feb 2008 02:35:05 +0000 (+0000) Subject: On Taylor's suggestion, change DEFINE-PRIMITIVES so that it generates X-Git-Tag: 20090517-FFI~317 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7630d7ce75c7a090fbca0c992c2da5cd585ecddb;p=mit-scheme.git On Taylor's suggestion, change DEFINE-PRIMITIVES so that it generates compound procedures rather than just binding the variables to the primitive-procedure objects. This allows us to drop the new macros needed by fixart, eliminating the need to patch older compilers to compile this code. --- diff --git a/v7/src/runtime/fixart.scm b/v7/src/runtime/fixart.scm index fa452e980..2f3d2848f 100644 --- a/v7/src/runtime/fixart.scm +++ b/v7/src/runtime/fixart.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -30,89 +30,85 @@ USA. (declare (usual-integrations)) -(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) - -(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)) (define-integrable (guarantee-index-fixnum object caller) (if (not (index-fixnum? object)) diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 384c3e162..1d1fb50ed 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -34,92 +34,42 @@ USA. (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)) - -(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) diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm index 6893278ac..0d825b154 100644 --- a/v7/src/runtime/sysmac.scm +++ b/v7/src/runtime/sysmac.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -36,8 +36,18 @@ USA. 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))) @@ -47,24 +57,6 @@ USA. (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)