You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
304 lines
9.0 KiB
Scheme
304 lines
9.0 KiB
Scheme
27 years ago
|
;; templates.ss
|
||
|
|
;; Handles the constructor environment,
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
||
|
|
;
|
||
|
|
; This program is free software; you can redistribute it and/or
|
||
|
|
; modify it under the terms of the GNU General Public License
|
||
|
|
; version 2 as published by the Free Software Foundation.
|
||
|
|
;
|
||
|
|
; This program is distributed in the hope that it will be useful,
|
||
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
; GNU General Public License for more details.
|
||
|
|
;
|
||
|
|
; You should have received a copy of the GNU General Public License
|
||
|
|
; along with this program; if not, write to the Free Software
|
||
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
;;
|
||
|
|
;; ======================================================================
|
||
|
|
;; Constructor environments: symbol -> template
|
||
|
|
;; First a helper function
|
||
|
|
|
||
|
|
(define (constructor->template con . modes)
|
||
|
|
(let* ( [n (length modes)]
|
||
|
|
[assign (make-vector n #f)]
|
||
|
|
[ref (make-vector n #f)])
|
||
|
|
(recur loop ([i 0][n 0][modes modes])
|
||
|
|
(match modes
|
||
|
|
[() (make-template con n i ref assign '() eqv?)]
|
||
|
|
[(#t . rest)
|
||
|
|
(vector-set! ref n n)
|
||
|
|
(vector-set! assign n i)
|
||
|
|
(loop (add1 i) (add1 n) rest)]
|
||
|
|
[(#f . rest)
|
||
|
|
(vector-set! ref n n)
|
||
|
|
(vector-set! assign n #f)
|
||
|
|
(loop i (add1 n) rest)]))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
;; The constructor environment
|
||
|
|
|
||
|
|
(define constructor-env (void))
|
||
|
|
|
||
|
|
(define (set-constructor-env! c)
|
||
|
|
(set! constructor-env (make-hash-table))
|
||
|
|
(hash-table-for-each c
|
||
|
|
(lambda (key val)
|
||
|
|
(hash-table-put! constructor-env key val))))
|
||
|
|
|
||
|
|
(define (extend-constructor-env! template)
|
||
|
|
(let* ( [type (template-type template)]
|
||
|
|
[old (hash-table-get constructor-env type (lambda () #f))])
|
||
|
|
(if old
|
||
|
|
(match (list template old)
|
||
|
|
[( ($ template _ n+1 n-1 ref1 assign1 super1 _)
|
||
|
|
($ template _ n+2 n-2 ref2 assign2 super2 _))
|
||
|
|
(unless (and (= n+1 n+2)
|
||
|
|
(= n-1 n-2)
|
||
|
|
(equal? assign1 assign2)
|
||
|
|
(equal? ref1 ref2)
|
||
|
|
(equal? super1 super2))
|
||
|
|
(pretty-print-debug
|
||
|
|
`( (,n+1 ,n-1 ,ref1 ,assign1 ,(map template-type super1))
|
||
|
|
(,n+2 ,n-2 ,ref2 ,assign2 ,(map template-type super2))))
|
||
|
|
(mrspidey:error
|
||
|
|
(format "New definition of template ~s does not match old"
|
||
|
|
type)))
|
||
|
|
old])
|
||
|
|
(begin
|
||
|
|
(hash-table-put! constructor-env type template)
|
||
|
|
template))))
|
||
|
|
|
||
|
|
(define (add-constructor! con . modes)
|
||
|
|
(extend-constructor-env! (apply constructor->template con modes)))
|
||
|
|
|
||
|
|
(define (constructor-alias! new-con old-con)
|
||
|
|
(hash-table-put! constructor-env new-con
|
||
|
|
(lookup-template-or-error old-con)))
|
||
|
|
|
||
|
|
(define (record-super-constructor! super-C C)
|
||
|
|
(record-super-constructor-of-template!
|
||
|
|
super-C (lookup-template-or-error C)))
|
||
|
|
|
||
|
|
(define (record-super-constructor-of-template! super-C T)
|
||
|
|
(record-super-template! (lookup-template-or-error super-C) T))
|
||
|
|
|
||
|
|
(define (record-super-template! super-T T)
|
||
|
|
(set-template-super-templates!
|
||
|
|
T
|
||
|
|
(cons super-T (template-super-templates T))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
;; Default templates
|
||
|
|
|
||
|
|
;(define-typed-structure (lam-info nargs restarg))
|
||
|
|
|
||
|
|
(define lam-misc-eq?
|
||
|
|
(match-lambda*
|
||
|
|
[(('lam-info nargs1 restarg1) ('lam-info nargs2 restarg2))
|
||
|
|
(and (= nargs1 nargs2) (eqv? restarg1 restarg2))
|
||
|
|
#t]
|
||
|
|
[(x y) (eq? x y)]))
|
||
|
|
|
||
|
|
(define template-lam
|
||
|
|
(make-template
|
||
|
|
'lambda
|
||
|
|
1
|
||
|
|
1
|
||
|
|
(vector #f 0)
|
||
|
|
(vector 0 #f)
|
||
|
|
'()
|
||
|
|
lam-misc-eq?))
|
||
|
|
|
||
|
|
(define filter-not-lam
|
||
|
|
(create-filter #f (list template-lam)))
|
||
|
|
|
||
|
|
(define template-lam++ ;; monotonic in both positions
|
||
|
|
(make-template
|
||
|
|
'lambda
|
||
|
|
2
|
||
|
|
0
|
||
|
|
(vector 0 1)
|
||
|
|
(vector)
|
||
|
|
'()
|
||
|
|
lam-misc-eq?))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define template-top-s (void))
|
||
|
|
(define template-cons (void))
|
||
|
|
(define template-nil (void))
|
||
|
|
(define template-num (void))
|
||
|
|
(define template-sym (void))
|
||
|
|
(define template-str (void))
|
||
|
|
(define template-char (void))
|
||
|
|
(define template-void (void))
|
||
|
|
(define template-undefined (void))
|
||
|
|
(define template-true (void))
|
||
|
|
(define template-false (void))
|
||
|
|
(define template-promise (void))
|
||
|
|
(define template-unit (void))
|
||
|
|
(define template-structure (void))
|
||
|
|
(define template-mvalues (void))
|
||
|
|
(define template-internal-class (void))
|
||
|
|
(define template-all-ivars (void))
|
||
|
|
(define template-dots (void))
|
||
|
|
(define template-ivarset (void))
|
||
|
|
|
||
|
|
(define (init-default-constructor-env!)
|
||
|
|
(pretty-debug ' (init-default-constructor-env!))
|
||
|
|
;; These are things needed by the analysis
|
||
|
|
(set! constructor-env (make-hash-table))
|
||
|
|
(hash-table-put! constructor-env 'lambda template-lam)
|
||
|
|
(set! template-top-s (add-constructor! 'top-s))
|
||
|
|
(set! template-cons
|
||
|
|
(if (st:cons-mutable)
|
||
|
|
(add-constructor! 'cons #t #t)
|
||
|
|
(add-constructor! 'cons #f #f)))
|
||
|
|
(set! template-nil (add-constructor! 'nil ))
|
||
|
|
(set! template-num (add-constructor! 'num ))
|
||
|
|
(set! template-sym (add-constructor! 'sym ))
|
||
|
|
(set! template-str (add-constructor! 'str ))
|
||
|
|
(set! template-char (add-constructor! 'char ))
|
||
|
|
(set! template-void (add-constructor! 'void ))
|
||
|
|
(set! template-undefined (add-constructor! 'undefined))
|
||
|
|
(set! template-true (add-constructor! 'true ))
|
||
|
|
(set! template-false (add-constructor! 'false))
|
||
|
|
(set! template-promise (add-constructor! 'promise #f))
|
||
|
|
(set! template-unit (add-constructor! 'unit-result* #f))
|
||
|
|
(set! template-structure (add-constructor! 'structure:))
|
||
|
|
(set! template-mvalues (add-constructor! 'mvalues #f))
|
||
|
|
(set! template-internal-class
|
||
|
|
(extend-constructor-env!
|
||
|
|
(make-template
|
||
|
|
'internal-class
|
||
|
|
4 4
|
||
|
|
(vector 0 1 2 #f #f 3 #f #f 4)
|
||
|
|
(vector #f #f #f 0 1 #f 2 3 #f)
|
||
|
|
'() eq?)))
|
||
|
|
(set! template-all-ivars
|
||
|
|
(extend-constructor-env!
|
||
|
|
(make-template
|
||
|
|
'all-ivars
|
||
|
|
1
|
||
|
|
0
|
||
|
|
(vector 0)
|
||
|
|
(vector #f)
|
||
|
|
'()
|
||
|
|
eq?)))
|
||
|
|
(set! template-dots (add-constructor! '...))
|
||
|
|
(set! template-ivarset (add-constructor! 'ivarset #t))
|
||
|
|
)
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
; The "template-prompt"
|
||
|
|
|
||
|
|
(define saved-constructor-env (make-hash-table))
|
||
|
|
|
||
|
|
(define (init-constructor-env!)
|
||
|
|
(set! constructor-env saved-constructor-env)
|
||
|
|
(set! unit-import-export-env (vector (make-hash-table) (make-hash-table)))
|
||
|
|
(set! object-ivar-template-env (make-hash-table))
|
||
|
|
)
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
; Unit templates
|
||
|
|
|
||
|
|
(define unit-import-export-env (vector (make-hash-table) (make-hash-table)))
|
||
|
|
|
||
|
|
(define (get-unit-import-export-template ndx sym thunk)
|
||
|
|
(hash-table-get
|
||
|
|
(vector-ref unit-import-export-env ndx)
|
||
|
|
sym
|
||
|
|
(lambda ()
|
||
|
|
(let ([template (thunk)])
|
||
|
|
(hash-table-put!
|
||
|
|
(vector-ref unit-import-export-env ndx)
|
||
|
|
sym template)
|
||
|
|
template))))
|
||
|
|
|
||
|
|
(define (get-unit-import-template sym)
|
||
|
|
(get-unit-import-export-template
|
||
|
|
0 sym
|
||
|
|
(lambda ()
|
||
|
|
(extend-constructor-env!
|
||
|
|
(make-template
|
||
|
|
(symbol-append 'unit-import- sym)
|
||
|
|
0
|
||
|
|
1
|
||
|
|
(vector #f)
|
||
|
|
(vector 0)
|
||
|
|
'()
|
||
|
|
eq?)))))
|
||
|
|
|
||
|
|
(define (get-unit-export-template sym)
|
||
|
|
(assert (symbol? sym) 'get-unit-export-template)
|
||
|
|
(get-unit-import-export-template
|
||
|
|
1 sym
|
||
|
|
(lambda ()
|
||
|
|
(extend-constructor-env!
|
||
|
|
(make-template
|
||
|
|
(symbol-append 'unit-export- sym)
|
||
|
|
1
|
||
|
|
0
|
||
|
|
(vector 0)
|
||
|
|
(vector #f)
|
||
|
|
'()
|
||
|
|
eq?)))))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
; Object templates
|
||
|
|
|
||
|
|
(define object-ivar-template-env (make-hash-table))
|
||
|
|
|
||
|
|
(define (get-ivar-template sym)
|
||
|
|
(assert (symbol? sym) 'get-ivar-template sym)
|
||
|
|
(hash-table-get
|
||
|
|
object-ivar-template-env
|
||
|
|
sym
|
||
|
|
(lambda ()
|
||
|
|
(let ([template (make-template
|
||
|
|
(symbol-append 'ivar- sym)
|
||
|
|
1
|
||
|
|
0
|
||
|
|
(vector 0)
|
||
|
|
(vector #f)
|
||
|
|
'()
|
||
|
|
eq?)])
|
||
|
|
(hash-table-put! object-ivar-template-env sym template)
|
||
|
|
(record-super-template! template-all-ivars template)
|
||
|
|
(extend-constructor-env! template)
|
||
|
|
template))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (type-constructor? C)
|
||
|
|
(if
|
||
|
|
(hash-table-get constructor-env C (lambda () #f))
|
||
|
|
#t #f))
|
||
|
|
|
||
|
|
(define (lookup-template C)
|
||
|
|
(hash-table-get constructor-env C (lambda () #f)))
|
||
|
|
|
||
|
|
(define (lookup-template-or-error C)
|
||
|
|
(or (lookup-template C)
|
||
|
|
(mrspidey:error (format "Unknown type constructor ~s" C))))
|
||
|
|
|
||
|
|
(define is-template?
|
||
|
|
(lambda (name)
|
||
|
|
(lambda (t)
|
||
|
|
(eq? t (lookup-template name)))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|