From: Stephen Adams Date: Mon, 4 Sep 1995 21:07:36 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~5994 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=06ade53b31a3f8d6ad64159aa0623e5b12c77efe;p=mit-scheme.git Initial revision --- diff --git a/v8/src/compiler/midend/kmp.scm b/v8/src/compiler/midend/kmp.scm new file mode 100644 index 000000000..e8ebaee9e --- /dev/null +++ b/v8/src/compiler/midend/kmp.scm @@ -0,0 +1,114 @@ +#| -*-Scheme-*- + +$Id: kmp.scm,v 1.1 1995/09/04 21:07:36 adams Exp $ + +Copyright (c) 1995 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; KMP scheme syntax +;;; package: (compiler midend) + +(declare (usual-integrations)) + +;;______________________________________________________________________ +;; +;; Syntax abstractions +;;______________________________________________________________________ + +(let-syntax + ((kmp-form-accessors + (macro (name . args) + (define (->string x) (if (symbol? x) (symbol-name x) x)) + (define (->sym . stuff) + (intern (apply string-append (map ->string stuff)))) + (define (loop args path defs) + (define (add-def field path) + (let ((base-name (->sym name "/" field)) + (safe-name (->sym name "/" field "/safe")) + (unsafe-name (->sym name "/" field "/unsafe"))) + (cons* `(DEFINE-INTEGRABLE (,base-name FORM) + (,safe-name FORM)) + `(DEFINE-INTEGRABLE (,unsafe-name FORM) + ,path) + `(DEFINE (,safe-name FORM) + (IF (AND (PAIR? FORM) + (EQ? (CAR FORM) ',name)) + ,path + (INTERNAL-ERROR "Illegal KMP syntax" ',name FORM))) + defs))) + (cond ((null? args) + defs) + ((eq? (car args) '#!REST) + (add-def (cadr args) path)) + ((eq? (car args) '#F) + (loop (cdr args) `(CDR ,path) defs)) + (else + (loop (cdr args) + `(CDR ,path) + (add-def (car args) `(CAR ,path)))))) + `(BEGIN 1 ;bogon for 0 defs + ,@(reverse (loop args `(CDR FORM) '()))))) + + (alternate-kmp-form + (macro (name . args) + `(kmp-form-accessors ,name . ,args))) + (kmp-form + (macro (name . args) + `(BEGIN (DEFINE-INTEGRABLE (,(symbol-append name '/?) FORM) + (AND (PAIR? FORM) + (EQ? (CAR FORM) ',name))) + (kmp-form-accessors ,name . ,args))))) + + ;; Generate KMP accessors like QUOTE/TEXT (doesn't check head of + ;; form) and QUOTE/TEXT/SAFE (requires head of form to be QUOTE) + + (kmp-form QUOTE text) + (kmp-form LOOKUP name) + (kmp-form LAMBDA formals body) + (kmp-form LET bindings body) + (kmp-form DECLARE #!rest declarations) + (kmp-form CALL operator continuation #!rest operands) + (alternate-kmp-form + CALL #F #!rest cont-and-operands) + (kmp-form BEGIN #!rest exprs) ; really 1 or more + (kmp-form IF predicate consequent alternate) + (kmp-form LETREC bindings body) + + (kmp-form SET! name expr) + (kmp-form ACCESS name env-expr) + (kmp-form DEFINE name expr) + (kmp-form THE-ENVIRONMENT) + (kmp-form IN-PACKAGE env-expr expr) + ) + +(define-integrable if/alternative if/alternate) +(define-integrable (call/operand1 form) (first (call/operands form))) +(define-integrable (call/operand2 form) (second (call/operands form))) +(define-integrable (call/operand3 form) (third (call/operands form))) diff --git a/v8/src/compiler/midend/typedb.scm b/v8/src/compiler/midend/typedb.scm new file mode 100644 index 000000000..fb6283512 --- /dev/null +++ b/v8/src/compiler/midend/typedb.scm @@ -0,0 +1,175 @@ +#| -*-Scheme-*- + +$Id: typedb.scm,v 1.1 1995/09/04 21:02:52 adams Exp $ + +Copyright (c) 1995 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Types of known operators +;;; package: (compiler midend) + +(declare (usual-integrations)) + + +(define-operator-type 'STRING->SYMBOL + (procedure-type (list type:string) type:interned-symbol + 'effect-sensitive effect:string-set!)) + +(define-operator-type 'SYMBOL->STRING + (procedure-type (list type:symbol) type:string + 'effect effect:allocation)) + +(define-operator-type 'SUBSTRING? + (procedure-type (list type:string type:string) type:boolean + 'effect-sensitive effect:string-set!)) + +(define-operator-type 'ERROR + ;; return type empty => Never returns + (procedure-type (cons* type:any type:any) type:empty + 'function)) + +(define-operator-type 'ERROR:WRONG-TYPE-ARGUMENT + ;; return type empty => Never returns + (procedure-type (list type:any type:any) type:empty + 'function)) + +(define-operator-type 'EXACT->INEXACT + (procedure-type (list type:number) type:inexact-number 'function)) + +(define-operator-type 'INEXACT->EXACT + (procedure-type (list type:number) type:exact-number 'function)) + +(define-operator-type (make-primitive-procedure 'CAR) + (primitive-procedure-type (list type:pair) type:any + 'effect-free + 'effect-sensitive effect:set-car!)) + +(define-operator-type (make-primitive-procedure 'CDR) + (primitive-procedure-type (list type:pair) type:any + 'effect-free + 'effect-sensitive effect:set-cdr!)) + +(define-operator-type (make-primitive-procedure 'SET-CAR!) + (primitive-procedure-type (list type:pair type:any) type:unspecified + 'effect-insensitive + 'effect effect:set-car!)) + +(define-operator-type (make-primitive-procedure 'SET-CDR!) + (primitive-procedure-type (list type:pair type:any) type:unspecified + 'effect-insensitive + 'effect effect:set-cdr!)) + +(define-operator-type (make-primitive-procedure 'SYSTEM-VECTOR-SIZE) + (primitive-procedure-type (list type:any) type:vector-length + 'function)) + +(define-operator-type (make-primitive-procedure 'VECTOR-LENGTH) + (primitive-procedure-type (list type:vector) type:vector-length + 'function)) + +(define-operator-type (make-primitive-procedure '%RECORD-LENGTH) + (primitive-procedure-type (list type:%record) type:vector-length + 'function)) + +(define-operator-type (make-primitive-procedure 'STRING-LENGTH) + (primitive-procedure-type (list type:string) type:string-length + 'effect-free + 'effect effect:other)) ; set-string-length! + +(define-operator-type (make-primitive-procedure 'FLOATING-VECTOR-LENGTH) + (primitive-procedure-type (list type:flonum-vector) type:vector-length + 'function)) + +(define-operator-type (make-primitive-procedure 'BIT-STRING-LENGTH) + (primitive-procedure-type (list type:bit-string) type:string-length + 'function)) + + +(define-operator-type (make-primitive-procedure 'COERCE-TO-COMPILED-PROCEDURE) + (primitive-procedure-type (list type:any) type:compiled-procedure + 'function)) + + +(let () + + (define (define-indexed thing-ref thing-set! + vector-type index-type element-type effect) + (define-operator-type (make-primitive-procedure thing-ref) + (primitive-procedure-type (list vector-type index-type) element-type + 'effect-free + 'effect-sensitive effect)) + (define-operator-type (make-primitive-procedure thing-set!) + (primitive-procedure-type (list vector-type index-type element-type) + type:any + 'effect effect + 'effect-insensitive))) + + (define-indexed 'VECTOR-REF 'VECTOR-SET! + type:vector type:vector-length type:any effect:vector-set!) + (define-indexed 'STRING-REF 'STRING-SET! + type:string type:string-length type:character effect:string-set!) + (define-indexed 'VECTOR-8B-REF 'VECTOR-8B-SET! + type:string type:string-length type:unsigned-byte effect:string-set!) + (define-indexed '%RECORD-REF '%RECORD-SET! + type:%record type:vector-length type:any effect:%record-set!) + (define-indexed 'FLOATING-VECTOR-REF 'FLOATING-VECTOR-SET! + type:flonum-vector type:vector-length type:flonum effect:flo:vector-set!) + (define-indexed 'BIT-STRING-REF 'BIT-STRING-SET! + type:bit-string type:string-length type:boolean effect:bit-string-set!)) + + +(for-each + (lambda (op) + (define-operator-type op + (primitive-procedure-type + (make-list (primitive-procedure-arity op) type:flonum) type:flonum + 'function))) + (list flo:+ flo:- flo:* flo:/ + flo:negate flo:abs flo:sqrt + flo:floor flo:ceiling flo:truncate flo:round + flo:exp flo:log flo:sin flo:cos flo:tan flo:asin + flo:acos flo:atan flo:atan2 flo:expt)) + +(for-each + (lambda (op) + (define-operator-type op + (primitive-procedure-type + (make-list (primitive-procedure-arity op) type:fixnum) type:fixnum + 'function 'unchecked))) + (list fix:-1+ fix:1+ fix:+ fix:- fix:* + fix:quotient fix:remainder ; fix:gcd + fix:andc fix:and fix:or fix:xor fix:not fix:lsh)) + +(for-each + (lambda (name) + (define-operator-type (make-primitive-procedure name) + (primitive-procedure-type (list type:any) type:boolean 'function))) + '(BIT-STRING? CELL? FIXNUM? FLONUM? INDEX-FIXNUM? NOT NULL? + PAIR? STRING? INTEGER?))