Commit ed5234d9 authored by Frode Vatvedt Fjeld's avatar Frode Vatvedt Fjeld

Re-worked several aspects of binding/environments: assignment,

type-inference, etc.
parent f5fb2761
;;;;------------------------------------------------------------------
;;;;
;;;; Copyright (C) 2001-2004,
;;;; Copyright (C) 2001-2005,
;;;; Department of Computer Science, University of Tromso, Norway.
;;;;
;;;; For distribution policy, see the accompanying file COPYING.
......@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Wed Oct 10 13:02:03 2001
;;;;
;;;; $Id: compiler-protocol.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $
;;;; $Id: compiler-protocol.lisp,v 1.3 2004/02/12 17:51:02 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -159,26 +159,29 @@ COMPILER-VALUES."
((&funobj funobj-var) (copy-symbol 'funobj) funobj-p)
((&env env-var) (copy-symbol 'env) env-p)
((&top-level-p top-level-p-var) (copy-symbol 'top-level-p) top-level-p-p)
((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p))
((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p)
((&extent extent-var) (copy-symbol 'extent) extent-p))
&body defun-body)
(multiple-value-bind (body docstring)
(if (and (cdr defun-body)
(stringp (car defun-body)))
(values (cdr defun-body) (list (car defun-body)))
(values defun-body nil))
`(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var)
`(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var ,extent-var)
,@docstring
(declare (,(if all-p 'ignorable 'ignore)
,@(unless form-p (list form-var))
,@(unless funobj-p (list funobj-var))
,@(unless env-p (list env-var))
,@(unless top-level-p-p (list top-level-p-var))
,@(unless result-mode-p (list result-mode-var))))
,@(unless result-mode-p (list result-mode-var))
,@(unless extent-p (list extent-var))))
(macrolet ((default-compiler-values-producer () '',name)
,@(when all-p
`((,all-var (v) (ecase v (:form ',form-var) (:funobj ',funobj-var)
(:env ',env-var) (:top-level-p ',top-level-p-var)
(:result-mode ',result-mode-var))))))
(:result-mode ',result-mode-var)
(:extent ',extent-var))))))
,@body))))
(defmacro compiler-call (compiler-name &rest all-keys
......@@ -186,6 +189,7 @@ COMPILER-VALUES."
((:form form-var) nil form-p)
((:funobj funobj-var) nil funobj-p)
((:env env-var) nil env-p)
((:extent extent-var) nil extent-p)
((:top-level-p top-level-p-var) nil top-level-p-p)
((:result-mode result-mode-var) :ignore result-mode-p))
(assert (not (and defaults forward)) ()
......@@ -208,7 +212,8 @@ COMPILER-VALUES."
,(if funobj-p funobj-var `(,defaults :funobj))
inner-env
,(when top-level-p-p top-level-p-var) ; default to nil, no forwarding.
,(if result-mode-p result-mode-var `(,defaults :result-mode)))))
,(if result-mode-p result-mode-var `(,defaults :result-mode))
,(if extent-p extent-var `(,defaults :extent)))))
(forward
`(let* ((outer-env ,(if env-p env-var `(,forward :env)))
(inner-env ,(if (not with-stack-used)
......@@ -222,15 +227,17 @@ COMPILER-VALUES."
,(if funobj-p funobj-var `(,forward :funobj))
inner-env
,(if top-level-p-p top-level-p-var `(,forward :top-level-p))
,(if result-mode-p result-mode-var `(,forward :result-mode)))))
,(if result-mode-p result-mode-var `(,forward :result-mode))
,(if extent-p extent-var `(,forward :extent)))))
((not with-stack-used)
`(funcall ,compiler-name ,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var))
`(funcall ,compiler-name ,form-var ,funobj-var ,env-var
,top-level-p-var ,result-mode-var ,extent-var))
(t (assert env-p () ":env is required when with-stack-used is given.")
`(funcall ,compiler-name ,form-var ,funobj-var
(make-instance 'with-things-on-stack-env
:uplink ,env-var :stack-used ,with-stack-used
:funobj (movitz-environment-funobj ,env-var))
,top-level-p-var ,result-mode-var))))
,top-level-p-var ,result-mode-var ,extent-var))))
(defmacro define-special-operator (name formals &body body)
(let* ((movitz-name (intern (symbol-name (translate-program name :cl :muerte.cl))
......
;;;;------------------------------------------------------------------
;;;;
;;;; Copyright (C) 2001, 2003-2004,
;;;; Copyright (C) 2001, 2003-2005,
;;;; Department of Computer Science, University of Tromso, Norway.
;;;;
;;;; For distribution policy, see the accompanying file COPYING.
......@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Wed Sep 10 00:40:07 2003
;;;;
;;;; $Id: compiler-types.lisp,v 1.21 2004/11/10 15:31:41 ffjeld Exp $
;;;; $Id: compiler-types.lisp,v 1.22 2005/01/03 11:52:33 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -153,7 +153,7 @@ with the single member of <type-specifier>."
(<= max (+ (car sub-range) epsilon))))
(d (and min (cdr sub-range) ; subtrahend starts above sub-range?
(<= (+ (cdr sub-range) epsilon) min))))
;; (warn "abcd: ~S ~S ~S ~S" a b c d)
#+ignore (warn "abcd: ~S ~S ~S ~S" a b c d)
(cond
((and a b)
;; sub-range is eclipsed by the subtrahend.
......@@ -173,8 +173,8 @@ with the single member of <type-specifier>."
(numscope-add-range new-numscope (+ max epsilon) (cdr sub-range) epsilon)))
((and (not d) b) ; (warn "right prune ~D with [~D-~D]" sub-range min max)
(setf new-numscope
(numscope-add-range new-numscope (car sub-range) min epsilon)))
(t (error "I am confused!")))))
(numscope-add-range new-numscope (car sub-range) (- min epsilon) epsilon)))
(t (break "I am confused!")))))
new-numscope))))
(defun numscope-complement (numscope &optional (epsilon 1))
......@@ -277,34 +277,35 @@ and any element of range1."
:initial-value (code first-type)))))
(defun encoded-type-decode (code integer-range members include complement)
(if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*)))))
(= mask (logand mask code)))
(not complement)
(let ((sub-specs include))
(loop for x in *tb-bitmap* as bit upfrom 0
do (when (logbitp bit code)
(push x sub-specs)))
(when (not (null members))
(push (cons 'member members) sub-specs))
(when (numscope-allp integer-range)
(pushnew 'integer sub-specs))
(when (and (not (member 'integer sub-specs))
integer-range)
(dolist (sub-range integer-range)
(push (list 'integer
(or (car sub-range) '*)
(or (cdr sub-range) '*))
sub-specs)))
(cond
((null sub-specs)
(if complement t nil))
((not (cdr sub-specs))
(if (not complement)
(car sub-specs)
(list 'not (car sub-specs))))
(t (if (not complement)
(cons 'or sub-specs)
(list 'not (cons 'or sub-specs))))))))
(cond
((let ((mask (1- (ash 1 (position :tail *tb-bitmap*)))))
(= mask (logand mask code)))
(not complement))
(t (let ((sub-specs include))
(loop for x in *tb-bitmap* as bit upfrom 0
do (when (logbitp bit code)
(push x sub-specs)))
(when (not (null members))
(push (cons 'member members) sub-specs))
(when (numscope-allp integer-range)
(pushnew 'integer sub-specs))
(when (and (not (member 'integer sub-specs))
integer-range)
(dolist (sub-range integer-range)
(push (list 'integer
(or (car sub-range) '*)
(or (cdr sub-range) '*))
sub-specs)))
(cond
((null sub-specs)
(if complement t nil))
((not (cdr sub-specs))
(if (not complement)
(car sub-specs)
(list 'not (car sub-specs))))
(t (if (not complement)
(cons 'or sub-specs)
(list 'not (cons 'or sub-specs)))))))))
(defun type-values (codes &key integer-range members include complement)
;; Members: A list of objects explicitly included in type.
......@@ -312,6 +313,8 @@ and any element of range1."
(check-type include list)
(check-type members list)
(check-type integer-range list)
(when (eq 'and (car include))
(break "foo"))
(let ((new-intscope integer-range)
(new-members ()))
(dolist (member members) ; move integer members into integer-range
......@@ -392,6 +395,19 @@ and any element of range1."
(not (encoded-typep t nil x code0 integer-range0 members0 include0 nil)))
members1)
nil nil))
((and (or integer-range0 integer-range1)
(encoded-emptyp code0 nil members0 nil complement0)
(encoded-emptyp code1 nil members1 nil complement1)
(flet ((integer-super-p (x)
(member x '(rational real number t))))
(and (every #'integer-super-p include0)
(every #'integer-super-p include1))))
(type-values () :integer-range (numscope-intersection integer-range0
integer-range1)))
((and (= code0 code1) (equal integer-range0 integer-range1)
(equal members0 members1) (equal include0 include1)
(eq complement0 complement1))
(values code0 integer-range0 members0 include0 complement0))
((and include0 (null include1))
;; (and (or a b c) d) => (or (and a d) (and b d) (and c d))
(values (logand code0 code1)
......@@ -413,19 +429,19 @@ and any element of range1."
include1)
nil))
(t ;; (warn "and with two includes: ~S ~S" include0 include1)
(type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0
include0 complement0)
,(encoded-type-decode code1 integer-range1 members1
include1 complement1))))))
(type-values () :include `((and ,(encoded-type-decode code0 integer-range0 members0
include0 complement0)
,(encoded-type-decode code1 integer-range1 members1
include1 complement1)))))))
((and complement0 complement1)
(multiple-value-bind (code integer-range members include complement)
(encoded-types-or code0 integer-range0 members0 include0 (not complement0)
code1 integer-range1 members1 include1 (not complement1))
(values code integer-range members include (not complement))))
(t (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0
include0 complement0)
,(encoded-type-decode code1 integer-range1 members1
include1 complement1))))))
(t (type-values () :include `((and ,(encoded-type-decode code0 integer-range0 members0
include0 complement0)
,(encoded-type-decode code1 integer-range1 members1
include1 complement1)))))))
(defun encoded-types-or (code0 integer-range0 members0 include0 complement0
code1 integer-range1 members1 include1 complement1)
......@@ -659,7 +675,8 @@ If it isn't, also return wether we _know_ it isn't."
(cond
((or complement include (not (= 0 code)))
nil)
((= 1 (length members))
((and (= 1 (length members))
(= 0 code) (null intscope) (null include) (not complement))
members)
((and (= 1 (length intscope))
(caar intscope)
......@@ -680,7 +697,7 @@ If it isn't, also return wether we _know_ it isn't."
"Return the integer type that can result from adding a member of type0 to a member of type1."
;; (declare (ignore members0 members1))
(cond
((or include0 include1 members0 members1)
((or include0 include1 members0 members1 (/= 0 code0) (/= 0 code1))
;; We can't know..
'number)
((or complement0 complement1)
......
This diff is collapsed.
......@@ -9,7 +9,7 @@
;;;; Created at: Fri Nov 3 11:40:15 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: environment.lisp,v 1.12 2005/01/04 11:35:25 ffjeld Exp $
;;;; $Id: environment.lisp,v 1.13 2005/08/14 12:13:07 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -225,7 +225,7 @@ the function sets up itself. Its parent env. must be a funobj-env."))
(find-function-env (movitz-environment-uplink env) funobj)))
(defun sub-env-p (sub-env env)
"Check if sub-env is a sub-environment of env."
"Check if sub-env is a sub-environment (or eq) of env."
(cond
((not sub-env)
nil)
......
......@@ -9,7 +9,7 @@
;;;; Created at: Sun Oct 22 00:22:43 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: image.lisp,v 1.100 2005/05/08 22:02:46 ffjeld Exp $
;;;; $Id: image.lisp,v 1.101 2005/05/21 22:38:39 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -957,60 +957,61 @@ a cons is an offset (the car) from some other code-vector (the cdr)."
(format t "~&;; Image file size: ~D octets.~%" image-end)
;; Write simple stage1 bootblock into sector 0..
(format t "~&;; Dump count: ~D." (incf (dump-count *image*)))
(set-file-position stream 0)
(flet ((global-slot-position (slot-name)
(+ 512
(image-nil-word *image*)
(image-ds-segment-base *image*)
(global-constant-offset slot-name)
(- load-address))))
(let ((bootblock (make-bootblock kernel-size
load-address
init-code-address)))
(setf (image-bootblock *image*) bootblock)
(write-sequence bootblock stream)
(let* ((stack-vector-address (+ (image-nil-word *image*)
(global-constant-offset 'stack-vector)
(image-ds-segment-base *image*)))
(stack-vector-position (- (+ stack-vector-address 512)
load-address)))
(declare (ignore stack-vector-position))
#+ignore(warn "stack-v-pos: ~S => ~S"
stack-vector-position
stack-vector-word)
(set-file-position stream (global-slot-position 'stack-vector) 'stack-vector)
(write-binary 'word stream stack-vector-word)
(set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom)
(write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion
(- stack-vector-word (tag :other))))
(set-file-position stream (global-slot-position 'stack-top) 'stack-top)
(write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other))
(* 4 (movitz-vector-num-elements stack-vector)))))
(if (not multiboot-p)
(format t "~&;; No multiboot header.")
;; Update multiboot header, symbolic and in the file..
(let* ((mb (image-multiboot-header *image*))
(mb-address (+ (movitz-intern mb)
(slot-offset 'multiboot-header 'magic)
(image-ds-segment-base *image*)))
(mb-file-position (- (+ mb-address 512)
load-address
(slot-offset 'multiboot-header 'magic))))
(when (< load-address #x100000)
(warn "Multiboot load-address #x~x is below the 1MB mark."
load-address))
(when (> (+ mb-file-position (sizeof mb)) 8192)
(warn "Multiboot header at position ~D is above the 8KB mark, ~
(with-simple-restart (continue "Don't write a floppy bootloader.")
(let ((bootblock (make-bootblock kernel-size
load-address
init-code-address)))
(setf (image-bootblock *image*) bootblock)
(set-file-position stream 0)
(write-sequence bootblock stream)))
(let* ((stack-vector-address (+ (image-nil-word *image*)
(global-constant-offset 'stack-vector)
(image-ds-segment-base *image*)))
(stack-vector-position (- (+ stack-vector-address 512)
load-address)))
(declare (ignore stack-vector-position))
#+ignore(warn "stack-v-pos: ~S => ~S"
stack-vector-position
stack-vector-word)
(set-file-position stream (global-slot-position 'stack-vector) 'stack-vector)
(write-binary 'word stream stack-vector-word)
(set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom)
(write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion
(- stack-vector-word (tag :other))))
(set-file-position stream (global-slot-position 'stack-top) 'stack-top)
(write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other))
(* 4 (movitz-vector-num-elements stack-vector)))))
(if (not multiboot-p)
(format t "~&;; No multiboot header.")
;; Update multiboot header, symbolic and in the file..
(let* ((mb (image-multiboot-header *image*))
(mb-address (+ (movitz-intern mb)
(slot-offset 'multiboot-header 'magic)
(image-ds-segment-base *image*)))
(mb-file-position (- (+ mb-address 512)
load-address
(slot-offset 'multiboot-header 'magic))))
(when (< load-address #x100000)
(warn "Multiboot load-address #x~x is below the 1MB mark."
load-address))
(when (> (+ mb-file-position (sizeof mb)) 8192)
(warn "Multiboot header at position ~D is above the 8KB mark, ~
this image will not be Multiboot compatible."
(+ mb-file-position (sizeof mb))))
(set-file-position stream mb-file-position 'multiboot-header)
;; (format t "~&;; Multiboot load-address: #x~X." load-address)
(setf (header-address mb) mb-address
(load-address mb) load-address
(load-end-address mb) (+ load-address kernel-size)
(bss-end-address mb) (+ load-address kernel-size)
(entry-address mb) init-code-address)
(write-binary-record mb stream)))))))))))
(+ mb-file-position (sizeof mb))))
(set-file-position stream mb-file-position 'multiboot-header)
;; (format t "~&;; Multiboot load-address: #x~X." load-address)
(setf (header-address mb) mb-address
(load-address mb) load-address
(load-end-address mb) (+ load-address kernel-size)
(bss-end-address mb) (+ load-address kernel-size)
(entry-address mb) init-code-address)
(write-binary-record mb stream))))))))))
(values))
(defun dump-image-core (image stream)
......
This diff is collapsed.
......@@ -8,7 +8,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Fri Nov 24 16:22:59 2000
;;;;
;;;; $Id: special-operators.lisp,v 1.51 2005/04/26 23:45:48 ffjeld Exp $
;;;; $Id: special-operators.lisp,v 1.52 2005/05/05 15:16:33 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -1015,6 +1015,7 @@ on the current result."
((:lexical-binding) result-mode))))
(compiler-values ()
:returns returns
:type 'number
:code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns)))))))
(define-special-operator muerte::include (&form form)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment