From 74d21c13df6f02b9a392ece75942f217a3a5bd7d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 13 Feb 2008 06:21:07 +0000 Subject: [PATCH] Redo the previous change: it was causing VERY BAD things to happen. This one should be considerably safer. --- v7/src/sf/pardec.scm | 10 +- v7/src/sf/subst.scm | 5 +- v7/src/sf/usicon.scm | 19 +-- v7/src/sf/usiexp.scm | 326 ++++++++++++++++++++++--------------------- 4 files changed, 173 insertions(+), 187 deletions(-) diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm index bfb360963..ed2f9ad75 100644 --- a/v7/src/sf/pardec.scm +++ b/v7/src/sf/pardec.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: pardec.scm,v 4.20 2008/02/10 04:42:41 cph Exp $ +$Id: pardec.scm,v 4.21 2008/02/13 06:21: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, @@ -216,13 +216,7 @@ USA. usual-integrations/constant-values) (for-each (constructor 'INTEGRATE) constant-names - constant-values)) - (receive (primitive-names primitive-values) - (do-deletions usual-integrations/primitive-names - usual-integrations/primitive-values) - (for-each (constructor 'INTEGRATE-OPERATOR) - primitive-names - primitive-values))) + constant-values))) (map* declarations (let ((top-level-block (let loop ((block block)) diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm index f802c0602..ab6152847 100644 --- a/v7/src/sf/subst.scm +++ b/v7/src/sf/subst.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: subst.scm,v 4.24 2008/02/10 04:42:42 cph Exp $ +$Id: subst.scm,v 4.25 2008/02/13 06:21: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, @@ -663,8 +663,7 @@ you ask for. => (lambda (operands*) (integrate/combination expression operations environment block (car operands*) (cdr operands*)))) - ((or (assq name usual-integrations/constant-alist) - (assq name usual-integrations/primitive-alist)) + ((assq name usual-integrations/constant-alist) => (lambda (entry) (integrate/combination expression operations environment block (cdr entry) operands))) diff --git a/v7/src/sf/usicon.scm b/v7/src/sf/usicon.scm index 10e194901..8a9136d8b 100644 --- a/v7/src/sf/usicon.scm +++ b/v7/src/sf/usicon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usicon.scm,v 4.13 2008/02/10 06:12:08 cph Exp $ +$Id: usicon.scm,v 4.14 2008/02/13 06:21: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, @@ -30,13 +30,10 @@ USA. (declare (usual-integrations) (integrate-external "object")) - + (define usual-integrations/constant-names) (define usual-integrations/constant-values) (define usual-integrations/constant-alist) -(define usual-integrations/primitive-names) -(define usual-integrations/primitive-values) -(define usual-integrations/primitive-alist) (define (usual-integrations/cache!) (set! usual-integrations/constant-names @@ -67,16 +64,4 @@ USA. #f (environment-lookup system-global-environment name)))) usual-integrations/constant-names)) - (set! usual-integrations/primitive-names - (map car global-primitives)) - (set! usual-integrations/primitive-values - (map (lambda (p) - (constant->integration-info - (make-primitive-procedure (cadr p)))) - global-primitives)) - (set! usual-integrations/primitive-alist - (map (lambda (p) - (cons (car p) - (constant/make #f (make-primitive-procedure (cadr p))))) - global-primitives)) unspecific) \ No newline at end of file diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index cdbaa5310..c475256a5 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usiexp.scm,v 4.49 2008/01/30 20:02:38 cph Exp $ +$Id: usiexp.scm,v 4.50 2008/02/13 06:21: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, @@ -576,170 +576,178 @@ USA. (ucode-primitive integer->flonum 2) (list (car operands) (constant/make #f #b10)))) (if-not-expanded))) + +(define (make-primitive-expander primitive) + (lambda (expr operands if-expanded if-not-expanded block) + (if (procedure-arity-valid? primitive (length operands)) + (if-expanded (make-combination expr block primitive operands)) + (if-not-expanded)))) ;;;; Tables (define usual-integrations/expansion-names - '( - * - + - - - -1+ - / - 1+ - < - <= - = - > - >= - apply - caaaar - caaadr - caaar - caadar - caaddr - caadr - caar - cadaar - cadadr - cadar - caddar - cadddr - caddr - cadr - call-with-values - cdaaar - cdaadr - cdaar - cdadar - cdaddr - cdadr - cdar - cddaar - cddadr - cddar - cdddar - cddddr - cdddr - cddr - char=? - complex? - cons* - default-object? - eighth - exact-integer? - exact-rational? - expt - fifth - first - fix:<= - fix:= - fix:>= - fourth - int:->flonum - int:integer? - intern - list - make-string - make-vector-8b - ;; modulo ; Compiler does not currently open-code it. - negative? - number? - positive? - quotient - remainder - second - seventh - sixth - string->symbol - symbol? - third - values - weak-pair? - with-values - zero? - )) + (append '(* + + + - + -1+ + / + 1+ + < + <= + = + > + >= + apply + caaaar + caaadr + caaar + caadar + caaddr + caadr + caar + cadaar + cadadr + cadar + caddar + cadddr + caddr + cadr + call-with-values + cdaaar + cdaadr + cdaar + cdadar + cdaddr + cdadr + cdar + cddaar + cddadr + cddar + cdddar + cddddr + cdddr + cddr + char=? + complex? + cons* + default-object? + eighth + exact-integer? + exact-rational? + expt + fifth + first + fix:<= + fix:= + fix:>= + fourth + int:->flonum + int:integer? + intern + list + make-string + make-vector-8b + ;; modulo ; Compiler does not currently open-code it. + negative? + number? + positive? + quotient + remainder + second + seventh + sixth + string->symbol + symbol? + third + values + weak-pair? + with-values + zero?) + (map car global-primitives))) (define usual-integrations/expansion-values - (list - *-expansion - +-expansion - --expansion - -1+-expansion - /-expansion - 1+-expansion - <-expansion - <=-expansion - =-expansion - >-expansion - >=-expansion - apply*-expansion - caaaar-expansion - caaadr-expansion - caaar-expansion - caadar-expansion - caaddr-expansion - caadr-expansion - caar-expansion - cadaar-expansion - cadadr-expansion - cadar-expansion - caddar-expansion - cadddr-expansion - caddr-expansion - cadr-expansion - call-with-values-expansion - cdaaar-expansion - cdaadr-expansion - cdaar-expansion - cdadar-expansion - cdaddr-expansion - cdadr-expansion - cdar-expansion - cddaar-expansion - cddadr-expansion - cddar-expansion - cdddar-expansion - cddddr-expansion - cdddr-expansion - cddr-expansion - char=?-expansion - complex?-expansion - cons*-expansion - default-object?-expansion - eighth-expansion - exact-integer?-expansion - exact-rational?-expansion - expt-expansion - fifth-expansion - first-expansion - fix:<=-expansion - fix:=-expansion - fix:>=-expansion - fourth-expansion - int:->flonum-expansion - exact-integer?-expansion - intern-expansion - list-expansion - make-string-expansion - make-string-expansion - ;; modulo-expansion - negative?-expansion - complex?-expansion - positive?-expansion - quotient-expansion - remainder-expansion - second-expansion - seventh-expansion - sixth-expansion - string->symbol-expansion - symbol?-expansion - third-expansion - values-expansion - weak-pair?-expansion - call-with-values-expansion - zero?-expansion - )) + (append (list + *-expansion + +-expansion + --expansion + -1+-expansion + /-expansion + 1+-expansion + <-expansion + <=-expansion + =-expansion + >-expansion + >=-expansion + apply*-expansion + caaaar-expansion + caaadr-expansion + caaar-expansion + caadar-expansion + caaddr-expansion + caadr-expansion + caar-expansion + cadaar-expansion + cadadr-expansion + cadar-expansion + caddar-expansion + cadddr-expansion + caddr-expansion + cadr-expansion + call-with-values-expansion + cdaaar-expansion + cdaadr-expansion + cdaar-expansion + cdadar-expansion + cdaddr-expansion + cdadr-expansion + cdar-expansion + cddaar-expansion + cddadr-expansion + cddar-expansion + cdddar-expansion + cddddr-expansion + cdddr-expansion + cddr-expansion + char=?-expansion + complex?-expansion + cons*-expansion + default-object?-expansion + eighth-expansion + exact-integer?-expansion + exact-rational?-expansion + expt-expansion + fifth-expansion + first-expansion + fix:<=-expansion + fix:=-expansion + fix:>=-expansion + fourth-expansion + int:->flonum-expansion + exact-integer?-expansion + intern-expansion + list-expansion + make-string-expansion + make-string-expansion + ;; modulo-expansion + negative?-expansion + complex?-expansion + positive?-expansion + quotient-expansion + remainder-expansion + second-expansion + seventh-expansion + sixth-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 + (make-primitive-procedure (cadr p)))) + global-primitives))) (define usual-integrations/expansion-alist (map cons -- 2.25.1