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.
128 lines
4.4 KiB
Scheme
128 lines
4.4 KiB
Scheme
27 years ago
|
;; program.ss
|
||
|
|
;; Handles cormac's program first-order structure for units
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; 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.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
;; Global environment stuff
|
||
|
|
|
||
|
|
(define global-def-env '())
|
||
|
|
(define global-result (void))
|
||
|
|
(define global-defs-parsed (void))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (analyze-program file)
|
||
|
|
;; file should be normalized
|
||
|
|
(let ([file (normalize-path file)])
|
||
|
|
(pretty-debug `(analyze-program ,file , (path-only (normalize-path file))))
|
||
|
|
(init-constructor-env!)
|
||
|
|
(initialize-language!)
|
||
|
|
(init-expand!)
|
||
|
|
(clear-file-time-cache!)
|
||
|
|
(let*-vals
|
||
|
|
( [sexps (zodiac:read* (open-code-file file) file)]
|
||
|
|
[_ (when debugging-front
|
||
|
|
(printf "~n--Loaded program------------------~n")
|
||
|
|
(for-each
|
||
|
|
(lambda (sexp) (pretty-print-debug (zodiac:stripper sexp)))
|
||
|
|
sexps)
|
||
|
|
(printf "----------------------------------~n"))]
|
||
|
|
[(defs free-names)
|
||
|
|
(parameterize ([current-load-relative-directory (path-only file)])
|
||
|
|
(my-scheme-expand-program sexps))]
|
||
|
|
[_ (set! global-defs-parsed defs)]
|
||
|
|
[_ (when debugging-front
|
||
|
|
(printf "~n--Parsed program------------------~n")
|
||
|
|
(for-each
|
||
|
|
(lambda (def) (pretty-print-debug (zodiac:stripper def)))
|
||
|
|
defs)
|
||
|
|
(printf "----------------------------------~n"))]
|
||
|
|
[init-env (get-default-bindings free-names)])
|
||
|
|
|
||
|
|
(pretty-debug `(init-env ,(atenv->pretty init-env)))
|
||
|
|
;; Now do analyis
|
||
|
|
|
||
|
|
(let-values ([(env refs result) (top-level-traverse-defs defs init-env)])
|
||
|
|
|
||
|
|
(pretty-debug '(fixing up envs))
|
||
|
|
(set! global-def-env env)
|
||
|
|
(set! global-result result)
|
||
|
|
;;(assert (null? refs) refs (map zodiac:binding-var (map car refs)))
|
||
|
|
'(for-each
|
||
|
|
(lambda (ref)
|
||
|
|
(mrspidey:warning
|
||
|
|
(format "Unbound variable ~s" (zodiac:binding-var (car ref)))))
|
||
|
|
refs)
|
||
|
|
|
||
|
|
;; --- Fix up type variables
|
||
|
|
;;(set! global-def-env (append global-def-env global-tdef-env))
|
||
|
|
(report-duplicate-defs global-tdef-env)
|
||
|
|
(report-unbound-vars
|
||
|
|
(connect-refs-defs global-tref-env global-tdef-env))
|
||
|
|
(connect-bangs-defs global-tbang-env global-tdef-env)
|
||
|
|
|
||
|
|
(when (not (st:whole-program))
|
||
|
|
(put-context-top-s defs env result))
|
||
|
|
|
||
|
|
;;(show-stat-small)
|
||
|
|
|
||
|
|
defs))))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (put-context-top-s defs env result)
|
||
|
|
(mrspidey:progress "Partial program analysis")
|
||
|
|
;;(show-stat-small)
|
||
|
|
(when result (new-leq-top-s! (FlowType->Tvar result)))
|
||
|
|
(when (and defs env)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:define-values-form _ _ _ _ refs)
|
||
|
|
(for-each
|
||
|
|
(lambda (ref)
|
||
|
|
(new-leq-top-s!
|
||
|
|
(FlowType->Tvar
|
||
|
|
(atenv:lookup env (zodiac:varref-binding ref)))))
|
||
|
|
refs)]
|
||
|
|
[_ (void)])
|
||
|
|
defs)))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
;; initialize-analysis!
|
||
|
|
|
||
|
|
(define (initialize-analysis!)
|
||
|
|
(pretty-debug '(initialize-analysis!))
|
||
|
|
(init-constructor-env!)
|
||
|
|
(let ([old-kernel (save-kernel-state)])
|
||
|
|
(init-kernel!)
|
||
|
|
;; First free old stuff
|
||
|
|
(when (st:zero-old-constraint-sets) (free-kernel-state! old-kernel)))
|
||
|
|
(init-global-tenv! '() '() '())
|
||
|
|
(init-common-AV!)
|
||
|
|
(pretty-debug '(analysis-initialized)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (show-global)
|
||
|
|
(list 'DEF (atenv->pretty global-def-env)
|
||
|
|
;;'TDEF (atenv->pretty global-tdef-env)
|
||
|
|
))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
|
||
|
|
|